Mercurial > core / lisp/lib/rt/pkg.lisp

 ;;; rt.lisp --- regression testing
 
 ;; Regression Testing framework. inspired by PCL, the original CMUCL
 ;; code, and the SBCL port.
 
 ;;; Commentary:
 
 ;; - :rt https://www.merl.com/publications/docs/TR91-04.pdf Chapter 1
 ;; - :com.gigamonkeys.test https://github.com/gigamonkey/monkeylib-test-framework
 ;; - :sb-rt https://github.com/sbcl/sbcl/blob/master/contrib/sb-rt/rt.lisp
 
 ;; This package is intended to provide a modernized Lisp testing
 ;; library with features found in some of the test frameworks listed
 ;; below.
 
 ;; - :it.bese.fiveam https://github.com/lispci/fiveam
 ;; - :try https://github.com/melisgl/try
 ;; - :rove https://github.com/fukamachi/rove
 
 ;;; TODO:
 #|
 
 - [ ] benchmark support: do-bench, test-count, 
 
 - [ ] fixtures api
 
 - [ ] profiling 
 |#
 ;;; Code:
 (in-package :std-user)
 (require 'sb-cover)
 (defpackage :rt
   (:use 
    :cl :std :sxp :log
    :sb-aprof)
   (:export
    :test-error
    :*test-opts*
    :*compile-tests*
    :*catch-test-errors*
    :*test-suffix*
    :*default-test-suite-name*
    :*test-suite*
    :*test-suite-list*
    ;;  TODO 2023-09-04: :*test-profiler-list* not yet
    :*testing*
    :random-elt
    :random-ref
    :random-char
    :random-chars
    :random-bytes
    :test-suite-designator
    :check-suite-designator
    :make-test
    :make-suite
    :test-name=
    :do-test
    :do-tests
    :reset-tests
    :continue-testing
    :with-test-env
    :%test-bail
    :%test-result
    :make-test-result
    :ensure-suite
    :test-fixture
    :fixture-prototype
    :make-fixture-prototype
    :make-fixture
    :with-fixture
    :test-result
    :test-fn
    :test-pass-p
    :test-fail-p
    :test-skip-p
    :test-failed
    :fail!
    :is
    :signals
    :deftest
    :defsuite
    :in-suite
    :eval-test
    :compile-test
    :locked-tests
    :push-test
    :pop-test
    :delete-test
    :find-test
    :find-suite
    :do-suite
    :test-object
    :test
    :test-fixture
    :test-suite
    :test-name
    :tests
    :test-form
    :test-results))
 
 (defpackage :rt/bench
   (:nicknames :bench)
   (:use :cl :std :log :rt)
   (:export
    :*bench-count*
    :defbench
    :do-bench))
 
 (uiop:define-package :rt/cover
   (:nicknames :cover)
   (:use :cl :std :log :rt)
   (:export
    :with-coverage :start-coverage :stop-coverage
    :*coverage-directory*
    :coverage-report))
 
 (defpackage :rt/tracing
   (:nicknames :tracing)
   (:use :cl :std :log :rt)
   (:export
    :start-tracing
    :stop-tracing
    :with-tracing
    :save-report
    ;; Extra utility
    :package-symbols-except))
 
 (defpackage :rt/flamegraph
   (:nicknames :flamegraph)
   (:use :cl :std :log :rt :sb-sprof)
   (:export :save-flamegraph))
 
 (in-package :rt)
 (in-readtable :std)
 
 ;;; Vars
 (defvar *test-opts* '(optimize sb-c::instrument-consing))
 (defvar *compile-tests* nil
   "When nil do not compile tests. With a value of t, tests are compiled
 with default optimizations else the value is used to configure
 compiler optimizations.")
 (defvar *catch-test-errors* t "When non-nil, cause errors in a test to be caught.")
 (defvar *test-suffix* "-TEST" "A suffix to append to every `test' defined with `deftest'.")
 (defvar *test-suite-list* nil "List of available `test-suite' objects.")
 (defvar *test-suite* nil "A 'test-suite-designator' which identifies the current `test-suite'.")
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defvar *default-test-suite-name* "default"))
 (declaim (type (or stream boolean string) *test-input*))
 (defvar *test-input* nil "When non-nil, specifies an input stream or buffer for `*testing*'.")
 (defvar *testing* nil "Testing state var.")
 
 ;;; Utils
 
 ;; random
 (defvar *simple-charset* "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789")
 
 (defun random-elt (seq)
   (elt seq (random (length seq))))
 
 (defun random-ref (vec)
   (aref vec (random (length vec))))
 
 (defun random-char ()
   (random-ref *simple-charset*))
 
 (defun random-chars (dim)
   (let ((r (make-array dim :element-type 'character)))
     (dotimes (i (array-total-size r) r)
       (setf (row-major-aref r i) (random-char)))))
 
 (defun random-byte () (random 255))
 
 (defun random-bytes (dim)
   (let ((r (make-array dim :element-type 'octet)))
     (dotimes (i (array-total-size r) r)
       (setf (row-major-aref r i) (random-byte)))))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defun make-test (&rest slots)
     (apply #'make-instance 'test slots))
   (defun make-suite (&rest slots)
     (apply #'make-instance 'test-suite slots)))
 
 ;; TODO 2023-09-04: optimize
 ;;(declaim (inline do-tests))
 (defun do-tests (&optional (suite *test-suite*) force (output *standard-output*))
   (if (pathnamep output)
       (with-open-file (stream output :direction :output)
 	(do-suite (ensure-suite suite) :stream stream :force force))
       (do-suite (ensure-suite suite) :stream output :force force)))
 
 (defvar *test-output-mutex* (sb-thread:make-mutex :name "tests-output"))
 
 ;; TODO
 (defun do-tests-concurrently (&optional (suite *test-suite*) force (output *standard-output*))
   (declare (ignore suite force))
   (sb-thread:with-mutex (*test-output-mutex*)
     (let ((stream (make-synonym-stream output)))
       (let ((*standard-output* stream)
             (*error-output* stream))
         (nyi!)))))
 
 (defun reset-tests ()
   (setq *testing* nil
         *test-suite* nil
         *test-suite-list* nil
         *test-input* nil))
 
 ;; this assumes that *test-suite* is re-initialized correctly to the
 ;; correct test-suite object.
 (defun continue-testing ()
   (if-let ((test *testing*))
     (throw '%in-test test)
     (do-suite *test-suite*)))
 
 ;; NOTE 2023-09-01: `pushnew' does not return an indication of whether
 ;; place is changed - it returns place. This is functionally sound but
 ;; means that if we want to do something else in the event that place
 ;; is unchanged, we run into some friction,
 ;; https://stackoverflow.com/questions/56228832/adapting-common-lisp-pushnew-to-return-success-failure
 (defun spush (item lst &key (test #'equal))
   "Substituting `push'"
   (declare (type function test))
   (cond
     ((null lst) (push item lst))
     ((list lst)
      (if-let ((found (member item lst
 			     :test test)))
        (progn
 	 (rplaca found item)
 	 lst)
        (push item lst)))
     #|(or nil '(t (cons item lst)))|#))
 
 ;; FIX 2023-08-31: spush, replace with `add-test' method.
 ;; (declaim (inline normalize-test-name))
 (defun normalize-test-name (a)
   "Return the normalized `test-suite-designator' of A."
   (etypecase a
     (string (string-upcase a))
     (symbol (symbol-name a))
     (test-object (normalize-test-name (test-name a)))
     (t (format nil "~A" a))))
 
 (defun test-name= (a b)
   "Return t if A and B are similar `test-suite-designator's."
   (let ((a (normalize-test-name a))
 	(b (normalize-test-name b)))
     (string= a b)))
 
 ;; (declaim (inline assert-suite ensure-suite))
 (defun ensure-suite (name)
   (if-let ((ok (member name *test-suite-list* :test #'test-name=)))
     (car ok)
     (when (or (eq name t) (null name)) (make-suite :name *default-test-suite-name*))))
 
 (defun check-suite-designator (suite) (check-type suite test-suite-designator))
 
 (defun assert-suite (name)
   (check-suite-designator name)
   (assert (ensure-suite name)))
 
 (declaim (inline test-opt-key-p test-opt-valid-p))
 (defun test-opt-key-p (k)
   "Test if K is a `test-opt-key'."
   (member k '(:profile :save :stream)))
 
 (defun test-opt-valid-p (f)
   "Test if F is a valid `test-opt' form. If so, return F else nil."
   (when (test-opt-key-p (car f))
     f))
 
 ;;; Conditions
 (define-condition test-failed (error)
   ((reason :accessor fail-reason :initarg :reason :initform "unknown")
    (name :accessor fail-name :initarg :name)
    (form :accessor fail-form :initarg :form))
   (:documentation "Signaled when a test fails.")
   (:report (lambda (c s)
 	     (format s "The following expression failed: ~S~%~A."
 		     (fail-form c)
 		     (fail-reason c)))))
 
 ;;; Protocol
 (defgeneric eval-test (self)
   (:documentation "Eval a `test'."))
 
 (defgeneric compile-test (self &key &allow-other-keys)
   (:documentation "Compile a `test'."))
 
 (defgeneric locked-tests (self)
   (:documentation "Return a list of locked tests in `test-suite' object SELF."))
 
 (defgeneric push-test (self place)
   (:documentation
    "Push `test' SELF to the value of slot ':tests' in `test-suite' object PLACE."))
 
 (defgeneric pop-test (self)
   (:documentation
    "Pop the first `test' from the slot-value of ':tests' in `test-suite' object SELF."))
 
 (defgeneric push-result (self place)
   (:documentation
    "Push object SELF to the value of slot ':results' in object PLACE."))
 
 (defgeneric pop-result (self)
   (:documentation
    "Pop the first `test-result' from the slot-value of ':tests' from object SELF."))
 
 (defgeneric push-fixture (self place)
   (:documentation
    "Push object SELF to the value of slot ':results' in object PLACE."))
 
 (defgeneric delete-test (self &key &allow-other-keys)
   (:documentation "Delete `test' object specified by `test-object' SELF and optional keys."))
 
 (defgeneric find-test (self name &key &allow-other-keys)
   (:documentation "Find `test' object specified by name and optional keys."))
 
 (defgeneric do-test (self &optional context)
   (:documentation "Run test SELF, printing results to *standard-output*. The second
 argument is an optional fixture.
 
 SELF can also be a `test-suite', in which case the TESTS slot is
 queried for the value of TEST. If TEST is not provided, pops the car
 from TESTS."))
 
 (defgeneric do-suite (self &key &allow-other-keys)
   (:documentation
    "Perform actions on `test-suite' object SELF with optional keys."))
 
 ;;;; Results
 (deftype result-tag ()
   '(or (member :pass :fail :skip) null))
 
 (declaim (inline %make-test-result))
 (defstruct (test-result (:constructor %make-test-result)
 			(:conc-name  tr-))
   (tag nil :type result-tag :read-only t)
   (form nil :type form))
 
 (defmethod print-object ((self test-result) stream)
   (print-unreadable-object (self stream :identity t)
     (format stream "~A ~A" (tr-tag self) (tr-form self))))
 
 (defun make-test-result (tag &optional form)
   (%make-test-result :tag tag :form form))
 
 (defmethod test-pass-p ((res test-result))
   (when (eq :pass (tr-tag res)) t))
 
 (defmethod test-fail-p ((res test-result))
   (when (eq :fail (tr-tag res)) t))
 
 (defmethod test-skip-p ((res test-result))
   (when (eq :skip (tr-tag res)) t))
 
 (defmethod print-object ((self test-result) stream)
   (print-unreadable-object (self stream)
     (format stream "~A ~A"
 	    (tr-tag self)
 	    (tr-form self))))
 
 ;;; Objects
 (defclass test-object ()
   ((name :initarg :name :initform (required-argument) :type string :accessor test-name)
    #+nil (cached :initarg :cache :allocation :class :accessor test-cached-p :type boolean))
   (:documentation "Super class for all test-related objects."))
 
 (defmethod print-object ((self test-object) stream)
   "test"
   (print-unreadable-object (self stream :type t :identity t)
     (format stream "~A"
 	    (test-name self))))
 
 ;;;; Tests
 ;; HACK 2023-08-31: inherit sxp?
 
 (defclass test (test-object)
   ((fn :type symbol :accessor test-fn)
    (bench :type (or boolean fixnum) :accessor test-bench :initform nil :initarg :bench)
    (profile :type list :accessor test-profile :initform nil :initarg :profile)
    (args :type list :accessor test-args :initform nil :initarg :args)
    (declare :type list :accessor test-declare :initform nil :initarg :declare)
    (form :initarg :form :initform nil :accessor test-form)
    (doc :initarg :doc :type string :accessor test-doc)
    (lock :initarg :lock :type boolean :accessor test-lock-p)
    (persist :initarg :persist :initform nil :type boolean :accessor test-persist-p)
    (results :initarg :results :type (array test-result) :accessor test-results))
   (:documentation "Test class typically made with `deftest'."))
 
 (defmethod initialize-instance ((self test) &key name)
   ;; (debug! "building test" name)
   (setf (test-fn self)
 	(make-symbol
 	 (format nil "~A~A"
 		 name
 		 (gensym *test-suffix*))))
   (setf (test-lock-p self) t)
   ;; TODO 2023-09-21: we should count how many checks are in the :form
   ;; slot and infer the array dimensions.
   (setf (test-results self) (make-array 0 :element-type 'test-result))
   (call-next-method))
 
 (defmethod print-object ((self test) stream)
   (print-unreadable-object (self stream :type t :identity t)
     (format stream "~A :fn ~A"
 	    (test-name self)
 	    (test-fn self))))
 
 (defmethod push-result ((self test-result) (place test))
   (with-slots (results) place
     (push self results)))
 
 (defmethod pop-result ((self test))
   (pop (test-results self)))
 
 (defmethod eval-test ((self test))
   (eval `(progn ,@(test-form self))))
 
 (defmethod funcall-test ((self test) &key declare)
   (unless (functionp (test-fn self))
     (trace! (setf (symbol-function (test-fn self))
                   (eval `(lambda ()
                            ,(when declare `(declare ,declare))
                            ,@(test-form self))))))
   (funcall (test-fn self)))
 
 (defmethod compile-test ((self test) &key declare &allow-other-keys)
   (with-compilation-unit (:policy '(optimize debug))
     (compile
      (test-fn self)
      `(lambda ()
         ,(when declare `(declare ,declare))
         ,@(test-form self)))))
 
 (defun fail! (form &optional fmt &rest args)
   (let ((reason (and fmt (apply #'format nil fmt args))))
     (with-simple-restart (ignore-fail "Continue testing.")
       (error 'test-failed :reason reason :form form))))
 
 (defmacro with-test-env (self &body body)
   `(catch '%in-test
      (setf (test-lock-p ,self) t)
      (let* ((*testing* ,self)
 	    (%test-bail nil)
 	    %test-result)
        (block %test-bail
 	 ,@body
 	 (setf (test-lock-p ,self) %test-bail))
        %test-result)))
 
 (defmethod do-test ((self test) &optional fx)
   (declare (ignorable fx))
   (with-test-env self
     (trace! "running test: " *testing*)
     (flet ((%do ()
 	     (if-let ((opt *compile-tests*))
 	       ;; RESEARCH 2023-08-31: with-compilation-unit?
 	       (progn
 		 (if (eq opt t)
                      (setq opt *test-opts*)
                      (setq opt (push *test-opts* opt)))
 		 ;; TODO 2023-09-21: handle failures here
 		 (funcall (compile-test self :declare opt))
 		 (setf %test-result (make-test-result :pass (test-fn self))))
 	       (progn
                  (funcall-test self :declare '(optimize (debug 3) (safety 0)))
 		 (setf %test-result (make-test-result :pass (test-name self)))))))
       (if *catch-test-errors*
 	  (handler-bind
 	      ((error 
 		 (lambda (c)
 		   (setf %test-bail t)
 		   (setf %test-result (make-test-result :fail c))
 		   (return-from %test-bail %test-result))))
 	    (%do))
 	  (%do)))))
 
 (defmethod do-test ((self simple-string) &optional fixture)
   (when-let ((test (find-test *test-suite* self)))
     (do-test test fixture)))
 
 (defmethod do-test ((self symbol) &optional fixture)
   (when-let ((test (find-test *test-suite* (symbol-name self))))
     (do-test test fixture)))
 
 ;;;; Fixtures
 
 ;; Our fixtures are just closures - with a pandoric environment. You
 ;; might call it a domain-specific object protocol.
 
 ;; You can build fixtures inside a test or use the push-fixture
 ;; method on a `test-suite' object.
 
 (deftype fixture () 'form)
 
 (declaim (inline %make-fixture-prototype))
 (defstruct (fixture-prototype (:constructor %make-fixture-prototype)
 			      (:conc-name fxp))
   (kind :empty :type keyword)
   (form nil :type form))
 
 (defun make-fixture-prototype (kind form)
   (%make-fixture-prototype :kind kind :form form))
 
 (defmacro make-fixture (letargs &body ds)
   (let ((letargs (let-binding-transform letargs)))
     `(let (,@letargs)
        (dlambda ,@ds))))
 
 (defmacro with-fixture ((var fx) &body body)
   `(let ((,var ,fx))
      ,@body))
 
 ;;;; Suites
 (defclass test-suite (test-object)
   ((tests :initarg :set :initform nil :type list :accessor tests
 	  :documentation "test-suite tests")
    (results :initarg :results :initform nil :type list :accessor test-results
 	    :documentation "test-suite results")
    (stream :initarg :stream :initform *standard-output* :type stream :accessor test-stream)
    (fixtures :initarg :fixtures :initform nil :type list :accessor test-fixtures))
   (:documentation "A class for collections of related `test' objects."))
 
 (defmethod print-object ((self test-suite) stream)
   (print-unreadable-object (self stream :type t :identity t)
     (format stream "~A [~d:~d:~d:~d]"
 	    (test-name self)
 	    (length (tests self))
 	    (count t (map-tests self #'test-lock-p))
 	    (count t (map-tests self #'test-persist-p))
 	    (length (test-results self)))))
 
 ;; (defmethod reinitialize-instance ((self test-suite) &rest initargs &key &allow-other-keys))
 
 (deftype test-suite-designator ()
   "Either nil, a symbol, a string, or a `test-suite' object."
   '(or null symbol string test-suite keyword))
 
 (defun find-suite (name)
   (declare (test-suite-designator name))
   (find name *test-suite-list* :test #'test-name=))
 
 (defmethod map-tests ((self test-suite) function)
   ;; tests are stored in reverse order. run LIFO.
   (mapcar function (reverse (tests self))))
 
 (defmethod push-test ((self test) (place test-suite))
   (push self (tests place)))
 
 (defmethod pop-test ((self test-suite))
   (pop (tests self)))
 
 (defmethod push-result ((self test-result) (place test-suite))
   (with-slots (results) place
     (push self results)))
 
 (defmethod pop-result ((self test-suite))
   (pop (test-results self)))
 
 (defmethod find-test ((self test-suite) name &key (test #'test-name=))
   (declare (type (or string symbol) name)
 	   (type function test))
   (find name (tests self) :test test))
 
 (defmethod do-test ((self test-suite) &optional test)
   (push-result 
    (if test
        (do-test
            (etypecase test
              (test test)
              (string (find-test self test))
              (symbol (find-test self (symbol-name test)))))
        (do-test (pop-test self)))
    self))
 
 ;; HACK 2023-09-01: find better method of declaring failures from
 ;; within the body of `deftest'.
 (defmethod do-suite ((self test-suite) &key stream force)
   (when stream (setf (test-stream self) stream))
   (with-slots (name stream) self
     (format stream "in suite ~x:~%"
 	    name)
     (format stream "; with ~A~A tests~%"
             (if force
                 ""
                 (format nil "~A/"
                         (count t (tests self)
                                :key (lambda (x) (or (test-lock-p x) (test-persist-p x))))))
             (length (tests self)))
     ;; loop over each test, calling `do-test'. if locked or
     ;; persistent, test is performed. if FORCE is non-nil all tests
     ;; are performed.
     (map-tests self 
 	       (lambda (x)
 		 (when (or force (test-lock-p x) (test-persist-p x))
 		   (let ((res (do-test x)))
 		     (push-result res self)
 		     (format stream "~@[~<~%~:;~:@(~S~) ~>~]~%" res)))))
     ;; compare locked vs expected
     (let ((locked (remove-if #'null (map-tests self (lambda (x) (when (test-lock-p x) x)))))
 	  (fails
 	    ;; collect if locked test not expected
 	    (loop for r in (test-results self)
 		  unless (test-pass-p r)
 		  collect r)))
       (if (null locked)
 	  (format stream "~&No tests failed.~%")
 	  (progn
 	    ;;  RESEARCH 2023-09-04: print fails ??
 	    (format stream "~&~A out of ~A ~
                    total tests failed: ~
                    ~:@(~{~<~%   ~1:;~S~>~
                          ~^, ~}~)."
 		    (length locked)
 		    (length (tests self))
 		    locked)
 	    (unless (null fails)
 	      (format stream "~&~A unexpected failures: ~
                    ~:@(~{~<~%   ~1:;~S~>~
                          ~^, ~}~)."
 		      (length fails)
 		      fails))))
       ;; close stream
       (finish-output stream)
       ;; return values (PASS? LOCKED)
       (values (not fails) locked))))
 
 (defmethod do-suite ((self string) &key stream)
   (do-suite (ensure-suite self) :stream stream))
 
 (defmethod do-suite ((self symbol) &key stream)
   (do-suite (ensure-suite self) :stream stream))
 
 (defmethod do-suite ((self null) &key stream)
   (do-suite *test-suite* :stream stream))
 
 ;;; Checks
 (eval-always
   (defun %test (val &optional form)
     (let ((r
 	    (if val 
 	        (make-test-result :pass form)
 	        (make-test-result :fail form))))
       ;; (print r *standard-output*)
       r)))
 
 (defmacro is (test &rest args)
   "The DWIM Check.
 
 (is (= 1 1)) ;=> #S(TEST-RESULT :TAG :PASS :FORM (= 1 1))
 If TEST returns a truthy value, return a PASS test-result, else return
 a FAIL. The TEST is parameterized by ARGS which is a plist or nil.
 
 If ARGS is nil, TEST is bound to to the RESULT slot of the test-result
 and evaluated 'as-is'.
 
 (nyi!)
 ARGS may contain the following keywords followed by a corresponding
 value:
 
 :EXPECTED
 
 :TIMEOUT
 
 :THEN
 
 All other values are treated as let bindings.
 "
     (with-gensyms (form)
       `(if ,(null args)
 	   (if *testing*
 	       (push-result (trace! (funcall #'rt::%test ,test ',test)) *testing*)
 	       (trace! (funcall #'rt::%test ,test ',test)))
 	   (macrolet ((,form (test) `(let ,,(group args 2) ,test)))
 	     ;; TODO 2023-09-21: does this work...
 	     (if *testing*
 		 (push-result (trace! (funcall #'rt::%test (,form ,test) ',test) *testing*))
 		 (trace! (funcall #'rt::%test (,form ,test) ',test)))))))
 
 (defmacro signals (condition-spec &body body)
   "Generates a passing TEST-RESULT if body signals a condition of type
 CONDITION-SPEC. BODY is evaluated in a block named NIL, CONDITION-SPEC
 is not evaluated."
   (let ((block-name (gensym)))
     (destructuring-bind (condition &optional reason-control &rest reason-args)
         (ensure-list condition-spec)
       `(block ,block-name
          (handler-bind ((,condition (lambda (c)
                                       (declare (ignore c))
                                       ;; ok, body threw condition
 				      ;; TODO 2023-09-05: result collectors
                                       ;; (add-result 'test-passed
                                       ;;            :test-expr ',condition)
                                       (return-from ,block-name (make-test-result :pass ',body)))))
            (block nil
              (locally (declare (sb-ext:muffle-conditions warning))
                ,@body)))
          (fail!
           ',condition
           ,@(if reason-control
                 `(,reason-control ,@reason-args)
                 `("Failed to signal a ~S" ',condition)))
          (return-from ,block-name nil)))))
 
 ;;; Macros
 (defmacro deftest (name props &body body)
   "Build a test with NAME, parameterized by PROPS and with a test form of BODY.
 
 PROPS is a plist which currently accepts the following parameters:
 
 :PERSIST - re-run this test even if it passes
 
 :ARGS - nyi
 
 :PROFILE - enable profiling of this test
 
 :SKIP - don't push this test to the current *TEST-SUITE*
 
 :BENCH - enable benchmarking of this test
 
 BODY is parsed with SB-INT:PARSE-BODY and will fill in documentation
 and declarations for the test body.
 "
   (destructuring-bind (pr doc dec fn)
       (multiple-value-bind (forms dec doc)
 	  ;; parse body with docstring allowed
 	  (parse-body (or body) :documentation t :whole t)
 	`(,props ,doc ,dec ',forms))
     ;; TODO 2023-09-21: parse plist
     `(let ((obj (make-test
 		 :name ,(format nil "~A" name)
 		 :form ,fn
 		 ,@(when-let ((v (getf pr :persist))) `(:persist ,v))
 		 ,@(when-let ((v (getf pr :args))) `(:args ',v))
 		 ,@(when-let ((v (getf pr :bench))) `(:bench ,v))
 		 ,@(when-let ((v (getf pr :profile))) `(:profile ,v))
 		 ,@(when doc `(:doc ,doc))
 		 ,@(when dec `(:declare ,dec)))))
        ,(unless (getf pr :skip) '(push-test obj *test-suite*))
        obj)))
 
 (defmacro defsuite (suite-name &rest props)
   "Define a TEST-SUITE with provided keys. The object returned can be
 enabled using the IN-SUITE macro, similiar to the DEFPACKAGE API."
   (check-type suite-name (or symbol string))
   `(eval-when (:compile-toplevel :load-toplevel :execute)
      (let ((obj (make-suite
 		 :name (format nil "~A" ',suite-name)
 		 ,@(when-let ((v (getf props :stream))) `(:stream ,v)))))
        (setq *test-suite-list* (spush obj *test-suite-list* :test #'test-name=))
        obj)))
 
 (defmacro in-suite (name)
   "Set *TEST-SUITE* to the TEST-SUITE object referred to by symbol
 NAME. Return the object."
   (assert-suite name)
   `(progn
      (setq *test-suite* (ensure-suite ,name))))