changelog shortlog graph tags branches files raw help

Mercurial > core / changeset: some optimizations, may have muddied the waters with cli-opt a bit though.. tbd

changeset 655: 65102f74d1ae
parent 654: 3dd1924ad5ea
child 656: b499d4bcfc39
author: Richard Westhaver <ellis@rwest.io>
date: Mon, 16 Sep 2024 21:28:33 -0400
files: emacs/lib/graph.el lisp/bin/skel.lisp lisp/lib/cli/clap/cli.lisp lisp/lib/cli/clap/cmd.lisp lisp/lib/cli/clap/macs.lisp lisp/lib/cli/clap/opt.lisp lisp/lib/cli/clap/pkg.lisp lisp/lib/cli/clap/proto.lisp
description: some optimizations, may have muddied the waters with cli-opt a bit though.. tbd
     1.1--- a/emacs/lib/graph.el	Sun Sep 15 22:23:16 2024 -0400
     1.2+++ b/emacs/lib/graph.el	Mon Sep 16 21:28:33 2024 -0400
     1.3@@ -111,10 +111,11 @@
     1.4 ;; See https://github.com/toshism/org-super-links/blob/develop/org-super-links.el
     1.5 (declare-function org-make-link-description-function "ext:org-mode")
     1.6 
     1.7-(defvar org-graph-edge-drawer "LINKS"
     1.8+(defvar org-graph-edge-drawer "EDGES"
     1.9   "Controls how/where to insert edges. If nil edges will just be inserted
    1.10 under the heading.")
    1.11 
    1.12+;; TODO 2024-09-16: edge properties
    1.13 (defvar org-graph-edge-prefix 'org-graph-edge-prefix-timestamp
    1.14   "Prefix to insert before the edge.
    1.15 This can be a string, nil, or a function that takes no arguments and
    1.16@@ -124,19 +125,22 @@
    1.17 which returns an inactive timestamp formatted according to the variable
    1.18 `org-time-stamp-formats' and a separator ' <- '.")
    1.19 
    1.20+;;  TODO 2024-09-16: do we need this? what sort of information for a
    1.21+;;  given edge would go in the postfix? this may be better suited as a
    1.22+;;  per-edge value rather than global - maybe use for comments.
    1.23 (defvar org-graph-edge-postfix nil
    1.24   "Postfix to insert after the edge.
    1.25 This can be a string, nil, or a function that takes no arguments and
    1.26 returns a string")
    1.27 
    1.28-(defvar org-graph-edge-related-into-drawer nil
    1.29+(defvar org-graph-edge-related-into-drawer t
    1.30     "Controls how/where to insert links.
    1.31 If non-nil a drawer will be created and links inserted there.  The
    1.32 default is `org-graph-edge-related-drawer-default-name'.  If this is set to a
    1.33 string a drawer will be created using that string.  For example LINKS.
    1.34 If nil links will just be inserted at point.")
    1.35 
    1.36-(defvar org-graph-edge-related-drawer-default-name "RELATED"
    1.37+(defvar org-graph-edge-related-drawer-default-name "EDGES"
    1.38   "Default name to use for link drawer.
    1.39 If variable `org-graph-edge-related-into-drawer' is 't' use this
    1.40 name for the drawer.  See variable `org-graph-edge-related-into-drawer' for more info.")
    1.41@@ -179,6 +183,16 @@
    1.42   "Hook called before storing the link on the backlink side.
    1.43 This is called with point in the heading of the backlink.")
    1.44 
    1.45+(defvar org-graph-edge-indicator-alist
    1.46+  '((link . "->")
    1.47+    (backlink . "<-")
    1.48+    (sibling . "--")
    1.49+    (parent . ">>")
    1.50+    (child . "<<"))
    1.51+  "An alist of (EDGE-TYPE . INDICATOR) pairs. Each INDICATOR is a string
    1.52+which will be printed between the properties and backlink of the
    1.53+associated EDGE-TYPE.")
    1.54+
    1.55 (defun org-graph-edge-get-location ()
    1.56   "Default for function `org-graph-edge-search-function' that reuses the `org-refile' machinery."
    1.57   (let ((target (org-refile-get-location "Node")))
    1.58@@ -213,6 +227,7 @@
    1.59         ((stringp org-graph-edge-link-postfix) org-graph-edge-link-postfix)
    1.60         (t (funcall org-graph-edge-link-postfix))))
    1.61 
    1.62+;; TODO 2024-09-16: edge-properties
    1.63 (defun org-graph-edge-prefix-timestamp ()
    1.64   "Return the default prefix string for an edge.
    1.65 Inactive timestamp formatted according to `org-time-stamp-formats' and
    1.66@@ -237,11 +252,8 @@
    1.67 used instead of the default value."
    1.68   (let ((p (org-entry-get nil "EDGE_DRAWER" 'inherit t)))
    1.69     (cond ((equal p "nil") nil)
    1.70-          ((equal p "t") "LINKS")
    1.71           ((stringp p) p)
    1.72-          (p "LINKS")
    1.73-          ((stringp org-graph-edge-drawer) org-graph-edge-drawer)
    1.74-          (org-graph-edge-drawer "LINKS"))))
    1.75+          (t org-graph-edge-drawer))))
    1.76 
    1.77 ;; delete related functions
    1.78 (defun org-graph-edge--find-link (id)
    1.79@@ -275,7 +287,6 @@
    1.80       (setq element (org-element-property :parent element)))
    1.81     element))
    1.82 
    1.83-
    1.84 (defun org-graph-edge--delete-link (link)
    1.85   "Delete the LINK.
    1.86 If point is in drawer, delete the entire line."
    1.87@@ -287,11 +298,7 @@
    1.88           (org-remove-empty-drawer-at (point)))
    1.89       (delete-region (org-element-property :begin link) (org-element-property :end link)))))
    1.90 
    1.91-
    1.92-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1.93-;; EXPERIMENTAL related into drawer
    1.94-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1.95-
    1.96+;;; EXPERIMENTAL 'related into drawer'
    1.97 (defun org-graph-edge-related-into-drawer ()
    1.98   "Name of the related drawer, as a string, or nil.
    1.99 This is the value of variable
   1.100@@ -306,13 +313,21 @@
   1.101           ((stringp org-graph-edge-related-into-drawer) org-graph-edge-related-into-drawer)
   1.102           (org-graph-edge-related-into-drawer org-graph-edge-related-drawer-default-name))))
   1.103 
   1.104-(defun org-graph-edge-insert-relatedlink (link desc)
   1.105+(defun org-graph-edge-link-prefix-timestamp ()
   1.106+  "Return the default prefix string for an edge.
   1.107+Inactive timestamp formatted according to `org-time-stamp-formats' and
   1.108+a separator ' -> '."
   1.109+  (concat (format-time-string (org-time-stamp-format t t) (current-time))
   1.110+          (format " %s " (cdr (assoc 'link org-graph-edge-indicator-alist)))))
   1.111+
   1.112+(defun org-graph-edge-insert-related-link (link desc)
   1.113   "LINK DESC related experiment."
   1.114   (if (org-graph-edge-related-into-drawer)
   1.115       (let* ((org-log-into-drawer (org-graph-edge-related-into-drawer))
   1.116              (beg (org-log-beginning t)))
   1.117         (goto-char beg)
   1.118         (insert (org-graph-edge-link-prefix))
   1.119+        (insert (org-graph-edge-link-prefix-timestamp))
   1.120         (org-insert-link nil link desc)
   1.121         (insert (org-graph-edge-link-postfix) "\n")
   1.122         (org-indent-region beg (point)))
   1.123@@ -320,13 +335,6 @@
   1.124     (org-insert-link nil link desc)
   1.125     (insert (org-graph-edge-link-postfix))))
   1.126 
   1.127-(defun org-graph-edge-link-prefix-timestamp ()
   1.128-  "Return the default prefix string for an edge.
   1.129-Inactive timestamp formatted according to `org-time-stamp-formats' and
   1.130-a separator ' -> '."
   1.131-  (concat (format-time-string (org-time-stamp-format t t) (current-time))
   1.132-        " -> "))
   1.133-
   1.134 (defun org-graph-edge-quick-insert-drawer-link ()
   1.135   "Insert link into drawer regardless of variable `org-graph-edge-related-into-drawer' value."
   1.136   (interactive)
   1.137@@ -343,9 +351,7 @@
   1.138         (org-graph-edge-link-prefix nil))
   1.139     (org-graph-edge-link)))
   1.140 
   1.141-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.142-;; /EXPERIMENTAL related into drawer
   1.143-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1.144+;; end
   1.145 
   1.146 (defun org-graph-edge-insert (link desc)
   1.147   "Insert edge to LINK with DESC.
   1.148@@ -400,11 +406,10 @@
   1.149       (with-current-buffer (marker-buffer source)
   1.150         (save-excursion
   1.151           (goto-char (marker-position source))
   1.152-          (org-graph-edge-insert-relatedlink (car target-formatted-link) (cdr target-formatted-link)))))))
   1.153-
   1.154+          (org-graph-edge-insert-related-link (car target-formatted-link) (cdr target-formatted-link)))))))
   1.155 
   1.156 ;;;###autoload
   1.157-(defun org-graph-edge-convert-link-to-edge (arg)
   1.158+(defun org-graph-edge-convert-link (arg)
   1.159   "Convert a normal `org-mode' link at `point' to a graph link, ARG prefix.
   1.160 If variable `org-graph-edge-related-into-drawer' is non-nil move
   1.161 the link into drawer.
   1.162@@ -428,7 +433,7 @@
   1.163       (delete-region begin end))))
   1.164 
   1.165 ;;;###autoload
   1.166-(defun org-graph-edge-delete-link ()
   1.167+(defun org-graph-edge-delete ()
   1.168   "Delete the link at point, and the corresponding reverse link.
   1.169 If no reverse link exists, just delete link at point.
   1.170 This works from either side, and deletes both sides of a link."
   1.171@@ -467,10 +472,6 @@
   1.172       (set-register ?^ c1)
   1.173       (message "Link copied"))))
   1.174 
   1.175-;; not sure if this should be autoloaded or left to config?
   1.176-;;;###autoload
   1.177-(advice-add 'org-capture :before #'org-graph-edge-store-link)
   1.178-
   1.179 ;;;###autoload
   1.180 (defun org-graph-edge-insert-link ()
   1.181   "Insert an edge link from the register."
   1.182@@ -484,7 +485,7 @@
   1.183 
   1.184 ;;;###autoload
   1.185 (defun org-graph-edge-link ()
   1.186-  "Insert a link and add a backlink to the target heading."
   1.187+  "Insert a link edge and add a backlink edge to the target heading."
   1.188   (interactive)
   1.189   (org-graph-edge-search-function))
   1.190 
     2.1--- a/lisp/bin/skel.lisp	Sun Sep 15 22:23:16 2024 -0400
     2.2+++ b/lisp/bin/skel.lisp	Mon Sep 16 21:28:33 2024 -0400
     2.3@@ -107,27 +107,27 @@
     2.4   (call-with-args :save *args*))
     2.5 
     2.6 (defun sk-slot-case (sel)
     2.7-  (std/string:string-case (sel :default (skel-simple-error "invalid slot"))
     2.8-    (":id" (std:format-sxhash (obj/id:id *skel-project*)))
     2.9-    (":name" (sk-name *skel-project*))
    2.10-    (":author" (sk-author *skel-project*))
    2.11-    (":version" (sk-version *skel-project*))
    2.12-    (":description" (sk-description *skel-project*))
    2.13-    (":tags" (sk-tags *skel-project*))
    2.14-    (":license" (sk-license *skel-project*))
    2.15-    (":vc" (sk-vc *skel-project*))
    2.16-    (":components" (sk-components *skel-project*))
    2.17-    (":scripts" (sk-scripts *skel-project*))
    2.18-    (":rules" (sk-rules *skel-project*))
    2.19-    (":phases" (hash-table-alist (sk-phases *skel-project*)))
    2.20-    (":env" (sk-env *skel-project*))
    2.21-    (":bind" (sk-bind *skel-project*))
    2.22-    (":include" (sk-include *skel-project*))
    2.23-    (":stash" (sk-stash *skel-project*))
    2.24-    (":store" (sk-store *skel-project*))
    2.25-    (":config" *skel-user-config*)
    2.26-    (":sys" *skel-system-config*)
    2.27-    (":cache" (sk-cache *skel-user-config*))))
    2.28+  (std/string:string-case ((string-left-trim ":" sel) :default (skel-simple-error "invalid slot"))
    2.29+    ("id" (std:format-sxhash (obj/id:id *skel-project*)))
    2.30+    ("name" (sk-name *skel-project*))
    2.31+    ("author" (sk-author *skel-project*))
    2.32+    ("version" (sk-version *skel-project*))
    2.33+    ("description" (sk-description *skel-project*))
    2.34+    ("tags" (sk-tags *skel-project*))
    2.35+    ("license" (sk-license *skel-project*))
    2.36+    ("vc" (sk-vc *skel-project*))
    2.37+    ("components" (sk-components *skel-project*))
    2.38+    ("scripts" (sk-scripts *skel-project*))
    2.39+    ("rules" (sk-rules *skel-project*))
    2.40+    ("phases" (hash-table-alist (sk-phases *skel-project*)))
    2.41+    ("env" (sk-env *skel-project*))
    2.42+    ("bind" (sk-bind *skel-project*))
    2.43+    ("include" (sk-include *skel-project*))
    2.44+    ("stash" (sk-stash *skel-project*))
    2.45+    ("store" (sk-store *skel-project*))
    2.46+    ("config" *skel-user-config*)
    2.47+    ("sys" *skel-system-config*)
    2.48+    ("cache" (sk-cache *skel-user-config*))))
    2.49 
    2.50 (defcmd skc-show
    2.51   (if *args*
    2.52@@ -344,11 +344,11 @@
    2.53   (let ((*log-level* :info))
    2.54     (in-readtable :shell)
    2.55     (with-cli (*skel-cli* opts cmds) (cli:args)
    2.56-      (debug-opts *cli*)
    2.57       (init-skel-vars)
    2.58       (when-let ((project (find-skelfile #P".")))
    2.59         (let ((*default-pathname-defaults* (pathname (directory-namestring project))))
    2.60           (setq *skel-project* (load-skelfile project))
    2.61           (setq *skel-path* (sk-src *skel-project*))
    2.62           (setq cli/shell:*shell-directory* (sk-src *skel-project*))))
    2.63-      (do-cmd *cli*))))
    2.64+      (do-cmd *cli*)
    2.65+      (debug-opts *cli*))))
     3.1--- a/lisp/lib/cli/clap/cli.lisp	Sun Sep 15 22:23:16 2024 -0400
     3.2+++ b/lisp/lib/cli/clap/cli.lisp	Mon Sep 16 21:28:33 2024 -0400
     3.3@@ -108,10 +108,6 @@
     3.4         (c (active-cmds cli)))
     3.5     (log:debug! :pwd (cli-cd cli) :active-opts o :cmd-args a :active-cmds c)))
     3.6 
     3.7-(defmethod do-opts ((self cli) &optional global)
     3.8-  (loop for opt across (active-opts self global)
     3.9-        do (do-opt opt)))
    3.10-
    3.11 (defmacro with-cli ((cli &rest slots) args &body body)
    3.12   "Like with-slots with some extra bindings.
    3.13 
     4.1--- a/lisp/lib/cli/clap/cmd.lisp	Sun Sep 15 22:23:16 2024 -0400
     4.2+++ b/lisp/lib/cli/clap/cmd.lisp	Mon Sep 16 21:28:33 2024 -0400
     4.3@@ -100,6 +100,10 @@
     4.4           c)
     4.5         c)))
     4.6 
     4.7+(defmethod (setf find-cmd) ((new cli-cmd) (self cli-cmd) name &optional active)
     4.8+  (let ((match (find-cmd self name active) ))
     4.9+    (substitute new match (cmds self) :test 'cli-equal)))
    4.10+
    4.11 (defmethod active-cmds ((self cli-cmd))
    4.12   (remove-if-not #'cli-lock-p (cmds self)))
    4.13 
    4.14@@ -119,6 +123,16 @@
    4.15         (setf ret (remove-if-not #'cli-lock-p ret)))
    4.16       ret)))
    4.17 
    4.18+(defmethod find-opt ((self cli-cmd) name &optional active)
    4.19+  (let ((ret (find name (opts self) :key #'cli-opt-name :test 'equal)))
    4.20+    (if active
    4.21+        (when (cli-opt-lock ret) ret)
    4.22+        ret)))
    4.23+
    4.24+(defmethod (setf find-opt) ((new cli-opt) (self cli-cmd) name &optional active)
    4.25+  (let ((match (find-opt self name active)))
    4.26+    (substitute new match (opts self) :test 'cli-equal)))
    4.27+
    4.28 (defmethod active-opts ((self cli-cmd) &optional global)
    4.29   (remove-if-not 
    4.30    (if global 
    4.31@@ -139,7 +153,7 @@
    4.32 
    4.33 (declaim (inline solop))
    4.34 (defun solop (self)
    4.35-  (and (= 0 (length (active-cmds self)) (length (active-opts self)))))
    4.36+  (= 0 (length (active-cmds self)) (length (active-opts self))))
    4.37 
    4.38 (defmacro with-opt-restart-case (arg condition)
    4.39   "Bind restarts 'use-as-arg' and 'discard-arg' for duration of BODY."
    4.40@@ -150,18 +164,20 @@
    4.41 (defmethod proc-args ((self cli-cmd) args)
    4.42   "Process ARGS into an ast. Each element of the ast is a node with a
    4.43 :kind slot, indicating the type of node and a :form slot which stores
    4.44-a value."
    4.45+an object."
    4.46   (make-cli-ast
    4.47    (loop
    4.48      with skip
    4.49-     for i below (length args)
    4.50+     with exit
    4.51      for (a . args) on args
    4.52      if skip
    4.53      do (setq skip nil)
    4.54-        ;; TODO 2024-09-15: handle flag groups -abcd
    4.55+     else if exit
    4.56+     do (return)
    4.57+     ;; TODO 2024-09-15: handle flag groups -abcd
    4.58      else if (short-opt-p a) ;; SHORT OPT
    4.59      collect
    4.60-        (if-let ((o (car (find-short-opts self (aref a 1) :recurse t))))
    4.61+        (if-let ((o (car (find-short-opts self (aref a 1) :recurse nil))))
    4.62           (%compose-short-opt o)
    4.63           (with-opt-restart-case a
    4.64             (clap-unknown-argument a 'cli-opt)))
    4.65@@ -169,7 +185,7 @@
    4.66      collect           
    4.67         (let* ((has-eq (long-opt-has-eq-p a))
    4.68                (name (or (car has-eq) (string-left-trim "-" a)))
    4.69-               (o (car (find-opts self name :recurse t))))
    4.70+               (o (car (find-opts self name :recurse nil))))
    4.71           (cond
    4.72             ((and has-eq o)
    4.73              (setf (cli-opt-val o) (cdr has-eq))
    4.74@@ -187,18 +203,17 @@
    4.75         (make-cli-node 'group nil)
    4.76      ;; OPT KEYWORD (experimental)
    4.77      else if (opt-keyword-p a)
    4.78-     collect (if-let ((o (car (find-opts self (string-left-trim ":" a) :recurse t))))
    4.79+     collect (if-let ((o (car (find-opts self (string-left-trim ":" a) :recurse nil))))
    4.80                (prog1 (%compose-keyword-opt o (pop args))
    4.81-                 (setq skip t))
    4.82+                 (setq exit t))
    4.83                (make-cli-node 'arg a))
    4.84      else ;; CMD or ARG
    4.85      collect
    4.86-        (let ((cmd (find-cmd self a)))
    4.87-          (if cmd
    4.88-              ;; CMD
    4.89-              (make-cli-node 'cmd cmd)
    4.90-              ;; ARG
    4.91-              (make-cli-node 'arg a))))))
    4.92+        (if-let ((cmd (find-cmd self a)))
    4.93+          (prog1 (make-cli-node 'cmd (parse-args cmd args :compile t))
    4.94+            (setq exit t))
    4.95+          ;; just a plain arg - move to next
    4.96+          (make-cli-node 'arg a)))))
    4.97 
    4.98 (defmethod install-ast ((self cli-cmd) (ast cli-ast))
    4.99   "Install the given AST, recursively filling in value slots."
   4.100@@ -213,23 +228,17 @@
   4.101           for (node . tail) on (ast ast)
   4.102           while node
   4.103           do 
   4.104-             (let ((kind (cli-node-kind node)) (form (cli-node-form node)))
   4.105+             (let ((kind (cli-node-kind node)) 
   4.106+                   (form (cli-node-form node)))
   4.107                (case kind
   4.108                  ;; opts 
   4.109                  (opt
   4.110-                  (let ((name (cli-opt-name form)))
   4.111-                    
   4.112-                    (when-let ((o (car (find-opts self name))))
   4.113-                      (log:trace! (format nil "installing opt ~A" name))
   4.114-                      (setf o form)
   4.115-                      (setf (cli-opt-lock o) t))))
   4.116-                 ;; when we encounter a command we recurse over the tail
   4.117-                 (cmd 
   4.118-                  (when-let ((c (find-cmd self (cli-name form))))
   4.119-                    (log:trace! (format nil "installing cmd ~A" c))
   4.120-                    ;; handle the rest of the AST
   4.121-                    (setf c (install-ast c (make-cli-ast tail)))
   4.122-                    (return-from install)))
   4.123+                  (setf #1=(find-opt self (cli-name form)) form)
   4.124+                  (activate-opt #1#)
   4.125+                  (log:trace! (format nil "installing opt ~A" (cli-name form))))
   4.126+                 (cmd
   4.127+                  (setf (find-cmd self (cli-name form)) form)
   4.128+                  (log:trace! (format nil "installing cmd ~A" (cli-name form))))
   4.129                  (arg (push-arg form self)))))
   4.130     (setf (cli-cmd-args self) (nreverse (cli-cmd-args self)))
   4.131     self))
   4.132@@ -258,10 +267,14 @@
   4.133   (trace! "calling command:" args opts)
   4.134   (funcall (cli-thunk self) args opts))
   4.135 
   4.136+(defmethod do-opts ((self cli-cmd) &optional global)
   4.137+  (do-opts (active-opts self) global))
   4.138+
   4.139 (defmethod do-cmd ((self cli-cmd))
   4.140-  "Perform the command, recursively calling child commands and opts if necessary."
   4.141-  (loop for o across (active-opts self)
   4.142-        do (do-opt o))
   4.143+  "Perform the active command or subcommand, recursively calling DO-CMD on
   4.144+subcommands until a level is reached which satisfies SOLOP. active OPTS are
   4.145+evaluated with DO-OPTS along the way."
   4.146+  (do-opts self)
   4.147   (if (solop self)
   4.148       (call-cmd self (cli-cmd-args self) (active-opts self))
   4.149       (loop for c across (active-cmds self)
     5.1--- a/lisp/lib/cli/clap/macs.lisp	Sun Sep 15 22:23:16 2024 -0400
     5.2+++ b/lisp/lib/cli/clap/macs.lisp	Mon Sep 16 21:28:33 2024 -0400
     5.3@@ -45,21 +45,19 @@
     5.4 
     5.5 ;; TODO fix these macros
     5.6 (defmacro defcmd (name &body body)
     5.7-  `(defun ,name (args opts) 
     5.8+  `(defun ,name (args opts)
     5.9      (declare (ignorable args opts)
    5.10               (sequence args opts))
    5.11-     (setq
    5.12-      *argc* (length args)
    5.13-      *optc* (length opts)
    5.14-      *args* args
    5.15-      *opts* opts)
    5.16-     ,@body))
    5.17+     (let ((*argc* (length args))
    5.18+           (*optc* (length opts))
    5.19+           (*args* args)
    5.20+           (*opts* opts))
    5.21+       ,@body)))
    5.22 
    5.23 (defmacro defopt (name &body body)
    5.24   `(defun ,name (&optional arg)
    5.25-     (declare (ignorable arg))
    5.26-     (setq *arg* arg)
    5.27-       ,@body))
    5.28+     (let ((*arg* arg))
    5.29+       ,@body)))
    5.30 
    5.31 ;; TODO 2023-10-06: 
    5.32 ;; (defmacro gen-cli-thunk (pvars &rest thunk)
     6.1--- a/lisp/lib/cli/clap/opt.lisp	Sun Sep 15 22:23:16 2024 -0400
     6.2+++ b/lisp/lib/cli/clap/opt.lisp	Mon Sep 16 21:28:33 2024 -0400
     6.3@@ -36,14 +36,17 @@
     6.4   ;; note that cli-opts can have a nil or unbound name slot
     6.5   (name "" :type string)
     6.6   (kind 'boolean :type (or symbol list))
     6.7-  (thunk nil :type (or null function symbol))
     6.8+  (thunk #'identity :type (or function symbol))
     6.9   (val nil)
    6.10   (global nil :type boolean)
    6.11   (description nil :type (or null string))
    6.12   (lock nil :type boolean))
    6.13 
    6.14+(defmethod cli-name ((self cli-opt))
    6.15+  (cli-opt-name self))
    6.16+
    6.17 (defmethod activate-opt ((self cli-opt))
    6.18-  (setf (cli-lock-p self) t))
    6.19+  (setf (cli-opt-lock self) t))
    6.20 
    6.21 (defun %compose-short-opt (o)
    6.22   (setf (cli-opt-val o) t)
    6.23@@ -64,7 +67,8 @@
    6.24 (defmethod initialize-instance :after ((self cli-opt) &key)
    6.25   (with-slots (name thunk) self
    6.26     (unless (stringp name) (setf name (format nil "~(~A~)" name)))
    6.27-    (when (symbolp thunk) (setf thunk (funcall (compile nil `(lambda () ,(symbol-function thunk))))))
    6.28+    ;; REVIEW 2024-09-16: 
    6.29+    (when (symbolp thunk) (setf thunk (symbol-function thunk)))
    6.30     self))
    6.31 
    6.32 (defmethod install-thunk ((self cli-opt) (lambda function) &optional compile)
    6.33@@ -98,11 +102,10 @@
    6.34            (equal kind bk)))))
    6.35 
    6.36 (defmethod call-opt ((self cli-opt) arg)
    6.37-  (when-let ((thunk (cli-opt-thunk self)))
    6.38-    (setf (cli-opt-val self) (funcall thunk arg))))
    6.39+  (funcall (cli-opt-thunk self) arg))
    6.40 
    6.41 (defmethod do-opt ((self cli-opt))
    6.42-  (call-opt self (cli-opt-val self)))
    6.43+  (setf (cli-opt-val self) (call-opt self (cli-opt-val self))))
    6.44 
    6.45 (defmethod do-opts ((self vector) &optional global)
    6.46   (loop for opt across self
     7.1--- a/lisp/lib/cli/clap/pkg.lisp	Sun Sep 15 22:23:16 2024 -0400
     7.2+++ b/lisp/lib/cli/clap/pkg.lisp	Mon Sep 16 21:28:33 2024 -0400
     7.3@@ -44,7 +44,8 @@
     7.4    :clap-missing-argument
     7.5    :clap-invalid-argument
     7.6    :activate-cmd
     7.7-   :activate-opt))
     7.8+   :activate-opt
     7.9+   :find-opt))
    7.10 
    7.11 (defpackage :cli/clap/ast
    7.12   (:use :cl :std :log :dat/sxp)
     8.1--- a/lisp/lib/cli/clap/proto.lisp	Sun Sep 15 22:23:16 2024 -0400
     8.2+++ b/lisp/lib/cli/clap/proto.lisp	Mon Sep 16 21:28:33 2024 -0400
     8.3@@ -35,6 +35,12 @@
     8.4 
     8.5 (defgeneric find-cmd (self name &optional active))
     8.6 
     8.7+(defgeneric (setf find-cmd) (new self name &optional active))
     8.8+
     8.9+(defgeneric find-opt (self name &optional active))
    8.10+
    8.11+(defgeneric (setf find-opt) (new self name &optional active))
    8.12+
    8.13 (defgeneric find-opts (self name &key active recurse))
    8.14 
    8.15 (defgeneric active-cmds (self))