Coverage report: /home/ellis/comp/core/lib/cli/clap/macs.lisp

KindCoveredAll%
expression51268 19.0
branch044 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; cli/clap/macs.lisp --- Clap Macros
2
 
3
 ;; 
4
 
5
 ;;; Code:
6
 (in-package :cli/clap/macs)
7
 
8
 (defmacro argp (arg &optional (args (args)))
9
   "Test for presence of ARG in ARGS. Return the tail of
10
 ARGS starting from the position of ARG."
11
   `(member ,arg ,args :test 'equal))
12
 
13
 (defmacro make-shorty (name)
14
   "Return the first char of symbol or string NAME."
15
   `(character (aref (if (stringp ,name) ,name (symbol-name ,name)) 0)))
16
 
17
 (defmacro with-cli-handlers (&body body)
18
   "A wrapper which handles common cli errors that may occur during
19
 evaluation of BODY."
20
   `(progn
21
      (if *no-debug*
22
          (sb-ext:disable-debugger)
23
          (sb-ext:enable-debugger))
24
      (unwind-protect
25
           (restart-case 
26
               (handler-case (progn ,@body)
27
                 (sb-sys:interactive-interrupt (c)
28
                   (if *no-debug*
29
                       (sb-ext:exit :code 130)
30
                       c))
31
                 (error (c)
32
                   (println c)
33
                   (sb-ext:exit :code 1)))
34
             (abort ()
35
               :report (lambda (s)
36
                         (write-string
37
                          "Skip to toplevel READ/EVAL/PRINT loop."
38
                          s)
39
                         (log:debug! "CONTINUEing from pre-REPL RESTART-CASE")
40
                         (values)))
41
             (exit ()
42
               :report "Exit SBCL (calling #'EXIT, killing the process)."
43
               ;; :test (lambda (c) (declare (ignore c)) t)
44
               (log:debug! "falling through to EXIT from pre-REPL RESTART-CASE~&")
45
               (exit :code 1))))
46
      (sb-impl::flush-standard-output-streams)
47
      (unless *no-exit*
48
        (exit :code 0))
49
      ;; reset terminal state
50
      #+nil (.ris)))
51
 
52
 (define-constant +cli-lambda-list-keywords+ '(&rest &optional &opt &key) :test 'equal)
53
 
54
 ;; TODO 2025-01-05: env? for shell env
55
 (defun parse-cli-lambda-list (ll)
56
   "Parse a specialized CLI lambda-list, returning as multiple values:
57
 
58
 - required ARGs
59
 - optional ARGs
60
 - rest ARG
61
 - OPTs
62
 - key OPTs"
63
   (let ((state :required)
64
         (required)
65
         (optional)
66
         (rest)
67
         (opts)
68
         (key-opts))
69
     (labels ((%fail (l)
70
                (simple-program-error "Misplaced ~S in ordinary lambda-list:~%  ~S"
71
                                      l ll))
72
              (%check-var (l what)
73
                (unless (and (or (symbolp l)
74
                                 (and (consp l) (= 2 (length l)) (symbolp (first l))))
75
                             (not (constantp l)))
76
                  (simple-program-error "Invalid ~A ~S in ordinary lambda-list:~%  ~S"
77
                                        what l ll)))
78
              (%check-spec (spec what)
79
                (destructuring-bind (init suppliedp) spec
80
                  (declare (ignore init))
81
                  (%check-var suppliedp what))))
82
       (dolist (l ll)
83
         (case l
84
           (&optional
85
            (if (eq state :required)
86
                (setf state l)
87
                (%fail l)))
88
           (&rest
89
            (if (member state '(:required &optional))
90
                (setf state l)
91
                (%fail l)))
92
           (&opt
93
            (if (member state '(:required &optional :after-rest &key))
94
                (setf state l)
95
                (%fail l)))
96
           (&key
97
            (if (member state '(:required &optional :after-rest &opt))
98
                (setf state l)
99
                (%fail l)))
100
           (t
101
            (when (member l '#.(set-difference lambda-list-keywords
102
                                               '(&optional &rest &key &allow-other-keys &aux &opt)))
103
              (simple-program-error
104
               "Bad lambda-list keyword ~S in ordinary lambda-list:~%  ~S"
105
               l ll))
106
            (case state
107
              (:required
108
               (%check-var l "required parameter")
109
               (push l required))
110
              (&optional
111
               (if (consp l)
112
                   (destructuring-bind (name &rest tail) l
113
                     (%check-var name "optional parameter")
114
                     (cond ((cdr tail)
115
                            (%check-spec tail "optional-supplied-p parameter"))))
116
                   (%check-var l "optional parameter"))
117
               (push (ensure-list l) optional))
118
              (&opt
119
               (if (consp l)
120
                   (destructuring-bind (name &rest tail) l
121
                     (%check-var name "opt parameter")
122
                     (when (cdr tail) (%check-spec tail "opt parameter")))
123
                   (%check-var l "opt parameter"))
124
               (push (ensure-list l) opts))
125
              (&rest
126
               (%check-var l "rest parameter")
127
               (setf rest l
128
                     state :after-rest))
129
              (&key
130
               (if (consp l)
131
                   (destructuring-bind (var-or-kv &rest tail) l
132
                     (if (consp var-or-kv)
133
                         (destructuring-bind (keyword var) var-or-kv
134
                           (unless (symbolp keyword)
135
                             (simple-program-error "Invalid key name ~S in ordinary ~
136
                                                          lambda-list:~%  ~S"
137
                                                   keyword ll))
138
                           (%check-var var "key parameter"))
139
                         (%check-var var-or-kv "key parameter"))
140
                     (when (cdr tail)
141
                       (%check-spec tail "key parameter"))
142
                     (setf l (cons var-or-kv tail)))
143
                   (%check-var l "key parameter"))
144
               (push (ensure-list l) key-opts))
145
              (t (simple-program-error "invalid cli lambda-list:~%  ~S" ll)))))))
146
     (values (nreverse required) 
147
             (nreverse optional) 
148
             rest 
149
             (nreverse opts)
150
             (nreverse key-opts))))
151
 
152
 #+nil (parse-cli-lambda-list '(arg1 arg2 &optional (arg3 "foo") &rest rest &opt opt1 opt2 &key key1 key2))
153
 
154
 ;; DEFCMD always returns a function of two argument ARGS and OPTS - the
155
 ;; cli-lambda-list is applied to the BODY instead of closing over the
156
 ;; function.
157
 (defmacro defcmd (name cli-lambda-list &body body)
158
   "Bind NAME to a functions which accepts a CLI-LAMBDA-LIST containing a
159
 specialized lambda-list with the following keywords:
160
 
161
 - &OPTIONAL is an optional positional argument in ARGS
162
 - &REST specifies the remainder of the ARGS passed at the CLI
163
 - &OPT specifies a set of cli options
164
 - &KEY specifies a set of cli keywords
165
 
166
 CLI-LAMBDA-LIST is a list which automatically selects and binds the values of
167
 parsed CLI-OPTs to a name via SYMBOL-MACROLET. The forms accepted are the same
168
 as the SLOTS args to WITH-SLOTS - the CAR is used as the name of the local
169
 symbol binding and the CDR is the actual name of the CLI-OPT.
170
 
171
 The following special variables are bound for the duration of BODY:
172
 
173
 - *ARGC* : the count of arguments passed to this command
174
 - *ARGS* : the actual list of args
175
 - *OPTC* : the count of options passed to this command
176
 - *OPTS* : the actual list of options"
177
   (multiple-value-bind (required optional rest opts keys) (parse-cli-lambda-list cli-lambda-list)
178
     (multiple-value-bind (body decl doc-string) (parse-body body :documentation t)
179
       `(defun ,name (args opts)
180
          ,(let ((%d '(ignorable args opts)))
181
             (if decl 
182
                 (append decl (list %d))
183
                 `(declare ,%d)))
184
          ,doc-string
185
          (let ((*argc* (length args))
186
                (*optc* (length opts))
187
                (*args* args)
188
                (*opts* opts))
189
            (symbol-macrolet
190
                ,(mapcar (lambda (x)
191
                           (unless (typep x
192
                                          '(or symbol
193
                                            (cons symbol (cons symbol null))))
194
                             (error "Malformed CLI-OPT binding: ~s, should either a symbol or (variable-name opt-name)" x))
195
                           (destructuring-bind (name &optional (opt-name name)) (ensure-list x)
196
                             `(,name
197
                               (when-let ((val (find ,(string-downcase opt-name) *opts* 
198
                                                     :test 'equal
199
                                                     :key 'cli/clap/obj:cli-opt-name)))
200
                                 (cli-opt-val val)))))
201
                  opts)
202
              ,@body))))))
