From 1f1cf84e9518a36896f293e47f4be8cace52df8d Mon Sep 17 00:00:00 2001
From: colin <colin@cicadas.surf>
Date: Sat, 11 Feb 2023 09:11:57 -0800
Subject: Breaking Refactor + New utils

---
 derrida.asd  |  2 +-
 derrida.lisp | 82 ++++++++++++++++++++++++++++++++++++++++++++++++++++--------
 package.lisp |  6 +++--
 3 files changed, 76 insertions(+), 14 deletions(-)

diff --git a/derrida.asd b/derrida.asd
index 8527790..af466d5 100644
--- a/derrida.asd
+++ b/derrida.asd
@@ -4,7 +4,7 @@
   :description "Macros for desctructuring common data structures."
   :author "Colin Okay <colin@cicadas.surf>"
   :license  "GPL-3.0"
-  :version "0.0.1"
+  :version "0.1.0"
   :serial t
   :components ((:file "package")
                (:file "derrida")))
diff --git a/derrida.lisp b/derrida.lisp
index 442c890..b0a1cc0 100644
--- a/derrida.lisp
+++ b/derrida.lisp
@@ -88,17 +88,77 @@ And would return
     `(let ((,plist-var ,plist)) (symbol-macrolet ,macrolet-bindings ,@body))))
 
 
-(defun get-nested (plist-tree &rest indicators)
-  "PLIST-TREE is plist some of whose values are also
-   PLISTS. INDICATORS are keyes to the plists."
-  (if (or (null plist-tree) (null indicators))
-      plist-tree
-      (apply #'get-nested (getf plist-tree (car indicators)) (cdr indicators))))
-
-(defmacro pluck-nested (keypaths plist &body body)
-  "Pluck nested binds variables to paths into a plist tree."
+(defmacro getf-path (place &rest indicators)
+  "(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)) 
-       (let ,(loop for (var . path) in keypaths
-                    collect `(,var (get-nested ,tmp-plist ,@path)))
+       (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))))
diff --git a/package.lisp b/package.lisp
index 8484a30..8e109a7 100644
--- a/package.lisp
+++ b/package.lisp
@@ -4,5 +4,7 @@
   (:use #:cl)
   (:export #:with-plist
            #:with-alist
-           #:get-nested
-           #:pluck-nested))
+           #:with-slot-paths
+           #:slot-path-value
+           #:with-keypaths
+           #:getf-path))
-- 
cgit v1.2.3