Coverage report: /home/ellis/comp/core/lib/rt/obj.lisp

Kind	Covered	All	%
expression	214	407	52.6
branch	13	20	65.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; obj.lisp --- Test Objects

2

3

;;

4

5

;;; Code:

6

(in-package :rt)

7

8

;;; Result

9

(deftype result-tag ()

10

'(or (member :pass :fail) null))

11

12

(declaim (inline %make-test-result))

13

(defstruct (test-result (:constructor %make-test-result)

14

(:conc-name tr-))

15

(tag nil :type result-tag :read-only t)

16

(form nil :type form))

17

18

(defmethod print-object ((self test-result) stream)

19

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

20

(format stream "~A ~A" (tr-tag self) (tr-form self))))

21

22

(defun make-test-result (tag &optional form)

23

(%make-test-result :tag tag :form form))

24

25

(defmethod test-pass-p ((res test-result))

26

(when (eq :pass (tr-tag res)) t))

27

28

(defmethod test-fail-p ((res test-result))

29

(when (eq :fail (tr-tag res)) t))

30

31

(defmethod print-object ((self test-result) stream)

32

(print-unreadable-object (self stream)

33

(format stream "~A ~A"

34

(tr-tag self)

35

(tr-form self))))

36

37

;;; Test Object

38

(defclass test-object ()

39

((name :initarg :name :initform (required-argument) :type string :accessor name)

40

#+nil (cached :initarg :cache :allocation :class :accessor test-cached-p :type boolean))

41

(:documentation "Super class for all test-related objects."))

42

43

(defmethod print-object ((self test-object) stream)

44

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

45

(format stream "~A"

46

(name self))))

47

48

;;; Fixtures

49

;; Our fixtures are objects which can be inherited to build different fixture

50

;; classes. Fixtures inherit from TEST-OBJECT and have a NAME which usually

51

;; indicates the key used to initialize this object with MAKE-FIXTURE.

52

53

;; You can use fixtures inside a test or use the push-fixture method on a

54

