Getting a setf-able place from a nested plist tree?

Question

I've got a nested plist structure, for example:

(:title "A title"
 :repeat (:row    #(:a :b :c)
          :column #(:c :a :b))
 :spec (:data my-data
        :late t))

and I need to set :data to a different value. The challange is that this key may appear anywhere in the tree, possibly even deeper in the tree than this example. It will only appear once. I know about the access library, but can't use it. I can find the key easy enough using a recursive search:

(defun find-in-tree (item tree &key (test #'eql))
           (labels ((find-in-tree-aux (tree)
                      (cond ((funcall test item tree)
                             (return-from find-in-tree tree))
                            ((consp tree)
                             (find-in-tree-aux (car tree))
                             (find-in-tree-aux (cdr tree))))))
             (find-in-tree-aux tree)))

But I can't quite work out if there's any way to get the place when it's nested in the tree. Ideally something like:

(setf (find-place-in-tree :data tree) 'foo)

is what I'm after.

Any ideas?

Answer 1

This is not exactly a setf-able tree. But the construction of a setf-like in-place mutation macro for nested plists - even for the case that the key of a nested plist occurs in more than one places.

The plist-setf constructs paths to the desired key within the nested plist. And replaces the current value to the new-value. Within a path, a symbol should not occur twice. Otherwise there will be severe errors.

(defun plistp (l)
  "Is `l` a plist?"
  (loop for (k v) on l by #'cddr
        always (symbolp k)))

(defun get-plist-paths (plist key &optional (acc '()))
  "Which paths are in a nested plist for reaching key?"
  (loop for (k v) on plist by #'cddr
        nconcing (if (eq key k)
                     (list (reverse (cons key acc)))
                     (if (plistp v)
                         (get-plist-paths v key (cons k acc))
                         nil))))

(defun staple (plist plist-path)
  "Given a plist-path, generate code to getf to this path."
  (let ((res (list 'getf plist (car plist-path))))
    (loop for s in (cdr plist-path)
          do (setf res (cons 'getf (cons res (list s))))
          finally (return res))))

(defun construct-call (plist plist-path new-value)
  "Add to the generated code a `(setf ... new-value)."
  `(setf ,(staple plist plist-path) ,new-value))

(defun construct-entire-call (plist-symbol plist key new-value)
  "Generate the entire code for the macro."
  (let ((plist-paths (get-plist-paths plist key)))
    (cons 'progn
      (loop for pp in plist-paths
            collect (construct-call plist-symbol pp new-value)))))

(defmacro %plist-setf (plist key new-value)
  "A macro to make the input of construct-entire-call more uniform."
  `(construct-entire-call ',plist ,plist ,key ,new-value))

(defmacro plist-setf (plist key new-value)
  "Automated setf of a key in a nested plist to set the location to the new-value."
  (eval `(%plist-setf ,plist ,key ,new-value)))

;; the `eval` is needed to have an extra evaluation step here.
;; I am happy if someone can suggest a better alternative.
;; Or if someone can falsify its correctness here.

Some of the functions can be "explained" by some examples:

(defparameter *pl* (list :points 5 :a (list :b 1 :c (list :d 0 :e 1) :f 2)))
(defparameter *pl1* (list :points 5 :a (list :b 1 :c (list :d 0 :e 1) :f 2 :e 3 :g (list :h 1 :e 1))))

(get-plist-path *pl1* :e)
;; => ((:A :C :E) (:A :E) (:A :G :E))

(construct-entire-call '*pl1* *pl1* :e 3)
;; (PROGN 
;;  (SETF (GETF (GETF (GETF *PL1* :A) :C) :E) 3) 
;;  (SETF (GETF (GETF *PL1* :A) :E) 3)
;;  (SETF (GETF (GETF (GETF *PL1* :A) :G) :E) 3))


(%plist-setf *pl1* :e 3)
;; (PROGN 
;;  (SETF (GETF (GETF (GETF *PL1* :A) :C) :E) 3) 
;;  (SETF (GETF (GETF *PL1* :A) :E) 3)
;;  (SETF (GETF (GETF (GETF *PL1* :A) :G) :E) 3))

Usage:

(defparameter *pl1* (list :points 5 :a (list :b 1 :c (list :d 0 :e 1) :f 2 :e 3 :g (list :h 1 :e 1))))

(macroexpand-1 '(plist-setf *pl1* :e 3))
;; (PROGN 
;;   (SETF (GETF (GETF (GETF *PL1* :A) :C) :E) 3) 
;;   (SETF (GETF (GETF *PL1* :A) :E) 3)
;;   (SETF (GETF (GETF (GETF *PL1* :A) :G) :E) 3)) ;
;; T

*pl1*
;; => (:POINTS 5 :A (:B 1 :C (:D 0 :E 1) :F 2 :E 3 :G (:H 1 :E 1)))

;; after
(plist-setf *pl1* :e 3)
*pl1*
;; => (:POINTS 5 :A (:B 1 :C (:D 0 :E 3) :F 2 :E 3 :G (:H 1 :E 3)))

Or also:

(defparameter *pl* (list :points 5 :a (list :b 1 :c (list :d 0 :e 1) :f 2)))

(macroexpand-1 '(plist-setf *pl* :e 3))
;; (PROGN (SETF (GETF (GETF (GETF *PL* :A) :C) :E) 3)) ;
;; T


*pl*
;; => (:POINTS 5 :A (:B 1 :C (:D 0 :E 1) :F 2))

(plist-setf *pl* :e 3)
*pl*
;; => (:POINTS 5 :A (:B 1 :C (:D 0 :E 3) :F 2))

Answer 2

I could not work out your recursive searcher so I wrote a simpler one, which also solves the 'item is present but value is nil' in the usual way:

(defun find-in-tree (item tree &key (test #'eql))
  ;; really just use iterate here  
  (labels ((fit-loop (tail)
             (cond 
              ((null tail)
               ;; not there
               (return-from find-in-tree (values nil nil)))
              ((null (rest tail))
               ;; not a plist
               (error "botched plist"))
              (t
               (destructuring-bind (this val . more) tail
                 (cond
                  ((funcall test this item)
                   ;; gotit
                   (return-from find-in-tree (values val t)))
                  ((consp val)
                   ;; Search in the value if it's a list
                   (fit-loop val)
                   (fit-loop more))
                  (t
                   ;; just keep down this list
                   (fit-loop more))))))))
    (fit-loop tree)))

Given that the setf function is essentially trivial if you don't want it to add entries (which it can not always do anyway):

(defun (setf find-in-tree) (new item tree &key (test #'eql))
  ;; really just use iterate here  
  (labels ((fit-loop (tail)
             (cond 
              ((null tail)
               (error "not in tree"))
              ((null (rest tail))
               (error "botched plist"))
              (t
               (destructuring-bind (this val . more) tail
                 (cond
                  ((funcall test this item)
                   (return-from find-in-tree
                     (car (setf (cdr tail) (cons new more)))))
                  ((consp val)
                   (fit-loop val)
                   (fit-loop more))
                  (t
                   (fit-loop more))))))))
    (fit-loop tree)))