# HG changeset patch # User Richard Westhaver # Date 1726453396 14400 # Node ID 3dd1924ad5eacd81a63b25b014f8af698b17b61e # Parent 119532882cb128c0362031b464b443a91e63c188 fixes diff -r 119532882cb1 -r 3dd1924ad5ea lisp/bin/skel.lisp --- a/lisp/bin/skel.lisp Sun Sep 15 19:34:00 2024 -0400 +++ b/lisp/bin/skel.lisp Sun Sep 15 22:23:16 2024 -0400 @@ -174,10 +174,9 @@ (t (skel-simple-error "unknown VC type")))) (defcmd skc-commit - ;; (debug! *optc* *argc*) (case (sk-vc-meta-kind (sk-vc (find-skelfile #P"." :load t))) - (:git (run-git-command "commit" *args* t)) - (:hg (run-hg-command "commit" *args* t)) + (:git (run-git-command "commit" (append '("-m") *args*) t)) + (:hg (run-hg-command "commit" (when *opts* ) t)) (t (skel-simple-error "unknown VC type")))) (defcmd skc-make @@ -227,7 +226,8 @@ (sb-impl::toplevel-repl nil)))) (defcmd skc-new - (trace! *args* *opts*)) + (println *args*) + (println *opts*)) (define-cli *skel-cli* :name "skel" @@ -275,7 +275,7 @@ :thunk skc-view) (:name make :description "build project targets" - :opts ((:name "target" :description "target to build" :kind string)) + :opts ((:name "target" :description "target to build" :kind string)) :thunk skc-make) (:name run :description "run a script or command" @@ -330,7 +330,8 @@ :thunk skc-clone) (:name commit :description "commit changes to the project vc" - :thunk skc-commit) + :thunk skc-commit + :opts ((:name "message" :description "commit message" :kind string))) (:name edit :description "edit a project file in emacs." :thunk skc-edit) diff -r 119532882cb1 -r 3dd1924ad5ea lisp/lib/cli/clap/cmd.lisp --- a/lisp/lib/cli/clap/cmd.lisp Sun Sep 15 19:34:00 2024 -0400 +++ b/lisp/lib/cli/clap/cmd.lisp Sun Sep 15 22:23:16 2024 -0400 @@ -13,9 +13,9 @@ ;; name slot is required and must be a string ((name :initarg :name :initform (required-argument :name) :accessor cli-name :type string) (opts :initarg :opts :initform (make-array 0 :element-type 'cli-opt :adjustable t) - :accessor cli-opts :type (vector cli-opt)) + :accessor opts :type (vector cli-opt)) (cmds :initarg :cmds :initform (make-array 0 :element-type 'cli-cmd :adjustable t) - :accessor cli-cmds :type (vector cli-cmd)) + :accessor cmds :type (vector cli-cmd)) (thunk :initform #'default-thunk :initarg :thunk :accessor cli-thunk :type function-lambda-expression) (lock :initform nil :initarg :lock :accessor cli-lock-p :type boolean) (description :initarg :description :accessor cli-description :type string) @@ -35,8 +35,8 @@ (print-unreadable-object (self stream :type t) (format stream "~A :opts ~A :cmds ~A :args ~A" (cli-name self) - (length (cli-opts self)) - (length (cli-cmds self)) + (length (opts self)) + (length (cmds self)) (length (cli-cmd-args self))))) (defmethod print-usage ((self cli-cmd) &optional stream) @@ -54,16 +54,16 @@ (format nil "~{!~A~}" (loop for c across cmds collect (print-usage c nil))))))) (defmethod push-cmd ((self cli-cmd) (place cli-cmd)) - (vector-push self (cli-cmds place))) + (vector-push self (cmds place))) (defmethod push-opt ((self cli-opt) (place cli-cmd)) - (vector-push self (cli-opts place))) + (vector-push self (opts place))) (defmethod pop-cmd ((self cli-cmd)) - (vector-pop (cli-cmds self))) + (vector-pop (cmds self))) (defmethod pop-opt ((self cli-opt)) - (vector-pop (cli-opts self))) + (vector-pop (opts self))) (defmethod handle-unknown-opt ((self cli-cmd) (opt string)) (with-opt-restart-case opt @@ -93,7 +93,7 @@ t)))))) (defmethod find-cmd ((self cli-cmd) name &optional active) - (when-let ((c (find name (cli-cmds self) :key #'cli-name :test #'string=))) + (when-let ((c (find name (cmds self) :key #'cli-name :test #'string=))) (if active ;; maybe issue warning here? report to user (when (cli-lock-p c) @@ -101,7 +101,7 @@ c))) (defmethod active-cmds ((self cli-cmd)) - (remove-if-not #'cli-lock-p (cli-cmds self))) + (remove-if-not #'cli-lock-p (cmds self))) (defmethod activate-cmd ((self cli-cmd)) (setf (cli-lock-p self) t)) @@ -109,10 +109,10 @@ (defmethod find-opts ((self cli-cmd) name &key active recurse) (let ((ret)) (flet ((%find (o obj) - (when-let ((found (find o (cli-opts obj) :key #'cli-opt-name :test 'equal))) + (when-let ((found (find o (opts obj) :key #'cli-opt-name :test 'equal))) (push found ret)))) - (when (and recurse (cli-cmds self)) - (loop for c across (cli-cmds self) + (when (and recurse (cmds self)) + (loop for c across (cmds self) do (%find name c))) (%find name self) (when active @@ -124,15 +124,15 @@ (if global #'active-global-opt-p #'cli-opt-lock) - (cli-opts self))) + (opts self))) (defmethod find-short-opts ((self cli-cmd) ch &key recurse) (let ((ret)) (flet ((%find (ch obj) - (when-let ((found (find ch (cli-opts obj) :key #'cli-opt-name :test #'opt-string-prefix-eq))) + (when-let ((found (find ch (opts obj) :key #'cli-opt-name :test #'opt-string-prefix-eq))) (push found ret)))) - (when (and recurse (cli-cmds self)) - (loop for c across (cli-cmds self) + (when (and recurse (cmds self)) + (loop for c across (cmds self) do (%find ch c))) (%find ch self) ret))) @@ -158,17 +158,18 @@ for (a . args) on args if skip do (setq skip nil) + ;; TODO 2024-09-15: handle flag groups -abcd else if (short-opt-p a) ;; SHORT OPT collect (if-let ((o (car (find-short-opts self (aref a 1) :recurse t)))) (%compose-short-opt o) - ;; TODO 2024-09-11: signal error? (with-opt-restart-case a (clap-unknown-argument a 'cli-opt))) else if (long-opt-p a) ;; LONG OPT collect - (let ((o (car (find-opts self (string-left-trim "-" a) :recurse t))) - (has-eq (long-opt-has-eq-p a))) + (let* ((has-eq (long-opt-has-eq-p a)) + (name (or (car has-eq) (string-left-trim "-" a))) + (o (car (find-opts self name :recurse t)))) (cond ((and has-eq o) (setf (cli-opt-val o) (cdr has-eq)) @@ -210,19 +211,22 @@ (activate-cmd self) (loop named install for (node . tail) on (ast ast) - until (null node) + while node do (let ((kind (cli-node-kind node)) (form (cli-node-form node))) (case kind ;; opts (opt (let ((name (cli-opt-name form))) + (when-let ((o (car (find-opts self name)))) + (log:trace! (format nil "installing opt ~A" name)) (setf o form) (setf (cli-opt-lock o) t)))) ;; when we encounter a command we recurse over the tail (cmd (when-let ((c (find-cmd self (cli-name form)))) + (log:trace! (format nil "installing cmd ~A" c)) ;; handle the rest of the AST (setf c (install-ast c (make-cli-ast tail))) (return-from install))) diff -r 119532882cb1 -r 3dd1924ad5ea lisp/lib/cli/clap/opt.lisp --- a/lisp/lib/cli/clap/opt.lisp Sun Sep 15 19:34:00 2024 -0400 +++ b/lisp/lib/cli/clap/opt.lisp Sun Sep 15 22:23:16 2024 -0400 @@ -105,9 +105,11 @@ (call-opt self (cli-opt-val self))) (defmethod do-opts ((self vector) &optional global) - (declare (ignore global)) (loop for opt across self - do (do-opt opt))) + do (if global + (when (cli-opt-global opt) + (do-opt opt)) + (do-opt opt)))) (defun active-global-opt-p (opt) "Return non-nil if OPT is active at runtime and global." diff -r 119532882cb1 -r 3dd1924ad5ea lisp/lib/rt/pkg.lisp --- a/lisp/lib/rt/pkg.lisp Sun Sep 15 19:34:00 2024 -0400 +++ b/lisp/lib/rt/pkg.lisp Sun Sep 15 22:23:16 2024 -0400 @@ -28,7 +28,6 @@ |# ;;; Code: (in-package :std-user) -(require 'sb-cover) (defpackage :rt (:use :cl :std :sxp :log diff -r 119532882cb1 -r 3dd1924ad5ea skelfile --- a/skelfile Sun Sep 15 19:34:00 2024 -0400 +++ b/skelfile Sun Sep 15 22:23:16 2024 -0400 @@ -137,9 +137,10 @@ (ql:quickload :core/tests) (in-package :core/tests) (compile-lisp :core/tests :save ".stash/tests.core"))) - (:compile () (compile-lisp :core/tests :force t :verbose t))) + (:compile () + (compile-lisp :core/tests :force t :verbose t))) (bench () (:compile () (compile-lisp :core/bench :force t :verbose t))) - (fasl (compile-core compile-tests compile-bench compile-user compile-prelude)) + (fasl (compile-core #+nil compile-tests compile-bench compile-user compile-prelude)) ;; rust (mailman () #$cd rust && cargo build -Z unstable-options --bin mailman --artifact-dir ../.stash/$#) (alik () #$cd rust && cargo build -Z unstable-options --bin alik --artifact-dir ../.stash/$#)