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

KindCoveredAll%
expression8699 86.9
branch22100.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; rt.lisp --- Regression Testing
2
 
3
 ;; 
4
 
5
 ;;; Code:
6
 (in-package :rt)
7
 
8
 ;;; Checks
9
 (eval-always
10
   (defun %test (val &optional form)
11
     (let ((form (macroexpand form)))
12
       (if val 
13
           (make-test-result :pass form)
14
           (make-test-result :fail form)))))
15
 
16
 (defmacro is (test)
17
   "The DWIM Test Checker.
18
 
19
 (is (= 1 1)) ;=> #S(TEST-RESULT :TAG :PASS :FORM (= 1 1))
20
 
21
 If TEST returns a truthy value, return a PASS test-result, else return
22
 a FAIL."
23
   `(if *testing*
24
        (push-result (funcall #'rt::%test ,test ',test) *testing*)
25
        (funcall #'rt::%test ,test ',test)))
26
 
27
 ;; convenience functions wrapping IS
28
 (macrolet ((defis (name op args)
29
              `(defmacro ,name ,args
30
                 `(is (,',op ,,@args))))
31
            (defis* (name op)
32
              `(defmacro ,name (&rest args)
33
                 `(is (,',op ,@args))))
34
            (defisn (name op)
35
              `(defmacro ,name (n &rest args)
36
                 `(is (,',op ,n ,@args))))
37
            (defis/ (name op args)
38
              `(defmacro ,name ,args
39
                 `(is (,',op ,,@(reverse args))))))
40
   (defis isnt not (it))
41
   (defisn is= =)
42
   (defis iseq eq (a b))
43
   (defis iseql eql (a b))
44
   (defis isequal equal (a b))
45
   (defis isequalp equalp (a b))
46
   (defis iszero zerop (n))
47
   (defis isempty sequence:emptyp (seq))
48
   (defis islist listp (lst))
49
   (defis* isand and)
50
   (defis* isor or)
51
   (defis* isevery every)
52
   (defis* issome some)
53
   (defisn is> >)
54
   (defisn is< <)
55
   (defisn is>= >=)
56
   (defisn is<= <=)
57
   (defis/ issubtype subtypep (type obj))
58
   (defis/ issubclass subclassp (type obj))
59
   (defis/ istype typep (type obj)))
60
 
61
 (defmacro signals (condition-spec &body body)
62
   "Generates a passing TEST-RESULT if body signals a condition of type
63
 CONDITION-SPEC. BODY is evaluated in a block named NIL, CONDITION-SPEC
64
 is not evaluated."
65
   (let ((block-name (gensym)))
66
     (destructuring-bind (condition &optional reason-control &rest reason-args)
67
         (ensure-list condition-spec)
68
       `(block ,block-name
69
          (handler-bind ((,condition (lambda (c)
70
                                       (declare (ignore c))
71
                                       ;; ok, body threw condition
72
                                       ;; TODO 2023-09-05: result collectors
73
                                       ;; (add-result 'test-passed
74
                                       ;;            :test-expr ',condition)
75
                                       (return-from ,block-name (make-test-result :pass ',body)))))
76
            (block nil
77
              (locally (declare (sb-ext:muffle-conditions warning))
78
                ,@body)))
79
          (fail!
80
           ',condition
81
           ,@(if reason-control
82
                 `(,reason-control ,@reason-args)
83
                 `("Failed to signal a ~S" ',condition)))
84
          (return-from ,block-name nil)))))
85
 
86
 ;;; Macros
87
 (defmacro deftest (name props &body body)
88
   "Build a test with NAME, parameterized by PROPS and with a test form of BODY.
89
 
90
 PROPS is a plist which currently accepts the following parameters:
91
 
92
 :PERSIST - re-run this test even if it passes
93
 
94
 :PROFILE - enable profiling of this test
95
 
96
 :SKIP - don't push this test to the current *TEST-SUITE*
97
 
98
 :BENCH - enable benchmarking of this test
99
 
100
 BODY is parsed with SB-INT:PARSE-BODY and will fill in documentation
101
 and declarations for the test body."
102
   (destructuring-bind (pr documentation dec fn)
103
       (multiple-value-bind (forms dec documentation)
104
           ;; parse body with docstring allowed
105
           (parse-body (or body) :documentation t :whole t)
106
         `(,props ,documentation ,dec 
107
                  ',(if-let ((fx (getf props :fx)))
108
                      `((let ((*fx* (find-fixture ,fx)))
109
                          ,@forms))
110
                      forms)))
111
     ;; TODO 2023-09-21: parse plist
112
     `(let ((obj (make-test
113
                  :name ,(format nil "~A" name)
114
                  :form ,fn
115
                  ,@(when-let ((v (getf pr :persist))) `(:persist ,v))
116
                  ,@(when-let ((v (getf pr :bench))) `(:bench ,v))
117
                  ,@(when-let ((v (getf pr :profile))) `(:profile ,v))
118
                  ,@(when documentation `(:documentation ,documentation))
119
                  ,@(when dec `(:declare ,dec)))))
120
        ,(unless (getf pr :skip) '(push-test obj *test-suite*))
121
        obj)))
122
 
123
 (defmacro defsuite (suite-name &rest props)
124
   "Define a TEST-SUITE with provided keys. The object returned can be
125
 enabled using the IN-SUITE macro, similiar to the DEFPACKAGE API."
126
   (check-type suite-name (or symbol string))
127
   `(eval-when (:compile-toplevel :load-toplevel :execute)
128
      (let ((obj (make-suite
129
                  :name (format nil "~A" ',suite-name)
130
                  ,@props)))
131
        (setq *test-suite-list* (spush obj *test-suite-list* :test #'test-name=))
132
        obj)))
133
 
134
 (defmacro in-suite (name)
135
   "Set *TEST-SUITE* to the TEST-SUITE object referred to by symbol
136
 NAME. Return the object."
137
   (assert-suite name)
138
   `(progn
139
      (setq *test-suite* (ensure-suite ,name))))
140
 
141
 (defun run-all-tests (&optional force)
142
   (with-readtable :std
143
     (mapcar (lambda (x) (do-tests x force)) (remove *test-suite* *test-suite-list*))))