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

Kind	Covered	All	%
expression	112	256	43.8
branch	8	14	57.1

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; cli/clap/cli.lisp --- Clap CLI Class

2

3

;; Top-level command object of a CLI App

4

5

;;; Code:

6

(in-package :cli/clap/obj)

7

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))

11

;; (print (getf slots :thunk))

12

(cond

13

((eql kind :cli) (apply #'make-instance 'cli slots))

14

;; replace :DEFAULT with :VAL

15

((eql kind :opt) (apply #'make-cli-opt (substitute :val :default slots)))

16

((eql kind :cmd) (apply #'make-instance 'cli-cmd slots))

17

(t (apply #'make-instance kind slots))))

18

19

(defopt help-opt

20

"Print help and exit."

21

(if *arg*

22

(print-help (find-cmd *arg* *cli* :default :error) t)

23

(print-help *cli*))

24

(exit :code 0))

25

26

(defopt version-opt

27

"Print version and exit."

28

(print-version *cli*)

29

(exit :code 0))

30

31

(defopt keep-ast-opt

32

"Set the *KEEP-AST* variable."

33

(setq ast:*keep-ast* t))

34

35

(defopt level-opt

36

"Set the *LOG-LEVEL* for this CLI session."

37

(if *arg*

38

(setq *log-level* (if (stringp *arg*)

39

(sb-int:keywordicate (string-upcase *arg*))

40

*arg*))

41

*log-level*))

42

43

(defmacro define-cli (sym &key name version help description thunk opts cmds package)

44

"Define a symbol SYM bound to a top-level CLI object.

45

46

NAME is assigned to the CLI and assumed to be the default binary name which

47

uses this object.

48

49

VERSION, DESCRIPTION, and THUNK are assigned to the associated slot value of

50

the CLI as is.

51

52

When HELP is non-nil, auto-generate a '--help' CLI-OPT and assign it to this

53

object.

54

55

OPTS and CMDS are lists of forms which are passed directly to MAKE-CLI :OPT

56

and MAKE-CLI :CMD respectively."

57

(with-gensyms (%name %class %opts)

58

(if (atom sym)

59

(setq %name sym

60

%class :cli)

61

(setq %name (car sym)

62

%class (cdr sym)))

63

(setq %opts

64

(if help

65

(make-opts

66

(append

67

`((:name "help" :description "print help" :kind string

68

:thunk cli/clap/obj::help-opt))

69

opts))

70

(make-opts opts)))

71

`(prog1 (,*default-cli-def* ,%name (make-cli ,%class :name ,name

72

                                                          :version ,version

73

                                                          :description ,description

74

                                                          :thunk ',thunk

75

                                                          :opts ,%opts

76

                                                          :cmds ,(make-cmds cmds)))

77

,@(when package `((load-package-cli ,%name :package ,package))))))

78

79

(defmacro defmain (name (&key (exit t) (debug t)) &body body)

80

"Define a CLI main function in the current package."

81

(multiple-value-bind (body decls docs) (parse-body body :documentation t)

82

`(let ((*no-exit* ,(not exit))

83

(*no-debug* ,(not debug)))

84

(defun ,name ()

85

,(or docs "Run the top-level function and print to *STDOUT*.")

86

,@decls

87

(with-cli-handlers

88

(progn

89

,@body))))))

90

91

;; RESEARCH 2023-09-12: closed over hash-table with short/long flags

92

;; to avoid conflicts. if not, need something like a flag-function

93

;; slot at class allocation.

94

(defun make-opts (opts)

95

"Make a vector of CLI-OPTs based on OPTS."

96

(map 'vector

97

(lambda (x)

98

(etypecase x

99

(string (make-cli-opt :name x))

100

(list (apply #'make-cli :opt x))

101

(symbol (make-cli-opt :name (string-downcase (symbol-name x ))))))

102

opts))

103

104

(defun make-cmds (cmds)

105

"Make a vector of CLI-CMDs based on CMDS."

106

(map 'vector

107

(lambda (x)

108

(etypecase x

109

(cli-cmd x)

110

(string (make-cli :cmd :name x))

111

(list (apply #'make-cli :cmd x))

112

(t (make-cli :cmd :name (format nil "~(~A~)" x)))))

113

cmds))

114

115

(defclass cli (cli-cmd)

116

;; name slot defaults to *package*, must be string

117

   ((name :initarg :name :initform (string-downcase (package-name *package*)) :accessor cli-name :type string)

118

(version :initarg :version :initform "0.1.0" :accessor cli-version :type string)

119

;; TODO 2023-10-11: look into pushd popd - cd-stack?

120

(cd :initarg :cd :initform (sb-posix:getcwd) :type string :accessor cli-cd

121

:documentation "working directory of the top-level CLI."))

122

(:documentation "CLI"))

123

124

(defmethod print-usage ((self cli) &optional stream)

125

(iprintln (format nil "usage: ~A [opts] <command> [<arg>]~%" (cli-name self)) 2 stream))

126

127

(defmethod print-version ((self cli) &optional stream)

128

(println (cli-version self) stream))

129

130

(defmethod print-help :before ((self cli) &optional (stream t))

131

   (println (format nil "~A v~A --- ~A~%" (cli-name self) (cli-version self) (cli-description self)) stream))

132

133

(defmethod equiv :before ((a cli) (b cli))

134

"Return T if A is the same cli object as B.

135

136

Currently this function is intended only for instances of the CLI

137

class and is used as a specialized EQL for DEFINE-CONSTANT."

138

(with-slots (version) a

139

(with-slots ((bv version)) b

140

(string= version bv))))

141

142

(declaim (inline debug-opts))

143

(defun debug-opts (cli)

144

(let ((o (active-opts cli))

145

(a (cli-args cli))

146

(c (active-cmds cli)))

147

(log:debug! :pwd (cli-cd cli) :active-opts o :cmd-args a :active-cmds c)))

148

149

(deftype cli-hook-designator () '(or boolean :after))

150

151

;; TODO 2025-06-13: call-with-cli

152

153

(defmacro with-cli ((cli &key slots (args *args*) (install t) run exit) &body body)

154

"Like with-slots with some extra bindings.

155

156

- CLI is an instance of a CLI class.

157

158

- SLOTS is a list passed directly to WITH-SLOTS with CLI.

159

160

- ARGS is a list of arguments to parse with this cli object.

161

162

- INSTALL defaults to T which implies that the AST will be consumed before

163

BODY. A nil value indicates that the AST will not be consumed and it is up

164

to the user to provide a binding for the AST slot so that they may call

165

INSTALL-AST manually. Alternatively a special value :AFTER may be supplied

166

which will delay installation until after BODY is evaluated.

167

168

- RUN with a non-nil value will call DO-CMD on the CLI after evaluating BODY.

169

170

- EXIT with a non-nil value will exit the current process as the last hook

171

after evaluating BODY.

172

173

CLI is updated based on the current environment and dynamically bound to

174

 *CLI*. ARGS is a list of CLI args, defaults to *ARGS* at runtime if nil. *AST* is bound to the parsed result of"

175

`(progn

176

(let ((*cli* ,cli))

177

(setf (cli-cd *cli*) *default-pathname-defaults*)

178

(let ((*args* ,args)

179

(*ast* (proc-args ,cli ,args)))

180

,@(when (eql install t)

181

`((install-ast *cli* *ast*)))

182

(with-slots ,slots *cli*

183

,@body

184

,@(when (eql install :after) '((install-ast *cli*)))

185

,@(when run '((do-cmd *cli*)))

186

,@(when exit '((sb-ext:exit))))))))

187

188

(defmacro with-cli-args (args &body body)

189

`(let ((*args* ,args)

190

(*argc* ,(length args)))

191

,@body))

192

193

;;; CLI Package Helpers

194

195

(defun %package-cli (&optional (package *package*))

196

(gethash (package-name package) *cli-package-table*))

197

(defun (setf %package-cli) (new &optional (package *package*))

198

(setf (gethash (package-name package) *cli-package-table*) new))

199

(defun package-cli (&optional (package *package*))

200

(car (%package-cli package)))

201

(defun (setf package-cli) (new &optional (package *package*))

202

(setf (car (%package-cli package)) new))

203

(defun package-cmds (&optional (package *package*))

204

(cadr (%package-cli package)))

205

(defun (setf package-cmds) (new &optional (package *package*))

206

(setf (cadr (%package-cli package)) new))

207

(defun package-opts (&optional (package *package*))

208

(caddr (%package-cli package)))

209

(defun (setf package-opts) (new &optional (package *package*))

210

(setf (caddr (%package-cli package)) new))

211

212

(deferror missing-package-cli (simple-error) ()

213

(:default-initargs :format-control "Missing PACKAGE-CLI method for ~A"))

214

215

(defun missing-package-cli (key)

216

(error 'missing-package-cli :format-arguments (list key)))

217

218

;; these functions are used to populate a *CLI-PACKAGE-TABLE* record.

219

(defmacro load-package-cli (cli &key (package *package*) cmds opts)

220

(with-gensyms (%cli)

221

`(let ((,%cli (if-let ((pkg (and (keywordp ,cli) (package-cli (find-package ,cli)))))

222

(copy-object pkg)

223

(if (typep ,cli 'cli)

224

,cli

225

(missing-package-cli ,cli)))))

226

(setf (cmds ,%cli) (concatenate 'vector (cmds ,%cli) (make-cmds ',cmds))

227

(opts ,%cli) (concatenate 'vector (opts ,%cli) (make-opts ',opts)))

228

(setf (%package-cli ,package)

229

(list ,%cli (cmds ,%cli) (opts ,%cli))))))

230

231

(defun add-package-cmd (cmd &optional (package *package*))

232

(vector-push-extend cmd (package-cmds package)))

233

234

(defun add-package-opt (opt &optional (package *package*))

235

(vector-push-extend opt (package-opts package)))

236

237

(defmacro add-package-cmds (&rest cmds)

238

`(setf (package-cmds *package*) (concatenate 'vector (package-cmds *package*) (make-cmds ',cmds))))

239

240

(defmacro add-package-opts (&rest opts)

241

`(setf (package-opts *package*) (concatenate 'vector (package-opts *package*) (make-opts ',opts))))