changeset 655: | 65102f74d1ae |
parent: | af486e0a40c9 |
child: | 5e8b1855f866 |
author: | Richard Westhaver <ellis@rwest.io> |
date: | Mon, 16 Sep 2024 21:28:33 -0400 |
permissions: | -rw-r--r-- |
description: | some optimizations, may have muddied the waters with cli-opt a bit though.. tbd |
426
3e721a3349a0
completed phase2 of clap migration
Richard Westhaver <ellis@rwest.io>
parents:
419
diff
changeset
|
1 | ;;; cli/clap/cli.lisp --- Clap CLI Class |
419
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
2 | |
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
3 | ;; Top-level command object of a CLI App |
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
4 | |
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
5 | ;;; Code: |
426
3e721a3349a0
completed phase2 of clap migration
Richard Westhaver <ellis@rwest.io>
parents:
419
diff
changeset
|
6 | (in-package :cli/clap/obj) |
3e721a3349a0
completed phase2 of clap migration
Richard Westhaver <ellis@rwest.io>
parents:
419
diff
changeset
|
7 | |
3e721a3349a0
completed phase2 of clap migration
Richard Westhaver <ellis@rwest.io>
parents:
419
diff
changeset
|
8 | (defun make-cli (kind &rest slots) |
3e721a3349a0
completed phase2 of clap migration
Richard Westhaver <ellis@rwest.io>
parents:
419
diff
changeset
|
9 | "Creates a new CLI object of the given kind." |
3e721a3349a0
completed phase2 of clap migration
Richard Westhaver <ellis@rwest.io>
parents:
419
diff
changeset
|
10 | (declare (type (member :opt :cmd :cli t) kind)) |
3e721a3349a0
completed phase2 of clap migration
Richard Westhaver <ellis@rwest.io>
parents:
419
diff
changeset
|
11 | (cond |
3e721a3349a0
completed phase2 of clap migration
Richard Westhaver <ellis@rwest.io>
parents:
419
diff
changeset
|
12 | ((eql kind :cli) (apply #'make-instance 'cli slots)) |
3e721a3349a0
completed phase2 of clap migration
Richard Westhaver <ellis@rwest.io>
parents:
419
diff
changeset
|
13 | ((eql kind :opt) (apply #'make-cli-opt slots)) |
3e721a3349a0
completed phase2 of clap migration
Richard Westhaver <ellis@rwest.io>
parents:
419
diff
changeset
|
14 | ((eql kind :cmd) (apply #'make-instance 'cli-cmd slots)) |
3e721a3349a0
completed phase2 of clap migration
Richard Westhaver <ellis@rwest.io>
parents:
419
diff
changeset
|
15 | (t (apply #'make-instance kind slots)))) |
3e721a3349a0
completed phase2 of clap migration
Richard Westhaver <ellis@rwest.io>
parents:
419
diff
changeset
|
16 | |
584
35bb0d5ec95e
bug fixes, added freedesktop.org.xml rule. more work on prolog/dql - considering lib/lang+forrth..
Richard Westhaver <ellis@rwest.io>
parents:
580
diff
changeset
|
17 | (defmacro define-cli (sym &key name version description thunk opts cmds) |
426
3e721a3349a0
completed phase2 of clap migration
Richard Westhaver <ellis@rwest.io>
parents:
419
diff
changeset
|
18 | "Define a symbol NAME bound to a top-level CLI object." |
3e721a3349a0
completed phase2 of clap migration
Richard Westhaver <ellis@rwest.io>
parents:
419
diff
changeset
|
19 | (with-gensyms (%name %class) |
584
35bb0d5ec95e
bug fixes, added freedesktop.org.xml rule. more work on prolog/dql - considering lib/lang+forrth..
Richard Westhaver <ellis@rwest.io>
parents:
580
diff
changeset
|
20 | (if (atom sym) |
35bb0d5ec95e
bug fixes, added freedesktop.org.xml rule. more work on prolog/dql - considering lib/lang+forrth..
Richard Westhaver <ellis@rwest.io>
parents:
580
diff
changeset
|
21 | (setq %name sym |
426
3e721a3349a0
completed phase2 of clap migration
Richard Westhaver <ellis@rwest.io>
parents:
419
diff
changeset
|
22 | %class :cli) |
584
35bb0d5ec95e
bug fixes, added freedesktop.org.xml rule. more work on prolog/dql - considering lib/lang+forrth..
Richard Westhaver <ellis@rwest.io>
parents:
580
diff
changeset
|
23 | (setq %name (car sym) |
35bb0d5ec95e
bug fixes, added freedesktop.org.xml rule. more work on prolog/dql - considering lib/lang+forrth..
Richard Westhaver <ellis@rwest.io>
parents:
580
diff
changeset
|
24 | %class (cdr sym))) |
35bb0d5ec95e
bug fixes, added freedesktop.org.xml rule. more work on prolog/dql - considering lib/lang+forrth..
Richard Westhaver <ellis@rwest.io>
parents:
580
diff
changeset
|
25 | `(,*default-cli-def* ,%name (make-cli ,%class :name ,name |
35bb0d5ec95e
bug fixes, added freedesktop.org.xml rule. more work on prolog/dql - considering lib/lang+forrth..
Richard Westhaver <ellis@rwest.io>
parents:
580
diff
changeset
|
26 | :version ,version |
35bb0d5ec95e
bug fixes, added freedesktop.org.xml rule. more work on prolog/dql - considering lib/lang+forrth..
Richard Westhaver <ellis@rwest.io>
parents:
580
diff
changeset
|
27 | :description ,description |
35bb0d5ec95e
bug fixes, added freedesktop.org.xml rule. more work on prolog/dql - considering lib/lang+forrth..
Richard Westhaver <ellis@rwest.io>
parents:
580
diff
changeset
|
28 | :thunk ,thunk |
35bb0d5ec95e
bug fixes, added freedesktop.org.xml rule. more work on prolog/dql - considering lib/lang+forrth..
Richard Westhaver <ellis@rwest.io>
parents:
580
diff
changeset
|
29 | :opts (make-opts ',opts) |
35bb0d5ec95e
bug fixes, added freedesktop.org.xml rule. more work on prolog/dql - considering lib/lang+forrth..
Richard Westhaver <ellis@rwest.io>
parents:
580
diff
changeset
|
30 | :cmds (make-cmds ',cmds))))) |
426
3e721a3349a0
completed phase2 of clap migration
Richard Westhaver <ellis@rwest.io>
parents:
419
diff
changeset
|
31 | |
651
af486e0a40c9
multi-binaries, working on removing x.lisp
Richard Westhaver <ellis@rwest.io>
parents:
647
diff
changeset
|
32 | (defmacro defmain (name (&key (exit t)) &body body) |
426
3e721a3349a0
completed phase2 of clap migration
Richard Westhaver <ellis@rwest.io>
parents:
419
diff
changeset
|
33 | "Define a CLI main function in the current package." |
651
af486e0a40c9
multi-binaries, working on removing x.lisp
Richard Westhaver <ellis@rwest.io>
parents:
647
diff
changeset
|
34 | `(let ((*no-exit* ,(not exit))) |
af486e0a40c9
multi-binaries, working on removing x.lisp
Richard Westhaver <ellis@rwest.io>
parents:
647
diff
changeset
|
35 | (defun ,name () |
af486e0a40c9
multi-binaries, working on removing x.lisp
Richard Westhaver <ellis@rwest.io>
parents:
647
diff
changeset
|
36 | "Run the top-level function and print to *STDOUT*." |
af486e0a40c9
multi-binaries, working on removing x.lisp
Richard Westhaver <ellis@rwest.io>
parents:
647
diff
changeset
|
37 | (with-cli-handlers |
af486e0a40c9
multi-binaries, working on removing x.lisp
Richard Westhaver <ellis@rwest.io>
parents:
647
diff
changeset
|
38 | (progn |
af486e0a40c9
multi-binaries, working on removing x.lisp
Richard Westhaver <ellis@rwest.io>
parents:
647
diff
changeset
|
39 | ,@body))))) |
426
3e721a3349a0
completed phase2 of clap migration
Richard Westhaver <ellis@rwest.io>
parents:
419
diff
changeset
|
40 | |
3e721a3349a0
completed phase2 of clap migration
Richard Westhaver <ellis@rwest.io>
parents:
419
diff
changeset
|
41 | ;; RESEARCH 2023-09-12: closed over hash-table with short/long flags |
3e721a3349a0
completed phase2 of clap migration
Richard Westhaver <ellis@rwest.io>
parents:
419
diff
changeset
|
42 | ;; to avoid conflicts. if not, need something like a flag-function |
3e721a3349a0
completed phase2 of clap migration
Richard Westhaver <ellis@rwest.io>
parents:
419
diff
changeset
|
43 | ;; slot at class allocation. |
584
35bb0d5ec95e
bug fixes, added freedesktop.org.xml rule. more work on prolog/dql - considering lib/lang+forrth..
Richard Westhaver <ellis@rwest.io>
parents:
580
diff
changeset
|
44 | (defun make-opts (opts) |
426
3e721a3349a0
completed phase2 of clap migration
Richard Westhaver <ellis@rwest.io>
parents:
419
diff
changeset
|
45 | "Make a vector of CLI-OPTs based on OPTS." |
567 | 46 | (map 'vector |
47 | (lambda (x) |
|
48 | (etypecase x |
|
49 | (string (make-cli-opt :name x)) |
|
50 | (list (apply #'make-cli :opt x)) |
|
51 | (t (make-cli :opt :name (format nil "~(~A~)" x) :global t)))) |
|
52 | opts)) |
|
426
3e721a3349a0
completed phase2 of clap migration
Richard Westhaver <ellis@rwest.io>
parents:
419
diff
changeset
|
53 | |
644
f59072409c7a
revert cli-cmds back to list instead of &rest
Richard Westhaver <ellis@rwest.io>
parents:
643
diff
changeset
|
54 | (defun make-cmds (cmds) |
426
3e721a3349a0
completed phase2 of clap migration
Richard Westhaver <ellis@rwest.io>
parents:
419
diff
changeset
|
55 | "Make a vector of CLI-CMDs based on CMDS." |
567 | 56 | (map 'vector |
647 | 57 | (lambda (x) |
58 | (etypecase x |
|
59 | (cli-cmd x) |
|
60 | (string (make-cli :cmd :name x)) |
|
61 | (list (apply #'make-cli :cmd x)) |
|
62 | (t (make-cli :cmd :name (format nil "~(~A~)" x))))) |
|
63 | cmds)) |
|
419
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
64 | |
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
65 | (defclass cli (cli-cmd) |
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
66 | ;; name slot defaults to *package*, must be string |
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
67 | ((name :initarg :name :initform (string-downcase (package-name *package*)) :accessor cli-name :type string) |
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
68 | (version :initarg :version :initform "0.1.0" :accessor cli-version :type string) |
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
69 | ;; TODO 2023-10-11: look into pushd popd - cd-stack? |
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
70 | (cd :initarg :cd :initform (sb-posix:getcwd) :type string :accessor cli-cd |
647 | 71 | :documentation "working directory of the top-level CLI.")) |
419
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
72 | (:documentation "CLI")) |
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
73 | |
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
74 | (defmethod print-usage ((self cli) &optional stream) |
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
75 | (iprintln (format nil "usage: ~A [global] <command> [<arg>]~%" (cli-name self)) 2 stream)) |
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
76 | |
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
77 | (defmethod print-version ((self cli) &optional stream) |
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
78 | (println (cli-version self) stream)) |
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
79 | |
643
f901de70a80e
opt fixes and test updates
Richard Westhaver <ellis@rwest.io>
parents:
626
diff
changeset
|
80 | (defmethod print-help ((self cli) &optional (stream t)) |
419
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
81 | (println (format nil "~A v~A --- ~A~%" (cli-name self) (cli-version self) (cli-description self)) stream) |
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
82 | (print-usage self stream) |
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
83 | ;; (terpri stream) |
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
84 | (println "options:" stream) |
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
85 | (with-slots (opts cmds) self |
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
86 | (unless (null opts) |
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
87 | (loop for o across opts |
643
f901de70a80e
opt fixes and test updates
Richard Westhaver <ellis@rwest.io>
parents:
626
diff
changeset
|
88 | do (iprintln (print-usage o nil) 2 stream))) |
419
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
89 | (terpri stream) |
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
90 | (println "commands:" stream) |
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
91 | (unless (null cmds) |
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
92 | (loop for c across cmds |
643
f901de70a80e
opt fixes and test updates
Richard Westhaver <ellis@rwest.io>
parents:
626
diff
changeset
|
93 | do (iprintln (print-usage c nil) 2 stream))))) |
419
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
94 | |
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
95 | (defmethod cli-equal :before ((a cli) (b cli)) |
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
96 | "Return T if A is the same cli object as B. |
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
97 | |
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
98 | Currently this function is intended only for instances of the CLI |
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
99 | class and is used as a specialized EQL for DEFINE-CONSTANT." |
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
100 | (with-slots (version) a |
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
101 | (with-slots ((bv version)) b |
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
102 | (string= version bv)))) |
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
103 | |
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
104 | (declaim (inline debug-opts)) |
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
105 | (defun debug-opts (cli) |
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
106 | (let ((o (active-opts cli)) |
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
107 | (a (cli-cmd-args cli)) |
0f0e5f9b5c55
add emacs/babel.org, finished clap refactor phase 1, test system fixes and more top-level packages
Richard Westhaver <ellis@rwest.io>
parents:
404
diff
changeset
|
108 | (c (active-cmds cli))) |
623 | 109 | (log:debug! :pwd (cli-cd cli) :active-opts o :cmd-args a :active-cmds c))) |
426
3e721a3349a0
completed phase2 of clap migration
Richard Westhaver <ellis@rwest.io>
parents:
419
diff
changeset
|
110 | |
647 | 111 | (defmacro with-cli ((cli &rest slots) args &body body) |
560
b9c64be96888
make cli/clap more dynamic
Richard Westhaver <ellis@rwest.io>
parents:
426
diff
changeset
|
112 | "Like with-slots with some extra bindings. |
b9c64be96888
make cli/clap more dynamic
Richard Westhaver <ellis@rwest.io>
parents:
426
diff
changeset
|
113 | |
b9c64be96888
make cli/clap more dynamic
Richard Westhaver <ellis@rwest.io>
parents:
426
diff
changeset
|
114 | SLOTS is a list passed to WITH-SLOTS. |
b9c64be96888
make cli/clap more dynamic
Richard Westhaver <ellis@rwest.io>
parents:
426
diff
changeset
|
115 | |
647 | 116 | CLI is updated based on the current environment and dynamically bound |
117 | to *CLI*. ARGS is a list of CLI args, defaults to *POSIX-ARGV* at |
|
118 | runtime if nil." |
|
426
3e721a3349a0
completed phase2 of clap migration
Richard Westhaver <ellis@rwest.io>
parents:
419
diff
changeset
|
119 | `(progn |
647 | 120 | (let ((*cli* ,cli)) |
121 | (setf (cli-cd *cli*) *default-pathname-defaults*) |
|
122 | (with-slots ,slots (parse-args *cli* ,args :compile t) |
|
123 | ,@body)))) |