util, shape: improve / fix property list and head handling facilities

shape/shape.lisp

@@ -6,7 +6,8 @@
                     (:mop :closer-mop))
   (:export #:meta #:get-meta #:create #:record-meta
            #:record #:print-fields #:print-slots
-           #:head-fields #:head #:head-value #:head-plist #:head-update
+           #:head #:head-fields #:head-value 
+           #:head-plist #:head-plist-str #:head-update
            #:data-fields #:data #:data-value))
 
 (in-package :scopes/shape)
@@ -52,19 +53,16 @@
 (defun (setf head-value) (val rec key)
   (setf (elt (head rec) (position key (head-fields rec))) val))
 
-(defun head-plist (rec &key (transform-value #'util:from-keyword))
-  (let (pl (hv (head rec)))
-    (dolist (hf (head-fields rec))
-      (setf pl (cons hf (cons (funcall transform-value (pop hv)) pl))))
-    pl))
+(defun head-plist (rec &key (transform-value #'identity))
+  (loop for k in (head-fields rec) and v in (head rec) 
+        append (list k (funcall transform-value v))))
 
-(defun head-plist-n (rec)
-  (loop for k in (head-fields rec) and v in (head rec) nconc (list k v)))
+(defun head-plist-str (rec)
+  (head-plist rec :transform-value #'util:from-keyword))
 
 (defun head-update (rec &rest plst)
-  (reverse
-    (util:loop-plist (head-plist rec :transform-value #'identity) k v
-      collect (or (getf plst k) v))))
+  (util:loop-plist (head-plist rec) k v
+    collect (or (getf plst k) v)))
 
 (defun data-value (rec key)
   (getf (data rec) key))

storage/tracking.lisp

@@ -191,7 +191,7 @@
     (setf (timestamp track) (get-universal-time))))
 
 (defun plist (track)
-  (let ((vl (shape:head-plist track))
+  (let ((vl (shape:head-plist-str track))
         (data (shape:data track)))
     (with-slots ((trid trackid) (ts timestamp)) track
       (when trid (setf (getf vl :trackid) trid))

test/test-core.lisp

@@ -86,6 +86,7 @@
   (== (util:rtrim '(1 2 nil 3 nil)) '(1 2 nil 3)) 
   (== (util:to-keyword "hello-kitty") :hello-kitty)
   (== (util:loop-plist '(:a "a" :b "b") k v collect (string-upcase k)) '("A" "B"))
+  (== (util:map-plist '(:a "a" :b "b") #'string-upcase) '(:a "A" :b "B"))
   (== (util:plist-pairs '(:a "a" :b "b")) '((:a "a") (:b "b")))
   (let ((pl '(:a 0)))
     (== (util:plist-add pl :b 1) '(:b 1 :a 0))
@@ -115,7 +116,7 @@
     (== (shape:head-value rec :taskid) :t1)
     (setf (shape:head-value rec :username) :u1)
     (== (shape:head-value rec :username) :u1)
-    (== (shape:head-plist rec) '(:username "u1" :taskid "t1"))
+    (== (shape:head-plist-str rec) '(:taskid "t1" :username "u1"))
 ))
 
 (deftest test-util-async ()

test/test-storage.lisp

@@ -51,7 +51,7 @@
     (tracking:create-table cont)
     (setf tr (tracking:make-item cont :t01 :john))
     (== (shape:head tr) '(:t01 :john))
-    (== (shape:head-plist tr) '(:username "john" :taskid "t01"))
+    (== (shape:head-plist-str tr) '(:taskid "t01" :username "john"))
     (== (shape:data tr) nil)
     (setf (shape:data tr) '(:desc "scopes/storage: queries"))
     (tracking:insert tr)

util/util.lisp

@@ -9,7 +9,8 @@
            #:from-unix-time #:to-unix-time
            #:ptr
            #:rfill #:rtrim 
-           #:loop-plist #:filter-plist #:plist-pairs #:plist-equal #:plist-add
+           #:loop-plist #:filter-plist #:map-plist 
+           #:plist-pairs #:plist-equal #:plist-add
            #:flatten-str #:from-keyword #:to-keyword #:to-integer #:to-string
            #:from-bytes #:to-bytes #:b64-decode #:b64-encode #:from-b64 #:to-b64
            #:absolute-dir #:check-dir #:ensure-dir #:home-path #:path-from-string
@@ -73,7 +74,10 @@
   `(loop for (,kvar ,vvar . nil) on ,plist by #'cddr ,@body))
 
 (defun filter-plist (pl keys)
-  (loop-plist pl k v when (find k keys) append (list k v)))
+  (loop-plist pl k v when (find k keys) nconc (list k v)))
+
+(defun map-plist (pl fn)
+  (loop-plist pl k v nconc (list k (funcall fn v))))
 
 (defun plist-pairs (pl)
   (loop-plist pl k v collect (list k v)))