changelog shortlog graph tags branches changeset files revisions annotate raw help

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

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 ;;; rt.lisp --- Regression Testing
     2 
     3 ;; 
     4 
     5 ;;; Code:
     6 (in-package :rt)
     7 
     8 ;;; Checks
     9 (eval-always
    10   (defun %test (val &optional form)
    11     (let ((r
    12             (if val 
    13                 (make-test-result :pass form)
    14                 (make-test-result :fail form))))
    15       ;; (print r *standard-output*)
    16       r)))
    17 
    18 (defmacro is (test &rest args)
    19   "The DWIM Check.
    20 
    21 (is (= 1 1)) ;=> #S(TEST-RESULT :TAG :PASS :FORM (= 1 1))
    22 If TEST returns a truthy value, return a PASS test-result, else return
    23 a FAIL. The TEST is parameterized by ARGS which is a plist or nil.
    24 
    25 If ARGS is nil, TEST is bound to to the RESULT slot of the test-result
    26 and evaluated 'as-is'.
    27 
    28 (nyi!)
    29 ARGS may contain the following keywords followed by a corresponding
    30 value:
    31 
    32 :EXPECTED
    33 
    34 :TIMEOUT
    35 
    36 :THEN
    37 
    38 All other values are treated as let bindings.
    39 "
    40     (with-gensyms (form)
    41       `(if ,(null args)
    42            (if *testing*
    43                (push-result (trace! (funcall #'rt::%test ,test ',test)) *testing*)
    44                (trace! (funcall #'rt::%test ,test ',test)))
    45            (macrolet ((,form (test) `(let ,,(group args 2) ,test)))
    46              ;; TODO 2023-09-21: does this work...
    47              (if *testing*
    48                  (push-result (trace! (funcall #'rt::%test (,form ,test) ',test) *testing*))
    49                  (trace! (funcall #'rt::%test (,form ,test) ',test)))))))
    50 
    51 (defmacro signals (condition-spec &body body)
    52   "Generates a passing TEST-RESULT if body signals a condition of type
    53 CONDITION-SPEC. BODY is evaluated in a block named NIL, CONDITION-SPEC
    54 is not evaluated."
    55   (let ((block-name (gensym)))
    56     (destructuring-bind (condition &optional reason-control &rest reason-args)
    57         (ensure-list condition-spec)
    58       `(block ,block-name
    59          (handler-bind ((,condition (lambda (c)
    60                                       (declare (ignore c))
    61                                       ;; ok, body threw condition
    62                                       ;; TODO 2023-09-05: result collectors
    63                                       ;; (add-result 'test-passed
    64                                       ;;            :test-expr ',condition)
    65                                       (return-from ,block-name (make-test-result :pass ',body)))))
    66            (block nil
    67              (locally (declare (sb-ext:muffle-conditions warning))
    68                ,@body)))
    69          (fail!
    70           ',condition
    71           ,@(if reason-control
    72                 `(,reason-control ,@reason-args)
    73                 `("Failed to signal a ~S" ',condition)))
    74          (return-from ,block-name nil)))))
    75 
    76 ;;; Macros
    77 (defmacro deftest (name props &body body)
    78   "Build a test with NAME, parameterized by PROPS and with a test form of BODY.
    79 
    80 PROPS is a plist which currently accepts the following parameters:
    81 
    82 :PERSIST - re-run this test even if it passes
    83 
    84 :ARGS - nyi
    85 
    86 :PROFILE - enable profiling of this test
    87 
    88 :SKIP - don't push this test to the current *TEST-SUITE*
    89 
    90 :BENCH - enable benchmarking of this test
    91 
    92 BODY is parsed with SB-INT:PARSE-BODY and will fill in documentation
    93 and declarations for the test body.
    94 "
    95   (destructuring-bind (pr doc dec fn)
    96       (multiple-value-bind (forms dec doc)
    97           ;; parse body with docstring allowed
    98           (parse-body (or body) :documentation t :whole t)
    99         `(,props ,doc ,dec ',forms))
   100     ;; TODO 2023-09-21: parse plist
   101     `(let ((obj (make-test
   102                  :name ,(format nil "~A" name)
   103                  :form ,fn
   104                  ,@(when-let ((v (getf pr :persist))) `(:persist ,v))
   105                  ,@(when-let ((v (getf pr :args))) `(:args ',v))
   106                  ,@(when-let ((v (getf pr :bench))) `(:bench ,v))
   107                  ,@(when-let ((v (getf pr :profile))) `(:profile ,v))
   108                  ,@(when doc `(:doc ,doc))
   109                  ,@(when dec `(:declare ,dec)))))
   110        ,(unless (getf pr :skip) '(push-test obj *test-suite*))
   111        obj)))
   112 
   113 (defmacro defsuite (suite-name &rest props)
   114   "Define a TEST-SUITE with provided keys. The object returned can be
   115 enabled using the IN-SUITE macro, similiar to the DEFPACKAGE API."
   116   (check-type suite-name (or symbol string))
   117   `(eval-when (:compile-toplevel :load-toplevel :execute)
   118      (let ((obj (make-suite
   119                  :name (format nil "~A" ',suite-name)
   120                  ,@(when-let ((v (getf props :stream))) `(:stream ,v)))))
   121        (setq *test-suite-list* (spush obj *test-suite-list* :test #'test-name=))
   122        obj)))
   123 
   124 (defmacro in-suite (name)
   125   "Set *TEST-SUITE* to the TEST-SUITE object referred to by symbol
   126 NAME. Return the object."
   127   (assert-suite name)
   128   `(progn
   129      (setq *test-suite* (ensure-suite ,name))))