Trashed most of hyperquirks, added let+

1 files changed, 42 insertions, 142 deletions

diff --git a/hyperquirks.lisp b/hyperquirks.lisp
index 70ee560..f0e8bfc 100644
--- a/hyperquirks.lisp
+++ b/hyperquirks.lisp
@@ -4,10 +4,41 @@
 
 ;;; MACROS
 
-(defmacro defvarf (var &optional val doc)
-  `(if (boundp ',var)
-       (setf ,var ,val)
-       (defvar ,var ,val ,doc)))
+(defmacro let+ (bindings &body body)
+  "General purpose binding. Normal let bindings, destructuring-binds,
+and multiple-value-binds all in the same form.
+
+(let+ ((x
+         10)
+       ((y z . w) 
+           (list 1 2 3 4 5)) 
+       (p q r 
+           (values :oh :my :goodness))) 
+
+  (list x y x w p q r))
+
+;; returns
+(10 1 2 (3 4 5) :oh :my :goodness)
+"
+  (flet ((destructuring-binding-p (binding)
+           (and (consp (first binding))
+                (every #'symbolp (first binding))))
+         (mvb-binding-p (binding)
+           (and (every #'symbolp (butlast binding))
+                (consp (first (last binding))))))
+    (loop
+      :with body = `(progn ,@body)
+      :for binding :in (reverse bindings)
+      :when (destructuring-binding-p binding)
+        :do (setf body
+                  `(destructuring-bind ,(first binding) ,(second binding)
+                     ,body))
+      :when (mvb-binding-p binding)
+        :do (setf body
+                  `(multiple-value-bind
+                         ,(butlast binding) ,(first (last binding))
+                     ,body))
+      :finally (return body))))
 
 (defmacro imperative (&body body)
    "Evaluate expressins in BODY in sequence. Expressions that look
@@ -54,60 +85,14 @@ returned from.
                        (expander (rest body)))))))
      `(block () ,@(expander body))))
 
-(defmacro >> (ob &rest accessors)
-  "Chain access to OB."
-  (let* ((tmpvar
-           (gensym))
-         (block-name
-           (gensym))
-         (body
-           (loop for a in accessors
-                 when (symbolp a)
-                   collect `(setf ,tmpvar (funcall ',a ,tmpvar))
-                 else
-                   collect `(setf ,tmpvar (funcall ,a ,tmpvar)))))
-    `(block ,block-name
-         (let ((,tmpvar ,ob))
-           ,@body))))
-
-
-(defmacro ?> ((&key default (test 'null)) ob &rest accessors)
-  "Chain access to OB, returning DEFAULT the first time TEST returns null.
-E.g. 
-
-
-> (let ((num-tree '(1 (2 3 (4 5) 6))))
-    (?> num-tree second third fourth))
-NIL
 
-> (let ((num-tree '(1 (2 3 (4 5) 6))))
-    (?> num-tree second third first))
-4
-"
-  (let* ((tmpvar
-           (gensym "TEMP"))
-         (block-name
-           (gensym "BLOCK"))
-         (body
-           (loop for a in accessors
-                 collect `(when (funcall ',test ,tmpvar)
-                            (return-from ,block-name ,default))
-                 when (symbolp a)
-                   collect `(setf ,tmpvar (funcall ',a ,tmpvar))
-                 else
-                   collect `(setf ,tmpvar (funcall ,a ,tmpvar)))))
-    `(block ,block-name
-         (let ((,tmpvar ,ob))
-           ,@body))))
-
-
-(defmacro imperative-cond (&body clauses)
+(defmacro binding-cond (&body clauses)
   "Like cond except the first form of every clause is a binding form
 alá IMPERATIVE. 
 
 E.g. 
 
-(imperative-cond 
+(binding-cond 
    ((:= x (and (zerop (random 2)) 10)
         y 11)
     (list :x x :y y))
@@ -129,55 +114,6 @@ Otherwise 12 would be returned."
                 collect `(when (and ,@vars) (return (progn ,@body))))))
     `(imperative ,@imperative-body)))
 
-(defmacro with-plist (keys plist &body body)
-  "KEYS is a list, each member of which is either a symbol or a pair of symbols.
-
-If a member is just a symbol, say KEY, then it is treated as the name
-of a symbol-macro (defined using symbol-macrolet) that expands to the
-expression (getf PLIST KEY).  In this case, KEY is not allowed to be a
-keyword symbol.
-
-If a member is a pair of symbols, it is of the form (VAR KEY). Here,
-key is a valid key into the PLIST and VAR is the name of the symbol
-macrolet that will be bound to (getf PLIST KEY).
-
-EXAMPLE:
-
-(let ((pl 
-        (list 'name \"colin\" :age 40 :|currentJob| :crumb-bum)))
-  (hq:with-plist (name (age :age) (job :|currentJob|)) pl 
-    (setf age (1+ age)) 
-    (format t \"~a the ~a had a birthday, and is now ~a years old~%\" 
-            name job age) 
-    pl))
-
-The above would print out:
-colin the CRUMB-BUM had a birthday, and is now 41 years old
-
-And would return 
-(NAME \"colin\" :AGE 41 :|currentJob| :CRUMB-BUM)"  
-
-  (let* ((plist-var
-           (gensym))
-         (macrolet-bindings
-           (loop for term in keys
-                 when (consp term )
-                   collect (destructuring-bind (var key) term
-                               `(,var (getf ,plist-var ',key)))
-                 else
-                   collect `(,term (getf ,plist-var ',term)))))
-    `(let ((,plist-var ,plist)) (symbol-macrolet ,macrolet-bindings ,@body))))
-
-(defmacro with-leaves (leaf-var tree &body body)
-  "Binds each atom in TREE to LEAF-VAR and then executes BODY."
-  (let ((tree-var (gensym))
-        (ignore-var (gensym)))
-    `(let ((,tree-var ,tree))
-       (tree-equal ,tree-var ,tree-var
-                   :test (lambda (,leaf-var ,ignore-var)
-                           (declare (ignore ,ignore-var))
-                           ,@body
-                           t)))))
 
 
 
@@ -202,47 +138,11 @@ E.g.
        (case (length ,rest-args)
          ,@clauses))))
 
-;;; LIST FUNCTIONS
-
-(defun group (n xs &optional default)
-  "Group a list XS into consequtive sublists of size N, using the
-DEFAULT to fill in any remainder in the case the length of XS is not
-neatly divisible by N."
-  (loop
-    with len = (length xs)
-    for start from 0 to len by n
-    for end = (+ start n)
-    when (<= end len)
-      collect (subseq xs start end)
-    when (< start len end)
-      collect (nconc (subseq xs start)
-                     (loop repeat (- end len) collect default))))
-
-;;; STRING FUNCTIONS
-
-(defun tabulate
-    (objects line-width col-count
-     &key
-       (default-fill #\space)
-       (stream t)
-       (object-formatter "~a"))
-"Print a table of OBJECTS to STREAM. The table will be LINE-WIDTH
-chracters wide and each line will have COL-COUNT columns. 
-
-The objects are formatted with the format string OBJECT-FORMATTER,
-which defaults to ~a. DEFAULT-FILL is used to fill in blanks in the
-table."
-  (let ((row-format
-          (apply 'concatenate 'string
-                 "~" (prin1-to-string line-width) "<"
-                 (loop for i from 1 to col-count
-                       collect object-formatter
-                       when (< i col-count)
-                         collect "~;"
-                       else
-                         collect "~>~%"))))
-    (dolist (g (group col-count objects default-fill))
-      (apply #'format stream row-format g))))
+
+
+
+
+