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
                (log-message "FORMAT ERROR: ~a" err)
                code-string))))
    (error (c)
      (log-message "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))