# HG changeset patch # User Steve Losh # Date 1449156332 0 # Node ID c24e85a0b4c0d01988cd2b5e1931d968c74049cc # Parent 7753eedff7fef062a7a6cf2ff72602b68f49ab07 Refactor a bunch of stuff. diff -r 7753eedff7fe -r c24e85a0b4c0 nrepl.asd --- a/nrepl.asd Tue Dec 01 15:31:00 2015 +0000 +++ b/nrepl.asd Thu Dec 03 15:25:32 2015 +0000 @@ -13,7 +13,6 @@ #:fset #:cl-ppcre #+sbcl :sb-introspect) - :serial t :components ((:file "package") (:module "src" diff -r 7753eedff7fe -r c24e85a0b4c0 package.lisp --- a/package.lisp Tue Dec 01 15:31:00 2015 +0000 +++ b/package.lisp Thu Dec 03 15:25:32 2015 +0000 @@ -2,7 +2,8 @@ (defpackage #:nrepl (:use #:cl) - (:import-from :ppcre :regex-replace) + (:import-from :ppcre + :regex-replace) (:export #:start-server #:stop-server)) diff -r 7753eedff7fe -r c24e85a0b4c0 src/middleware/describe.lisp --- a/src/middleware/describe.lisp Tue Dec 01 15:31:00 2015 +0000 +++ b/src/middleware/describe.lisp Thu Dec 03 15:25:32 2015 +0000 @@ -6,18 +6,14 @@ "incremental" incremental "version-string" (format nil "~d.~d.~d" major minor incremental))) -(defun wrap-describe (h) - (lambda (message) - (handle-op - message "describe" h - (respond message - (make-map "status" '("done") - "versions" (make-map - "lisp" (make-version-map 0 0 0) - "cl-nrepl" (make-version-map 0 0 0) - ; we're not nrepl but fireplace wants this - "nrepl" (make-version-map 0 2 0)) - "ops" (make-map)))))) +(defmiddleware wrap-describe "describe" message + (respond message + (make-map "status" '("done") + "versions" (make-map + "lisp" (make-version-map 0 0 0) + "cl-nrepl" (make-version-map 0 0 0)) + "ops" (make-map)))) + ; {'aux': {'current-ns': 'user'}, ; 'ops': {'clone': {'doc': 'Clones the current session, returning the ID of the newly-created session.', diff -r 7753eedff7fe -r c24e85a0b4c0 src/middleware/documentation.lisp --- a/src/middleware/documentation.lisp Tue Dec 01 15:31:00 2015 +0000 +++ b/src/middleware/documentation.lisp Thu Dec 03 15:25:32 2015 +0000 @@ -16,19 +16,16 @@ (find-package pack) *package*))))) -(defun wrap-documentation (h) - (lambda (message) - (handle-op - message "documentation" h - (let* ((s (find-symbol-harder (fset:lookup message "symbol")))) - (respond message - (with-when - (make-map "status" '("done")) - "type-docstring" (documentation s 'type) - "structure-docstring" (documentation s 'structure) - "variable-docstring" (documentation s 'variable) - "setf-docstring" (documentation s 'setf) - "function-docstring" (documentation s 'function) - "function-arglist" (when-let ((arglist (find-lambda-list s))) - (prin1-to-string arglist)))))))) +(defmiddleware wrap-documentation "documentation" message + (let* ((s (find-symbol-harder (fset:lookup message "symbol")))) + (respond message + (with-when + (make-map "status" '("done")) + "type-docstring" (documentation s 'type) + "structure-docstring" (documentation s 'structure) + "variable-docstring" (documentation s 'variable) + "setf-docstring" (documentation s 'setf) + "function-docstring" (documentation s 'function) + "function-arglist" (when-let ((arglist (find-lambda-list s))) + (prin1-to-string arglist)))))) diff -r 7753eedff7fe -r c24e85a0b4c0 src/middleware/eval.lisp --- a/src/middleware/eval.lisp Tue Dec 01 15:31:00 2015 +0000 +++ b/src/middleware/eval.lisp Thu Dec 03 15:25:32 2015 +0000 @@ -1,12 +1,15 @@ (in-package #:nrepl) -;;; Eval +(define-condition evaluation-error (error) + ((text :initarg :text :reader text) + (orig :initarg :orig :reader orig) + (data :initarg :data :reader data :initform ()))) + (defclass evaluator () ((standard-input :initarg :in :reader in) (standard-output :initarg :out :reader out) (standard-error :initarg :err :reader err))) - (defun shuttle-stream (from-stream stream-name message) (do ((data "" (flex:octets-to-string (flex:get-output-stream-sequence from-stream) @@ -19,31 +22,59 @@ stream-name data))) (sleep 0.1))) -(defun wrap-eval (h) - (lambda (message) - (handle-op - message "eval" h - (let* ((code (fset:lookup message "code")) - (captured-out (flex:make-in-memory-output-stream)) - (captured-err (flex:make-in-memory-output-stream)) - (*standard-output* - (flex:make-flexi-stream captured-out :external-format :utf-8)) - (*error-output* - (flex:make-flexi-stream captured-err :external-format :utf-8))) - (unwind-protect - (progn - (bt:make-thread - (lambda () (shuttle-stream captured-out "stdout" message)) - :name "NREPL stdout writer") - (bt:make-thread - (lambda () (shuttle-stream captured-err "stderr" message)) - :name "NREPL stderr writer") - (loop for form in (read-all-from-string code) - do (let ((result (prin1-to-string (eval form)))) - (respond message - (make-map "form" (prin1-to-string form) - "value" result)))) - (respond message (make-map "status" '("done")))) - (close captured-out) - (close captured-err)))))) +(defun get-forms (code) + "Get all lisp forms from the given hunk of code. + + Signal an evaluation-error if the input is mangled. + + " + (handler-case + (read-all-from-string code) + (error (e) + (error 'evaluation-error + :text "Malformed input!" + :orig e)))) +(defmiddleware wrap-eval "eval" message + (let* ((code (fset:lookup message "code")) + (captured-out (flex:make-in-memory-output-stream)) + (captured-err (flex:make-in-memory-output-stream)) + (*standard-output* + (flex:make-flexi-stream captured-out :external-format :utf-8)) + (*error-output* + (flex:make-flexi-stream captured-err :external-format :utf-8))) + (flet ((eval-form (form) + (handler-case + (let ((result (prin1-to-string (eval form)))) + (respond message + (make-map "form" (prin1-to-string form) + "value" result))) + (error (e) + (error 'evaluation-error + :text "Traceback during evaluation!" + :orig e + :data (list + "form" (prin1-to-string form)))))) + (error-respond (e) + (respond message + (apply #'make-map + "status" '("error") + "error" (text e) + "original" (format nil "~A" (orig e)) + (data e)))) + (make-shuttle-thread (stream desc) + (bt:make-thread + (lambda () (shuttle-stream stream desc message)) + :name (format nil "NREPL ~A writer" desc)))) + (unwind-protect + (progn + (make-shuttle-thread captured-out "stdout") + (make-shuttle-thread captured-err "stderr") + (handler-case + (progn + (loop for form in (get-forms code) do (eval-form form)) + (respond message (make-map "status" '("done")))) + (evaluation-error (e) (error-respond e)))) + (close captured-out) + (close captured-err))))) + diff -r 7753eedff7fe -r c24e85a0b4c0 src/middleware/session.lisp --- a/src/middleware/session.lisp Tue Dec 01 15:31:00 2015 +0000 +++ b/src/middleware/session.lisp Thu Dec 03 15:25:32 2015 +0000 @@ -44,26 +44,17 @@ (*session* session)) (funcall h (fset:with message "session" session-id))))) -(defun wrap-session-ls (h) - (lambda (message) - (handle-op - message "ls-sessions" h - (respond message - (make-map "status" '("done") - "sessions" (get-sessions)))))) +(defmiddleware wrap-session-ls "ls-sessions" message + (respond message + (make-map "status" '("done") + "sessions" (get-sessions)))) -(defun wrap-session-close (h) - (lambda (message) - (handle-op - message "close" h - (remove-session! (fset:lookup message "session")) - (respond message (make-map "status" '("session-closed")))))) +(defmiddleware wrap-session-close "close" message + (remove-session! (fset:lookup message "session")) + (respond message (make-map "status" '("session-closed")))) -(defun wrap-session-clone (h) - (lambda (message) - (handle-op - message "clone" h - (let ((new-id (register-session! (random-uuid) - (fset:lookup message "session")))) - (respond message (make-map "status" '("done") "new-session" new-id)))))) +(defmiddleware wrap-session-clone "clone" message + (let ((new-id (register-session! (random-uuid) + (fset:lookup message "session")))) + (respond message (make-map "status" '("done") "new-session" new-id)))) diff -r 7753eedff7fe -r c24e85a0b4c0 src/utils.lisp --- a/src/utils.lisp Tue Dec 01 15:31:00 2015 +0000 +++ b/src/utils.lisp Thu Dec 03 15:25:32 2015 +0000 @@ -102,3 +102,10 @@ (progn ,@body) (funcall ,fallback ,message))) +(defmacro defmiddleware (name op message-binding &rest body) + (let ((fallback (gensym))) + `(defun ,name (,fallback) + (lambda (,message-binding) + (handle-op ,message-binding ,op ,fallback + ,@body))))) + diff -r 7753eedff7fe -r c24e85a0b4c0 src/workarounds.lisp --- a/src/workarounds.lisp Tue Dec 01 15:31:00 2015 +0000 +++ b/src/workarounds.lisp Thu Dec 03 15:25:32 2015 +0000 @@ -17,59 +17,52 @@ (respond ,message (make-map "status" '("done")))) (funcall ,fallback ,message))) +(defmacro defworkaround (name op message-binding &rest body) + (let ((fallback (gensym))) + `(defun ,name (,fallback) + (lambda (,message-binding) + (handle-workaround + ,message-binding ,fallback ,op + ,@body))))) -(defun workaround-fireplace-classpath (h) - (lambda (message) - (handle-workaround - message h "eval" - (workaround-matches - '("(do (println \"success\") " - "(symbol (str (System/getProperty \"path.separator\") " - "(System/getProperty \"java.class.path\"))))")) - (respond message (make-map "value" ":"))))) -(defun workaround-fireplace-pathsep (h) - (lambda (message) - (handle-workaround - message h "eval" - (workaround-matches - '("[(System/getProperty \"path.separator\") " - "(System/getProperty \"java.class.path\")]")) - (respond message (make-map "value" "[\"/\" \":\"]"))))) +(defworkaround workaround-fireplace-classpath "eval" message + (workaround-matches + '("(do (println \"success\") " + "(symbol (str (System/getProperty \"path.separator\") " + "(System/getProperty \"java.class.path\"))))")) + (respond message (make-map "value" ":"))) + +(defworkaround workaround-fireplace-pathsep "eval" message + (workaround-matches + '("[(System/getProperty \"path.separator\") " + "(System/getProperty \"java.class.path\")]")) + (respond message (make-map "value" "[\"/\" \":\"]"))) -(defun workaround-fireplace-star (h) - (lambda (message) - (handle-workaround - message h "eval" - ((lambda (code) - (member code '("(*1 1)" "(*2 2)" "(*3 3)") :test #'equal))) - (respond message (make-map "value" "Not yet implemented, sorry :("))))) +(defworkaround workaround-fireplace-star "eval" message + ((lambda (code) + (member code '("(*1 1)" "(*2 2)" "(*3 3)") :test #'equal))) + (respond message (make-map "value" "Not yet implemented, sorry :("))) -(defun workaround-fireplace-fakepathsep (h) +(defworkaround workaround-fireplace-fakepathsep "eval" message ; lol what in the fuck even is this for? - (lambda (message) - (handle-workaround - message h "eval" - (workaround-matches - '("[(System/getProperty \"path.separator\") " - "(System/getProperty \"fake.class.path\")]")) - (respond message (make-map "value" "[\"/\" \"None\"]"))))) + (workaround-matches + '("[(System/getProperty \"path.separator\") " + "(System/getProperty \"fake.class.path\")]")) + (respond message (make-map "value" "[\"/\" \"None\"]"))) -(defun workaround-fireplace-macroexpand-all (h) +(defworkaround workaround-fireplace-macroexpand-all "eval" message ; this should really do a macroexpand-all but this'll have to do for now - (lambda (message) - (handle-workaround - message h "eval" - (starts-with "(clojure.walk/macroexpand-all (quote") - ; TODO: Fix the extra done status message here - (funcall h (with-map message "code" - (lambda (s) - (ppcre:regex-replace - "clojure.walk/macroexpand-all" - s - "macroexpand"))))))) + (starts-with "(clojure.walk/macroexpand-all (quote") + ; TODO: Fix the extra done status message here + (funcall h (with-map message "code" + (lambda (s) + (ppcre:regex-replace + "clojure.walk/macroexpand-all" + s + "macroexpand"))))) -; (def-workaround (+ "[(symbol (str \"\\n\\b\" (apply str (interleave " +; TODO: (def-workaround (+ "[(symbol (str \"\\n\\b\" (apply str (interleave " ; "(repeat \"\\n\") (map str (.getStackTrace *e)))) " ; "\"\\n\\b\\n\")) *3 *2 *1]") ; [session msg]