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

Kind	Covered	All	%
expression	78	253	30.8
branch	5	26	19.2

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; cli/clap/opt.lisp --- Clap Opts

2

3

;; CLI Opt Objects

4

5

;;; Code:

6

(in-package :cli/clap/obj)

7

8

;;; Parsers

9

(make-opt-parser string *arg*)

10

11

(make-opt-parser boolean (when *arg* t))

12

13

(make-opt-parser (form string) (read-from-string *arg*))

14

15

(make-opt-parser (list form) (when (listp *arg*) *arg*))

16

17

(make-opt-parser (symbol form) (when (symbolp *arg*) *arg*))

18

19

(make-opt-parser (keyword form) (when (keywordp *arg*) *arg*))

20

21

(make-opt-parser number (when *arg* (parse-number *arg*)))

22

23

(make-opt-parser integer (when *arg* (parse-integer *arg*)))

24

25

(make-opt-parser (file string)

26

(parse-native-namestring *arg* nil *default-pathname-defaults* :as-directory nil))

27

28

(make-opt-parser (directory string)

29

(sb-ext:parse-native-namestring *arg* nil *default-pathname-defaults* :as-directory t))

30

31

(make-opt-parser (pathname string)

32

(pathname *arg*))

33

34

;;; Objects

35

(defstruct cli-opt

36

;; note that cli-opts can have a nil or unbound name slot

37

(name "" :type string)

38

(kind 'boolean :type (or symbol list))

39

(thunk 'default-opt-thunk :type symbol)

40

(val nil)

41

(description nil :type (or null string))

42

(lock nil :type boolean))

43

44

(defaccessor cli-thunk ((self cli-opt)) (cli-opt-thunk self))

45

(defaccessor cli-name ((self cli-opt)) (cli-opt-name self))

46

47

(defmethod activate-opt ((self cli-opt))

48

(setf (cli-opt-lock self) t))

49

50

(defmethod cli-lock-p ((self cli-opt))

51

(cli-opt-lock self))

52

53

(defun %compose-flag-opt (o)

54

(activate-opt o)

55

(setf (cli-opt-val o) t)

56

(make-cli-node 'opt o))

57

58

(defun %compose-flag-opts (&rest os)

59

(let ((ret))

60

(dolist (o os ret)

61

(%compose-flag-opt o))))

62

63

(defun %compose-value-opt (o &optional val)

64

(activate-opt o)

65

(setf (cli-opt-val o) val)

66

(make-cli-node 'opt o))

67

68

(defun %compose-keyword-opt (o val)

69

(activate-opt o)

70

(setf (cli-opt-val o) val)

71

(make-cli-node 'opt o))

72

73

(defmethod initialize-instance :after ((self cli-opt) &key)

74

(with-slots (name thunk) self

75

(unless (stringp name) (setf name (format nil "~(~A~)" name)))

76

self))

77

78

(defmethod make-load-form ((obj cli-opt) &optional env)

79

(make-load-form-saving-slots

80

obj

81

:slot-names '(name kind thunk val description lock)

82

:environment env))

83

84

(defmethod install-thunk ((self cli-opt) (lambda function) &optional compile)

85

"Install THUNK into the corresponding slot in cli-cmd SELF."

86

(let ((%thunk (if compile (compile nil lambda) lambda)))

87

(setf (cli-thunk self) %thunk)

88

self))

89

90

(defmethod print-object ((self cli-opt) stream)

91

(print-unreadable-object (self stream :type t)

92

(format stream "~A :active ~A :val ~A"

93

(cli-opt-name self)

94

(cli-opt-lock self)

95

(cli-opt-val self))))

96

97

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

98

(format stream "-~(~{~A~^/--~}~)~@[ :value ~A~]~24t~@[~A~]~@[~%~4t:doc ~A~]"

99

(let ((n (cli-opt-name self)))

100

(declare (simple-string n))

101

(list (make-shorty n) n))

102

(and (slot-boundp self 'val) (cli-opt-val self))

103

(and (slot-boundp self 'description) (cli-opt-description self))

104

(when (fboundp (cli-thunk self))

105

(documentation (symbol-function (cli-thunk self)) 'function))))

106

107

(defmethod equiv ((a cli-opt) (b cli-opt))

108

(with-slots (name kind) a

109

(with-slots ((bn name) (bk kind)) b

110

(and (equal name bn)

111

(equal kind bk)))))

112

113

(defmethod equiv ((a t) (b cli-opt))

114

(equalp (cli-opt-val b) a))

115

116

(defmethod equiv ((a cli-opt) (b t))

117

(equalp (cli-opt-val a) b))

118

119

(defmethod call-opt ((self cli-opt) arg)

120

(funcall (cli-opt-thunk self) arg))

121

122

(defmethod do-opt ((self cli-opt))

123

(prog1 (setf (cli-opt-val self) (call-opt self (cli-opt-val self)))

124

(setf (cli-opt-lock self) nil)))

125

126

(defmethod do-opts ((self vector))

127

(loop for opt across self

128

do (do-opt opt)))

129

130

(defmethods find-opt

131

(((name string) (self list) &key active default)

132

(if-let ((found (find name self :key 'cli-opt-name :test 'equal)))

133

(if active

134

(when (cli-lock-p found)

135

found)

136

found)

137

default))

138

(((name string) (self vector) &key active default)

139

(if-let ((found (find name self :key 'cli-opt-name :test 'equal)))

140

(if active

141

(when (cli-lock-p found)

142

found)

143

found)

144

default)))

145

146

(defun getopt (name &optional (default :error) (opts *opts*))

147

"Retrieve a CLI-OPT-VAL by name from a vector of CLI-OPTs."

148

(let ((opts (or opts (opts *cli*))))

149

(cli-opt-val (find-opt

150

(string-downcase name) opts

151

:default (if (eql default :error)

152

(clap-unknown-argument name 'opt)

153

default)))))

154

155

(defun setopt (name val &optional (default :error) (opts *opts*))

156

(let ((opts (or opts (opts *cli*))))

157

(setf (cli-opt-val

158

(find-opt

159

(string-downcase name) opts

160

:default (if (eql default :error)

161

(clap-unknown-argument name 'opt)

162

default)))

163

val)))

164

165

(defsetf getopt setopt)

166

167

(defmacro with-opt-restart-case (arg expression)

168

"Bind restarts 'use-as-arg' and 'discard-arg' for duration of EXPRESSION."

169

`(restart-case ,expression

170

(use-as-arg () () (make-cli-node 'arg ,arg))

171

(discard-arg () () (setf ,arg nil))))