Mercurial > core / lisp/lib/cli/clap/cli.lisp
changeset 644: |
f59072409c7a |
parent: |
f901de70a80e
|
child: |
74e563ed4537 |
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Tue, 10 Sep 2024 21:52:14 -0400 |
permissions: |
-rw-r--r-- |
description: |
revert cli-cmds back to list instead of &rest |
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 description thunk opts cmds) 18 "Define a symbol NAME bound to a top-level CLI object." 19 (with-gensyms (%name %class) 25 `(,*default-cli-def* ,%name (make-cli ,%class :name ,name 27 :description ,description 29 :opts (make-opts ',opts) 30 :cmds (make-cmds ',cmds))))) 32 (defmacro defmain ((&key (exit t) (export t)) &body body) 33 "Define a CLI main function in the current package." 34 (let ((main (symbolicate "MAIN"))) 35 `(let ((*no-exit* ,(not exit))) 37 "Run the top-level function and print to *STDOUT*." 41 ,@(when export `((export ',main)))))) 43 ;; RESEARCH 2023-09-12: closed over hash-table with short/long flags 44 ;; to avoid conflicts. if not, need something like a flag-function 45 ;; slot at class allocation. 46 (defun make-opts (opts) 47 "Make a vector of CLI-OPTs based on OPTS." 51 (string (make-cli-opt :name x)) 52 (list (apply #'make-cli :opt x)) 53 (t (make-cli :opt :name (format nil "~(~A~)" x) :global t)))) 56 (defun make-cmds (cmds) 57 "Make a vector of CLI-CMDs based on CMDS." 62 (string (make-cli :cmd :name x)) 63 (list (apply #'make-cli :cmd x)) 64 (t (make-cli :cmd :name (format nil "~(~A~)" x))))) 67 (defclass cli (cli-cmd) 68 ;; name slot defaults to *package*, must be string 69 ((name :initarg :name :initform (string-downcase (package-name *package*)) :accessor cli-name :type string) 70 (version :initarg :version :initform "0.1.0" :accessor cli-version :type string) 71 ;; TODO 2023-10-11: look into pushd popd - cd-stack? 72 (cd :initarg :cd :initform (sb-posix:getcwd) :type string :accessor cli-cd 73 :documentation "working directory of the top-level CLI.")) 74 (:documentation "CLI")) 76 (defmethod print-usage ((self cli) &optional stream) 77 (iprintln (format nil "usage: ~A [global] <command> [<arg>]~%" (cli-name self)) 2 stream)) 79 (defmethod print-version ((self cli) &optional stream) 80 (println (cli-version self) stream)) 82 (defmethod print-help ((self cli) &optional (stream t)) 83 (println (format nil "~A v~A --- ~A~%" (cli-name self) (cli-version self) (cli-description self)) stream) 84 (print-usage self stream) 86 (println "options:" stream) 87 (with-slots (opts cmds) self 89 (loop for o across opts 90 do (iprintln (print-usage o nil) 2 stream))) 92 (println "commands:" stream) 94 (loop for c across cmds 95 do (iprintln (print-usage c nil) 2 stream))))) 97 (defmethod cli-equal :before ((a cli) (b cli)) 98 "Return T if A is the same cli object as B. 100 Currently this function is intended only for instances of the CLI 101 class and is used as a specialized EQL for DEFINE-CONSTANT." 102 (with-slots (version) a 103 (with-slots ((bv version)) b 104 (string= version bv)))) 106 (declaim (inline debug-opts)) 107 (defun debug-opts (cli) 108 (let ((o (active-opts cli)) 109 (a (cli-cmd-args cli)) 110 (c (active-cmds cli))) 111 (log:debug! :pwd (cli-cd cli) :active-opts o :cmd-args a :active-cmds c))) 113 (defmethod do-opts ((self cli) &optional global) 114 (loop for opt across (active-opts self global) 117 (defmacro with-cli (slots cli &body body) 118 "Like with-slots with some extra bindings. 120 SLOTS is a list passed to WITH-SLOTS. 122 CLI is updated based on the current environment and dynamically bound to 126 (setf (cli-cd ,cli) (sb-posix:getcwd)) 127 (with-slots ,slots (parse-args ,cli (args) :compile t)