--- 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"
--- 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))
--- 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.',
--- 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))))))
--- 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)))))
+
--- 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))))
--- 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)))))
+
--- 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]