changeset 582: |
568c39371122 |
parent: |
806c2b214df8
|
child: |
bbd9024f2fe2 |
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Wed, 07 Aug 2024 21:09:43 -0400 |
permissions: |
-rw-r--r-- |
description: |
sql updates, fuzzz |
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, 30 (in-package :std-user) 42 :*default-test-suite-name* 45 ;; TODO 2023-09-04: :*test-profiler-list* not yet 52 :test-suite-designator 53 :check-suite-designator 68 :make-fixture-prototype 101 (defpackage :rt/bench 103 (:use :cl :std :log :rt) 109 (uiop:define-package :rt/cover 111 (:use :cl :std :log :rt) 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)) 135 (:use :cl :std :log :rt) 146 (defvar *test-opts* '(optimize sb-c::instrument-consing)) 147 (defvar *compile-tests* nil 148 "When nil do not compile tests. With a value of t, tests are compiled 149 with default optimizations else the value is used to configure 150 compiler optimizations.") 151 (defvar *catch-test-errors* t "When non-nil, cause errors in a test to be caught.") 152 (defvar *test-suffix* "-TEST" "A suffix to append to every `test' defined with `deftest'.") 153 (defvar *test-suite-list* nil "List of available `test-suite' objects.") 154 (defvar *test-suite* nil "A 'test-suite-designator' which identifies the current `test-suite'.") 155 (eval-when (:compile-toplevel :load-toplevel :execute) 156 (defvar *default-test-suite-name* "default")) 157 (declaim (type (or stream boolean string) *test-input*)) 158 (defvar *test-input* nil "When non-nil, specifies an input stream or buffer for `*testing*'.") 159 (defvar *testing* nil "Testing state var.") 164 (defvar *simple-charset* "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789") 166 (defun random-elt (seq) 167 (elt seq (random (length seq)))) 169 (defun random-ref (vec) 170 (aref vec (random (length vec)))) 172 (defun random-char () 173 (random-ref *simple-charset*)) 175 (defun random-chars (dim) 176 (let ((r (make-array dim :element-type 'character))) 177 (dotimes (i (array-total-size r) r) 178 (setf (row-major-aref r i) (random-char))))) 180 (defun random-byte () (random 255)) 182 (defun random-bytes (dim) 183 (let ((r (make-array dim :element-type 'octet))) 184 (dotimes (i (array-total-size r) r) 185 (setf (row-major-aref r i) (random-byte))))) 187 (eval-when (:compile-toplevel :load-toplevel :execute) 188 (defun make-test (&rest slots) 189 (apply #'make-instance 'test slots)) 190 (defun make-suite (&rest slots) 191 (apply #'make-instance 'test-suite slots))) 193 ;; TODO 2023-09-04: optimize 194 ;;(declaim (inline do-tests)) 195 (defun do-tests (&optional (suite *test-suite*) force (output *standard-output*)) 196 (if (pathnamep output) 197 (with-open-file (stream output :direction :output) 198 (do-suite (ensure-suite suite) :stream stream :force force)) 199 (do-suite (ensure-suite suite) :stream output :force force))) 201 (defvar *test-output-mutex* (sb-thread:make-mutex :name "tests-output")) 204 (defun do-tests-concurrently (&optional (suite *test-suite*) force (output *standard-output*)) 205 (declare (ignore suite force)) 206 (sb-thread:with-mutex (*test-output-mutex*) 207 (let ((stream (make-synonym-stream output))) 208 (let ((*standard-output* stream) 209 (*error-output* stream)) 212 (defun reset-tests () 215 *test-suite-list* nil 218 ;; this assumes that *test-suite* is re-initialized correctly to the 219 ;; correct test-suite object. 220 (defun continue-testing () 221 (if-let ((test *testing*)) 222 (throw '%in-test test) 223 (do-suite *test-suite*))) 225 ;; NOTE 2023-09-01: `pushnew' does not return an indication of whether 226 ;; place is changed - it returns place. This is functionally sound but 227 ;; means that if we want to do something else in the event that place 228 ;; is unchanged, we run into some friction, 229 ;; https://stackoverflow.com/questions/56228832/adapting-common-lisp-pushnew-to-return-success-failure 230 (defun spush (item lst &key (test #'equal)) 231 "Substituting `push'" 232 (declare (type function test)) 234 ((null lst) (push item lst)) 236 (if-let ((found (member item lst 242 #|(or nil '(t (cons item lst)))|#)) 244 ;; FIX 2023-08-31: spush, replace with `add-test' method. 245 ;; (declaim (inline normalize-test-name)) 246 (defun normalize-test-name (a) 247 "Return the normalized `test-suite-designator' of A." 249 (string (string-upcase a)) 250 (symbol (symbol-name a)) 251 (test-object (normalize-test-name (test-name a))) 252 (t (format nil "~A" a)))) 254 (defun test-name= (a b) 255 "Return t if A and B are similar `test-suite-designator's." 256 (let ((a (normalize-test-name a)) 257 (b (normalize-test-name b))) 260 ;; (declaim (inline assert-suite ensure-suite)) 261 (defun ensure-suite (name) 262 (if-let ((ok (member name *test-suite-list* :test #'test-name=))) 264 (when (or (eq name t) (null name)) (make-suite :name *default-test-suite-name*)))) 266 (defun check-suite-designator (suite) (check-type suite test-suite-designator)) 268 (defun assert-suite (name) 269 (check-suite-designator name) 270 (assert (ensure-suite name))) 272 (declaim (inline test-opt-key-p test-opt-valid-p)) 273 (defun test-opt-key-p (k) 274 "Test if K is a `test-opt-key'." 275 (member k '(:profile :save :stream))) 277 (defun test-opt-valid-p (f) 278 "Test if F is a valid `test-opt' form. If so, return F else nil." 279 (when (test-opt-key-p (car f)) 283 (define-condition test-failed (error) 284 ((reason :accessor fail-reason :initarg :reason :initform "unknown") 285 (name :accessor fail-name :initarg :name) 286 (form :accessor fail-form :initarg :form)) 287 (:documentation "Signaled when a test fails.") 288 (:report (lambda (c s) 289 (format s "The following expression failed: ~S~%~A." 294 (defgeneric eval-test (self) 295 (:documentation "Eval a `test'.")) 297 (defgeneric compile-test (self &key &allow-other-keys) 298 (:documentation "Compile a `test'.")) 300 (defgeneric locked-tests (self) 301 (:documentation "Return a list of locked tests in `test-suite' object SELF.")) 303 (defgeneric push-test (self place) 305 "Push `test' SELF to the value of slot ':tests' in `test-suite' object PLACE.")) 307 (defgeneric pop-test (self) 309 "Pop the first `test' from the slot-value of ':tests' in `test-suite' object SELF.")) 311 (defgeneric push-result (self place) 313 "Push object SELF to the value of slot ':results' in object PLACE.")) 315 (defgeneric pop-result (self) 317 "Pop the first `test-result' from the slot-value of ':tests' from object SELF.")) 319 (defgeneric push-fixture (self place) 321 "Push object SELF to the value of slot ':results' in object PLACE.")) 323 (defgeneric delete-test (self &key &allow-other-keys) 324 (:documentation "Delete `test' object specified by `test-object' SELF and optional keys.")) 326 (defgeneric find-test (self name &key &allow-other-keys) 327 (:documentation "Find `test' object specified by name and optional keys.")) 329 (defgeneric do-test (self &optional context) 330 (:documentation "Run test SELF, printing results to *standard-output*. The second 331 argument is an optional fixture. 333 SELF can also be a `test-suite', in which case the TESTS slot is 334 queried for the value of TEST. If TEST is not provided, pops the car 337 (defgeneric do-suite (self &key &allow-other-keys) 339 "Perform actions on `test-suite' object SELF with optional keys.")) 342 (deftype result-tag () 343 '(or (member :pass :fail :skip) null)) 345 (declaim (inline %make-test-result)) 346 (defstruct (test-result (:constructor %make-test-result) 348 (tag nil :type result-tag :read-only t) 349 (form nil :type form)) 351 (defmethod print-object ((self test-result) stream) 352 (print-unreadable-object (self stream :identity t) 353 (format stream "~A ~A" (tr-tag self) (tr-form self)))) 355 (defun make-test-result (tag &optional form) 356 (%make-test-result :tag tag :form form)) 358 (defmethod test-pass-p ((res test-result)) 359 (when (eq :pass (tr-tag res)) t)) 361 (defmethod test-fail-p ((res test-result)) 362 (when (eq :fail (tr-tag res)) t)) 364 (defmethod test-skip-p ((res test-result)) 365 (when (eq :skip (tr-tag res)) t)) 367 (defmethod print-object ((self test-result) stream) 368 (print-unreadable-object (self stream) 369 (format stream "~A ~A" 374 (defclass test-object () 375 ((name :initarg :name :initform (required-argument) :type string :accessor test-name) 376 #+nil (cached :initarg :cache :allocation :class :accessor test-cached-p :type boolean)) 377 (:documentation "Super class for all test-related objects.")) 379 (defmethod print-object ((self test-object) stream) 381 (print-unreadable-object (self stream :type t :identity t) 386 ;; HACK 2023-08-31: inherit sxp? 388 (defclass test (test-object) 389 ((fn :type symbol :accessor test-fn) 390 (bench :type (or boolean fixnum) :accessor test-bench :initform nil :initarg :bench) 391 (profile :type list :accessor test-profile :initform nil :initarg :profile) 392 (args :type list :accessor test-args :initform nil :initarg :args) 393 (declare :type list :accessor test-declare :initform nil :initarg :declare) 394 (form :initarg :form :initform nil :accessor test-form) 395 (doc :initarg :doc :type string :accessor test-doc) 396 (lock :initarg :lock :type boolean :accessor test-lock-p) 397 (persist :initarg :persist :initform nil :type boolean :accessor test-persist-p) 398 (results :initarg :results :type (array test-result) :accessor test-results)) 399 (:documentation "Test class typically made with `deftest'.")) 401 (defmethod initialize-instance ((self test) &key name) 402 ;; (debug! "building test" name) 407 (gensym *test-suffix*)))) 408 (setf (test-lock-p self) t) 409 ;; TODO 2023-09-21: we should count how many checks are in the :form 410 ;; slot and infer the array dimensions. 411 (setf (test-results self) (make-array 0 :element-type 'test-result)) 414 (defmethod print-object ((self test) stream) 415 (print-unreadable-object (self stream :type t :identity t) 416 (format stream "~A :fn ~A" 420 (defmethod push-result ((self test-result) (place test)) 421 (with-slots (results) place 422 (push self results))) 424 (defmethod pop-result ((self test)) 425 (pop (test-results self))) 427 (defmethod eval-test ((self test)) 428 (eval `(progn ,@(test-form self)))) 430 (defmethod funcall-test ((self test) &key declare) 431 (unless (functionp (test-fn self)) 432 (trace! (setf (symbol-function (test-fn self)) 434 ,(when declare `(declare ,declare)) 435 ,@(test-form self)))))) 436 (funcall (test-fn self))) 438 (defmethod compile-test ((self test) &key declare &allow-other-keys) 439 (with-compilation-unit (:policy '(optimize debug)) 443 ,(when declare `(declare ,declare)) 444 ,@(test-form self))))) 446 (defun fail! (form &optional fmt &rest args) 447 (let ((reason (and fmt (apply #'format nil fmt args)))) 448 (with-simple-restart (ignore-fail "Continue testing.") 449 (error 'test-failed :reason reason :form form)))) 451 (defmacro with-test-env (self &body body) 453 (setf (test-lock-p ,self) t) 454 (let* ((*testing* ,self) 459 (setf (test-lock-p ,self) %test-bail)) 462 (defmethod do-test ((self test) &optional fx) 463 (declare (ignorable fx)) 465 (trace! "running test: " *testing*) 467 (if-let ((opt *compile-tests*)) 468 ;; RESEARCH 2023-08-31: with-compilation-unit? 471 (setq opt *test-opts*) 472 (setq opt (push *test-opts* opt))) 473 ;; TODO 2023-09-21: handle failures here 474 (funcall (compile-test self :declare opt)) 475 (setf %test-result (make-test-result :pass (test-fn self)))) 477 (funcall-test self :declare '(optimize (debug 3) (safety 0))) 478 (setf %test-result (make-test-result :pass (test-name self))))))) 479 (if *catch-test-errors* 484 (setf %test-result (make-test-result :fail c)) 485 (return-from %test-bail %test-result)))) 489 (defmethod do-test ((self simple-string) &optional fixture) 490 (when-let ((test (find-test *test-suite* self))) 491 (do-test test fixture))) 493 (defmethod do-test ((self symbol) &optional fixture) 494 (when-let ((test (find-test *test-suite* (symbol-name self)))) 495 (do-test test fixture))) 499 ;; Our fixtures are just closures - with a pandoric environment. You 500 ;; might call it a domain-specific object protocol. 502 ;; You can build fixtures inside a test or use the push-fixture 503 ;; method on a `test-suite' object. 505 (deftype fixture () 'form) 507 (declaim (inline %make-fixture-prototype)) 508 (defstruct (fixture-prototype (:constructor %make-fixture-prototype) 510 (kind :empty :type keyword) 511 (form nil :type form)) 513 (defun make-fixture-prototype (kind form) 514 (%make-fixture-prototype :kind kind :form form)) 516 (defmacro make-fixture (letargs &body ds) 517 (let ((letargs (let-binding-transform letargs))) 521 (defmacro with-fixture ((var fx) &body body) 526 (defclass test-suite (test-object) 527 ((tests :initarg :set :initform nil :type list :accessor tests 528 :documentation "test-suite tests") 529 (results :initarg :results :initform nil :type list :accessor test-results 530 :documentation "test-suite results") 531 (stream :initarg :stream :initform *standard-output* :type stream :accessor test-stream) 532 (fixtures :initarg :fixtures :initform nil :type list :accessor test-fixtures)) 533 (:documentation "A class for collections of related `test' objects.")) 535 (defmethod print-object ((self test-suite) stream) 536 (print-unreadable-object (self stream :type t :identity t) 537 (format stream "~A [~d:~d:~d:~d]" 539 (length (tests self)) 540 (count t (map-tests self #'test-lock-p)) 541 (count t (map-tests self #'test-persist-p)) 542 (length (test-results self))))) 544 ;; (defmethod reinitialize-instance ((self test-suite) &rest initargs &key &allow-other-keys)) 546 (deftype test-suite-designator () 547 "Either nil, a symbol, a string, or a `test-suite' object." 548 '(or null symbol string test-suite keyword)) 550 (defun find-suite (name) 551 (declare (test-suite-designator name)) 552 (find name *test-suite-list* :test #'test-name=)) 554 (defmethod map-tests ((self test-suite) function) 555 ;; tests are stored in reverse order. run LIFO. 556 (mapcar function (reverse (tests self)))) 558 (defmethod push-test ((self test) (place test-suite)) 559 (push self (tests place))) 561 (defmethod pop-test ((self test-suite)) 564 (defmethod push-result ((self test-result) (place test-suite)) 565 (with-slots (results) place 566 (push self results))) 568 (defmethod pop-result ((self test-suite)) 569 (pop (test-results self))) 571 (defmethod find-test ((self test-suite) name &key (test #'test-name=)) 572 (declare (type (or string symbol) name) 573 (type function test)) 574 (find name (tests self) :test test)) 576 (defmethod do-test ((self test-suite) &optional test) 582 (string (find-test self test)) 583 (symbol (find-test self (symbol-name test))))) 584 (do-test (pop-test self))) 587 ;; HACK 2023-09-01: find better method of declaring failures from 588 ;; within the body of `deftest'. 589 (defmethod do-suite ((self test-suite) &key stream force) 590 (when stream (setf (test-stream self) stream)) 591 (with-slots (name stream) self 592 (format stream "in suite ~x:~%" 594 (format stream "; with ~A~A tests~%" 598 (count t (tests self) 599 :key (lambda (x) (or (test-lock-p x) (test-persist-p x)))))) 600 (length (tests self))) 601 ;; loop over each test, calling `do-test'. if locked or 602 ;; persistent, test is performed. if FORCE is non-nil all tests 606 (when (or force (test-lock-p x) (test-persist-p x)) 607 (let ((res (do-test x))) 608 (push-result res self) 609 (format stream "~@[~<~%~:;~:@(~S~) ~>~]~%" res))))) 610 ;; compare locked vs expected 611 (let ((locked (remove-if #'null (map-tests self (lambda (x) (when (test-lock-p x) x))))) 613 ;; collect if locked test not expected 614 (loop for r in (test-results self) 615 unless (test-pass-p r) 618 (format stream "~&No tests failed.~%") 620 ;; RESEARCH 2023-09-04: print fails ?? 621 (format stream "~&~A out of ~A ~ 622 total tests failed: ~ 626 (length (tests self)) 629 (format stream "~&~A unexpected failures: ~ 635 (finish-output stream) 636 ;; return values (PASS? LOCKED) 637 (values (not fails) locked)))) 639 (defmethod do-suite ((self string) &key stream) 640 (do-suite (ensure-suite self) :stream stream)) 642 (defmethod do-suite ((self symbol) &key stream) 643 (do-suite (ensure-suite self) :stream stream)) 645 (defmethod do-suite ((self null) &key stream) 646 (do-suite *test-suite* :stream stream)) 650 (defun %test (val &optional form) 653 (make-test-result :pass form) 654 (make-test-result :fail form)))) 655 ;; (print r *standard-output*) 658 (defmacro is (test &rest args) 661 (is (= 1 1)) ;=> #S(TEST-RESULT :TAG :PASS :FORM (= 1 1)) 662 If TEST returns a truthy value, return a PASS test-result, else return 663 a FAIL. The TEST is parameterized by ARGS which is a plist or nil. 665 If ARGS is nil, TEST is bound to to the RESULT slot of the test-result 666 and evaluated 'as-is'. 669 ARGS may contain the following keywords followed by a corresponding 678 All other values are treated as let bindings. 683 (push-result (trace! (funcall #'rt::%test ,test ',test)) *testing*) 684 (trace! (funcall #'rt::%test ,test ',test))) 685 (macrolet ((,form (test) `(let ,,(group args 2) ,test))) 686 ;; TODO 2023-09-21: does this work... 688 (push-result (trace! (funcall #'rt::%test (,form ,test) ',test) *testing*)) 689 (trace! (funcall #'rt::%test (,form ,test) ',test))))))) 691 (defmacro signals (condition-spec &body body) 692 "Generates a passing TEST-RESULT if body signals a condition of type 693 CONDITION-SPEC. BODY is evaluated in a block named NIL, CONDITION-SPEC 695 (let ((block-name (gensym))) 696 (destructuring-bind (condition &optional reason-control &rest reason-args) 697 (ensure-list condition-spec) 699 (handler-bind ((,condition (lambda (c) 701 ;; ok, body threw condition 702 ;; TODO 2023-09-05: result collectors 703 ;; (add-result 'test-passed 704 ;; :test-expr ',condition) 705 (return-from ,block-name (make-test-result :pass ',body))))) 707 (locally (declare (sb-ext:muffle-conditions warning)) 712 `(,reason-control ,@reason-args) 713 `("Failed to signal a ~S" ',condition))) 714 (return-from ,block-name nil))))) 717 (defmacro deftest (name props &body body) 718 "Build a test with NAME, parameterized by PROPS and with a test form of BODY. 720 PROPS is a plist which currently accepts the following parameters: 722 :PERSIST - re-run this test even if it passes 726 :PROFILE - enable profiling of this test 728 :SKIP - don't push this test to the current *TEST-SUITE* 730 :BENCH - enable benchmarking of this test 732 BODY is parsed with SB-INT:PARSE-BODY and will fill in documentation 733 and declarations for the test body. 735 (destructuring-bind (pr doc dec fn) 736 (multiple-value-bind (forms dec doc) 737 ;; parse body with docstring allowed 738 (parse-body (or body) :documentation t :whole t) 739 `(,props ,doc ,dec ',forms)) 740 ;; TODO 2023-09-21: parse plist 741 `(let ((obj (make-test 742 :name ,(format nil "~A" name) 744 ,@(when-let ((v (getf pr :persist))) `(:persist ,v)) 745 ,@(when-let ((v (getf pr :args))) `(:args ',v)) 746 ,@(when-let ((v (getf pr :bench))) `(:bench ,v)) 747 ,@(when-let ((v (getf pr :profile))) `(:profile ,v)) 748 ,@(when doc `(:doc ,doc)) 749 ,@(when dec `(:declare ,dec))))) 750 ,(unless (getf pr :skip) '(push-test obj *test-suite*)) 753 (defmacro defsuite (suite-name &rest props) 754 "Define a TEST-SUITE with provided keys. The object returned can be 755 enabled using the IN-SUITE macro, similiar to the DEFPACKAGE API." 756 (check-type suite-name (or symbol string)) 757 `(eval-when (:compile-toplevel :load-toplevel :execute) 758 (let ((obj (make-suite 759 :name (format nil "~A" ',suite-name) 760 ,@(when-let ((v (getf props :stream))) `(:stream ,v))))) 761 (setq *test-suite-list* (spush obj *test-suite-list* :test #'test-name=)) 764 (defmacro in-suite (name) 765 "Set *TEST-SUITE* to the TEST-SUITE object referred to by symbol 766 NAME. Return the object." 769 (setq *test-suite* (ensure-suite ,name))))