;;;; derrida.lisp


(in-package #:derrida)

(defmacro with-alist ((&optional (accessor 'cdr)) (&rest bindings) alist &body body)
  "Bind variables to accessors into ALISTS. ACCESSOR, which should be
  an accessor function, is called like (ACCESSOR (ASSOC ..)).

   Each member of BINDINGS is either a symbol VAR or a list that
   looks like (VAR KEY-TERM . KWARGS).

   KWARGS are passed as keyword argments to (ASSOC KEY-TERM ALIST ...).

EXAMPLE:

  (let ((al 
          (list (cons 'name \"colin\")
                (list :hobbies \"fiddling\" \"diddling\")
                (list \"job\" :executive \"crum bum\"))))
    (with-alist () 
        (name (hobbies :hobbies) (job \"job\" :test 'equalp)) 
        al 
      (setf job (format nil \"~{~a~^ ~}\" job))
      (format t \"---------------------------~%\")
      (format t \"name: ~a~%hobbies: ~{~a~^,~}~%job: ~a~%\" 
              name hobbies job) 
      (format t \"---------------------------~%\")
      al))
---------------------------
name: colin
hobbies: fiddling,diddling
job: EXECUTIVE crum bum
---------------------------

((NAME . \"colin\") (:HOBBIES \"fiddling\" \"diddling\")
 (\"job\" . \"EXECUTIVE crum bum\"))
"
  (let* ((alist-var
           (gensym))
         (macrolet-bindings
           (loop for term in bindings
                 when (symbolp term )
                   collect `(,term (,accessor (assoc ',term ,alist-var)))
                 when (consp term)
                   collect `(,(first term)
                             (,accessor (assoc ',(second term) ,alist-var ,@(nthcdr 2 term)))))))
    `(let ((,alist-var ,alist)) (symbol-macrolet ,macrolet-bindings ,@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)))
  (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 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))")

(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)