Mercurial > core / lisp/lib/cli/clap/cli.lisp
changeset 682: |
5e8b1855f866 |
parent: |
65102f74d1ae
|
child: |
c5fe76568de0 |
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Sat, 28 Sep 2024 16:42:55 -0400 |
permissions: |
-rw-r--r-- |
description: |
lisp fixes |
1 ;;; cli/clap/cli.lisp --- Clap CLI Class 3 ;; Top-level command object of a CLI App 6 (in-package :cli/clap/obj) 8 (defun make-cli (kind &rest slots) 9 "Creates a new CLI object of the given kind." 10 (declare (type (member :opt :cmd :cli t) kind)) 12 ((eql kind :cli) (apply #'make-instance 'cli slots)) 13 ((eql kind :opt) (apply #'make-cli-opt slots)) 14 ((eql kind :cmd) (apply #'make-instance 'cli-cmd slots)) 15 (t (apply #'make-instance kind slots)))) 17 (defmacro define-cli (sym &key name version #+nil (help t) description thunk opts cmds) 18 "Define a symbol NAME bound to a top-level CLI object." 19 (with-gensyms (%name %class) 26 `(,*default-cli-def* ,%name (make-cli ,%class :name ,name 28 :description ,description 30 :opts (make-opts ',opts) 31 :cmds (make-cmds ',cmds))))) 33 (defmacro defmain (name (&key (exit t)) &body body) 34 "Define a CLI main function in the current package." 35 `(let ((*no-exit* ,(not exit))) 37 "Run the top-level function and print to *STDOUT*." 42 ;; RESEARCH 2023-09-12: closed over hash-table with short/long flags 43 ;; to avoid conflicts. if not, need something like a flag-function 44 ;; slot at class allocation. 45 (defun make-opts (opts) 46 "Make a vector of CLI-OPTs based on OPTS." 50 (string (make-cli-opt :name x)) 51 (list (apply #'make-cli :opt x)) 52 (t (make-cli :opt :name (format nil "~(~A~)" x) :global t)))) 55 (defun make-cmds (cmds) 56 "Make a vector of CLI-CMDs based on CMDS." 61 (string (make-cli :cmd :name x)) 62 (list (apply #'make-cli :cmd x)) 63 (t (make-cli :cmd :name (format nil "~(~A~)" x))))) 66 (defclass cli (cli-cmd) 67 ;; name slot defaults to *package*, must be string 68 ((name :initarg :name :initform (string-downcase (package-name *package*)) :accessor cli-name :type string) 69 (version :initarg :version :initform "0.1.0" :accessor cli-version :type string) 70 ;; TODO 2023-10-11: look into pushd popd - cd-stack? 71 (cd :initarg :cd :initform (sb-posix:getcwd) :type string :accessor cli-cd 72 :documentation "working directory of the top-level CLI.")) 73 (:documentation "CLI")) 75 (defmethod print-usage ((self cli) &optional stream) 76 (iprintln (format nil "usage: ~A [global] <command> [<arg>]~%" (cli-name self)) 2 stream)) 78 (defmethod print-version ((self cli) &optional stream) 79 (println (cli-version self) stream)) 81 (defmethod print-help ((self cli) &optional (stream t)) 82 (println (format nil "~A v~A --- ~A~%" (cli-name self) (cli-version self) (cli-description self)) stream) 83 (print-usage self stream) 85 (println "options:" stream) 86 (with-slots (opts cmds) self 88 (loop for o across opts 89 do (iprintln (print-usage o nil) 2 stream))) 91 (println "commands:" stream) 93 (loop for c across cmds 94 do (iprintln (print-usage c nil) 2 stream))))) 96 (defmethod cli-equal :before ((a cli) (b cli)) 97 "Return T if A is the same cli object as B. 99 Currently this function is intended only for instances of the CLI 100 class and is used as a specialized EQL for DEFINE-CONSTANT." 101 (with-slots (version) a 102 (with-slots ((bv version)) b 103 (string= version bv)))) 105 (declaim (inline debug-opts)) 106 (defun debug-opts (cli) 107 (let ((o (active-opts cli)) 108 (a (cli-cmd-args cli)) 109 (c (active-cmds cli))) 110 (log:debug! :pwd (cli-cd cli) :active-opts o :cmd-args a :active-cmds c))) 112 (defmacro with-cli ((cli &rest slots) args &body body) 113 "Like with-slots with some extra bindings. 115 SLOTS is a list passed to WITH-SLOTS. 117 CLI is updated based on the current environment and dynamically bound 118 to *CLI*. ARGS is a list of CLI args, defaults to *POSIX-ARGV* at 122 (setf (cli-cd *cli*) *default-pathname-defaults*) 123 (with-slots ,slots (parse-args *cli* ,args :compile t)