external/lift.darcs/dev/random-testing.lisp

   1 (in-package #:lift)
   2
   3 ;; we redefine the class and possibly method each time, ick.
   4
   5 (define-condition ensure-random-cases-failure (test-condition)
   6   ((total :initarg :total :initform 0)
   7    (problems :initarg :problems :initform nil))
   8   (:report (lambda (condition stream)
   9              (format stream "Ensure-random-cases: ~d out of ~d failed. Failing values are: ~{~%  ~s~^, ~}"
  10                      (length (slot-value condition 'problems))
  11                      (slot-value condition 'total)
  12                      (slot-value condition 'problems)))))
  13
  14 (defgeneric random-instance-for-suite (thing suite))
  15
  16 (defmacro defrandom-instance (instance-type suite &body body)
  17   `(progn
  18      (defclass ,instance-type () ())
  19      (defvar ,(intern (format nil "+~a+" instance-type) :lift)
  20        (make-instance ',instance-type))
  21      (defmethod random-instance-for-suite
  22          ((thing ,instance-type) (suite ,(if suite suite t)))
  23        ,@body)))
  24
  25 (defmacro ensure-random-cases (count (&rest vars-and-types)
  26                              &body body)
  27   (let ((problems (gensym)))
  28     (flet ((intern-type (type)
  29              (intern (format nil "+~a+" type) :lift)))
  30       `(let ((,problems nil))
  31          (loop repeat ,count do
  32               (let (,@(mapcar
  33                        (lambda (var-and-type)
  34                          `(,(first var-and-type)
  35                             (random-instance-for-suite
  36                              ,(intern-type (second var-and-type))
  37                              *current-test*)))
  38                        vars-and-types))
  39                 (restart-case
  40                     (progn ,@body
  41                            (princ #\. *debug-io*))
  42                   (ensure-failed (cond)
  43                     (declare (ignorable cond))
  44                     (princ #\* *debug-io*)
  45                     (push (list ,@(mapcar
  46                                    (lambda (var-and-type)
  47                                      `(list ',(first var-and-type)
  48                                             ,(first var-and-type)))
  49                                    vars-and-types)) ,problems)))))
  50          (when ,problems
  51            (let ((condition (make-condition
  52                              'ensure-random-cases-failure
  53                              :total ,count
  54                              :problems ,problems)))
  55              (if (find-restart 'ensure-failed)
  56                  (invoke-restart 'ensure-failed condition)
  57                  (warn condition))))))))
  58
  59 (defmacro ensure-random-cases+ (count (&rest vars) (&rest case-form)
  60                                 &body body)
  61   (let ((total (gensym))
  62         (problems (gensym)))
  63     `(let ((,problems nil) (,total 0))
  64        (loop repeat ,count do
  65             (incf ,total)
  66             (destructuring-bind ,vars ,case-form
  67               (restart-case
  68                   (progn ,@body)
  69                 (ensure-failed (cond)
  70                   (declare (ignore cond))
  71                   (push (list ,@vars) ,problems)))))
  72        (when ,problems
  73          (let ((condition (make-condition
  74                            'ensure-random-cases-failure
  75                            :total ,total
  76                            :problems ,problems)))
  77            (if (find-restart 'ensure-failed)
  78                (invoke-restart 'ensure-failed condition)
  79                (warn condition)))))))
  80
  81 ;;; merge with deftestsuite macro
  82 (pushnew :random-instance *deftest-clauses*)
  83
  84 (add-code-block
  85  :random-instance 2 :methods
  86  (lambda () (def :random-instances))
  87  '((push (cleanup-parsed-parameter value) (def :random-instances)))
  88  'build-random-instances-method)
  89
  90 (defun build-random-instances-method ()
  91   `(progn ,@(mapcar (lambda (instance)
  92                       (let ((atype (first instance))
  93                             (body (second instance)))
  94                         `(defrandom-instance ,atype test-mixin ,body)))
  95                     (def :random-instances))))
  96
  97 (defgeneric random-number (suite min max))
  98
  99 (defgeneric random-element (suite sequence))
 100
 101 (defmethod random-number (suite min max)
 102   (declare (ignore suite))
 103   (+ min (random (- max min))))
 104
 105 (defmethod random-element (suite sequence)
 106   (elt sequence (random-number suite 0 (1- (length sequence)))))
 107
 108 (defrandom-instance an-integer test-mixin
 109   (random-number suite -100 100))
 110
 111 (defrandom-instance a-single-float test-mixin
 112   (random-number suite -100s0 100.0s0))
 113
 114 (defrandom-instance a-double-float test-mixin
 115   (random-number suite -100d0 100.0d0))
 116
 117 (defrandom-instance a-symbol test-mixin
 118   (random-element suite '(a hello a-c d_f |MiXeD|
 119                           -2<>#$%#)))
 120
 121
 122