# HG changeset patch # User Steve Losh # Date 1479663334 0 # Node ID ca726222b6f10efd68cf4630592e0cabdc44dbc9 # Parent d1fec9bbd787c579e40e3ef1189d9c97b219398f Use quickutil to save some code diff -r d1fec9bbd787 -r ca726222b6f1 Makefile --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Makefile Sun Nov 20 17:35:34 2016 +0000 @@ -0,0 +1,8 @@ +.PHONY: vendor + + +# Vendor ---------------------------------------------------------------------- +vendor/quickutils.lisp: vendor/make-quickutils.lisp + cd vendor && sbcl --noinform --load make-quickutils.lisp --eval '(quit)' + +vendor: vendor/quickutils.lisp diff -r d1fec9bbd787 -r ca726222b6f1 nrepl.asd --- a/nrepl.asd Sun Nov 20 17:20:42 2016 +0000 +++ b/nrepl.asd Sun Nov 20 17:35:34 2016 +0000 @@ -21,19 +21,21 @@ ) :serial t - :components - ((:file "package") - (:module "src" :serial t - :components ((:file "utils") - (:file "sockets") - (:file "evaluation") - (:module "middleware" :serial t - :components ((:file "core") - (:file "describe") - (:file "documentation") - (:file "macroexpand") - (:file "eval") - (:file "load-file") - (:file "session"))) - (:file "server"))))) + :components ((:module "vendor" :serial t + :components ((:file "quickutils-package") + (:file "quickutils"))) + (:file "package") + (:module "src" :serial t + :components ((:file "utils") + (:file "sockets") + (:file "evaluation") + (:module "middleware" :serial t + :components ((:file "core") + (:file "describe") + (:file "documentation") + (:file "macroexpand") + (:file "eval") + (:file "load-file") + (:file "session"))) + (:file "server"))))) diff -r d1fec9bbd787 -r ca726222b6f1 package.lisp --- a/package.lisp Sun Nov 20 17:20:42 2016 +0000 +++ b/package.lisp Sun Nov 20 17:35:34 2016 +0000 @@ -1,7 +1,8 @@ (defpackage :nrepl (:use :cl - :split-sequence) + :split-sequence + :nrepl.quickutils) (:export :start-server :stop-server)) diff -r d1fec9bbd787 -r ca726222b6f1 src/middleware/core.lisp --- a/src/middleware/core.lisp Sun Nov 20 17:20:42 2016 +0000 +++ b/src/middleware/core.lisp Sun Nov 20 17:35:34 2016 +0000 @@ -14,7 +14,7 @@ As the body is executing `message-binding` will be bound to the message map. " - (let ((fallback (gensym))) + (with-gensyms (fallback) `(defun ,name (,fallback) (lambda (,message-binding) (handle-op ,message-binding ,op ,fallback diff -r d1fec9bbd787 -r ca726222b6f1 src/middleware/documentation.lisp --- a/src/middleware/documentation.lisp Sun Nov 20 17:20:42 2016 +0000 +++ b/src/middleware/documentation.lisp Sun Nov 20 17:35:34 2016 +0000 @@ -22,7 +22,7 @@ (defun parse-symbol-designator-package (string in-package) - (let ((parts (split-sequence-if (partial #'char= #\:) + (let ((parts (split-sequence-if (curry #'char= #\:) (string-upcase string)))) (case (length parts) (0 nil) @@ -41,7 +41,7 @@ (t nil)))) (defun parse-symbol-designator-name (string) - (let ((parts (split-sequence-if (partial #'char= #\:) + (let ((parts (split-sequence-if (curry #'char= #\:) (string-upcase string)))) (case (length parts) (0 nil) @@ -87,7 +87,7 @@ "setf-docstring" (documentation symbol 'setf) "function-docstring" (documentation symbol 'function) "function-arglist" - (when-found arglist (find-lambda-list symbol) + (when-found (arglist (find-lambda-list symbol)) (princ-to-string (cons symbol arglist))))))) (define-middleware wrap-arglist "arglist" message @@ -97,5 +97,5 @@ (with-when (make-map "status" '("done")) "function-arglist" - (when-found arglist (find-lambda-list symbol) + (when-found (arglist (find-lambda-list symbol)) (lambda-list-to-string (cons symbol arglist))))))) diff -r d1fec9bbd787 -r ca726222b6f1 src/middleware/session.lisp --- a/src/middleware/session.lisp Sun Nov 20 17:20:42 2016 +0000 +++ b/src/middleware/session.lisp Sun Nov 20 17:35:34 2016 +0000 @@ -20,7 +20,7 @@ (gethash id *sessions*)) (defun get-sessions () - (hash-keys *sessions*)) + (hash-table-keys *sessions*)) (defun wrap-session (handler) diff -r d1fec9bbd787 -r ca726222b6f1 src/server.lisp --- a/src/server.lisp Sun Nov 20 17:20:42 2016 +0000 +++ b/src/server.lisp Sun Nov 20 17:35:34 2016 +0000 @@ -52,7 +52,7 @@ (defun handle-message (socket-stream lock) "Read and handle a single message from `socket-stream`." (let ((message (fset:with (read-object socket-stream) - "transport" (partial #'write-object socket-stream lock)))) + "transport" (curry #'write-object socket-stream lock)))) (handle message))) (defun handler (socket-stream lock) diff -r d1fec9bbd787 -r ca726222b6f1 src/utils.lisp --- a/src/utils.lisp Sun Nov 20 17:20:42 2016 +0000 +++ b/src/utils.lisp Sun Nov 20 17:35:34 2016 +0000 @@ -3,14 +3,9 @@ (defvar *log* *error-output*) -(defun pairs (sequence) - "Return a list of cons pairs of the items of the riffle `sequence`." - (loop :for (a b) :on sequence :by #'cddr - :collect (cons a b))) - (defun make-map (&rest keyvals) "Create an fset map of the given riffle of keys and values." - (fset:convert 'fset:map (pairs keyvals))) + (fset:convert 'fset:map (subdivide keyvals 2))) (defun with-when (map &rest keyvals) "Add the items in the `keyvals` riffle with non-nil values to `map`." @@ -33,19 +28,10 @@ (read-next-from-string (subseq s pos) (cons i results)))))) (nreverse (read-next-from-string s ())))) -(defun partial (fn &rest args) - (lambda (&rest remaining-args) - (apply fn (append args remaining-args)))) - (defun random-uuid () "Return a random UUID as a string." (format nil "~a" (uuid:make-v4-uuid))) -(defun hash-keys (h) - (loop :for key :being :the :hash-keys :of h - :collect key)) - - (defun log-message (&rest args) (apply #'format *log* args) (force-output *log*)) @@ -69,8 +55,8 @@ (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. +(defmacro when-found ((var lookup-expr) &body body) + "Perform `body` with `var` bound 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 @@ -82,11 +68,11 @@ (when found body)) - (when-found val (gethash :foo hash) - body) + (when-found (val (gethash :foo hash)) + body) " - (let ((found (gensym "found"))) + (with-gensyms (found) `(multiple-value-bind (,var ,found) ,lookup-expr - (when ,found - ,@body)))) + (when ,found + ,@body)))) diff -r d1fec9bbd787 -r ca726222b6f1 vendor/make-quickutils.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/vendor/make-quickutils.lisp Sun Nov 20 17:35:34 2016 +0000 @@ -0,0 +1,14 @@ +(ql:quickload 'quickutil) + +(qtlc:save-utils-as + "quickutils.lisp" + :utilities '( + + :curry + :hash-table-keys + :rcurry + :subdivide + :with-gensyms + + ) + :package "NREPL.QUICKUTILS") diff -r d1fec9bbd787 -r ca726222b6f1 vendor/quickutils-package.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/vendor/quickutils-package.lisp Sun Nov 20 17:35:34 2016 +0000 @@ -0,0 +1,12 @@ +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (find-package "NREPL.QUICKUTILS") + (defpackage "NREPL.QUICKUTILS" + (:documentation "Package that contains Quickutil utility functions.") + (:use :cl)))) + +(in-package "NREPL.QUICKUTILS") + +;; need to define this here so sbcl will shut the hell up about it being +;; undefined when compiling quickutils.lisp. computers are trash. +(defparameter *utilities* nil) + diff -r d1fec9bbd787 -r ca726222b6f1 vendor/quickutils.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/vendor/quickutils.lisp Sun Nov 20 17:35:34 2016 +0000 @@ -0,0 +1,298 @@ +;;;; This file was automatically generated by Quickutil. +;;;; See http://quickutil.org for details. + +;;;; To regenerate: +;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:CURRY :SUBDIVIDE :APPENDF :COMPOSE :DOHASH :ENSURE-BOOLEAN :ENSURE-GETHASH :ENSURE-LIST :HASH-TABLE-KEYS :MAPHASH-KEYS :MKSTR :ONCE-ONLY :RCURRY :REMOVEF :SYMB :WITH-GENSYMS) :ensure-package T :package "NREPL.QUICKUTILS") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (find-package "NREPL.QUICKUTILS") + (defpackage "NREPL.QUICKUTILS" + (:documentation "Package that contains Quickutil utility functions.") + (:use #:cl)))) + +(in-package "NREPL.QUICKUTILS") + +(when (boundp '*utilities*) + (setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION + :CURRY :SUBDIVIDE :APPENDF :COMPOSE + :DOHASH :ENSURE-BOOLEAN + :ENSURE-GETHASH :ENSURE-LIST + :MAPHASH-KEYS :HASH-TABLE-KEYS :MKSTR + :ONCE-ONLY :RCURRY :REMOVEF :SYMB + :STRING-DESIGNATOR :WITH-GENSYMS)))) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun make-gensym-list (length &optional (x "G")) + "Returns a list of `length` gensyms, each generated as if with a call to `make-gensym`, +using the second (optional, defaulting to `\"G\"`) argument." + (let ((g (if (typep x '(integer 0)) x (string x)))) + (loop repeat length + collect (gensym g)))) + ) ; eval-when +(eval-when (:compile-toplevel :load-toplevel :execute) + ;;; To propagate return type and allow the compiler to eliminate the IF when + ;;; it is known if the argument is function or not. + (declaim (inline ensure-function)) + + (declaim (ftype (function (t) (values function &optional)) + ensure-function)) + (defun ensure-function (function-designator) + "Returns the function designated by `function-designator`: +if `function-designator` is a function, it is returned, otherwise +it must be a function name and its `fdefinition` is returned." + (if (functionp function-designator) + function-designator + (fdefinition function-designator))) + ) ; eval-when + + (defun curry (function &rest arguments) + "Returns a function that applies `arguments` and the arguments +it is called with to `function`." + (declare (optimize (speed 3) (safety 1) (debug 1))) + (let ((fn (ensure-function function))) + (lambda (&rest more) + (declare (dynamic-extent more)) + ;; Using M-V-C we don't need to append the arguments. + (multiple-value-call fn (values-list arguments) (values-list more))))) + + (define-compiler-macro curry (function &rest arguments) + (let ((curries (make-gensym-list (length arguments) "CURRY")) + (fun (gensym "FUN"))) + `(let ((,fun (ensure-function ,function)) + ,@(mapcar #'list curries arguments)) + (declare (optimize (speed 3) (safety 1) (debug 1))) + (lambda (&rest more) + (apply ,fun ,@curries more))))) + + + (defun subdivide (sequence chunk-size) + "Split `sequence` into subsequences of size `chunk-size`." + (check-type sequence sequence) + (check-type chunk-size (integer 1)) + + (etypecase sequence + ;; Since lists have O(N) access time, we iterate through manually, + ;; collecting each chunk as we pass through it. Using SUBSEQ would + ;; be O(N^2). + (list (loop :while sequence + :collect + (loop :repeat chunk-size + :while sequence + :collect (pop sequence)))) + + ;; For other sequences like strings or arrays, we can simply chunk + ;; by repeated SUBSEQs. + (sequence (loop :with len := (length sequence) + :for i :below len :by chunk-size + :collect (subseq sequence i (min len (+ chunk-size i))))))) + + + (define-modify-macro appendf (&rest lists) append + "Modify-macro for `append`. Appends `lists` to the place designated by the first +argument.") + + + (defun compose (function &rest more-functions) + "Returns a function composed of `function` and `more-functions` that applies its ; +arguments to to each in turn, starting from the rightmost of `more-functions`, +and then calling the next one with the primary value of the last." + (declare (optimize (speed 3) (safety 1) (debug 1))) + (reduce (lambda (f g) + (let ((f (ensure-function f)) + (g (ensure-function g))) + (lambda (&rest arguments) + (declare (dynamic-extent arguments)) + (funcall f (apply g arguments))))) + more-functions + :initial-value function)) + + (define-compiler-macro compose (function &rest more-functions) + (labels ((compose-1 (funs) + (if (cdr funs) + `(funcall ,(car funs) ,(compose-1 (cdr funs))) + `(apply ,(car funs) arguments)))) + (let* ((args (cons function more-functions)) + (funs (make-gensym-list (length args) "COMPOSE"))) + `(let ,(loop for f in funs for arg in args + collect `(,f (ensure-function ,arg))) + (declare (optimize (speed 3) (safety 1) (debug 1))) + (lambda (&rest arguments) + (declare (dynamic-extent arguments)) + ,(compose-1 funs)))))) + + + (defmacro dohash ((key value table &optional result) &body body) + "Iterate over the hash table `table`, executing `body`, with `key` and + `value` bound to the keys and values of the hash table + respectively. Return `result` from the iteration form." + `(progn + (maphash (lambda (,key ,value) + ,@body) + ,table) + ,result)) + + + (defun ensure-boolean (x) + "Convert `x` into a Boolean value." + (and x t)) + + + (defmacro ensure-gethash (key hash-table &optional default) + "Like `gethash`, but if `key` is not found in the `hash-table` saves the `default` +under key before returning it. Secondary return value is true if key was +already in the table." + `(multiple-value-bind (value ok) (gethash ,key ,hash-table) + (if ok + (values value ok) + (values (setf (gethash ,key ,hash-table) ,default) nil)))) + + + (defun ensure-list (list) + "If `list` is a list, it is returned. Otherwise returns the list designated by `list`." + (if (listp list) + list + (list list))) + + + (declaim (inline maphash-keys)) + (defun maphash-keys (function table) + "Like `maphash`, but calls `function` with each key in the hash table `table`." + (maphash (lambda (k v) + (declare (ignore v)) + (funcall function k)) + table)) + + + (defun hash-table-keys (table) + "Returns a list containing the keys of hash table `table`." + (let ((keys nil)) + (maphash-keys (lambda (k) + (push k keys)) + table) + keys)) + + + (defun mkstr (&rest args) + "Receives any number of objects (string, symbol, keyword, char, number), extracts all printed representations, and concatenates them all into one string. + +Extracted from _On Lisp_, chapter 4." + (with-output-to-string (s) + (dolist (a args) (princ a s)))) + + + (defmacro once-only (specs &body forms) + "Evaluates `forms` with symbols specified in `specs` rebound to temporary +variables, ensuring that each initform is evaluated only once. + +Each of `specs` must either be a symbol naming the variable to be rebound, or of +the form: + + (symbol initform) + +Bare symbols in `specs` are equivalent to + + (symbol symbol) + +Example: + + (defmacro cons1 (x) (once-only (x) `(cons ,x ,x))) + (let ((y 0)) (cons1 (incf y))) => (1 . 1)" + (let ((gensyms (make-gensym-list (length specs) "ONCE-ONLY")) + (names-and-forms (mapcar (lambda (spec) + (etypecase spec + (list + (destructuring-bind (name form) spec + (cons name form))) + (symbol + (cons spec spec)))) + specs))) + ;; bind in user-macro + `(let ,(mapcar (lambda (g n) (list g `(gensym ,(string (car n))))) + gensyms names-and-forms) + ;; bind in final expansion + `(let (,,@(mapcar (lambda (g n) + ``(,,g ,,(cdr n))) + gensyms names-and-forms)) + ;; bind in user-macro + ,(let ,(mapcar (lambda (n g) (list (car n) g)) + names-and-forms gensyms) + ,@forms))))) + + + (defun rcurry (function &rest arguments) + "Returns a function that applies the arguments it is called +with and `arguments` to `function`." + (declare (optimize (speed 3) (safety 1) (debug 1))) + (let ((fn (ensure-function function))) + (lambda (&rest more) + (declare (dynamic-extent more)) + (multiple-value-call fn (values-list more) (values-list arguments))))) + + + (declaim (inline remove/swapped-arguments)) + (defun remove/swapped-arguments (sequence item &rest keyword-arguments) + (apply #'remove item sequence keyword-arguments)) + + (define-modify-macro removef (item &rest remove-keywords) + remove/swapped-arguments + "Modify-macro for `remove`. Sets place designated by the first argument to +the result of calling `remove` with `item`, place, and the `keyword-arguments`.") + + + (defun symb (&rest args) + "Receives any number of objects, concatenates all into one string with `#'mkstr` and converts them to symbol. + +Extracted from _On Lisp_, chapter 4. + +See also: `symbolicate`" + (values (intern (apply #'mkstr args)))) + + + (deftype string-designator () + "A string designator type. A string designator is either a string, a symbol, +or a character." + `(or symbol string character)) + + + (defmacro with-gensyms (names &body forms) + "Binds each variable named by a symbol in `names` to a unique symbol around +`forms`. Each of `names` must either be either a symbol, or of the form: + + (symbol string-designator) + +Bare symbols appearing in `names` are equivalent to: + + (symbol symbol) + +The string-designator is used as the argument to `gensym` when constructing the +unique symbol the named variable will be bound to." + `(let ,(mapcar (lambda (name) + (multiple-value-bind (symbol string) + (etypecase name + (symbol + (values name (symbol-name name))) + ((cons symbol (cons string-designator null)) + (values (first name) (string (second name))))) + `(,symbol (gensym ,string)))) + names) + ,@forms)) + + (defmacro with-unique-names (names &body forms) + "Binds each variable named by a symbol in `names` to a unique symbol around +`forms`. Each of `names` must either be either a symbol, or of the form: + + (symbol string-designator) + +Bare symbols appearing in `names` are equivalent to: + + (symbol symbol) + +The string-designator is used as the argument to `gensym` when constructing the +unique symbol the named variable will be bound to." + `(with-gensyms ,names ,@forms)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (export '(curry subdivide appendf compose dohash ensure-boolean + ensure-gethash ensure-list hash-table-keys maphash-keys mkstr + once-only rcurry removef symb with-gensyms with-unique-names))) + +;;;; END OF quickutils.lisp ;;;;