passepartout/lisp/programming-lisp.lisp

(defun lisp-structural-check (code)
  "Checks if parentheses are balanced and the code is readable."
  (handler-case
      (let ((*read-eval* nil))
        (with-input-from-string (s code)
          (loop for form = (read s nil :eof) until (eq form :eof)))
        (values t nil))
    (error (c)
      (values nil (format nil "Reader Error: ~a" c)))))

(defun lisp-syntactic-check (code)
  "Checks for valid Lisp syntax beyond just balanced parentheses."
  (lisp-structural-check code))

(defun lisp-semantic-check (code)
  "Checks for potentially unsafe forms."
  (let ((unsafe-tokens '("eval" "load" "uiop:run-program" "sb-ext:run-program" "cl-user::eval")))
    (loop for token in unsafe-tokens
          when (search token (string-downcase code))
          do (return-from lisp-semantic-check (values nil (format nil "Unsafe form detected: ~a" token))))
    (values t nil)))

(defun lisp-validate (code &key (strict t))
  "Unified validation gate for Lisp code."
  (multiple-value-bind (struct-ok struct-err) (lisp-structural-check code)
    (unless struct-ok
      (return-from lisp-validate (list :status :error :reason struct-err)))
    (when strict
      (multiple-value-bind (sem-ok sem-err) (lisp-semantic-check code)
        (unless sem-ok
          (return-from lisp-validate (list :status :error :reason sem-err)))))
    (list :status :success)))

(defun lisp-eval (code-string &key (package :passepartout))
  "Evaluates a Lisp string and captures its output/results."
  (let ((out (make-string-output-stream))
        (err (make-string-output-stream)))
    (handler-case
        (let* ((*standard-output* out)
               (*error-output* err)
               (*package* (or (find-package package) (find-package :passepartout)))
               (result (with-input-from-string (s code-string)
                         (let ((last-val nil))
                           (loop for form = (read s nil :eof) until (eq form :eof)
                                 do (setf last-val (eval form)))
                           last-val))))
          (list :status :success
                :result (format nil "~a" result)
                :output (get-output-stream-string out)
                :error (get-output-stream-string err)))
      (error (c)
        (list :status :error
              :reason (format nil "~a" c)
              :output (get-output-stream-string out)
              :error (get-output-stream-string err))))))

(defun lisp-format (code-string)
  "Attempts to format Lisp code using Emacs batch mode if available."
  (handler-case
      (let ((tmp-file "/tmp/oc-format-temp.lisp"))
        (uiop:with-output-file (s tmp-file :if-exists :supersede)
          (format s "~a" code-string))
        (multiple-value-bind (out err code)
            (uiop:run-program (list "emacs" "--batch" tmp-file 
                                   "--eval" "(indent-region (point-min) (point-max))"
                                   "--eval" "(princ (buffer-string))")
                             :output :string :error-output :string :ignore-error-status t)
          (if (= code 0)
              out
              (progn
                (harness-log "FORMAT ERROR: ~a" err)
                code-string))))
    (error (c)
      (harness-log "FORMAT EXCEPTION: ~a" c)
      code-string)))

(defun lisp-extract (code function-name)
  "Extracts the definition of a specific function from a code string."
  (let ((*read-eval* nil))
    (with-input-from-string (s code)
      (loop for form = (read s nil :eof) until (eq form :eof)
            when (and (listp form) 
                      (symbolp (car form))
                      (member (symbol-name (car form)) '("DEFUN" "DEFMACRO" "DEFMETHOD") :test #'string-equal)
                      (symbolp (second form))
                      (string-equal (symbol-name (second form)) function-name))
            do (return-from lisp-extract (format nil "~s" form))))
    nil))

(defun lisp-wrap (code target-name wrapper-symbol)
  "Wraps a specific form in a wrapper form (e.g., wrap in a let)."
  (let ((*read-eval* nil) (results nil))
    (with-input-from-string (s code)
      (loop for form = (read s nil :eof) until (eq form :eof)
            do (if (and (listp form) 
                        (symbolp (second form))
                        (string-equal (symbol-name (second form)) target-name))
                   (push (list wrapper-symbol form) results)
                   (push form results))))
    (format nil "~{~s~^~%~%~}" (nreverse results))))

(defun lisp-list-definitions (code)
  "Returns a list of names for all top-level definitions (defun, defmacro, etc.)."
  (let ((*read-eval* nil) (names nil))
    (with-input-from-string (s code)
      (loop for form = (read s nil :eof) until (eq form :eof)
            when (and (listp form) 
                      (symbolp (car form))
                      (member (symbol-name (car form)) 
                              '("DEFUN" "DEFMACRO" "DEFMETHOD" "DEFVAR" "DEFPARAMETER")
                              :test #'string-equal)
                      (symbolp (second form)))
            do (push (second form) names)))
    (nreverse names)))

(defun lisp-inject (code target-name new-form-string)
  "Injects a new form into the body of a targeted definition."
  (let ((*read-eval* nil)
        (new-form (read-from-string new-form-string))
        (results nil))
    (with-input-from-string (s code)
      (loop for form = (read s nil :eof) until (eq form :eof)
            do (if (and (listp form) 
                        (symbolp (car form))
                        (member (symbol-name (car form)) '("DEFUN" "DEFMACRO" "DEFMETHOD") :test #'string-equal)
                        (symbolp (second form))
                        (string-equal (symbol-name (second form)) target-name))
                   (push (append form (list new-form)) results)
                   (push form results))))
    (format nil "~{~s~^~%~%~}" (nreverse results))))

(defun lisp-slurp (code target-name form-to-slurp-string)
  "Adds a form to the end of a named list or definition (Paredit slurp)."
  (let ((*read-eval* nil)
        (to-slurp (read-from-string form-to-slurp-string))
        (results nil))
    (with-input-from-string (s code)
      (loop for form = (read s nil :eof) until (eq form :eof)
            do (if (and (listp form) 
                        (symbolp (second form))
                        (string-equal (symbol-name (second form)) target-name))
                   (push (append form (list to-slurp)) results)
                   (push form results))))
    (format nil "~{~s~^~%~%~}" (nreverse results))))

(defskill :passepartout-programming-lisp
  :priority 400
  :trigger (lambda (ctx) (declare (ignore ctx)) nil))

(defpackage :passepartout-utils-lisp-tests
  (:use :cl :fiveam :passepartout)
  (:export #:utils-lisp-suite))

(in-package :passepartout-utils-lisp-tests)

(def-suite utils-lisp-suite
  :description "Tests for the Lisp Validator structural, syntactic, and semantic gates")

(in-suite utils-lisp-suite)

(test structural-balanced
  (is (eq t (passepartout:lisp-structural-check "(+ 1 2)"))))

(test structural-unbalanced-open
  (multiple-value-bind (ok reason) (passepartout:lisp-structural-check "(+ 1 2")
    (is (null ok))
    (is (search "Reader Error" reason))))

(test structural-unbalanced-close
  (multiple-value-bind (ok reason) (passepartout:lisp-structural-check "+ 1 2)")
    (is (null ok))
    (is (search "Reader Error" reason))))

(test syntactic-valid
  (is (eq t (passepartout:lisp-syntactic-check "(+ 1 2)"))))

(test semantic-safe
  (is (eq t (passepartout:lisp-semantic-check "(+ 1 2)"))))

(test semantic-blocked-eval
  (multiple-value-bind (ok reason) (passepartout:lisp-semantic-check "(eval '(+ 1 2))")
    (is (null ok))
    (is (search "Unsafe" reason))))

(test unified-success
  (let ((result (passepartout:lisp-validate "(+ 1 2)" :strict t)))
    (is (eq (getf result :status) :success))))

(test unified-failure
  (let ((result (passepartout:lisp-validate "(+ 1 2" :strict nil)))
    (is (eq (getf result :status) :error))))

(test eval-basic
  (let ((result (passepartout:lisp-eval "(+ 1 2)")))
    (is (eq (getf result :status) :success))
    (is (string= (getf result :result) "3"))))

(test structural-extract
  (let* ((code "(defun hello () (print \"hi\")) (defun bye () (print \"bye\"))")
         (extracted (passepartout:lisp-extract code "hello")))
    (is (not (null extracted)))
    (let ((form (read-from-string extracted)))
      (is (eq (car form) 'DEFUN))
      (is (eq (second form) 'HELLO)))))

(test list-definitions
  (let ((code "(defun foo () t) (defmacro bar () nil) (defparameter *baz* 10)"))
    (let ((names (passepartout:lisp-list-definitions code)))
      (is (member 'FOO names))
      (is (member 'BAR names))
      (is (member '*BAZ* names)))))

(test structural-inject
  (let* ((code "(defun my-fun (x) (print x))")
         (injected (passepartout:lisp-inject code "my-fun" "(finish-output)")))
    (let ((form (read-from-string injected)))
      (is (equal (last form) '((FINISH-OUTPUT)))))))

(test structural-slurp
  (let* ((code "(defun work () (step-1))")
         (slurped (passepartout:lisp-slurp code "work" "(step-2)")))
    (let ((form (read-from-string slurped)))
      (is (equal (last form) '((STEP-2)))))))