changeset 282: |
da580c7fe954 |
parent: |
5f782d361e08
|
child: |
597f34d43df7 |
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Wed, 17 Apr 2024 22:53:44 -0400 |
permissions: |
-rw-r--r-- |
description: |
upgrades |
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) 38 :sb-aprof #+x86-64 :sb-sprof) 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) 110 (:reexport :sb-cover) 111 (:reexport :sb-sprof) 113 :with-coverage :start-coverage :stop-coverage 114 :*coverage-directory* 117 (defpackage :rt/tracing 118 (:nicknames :tracing) 119 (:use :cl :std :log :rt) 126 :package-symbols-except)) 128 (defpackage :rt/flamegraph 129 (:nicknames :flamegraph) 130 (:use :cl :std :log :rt :sb-sprof) 131 (:export :save-flamegraph)) 137 (defvar *test-opts* '(optimize sb-c::instrument-consing)) 138 (defvar *compile-tests* t 139 "When nil do not compile tests. With a value of t, tests are compiled 140 with default optimizations else the value is used to configure 141 compiler optimizations.") 142 (defvar *catch-test-errors* t "When non-nil, cause errors in a test to be caught.") 143 (defvar *test-suffix* "-test" "A suffix to append to every `test' defined with `deftest'.") 144 (defvar *test-suite-list* nil "List of available `test-suite' objects.") 145 (defvar *test-suite* nil "A 'test-suite-designator' which identifies the current `test-suite'.") 146 (eval-when (:compile-toplevel :load-toplevel :execute) 147 (defvar *default-test-suite-name* "default")) 148 (declaim (type (or stream boolean string) *test-input*)) 149 (defvar *test-input* nil "When non-nil, specifies an input stream or buffer for `*testing*'.") 150 (defvar *testing* nil "Testing state var.") 153 (eval-when (:compile-toplevel :load-toplevel :execute) 154 (defun make-test (&rest slots) 155 (apply #'make-instance 'test slots)) 156 (defun make-suite (&rest slots) 157 (apply #'make-instance 'test-suite slots))) 159 ;; TODO 2023-09-04: optimize 160 ;;(declaim (inline do-tests)) 161 (defun do-tests (&optional (suite *test-suite*) force (output *standard-output*)) 162 (if (pathnamep output) 163 (with-open-file (stream output :direction :output) 164 (do-suite (ensure-suite suite) :stream stream :force force)) 165 (do-suite (ensure-suite suite) :stream output :force force))) 167 (defvar *test-output-mutex* (sb-thread:make-mutex :name "tests-output")) 170 (defun do-tests-concurrently (&optional (suite *test-suite*) force (output *standard-output*)) 171 (declare (ignore suite force)) 172 (sb-thread:with-mutex (*test-output-mutex*) 173 (let ((stream (make-synonym-stream output))) 174 (let ((*standard-output* stream) 175 (*error-output* stream)) 178 (defun reset-tests () 181 *test-suite-list* nil 184 ;; this assumes that *test-suite* is re-initialized correctly to the 185 ;; correct test-suite object. 186 (defun continue-testing () 187 (if-let ((test *testing*)) 188 (throw '%in-test test) 189 (do-suite *test-suite*))) 191 ;; NOTE 2023-09-01: `pushnew' does not return an indication of whether 192 ;; place is changed - it returns place. This is functionally sound but 193 ;; means that if we want to do something else in the event that place 194 ;; is unchanged, we run into some friction, 195 ;; https://stackoverflow.com/questions/56228832/adapting-common-lisp-pushnew-to-return-success-failure 196 (defun spush (item lst &key (test #'equal)) 197 "Substituting `push'" 198 (declare (type function test)) 200 ((null lst) (push item lst)) 202 (if-let ((found (member item lst 208 #|(or nil '(t (cons item lst)))|#)) 210 ;; FIX 2023-08-31: spush, replace with `add-test' method. 211 ;; (declaim (inline normalize-test-name)) 212 (defun normalize-test-name (a) 213 "Return the normalized `test-suite-designator' of A." 215 (string (string-upcase a)) 216 (symbol (symbol-name a)) 217 (test-object (normalize-test-name (test-name a))) 218 (t (format nil "~A" a)))) 220 (defun test-name= (a b) 221 "Return t if A and B are similar `test-suite-designator's." 222 (let ((a (normalize-test-name a)) 223 (b (normalize-test-name b))) 226 ;; (declaim (inline assert-suite ensure-suite)) 227 (defun ensure-suite (name) 228 (if-let ((ok (member name *test-suite-list* :test #'test-name=))) 230 (when (or (eq name t) (null name)) (make-suite :name *default-test-suite-name*)))) 232 (defun check-suite-designator (suite) (check-type suite test-suite-designator)) 234 (defun assert-suite (name) 235 (check-suite-designator name) 236 (assert (ensure-suite name))) 238 (declaim (inline test-opt-key-p test-opt-valid-p)) 239 (defun test-opt-key-p (k) 240 "Test if K is a `test-opt-key'." 241 (member k '(:profile :save :stream))) 243 (defun test-opt-valid-p (f) 244 "Test if F is a valid `test-opt' form. If so, return F else nil." 245 (when (test-opt-key-p (car f)) 249 (define-condition test-failed (error) 250 ((reason :accessor fail-reason :initarg :reason :initform "unknown") 251 (name :accessor fail-name :initarg :name) 252 (form :accessor fail-form :initarg :form)) 253 (:documentation "Signaled when a test fails.") 254 (:report (lambda (c s) 255 (format s "The following expression failed: ~S~%~A." 260 (defgeneric eval-test (self) 261 (:documentation "Eval a `test'.")) 263 (defgeneric compile-test (self &key &allow-other-keys) 264 (:documentation "Compile a `test'.")) 266 (defgeneric locked-tests (self) 267 (:documentation "Return a list of locked tests in `test-suite' object SELF.")) 269 (defgeneric push-test (self place) 271 "Push `test' SELF to the value of slot ':tests' in `test-suite' object PLACE.")) 273 (defgeneric pop-test (self) 275 "Pop the first `test' from the slot-value of ':tests' in `test-suite' object SELF.")) 277 (defgeneric push-result (self place) 279 "Push object SELF to the value of slot ':results' in object PLACE.")) 281 (defgeneric pop-result (self) 283 "Pop the first `test-result' from the slot-value of ':tests' from object SELF.")) 285 (defgeneric push-fixture (self place) 287 "Push object SELF to the value of slot ':results' in object PLACE.")) 289 (defgeneric delete-test (self &key &allow-other-keys) 290 (:documentation "Delete `test' object specified by `test-object' SELF and optional keys.")) 292 (defgeneric find-test (self name &key &allow-other-keys) 293 (:documentation "Find `test' object specified by name and optional keys.")) 295 (defgeneric do-test (self &optional test) 297 "Run `test' SELF, printing results to `*standard-output*'. The second 298 argument is an optional fixture. 300 SELF can also be a `test-suite', in which case the TESTS slot is 301 queried for the value of TEST. If TEST is not provided, pops the car 304 (defgeneric do-suite (self &key &allow-other-keys) 306 "Perform actions on `test-suite' object SELF with optional keys.")) 309 (deftype result-tag () 310 '(or (member :pass :fail :skip) null)) 312 (declaim (inline %make-test-result)) 313 (defstruct (test-result (:constructor %make-test-result) 315 (tag nil :type result-tag :read-only t) 316 (form nil :type form)) 318 (defun make-test-result (tag &optional form) 319 (%make-test-result :tag tag :form form)) 321 (defmethod test-pass-p ((res test-result)) 322 (when (eq :pass (tr-tag res)) t)) 324 (defmethod test-fail-p ((res test-result)) 325 (when (eq :fail (tr-tag res)) t)) 327 (defmethod test-skip-p ((res test-result)) 328 (when (eq :skip (tr-tag res)) t)) 330 (defmethod print-object ((self test-result) stream) 331 (print-unreadable-object (self stream) 332 (format stream "~A ~A" 337 (defclass test-object () 338 ((name :initarg :name :initform (required-argument) :type string :accessor test-name) 339 #+nil (cached :initarg :cache :allocation :class :accessor test-cached-p :type boolean)) 340 (:documentation "Super class for all test-related objects.")) 342 (defmethod print-object ((self test-object) stream) 344 (print-unreadable-object (self stream :type t :identity t) 349 ;; HACK 2023-08-31: inherit sxp? 351 (defclass test (test-object) 352 ((fn :type symbol :accessor test-fn) 353 ;; (bench :type (or boolean fixnum) :accessor test-bench :initform nil :initarg :bench) 354 (profile :type list :accessor test-profile :initform nil :initarg :profile) 355 (args :type list :accessor test-args :initform nil :initarg :args) 356 (decl :type list :accessor test-decl :initform nil :initarg :decl) 357 (form :initarg :form :initform nil :type function-lambda-expression :accessor test-form) 358 (doc :initarg :doc :type string :accessor test-doc) 359 (lock :initarg :lock :type boolean :accessor test-lock-p) 360 (persist :initarg :persist :initform nil :type boolean :accessor test-persist-p) 361 (results :initarg :results :type (array test-result) :accessor test-results)) 362 (:documentation "Test class typically made with `deftest'.")) 364 (defmethod initialize-instance ((self test) &key name) 365 ;; (debug! "building test" name) 370 (gensym *test-suffix*)))) 371 (setf (test-lock-p self) t) 372 ;; TODO 2023-09-21: we should count how many checks are in the :form 373 ;; slot and infer the array dimensions. 374 (setf (test-results self) (make-array 0 :element-type 'test-result)) 377 (defmethod print-object ((self test) stream) 378 (print-unreadable-object (self stream :type t :identity t) 379 (format stream "~A :fn ~A :args ~A :persist ~A" 383 (test-persist-p self)))) 385 (defmethod push-result ((self test-result) (place test)) 386 (with-slots (results) place 387 (push self results))) 389 (defmethod pop-result ((self test)) 390 (pop (test-results self))) 392 (defmethod eval-test ((self test)) 393 (eval `(progn ,@(test-form self)))) 395 (defmethod compile-test ((self test) &key declare &allow-other-keys) 399 ,(when declare `(declare ,declare)) 400 ,@(test-form self)))) 402 (defun fail! (form &optional fmt &rest args) 403 (let ((reason (and fmt (apply #'format nil fmt args)))) 404 (with-simple-restart (ignore-fail "Continue testing.") 405 (error 'test-failed :reason reason :form form)))) 407 (defmacro with-test-env (self &body body) 409 (setf (test-lock-p ,self) t) 410 (let* ((*testing* ,self) 415 (setf (test-lock-p ,self) %test-bail)) 418 (defmethod do-test ((self test) &optional fx) 419 (declare (ignorable fx)) 421 (debug! "running test: " *testing*) 423 (if-let ((opt *compile-tests*)) 424 ;; RESEARCH 2023-08-31: with-compilation-unit? 427 (setq opt *test-opts*) 428 (setq opt (push *test-opts* opt))) 429 ;; TODO 2023-09-21: handle failures here 430 (ignore-some-conditions (style-warning) (funcall (compile-test self :declare opt))) 431 (setf %test-result (make-test-result :pass (test-fn self)))) 433 (ignore-some-conditions (style-warning) (eval-test self)) 434 (setf %test-result (make-test-result :pass (test-name self))))))) 435 (if *catch-test-errors* 437 ((style-warning #'muffle-warning) 441 (setf %test-result (make-test-result :fail c)) 442 (return-from %test-bail %test-result)))) 448 ;; Our fixtures are just closures - with a pandoric environment. You 449 ;; might call it a domain-specific object protocol. 451 ;; You can build fixtures inside a test or use the push-fixture 452 ;; method on a `test-suite' object. 454 (deftype fixture () 'form) 456 (declaim (inline %make-fixture-prototype)) 457 (defstruct (fixture-prototype (:constructor %make-fixture-prototype) 459 (kind :empty :type keyword) 460 (form nil :type form)) 462 (defun make-fixture-prototype (kind form) 463 (%make-fixture-prototype :kind kind :form form)) 465 (defmacro make-fixture (letargs &body ds) 466 (let ((letargs (let-binding-transform letargs))) 470 (defmacro with-fixture ((var fx) &body body) 475 (defclass test-suite (test-object) 476 ((tests :initarg :set :initform nil :type list :accessor tests 477 :documentation "test-suite tests") 478 (results :initarg :results :initform nil :type list :accessor test-results 479 :documentation "test-suite results") 480 (stream :initarg :stream :initform *standard-output* :type stream :accessor test-stream) 481 (fixtures :initarg :fixtures :initform nil :type list :accessor test-fixtures)) 482 (:documentation "A class for collections of related `test' objects.")) 484 (defmethod print-object ((self test-suite) stream) 485 (print-unreadable-object (self stream :type t :identity t) 486 (format stream "~A [~d:~d:~d:~d]" 488 (length (tests self)) 489 (count t (map-tests self #'test-lock-p)) 490 (count t (map-tests self #'test-persist-p)) 491 (length (test-results self))))) 493 ;; (defmethod reinitialize-instance ((self test-suite) &rest initargs &key &allow-other-keys)) 495 (deftype test-suite-designator () 496 "Either nil, a symbol, a string, or a `test-suite' object." 497 '(or null symbol string test-suite keyword)) 499 (defun find-suite (name) 500 (declare (test-suite-designator name)) 501 (find name *test-suite-list* :test #'test-name=)) 503 (defmethod map-tests ((self test-suite) function) 504 (mapcar function (tests self))) 506 (defmethod push-test ((self test) (place test-suite)) 507 (push self (tests place))) 509 (defmethod pop-test ((self test-suite)) 512 (defmethod push-result ((self test-result) (place test-suite)) 513 (with-slots (results) place 514 (push self results))) 516 (defmethod pop-result ((self test-suite)) 517 (pop (test-results self))) 519 (defmethod find-test ((self test-suite) name &key (test #'test-name=)) 520 (declare (type (or string symbol) name) 521 (type function test)) 522 (find name (the list (tests self)) :test test)) 524 (defmethod do-test ((self test-suite) &optional test) 530 (string (find-test self test)) 531 (symbol (find-test self (symbol-name test))))) 532 (do-test (pop-test self))) 535 (defmethod do-test ((self simple-string) &optional test) 536 (let ((suite (find-suite self))) 537 (do-test suite test))) 539 (defmethod do-test ((self symbol) &optional test) 540 (do-test (symbol-name self) test)) 542 ;; HACK 2023-09-01: find better method of declaring failures from 543 ;; within the body of `deftest'. 544 (defmethod do-suite ((self test-suite) &key stream force) 545 (when stream (setf (test-stream self) stream)) 546 (with-slots (name stream) self 547 (format stream "in suite ~x with ~A/~A tests:~%" 549 (count t (tests self) 550 :key (lambda (x) (or (test-lock-p x) (test-persist-p x)))) 551 (length (tests self))) 552 ;; loop over each test, calling `do-test'. if locked or 553 ;; persistent, test is performed. if FORCE is non-nil all tests 557 (when (or force (test-lock-p x) (test-persist-p x)) 558 (let ((res (do-test x))) 559 (push-result res self) 560 (format stream "~@[~<~%~:;~:@(~S~) ~>~]~%" res))))) 561 ;; compare locked vs expected 562 (let ((locked (remove-if #'null (map-tests self (lambda (x) (when (test-lock-p x) x))))) 564 ;; collect if locked test not expected 565 (loop for r in (test-results self) 566 unless (test-pass-p r) 569 (format stream "~&No tests failed.~%") 571 ;; RESEARCH 2023-09-04: print fails ?? 572 (format stream "~&~A out of ~A ~ 573 total tests failed: ~ 577 (length (tests self)) 580 (format stream "~&~A unexpected failures: ~ 586 (finish-output stream) 587 ;; return values (PASS? LOCKED) 588 (values (not fails) locked)))) 590 (defmethod do-suite ((self string) &key stream) 591 (do-suite (ensure-suite self) :stream stream)) 593 (defmethod do-suite ((self symbol) &key stream) 594 (do-suite (ensure-suite self) :stream stream)) 596 (defmethod do-suite ((self null) &key stream) 597 (do-suite *test-suite* :stream stream)) 600 (flet ((%test (val form) 603 (make-test-result :pass form) 604 (make-test-result :fail form)))) 607 (defmacro is (test &rest args) 610 (is (= 1 1)) ;=> #S(TEST-RESULT :TAG :PASS :FORM (= 1 1)) 611 If TEST returns a truthy value, return a PASS test-result, else return 612 a FAIL. The TEST is parameterized by ARGS which is a plist or nil. 614 If ARGS is nil, TEST is bound to to the RESULT slot of the test-result 615 and evaluated 'as-is'. 618 ARGS may contain the following keywords followed by a corresponding 627 All other values are treated as let bindings. 632 (push-result (funcall ,#'%test ,test ',test) *testing*) 633 (funcall ,#'%test ,test ',test)) 634 (macrolet ((,form (test) `(let ,,(group args 2) ,,test))) 635 ;; TODO 2023-09-21: does this work... 637 (push-result (funcall ,#'%test (,form ,test) ',test) *testing*) 638 (funcall ,#'%test (,form ,test) ',test))))))) 640 (defmacro signals (condition-spec &body body) 641 "Generates a passing TEST-RESULT if body signals a condition of type 642 CONDITION-SPEC. BODY is evaluated in a block named NIL, CONDITION-SPEC 644 (let ((block-name (gensym))) 645 (destructuring-bind (condition &optional reason-control &rest reason-args) 646 (ensure-list condition-spec) 648 (handler-bind ((,condition (lambda (c) 649 ;; ok, body threw condition 650 ;; TODO 2023-09-05: result collectors 651 ;; (add-result 'test-passed 652 ;; :test-expr ',condition) 653 (return-from ,block-name (make-test-result :pass ',body))))) 659 `(,reason-control ,@reason-args) 660 `("Failed to signal a ~S" ',condition))) 661 (return-from ,block-name nil))))) 664 (defmacro deftest (name props &body body) 665 "Build a test with NAME, parameterized by PROPS and with a test form of BODY. 667 PROPS is a plist which currently accepts the following parameters: 669 :PERSIST - re-run this test even if it passes 673 :PROFILE - enable profiling of this test 675 :DISABLED - don't push this test to the current *TEST-SUITE* 677 BODY is parsed with SB-INT:PARSE-BODY and will fill in documentation 678 and declarations for the test body. 680 (destructuring-bind (pr doc dec fn) 681 (multiple-value-bind (forms dec doc) 682 ;; parse body with docstring allowed 683 (sb-int:parse-body (or body) t) 684 `(,props ',doc ',dec ',forms)) 685 ;; TODO 2023-09-21: parse plist 686 `(let ((obj (make-test 687 :name ,(format nil "~A" name) 688 ;; note: we could leave these unbound if we want, 689 ;; personal preference 691 ,@(when-let ((v (getf pr :persist))) `(:persist ,v)) 692 ,@(when-let ((v (getf pr :args))) `(:args ,v)) 693 ;; ,@(when-let ((v (getf pr :bench))) `(:bench ,v)) 694 ,@(when-let ((v (getf pr :profile))) `(:profile ,v)) 695 ,@(when doc `(:doc ,doc)) 696 ,@(when dec `(:decl ,dec))))) 697 ,(unless (getf pr :disabled) '(push-test obj *test-suite*)) 700 (defmacro defsuite (suite-name &rest props) 701 "Define a TEST-SUITE with provided keys. The object returned can be 702 enabled using the IN-SUITE macro, similiar to the DEFPACKAGE API." 703 (check-type suite-name (or symbol string)) 704 `(eval-when (:compile-toplevel :load-toplevel :execute) 705 (let ((obj (make-suite 706 :name (format nil "~A" ',suite-name) 707 ,@(when-let ((v (getf props :stream))) `(:stream ,v))))) 708 (setq *test-suite-list* (spush obj *test-suite-list* :test #'test-name=)) 711 (defmacro in-suite (name) 712 "Set *TEST-SUITE* to the TEST-SUITE object referred to by symbol 713 NAME. Return the object." 716 (setq *test-suite* (ensure-suite ,name))))