Coverage report: /home/runner/work/geb/geb/src/util/utils.lisp

Kind	Covered	All	%
expression	58	115	50.4
branch	2	8	25.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

(in-package :geb.utils)

2

3

(defun subclass-responsibility (obj)

4

"Denotes that the given method is the subclasses

5

responsibility. Inspired from Smalltalk"

6

(error "Subclass Responsbility for ~A" (class-name (class-of obj))))

7

8

(defun symbol-to-keyword (symbol)

9

"Turns a [symbol] into a [keyword]"

10

(intern (symbol-name symbol) :keyword))

11

12

(defmacro muffle-package-variance (&rest package-declarations)

13

"Muffle any errors about package variance and stating exports out of order.

14

This is particularly an issue for SBCL as it will error when using MGL-PAX

15

to do the [export] instead of DEFPACKAGE.

16

17

This is more modular thank

18

 [MGL-PAX:DEFINE-PACKAGE](https://melisgl.Githubc.io/mgl-pax-world/mgl-pax-manual.html#MGL-PAX:DEFINE-PACKAGE%20MGL-PAX:MACRO)

19

in that this can be used with any package creation function like

20

[UIOP:DEFINE-PACKAGE](https://privet-kitty.github.io/etc/uiop.html#UIOP_002fPACKAGE).

21

22

Here is an example usage:

23

24

```lisp

25

(geb.utils:muffle-package-variance

26

(uiop:define-package #:geb.lambda.trans

27

(:mix #:trivia #:geb #:serapeum #:common-lisp)

28

(:export

29

:compile-checked-term :stlc-ctx-to-mu)))

30

```"

31

`(eval-when (:compile-toplevel :load-toplevel :execute)

32

(locally (declare #+sbcl (sb-ext:muffle-conditions sb-int:package-at-variance))

33

(handler-bind (#+sbcl (sb-int:package-at-variance #'muffle-warning))

34

,@package-declarations))))

35

36

(defmacro make-pattern (object-name &rest constructor-names)

37

"make pattern matching position style instead of record style. This

38

removes the record constructor style, however it can be brought back

39

if wanted

40

41

```lisp

42

(defclass alias (<substmorph> <substobj>)

43

((name :initarg :name

44

:accessor name

45

:type symbol

46

:documentation \"The name of the GEB object\")

47

(obj :initarg :obj

48

:accessor obj

49

:documentation \"The underlying geb object\"))

50

(:documentation \"an alias for a geb object\"))

51

52

(make-pattern alias name obj)

53

```"

54

`(trivia.level2:defpattern ,object-name

55

(&optional ,@constructor-names)

56

(list 'and

57

(list 'type ',object-name)

58

,@(mapcar (lambda (x)

59

`(list 'trivia.level2:access '',x ,x))

60

constructor-names))))

61

62

(defun shallow-copy-object (original)

63

(let* ((class (class-of original))

64

(copy (allocate-instance class)))

65

(dolist (slot (mapcar #'c2mop:slot-definition-name (c2mop:class-slots class)))

66

(when (slot-boundp original slot)

67

(setf (slot-value copy slot)

68

(slot-value original slot))))

69

copy))

70

71

72

;; from

73

;; https://stackoverflow.com/questions/11067899/is-there-a-generic-method-for-cloning-clos-objects

74

75

;; Don't need it to be an object on non standard-classes for this

76

;; project, if so, we can promote it to the old form of being a

77

;; defgeneric.

78

79

(defgeneric copy-instance (object &rest initargs &key &allow-other-keys)

80

(:documentation

81

"Makes and returns a shallow copy of OBJECT.

82

83

An uninitialized object of the same class as OBJECT is allocated by

84

calling ALLOCATE-INSTANCE. For all slots returned by

85

CLASS-SLOTS, the returned object has the

86

same slot values and slot-unbound status as OBJECT.

87

88

REINITIALIZE-INSTANCE is called to update the copy with INITARGS."))

89

90

(defmethod copy-instance ((object standard-object) &rest initargs &key &allow-other-keys)

91

(let* ((class (class-of object))

92

(copy (allocate-instance class)))

93

(dolist (slot (c2mop:class-slots class))

94

;; moved the mapcar into a let, as allocation wise, CCL

95

;; preformed better this way.

96

(let ((slot-name (c2mop:slot-definition-name slot)))

97

(when (slot-boundp object slot-name)

98

(setf (slot-value copy slot-name)

99

(slot-value object slot-name)))))

100

(values

101

(apply #'reinitialize-instance copy initargs))))

102

103

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

104

;; Numeric Utilities

105

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

106

107

(-> number-to-digits (integer &optional list) list)

108

(defun number-to-digits (number &optional rem)

109

"turns an [INTEGER][type] into a list of its digits"

110

(multiple-value-bind (cont flored) (floor number 10)

111

(if (and (zerop cont) (zerop flored))

112

rem

113

(number-to-digits cont (cons flored rem)))))

114

115

(-> digit-to-under (fixnum) string)

116

(defun digit-to-under (digit)

117

"Turns a digit into a subscript string version of the number"

118

(cl:case digit

119

(0 "₀") (1 "₁") (2 "₂") (3 "₃") (4 "₄")

120

(5 "₅") (6 "₆") (7 "₇") (8 "₈") (9 "₉")

121

(t "?")))

122

123

(-> number-to-under (integer) string)

124

(defun number-to-under (index)

125

"Turns an [INTEGER][type] into a subscripted [STRING][type]"

126

(format nil "~{~A~}" (mapcar #'digit-to-under (number-to-digits index))))

127

128

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

129

;; Generic type constructions

130

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

131

132

(deftype list-of (ty)

133

"Allows us to state a list contains a given type.

134

135

-------------

136

137

*NOTE*

138

139

This does not type check the whole list, but only the first

140

element. This is an issue with how lists are defined in the

141

language. Thus this should be be used for intent purposes.

142

143

-------------

144

145

For a more proper version that checks all elements please look at writing code like

146

147

```cl

148

(deftype normal-form-list ()

149

`(satisfies normal-form-list))

150

151

(defun normal-form-list (list)

152

(and (listp list)

153

(every (lambda (x) (typep x 'normal-form)) list)))

154

155

(deftype normal-form ()

156

`(or wire constant))

157

```

158

159

Example usage of this can be used with `typep`

160

161

```cl-transcript

162

(typep '(1 . 23) '(list-of fixnum))

163

=> NIL

164

165

(typep '(1 23) '(list-of fixnum))

166

=> T

167

168

(typep '(1 3 4 \"hi\" 23) '(list-of fixnum))

169

=> T

170

171

(typep '(1 23 . 5) '(list-of fixnum))

172

=> T

173

```

174

175

Further this can be used in type signatures

176

177

```cl

178

(-> foo (fixnum) (list-of fixnum))

179

(defun foo (x)

180

(list x))

181

```

182

"

183

`(cons ,ty (or null cons)))

184

185

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

186

;; Generic Constructors declarations

187

;; These aren't needed but serve as a good place to put a default doc.

188

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

189

190

(defgeneric mcar (obj)

191

(:documentation

192

"Can be seen as calling CAR on a generic CLOS

193

[object](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_o.htm#object)"))

194

(defgeneric mcdr (obj)

195

(:documentation "Similar to MCAR, however acts like a CDR for

196

[classes] that we wish to view as a SEQUENCE"))

197

(defgeneric mcadr (obj)

198

(:documentation "like MCAR but for the CADR"))

199

200

(defgeneric mcaddr (obj)

201

(:documentation "like MCAR but for the CADDR"))

202

203

(defgeneric mcadddr (obj)

204

(:documentation "like MCAR but for the CADDDR"))

205

206

(defgeneric obj (obj)

207

(:documentation

208

"Grabs the underlying

209

[object](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_o.htm#object)"))

210

211

(defgeneric name (obj)

212

(:documentation

213

"the name of the given

214

[object](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_o.htm#object)"))

215

216

(defgeneric func (obj)

217

(:documentation

218

"the function of the

219

[object](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_o.htm#object)"))

220

221

(defgeneric predicate (obj)

222

(:documentation

223

"the PREDICATE of the

224

[object](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_o.htm#object)"))

225

226

(defgeneric then (obj)

227

(:documentation

228

"the then branch of the

229

[object](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_o.htm#object)"))

230

231

(defgeneric else (obj)

232

(:documentation

233

"the then branch of the

234

[object](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_o.htm#object)"))

235

236

(defgeneric code (obj)

237

(:documentation

238

"the code of the

239

[object](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_o.htm#object)"))

240

241

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

242

;; Additional Utils

243

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

244

245

246

(defun apply-n (times f initial)

247

"Applies a function, f, n TIMES to the INITIAL values

248

249

```lisp

250

GEB> (apply-n 10 #'1+ 0)

251

10 (4 bits, #xA, #o12, #b1010)

252

```"

253

(let ((value initial))

254

(dotimes (n times value)

255

(setf value (funcall f value)))))

256

��