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/$#)