Abstracted into macro-defining macrosHEADmain

3 files changed, 172 insertions, 73 deletions

diff --git a/README.org b/README.org
new file mode 100644
index 0000000..7b0b80b
--- /dev/null
+++ b/README.org
@@ -0,0 +1,81 @@
+* derrida
+
+`DERRIDA` is a library for destructuring common "object-like" structures in Common Lisp.
+
+More specifically, it provides forms that act like `WITH-SLOTS` for "object-like" or "map-like" data structure.
+
+It provides forms for digging into association lists, property lists,
+and struct instances and CLOS class instances.
+
+** Examples
+
+*** Property Lists
+
+#+begin_src lisp
+
+(let ((pl 
+        (list 'name \"colin\" :age 40 :|currentJob| :crumb-bum)))
+  (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))
+
+#+end_src
+
+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)"  
+
+*** Nested Property Lists
+
+#+begin_src lisp
+
+> (defvar *pl* '(:x (:a 10) :y (:b 20))
+*PL*
+
+> (with-keypaths ((a :x :a) 
+                  (b :y :b) 
+                  (d :y :d))  *pl*
+    (incf a) 
+    (setf d (* a b)))
+220
+
+> *pl*
+(:X (:A 11) :Y (:D 220 :B 20))"
+#+end_src
+
+
+*** Nested Instances
+
+
+#+begin_src lisp
+> (defclass point () ((x :initform 0) (y :initform 0)))
+#<STANDARD-CLASS DERRIDA::POINT>
+
+> (defclass in-space () 
+     ((location :initform (make-instance 'point))))
+#<STANDARD-CLASS DERRIDA::IN-SPACE>
+
+> (defvar *thing* (make-instance 'in-space))
+*THING*
+
+> (with-slot-paths 
+      ((x 'location 'x) 
+       (y 'location 'y)) *thing* 
+    (setf x 10 
+          y -30))
+
+-30
+
+> (describe (slot-value *thing* 'location))
+#<POINT {100781DB53}>
+  [standard-object]
+
+Slots with :INSTANCE allocation:
+  X                              = 10
+  Y                              = -30"
+#+end_src
+
diff --git a/derrida.lisp b/derrida.lisp
index b0a1cc0..6c4a3f7 100644
--- a/derrida.lisp
+++ b/derrida.lisp
@@ -1,8 +1,7 @@
 ;;;; derrida.lisp
 
-(in-package #:derrida)
-
 
+(in-package #:derrida)
 
 (defmacro with-alist ((&optional (accessor 'cdr)) (&rest bindings) alist &body body)
   "Bind variables to accessors into ALISTS. ACCESSOR, which should be
@@ -64,7 +63,7 @@ EXAMPLE:
 
 (let ((pl 
         (list 'name \"colin\" :age 40 :|currentJob| :crumb-bum)))
-  (hq:with-plist (name (age :age) (job :|currentJob|)) pl 
+  (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) 
@@ -88,77 +87,92 @@ And would return
     `(let ((,plist-var ,plist)) (symbol-macrolet ,macrolet-bindings ,@body))))
 
 
-(defmacro getf-path (place &rest indicators)
+(defmacro define-deep-place-accessor (name nester &optional docstring)
+  "An internal helper macro. It defines a macro named NAME. NESTER
+should be a function passed to REDUCE. Its purpose is to construct
+nested access.  See applications of DEFINE-DEEP-PLACE-ACCESSOR for examples."
+  `(defmacro ,name (place &rest indicators)
+     ,docstring
+     (if (null indicators) place
+         (reduce ,nester indicators :initial-value place))))
+
+(defmacro define-with-deep-access (name accessor-macro &optional docstring)
+  "An internal helper macro for defining forms that behave like
+WITH-SLOTS.  NAME, a symbol, is the name of the macro being
+defined. ACCESSOR-MACRO should be a symbol naming a macro defined with
+DEFINE-DEEP-PLACE-ACCESSOR.  See applications of this form for examples."
+  `(defmacro ,name (binding-paths place-form &body body)
+     ,docstring
+     (let ((tmp-place (gensym "place")))
+       `(let ((,tmp-place ,place-form))
+          (symbol-macrolet
+              ,(loop :for (var . path) :in binding-paths
+                     :collect
+                     (list var (list* ',accessor-macro tmp-place path)))
+            ,@body)))))
+
+(define-deep-place-accessor
+    gethash-path
+    (lambda (nested key) `(gethash ,key ,nested))
+  "(GETHASH-PATH HASH K1 ... KN) expends into (GETHASH ( ... (GETHASH K1 PLACE) ...) KN).")
+
+(define-deep-place-accessor
+    slot-value-path
+    (lambda (nested slot) `(slot-value ,nested ,slot))
+  "(SLOT-VALUE-PATH PLACE S1 ... SN) expands into (SLOT-VALUE (...(SLOT-VALUE PLACE S1) ..) SN).  It gives you a SETFable in a nested tree of class instances.")
+
+(define-deep-place-accessor
+    getf-path
+    (lambda (nested key) `(getf ,nested ,key))
   "(GETF-PATH PLACE K1 ... KN) expands to (GETF (... (GETF PLACE K1) ...) KN)
 
 E.g 
     > (let ((pl '(:x (:a 10 :b 20) :y (:c 30))))
         (incf (getf-path pl :x :b)) 
         pl)
-   (:X (:A 10 :B 21) :Y (:C 30))"
-  (if
-   (null indicators) place
-   (reduce (lambda (nested key) `(getf ,nested ,key))
-           indicators
-           :initial-value place)))
-
-
-(defmacro with-keypaths (keypaths plist &body body)
-  "Bind SETFable places to locations in a nested PLIST and evaluate BODY.
-
-E.g.
-  > (defvar *pl* '(:x (:a 10 :b 20) :y (:c 30)))
-  *PL*
-  > (with-keypaths 
-       ((b :x :b) 
-        (c :y :c) 
-        (d :y :d)) 
-     (incf b)
-     (setf c (* c b)) 
-     (setf d :HELLO))
-  :HELLO
-  > *pl* 
-  (:X (:A 10 :B 21) :Y (:D :HELLO :C 630))
-"
-  (let ((tmp-plist (gensym "plist")))
-    `(let ((,tmp-plist ,plist)) 
-       (symbol-macrolet
-           ,(loop :for (var . path) :in keypaths
-                  :collect `(,var (getf-path ,tmp-plist ,@path)))
-         ,@body))))
-
-(defmacro slot-path-value (place &rest slots)
-  "(SLOT-PATH-VALUE PLACE S1 ... SN) expands into (SLOT-VALUE (...(SLOT-VALUE PLACE S1) ..) SN).  It gives you a SETFable in a nested tree of class instances."
-  (if (null slots) place
-      (reduce (lambda (nested slot) `(slot-value ,nested ,slot))
-              slots
-              :initial-value place)))
-
-(defmacro with-slot-paths (slotpaths root &body body)
-" Bind SETFable places to locations in a nested tree of CLOS instances and evaluate BODY. 
-
-  > (defclass moo () 
-        ((x :initform 10)))
-  #<STANDARD-CLASS DERRIDA::MOO>
-  > (defclass zoo () 
-       ((a-moo :initform (make-instance 'moo))))
-  #<STANDARD-CLASS DERRIDA::ZOO>
-  > (defvar *z* (make-instance 'zoo))
-  *Z*
-  > (with-slot-paths 
-        ((x 'a-moo 'x)) *z* 
-      (setf x (+ x 20)))
-  30
-  > (describe (slot-value *z* 'a-moo))
-  #<MOO {100AEB1293}>
-    [standard-object]
-  
-  Slots with :INSTANCE allocation:
-    X                              = 30
-"
-  (let ((tmp-root (gensym "root")))
-    `(let ((,tmp-root ,root))
-       (symbol-macrolet
-           ,(loop :for (var . path) :in slotpaths
-                  :collect `(,var (slot-path-value ,tmp-root ,@path)))
-         ,@body))))
+   (:X (:A 10 :B 21) :Y (:C 30))")
+
+(define-with-deep-access with-keypaths getf-path
+  "PLACE should evaluate to a PLIST. WITH-KEPATHS evaluates BODY in the
+context of context established by BINDING-PATHS.
+
+Example:
+
+> (defvar *pl* '(:x (:a 10) :y (:b 20))
+> (with-keypaths ((a :x :a) 
+                  (b :y :b) 
+                  (d :y :d))  *pl*
+    (incf a) 
+    (setf d (* a b)))
+220
+> *pl*
+(:X (:A 11) :Y (:D 220 :B 20))")
+
+(define-with-deep-access with-slot-paths slot-value-path
+  "PLACE should evaluate to an instance of a CLOS class or a struct. WITH-SLOT-PATHS evaluates BODY in the context established by BINDING-PATHS.
+
+Example:
+
+> (defclass point () ((x :initform 0) (y :initform 0)))
+#<STANDARD-CLASS DERRIDA::POINT>
+> (defclass in-space () 
+     ((location :initform (make-instance 'point))))
+#<STANDARD-CLASS DERRIDA::IN-SPACE>
+> (defvar *thing* (make-instance 'in-space))
+*THING*
+> (with-slot-paths 
+      ((x 'location 'x) 
+       (y 'location 'y)) *thing* 
+    (setf x 10 
+          y -30))
+
+-30
+> (describe (slot-value *thing* 'location))
+#<POINT {100781DB53}>
+  [standard-object]
+
+Slots with :INSTANCE allocation:
+  X                              = 10
+  Y                              = -30")
+
+(define-with-deep-access with-hash-paths gethash-path)
diff --git a/package.lisp b/package.lisp
index 8e109a7..9359f1b 100644
--- a/package.lisp
+++ b/package.lisp
@@ -4,7 +4,11 @@
   (:use #:cl)
   (:export #:with-plist
            #:with-alist
-           #:with-slot-paths
            #:slot-path-value
+           #:gethash-path
+           #:getf-path
+           #:with-slot-paths
            #:with-keypaths
-           #:getf-path))
+           #:with-hash-paths))
+
+