changelog shortlog graph tags branches files raw help

Mercurial > core / changeset: fixes

changeset 654: 3dd1924ad5ea
parent 653: 119532882cb1
child 655: 65102f74d1ae
author: Richard Westhaver <ellis@rwest.io>
date: Sun, 15 Sep 2024 22:23:16 -0400
files: lisp/bin/skel.lisp lisp/lib/cli/clap/cmd.lisp lisp/lib/cli/clap/opt.lisp lisp/lib/rt/pkg.lisp skelfile
description: fixes
     1.1--- a/lisp/bin/skel.lisp	Sun Sep 15 19:34:00 2024 -0400
     1.2+++ b/lisp/bin/skel.lisp	Sun Sep 15 22:23:16 2024 -0400
     1.3@@ -174,10 +174,9 @@
     1.4     (t (skel-simple-error "unknown VC type"))))
     1.5 
     1.6 (defcmd skc-commit
     1.7-  ;; (debug! *optc* *argc*)
     1.8   (case (sk-vc-meta-kind (sk-vc (find-skelfile #P"." :load t)))
     1.9-    (:git (run-git-command "commit" *args* t))
    1.10-    (:hg (run-hg-command "commit" *args* t))
    1.11+    (:git (run-git-command "commit" (append '("-m") *args*) t))
    1.12+    (:hg (run-hg-command "commit" (when *opts* ) t))
    1.13     (t (skel-simple-error "unknown VC type"))))
    1.14 
    1.15 (defcmd skc-make
    1.16@@ -227,7 +226,8 @@
    1.17       (sb-impl::toplevel-repl nil))))
    1.18 
    1.19 (defcmd skc-new
    1.20-  (trace! *args* *opts*))
    1.21+  (println *args*) 
    1.22+  (println *opts*))
    1.23 
    1.24 (define-cli *skel-cli*
    1.25   :name "skel"
    1.26@@ -275,7 +275,7 @@
    1.27           :thunk skc-view)
    1.28 	 (:name make
    1.29 	  :description "build project targets"
    1.30-	  :opts ((:name "target" :description "target to build" :kind string))
    1.31+          :opts ((:name "target" :description "target to build" :kind string))
    1.32 	  :thunk skc-make)
    1.33 	 (:name run
    1.34 	  :description "run a script or command"
    1.35@@ -330,7 +330,8 @@
    1.36           :thunk skc-clone)
    1.37 	 (:name commit
    1.38 	  :description "commit changes to the project vc"
    1.39-          :thunk skc-commit)
    1.40+          :thunk skc-commit
    1.41+          :opts ((:name "message" :description "commit message" :kind string)))
    1.42 	 (:name edit
    1.43 	  :description "edit a project file in emacs."
    1.44           :thunk skc-edit)
     2.1--- a/lisp/lib/cli/clap/cmd.lisp	Sun Sep 15 19:34:00 2024 -0400
     2.2+++ b/lisp/lib/cli/clap/cmd.lisp	Sun Sep 15 22:23:16 2024 -0400
     2.3@@ -13,9 +13,9 @@
     2.4   ;; name slot is required and must be a string
     2.5   ((name :initarg :name :initform (required-argument :name) :accessor cli-name :type string)
     2.6    (opts :initarg :opts :initform (make-array 0 :element-type 'cli-opt :adjustable t)
     2.7-         :accessor cli-opts :type (vector cli-opt))
     2.8+         :accessor opts :type (vector cli-opt))
     2.9    (cmds :initarg :cmds :initform (make-array 0 :element-type 'cli-cmd :adjustable t)
    2.10-         :accessor cli-cmds :type (vector cli-cmd))
    2.11+         :accessor cmds :type (vector cli-cmd))
    2.12    (thunk :initform #'default-thunk :initarg :thunk :accessor cli-thunk :type function-lambda-expression)
    2.13    (lock :initform nil :initarg :lock :accessor cli-lock-p :type boolean)
    2.14    (description :initarg :description :accessor cli-description :type string)
    2.15@@ -35,8 +35,8 @@
    2.16   (print-unreadable-object (self stream :type t)
    2.17     (format stream "~A :opts ~A :cmds ~A :args ~A"
    2.18             (cli-name self)
    2.19-            (length (cli-opts self))
    2.20-            (length (cli-cmds self))
    2.21+            (length (opts self))
    2.22+            (length (cmds self))
    2.23             (length (cli-cmd-args self)))))
    2.24 
    2.25 (defmethod print-usage ((self cli-cmd) &optional stream)
    2.26@@ -54,16 +54,16 @@
    2.27                 (format nil "~{!~A~}" (loop for c across cmds collect (print-usage c nil)))))))
    2.28 
    2.29 (defmethod push-cmd ((self cli-cmd) (place cli-cmd))
    2.30-  (vector-push self (cli-cmds place)))
    2.31+  (vector-push self (cmds place)))
    2.32 
    2.33 (defmethod push-opt ((self cli-opt) (place cli-cmd))
    2.34-  (vector-push self (cli-opts place)))
    2.35+  (vector-push self (opts place)))
    2.36 
    2.37 (defmethod pop-cmd ((self cli-cmd))
    2.38-  (vector-pop (cli-cmds self)))
    2.39+  (vector-pop (cmds self)))
    2.40 
    2.41 (defmethod pop-opt ((self cli-opt))
    2.42-  (vector-pop (cli-opts self)))
    2.43+  (vector-pop (opts self)))
    2.44 
    2.45 (defmethod handle-unknown-opt ((self cli-cmd) (opt string))
    2.46   (with-opt-restart-case opt
    2.47@@ -93,7 +93,7 @@
    2.48                  t))))))
    2.49 
    2.50 (defmethod find-cmd ((self cli-cmd) name &optional active)
    2.51-  (when-let ((c (find name (cli-cmds self) :key #'cli-name :test #'string=)))
    2.52+  (when-let ((c (find name (cmds self) :key #'cli-name :test #'string=)))
    2.53     (if active 
    2.54         ;; maybe issue warning here? report to user
    2.55         (when (cli-lock-p c)
    2.56@@ -101,7 +101,7 @@
    2.57         c)))
    2.58 
    2.59 (defmethod active-cmds ((self cli-cmd))
    2.60-  (remove-if-not #'cli-lock-p (cli-cmds self)))
    2.61+  (remove-if-not #'cli-lock-p (cmds self)))
    2.62 
    2.63 (defmethod activate-cmd ((self cli-cmd))
    2.64   (setf (cli-lock-p self) t))
    2.65@@ -109,10 +109,10 @@
    2.66 (defmethod find-opts ((self cli-cmd) name &key active recurse)
    2.67   (let ((ret))
    2.68     (flet ((%find (o obj)
    2.69-             (when-let ((found (find o (cli-opts obj) :key #'cli-opt-name :test 'equal)))
    2.70+             (when-let ((found (find o (opts obj) :key #'cli-opt-name :test 'equal)))
    2.71                (push found ret))))
    2.72-      (when (and recurse (cli-cmds self))
    2.73-        (loop for c across (cli-cmds self)
    2.74+      (when (and recurse (cmds self))
    2.75+        (loop for c across (cmds self)
    2.76               do (%find name c)))
    2.77       (%find name self)
    2.78       (when active
    2.79@@ -124,15 +124,15 @@
    2.80    (if global 
    2.81        #'active-global-opt-p
    2.82        #'cli-opt-lock)
    2.83-   (cli-opts self)))
    2.84+   (opts self)))
    2.85 
    2.86 (defmethod find-short-opts ((self cli-cmd) ch &key recurse)
    2.87   (let ((ret))
    2.88     (flet ((%find (ch obj)
    2.89-             (when-let ((found (find ch (cli-opts obj) :key #'cli-opt-name :test #'opt-string-prefix-eq)))
    2.90+             (when-let ((found (find ch (opts obj) :key #'cli-opt-name :test #'opt-string-prefix-eq)))
    2.91                (push found ret))))
    2.92-      (when (and recurse (cli-cmds self))
    2.93-        (loop for c across (cli-cmds self)
    2.94+      (when (and recurse (cmds self))
    2.95+        (loop for c across (cmds self)
    2.96               do (%find ch c)))
    2.97       (%find ch self)
    2.98       ret)))
    2.99@@ -158,17 +158,18 @@
   2.100      for (a . args) on args
   2.101      if skip
   2.102      do (setq skip nil)
   2.103+        ;; TODO 2024-09-15: handle flag groups -abcd
   2.104      else if (short-opt-p a) ;; SHORT OPT
   2.105      collect
   2.106         (if-let ((o (car (find-short-opts self (aref a 1) :recurse t))))
   2.107           (%compose-short-opt o)
   2.108-          ;;  TODO 2024-09-11: signal error?
   2.109           (with-opt-restart-case a
   2.110             (clap-unknown-argument a 'cli-opt)))
   2.111      else if (long-opt-p a) ;; LONG OPT
   2.112      collect           
   2.113-        (let ((o (car (find-opts self (string-left-trim "-" a) :recurse t)))
   2.114-              (has-eq (long-opt-has-eq-p a)))
   2.115+        (let* ((has-eq (long-opt-has-eq-p a))
   2.116+               (name (or (car has-eq) (string-left-trim "-" a)))
   2.117+               (o (car (find-opts self name :recurse t))))
   2.118           (cond
   2.119             ((and has-eq o)
   2.120              (setf (cli-opt-val o) (cdr has-eq))
   2.121@@ -210,19 +211,22 @@
   2.122     (activate-cmd self)
   2.123     (loop named install
   2.124           for (node . tail) on (ast ast)
   2.125-          until (null node)
   2.126+          while node
   2.127           do 
   2.128              (let ((kind (cli-node-kind node)) (form (cli-node-form node)))
   2.129                (case kind
   2.130                  ;; opts 
   2.131                  (opt
   2.132                   (let ((name (cli-opt-name form)))
   2.133+                    
   2.134                     (when-let ((o (car (find-opts self name))))
   2.135+                      (log:trace! (format nil "installing opt ~A" name))
   2.136                       (setf o form)
   2.137                       (setf (cli-opt-lock o) t))))
   2.138                  ;; when we encounter a command we recurse over the tail
   2.139                  (cmd 
   2.140                   (when-let ((c (find-cmd self (cli-name form))))
   2.141+                    (log:trace! (format nil "installing cmd ~A" c))
   2.142                     ;; handle the rest of the AST
   2.143                     (setf c (install-ast c (make-cli-ast tail)))
   2.144                     (return-from install)))
     3.1--- a/lisp/lib/cli/clap/opt.lisp	Sun Sep 15 19:34:00 2024 -0400
     3.2+++ b/lisp/lib/cli/clap/opt.lisp	Sun Sep 15 22:23:16 2024 -0400
     3.3@@ -105,9 +105,11 @@
     3.4   (call-opt self (cli-opt-val self)))
     3.5 
     3.6 (defmethod do-opts ((self vector) &optional global)
     3.7-  (declare (ignore global))
     3.8   (loop for opt across self
     3.9-        do (do-opt opt)))
    3.10+        do (if global 
    3.11+               (when (cli-opt-global opt)
    3.12+                 (do-opt opt))
    3.13+               (do-opt opt))))
    3.14 
    3.15 (defun active-global-opt-p (opt)
    3.16   "Return non-nil if OPT is active at runtime and global."
     4.1--- a/lisp/lib/rt/pkg.lisp	Sun Sep 15 19:34:00 2024 -0400
     4.2+++ b/lisp/lib/rt/pkg.lisp	Sun Sep 15 22:23:16 2024 -0400
     4.3@@ -28,7 +28,6 @@
     4.4 |#
     4.5 ;;; Code:
     4.6 (in-package :std-user)
     4.7-(require 'sb-cover)
     4.8 (defpackage :rt
     4.9   (:use 
    4.10    :cl :std :sxp :log
     5.1--- a/skelfile	Sun Sep 15 19:34:00 2024 -0400
     5.2+++ b/skelfile	Sun Sep 15 22:23:16 2024 -0400
     5.3@@ -137,9 +137,10 @@
     5.4                     (ql:quickload :core/tests)
     5.5                     (in-package :core/tests)
     5.6                     (compile-lisp :core/tests :save ".stash/tests.core")))
     5.7-        (:compile () (compile-lisp :core/tests :force t :verbose t)))
     5.8+        (:compile () 
     5.9+                  (compile-lisp :core/tests :force t :verbose t)))
    5.10  (bench () (:compile () (compile-lisp :core/bench :force t :verbose t)))
    5.11- (fasl (compile-core compile-tests compile-bench compile-user compile-prelude))
    5.12+ (fasl (compile-core #+nil compile-tests compile-bench compile-user compile-prelude))
    5.13  ;; rust
    5.14  (mailman () #$cd rust && cargo build -Z unstable-options --bin mailman --artifact-dir ../.stash/$#)
    5.15  (alik () #$cd rust && cargo build -Z unstable-options --bin alik --artifact-dir ../.stash/$#)