Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

STYLE: Merging DEFMETHODs into DEFGENERICs + :METHODs

  • Loading branch information...
commit 172b8664e81f8db61ed66016cbfbb6f75dde6761 1 parent d8b9e6c
@adlai authored
Showing with 168 additions and 178 deletions.
  1. +59 −59 src/explain.lisp
  2. +109 −119 src/run.lisp
View
118 src/explain.lisp
@@ -5,65 +5,65 @@
(defparameter *verbose-failures* nil
"T if we should print the expression failing, NIL otherwise.")
-(defmethod explain ((exp detailed-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))
- (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 (reverse 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 stream)))))
-
-(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 "~&~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 "~vT~D UNKNOWN RESULTS.~%" recursive-depth num-unknown))))
+(defgeneric explain (explainer results &optional stream recursive-depth)
+ (:method ((exp detailed-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))
+ (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 (reverse 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 stream)))))
+ (:method ((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 "~&~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 "~vT~D UNKNOWN RESULTS.~%" recursive-depth num-unknown)))))
(defun partition-results (results-list)
(let ((num-checks (length results-list)))
View
228 src/run.lisp
@@ -23,59 +23,53 @@
between test-cases has been detected."))
(defgeneric run-resolving-dependencies (test)
- (:documentation "Given a dependency spec determine if the spec
-is satisfied or not, this will generally involve running other
-tests. If the dependency spec can be satisfied the test is alos
-run."))
-
-(defmethod run-resolving-dependencies ((test test-case))
- "Return true if this test, and its dependencies, are satisfied,
- NIL otherwise."
- (case (status test)
- (:unknown
- (setf (status test) :resolving)
- (if (or (not (depends-on test))
- (eql t (resolve-dependencies (depends-on test))))
- (progn
- (run-test-lambda test)
- (status test))
- (with-run-state (result-list)
- (unless (eql :circular (status test))
- (push (make-instance 'test-skipped
- :test-case test
- :reason "Dependencies not satisfied")
- result-list)
- (setf (status test) :depends-not-satisfied)))))
- (:resolving
- (restart-case
- (error 'circular-dependency :test-case test)
- (skip ()
- :report (lambda (s)
- (format s "Skip the test ~S and all its dependencies." (name test)))
- (with-run-state (result-list)
- (push (make-instance 'test-skipped :reason "Circular dependencies" :test-case test)
- result-list))
- (setf (status test) :circular))))
- (t (status test))))
-
-(defmethod resolve-dependencies ((depends-on symbol))
- "A test which depends on a symbol is interpreted as `(AND
- ,DEPENDS-ON)."
- (run-resolving-dependencies (get-test depends-on)))
-
-(defmethod resolve-dependencies ((depends-on list))
- "Return true if the dependency spec DEPENDS-ON is satisfied,
- nil otherwise."
- (if (null depends-on)
- t
- (flet ((satisfies-depends-p (test)
- (funcall test (lambda (dep)
- (eql t (resolve-dependencies dep)))
- (cdr depends-on))))
- (ecase (car depends-on)
- (and (satisfies-depends-p #'every))
- (or (satisfies-depends-p #'some))
- (not (satisfies-depends-p #'notany))))))
+ (:documentation "Given a dependency spec determine if the spec is
+ satisfied or not, this will generally involve running other tests.
+ If the dependency spec can be satisfied the test is also run.")
+ (:method ((test test-case))
+ "Return true if this test, and its dependencies, are satisfied, NIL otherwise."
+ (case (status test)
+ (:unknown
+ (setf (status test) :resolving)
+ (if (or (not (depends-on test))
+ (eql t (resolve-dependencies (depends-on test))))
+ (progn
+ (run-test-lambda test)
+ (status test))
+ (with-run-state (result-list)
+ (unless (eql :circular (status test))
+ (push (make-instance 'test-skipped
+ :test-case test
+ :reason "Dependencies not satisfied")
+ result-list)
+ (setf (status test) :depends-not-satisfied)))))
+ (:resolving
+ (restart-case
+ (error 'circular-dependency :test-case test)
+ (skip ()
+ :report (lambda (s)
+ (format s "Skip the test ~S and all its dependencies." (name test)))
+ (with-run-state (result-list)
+ (push (make-instance 'test-skipped :reason "Circular dependencies" :test-case test)
+ result-list))
+ (setf (status test) :circular))))
+ (t (status test)))))
+
+(defgeneric resolve-dependencies (depends-on)
+ (:method ((depends-on symbol))
+ "A test which depends on a symbol is interpreted as `(AND ,DEPENDS-ON)."
+ (run-resolving-dependencies (get-test depends-on)))
+ (:method ((depends-on list))
+ "Return true if the dependency spec DEPENDS-ON is satisfied,nil otherwise."
+ (if (null depends-on) t
+ (flet ((satisfies-depends-p (test)
+ (funcall test (lambda (dep)
+ (eql t (resolve-dependencies dep)))
+ (cdr depends-on))))
+ (ecase (car depends-on)
+ (and (satisfies-depends-p #'every))
+ (or (satisfies-depends-p #'some))
+ (not (satisfies-depends-p #'notany)))))))
(defun results-status (result-list)
"Given a list of test results (generated while running a test)
@@ -93,74 +87,70 @@ run."))
(funcall test-lambda)
result-list))
-(defmethod run-test-lambda ((test test-case))
- (with-run-state (result-list)
- (bind-run-state ((current-test test))
- (labels ((abort-test (e)
- (add-result 'unexpected-test-failure
- :test-expr nil
- :test-case test
- :reason (format nil "Unexpected Error: ~S~%~A." e e)
- :condition e))
- (run-it ()
- (let ((result-list '()))
- (declare (special result-list))
- (handler-bind ((check-failure (lambda (e)
- (declare (ignore e))
- (unless *debug-on-failure*
- (invoke-restart
- (find-restart 'ignore-failure)))))
- (error (lambda (e)
- (unless (or *debug-on-error*
- (typep e 'check-failure))
- (abort-test e)
- (return-from run-it result-list)))))
- (restart-case
- (let ((*readtable* (copy-readtable))
- (*package* (runtime-package test)))
- (funcall (test-lambda test)))
- (retest ()
- :report (lambda (stream)
- (format stream "~@<Rerun the test ~S~@:>" test))
- (return-from run-it (run-it)))
- (ignore ()
- :report (lambda (stream)
- (format stream "~@<Signal an exceptional test failure and abort the test ~S.~@:>" test))
- (abort-test (make-instance 'test-failure :test-case test
- :reason "Failure restart."))))
- result-list))))
- (let ((results (run-it)))
- (setf (status test) (results-status results)
- result-list (nconc result-list results)))))))
+(defgeneric run-test-lambda (test)
+ (:method ((test test-case))
+ (with-run-state (result-list)
+ (bind-run-state ((current-test test))
+ (labels ((abort-test (e)
+ (add-result 'unexpected-test-failure
+ :test-expr nil
+ :test-case test
+ :reason (format nil "Unexpected Error: ~S~%~A." e e)
+ :condition e))
+ (run-it ()
+ (let ((result-list '()))
+ (declare (special result-list))
+ (handler-bind ((check-failure (lambda (e)
+ (declare (ignore e))
+ (unless *debug-on-failure*
+ (invoke-restart
+ (find-restart 'ignore-failure)))))
+ (error (lambda (e)
+ (unless (or *debug-on-error*
+ (typep e 'check-failure))
+ (abort-test e)
+ (return-from run-it result-list)))))
+ (restart-case
+ (let ((*readtable* (copy-readtable))
+ (*package* (runtime-package test)))
+ (funcall (test-lambda test)))
+ (retest ()
+ :report (lambda (stream)
+ (format stream "~@<Rerun the test ~S~@:>" test))
+ (return-from run-it (run-it)))
+ (ignore ()
+ :report (lambda (stream)
+ (format stream "~@<Signal an exceptional test failure and abort the test ~S.~@:>" test))
+ (abort-test (make-instance 'test-failure :test-case test
+ :reason "Failure restart."))))
+ result-list))))
+ (let ((results (run-it)))
+ (setf (status test) (results-status results)
+ result-list (nconc result-list results))))))))
(defgeneric %run (test-spec)
- (:documentation "Internal method for running a test. Does not
- update the status of the tests nor the special vairables !,
- !!, !!!"))
-
-(defmethod %run ((test test-case))
- (run-resolving-dependencies test))
-
-(defmethod %run ((tests list))
- (mapc #'%run tests))
-
-(defmethod %run ((suite test-suite))
- (let (suite-results)
- (flet ((run-tests ()
- (loop
- :for test :being :the hash-values :of (tests suite)
- :do (%run test))))
- (unwind-protect
- (bind-run-state ((result-list '()))
- (run-tests)
- (setf suite-results result-list
- (status suite) (every (fun (typep _ 'test-passed)) suite-results)))
- (with-run-state (result-list)
- (setf result-list (nconc result-list suite-results)))))))
-
-(defmethod %run ((test-name symbol))
- (when (get-test test-name)
- (%run (get-test test-name))))
+ (:documentation "Internal method for running a test. Does not update
+ the status of the tests nor the special vairables !, !!, or !!!")
+ (:method ((test test-case))
+ (run-resolving-dependencies test))
+ (:method ((tests list))
+ (mapc #'%run tests))
+ (:method ((suite test-suite))
+ (let (suite-results)
+ (flet ((run-tests ()
+ (loop
+ :for test :being :the hash-values :of (tests suite)
+ :do (%run test))))
+ (unwind-protect
+ (bind-run-state ((result-list '()))
+ (run-tests)
+ (setf suite-results result-list
+ (status suite) (every (fun (typep _ 'test-passed)) suite-results)))
+ (with-run-state (result-list)
+ (setf result-list (nconc result-list suite-results)))))))
+ (:method ((test-name symbol))
+ (when (get-test test-name)
+ (%run (get-test test-name)))))
(defvar *initial-!* (lambda () (format t "Haven't run that many tests yet.~%")))
(defvar *!* *initial-!*)
Please sign in to comment.
Something went wrong with that request. Please try again.