Mercurial > core / lisp/lib/cli/pkg.lisp
changeset 96: |
301fd45bbe73 |
child: |
6e5caf0c68a1 |
author: |
ellis <ellis@rwest.io> |
date: |
Wed, 13 Dec 2023 20:02:36 -0500 |
permissions: |
-rw-r--r-- |
description: |
big refactor of lisp code |
1 ;;; cli.lisp --- cli programming api and utils 3 ;; This package contains a simple api and macros for building lisp CLI 8 ;; - inspired by: clingon, uiop 10 ;; Basic assumptions at runtime: 11 ;; - running in a POSIX-compliant shell 12 ;; - output stream supports UTF-8 14 ;; TODO 2023-10-14: install-ast, install-thunk, proc-args, etc should 15 ;; return IR types - CLI-IR THUNK and CLI-IR respectively. 17 ;; TODO 2023-10-14: rename cli-ast to cli-ir, install-ast to 21 (uiop:define-package :cli 22 (:use :cl :std :log :sb-ext) 23 (:import-from :uiop :println) 24 (:import-from :sb-ext :parse-native-namestring) 25 (:shadowing-import-from :sb-ext :exit) 32 :*cli-group-separator* 83 :handle-unknown-argument 84 :handle-missing-argument 85 :handle-invalid-argument 118 (defun cli-arg0 () (car sb-ext:*posix-argv*)) 119 (defun cli-args () (cdr sb-ext:*posix-argv*)) 121 (declaim (inline exec-path-list)) 122 (defun exec-path-list () 123 "Return a list of all members of PATH" 124 (let ((var (sb-posix:getenv "PATH"))) 125 (let ((lst (loop for i = 0 then (1+ j) 126 as j = (position #\: var :start i) 127 when (uiop:directory-exists-p (probe-file (subseq var i j))) 128 collect (probe-file (subseq var i j)) 130 (unless (null (car lst)) 131 (mapcar (lambda (x) (car (directory x))) 134 (defun program-list () 135 "Return a fresh list of all files in PATH directories." 136 (loop for p in (exec-path-list) 137 append (uiop:directory-files p))) 139 (defun find-exe (name &optional programs) 140 "Find NAME in list of PROGRAMS, defaulting to the result of #'program-list." 141 (find name (or programs (program-list)) 143 :key #'pathname-name)) 145 (defun open-with-editor (path &key editor args) 146 (unless editor (setq editor (or (sb-posix:getenv "EDITOR") (find-exe "emacs")))) 147 (run-program editor (nconc args (list path)))) 149 (declaim (inline ld-library-path-list)) 150 (defun ld-library-path-list () 151 (let ((var (sb-posix:getenv "LD_LIBRARY_PATH"))) 152 (let ((lst (loop for i = 0 then (1+ j) 153 as j = (position #\: var :start i) 154 collect (subseq var i j) 156 (unless (null (car lst)) 157 (mapcar (lambda (x) (car (directory x))) lst))))) 159 (defparameter *cli-group-separator* 161 "A marker specifying the end of a unique group of CLI args.") 163 ;; uiop:command-line-arguments 166 (defmacro argp (arg &optional (args (cli-args))) 167 "Test for presence of ARG in ARGS. Return the tail of 168 ARGS starting from the position of ARG." 169 `(member ,arg ,args :test #'string=)) 171 (defmacro make-shorty (name) 172 "Return the first char of symbol or string NAME." 173 `(character (aref (if (stringp ,name) ,name (symbol-name ,name)) 0))) 175 ;; (defun treat-as-argument (condition) 176 ;; "A handler which can be used to invoke the `treat-as-argument' restart" 177 ;; (invoke-restart (find-restart 'treat-as-argument condition))) 179 ;; (defun discard-argument (condition) 180 ;; "A handler which can be used to invoke the `discard-argument' restart" 181 ;; (invoke-restart (find-restart 'discard-argument condition))) 183 (defmacro with-cli-handlers (form) 184 "A wrapper which handles common cli errors that may occur during 187 (sb-sys:interactive-interrupt () 188 (format *error-output* "~&(:SIGINT)~&") 191 (format *error-output* "~&~A~&" c) 194 (defun init-args () (setq *argv* (cons (cli-arg0) (cli-args)))) 196 (defmacro with-cli (slots cli &body body) 197 "Like with-slots with some extra bindings." 198 ;; (with-gensyms (cli-body) 199 ;; (let ((cli-body (mapcar (lambda (x) ()) cli-body) 202 (setf (cli-cwd ,cli) (sb-posix:getcwd)) 203 (with-slots ,slots (parse-args ,cli *argv* :compile t) 207 (declaim (inline completing-read)) 208 (defun completing-read (prompt collection 209 &key (history nil) (default nil) 210 (key nil) (test nil)) 212 "A simplified COMPLETING-READ for common-lisp. 214 The Emacs completion framework includes a function called 215 `completing-read' which prompts the user for input from the 216 mini-buffer. It is a very flexible interface which can be used to read 217 user input programatically. This is incredibly useful for building 218 data entry interfaces -- for example see the `defprompt' macro. 220 Obviously writing a completion framework is out-of-scope, but we can 221 simulate one by embedding a DSL in our prompters if we choose. For 222 example, perhaps we treat a single '?' character as a request from the 223 user to list valid options while continue waiting for input." 225 ;; ensure we empty internal buffer 227 (let* ((coll (symbol-value collection)) 229 (find (read-line) coll :key key :test test) 230 (or (read-line) default)))) 233 (setf (symbol-value history) (push r history))))) 235 (defmacro defprompt (var &optional prompt) 236 "Generate a 'prompter' from list or variable VAR and optional 239 This isn't an ideal solution as it does in fact expose a dynamic 240 variable (VAR-prompt-history). We should generate accessors and 241 keep the variables within lexical scope of the generated 243 (with-gensyms (s p h) 244 `(let ((,s (if (boundp ',var) (symbol-value ',var) 246 (defvar ,(symb var) nil) 248 (,p (when (stringp ,prompt) ,prompt)) ;; prompt string 249 (,h ',(symb var '-prompt-history))) ;; history symbol 250 (defvar ,(symb var '-prompt-history) nil) 251 (defun ,(symb var '-prompt) () 252 ,(format nil "Prompt for a value from `~A', use DEFAULT if non-nil 253 and no value is provided by user, otherwise fallback to the `car' 254 of `~A-PROMPT-HISTORY'." var var) 256 (format nil "~A [~A]: " 258 (car (symbol-value ,h))) 259 ,s :history ,h :default nil))))) 261 (defmacro define-cli-constant (name cli &optional doc) 262 `(define-constant ,name ,cli ,@doc :test #'cli-equal)) 264 (defvar *default-cli-def* 'defparameter) 266 (defmacro defcmd (name &body body) 267 `(defun ,name ($args $opts) 268 (declare (ignorable $args $opts)) 269 (let (($argc (length $args)) 270 ($optc (length $opts))) 271 (declare (ignorable $argc $optc)) 274 (defmacro defopt (name &body body) 276 (declare (ignorable $val)) 279 (declaim (inline walk-cli-slots)) 280 (defun walk-cli-slots (cli) 281 "Walk the plist CLI, performing actions as necessary based on the slot 283 (loop for kv in (group cli 2) 284 when (eql :thunk (car kv)) 285 return (let ((th (cdr kv))) 286 (if (or (functionp th) (symbolp th)) (funcall th) (compile nil (lambda () th))))) 289 (defmacro define-cli (name &body body) 290 "Define a symbol NAME bound to a top-level CLI object." 291 (declare (type symbol name)) 292 `(,*default-cli-def* ,name (apply #'make-cli t (walk-cli-slots ',body)))) 294 (defmacro defmain (ret &body body) 295 "Define a CLI main function in the current package which returns RET. 297 Note that this macro does not export the defined function and requires 298 `cli:main' to be an external symbol." 300 (declaim (type stream output)) 301 (defun main (&key (output *standard-output*)) 302 "Run the top-level function and print to OUTPUT." 303 (let ((*standard-output* output)) 305 (progn ,@body ,ret)))))) 308 (defun make-cli (kind &rest slots) 309 "Creates a new CLI object of the given kind." 310 (declare (type (member :opt :cmd :cli t) kind)) 311 (apply #'make-instance 313 ((eql kind :cli) 'cli) 314 ((eql kind :opt) 'cli-opt) 315 ((eql kind :cmd) 'cli-cmd) 319 ;; RESEARCH 2023-09-12: closed over hash-table with short/long flags 320 ;; to avoid conflicts. if not, need something like a flag-function 321 ;; slot at class allocation. 322 (defmacro make-opts (&body opts) 326 (string (make-cli :opt :name x)) 327 (list (apply #'make-cli :opt x)) 328 (t (make-cli :opt :name (format nil "~(~A~)" x) :global t)))) 329 (walk-cli-slots ',opts))) 331 (defmacro make-cmds (&body opts) 335 (string (make-cli :cmd :name x)) 336 (list (apply #'make-cli :cmd x)) 337 (t (make-cli :cmd :name (format nil "~(~A~)" x))))) 338 (walk-cli-slots ',opts))) 340 (defun long-opt-p (str) 341 (and (char= (aref str 0) (aref str 1) #\-) 344 (defun short-opt-p (str) 345 (and (char= (aref str 0) #\-) 346 (not (char= (aref str 1) #\-)) 349 (defun opt-group-p (str) 350 (string= str *cli-group-separator*)) 352 (defun opt-prefix-eq (ch str) 353 (char= (aref str 0) ch)) 355 (defun gen-thunk-ll (origin args) 356 (let ((a0 (list (symb '$a 0) origin))) 358 (nconc (loop for i from 1 for a in args nconc (list (symb '$a i) a)) a0 ) 362 ;; (defmacro gen-cli-thunk (pvars &rest thunk) 363 ;; "Generate and return a function based on THUNK suitable for the :thunk 364 ;; slot of cli objects with pandoric bindings PVARS.") 367 (defgeneric push-cmd (cmd place)) 369 (defgeneric push-opt (opt place)) 371 (defgeneric pop-cmd (place)) 373 (defgeneric pop-opt (place)) 375 (defgeneric find-cmd (self name &optional active)) 377 (defgeneric find-opt (self name &optional active)) 379 (defgeneric active-cmds (self)) 381 (defgeneric active-opts (self &optional global)) 383 (defgeneric find-short-opt (self ch)) 385 (defgeneric call-opt (self arg)) 387 (defgeneric do-opt (self)) 389 (defgeneric call-cmd (self args opts)) 391 (defgeneric parse-args (self args &key &allow-other-keys) 392 (:documentation "Parse list of strings ARGS using SELF. 394 A list of the same length as ARGS is returned containing 'cli-ast' 395 objects: (OPT . (or char string)) (CMD . string) NIL")) 397 (defgeneric do-cmd (self) 398 (:documentation "Run the command SELF with args parsed at runtime.")) 400 (defgeneric print-help (self &optional stream) 401 (:documentation "Format cli SELF as a helpful string.")) 403 (defgeneric print-version (self &optional stream) 404 (:documentation "Print the version of SELF.")) 406 (defgeneric print-usage (self &optional stream) 407 (:documentation "Format cli SELF as a useful string.")) 409 (defgeneric handle-unknown-argument (self arg) 410 (:documentation "Handle an unknown argument.")) 412 (defgeneric handle-missing-argument (self arg) 413 (:documentation "Handle a missing argument.")) 415 (defgeneric handle-invalid-argument (self arg) 416 (:documentation "Handle an invalid argument.")) 418 (defgeneric cli-equal (a b)) 420 (defun default-thunk (cli) (lambda (x) (declare (ignore x)) (print-help cli))) 422 (defvar *cli-opt-kinds* '(bool str form list sym key num file dir)) 424 (defun cli-opt-kind-p (s) 425 (declare (type symbol s)) 426 (find s *cli-opt-kinds*)) 428 (defmacro make-opt-parser (kind-spec &body body) 429 "Return a KIND-opt-parser function based on KIND-SPEC which is either a 430 symbol from *cli-opt-kinds* or a list, and optional BODY which 431 is a list of handlers for the opt-val." 432 (let* ((kind (if (consp kind-spec) (car kind-spec) kind-spec)) 433 (super (when (consp kind-spec) (cadr kind-spec))) 434 (fn-name (symb 'parse- kind '-opt))) 436 (let ((fn1 (when (not (eql 'nil super)) (symb 'parse- super '-opt)))) 438 (defun ,fn-name ($val) 439 "Parse the cli-opt-val $VAL." 441 (when (not (eql ',fn1 'nil)) (setq $val (funcall ',fn1 $val))) 444 (make-opt-parser bool $val) 446 (make-opt-parser (str bool) (when (stringp $val) $val)) 448 (make-opt-parser (form str) (read-from-string $val)) 450 (make-opt-parser (list form) (when (listp $val) $val)) 452 (make-opt-parser (sym form) (when (symbolp $val) $val)) 454 (make-opt-parser (key form) (when (keywordp $val) $val)) 456 (make-opt-parser (num form) (when (numberp $val) $val)) 458 (make-opt-parser (file str) 459 (when $val (parse-native-namestring $val nil *default-pathname-defaults* :as-directory nil))) 461 (make-opt-parser (dir str) 462 (when $val (sb-ext:parse-native-namestring $val nil *default-pathname-defaults* :as-directory t))) 466 ;; note that cli-opts can have a nil or unbound name slot 467 ((name :initarg :name :initform (required-argument :name) :accessor cli-name :type string) 468 (kind :initarg :kind :initform 'boolean :accessor cli-opt-kind :type cli-opt-kind-p) 469 (thunk :initform #'default-thunk :initarg :thunk :type function-lambda-expression :accessor cli-thunk) 470 (val :initarg :val :initform nil :accessor cli-val :type form) 471 (global :initarg :global :initform nil :accessor global-opt-p :type boolean) 472 (description :initarg :description :accessor cli-description :type string) 473 (lock :initform nil :initarg :lock :accessor cli-lock-p :type boolean)) 474 (:documentation "CLI option")) 476 (defmethod handle-unknown-argument ((self cli-opt) arg)) 477 (defmethod handle-missing-argument ((self cli-opt) arg)) 478 (defmethod handle-invalid-argument ((self cli-opt) arg)) 480 (defmethod initialize-instance :after ((self cli-opt) &key) 481 (with-slots (name thunk) self 482 (unless (stringp name) (setf name (format nil "~(~A~)" name))) 483 (when (symbolp thunk) (setf thunk (funcall (compile nil `(lambda () ,(symbol-function thunk)))))) 486 (defmethod install-thunk ((self cli-opt) (lambda function) &optional compile) 487 "Install THUNK into the corresponding slot in cli-cmd SELF." 488 (let ((%thunk (if compile (compile nil lambda) lambda))) 489 (setf (cli-thunk self) %thunk) 492 (defmethod print-object ((self cli-opt) stream) 493 (print-unreadable-object (self stream :type t) 494 (format stream "~A :global ~A :val ~A" 499 (defmethod print-usage ((self cli-opt) &optional stream) 500 (format stream " -~(~{~A~^/--~}~)~A~A" 501 (if-let ((n (cli-name self))) 502 (list (make-shorty n) n) 504 (if (global-opt-p self) "* " " ") 505 (if-let ((d (and (slot-boundp self 'description) (cli-description self)))) 506 (format stream ": ~A" d) 509 (defmethod cli-equal ((a cli-opt) (b cli-opt)) 510 (with-slots (name global kind) a 511 (with-slots ((bn name) (bg global) (bk kind)) b 512 (and (string= name bn) 516 (defmethod call-opt ((self cli-opt) arg) 517 (funcall (compile nil (cli-thunk self)) arg)) 519 (defmethod do-opt ((self cli-opt)) 520 (call-opt self (cli-val self))) 523 ;; name slot is required and must be a string 524 ((name :initarg :name :initform (required-argument :name) :accessor cli-name :type string) 525 (opts :initarg :opts :initform (make-array 0 :element-type 'cli-opt) 526 :accessor cli-opts :type (vector cli-opt)) 527 (cmds :initarg :cmds :initform (make-array 0 :element-type 'cli-cmd) 528 :accessor cli-cmds :type (vector cli-cmd)) 529 (thunk :initform #'default-thunk :initarg :thunk :accessor cli-thunk :type function-lambda-expression) 530 (lock :initform nil :initarg :lock :accessor cli-lock-p :type boolean) 531 (description :initarg :description :accessor cli-description :type string) 532 (args :initform nil :initarg :args :accessor cli-cmd-args)) 533 (:documentation "CLI command")) 535 (defmethod initialize-instance :after ((self cli-cmd) &key) 536 (with-slots (name cmds opts thunk) self 537 (unless (stringp name) (setf name (format nil "~(~A~)" name))) 538 (unless (vectorp cmds) (setf cmds (funcall (compile nil `(lambda () ,cmds))))) 539 (unless (vectorp opts) (setf opts (funcall (compile nil `(lambda () ,opts))))) 540 (when (symbolp thunk) (setf thunk (symbol-function thunk))) 543 (defmethod print-object ((self cli-cmd) stream) 544 (print-unreadable-object (self stream :type t) 545 (format stream "~A :opts ~A :cmds ~A :args ~A" 547 (length (cli-opts self)) 548 (length (cli-cmds self)) 549 (length (cli-cmd-args self))))) 551 (defmethod print-usage ((self cli-cmd) &optional stream) 552 (with-slots (opts cmds) self 553 (format stream "~(~A~) ~A~A~A" 555 (if-let ((d (and (slot-boundp self 'description) (cli-description self)))) 556 (format nil ": ~A" d) 560 (format nil "~{~% ~A~^~}" (loop for o across opts collect (print-usage o nil)))) 563 (format nil "~% ~{! ~A~}" (loop for c across cmds collect (print-usage c nil))))))) 565 (defmethod push-cmd ((self cli-cmd) (place cli-cmd)) 566 (vector-push self (cli-cmds place))) 568 (defmethod push-opt ((self cli-opt) (place cli-cmd)) 569 (vector-push self (cli-opts place))) 571 (defmethod pop-cmd ((self cli-cmd)) 572 (vector-pop (cli-cmds self))) 574 (defmethod pop-opt ((self cli-opt)) 575 (vector-pop (cli-opts self))) 577 (defmethod cli-equal ((a cli-cmd) (b cli-cmd)) 578 (with-slots (name opts cmds) a 579 (with-slots ((bn name) (bo opts) (bc cmds)) b 580 (and (string= name bn) 581 (if (and (null opts) (null bo)) 583 (unless (member nil (loop for oa across opts 585 collect (cli-equal oa ob))) 587 (if (and (null cmds) (null bc)) 589 (unless (member nil (loop for ca across cmds 591 collect (cli-equal ca cb))) 594 ;; typically when starting from a top-level `cli', the global 595 ;; `cli-opts' will be parsed first, followed by the first command 596 ;; found. If a command is found, the tail of the list is passed as 597 ;; arguments to this function, which can pass additonal arguments to 600 ;; TODO 2023-09-12: Parsing restarts at the `*cli-group-separator*' 601 ;; if present, or stops at EOI. 603 (declaim (inline %make-cli-node)) 604 (defstruct (cli-node (:constructor %make-cli-node)) kind form) 606 (defun make-cli-node (kind form) 607 (%make-cli-node :kind kind :form form)) 609 (declaim (inline %make-cli-ast)) 610 (defstruct (cli-ast (:constructor %make-cli-ast)) ast) 612 (defun make-cli-ast (nodes) 613 (%make-cli-ast :ast nodes)) 615 (defmethod find-cmd ((self cli-cmd) name &optional active) 616 (when-let ((c (find name (cli-cmds self) :key #'cli-name :test #'string=))) 618 ;; maybe issue warning here? report to user 619 (when (cli-lock-p c) c) 622 (defmethod active-cmds ((self cli-cmd)) 623 (remove-if-not #'cli-lock-p (cli-cmds self))) 626 (defmethod find-opt ((self cli-cmd) name &optional active) 627 (when-let ((o (find name (cli-opts self) :key #'cli-name :test #'string=))) 629 (when (cli-lock-p o) o) 632 (defun active-global-opt-p (opt) 633 "Return non-nil if OPT is active at runtime and global." 634 (when (and (cli-lock-p opt) (global-opt-p opt)) t)) 636 (defmethod active-opts ((self cli-cmd) &optional global) 639 #'active-global-opt-p 643 (defmethod find-short-opt ((self cli-cmd) ch) 644 (find ch (cli-opts self) :key #'cli-name :test #'opt-prefix-eq)) 646 (defmethod proc-args ((self cli-cmd) args) 647 "process ARGS into an ast. Each element of the ast is a node with a 648 :kind slot, indicating the type of node and a :form slot which stores 651 For now we parse group separators '--' and insert a nil into the tree, 652 this will likely change to generating a new branch in the ast as it 657 if (= (length a) 1) collect (make-cli-node 'arg a) 659 else if (short-opt-p a) 660 collect (if-let ((o (find-short-opt self (aref a 1)))) 663 (make-cli-node 'opt o)) 664 (make-cli-node 'arg a)) 667 else if (long-opt-p a) 668 ;; what we actually want to do is consume the next sequence of args - TBD 669 collect (if-let ((o (find-opt self (string-trim "-" a)))) 671 (setf (cli-val o) (string-trim "-" a)) 672 (make-cli-node 'opt o)) 673 (make-cli-node 'arg a)) 675 else if (opt-group-p a) 678 else if (find-cmd self a) 680 collect (make-cli-node 'cmd (find-cmd self a)) 682 else collect (make-cli-node 'arg a)))) 684 (defmethod install-ast ((self cli-cmd) (ast cli-ast)) 685 "Install the given AST, recursively filling in value slots." 686 (with-slots (cmds opts) self 687 ;; we assume all nodes in the ast have been validated and the ast 688 ;; itself is consumed. validation is performed in proc-args. 690 ;; before doing anything else we lock SELF, which should remain 691 ;; locked for the full runtime duration. 692 (setf (cli-lock-p self) t) 694 for (node . tail) on (cli-ast-ast ast) 697 (with-slots (kind form) node 701 (let ((name (cli-name form)) 702 (val (cli-val form))) 703 (when-let ((o (find-opt self name))) 704 (setf (cli-val o) val 706 ;; when we encounter a command we recurse over the tail 708 (when-let ((c (find-cmd self (cli-name form)))) 709 (setf (cli-lock-p c) t) 710 ;; handle the rest of the AST 711 (install-ast c (make-cli-ast tail)) 712 (return-from install))) 713 (arg (push-arg form self))))) 714 (setf (cli-cmd-args self) (nreverse (cli-cmd-args self))) 717 (defmethod install-thunk ((self cli-cmd) (lambda function) &optional compile) 718 "Install THUNK into the corresponding slot in cli-cmd SELF." 719 (let ((%thunk (if compile (compile nil lambda) lambda))) 720 (setf (cli-thunk self) %thunk) 723 (defmethod push-arg (arg (self cli-cmd)) 724 (push arg (cli-cmd-args self))) 726 (defmethod parse-args ((self cli-cmd) args &key (compile nil)) 727 "Parse ARGS and return the updated object SELF. 729 ARGS is assumed to be a valid cli-ast (list of cli-nodes), unless 730 COMPILE is t, in which case a list of strings is assumed." 731 (with-slots (opts cmds) self 732 (let ((args (if compile (proc-args self args) args))) 733 (print (install-ast self args))))) 735 ;; warning: make sure to fill in the opt and cmd slots with values 736 ;; from the top-level args before doing a command. 737 (defmethod call-cmd ((self cli-cmd) args opts) 738 ;; TODO 2023-09-12: handle args/env 739 (funcall (cli-thunk self) args opts)) 741 (defmethod do-cmd ((self cli-cmd)) 742 (call-cmd self (cli-cmd-args self) (cli-opts self))) 744 (defclass cli (cli-cmd) 745 ;; name slot defaults to *package*, must be string 746 ((name :initarg :name :initform (string-downcase (package-name *package*)) :accessor cli-name :type string) 747 (version :initarg :version :initform "0.1.0" :accessor cli-version :type string) 748 ;; TODO 2023-10-11: look into pushd popd - wd-stack? 749 (cwd :initarg :cwd :initform (sb-posix:getcwd) :type string :accessor cli-cwd 750 :documentation "working directory of the top-level CLI.")) 751 (:documentation "CLI")) 753 (defmethod print-usage ((self cli) &optional stream) 754 (iprintln (format nil "usage: ~A [global] <command> [<arg>]~%" (cli-name self)) 2 stream)) 756 (defmethod print-version ((self cli) &optional stream) 757 (println (cli-version self) stream)) 759 (defmethod print-help ((self cli) &optional stream) 760 (println (format nil "~A v~A" (cli-name self) (cli-version self)) stream) 761 (print-usage self stream) 762 (iprintln (cli-description self) 2 stream) 764 (iprintln "options:" 2 stream) 765 (with-slots (opts cmds) self 767 (loop for o across opts 768 do (iprintln (print-usage o) 4 stream))) 770 (iprintln "commands:" 2 stream) 772 (loop for c across cmds 773 do (iprintln (print-usage c) 4 stream))))) 775 (defmethod cli-equal :before ((a cli) (b cli)) 776 "Return T if A is the same cli object as B. 778 Currently this function is intended only for instances of the CLI 779 class and is used as a specialized EQL for DEFINE-CONSTANT." 780 (with-slots (version) a 781 (with-slots ((bv version)) b 782 (string= version bv)))) 784 ;; same as cli-cmd method, default is to compile though 785 (defmethod parse-args ((self cli) (args list) &key (compile t)) 786 "Parse list of string arguments ARGS and return the updated object SELF." 787 (with-slots (opts cmds) self 788 (let ((args (if compile (proc-args self args) args))) 789 (install-ast self args)))) 791 (declaim (inline debug-opts)) 792 (defun debug-opts (cli) 793 (let ((o (active-opts cli)) 794 (a (cli-cmd-args cli)) 795 (c (active-cmds cli))) 796 (debug! (cli-cwd cli) o a c))) 798 (declaim (inline solop)) 800 (and (= 0 (length (active-opts self t)) (length (active-cmds self))))) 802 (defmethod do-cmd ((self cli)) 804 (call-cmd self (cli-cmd-args self) (cli-opts self)) 806 (loop for o across (active-opts self t) 808 (loop for c across (active-cmds self)