changeset 437: |
83f8623a6ec3 |
parent: |
49357f8b5e65
|
child: |
a37b1d3371fc |
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Tue, 11 Jun 2024 22:33:37 -0400 |
permissions: |
-rw-r--r-- |
description: |
std work, renamed :disabled in deftest to :skip |
1 ;;; rt.lisp --- regression testing 3 ;; Regression Testing framework. inspired by PCL, the original CMUCL 4 ;; code, and the SBCL port. 8 ;; - :rt https://www.merl.com/publications/docs/TR91-04.pdf Chapter 1 9 ;; - :com.gigamonkeys.test https://github.com/gigamonkey/monkeylib-test-framework 10 ;; - :sb-rt https://github.com/sbcl/sbcl/blob/master/contrib/sb-rt/rt.lisp 12 ;; This package is intended to provide a modernized Lisp testing 13 ;; library with features found in some of the test frameworks listed 16 ;; - :it.bese.fiveam https://github.com/lispci/fiveam 17 ;; - :try https://github.com/melisgl/try 18 ;; - :rove https://github.com/fukamachi/rove 23 - [ ] benchmark support: do-bench, test-count, 31 (eval-when (:compile-toplevel :load-toplevel :execute) 45 :*default-test-suite-name* 48 ;; TODO 2023-09-04: :*test-profiler-list* not yet 50 :test-suite-designator 51 :check-suite-designator 66 :make-fixture-prototype 101 (:use :cl :std :log :rt) 107 (uiop:define-package :rt/cover 109 (:use :cl :std :log :rt :sb-cover) 111 :with-coverage :start-coverage :stop-coverage 112 :*coverage-directory* 115 (defpackage :rt/tracing 116 (:nicknames :tracing) 117 (:use :cl :std :log :rt) 124 :package-symbols-except)) 126 (defpackage :rt/flamegraph 127 (:nicknames :flamegraph) 128 (:use :cl :std :log :rt :sb-sprof) 129 (:export :save-flamegraph)) 135 (defvar *test-opts* '(optimize sb-c::instrument-consing)) 136 (defvar *compile-tests* nil 137 "When nil do not compile tests. With a value of t, tests are compiled 138 with default optimizations else the value is used to configure 139 compiler optimizations.") 140 (defvar *catch-test-errors* t "When non-nil, cause errors in a test to be caught.") 141 (defvar *test-suffix* "-TEST" "A suffix to append to every `test' defined with `deftest'.") 142 (defvar *test-suite-list* nil "List of available `test-suite' objects.") 143 (defvar *test-suite* nil "A 'test-suite-designator' which identifies the current `test-suite'.") 144 (eval-when (:compile-toplevel :load-toplevel :execute) 145 (defvar *default-test-suite-name* "default")) 146 (declaim (type (or stream boolean string) *test-input*)) 147 (defvar *test-input* nil "When non-nil, specifies an input stream or buffer for `*testing*'.") 148 (defvar *testing* nil "Testing state var.") 151 (eval-when (:compile-toplevel :load-toplevel :execute) 152 (defun make-test (&rest slots) 153 (apply #'make-instance 'test slots)) 154 (defun make-suite (&rest slots) 155 (apply #'make-instance 'test-suite slots))) 157 ;; TODO 2023-09-04: optimize 158 ;;(declaim (inline do-tests)) 159 (defun do-tests (&optional (suite *test-suite*) force (output *standard-output*)) 160 (if (pathnamep output) 161 (with-open-file (stream output :direction :output) 162 (do-suite (ensure-suite suite) :stream stream :force force)) 163 (do-suite (ensure-suite suite) :stream output :force force))) 165 (defvar *test-output-mutex* (sb-thread:make-mutex :name "tests-output")) 168 (defun do-tests-concurrently (&optional (suite *test-suite*) force (output *standard-output*)) 169 (declare (ignore suite force)) 170 (sb-thread:with-mutex (*test-output-mutex*) 171 (let ((stream (make-synonym-stream output))) 172 (let ((*standard-output* stream) 173 (*error-output* stream)) 176 (defun reset-tests () 179 *test-suite-list* nil 182 ;; this assumes that *test-suite* is re-initialized correctly to the 183 ;; correct test-suite object. 184 (defun continue-testing () 185 (if-let ((test *testing*)) 186 (throw '%in-test test) 187 (do-suite *test-suite*))) 189 ;; NOTE 2023-09-01: `pushnew' does not return an indication of whether 190 ;; place is changed - it returns place. This is functionally sound but 191 ;; means that if we want to do something else in the event that place 192 ;; is unchanged, we run into some friction, 193 ;; https://stackoverflow.com/questions/56228832/adapting-common-lisp-pushnew-to-return-success-failure 194 (defun spush (item lst &key (test #'equal)) 195 "Substituting `push'" 196 (declare (type function test)) 198 ((null lst) (push item lst)) 200 (if-let ((found (member item lst 206 #|(or nil '(t (cons item lst)))|#)) 208 ;; FIX 2023-08-31: spush, replace with `add-test' method. 209 ;; (declaim (inline normalize-test-name)) 210 (defun normalize-test-name (a) 211 "Return the normalized `test-suite-designator' of A." 213 (string (string-upcase a)) 214 (symbol (symbol-name a)) 215 (test-object (normalize-test-name (test-name a))) 216 (t (format nil "~A" a)))) 218 (defun test-name= (a b) 219 "Return t if A and B are similar `test-suite-designator's." 220 (let ((a (normalize-test-name a)) 221 (b (normalize-test-name b))) 224 ;; (declaim (inline assert-suite ensure-suite)) 225 (defun ensure-suite (name) 226 (if-let ((ok (member name *test-suite-list* :test #'test-name=))) 228 (when (or (eq name t) (null name)) (make-suite :name *default-test-suite-name*)))) 230 (defun check-suite-designator (suite) (check-type suite test-suite-designator)) 232 (defun assert-suite (name) 233 (check-suite-designator name) 234 (assert (ensure-suite name))) 236 (declaim (inline test-opt-key-p test-opt-valid-p)) 237 (defun test-opt-key-p (k) 238 "Test if K is a `test-opt-key'." 239 (member k '(:profile :save :stream))) 241 (defun test-opt-valid-p (f) 242 "Test if F is a valid `test-opt' form. If so, return F else nil." 243 (when (test-opt-key-p (car f)) 247 (define-condition test-failed (error) 248 ((reason :accessor fail-reason :initarg :reason :initform "unknown") 249 (name :accessor fail-name :initarg :name) 250 (form :accessor fail-form :initarg :form)) 251 (:documentation "Signaled when a test fails.") 252 (:report (lambda (c s) 253 (format s "The following expression failed: ~S~%~A." 258 (defgeneric eval-test (self) 259 (:documentation "Eval a `test'.")) 261 (defgeneric compile-test (self &key &allow-other-keys) 262 (:documentation "Compile a `test'.")) 264 (defgeneric locked-tests (self) 265 (:documentation "Return a list of locked tests in `test-suite' object SELF.")) 267 (defgeneric push-test (self place) 269 "Push `test' SELF to the value of slot ':tests' in `test-suite' object PLACE.")) 271 (defgeneric pop-test (self) 273 "Pop the first `test' from the slot-value of ':tests' in `test-suite' object SELF.")) 275 (defgeneric push-result (self place) 277 "Push object SELF to the value of slot ':results' in object PLACE.")) 279 (defgeneric pop-result (self) 281 "Pop the first `test-result' from the slot-value of ':tests' from object SELF.")) 283 (defgeneric push-fixture (self place) 285 "Push object SELF to the value of slot ':results' in object PLACE.")) 287 (defgeneric delete-test (self &key &allow-other-keys) 288 (:documentation "Delete `test' object specified by `test-object' SELF and optional keys.")) 290 (defgeneric find-test (self name &key &allow-other-keys) 291 (:documentation "Find `test' object specified by name and optional keys.")) 293 (defgeneric do-test (self &optional context) 294 (:documentation "Run test SELF, printing results to *standard-output*. The second 295 argument is an optional fixture. 297 SELF can also be a `test-suite', in which case the TESTS slot is 298 queried for the value of TEST. If TEST is not provided, pops the car 301 (defgeneric do-suite (self &key &allow-other-keys) 303 "Perform actions on `test-suite' object SELF with optional keys.")) 306 (deftype result-tag () 307 '(or (member :pass :fail :skip) null)) 309 (declaim (inline %make-test-result)) 310 (defstruct (test-result (:constructor %make-test-result) 312 (tag nil :type result-tag :read-only t) 313 (form nil :type form)) 315 (defun make-test-result (tag &optional form) 316 (%make-test-result :tag tag :form form)) 318 (defmethod test-pass-p ((res test-result)) 319 (when (eq :pass (tr-tag res)) t)) 321 (defmethod test-fail-p ((res test-result)) 322 (when (eq :fail (tr-tag res)) t)) 324 (defmethod test-skip-p ((res test-result)) 325 (when (eq :skip (tr-tag res)) t)) 327 (defmethod print-object ((self test-result) stream) 328 (print-unreadable-object (self stream) 329 (format stream "~A ~A" 334 (defclass test-object () 335 ((name :initarg :name :initform (required-argument) :type string :accessor test-name) 336 #+nil (cached :initarg :cache :allocation :class :accessor test-cached-p :type boolean)) 337 (:documentation "Super class for all test-related objects.")) 339 (defmethod print-object ((self test-object) stream) 341 (print-unreadable-object (self stream :type t :identity t) 346 ;; HACK 2023-08-31: inherit sxp? 348 (defclass test (test-object) 349 ((fn :type symbol :accessor test-fn) 350 ;; (bench :type (or boolean fixnum) :accessor test-bench :initform nil :initarg :bench) 351 (profile :type list :accessor test-profile :initform nil :initarg :profile) 352 (args :type list :accessor test-args :initform nil :initarg :args) 353 (declaration :type list :accessor test-declaration :initform nil :initarg :declaration) 354 (form :initarg :form :initform nil :accessor test-form) 355 (doc :initarg :doc :type string :accessor test-doc) 356 (lock :initarg :lock :type boolean :accessor test-lock-p) 357 (persist :initarg :persist :initform nil :type boolean :accessor test-persist-p) 358 (results :initarg :results :type (array test-result) :accessor test-results)) 359 (:documentation "Test class typically made with `deftest'.")) 361 (defmethod initialize-instance ((self test) &key name) 362 ;; (debug! "building test" name) 367 (gensym *test-suffix*)))) 368 (setf (test-lock-p self) t) 369 ;; TODO 2023-09-21: we should count how many checks are in the :form 370 ;; slot and infer the array dimensions. 371 (setf (test-results self) (make-array 0 :element-type 'test-result)) 374 (defmethod print-object ((self test) stream) 375 (print-unreadable-object (self stream :type t :identity t) 376 (format stream "~A :fn ~A" 380 (defmethod push-result ((self test-result) (place test)) 381 (with-slots (results) place 382 (push self results))) 384 (defmethod pop-result ((self test)) 385 (pop (test-results self))) 387 (defmethod eval-test ((self test)) 388 (eval `(progn ,@(test-form self)))) 390 (defmethod funcall-test ((self test) &key declare) 391 (unless (functionp (test-fn self)) 392 (trace! (setf (symbol-function (test-fn self)) 394 ,(when declare `(declare ,declare)) 395 ,@(test-form self)))))) 396 (funcall (test-fn self))) 398 (defmethod compile-test ((self test) &key declare &allow-other-keys) 399 (with-compilation-unit (:policy '(optimize debug)) 403 ,(when declare `(declare ,declare)) 404 ,@(test-form self))))) 406 (defun fail! (form &optional fmt &rest args) 407 (let ((reason (and fmt (apply #'format nil fmt args)))) 408 (with-simple-restart (ignore-fail "Continue testing.") 409 (error 'test-failed :reason reason :form form)))) 411 (defmacro with-test-env (self &body body) 413 (setf (test-lock-p ,self) t) 414 (let* ((*testing* ,self) 419 (setf (test-lock-p ,self) %test-bail)) 422 (defmethod do-test ((self test) &optional fx) 423 (declare (ignorable fx)) 425 (trace! "running test: " *testing*) 427 (if-let ((opt *compile-tests*)) 428 ;; RESEARCH 2023-08-31: with-compilation-unit? 431 (setq opt *test-opts*) 432 (setq opt (push *test-opts* opt))) 433 ;; TODO 2023-09-21: handle failures here 434 (funcall (compile-test self :declare opt)) 435 (setf %test-result (make-test-result :pass (test-fn self)))) 437 (funcall-test self :declare '(optimize (debug 3) (safety 0))) 438 (setf %test-result (make-test-result :pass (test-name self))))))) 439 (if *catch-test-errors* 444 (setf %test-result (make-test-result :fail c)) 445 (return-from %test-bail %test-result)))) 449 (defmethod do-test ((self simple-string) &optional fixture) 450 (do-test (find-test *test-suite* self) fixture)) 452 (defmethod do-test ((self symbol) &optional fixture) 453 (do-test (find-test *test-suite* (symbol-name self)) fixture)) 457 ;; Our fixtures are just closures - with a pandoric environment. You 458 ;; might call it a domain-specific object protocol. 460 ;; You can build fixtures inside a test or use the push-fixture 461 ;; method on a `test-suite' object. 463 (deftype fixture () 'form) 465 (declaim (inline %make-fixture-prototype)) 466 (defstruct (fixture-prototype (:constructor %make-fixture-prototype) 468 (kind :empty :type keyword) 469 (form nil :type form)) 471 (defun make-fixture-prototype (kind form) 472 (%make-fixture-prototype :kind kind :form form)) 474 (defmacro make-fixture (letargs &body ds) 475 (let ((letargs (let-binding-transform letargs))) 479 (defmacro with-fixture ((var fx) &body body) 484 (defclass test-suite (test-object) 485 ((tests :initarg :set :initform nil :type list :accessor tests 486 :documentation "test-suite tests") 487 (results :initarg :results :initform nil :type list :accessor test-results 488 :documentation "test-suite results") 489 (stream :initarg :stream :initform *standard-output* :type stream :accessor test-stream) 490 (fixtures :initarg :fixtures :initform nil :type list :accessor test-fixtures)) 491 (:documentation "A class for collections of related `test' objects.")) 493 (defmethod print-object ((self test-suite) stream) 494 (print-unreadable-object (self stream :type t :identity t) 495 (format stream "~A [~d:~d:~d:~d]" 497 (length (tests self)) 498 (count t (map-tests self #'test-lock-p)) 499 (count t (map-tests self #'test-persist-p)) 500 (length (test-results self))))) 502 ;; (defmethod reinitialize-instance ((self test-suite) &rest initargs &key &allow-other-keys)) 504 (deftype test-suite-designator () 505 "Either nil, a symbol, a string, or a `test-suite' object." 506 '(or null symbol string test-suite keyword)) 508 (defun find-suite (name) 509 (declare (test-suite-designator name)) 510 (find name *test-suite-list* :test #'test-name=)) 512 (defmethod map-tests ((self test-suite) function) 513 (mapcar function (tests self))) 515 (defmethod push-test ((self test) (place test-suite)) 516 (push self (tests place))) 518 (defmethod pop-test ((self test-suite)) 521 (defmethod push-result ((self test-result) (place test-suite)) 522 (with-slots (results) place 523 (push self results))) 525 (defmethod pop-result ((self test-suite)) 526 (pop (test-results self))) 528 (defmethod find-test ((self test-suite) name &key (test #'test-name=)) 529 (declare (type (or string symbol) name) 530 (type function test)) 531 (find name (the list (tests self)) :test test)) 533 (defmethod do-test ((self test-suite) &optional test) 539 (string (find-test self test)) 540 (symbol (find-test self (symbol-name test))))) 541 (do-test (pop-test self))) 544 ;; HACK 2023-09-01: find better method of declaring failures from 545 ;; within the body of `deftest'. 546 (defmethod do-suite ((self test-suite) &key stream force) 547 (when stream (setf (test-stream self) stream)) 548 (with-slots (name stream) self 549 (format stream "in suite ~x:~%" 551 (format stream "; with ~A~A tests~%" 555 (count t (tests self) 556 :key (lambda (x) (or (test-lock-p x) (test-persist-p x)))))) 557 (length (tests self))) 558 ;; loop over each test, calling `do-test'. if locked or 559 ;; persistent, test is performed. if FORCE is non-nil all tests 563 (when (or force (test-lock-p x) (test-persist-p x)) 564 (let ((res (do-test x))) 565 (push-result res self) 566 (format stream "~@[~<~%~:;~:@(~S~) ~>~]~%" res))))) 567 ;; compare locked vs expected 568 (let ((locked (remove-if #'null (map-tests self (lambda (x) (when (test-lock-p x) x))))) 570 ;; collect if locked test not expected 571 (loop for r in (test-results self) 572 unless (test-pass-p r) 575 (format stream "~&No tests failed.~%") 577 ;; RESEARCH 2023-09-04: print fails ?? 578 (format stream "~&~A out of ~A ~ 579 total tests failed: ~ 583 (length (tests self)) 586 (format stream "~&~A unexpected failures: ~ 592 (finish-output stream) 593 ;; return values (PASS? LOCKED) 594 (values (not fails) locked)))) 596 (defmethod do-suite ((self string) &key stream) 597 (do-suite (ensure-suite self) :stream stream)) 599 (defmethod do-suite ((self symbol) &key stream) 600 (do-suite (ensure-suite self) :stream stream)) 602 (defmethod do-suite ((self null) &key stream) 603 (do-suite *test-suite* :stream stream)) 607 (defun %test (val &optional form) 610 (make-test-result :pass form) 611 (make-test-result :fail form)))) 612 ;; (print r *standard-output*) 615 (defmacro is (test &rest args) 618 (is (= 1 1)) ;=> #S(TEST-RESULT :TAG :PASS :FORM (= 1 1)) 619 If TEST returns a truthy value, return a PASS test-result, else return 620 a FAIL. The TEST is parameterized by ARGS which is a plist or nil. 622 If ARGS is nil, TEST is bound to to the RESULT slot of the test-result 623 and evaluated 'as-is'. 626 ARGS may contain the following keywords followed by a corresponding 635 All other values are treated as let bindings. 640 (push-result (funcall #'rt::%test ,test ',test) *testing*) 641 (funcall #'rt::%test ,test ',test)) 642 (macrolet ((,form (test) `(let ,,(group args 2) ,test))) 643 ;; TODO 2023-09-21: does this work... 645 (push-result (funcall #'rt::%test (,form ,test) ',test) *testing*) 646 (funcall #'rt::%test (,form ,test) ',test)))))) 648 (defmacro signals (condition-spec &body body) 649 "Generates a passing TEST-RESULT if body signals a condition of type 650 CONDITION-SPEC. BODY is evaluated in a block named NIL, CONDITION-SPEC 652 (let ((block-name (gensym))) 653 (destructuring-bind (condition &optional reason-control &rest reason-args) 654 (ensure-list condition-spec) 656 (handler-bind ((,condition (lambda (c) 658 ;; ok, body threw condition 659 ;; TODO 2023-09-05: result collectors 660 ;; (add-result 'test-passed 661 ;; :test-expr ',condition) 662 (return-from ,block-name (make-test-result :pass ',body))))) 664 (locally (declare (sb-ext:muffle-conditions warning)) 669 `(,reason-control ,@reason-args) 670 `("Failed to signal a ~S" ',condition))) 671 (return-from ,block-name nil))))) 674 (defmacro deftest (name props &body body) 675 "Build a test with NAME, parameterized by PROPS and with a test form of BODY. 677 PROPS is a plist which currently accepts the following parameters: 679 :PERSIST - re-run this test even if it passes 683 :PROFILE - enable profiling of this test 685 :SKIP - don't push this test to the current *TEST-SUITE* 687 :BENCH - enable benchmarking of this test 689 BODY is parsed with SB-INT:PARSE-BODY and will fill in documentation 690 and declarations for the test body. 692 (destructuring-bind (pr doc dec fn) 693 (multiple-value-bind (forms dec doc) 694 ;; parse body with docstring allowed 695 (parse-body (or body) :documentation t :whole t) 696 `(,props ,doc ,dec ',forms)) 697 ;; TODO 2023-09-21: parse plist 698 `(let ((obj (make-test 699 :name ,(format nil "~A" name) 701 ,@(when-let ((v (getf pr :persist))) `(:persist ,v)) 702 ,@(when-let ((v (getf pr :args))) `(:args ,v)) 703 ,@(when-let ((v (getf pr :bench))) `(:bench ,v)) 704 ,@(when-let ((v (getf pr :profile))) `(:profile ,v)) 705 ,@(when doc `(:doc ,doc)) 706 ,@(when dec `(:declaration ,dec))))) 707 ,(unless (getf pr :skip) '(push-test obj *test-suite*)) 710 (defmacro defsuite (suite-name &rest props) 711 "Define a TEST-SUITE with provided keys. The object returned can be 712 enabled using the IN-SUITE macro, similiar to the DEFPACKAGE API." 713 (check-type suite-name (or symbol string)) 714 `(eval-when (:compile-toplevel :load-toplevel :execute) 715 (let ((obj (make-suite 716 :name (format nil "~A" ',suite-name) 717 ,@(when-let ((v (getf props :stream))) `(:stream ,v))))) 718 (setq *test-suite-list* (spush obj *test-suite-list* :test #'test-name=)) 721 (defmacro in-suite (name) 722 "Set *TEST-SUITE* to the TEST-SUITE object referred to by symbol 723 NAME. Return the object." 726 (setq *test-suite* (ensure-suite ,name))))