203
 
204
 ;; DEFOPTS are much simpler - they always take a single optional argument and
205
 ;; have no lambda-list that needs to be applied.
206
 (defmacro defopt (name &body body)
207
   (multiple-value-bind (body decl doc-string) (parse-body body :documentation t)
208
     `(defun ,name (&optional arg)
209
        ,(let ((%d '(ignorable arg)))
210
           (if decl 
211
               (append decl (list %d))
212
               `(declare ,%d)))
213
        ,@(when doc-string (list doc-string))
214
        (let ((*arg* arg))
215
          ,@body))))
216
 
217
 (defmacro defopts (&body body)
218
   (unless (null body)
219
     `(progn ,@(mapcar (lambda (x) `((defopt ,@x))) body))))
220
 
221
 ;; TODO 2023-10-06: 
222
 ;; (defmacro gen-cli-thunk (pvars &rest thunk)
223
 ;;   "Generate and return a function based on THUNK suitable for the :thunk
224
 ;; slot of cli objects with pandoric bindings PVARS.")
225
 
226
 (defmacro make-opt-parser (kind-spec &body body)
227
   "Return a KIND-opt-parser function based on KIND-SPEC which is either a
228
 symbol from *CLI-OPT-KINDS* or a list, and optional BODY which
229
 is a list of handlers for the opt-val."
230
   (let* ((kind (if (consp kind-spec) (car kind-spec) kind-spec))
231
          (super (when (consp kind-spec) (cadr kind-spec)))
232
          (fn-name (symbolicate 'parse- kind '-opt)))
233
     ;; thread em
234
     (let ((fn1 (unless (null super) (symbolicate "PARSE-" super "-OPT"))))
235
       `(defun ,fn-name (&optional arg)
236
          "Parse the cli-opt-val *ARG*."
237
          (declare (ignorable arg))
238
          ,@(if fn1
239
                `((setf *arg* (funcall #',fn1 arg)))
240
                `((setf *arg* arg)))
241
          ,@body))))