From f7baaa6fbf2457e72c3237cbce158a42315c1873 Mon Sep 17 00:00:00 2001 From: colin Date: Sat, 11 Feb 2023 15:18:46 -0800 Subject: Abstracted into macro-defining macros --- README.org | 81 +++++++++++++++++++++++++++++++ derrida.lisp | 156 ++++++++++++++++++++++++++++++++--------------------------- package.lisp | 8 ++- 3 files changed, 172 insertions(+), 73 deletions(-) create mode 100644 README.org 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))) +# + +> (defclass in-space () + ((location :initform (make-instance 'point)))) +# + +> (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)) +# + [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))) - # - > (defclass zoo () - ((a-moo :initform (make-instance 'moo)))) - # - > (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)) - # - [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))) +# +> (defclass in-space () + ((location :initform (make-instance 'point)))) +# +> (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)) +# + [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)) + + -- cgit v1.2.3