# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1471784295 0
# Node ID e342c4a78a57d7a3538ab4d091c6ffdacceba485
# Parent  f36b8fd3e9dd3b0e553fb7de1cdea77ee3cf025c
More refactoring and cleanup

diff -r f36b8fd3e9dd -r e342c4a78a57 .hgignore
--- a/.hgignore	Sun Aug 21 12:21:26 2016 +0000
+++ b/.hgignore	Sun Aug 21 12:58:15 2016 +0000
@@ -5,4 +5,4 @@
 *.swo
 *.un~
 tags
-src/scratch.lisp
+scratch.lisp
diff -r f36b8fd3e9dd -r e342c4a78a57 nrepl.asd
--- a/nrepl.asd	Sun Aug 21 12:21:26 2016 +0000
+++ b/nrepl.asd	Sun Aug 21 12:58:15 2016 +0000
@@ -24,6 +24,7 @@
    (:module "src"
     :components ((:file "utils")
                  (:file "sockets")
+                 (:file "evaluation")
                  (:module "middleware"
                   :components ((:file "core")
                                (:file "describe")
diff -r f36b8fd3e9dd -r e342c4a78a57 src/evaluation.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/evaluation.lisp	Sun Aug 21 12:58:15 2016 +0000
@@ -0,0 +1,135 @@
+(in-package #:nrepl)
+
+(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 read-data (stream)
+  (flex:octets-to-string
+    (flex:get-output-stream-sequence stream)
+    :external-format :utf-8))
+
+(defun shuttle-stream (stream stream-name message)
+  "Read data from `stream` and shuttle it back to the client.
+
+  Chunks of data will be read from `stream` until it's finished and closed.
+
+  For each hunk of data read, a response will be sent back to the client using
+  the transport defined in `message`, looking something like:
+
+    {\"status\" \"ok\"
+     \"stdout\" \"...data...\"}
+
+  `stream-name` should be the name of the stream being shuttled, like
+  \"stderr\", and will be used as the key in the response.
+
+  "
+  (loop
+    :for data = (read-data stream)
+    :until (and (not (open-stream-p stream))
+                (equal data ""))
+    :do (progn
+          (when (not (string= data ""))
+            (respond message (make-map "status" '("ok")
+                                       stream-name data)))
+          (sleep 0.1))))
+
+
+(defun get-forms (code)
+  "Get all lisp forms from `code`.
+
+  If `code` is a string, the forms will be read out of it, and an
+  `evaluation-error` signaled if the input is mangled.
+
+  If `code` is anything else it will just be returned as-is.
+
+  "
+  (if (stringp code)
+    (handler-case
+        (read-all-from-string code)
+      (error (e)
+             (error 'evaluation-error
+                    :text "Malformed input!"
+                    :orig e)))
+    code))
+
+(defun clean-backtrace (backtrace)
+  (format nil "~{~A~^~%~}"
+          (loop :for line :in (split-sequence:split-sequence #\newline backtrace)
+                :until (ppcre:scan "NREPL::NREPL-EVALUATE-FORM" line)
+                :collect line)))
+
+(defun nrepl-evaluate-form (form)
+  (declare (optimize (debug 3)))
+  ;im so sorry you have to see this
+  (prin1-to-string
+    (handler-bind
+      ((error
+         (lambda (err)
+           ; if we hit an error, print the backtrace to the stream before
+           ; reraising.  if we wait til later to print it, it'll be too late.
+           (error 'evaluation-error
+                  :text "Error during evaluation!"
+                  :orig err
+                  :data (list
+                          "form" (prin1-to-string form)
+                          "backtrace" (clean-backtrace
+                                        #+sbcl (with-output-to-string (s)
+                                                 (sb-debug:print-backtrace
+                                                   :stream s
+                                                   :print-frame-source t
+                                                   :from :interrupted-frame))
+                                        #-sbcl "dunno"))))))
+      (eval form))))
+
+
+(defun evaluate-forms (message forms &optional in-package)
+  "Evaluate each form in `forms` and shuttle back the responses.
+
+  `forms` can be a string, in which case the forms will be read out of it, or
+  a ready-to-go list of actual forms.
+
+  `in-package` can be a package designator, or `nil` to just use `*package*`.
+
+  "
+  (let* ((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)
+             (let ((result (nrepl-evaluate-form form)))
+               (respond message
+                        (make-map "form" (prin1-to-string form)
+                                  "value" result))))
+           (error-respond (e)
+             (respond message
+                      (apply #'make-map
+                             "status" '("error")
+                             "error" (text e)
+                             "original" (format nil "~S" (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
+                  (let ((*package* (parse-in-package in-package)))
+                    (mapc #'eval-form (get-forms forms)))
+                  (respond message (make-map "status" '("done"))))
+              (evaluation-error (e) (error-respond e))))
+        (close captured-out)
+        (close captured-err)))))
diff -r f36b8fd3e9dd -r e342c4a78a57 src/middleware/documentation.lisp
--- a/src/middleware/documentation.lisp	Sun Aug 21 12:21:26 2016 +0000
+++ b/src/middleware/documentation.lisp	Sun Aug 21 12:58:15 2016 +0000
@@ -1,22 +1,22 @@
 (in-package #:nrepl)
 
-(defun lambda-list-to-string (l)
+(defun lambda-list-to-string (lambda-list)
   "Return a single-line string of the lambda list."
-  (if (listp l)
-    (format nil "(~{~A~^ ~})" (mapcar #'lambda-list-to-string l))
-    (princ-to-string l)))
+  (if (listp lambda-list)
+    (format nil "(~{~A~^ ~})" (mapcar #'lambda-list-to-string lambda-list))
+    (princ-to-string lambda-list)))
 
-(defun find-lambda-list (s)
+(defun find-lambda-list (symbol)
   "Return the lambda list for the given symbol.
 
   Will return `nil` if none is found.  A second value is returned to indicate
   whether it was found.
 
   "
-  (if (fboundp s)
+  (if (fboundp symbol)
     (values
-      #+sbcl (sb-introspect:function-lambda-list s)
-      #+ccl (ccl:arglist s)
+      #+sbcl (sb-introspect:function-lambda-list symbol)
+      #+ccl (ccl:arglist symbol)
       t)
     (values nil nil)))
 
@@ -76,30 +76,26 @@
 
 
 (define-middleware wrap-documentation "documentation" message
-  (let ((s (find-symbol-harder (fset:lookup message "symbol")
-                               (fset:lookup message "in-package"))))
+  (let ((symbol (find-symbol-harder (fset:lookup message "symbol")
+                                    (fset:lookup message "in-package"))))
     (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)
+               "type-docstring" (documentation symbol 'type)
+               "structure-docstring" (documentation symbol 'structure)
+               "variable-docstring" (documentation symbol 'variable)
+               "setf-docstring" (documentation symbol 'setf)
+               "function-docstring" (documentation symbol 'function)
                "function-arglist"
-               (multiple-value-bind (arglist foundp)
-                   (find-lambda-list s)
-                 (when foundp
-                   (princ-to-string (cons s arglist))))))))
+               (when-found arglist (find-lambda-list symbol)
+                 (princ-to-string (cons symbol arglist)))))))
 
 (define-middleware wrap-arglist "arglist" message
-  (let ((s (find-symbol-harder (fset:lookup message "symbol")
-                               (fset:lookup message "in-package"))))
+  (let ((symbol (find-symbol-harder (fset:lookup message "symbol")
+                                    (fset:lookup message "in-package"))))
     (respond message
              (with-when
-               (make-map "status" '("done"))
+                 (make-map "status" '("done"))
                "function-arglist"
-               (multiple-value-bind (arglist foundp)
-                   (find-lambda-list s)
-                 (when foundp
-                   (lambda-list-to-string (cons s arglist))))))))
+               (when-found arglist (find-lambda-list symbol)
+                 (lambda-list-to-string (cons symbol arglist)))))))
diff -r f36b8fd3e9dd -r e342c4a78a57 src/middleware/eval.lisp
--- a/src/middleware/eval.lisp	Sun Aug 21 12:21:26 2016 +0000
+++ b/src/middleware/eval.lisp	Sun Aug 21 12:58:15 2016 +0000
@@ -1,122 +1,5 @@
 (in-package #:nrepl)
 
-(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)
-                  :external-format :utf-8)))
-      ((and (not (open-stream-p from-stream))
-            (equal data ""))
-       nil)
-    (when (not (equal data ""))
-      (respond message (make-map "status" '("ok")
-                                 stream-name data)))
-    (sleep 0.1)))
-
-(defun get-forms (code)
-  "Get all lisp forms from `code`.
-
-  If `code` is a string, the forms will be read out of it, and an
-  `evaluation-error` signaled if the input is mangled.
-
-  If `code` is anything else it will just be returned as-is.
-
-  "
-  (if (stringp code)
-    (handler-case
-        (read-all-from-string code)
-      (error (e)
-             (error 'evaluation-error
-                    :text "Malformed input!"
-                    :orig e)))
-    code))
-
-(defun clean-backtrace (backtrace)
-  (format nil "~{~A~^~%~}"
-          (loop :for line :in (split-sequence:split-sequence #\newline backtrace)
-                :until (ppcre:scan "NREPL::NREPL-EVALUATE-FORM" line)
-                :collect line)))
-
-(defun nrepl-evaluate-form (form)
-  (declare (optimize (debug 3)))
-  ;im so sorry you have to see this
-  (prin1-to-string
-    (handler-bind
-      ((error
-         (lambda (err)
-           ; if we hit an error, print the backtrace to the stream before
-           ; reraising.  if we wait til later to print it, it'll be too late.
-           (error 'evaluation-error
-                  :text "Error during evaluation!"
-                  :orig err
-                  :data (list
-                          "form" (prin1-to-string form)
-                          "backtrace" (clean-backtrace
-                                        #+sbcl (with-output-to-string (s)
-                                                 (sb-debug:print-backtrace
-                                                   :stream s
-                                                   :print-frame-source t
-                                                   :from :interrupted-frame))
-                                        #-sbcl "dunno"))))))
-      (eval form))))
-
-
-(defun evaluate-forms (message forms &optional in-package)
-  "Evaluate each form in `forms` and shuttle back the responses.
-
-  `forms` can be a string, in which case the forms will be read out of it, or
-  a ready-to-go list of actual forms.
-
-  `in-package` can be a package designator, or `nil` to just use `*package*`.
-
-  Other middlewares (e.g. `load-file`) can use this function to evaluate things
-  and send the results back to the user.
-
-  "
-  (let* ((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)
-             (let ((result (nrepl-evaluate-form form)))
-               (respond message
-                        (make-map "form" (prin1-to-string form)
-                                  "value" result))))
-           (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
-                  (let ((*package* (parse-in-package in-package)))
-                    (mapc #'eval-form (get-forms forms)))
-                  (respond message (make-map "status" '("done"))))
-              (evaluation-error (e) (error-respond e))))
-        (close captured-out)
-        (close captured-err)))))
-
 (define-middleware wrap-eval "eval" message
   (evaluate-forms message
                   (fset:lookup message "code")
diff -r f36b8fd3e9dd -r e342c4a78a57 src/middleware/session.lisp
--- a/src/middleware/session.lisp	Sun Aug 21 12:21:26 2016 +0000
+++ b/src/middleware/session.lisp	Sun Aug 21 12:58:15 2016 +0000
@@ -4,11 +4,11 @@
 (defvar *session* nil)
 
 
-(defun clear-sessions! ()
-  (setf *sessions* (make-hash-table :test #'equal)))
+(defun make-session ()
+  (fset:empty-map))
 
-(defun create-session ()
-  (fset:empty-map))
+(defun clear-sessions! ()
+  (clrhash *sessions*))
 
 (defun register-session! (id session)
   (setf (gethash id *sessions*) session))
@@ -42,7 +42,7 @@
     (let* ((session-id (fset:lookup message "session"))
            (session (if session-id
                       (get-session session-id)
-                      (create-session)))
+                      (make-session)))
            (session-id (or session-id (random-uuid)))
            (*session* session))
       (funcall handler (fset:with message "session" session-id)))))
diff -r f36b8fd3e9dd -r e342c4a78a57 src/sockets.lisp
--- a/src/sockets.lisp	Sun Aug 21 12:21:26 2016 +0000
+++ b/src/sockets.lisp	Sun Aug 21 12:58:15 2016 +0000
@@ -12,7 +12,7 @@
   (fset:convert 'fset:map (bencode:decode socket-stream)))
 
 
-;;; Patch in support for writing fset data types to bencode
+;;;; FSet+Bencode
 (defmethod bencode:encode ((fm fset:map) stream &key &allow-other-keys)
   (bencode:encode (fset:convert 'hash-table fm) stream))
 
diff -r f36b8fd3e9dd -r e342c4a78a57 src/utils.lisp
--- a/src/utils.lisp	Sun Aug 21 12:21:26 2016 +0000
+++ b/src/utils.lisp	Sun Aug 21 12:58:15 2016 +0000
@@ -73,3 +73,26 @@
   (if (or (null in-package) (string= in-package ""))
     *package*
     (or (find-package (read-from-string in-package)) *package*)))
+
+
+(defmacro when-found (var lookup-expr &body body)
+  "Perform `body` with `var` to the results of `lookup-expr`, when valid.
+
+  `lookup-expr` should be an expression that returns two values, the first being
+  the result (which will be bound to `var`) and the second indicating whether
+  the lookup was successful.  The standard `gethash` is an example of a function
+  that behaves like this.
+
+  Instead of:
+  (multiple-value-bind (val found) (gethash :foo hash)
+    (when found
+      body))
+
+  (when-found val (gethash :foo hash)
+              body)
+
+  "
+  (let ((found (gensym "found")))
+    `(multiple-value-bind (,var ,found) ,lookup-expr
+       (when ,found
+         ,@body))))