changeset 632: |
bbd9024f2fe2 |
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Sat, 31 Aug 2024 22:34:56 -0400 |
permissions: |
-rw-r--r-- |
description: |
lib/rt upgrades and refactoring |
1 ;;; obj.lisp --- Test Objects 10 '(or (member :pass :fail :skip) null)) 12 (declaim (inline %make-test-result)) 13 (defstruct (test-result (:constructor %make-test-result) 15 (tag nil :type result-tag :read-only t) 16 (form nil :type form)) 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)))) 22 (defun make-test-result (tag &optional form) 23 (%make-test-result :tag tag :form form)) 25 (defmethod test-pass-p ((res test-result)) 26 (when (eq :pass (tr-tag res)) t)) 28 (defmethod test-fail-p ((res test-result)) 29 (when (eq :fail (tr-tag res)) t)) 31 (defmethod test-skip-p ((res test-result)) 32 (when (eq :skip (tr-tag res)) t)) 34 (defmethod print-object ((self test-result) stream) 35 (print-unreadable-object (self stream) 36 (format stream "~A ~A" 41 (defclass test-object () 42 ((name :initarg :name :initform (required-argument) :type string :accessor test-name) 43 #+nil (cached :initarg :cache :allocation :class :accessor test-cached-p :type boolean)) 44 (:documentation "Super class for all test-related objects.")) 46 (defmethod print-object ((self test-object) stream) 48 (print-unreadable-object (self stream :type t :identity t) 53 (defclass test (test-object) 54 ((fn :type symbol :accessor test-fn) 55 (bench :type (or boolean fixnum) :accessor test-bench :initform nil :initarg :bench) 56 (profile :type list :accessor test-profile :initform nil :initarg :profile) 57 (args :type list :accessor test-args :initform nil :initarg :args) 58 (declare :type list :accessor test-declare :initform nil :initarg :declare) 59 (form :initarg :form :initform nil :accessor test-form) 60 (doc :initarg :doc :type string :accessor test-doc) 61 (lock :initarg :lock :type boolean :accessor test-lock-p) 62 (persist :initarg :persist :initform nil :type boolean :accessor test-persist-p) 63 (results :initarg :results :type (array test-result) :accessor test-results)) 64 (:documentation "Test class typically made with `deftest'.")) 66 (defmethod initialize-instance ((self test) &key name) 67 ;; (debug! "building test" name) 72 (gensym *test-suffix*)))) 73 (setf (test-lock-p self) t) 74 ;; TODO 2023-09-21: we should count how many checks are in the :form 75 ;; slot and infer the array dimensions. 76 (setf (test-results self) (make-array 0 :element-type 'test-result)) 79 (defmethod print-object ((self test) stream) 80 (print-unreadable-object (self stream :type t :identity t) 81 (format stream "~A :fn ~A" 85 (defmethod push-result ((self test-result) (place test)) 86 (with-slots (results) place 89 (defmethod pop-result ((self test)) 90 (pop (test-results self))) 92 (defmethod eval-test ((self test)) 93 (eval `(progn ,@(test-form self)))) 95 (defmethod funcall-test ((self test) &key declare) 96 (unless (functionp (test-fn self)) 97 (trace! (setf (symbol-function (test-fn self)) 99 ,(when declare `(declare ,declare)) 100 ,@(test-form self)))))) 101 (funcall (test-fn self))) 103 (defmethod compile-test ((self test) &key declare &allow-other-keys) 104 (with-compilation-unit (:policy '(optimize debug)) 108 ,(when declare `(declare ,declare)) 109 ,@(test-form self))))) 111 (defun fail! (form &optional fmt &rest args) 112 (let ((reason (and fmt (apply #'format nil fmt args)))) 113 (with-simple-restart (ignore-fail "Continue testing.") 114 (error 'test-failed :reason reason :form form)))) 116 (defmacro with-test-env (self &body body) 118 (setf (test-lock-p ,self) t) 119 (let* ((*testing* ,self) 124 (setf (test-lock-p ,self) %test-bail)) 127 (defmethod do-test ((self test) &optional fx) 128 (declare (ignorable fx)) 130 (trace! "running test: " *testing*) 132 (if-let ((opt *compile-tests*)) 133 ;; RESEARCH 2023-08-31: with-compilation-unit? 136 (setq opt *test-opts*) 137 (setq opt (push *test-opts* opt))) 138 ;; TODO 2023-09-21: handle failures here 139 (funcall (compile-test self :declare opt)) 140 (setf %test-result (make-test-result :pass (test-fn self)))) 142 (funcall-test self :declare '(optimize (debug 3) (safety 0))) 143 (setf %test-result (make-test-result :pass (test-name self))))))) 144 (if *catch-test-errors* 149 (setf %test-result (make-test-result :fail c)) 150 (return-from %test-bail %test-result)))) 154 (defmethod do-test ((self simple-string) &optional fixture) 155 (when-let ((test (find-test *test-suite* self))) 156 (do-test test fixture))) 158 (defmethod do-test ((self symbol) &optional fixture) 159 (when-let ((test (find-test *test-suite* (symbol-name self)))) 160 (do-test test fixture))) 163 (defclass test-suite (test-object) 164 ((tests :initarg :set :initform nil :type list :accessor tests 165 :documentation "test-suite tests") 166 (results :initarg :results :initform nil :type list :accessor test-results 167 :documentation "test-suite results") 168 (stream :initarg :stream :initform *standard-output* :type stream :accessor test-stream) 169 (fixtures :initarg :fixtures :initform nil :type list :accessor test-fixtures)) 170 (:documentation "A class for collections of related `test' objects.")) 172 (defmethod print-object ((self test-suite) stream) 173 (print-unreadable-object (self stream :type t :identity t) 174 (format stream "~A [~d:~d:~d:~d]" 176 (length (tests self)) 177 (count t (map-tests self #'test-lock-p)) 178 (count t (map-tests self #'test-persist-p)) 179 (length (test-results self))))) 181 ;; (defmethod reinitialize-instance ((self test-suite) &rest initargs &key &allow-other-keys)) 183 (deftype test-suite-designator () 184 "Either nil, a symbol, a string, or a `test-suite' object." 185 '(or null symbol string test-suite keyword)) 187 (defun find-suite (name) 188 (declare (test-suite-designator name)) 189 (find name *test-suite-list* :test #'test-name=)) 191 (defmethod map-tests ((self test-suite) function) 192 ;; tests are stored in reverse order. run LIFO. 193 (mapcar function (reverse (tests self)))) 195 (defmethod push-test ((self test) (place test-suite)) 196 (push self (tests place))) 198 (defmethod pop-test ((self test-suite)) 201 (defmethod push-result ((self test-result) (place test-suite)) 202 (with-slots (results) place 203 (push self results))) 205 (defmethod pop-result ((self test-suite)) 206 (pop (test-results self))) 208 (defmethod find-test ((self test-suite) name &key (test #'test-name=)) 209 (declare (type (or string symbol) name) 210 (type function test)) 211 (find name (tests self) :test test)) 213 (defmethod do-test ((self test-suite) &optional test) 219 (string (find-test self test)) 220 (symbol (find-test self (symbol-name test))))) 221 (do-test (pop-test self))) 224 ;; HACK 2023-09-01: find better method of declaring failures from 225 ;; within the body of `deftest'. 226 (defmethod do-suite ((self test-suite) &key stream force) 227 (when stream (setf (test-stream self) stream)) 228 (with-slots (name stream) self 229 (format stream "in suite ~x:~%" 231 (format stream "; with ~A~A tests~%" 235 (count t (tests self) 236 :key (lambda (x) (or (test-lock-p x) (test-persist-p x)))))) 237 (length (tests self))) 238 ;; loop over each test, calling `do-test'. if locked or 239 ;; persistent, test is performed. if FORCE is non-nil all tests 243 (when (or force (test-lock-p x) (test-persist-p x)) 244 (let ((res (do-test x))) 245 (push-result res self) 246 (format stream "~@[~<~%~:;~:@(~S~) ~>~]~%" res))))) 247 ;; compare locked vs expected 248 (let ((locked (remove-if #'null (map-tests self (lambda (x) (when (test-lock-p x) x))))) 250 ;; collect if locked test not expected 251 (loop for r in (test-results self) 252 unless (test-pass-p r) 255 (format stream "~&No tests failed.~%") 257 ;; RESEARCH 2023-09-04: print fails ?? 258 (format stream "~&~A out of ~A ~ 259 total tests failed: ~ 263 (length (tests self)) 266 (format stream "~&~A unexpected failures: ~ 272 (finish-output stream) 273 ;; return values (PASS? LOCKED) 274 (values (not fails) locked)))) 276 (defmethod do-suite ((self string) &key stream) 277 (do-suite (ensure-suite self) :stream stream)) 279 (defmethod do-suite ((self symbol) &key stream) 280 (do-suite (ensure-suite self) :stream stream)) 282 (defmethod do-suite ((self null) &key stream) 283 (do-suite *test-suite* :stream stream)) 286 ;; Our fixtures are objects which can be inherited to build different fixture 287 ;; classes. Fixtures inherit from TEST-OBJECT and have a NAME which usually 288 ;; indicates the key used to initialize this object with MAKE-INSTANCE. 290 ;; You can use fixtures inside a test or use the push-fixture method on a 291 ;; `test-suite' object to make it accessible within that suite. 293 (defclass fixture (test-object) ()) 295 (defclass tmp-fixture (fixture) 296 ((directory :initform #P"/tmp/" :type directory :initarg :directory) 297 (file :initform nil :type (or null pathname string) :initarg :file)) 301 (defmethod make-fixture ((kind (eql :tmp)) &rest args) 302 (apply 'make-instance 'tmp-fixture args)) 304 (defmacro with-fixture ((var (kind &rest args)) &body body) 305 `(let ((,var (make-fixture ,kind ,@args)))