;; `test-suite' object to make it accessible within that suite.

55

56

(defclass fixture (test-object)

57

((name :initarg :name :initform (string (gensym "fx"))

58

:accessor name)))

59

60

(defclass tmp-fixture (fixture)

61

((directory :initform #P"/tmp/" :type directory :initarg :directory :accessor dir)

62

(file :initform nil :type (or null pathname string) :initarg :file :accessor file)))

63

64

(defmethod make-fixture ((kind (eql :tmp)) &rest args)

65

(apply 'make-instance 'tmp-fixture args))

66

67

(defmethod make-fixture (kind &rest args)

68

(apply 'make-instance kind args))

69

70

(defmacro with-fixture ((var kind &rest args) &body body)

71

`(let ((,var (make-fixture ',kind ,@args)))

72

,@body))

73

74

(defmethod path ((self tmp-fixture))

75

(merge-pathnames (file self) (dir self)))

76

77

;;;; Tests

78

(defclass test (test-object)

79

((fn :type symbol :accessor test-fn)

80

(bench :type (or boolean fixnum) :accessor test-bench :initform nil :initarg :bench)

81

(profile :type list :accessor test-profile :initform nil :initarg :profile)

82

(cover :type boolean :accessor test-cover :initform nil :initarg :cover)

83

(declare :type list :accessor test-declare :initform nil :initarg :declare)

84

(form :initarg :form :initform nil :accessor test-form)

85

(documentaton :initarg :documentation :type string :accessor test-documentation)

86

(lock :initarg :lock :type boolean :accessor test-lock-p)

87

(persist :initarg :persist :initform nil :type boolean :accessor test-persist-p)

88

(results :initarg :results :type (array test-result) :accessor test-results))

89

(:documentation "Test class typically made with `deftest'."))

90

91

(defmethod initialize-instance ((self test) &key name)

92

;; (debug! "building test" name)

93

(setf (test-fn self)

94

(make-symbol

95

(format nil "~A~A"

96

name

97

(gensym *test-suffix*))))

98

(setf (test-lock-p self) t)

99

;; TODO 2023-09-21: we should count how many checks are in the :form

100

;; slot and infer the array dimensions.

101

(setf (test-results self) (make-array 0 :element-type 'test-result))

102

(call-next-method))

103

104

(defmethod initialize-instance :after ((self test) &key cover)

105

(when cover (push '(optimize sb-cover:store-coverage-data) (test-declare self))))

106

107

(defmethod print-object ((self test) stream)

108

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

109

(format stream "~A"

110

(name self))))

111

112

(defmethod push-result ((self test-result) (place test))

113

(with-slots (results) place

114

(push self results)))

115

116

(defmethod pop-result ((self test))

117

(pop (test-results self)))

118

119

(defmethod eval-test ((self test))

120

(eval `(progn ,@(test-form self))))

121

122

(defmethod funcall-test ((self test) &key declare)

123

(unless (functionp (test-fn self))

124

(trace! (setf (symbol-function (test-fn self))

125

(eval `(lambda ()

126

,(when declare `(declare ,declare))

127

,@(test-form self))))))

128

(funcall (test-fn self)))

129

130

(defmethod compile-test ((self test) &key declare &allow-other-keys)

131

(compile

132

(test-fn self)

133

`(lambda ()

134

,@(when declare `((declare ,declare)))

135

,@(test-form self))))

136

137

(defun fail! (form &optional fmt &rest args)

138

(let ((reason (and fmt (apply #'format nil fmt args))))

139

(with-simple-restart (ignore-fail "Continue testing.")

140

(error 'test-failed :reason reason :form form))))

141

142

(defmacro with-test-env (self &body body)

143

`(catch '%in-test

144

(setf (test-lock-p ,self) t)

145

(let* ((*testing* ,self)

146

(*log-level* (level *test-suite*))

147

(*fixtures* (test-fixtures *test-suite*))

148

(%test-bail nil)

149

%test-result)

150

(block %test-bail

151

,@body

152

(setf (test-lock-p ,self) %test-bail))

153

%test-result)))

154

155

(defmethod do-test ((self test) &optional fx)

156

(declare (ignorable fx))

157

(with-test-env self

158

(trace! "running test: ~A" *testing*)

159

(flet ((%do ()

160

;; (when (test-profile self)

161

;; (sb-sprof:start-profiling))

162

(if *compile-tests*

163

                  (with-compilation-unit (:override t :policy (or (and *test-suite* (test-policy *test-suite*)) *test-policy*))

164

;; TODO 2023-09-21: handle failures here

165

(funcall (compile-test self :declare (test-declare self)))

166

(setf %test-result (make-test-result :pass (test-fn self))))

167

(progn

168

(funcall-test self :declare (test-declare self))

169

(setf %test-result (make-test-result :pass self))))

170

(when (test-profile self)

171

(sb-sprof:stop-profiling))))

172

(if *catch-test-errors*

173

(handler-bind

174

((error

175

(lambda (c)

176

(setf %test-bail t)

177

(setf %test-result (make-test-result :fail c))

178

(return-from %test-bail %test-result))))

179

(%do))

180

(%do)))))

181

182

(defmethod do-test ((self simple-string) &optional fixture)

183

(when-let ((test (find-test *test-suite* self)))

184

(do-test test fixture)))

185

186

(defmethod do-test ((self symbol) &optional fixture)

187

(when-let ((test (find-test *test-suite* (symbol-name self))))

188

(do-test test fixture)))

189

190

;;;; Suites

191

(defclass test-suite (test-object)

192

((tests :initarg :set :initform nil :type list :accessor tests

193

:documentation "test-suite tests")

194

(results :initarg :results :initform nil :type list :accessor test-results

195

:documentation "test-suite results")

196

(stream :initarg :stream :initform *standard-output* :type stream :accessor test-stream)

197

(fixtures :initarg :fixtures :initform nil :type list :accessor test-fixtures)

198

(level :initarg :level :initform *log-level* :type log-level-designator :accessor level)

199

(policy :initarg :policy :initform *test-policy* :accessor test-policy)

200

(logger :initarg :logger :initform *logger* :accessor test-logger))

201

(:documentation "A class for collections of related `test' objects."))

202

203

(defmethod print-object ((self test-suite) stream)

204

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

205

(format stream "~A [~d:~d:~d:~d]"

206

(name self)

207

(length (tests self))

208

(count t (map-tests self #'test-lock-p))

209

(count t (map-tests self #'test-persist-p))

210

(length (test-results self)))))

211

212

;; (defmethod reinitialize-instance ((self test-suite) &rest initargs &key &allow-other-keys))

213

214

(deftype test-suite-designator ()

215

"Either nil, a symbol, a string, or a `test-suite' object."

216

'(or null symbol string test-suite keyword))

217

218

(defun find-suite (name)

219

(declare (test-suite-designator name))

220

(find name *test-suite-list* :test #'test-name=))

221

222

(defun find-fixture (name &optional (suite *test-suite*))

223

(find name (test-fixtures suite)

224

:test 'string-equal

225

:key 'name))

226

227

(defmethod map-tests ((self test-suite) function)

228

;; tests are stored in reverse order. run LIFO.

229

(mapcar function (reverse (tests self))))

230

231

(defmethod push-test ((self test) (place test-suite))

232

(push self (tests place)))

233

234

(defmethod pop-test ((self test-suite))

235

(pop (tests self)))

236

237

(defmethod push-result ((self test-result) (place test-suite))

238

(with-slots (results) place

239

(push self results)))

240

241

(defmethod pop-result ((self test-suite))

242

(pop (test-results self)))

243

244

(defmethod find-test ((self test-suite) name &key (test #'test-name=))

245

(declare (type (or string symbol) name)

246

(type function test))

247

(find name (tests self) :test test))

248

249

(defmethod find-test ((self symbol) name &key (test #'test-name=))

250

(find-test (find-suite self) name :test test))

251

252

(defmethod do-test ((self test-suite) &optional test)

253

(push-result

254

(if (log:info! test)

255

(do-test

256

(etypecase test

257

(test test)

258

(string (find-test self test))

259

(symbol (find-test self (symbol-name test)))))

260

(do-test (pop-test self)))

261

self))

262

263

;; HACK 2023-09-01: find better method of declaring failures from

264

;; within the body of `deftest'.

265

(defmethod do-suite ((self test-suite) &key stream force)

266

(when stream (setf (test-stream self) stream))

267

(with-slots (name stream) self

268

(format stream "in suite ~x:~%"

269

name)

270

(format stream "; with ~A~A tests~%"

271

(if force

272

""

273

(format nil "~A/"

274

(count t (tests self)

275

                                :key (lambda (x) (or (test-lock-p x) (test-persist-p x))))))

276

(length (tests self)))

277

;; loop over each test, calling `do-test'. if locked or persistent, test

278

;; is performed. if FORCE is non-nil all tests are performed.

279

(map-tests self

280

(lambda (x)

281

(when (or force (test-lock-p x) (test-persist-p x))

282

(let ((res (do-test x)))

283

(push-result res self)

284

(format stream "~@[~<~%~:;~:@(~S~) ~>~]~%" res)))))

285

;; compare locked vs expected

286

(let ((locked (remove-if #'null (map-tests self (lambda (x) (when (test-lock-p x) x)))))

287

(fails

288

;; collect if locked test not expected

289

(loop for r in (test-results self)

290

unless (test-pass-p r)

291

collect r)))

292

(if (null locked)

293

(format stream "~&No tests failed.~%")

294

(progn

295

;; RESEARCH 2023-09-04: print fails ??

296

(format stream "~&~A out of ~A ~

297

total tests failed: ~

298

~:@(~{~<~% ~1:;~S~>~

299

~^, ~}~)."

300

(length locked)

301

(length (tests self))

302

locked)

303

(unless (null fails)

304

(format stream "~&~A unexpected failures: ~

305

~:@(~{~<~% ~1:;~S~>~

306

~^, ~}~)."

307

(length fails)

308

fails))))

309

;; close stream

310

(finish-output stream)

311

;; return values (PASS? LOCKED)

312

(values (not fails) locked))))

313

314

(defmethod do-suite ((self string) &key stream)

315

(do-suite (ensure-suite self) :stream stream))

316

317

(defmethod do-suite ((self symbol) &key stream)

318

(do-suite (ensure-suite self) :stream stream))

319

320

(defmethod do-suite ((self null) &key stream)

321

(do-suite *test-suite* :stream stream))