Mercurial > core / lisp/lib/cli/clap/cli.lisp
changeset 623: |
a304c9713a51 |
parent: |
35bb0d5ec95e
|
child: |
e49442cd6010 |
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Sun, 25 Aug 2024 00:14:17 -0400 |
permissions: |
-rw-r--r-- |
description: |
init graph.el |
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." 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) 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) 2 stream))) 91 (println "commands:" stream) 93 (loop for c across cmds 94 do (iprintln (print-usage c) 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 (slots cli &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 to 121 (setf (cli-cd ,cli) (sb-posix:getcwd)) 122 (with-slots ,slots (parse-args ,cli (args) :compile t)