src/random.lisp

   1 ;; -*- lisp -*-
   2
   3 (in-package :it.bese.FiveAM)
   4
   5 ;;;; ** Random (QuickCheck-ish) testing
   6
   7 ;;;; FiveAM provides the ability to automatically generate a
   8 ;;;; collection of random input data for a specific test and run a
   9 ;;;; test multiple times.
  10
  11 ;;;; Specification testing is done through the FOR-ALL macro. This
  12 ;;;; macro will bind variables to random data and run a test body a
  13 ;;;; certain number of times. Should the test body ever signal a
  14 ;;;; failure we stop running and report what values of the variables
  15 ;;;; caused the code to fail.
  16
  17 (defparameter *num-trials* 100
  18   "Number of times we attempt to run the body of the FOR-ALL test.")
  19
  20 (defparameter *max-trials* 10000
  21   "Number of total times we attempt to run the body of the
  22   FOR-ALL test including when the body is skipped due to failed
  23   guard conditions.
  24
  25 Since we have guard conditions we may get into infinite loops
  26 where the test code is never run due to the guards never
  27 returning true. This second run limit prevents that.")
  28
  29 (defmacro for-all (bindings &body body)
  30   `(perform-random-testing
  31     (list ,@(mapcar #'second bindings))
  32     (lambda ,(mapcar #'first bindings)
  33       (if (and ,@(delete-if #'null (mapcar #'third bindings)))
  34           (progn ,@body)
  35           (throw 'run-once
  36             (list :guard-conditions-failed))))))
  37
  38 (defun perform-random-testing (generators body)
  39   (loop
  40      with random-state = *random-state*
  41      with total-counter = *max-trials*
  42      with counter = *num-trials*
  43      with run-at-least-once = nil
  44      until (or (zerop total-counter)
  45                (zerop counter))
  46      do (let ((result (perform-random-testing/run-once generators body)))
  47           (ecase (first result)
  48             (:pass
  49              (decf counter)
  50              (decf total-counter)
  51              (setf run-at-least-once t))
  52             (:no-tests
  53              (add-result 'for-all-test-no-tests
  54                          :reason "No tests"
  55                          :random-state random-state)
  56              (return-from perform-random-testing nil))
  57             (:guard-conditions-failed
  58              (decf total-counter))
  59             (:fail
  60              (add-result 'for-all-test-failed
  61                          :reason "Found failing test data"
  62                          :random-state random-state
  63                          :failure-values (second result)
  64                          :result-list (third result))
  65              (return-from perform-random-testing nil))))
  66      finally (if run-at-least-once
  67                  (add-result 'for-all-test-passed)
  68                  (add-result 'for-all-test-never-run
  69                              :reason "Guard conditions never passed"))))
  70
  71 (defun perform-random-testing/run-once (generators body)
  72   (catch 'run-once
  73     (bind-run-state ((result-list '()))
  74       (let ((values (mapcar #'funcall generators)))
  75         (apply body values)
  76         (cond
  77           ((null result-list)
  78            (throw 'run-once (list :no-tests)))
  79           ((every #'test-passed-p result-list)
  80            (throw 'run-once (list :pass)))
  81           ((notevery #'test-passed-p result-list)
  82            (throw 'run-once (list :fail values result-list))))))))
  83
  84 (defclass for-all-test-result ()
  85   ((random-state :initarg :random-state)))
  86
  87 (defclass for-all-test-passed (test-passed for-all-test-result)
  88   ())
  89
  90 (defclass for-all-test-failed (test-failure for-all-test-result)
  91   ((failure-values :initarg :failure-values)
  92    (result-list :initarg :result-list)))
  93
  94 (defgeneric for-all-test-failed-p (object)
  95   (:method ((object for-all-test-failed)) t)
  96   (:method ((object t)) nil))
  97
  98 (defmethod reason ((result for-all-test-failed))
  99   (format nil "Falsafiable with ~S" (slot-value result 'failure-values)))
 100
 101 (defclass for-all-test-no-tests (test-failure for-all-test-result)
 102   ())
 103
 104 (defclass for-all-test-never-run (test-failure for-all-test-result)
 105   ())
 106
 107 ;;;; *** Generators
 108
 109 ;;;; Since this is random testing we need some way of creating random
 110 ;;;; data to feed to our code. Generators are regular functions which
 111 ;;;; create this random data.
 112
 113 ;;;; We provide a set of built-in generators.
 114
 115 (defun gen-integer (&key (max (1+ most-positive-fixnum))
 116                     (min (1- most-negative-fixnum)))
 117   "Returns a generator which produces random integers greater
 118 than or equal to MIN and less than or equal to MIN."
 119   (lambda ()
 120     (+ min (random (1+ (- max min))))))
 121
 122 (defun gen-float (&key bound (type 'short-float))
 123   "Returns a generator which producs floats of type TYPE. BOUND,
 124 if specified, constrains the ruselts to be in the range (-BOUND,
 125 BOUND)."
 126   (lambda ()
 127     (let* ((most-negative (ecase type
 128                             (short-float most-negative-short-float)
 129                             (single-float most-negative-single-float)
 130                             (double-float most-negative-double-float)
 131                             (long-float most-negative-long-float)))
 132            (most-positive (ecase type
 133                             (short-float most-positive-short-float)
 134                             (single-float most-positive-single-float)
 135                             (double-float most-positive-double-float)
 136                             (long-float most-positive-long-float)))
 137            (bound (or bound (max most-positive (- most-negative)))))
 138       (coerce
 139        (ecase (random 2)
 140          (0 ;; generate a positive number
 141           (random (min most-positive bound)))
 142          (1 ;; generate a negative number
 143           (- (random (min (- most-negative) bound)))))
 144        type))))
 145
 146 (defun gen-character (&key (code (gen-integer :min 0 :max (1- char-code-limit)))
 147                            (alphanumericp nil))
 148   "Returns a generator of characters.
 149
 150 CODE must be a generator of random integers. ALPHANUMERICP, if
 151 non-NIL, limits the returned chars to those which pass
 152 alphanumericp."
 153   (lambda ()
 154     (if alphanumericp
 155         (code-char (funcall code))
 156         (loop
 157            for char = (code-char (funcall code))
 158            until (alphanumericp char)
 159            finally (return char)))))
 160
 161 (defun gen-string (&key (length (gen-integer :min 0 :max 80))
 162                         (elements (gen-character))
 163                         (element-type 'character))
 164   "Returns a generator which producs random strings. LENGTH must
 165 be a generator which producs integers, ELEMENTS must be a
 166 generator which produces characters of type ELEMENT-TYPE."
 167   (lambda ()
 168     (loop
 169        with length = (funcall length)
 170        with string = (make-string length :element-type element-type)
 171        for index below length
 172        do (setf (aref string index) (funcall elements))
 173        finally (return string))))
 174
 175 (defun gen-list (&key (length (gen-integer :min 0 :max 10))
 176                       (elements (gen-integer :min -10 :max 10)))
 177   "Returns a generator which producs random lists. LENGTH must be
 178 an integer generator and ELEMENTS must be a generator which
 179 producs objects."
 180   (lambda ()
 181     (loop
 182        repeat (funcall length)
 183        collect (funcall elements))))
 184
 185 ;;;; The trivial always-produce-the-same-thing generator is done using
 186 ;;;; cl:constantly.