From 9adc37ba6fbe512af2c83863e9f51461479678ed Mon Sep 17 00:00:00 2001 From: Marco Baringer Date: Thu, 19 Jan 2006 19:58:36 +0100 Subject: [PATCH] Initial version of random testing --- fiveam.asd | 1 + src/explain.lisp | 81 +++++++++++++++++++--------------- src/packages.lisp | 4 ++ src/random.lisp | 126 +++++++++++++++++++++++++++++++++++++++++++++++++++++ t/example.lisp | 32 ++++++++++++++ 5 files changed, 209 insertions(+), 35 deletions(-) create mode 100644 src/random.lisp diff --git a/fiveam.asd b/fiveam.asd index ad5833f..9280193 100644 --- a/fiveam.asd +++ b/fiveam.asd @@ -18,6 +18,7 @@ (:file "packages") (:file "run" :depends-on ("packages" "classes" "test" "suite" "check")) (:file "suite" :depends-on ("packages" "test" "classes")) + (:file "random-check" :depends-on ("packages" "check")) (:file "test" :depends-on ("packages" "classes")))) (:module :t :components ((:file "suite") diff --git a/src/explain.lisp b/src/explain.lisp index bb76305..b3bf2c3 100644 --- a/src/explain.lisp +++ b/src/explain.lisp @@ -12,58 +12,69 @@ ;;;; which prints a human readable summary (number passed, number ;;;; failed, what failed and why, etc.) of a list of test results. -(defmethod explain ((exp detailed-text-explainer) results &optional (stream *test-dribble*)) - "Given a list of test results report write to stream detailed - human readable statistics regarding the results." +(defmethod explain ((exp detailed-text-explainer) results + &optional (stream *test-dribble*) (recursive-depth 0)) + #| "Given a list of test results report write to stream detailed + human readable statistics regarding the results." |# (multiple-value-bind (num-checks passed num-passed passed% skipped num-skipped skipped% failed num-failed failed% unknown num-unknown unknown%) (partition-results results) (declare (ignore passed)) - (when (zerop num-checks) - (format stream "~%Didn't run anything...huh?") - (return-from explain nil)) - (format stream "~%Did ~D check~P.~%" - num-checks num-checks) - (format stream " Pass: ~D (~2D%)~%" num-passed passed%) - (format stream " Skip: ~D (~2D%)~%" num-skipped skipped%) - (format stream " Fail: ~D (~2D%)~%" num-failed failed%) - (when unknown - (format stream " UNKNOWN RESULTS: ~D (~2D)~%" num-unknown unknown%)) - (terpri stream) - (when failed - (format stream "Failure Details:~%") - (dolist (f failed) - (format stream "~A ~@{[~A]~}: ~%" - (name (test-case f)) - (description (test-case f))) - (when (and *verbose-failures* (test-expr f)) - (format stream " ~S~%" (test-expr f))) - (format stream " ~A.~%" (reason f))) - (terpri stream)) - (when skipped - (format stream "Skip Details:~%") - (dolist (f skipped) - (format stream "~A ~@{[~A]~}: ~%" - (name (test-case f)) - (description (test-case f))) - (format stream " ~A.~%" (reason f))) - (terpri *test-dribble*)))) + (flet ((output (&rest format-args) + (format stream "~&~vT" recursive-depth) + (apply #'format stream format-args))) + + (when (zerop num-checks) + (output "Didn't run anything...huh?") + (return-from explain nil)) + (output "Did ~D check~P.~%" num-checks num-checks) + (output " Pass: ~D (~2D%)~%" num-passed passed%) + (output " Skip: ~D (~2D%)~%" num-skipped skipped%) + (output " Fail: ~D (~2D%)~%" num-failed failed%) + (when unknown + (output " UNKNOWN RESULTS: ~D (~2D)~%" num-unknown unknown%)) + (terpri stream) + (when failed + (output "Failure Details:~%") + (dolist (f failed) + (output "--------------------------------~%") + (output "~A ~@{[~A]~}: ~%" + (name (test-case f)) + (description (test-case f))) + (output " ~A.~%" (reason f)) + (when (for-all-test-failed-p f) + (output "Results collected with failure data:~%") + (explain exp (slot-value f 'result-list) + stream (+ 4 recursive-depth))) + (when (and *verbose-failures* (test-expr f)) + (output " ~S~%" (test-expr f))) + (output "--------------------------------~%")) + (terpri stream)) + (when skipped + (output "Skip Details:~%") + (dolist (f skipped) + (output "~A ~@{[~A]~}: ~%" + (name (test-case f)) + (description (test-case f))) + (output " ~A.~%" (reason f))) + (terpri *test-dribble*))))) -(defmethod explain ((exp simple-text-explainer) results &optional (stream *test-dribble*)) +(defmethod explain ((exp simple-text-explainer) results + &optional (stream *test-dribble*) (recursive-depth 0)) (multiple-value-bind (num-checks passed num-passed passed% skipped num-skipped skipped% failed num-failed failed% unknown num-unknown unknown%) (partition-results results) (declare (ignore passed passed% skipped skipped% failed failed% unknown unknown%)) - (format stream "~&Ran ~D checks, ~D passed" num-checks num-passed) + (format stream "~&~vTRan ~D checks, ~D passed" recursive-depth num-checks num-passed) (when (plusp num-skipped) (format stream ", ~D skipped " num-skipped)) (format stream " and ~D failed.~%" num-failed) (when (plusp num-unknown) - (format stream "~D UNKNOWN RESULTS.~%" num-unknown)))) + (format stream "~vT~D UNKNOWN RESULTS.~%" recursive-depth num-unknown)))) (defun partition-results (results-list) (let ((num-checks (length results-list))) diff --git a/src/packages.lisp b/src/packages.lisp index 53e30ae..d880069 100644 --- a/src/packages.lisp +++ b/src/packages.lisp @@ -46,6 +46,10 @@ #:pass #:fail #:*test-dribble* + #:for-all + #:gen-integer + #:gen-string + #:gen-character ;; running tests #:run #:run-all-tests diff --git a/src/random.lisp b/src/random.lisp new file mode 100644 index 0000000..9f9de08 --- /dev/null +++ b/src/random.lisp @@ -0,0 +1,126 @@ +;; -*- lisp -*- + +(in-package :it.bese.FiveAM) + +;;;; * Random (QuickCheck-ish) testing + +;;;; FiveAM provides the ability to automatically generate a +;;;; collection of random input data for a specific test and run a +;;;; test multiple times. + +;;;; Specification testing is done through the FOR-ALL macro. This +;;;; macro will bind variables to random data and run a test body a +;;;; certain number of times. Should the test body ever signal a +;;;; failure we stop running and report what values of the variables +;;;; caused the code to fail. + +(defmacro for-all (bindings &body body) + `(perform-random-testing + (list ,@(mapcar #'second bindings)) + (lambda ,(mapcar #'first bindings) + (if (and ,@(delete-if #'null (mapcar #'third bindings))) + (progn ,@body) + (throw 'run-once + (list :guard-conditions-failed)))))) + +(defun perform-random-testing (generators body) + (loop + with random-state = *random-state* + with total-counter = 1000 + with counter = 100 + until (zerop counter) + do (let ((result (perform-random-testing/run-once generators body))) + (ecase (first result) + (:pass + (decf counter) + (decf total-counter)) + (:no-tests + (add-result 'for-all-test-no-tests + :reason "No tests" + :random-state random-state) + (return-from perform-random-testing nil)) + (:guard-conditions-failed + (decf total-counter)) + (:fail + (add-result 'for-all-test-failed + :reason "Found failing test data" + :random-state random-state + :failure-values (second result) + :result-list (third result)) + (return-from perform-random-testing nil)))) + finally (add-result 'for-all-test-passed))) + +(defun perform-random-testing/run-once (generators body) + (catch 'run-once + (bind-run-state ((result-list '())) + (let ((values (mapcar #'funcall generators))) + (apply body values) + (cond + ((null result-list) + (throw 'run-once (list :no-tests))) + ((every #'test-passed-p result-list) + (throw 'run-once (list :pass))) + ((notevery #'test-passed-p result-list) + (throw 'run-once (list :fail values result-list)))))))) + +(defclass for-all-test-result () + ((random-state :initarg :random-state))) + +(defclass for-all-test-passed (test-passed for-all-test-result) + ()) + +(defclass for-all-test-failed (test-failure for-all-test-result) + ((failure-values :initarg :failure-values) + (result-list :initarg :result-list))) + +(defgeneric for-all-test-failed-p (object) + (:method ((object for-all-test-failed)) t) + (:method ((object t)) nil)) + +(defclass for-all-test-no-tests (test-failure for-all-test-result) + ()) + +(defmethod reason ((result for-all-test-failed)) + (format nil "Falsafiable with ~S" (slot-value result 'failure-values))) + +;;;; ** Generators. + +;;;; Since this is random testing we need some way of creating random +;;;; data to feed to our code. Generators are regular functions whcih +;;;; create this random data. + +;;;; We provide a set of built-in generators. + +(defmacro defgenerator (name arguments &body body) + `(defun ,name ,arguments + (lambda () ,@body))) + +(defgenerator gen-integer (&key (max (1+ most-positive-fixnum)) + (min (1+ most-negative-fixnum))) + (+ min (random (1+ (- max min))))) + +(defgenerator gen-character (&key (code (gen-integer :min 0 :max (1- char-code-limit)))) + (code-char (funcall code))) + +(defun gen-string (&key + (length (gen-integer :min 0 :max 80)) + (elements (gen-character)) + (element-type 'character)) + (lambda () + (loop + with length = (funcall length) + with string = (make-string length :element-type element-type) + for index below length + do (setf (aref string index) (funcall elements)) + finally (return string)))) + +(defun gen-list (&key + (length (gen-integer :min 0 :max 10)) + (elements (gen-integer :min -10 :max 10))) + (lambda () + (loop + repeat (funcall length) + collect (funcall elements)))) + +;;;; The trivial always-produce-the-same-thing generator is done using +;;;; cl:constantly. diff --git a/t/example.lisp b/t/example.lisp index 6131c39..fadeafd 100644 --- a/t/example.lisp +++ b/t/example.lisp @@ -85,3 +85,35 @@ (is (= 2 (add-2 0))) (is (= 0 (add-2 -2))) (is (= 0 (add-2 0)))) + +;; Finally let's try out the specification based testing. + +(defun dummy-add (a b) + (+ a b)) + +(defun dummy-strcat (a b) + (concatenate 'string a b)) + +(test dummy-add + (for-all ((a (gen-integer)) + (b (gen-integer))) + ;; assuming we have an "oracle" to compare our function results to + ;; we can use it: + (is (= (+ a b) (dummy-add a b))) + ;; if we don't have an oracle (as in most cases) we just ensure + ;; that certain properties hold: + (is (= (dummy-add a b) + (dummy-add b a))) + (is (= a (dummy-add a 0))) + (is (= 0 (dummy-add a (- a)))) + (is (< a (dummy-add a 1))) + (is (= (* 2 a) (dummy-add a a))))) + +(test dummy-strcat + (for-all ((result (gen-string)) + (split-point (gen-integer :min 0 :max 80) + (< split-point (length result)))) + (is (string= result (dummy-strcat (subseq result 0 split-point) + (subseq result split-point)))))) + +(5am:run! 'dummy-strcat) \ No newline at end of file -- 1.7.10.4