From f414d71f98e3d8e210dce2dcf114662c4a0e3d12 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Micha=C3=ABl=20Le=20Barbier?= Date: Sun, 31 Mar 2024 20:56:33 +0200 Subject: [PATCH] Avoid code-walking in DEFINE-TESTCASE Rewrite the DEFINE-TESTCASE macro so that it does not rely on code walking. This approach is lengthy, brittle and hard to expand. It furthermore has some unexpected inconvenience. The DEFINE-TESTCASE macro is rewritten so that it only instruments assertions using signal and handlers. --- org.melusina.confidence.asd | 1 + src/package.lisp | 20 +- src/result.lisp | 330 ++++++--------------------------- src/testcase.lisp | 358 ++++++++++++++++++++++++++++++------ testsuite/entrypoint.lisp | 4 + testsuite/result.lisp | 70 ++----- testsuite/testcase.lisp | 39 ++-- testsuite/utilities.lisp | 119 ++++++++---- 8 files changed, 501 insertions(+), 440 deletions(-) diff --git a/org.melusina.confidence.asd b/org.melusina.confidence.asd index 8a921a2..fbae8ec 100644 --- a/org.melusina.confidence.asd +++ b/org.melusina.confidence.asd @@ -37,6 +37,7 @@ (:file "assertion") (:file "result") (:file "testcase") + (:file "interactive") (:file "entrypoint"))))) (asdf:defsystem #:org.melusina.confidence/development diff --git a/src/package.lisp b/src/package.lisp index c0a57eb..c9bcb0b 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -16,12 +16,22 @@ (:export #:quit ;; Results - #:assertion-success - #:assertion-failure - #:assertion-condition - #:testcase-result - #:record-result + #:testcase-outcome + #:testcase-path + #:testcase-name + #:testcase-total + #:testcase-success + #:testcase-failure + #:testcase-condition ;; Testcases + #:assertion-path + #:assertion-name + #:assertion-argument-names + #:assertion-argument-values + #:assertion-form + #:assertion-type + #:assertion-description + #:assertion-condition #:define-testcase #:without-confidence #:*testcase-interactive-p* diff --git a/src/result.lisp b/src/result.lisp index f162047..92a9e49 100644 --- a/src/result.lisp +++ b/src/result.lisp @@ -14,257 +14,85 @@ (in-package #:org.melusina.confidence) -;;; -;;; RESULT -;;; +;;;; +;;;; TESTCASE-OUTCOME +;;;; -(defclass result nil +(defclass testcase-outcome () ((path :initarg :path + :reader testcase-path :initform nil :documentation "The path of the result in the test hierarchy. -This is the stack of preceding testcases in the test hierarchy.")) - (:documentation "The abstract class of testcase results.")) - - -;;; -;;; ASSERTION-RESULT -;;; - -(defclass assertion-result (result) - ((type - :initarg :type - :initform :function - :documentation - "One of the keywords :FUNCTION or :MACRO according to the nature of the assertion.") +This is the stack of preceding testcases in the test hierarchy.") (name :initarg :name - :initform (error "An ASSERTION-RESULT requires a :NAME.") - :documentation - "The symbol designating the assertion that yielded this result. -This is the first element of the FORM.") - (argument-values - :initarg :argument-values - :initform (error "An ASSERTION-RESULT requires an :ARGUMENT-VALUES list.") - :documentation - "The list of evaluated arguments for the assertion.") - (argument-names - :initarg :argument-names - :initform (error "An ASSERTION-RESULT requires an :ARGUMENT-NAMES list.") - :documentation - "The list of argument names for the assertion.") - (form - :initarg :form - :initform (error "An ASSERTION-RESULT requires a :FORM.") - :documentation - "The form for the assertion invocation.")) - (:documentation - "A class capturing an assertion result.")) - -(defmethod describe-object ((instance assertion-result) stream) - (format stream "~&~A is an assertion result of type ~A." instance (type-of instance)) - (with-slots (path type name argument-values form) instance - (format stream "~&Type: ~S" type) - (format stream "~&Name: ~S" name) - (when path - (format stream "~&Path:~%") - (loop :for path-element :in (reverse path) - :for path-level :from 1 - :do (dotimes (_ (* 2 path-level)) (write-char #\Space stream)) - :do (format stream "~S~%" path-element))) - (cond - ((> (length argument-values) 1) - (format stream "~&Arguments:") - (loop :for argument :in argument-values - :for i = 1 :then (1+ i) - :do (format stream "~& Argument #~A: ~S" i argument))) - ((= (length argument-values) 1) - (format stream "~&Argument: ~S" (first argument-values)))) - (format stream "~&Form: ~S" form)) - (values)) - - -;;; -;;; ASSERTION-SUCCESS -;;; - -(defclass assertion-success (assertion-result) - nil - (:documentation - "A class capturing an assertion success.")) - -(defmethod describe-object :after ((instance assertion-success) stream) - (declare (ignore instance)) - (format stream "~&Outcome: Success") - (values)) - - -;;; -;;; ASSERTION-FAILURE -;;; - -(defclass assertion-failure (assertion-result) - ((description - :initarg :description - :initform (error "An ASSERTION-FAILURE requires a :DESCRIPTION.") - :documentation - "A detailed description on why the assertion failed.")) - (:documentation - "A class capturing an assertion failure.")) - -(defun describe-object-arguments (instance stream) - (labels - ((symbol-prefix (name) - (if (keywordp name) ":" "")) - (composed-argument-p (form) - (not (atom form))) - (format-atom-argument (name value) - (format stream "~& ~A~A: ~S~%~%" - (symbol-prefix name) (symbol-name name) value)) - (format-condition-argument (name form value) - (format stream "~& ~A~A: ~S => CONDITION" - (symbol-prefix name) (symbol-name name) form) - (format stream "~& The evaluation of this form yielded a condition~%~%") - (describe value stream)) - (format-composed-argument (name form value) - (format stream "~& ~A~A: ~S => ~S~%~%" - (symbol-prefix name) (symbol-name name) form value)) - (format-argument (name form value) - (cond - ((typep value 'condition) - (format-condition-argument name form value)) - ((composed-argument-p form) - (format-composed-argument name form value)) - ((atom form) - (format-atom-argument name value)) - (t - (error "Cannot describe argument ~S => ~S" form value)))) - (format-positional-arguments (names forms values) - (loop :for name :in names - :for form :in forms - :for value :in values - :when (eq name '&key) - :return nil - :do (format-argument name form value))) - (format-key-arguments (names forms values) - (let ((key-index (position '&key names))) - (unless key-index - (return-from format-key-arguments)) - (loop :for (form-name form) :on (subseq forms key-index) :by #'cddr - :for (value-name value) :on (subseq values key-index) :by #'cddr - :for name = (if (eq form-name value-name) - form-name - (error "Value and form name differ.")) - :do (format-argument name form value))))) - (with-slots (name form argument-values argument-names) instance - (when argument-names - (format stream - "~& In this call, forms in argument position evaluate as:~%~%")) - (format-positional-arguments argument-names (rest form) argument-values) - (format-key-arguments argument-names (rest form) argument-values)))) - -(defmethod describe-object :after ((instance assertion-failure) stream) - (format stream "~&Outcome: Failure") - (with-slots (description) instance - (format stream "~&Description: ~A" description) - (describe-object-arguments instance stream)) - (values)) - - -;;; -;;; ASSERTION-CONDITION -;;; - -(defclass assertion-condition (assertion-result) - ((condition - :initarg :condition - :initform (error "An ASSERTION-CONDITION requires a :CONDITION."))) - (:documentation - "A class capturing an assertion that signaled a condition instead -of returning normally.")) - -(defmethod describe-object :after ((instance assertion-condition) stream) - (format stream "~&Outcome: Condition") - (with-slots (condition argument-values) instance - (if (member-if (lambda (argument-value) (typep argument-value 'condition)) argument-values) - (progn - (format stream "~&Description:") ) - (progn - (format stream "~&Condition: ~S" condition) - (describe condition stream))) - (describe-object-arguments instance stream)) - (values)) - - - -;;; -;;; TESTCASE-RESULT -;;; - -(defclass testcase-result (result) - ((name - :initarg :name - :initform (error "A TESTCASE-RESULT requires a :NAME.")) + :reader testcase-name + :initform (error "A TESTCASE-OUTCOME requires a :NAME.")) (argument-values :initarg :argument-values :initform nil + :reader testcase-argument-values :documentation "The list of evaluated arguments for the testcase.") (total + :initarg :total :initform 0 + :reader testcase-total :documentation "The total number of assertions in the testcase and its descendants.") (success + :initarg :success :initform 0 + :reader testcase-success :documentation "The total number of assertions that yielded a success in the testcase and its descendants.") (failure + :initarg :failure :initform 0 + :reader testcase-failure :documentation "The total number of assertions that yielded a failure in the testcase and its descendants.") (condition + :initarg :condition :initform 0 + :reader testcase-condition :documentation - "The total number of assertions that yielded a condition in the testcase and its descendants.") - (results - :initarg :results - :initform (error "A TESTCASE-RESULT requires a list of :RESULTS.") - :documentation - "The list of testcase results and assertions results yielded by descendants.")) + "The total number of assertions that yielded a condition in the testcase and its descendants.")) (:documentation - "A class capturing a testcase result.")) + "A class capturing a testcase outcome.")) -(defmethod initialize-instance :after ((instance testcase-result) &rest initargs &key &allow-other-keys) - (declare (ignore initargs)) - (with-slots (results total success failure condition) instance - (loop :for result :in results - :do (etypecase result - (assertion-success - (incf total) - (incf success)) - (assertion-failure - (incf total) - (incf failure)) - (assertion-condition - (incf total) - (incf condition)) - (testcase-result - (incf total (slot-value result 'total)) - (incf success (slot-value result 'success)) - (incf failure (slot-value result 'failure)) - (incf condition (slot-value result 'condition))))))) - -(defmethod print-object ((instance testcase-result) stream) +(defmethod print-object ((instance testcase-outcome) stream) (print-unreadable-object (instance stream :type t :identity t) (format stream ":NAME ~S" (if (slot-boundp instance 'name) (slot-value instance 'name) "(no name)")) (loop :for slot :in '(total success failure condition) - :do (format stream " :~S ~A" slot (slot-value instance slot))))) - -(defmethod describe-object ((instance testcase-result) stream) - (with-slots (name argument-values total success failure condition results) instance + :do (format stream " :~A ~A" (symbol-name slot) (slot-value instance slot))))) + +(defmethod describe-object ((instance testcase-outcome) stream) + (flet ((describe-path (path) + (when path + (format stream "~&Path:~%") + (loop :for path-element :in (reverse path) + :do (format stream "~S~%" path-element)))) + (describe-result (&key total success failure condition) + (format stream "~&Total: ~D" total) + (when (> total 0) + (flet ((fraction (n) + (round (/ (* 100 n) total)))) + (format stream "~&Success: ~D/~D (~D%)" + success total (fraction success)) + (format stream "~&Failure: ~D/~D (~D%)" + failure total (fraction failure)) + (format stream "~&Condition: ~D/~D (~D%)" + condition total (fraction condition))) + (if (< success total) + (format stream "~&Outcome: Failure") + (format stream "~&Outcome: Success"))))) + (with-slots (name path argument-values total success failure condition) instance (format stream "~&Name: ~S" name) + (describe-path path) (cond ((> (length argument-values) 1) (format stream "~&Arguments:") @@ -273,73 +101,21 @@ of returning normally.")) :do (format stream "~& Argument #~A: ~S" i argument))) ((= (length argument-values) 1) (format stream "~&Argument: ~S" (first argument-values)))) - (format stream "~&Total: ~D" total) - (when (> total 0) - (format stream "~&Success: ~D/~D (~D%)" - success total (round (/ (* 100 success) total))) - (format stream "~&Failure: ~D/~D (~D%)" - failure total (round (/ (* 100 failure) total))) - (format stream "~&Condition: ~D/~D (~D%)" - condition total (round (/ (* 100 condition) total)))) - (if (< success total) - (format stream "~&Outcome: Failure") - (format stream "~&Outcome: Success")) - (when (< success total) - (let ((description-separator - (make-string 80 :initial-element #\=))) - (loop :for result :in results - :when (or (typep result 'assertion-failure) - (typep result 'assertion-condition) - (and (typep result 'testcase-result) - (< (slot-value result 'success) - (slot-value result 'total)))) - :do (progn - (format stream "~&~A~&" description-separator) - (describe result stream))))) - (values))) + (describe-result :total total :success success :failure failure :condition condition)))) +(defun make-testcase-outcome (&rest initargs &key path name argument-values total success failure condition) + (declare (ignore path name argument-values total success failure condition)) + (apply #'make-instance 'testcase-outcome initargs)) ;;; -;;; Current Testcase Result +;;; Current Testcase Outcome ;;; -(defparameter *current-testcase-result* nil - "The result of the current testcase.") - -(defvar *last-testsuite-result* nil - "The result of the last testsuite.") - -(defgeneric record-result (new-result testcase-result) - (:method ((new-result result) (accumulator testcase-result)) - (with-slots (results total) accumulator - (setf results (nconc results (list new-result))))) - (:method ((new-result assertion-result) (accumulator testcase-result)) - (declare (ignore new-result)) - (incf (slot-value accumulator 'total)) - (call-next-method)) - (:method ((new-result assertion-success) (accumulator testcase-result)) - (declare (ignore new-result)) - (incf (slot-value accumulator 'success)) - (call-next-method)) - (:method ((new-result assertion-failure) (accumulator testcase-result)) - (declare (ignore new-result)) - (incf (slot-value accumulator 'failure)) - (call-next-method)) - (:method ((new-result assertion-condition) (accumulator testcase-result)) - (declare (ignore new-result)) - (incf (slot-value accumulator 'condition)) - (call-next-method)) - (:method ((new-result testcase-result) (accumulator testcase-result)) - (dolist (slot '(success failure condition total)) - (incf (slot-value accumulator slot) - (slot-value new-result slot))) - (call-next-method))) +(defparameter *current-testcase-outcome* nil + "The outcome of the current testcase.") -(defun record-testcase-result (result &optional (testcase-result *current-testcase-result*)) - "Record RESULT in TESTCASE-RESULT." - (unless testcase-result - (return-from record-testcase-result result)) - (record-result result testcase-result)) +(defvar *last-testsuite-outcome* nil + "The outcome of the last testsuite.") ;;;; End of file `result.lisp' diff --git a/src/testcase.lisp b/src/testcase.lisp index 388334a..fd33bc8 100644 --- a/src/testcase.lisp +++ b/src/testcase.lisp @@ -89,7 +89,220 @@ References: (random-string 7 :base36))))) (concatenate 'string *testsuite-name* designator))) + +;;;; +;;;; ASSERTION-OUTCOME +;;;; +(define-condition assertion-outcome () + ((path + :initarg :path + :initform nil + :reader assertion-path + :documentation "The path of the result in the test hierarchy. +This is the stack of preceding testcases in the test hierarchy.") + (type + :initarg :type + :initform :function + :reader assertion-type + :documentation + "One of the keywords :FUNCTION or :MACRO according to the nature of the assertion.") + (name + :initarg :name + :initform (error "An ASSERTION-OUTCOME requires a :NAME.") + :reader assertion-name + :documentation + "The symbol designating the assertion that yielded this result. +This is the first element of the FORM.") + (argument-values + :initarg :argument-values + :initform (error "An ASSERTION-OUTCOME requires an :ARGUMENT-VALUES list.") + :reader assertion-argument-values + :documentation + "The list of evaluated arguments for the assertion.") + (argument-names + :initarg :argument-names + :initform (error "An ASSERTION-OUTCOME requires an :ARGUMENT-NAMES list.") + :reader assertion-argument-names + :documentation + "The list of argument names for the assertion.") + (form + :initarg :form + :initform (error "An ASSERTION-OUTCOME requires a :FORM.") + :reader assertion-form + :documentation + "The form for the assertion invocation.")) + (:report describe-assertion-outcome) + (:documentation + "The condition signalling an assertion result.")) + +(defun describe-assertion-outcome (condition stream) + (flet ((describe-path (path) + (when path + (format stream "~&Path:~%") + (loop :for path-element :in (reverse path) + :do (format stream "~S~%" path-element)))) + (describe-argument-values (argument-values) + (cond + ((> (length argument-values) 1) + (format stream "~&Arguments:") + (loop :for argument :in argument-values + :for i = 1 :then (1+ i) + :do (format stream "~& Argument #~A: ~S" i argument))) + ((= (length argument-values) 1) + (format stream "~&Argument: ~S" (first argument-values)))))) + (format stream "~&Type: ~S" (assertion-type condition)) + (format stream "~&Name: ~S" (assertion-name condition)) + (describe-path (assertion-path condition)) + (describe-argument-values (assertion-argument-values condition)) + (format stream "~&Form: ~S" (assertion-form condition)) + (values))) + + +;;;; +;;;; ASSERTION-SUCCESS +;;;; + +(define-condition assertion-success (assertion-outcome) + nil + (:report describe-assertion-success) + (:documentation "The condition signaled by succesful assertions.")) + +(defun describe-assertion-success (condition stream) + (describe-assertion-outcome condition stream) + (format stream "~&Outcome: Success") + (values)) + + +;;;; +;;;; ASSERTION-FAILURE +;;;; + +(define-condition assertion-failure (assertion-outcome) + ((description + :initarg :description + :initform (error "An ASSERTION-FAILURE requires a :DESCRIPTION.") + :reader assertion-description + :documentation + "A detailed description on why the assertion failed.")) + (:report describe-assertion-failure) + (:documentation "The condition signaled by failed assertions.")) + +(defun describe-object-arguments (condition stream) + (labels + ((symbol-prefix (name) + (if (keywordp name) ":" "")) + (composed-argument-p (form) + (not (atom form))) + (format-atom-argument (name value) + (format stream "~& ~A~A: ~S~%~%" + (symbol-prefix name) (symbol-name name) value)) + (format-condition-argument (name form value) + (format stream "~& ~A~A: ~S => CONDITION" + (symbol-prefix name) (symbol-name name) form) + (format stream "~& The evaluation of this form yielded a condition~%~%") + (describe value stream)) + (format-composed-argument (name form value) + (format stream "~& ~A~A: ~S => ~S~%~%" + (symbol-prefix name) (symbol-name name) form value)) + (format-argument (name form value) + (cond + ((typep value 'condition) + (format-condition-argument name form value)) + ((composed-argument-p form) + (format-composed-argument name form value)) + ((atom form) + (format-atom-argument name value)))) + (format-positional-arguments (names forms values) + (loop :for name :in names + :for form :in forms + :for value :in values + :when (eq name '&key) + :return nil + :do (format-argument name form value))) + (format-key-arguments (names forms values) + (let ((key-index (position '&key names))) + (unless key-index + (return-from format-key-arguments)) + (loop :for (form-name form) :on (subseq forms key-index) :by #'cddr + :for (value-name value) :on (subseq values key-index) :by #'cddr + :for name = (if (eq form-name value-name) + form-name + (error "Value and form name differ.")) + :do (format-argument name form value))))) + (let ((form + (assertion-form condition)) + (argument-values + (assertion-argument-values condition)) + (argument-names + (assertion-argument-names condition))) + (when argument-names + (format stream + "~& In this call, forms in argument position evaluate as:~%~%")) + (format-positional-arguments argument-names (rest form) argument-values) + (format-key-arguments argument-names (rest form) argument-values)))) + +(defun describe-assertion-failure (condition stream) + (describe-assertion-outcome condition stream) + (format stream "~&Outcome: Failure") + (format stream "~&Description: ~A" (assertion-description condition)) + (describe-object-arguments condition stream) + (values)) + + +;;; +;;; ASSERTION-CONDITION +;;; + +(define-condition assertion-condition (assertion-outcome) + ((condition + :initarg :condition + :initform (error "An ASSERTION-CONDITION requires a :CONDITION.") + :reader assertion-condition + :documentation "The condition signalled by the assertion.")) + (:report describe-assertion-condition) + (:documentation "The condition signaled by assertions that trigger an unexpected condition +instead of returning normally.")) + +(defun describe-assertion-condition (condition stream) + (describe-assertion-outcome condition stream) + (format stream "~&Outcome: Condition") + (let ((argument-values + (assertion-argument-values condition)) + (condition + (assertion-condition condition))) + (if (member-if (lambda (argument-value) (typep argument-value 'condition)) argument-values) + (progn + (format stream "~&Description:") ) + (progn + (format stream "~&Condition: ~S" condition) + (describe condition stream)))) + (describe-object-arguments condition stream) + (values)) + +(define-condition assertion-skipped nil nil + (:documentation "The condition signaled by assertions that are skipped.")) + + +;;;; +;;;; TESTCASE-END +;;;; + +(define-condition testcase-end () + ((outcome + :initarg :outcome + :initform (error "A TESTCASE-END requires an outcome.") + :reader testcase-outcome + :documentation + "The outcome of the finished testcase.")) + (:report describe-testcase-end) + (:documentation + "The condition signalled at the end of a testcase.")) + +(defun describe-testcase-end (condition stream) + (describe-object (testcase-outcome condition) stream)) + + ;;; ;;; SUPERVISE-ASSERTION ;;; @@ -100,7 +313,7 @@ References: (multiple-value-bind (success-p description) (handler-case (if argument-condition - (make-instance + (signal 'assertion-condition :path *testcase-path* :name name @@ -110,8 +323,8 @@ References: :type type :condition (first argument-condition)) (funcall assertion-lambda argument-values)) - (t (unexpected-condition) - (make-instance + (serious-condition (unexpected-condition) + (signal 'assertion-condition :path *testcase-path* :name name @@ -121,25 +334,23 @@ References: :type type :condition unexpected-condition))) (cond - ((typep success-p 'result) - success-p) ((not success-p) - (make-instance 'assertion-failure - :path *testcase-path* - :name name - :argument-names argument-names - :argument-values argument-values - :form form - :type type - :description description)) + (signal 'assertion-failure + :path *testcase-path* + :name name + :argument-names argument-names + :argument-values argument-values + :form form + :type type + :description description)) (t - (make-instance 'assertion-success - :path *testcase-path* - :name name - :argument-names argument-names - :argument-values argument-values - :form form - :type type))))) + (signal 'assertion-success + :path *testcase-path* + :name name + :argument-names argument-names + :argument-values argument-values + :form form + :type type))))) (evaluation-strategy (argument-values) (evaluation-strategy-1 (member-if (lambda (object) (typep object 'condition)) argument-values) @@ -192,7 +403,7 @@ guarantees that conditions triggered by the evaluation of arguments are recorded (defun set-testcase-properties (name) (setf (get name :org.melusina.confidence/testcase) t))) -(defun define-testcase/wrap-confidence-forms (body-forms) +(defun define-testcase/wrap-assertion-forms (body-forms) "Walks through BODY-FORMS and wrap assertion forms in a RESTART-CASE." (labels ((function-name (form) @@ -222,23 +433,17 @@ symbol of this function." (is-assert-form-p (form) (get (is-assert-name-p (is-funcall-p form)) :org.melusina.confidence/assertion)) - (is-testcase-form-p (form) - (get (is-funcall-p form) - :org.melusina.confidence/testcase)) - (wrap-confidence-forms (form) + (wrap-assertion-forms (form) (cond ((eq 'without-confidence (is-funcall-p form)) `(progn ,@(rest form))) ((is-assert-form-p form) - `(record-testcase-result - (supervise-assertion ,form))) - ((is-testcase-form-p form) - `(record-testcase-result ,form)) + `(supervise-assertion ,form)) ((is-funcall-p form) - (cons (first form) (mapcar #'wrap-confidence-forms (rest form)))) + (cons (first form) (mapcar #'wrap-assertion-forms (rest form)))) (t form)))) - (mapcar #'wrap-confidence-forms body-forms))) + (mapcar #'wrap-assertion-forms body-forms))) (defun testcase-result-pathname (result) "The pathname used to write RESULT description." @@ -256,18 +461,68 @@ symbol of this function." (with-open-file (stream pathname :direction :output :if-exists :supersede) (describe result stream)))) -(defun maybe-perform-testsuite-epilogue () - "When invoked from a testsuite, performs testsuite epilogue. -The testsuite epilogue prints details about the current testcase -result and saves the result as the *LAST-TESTSUITE-RESULT*." - (when (< 1 (length *testcase-path*)) - (return-from maybe-perform-testsuite-epilogue - *current-testcase-result*)) - (when (>= 1 (length *testcase-path*)) - (setf *last-testsuite-result* *current-testcase-result*) - (describe *last-testsuite-result*) - (terpri))) - +(defun run-testcase (&key testcase-name testcase-body) + "Run TESTCASE-BODY" + (check-type testcase-name symbol) + (let* ((testsuite-p + (not *testsuite-id*)) + (*testsuite-id* + (or *testsuite-id* (make-testsuite-id))) + (this-testcase-outcome + (make-testcase-outcome + :path *testcase-path* + :name testcase-name)) + (*testcase-path* + (cons testcase-name *testcase-path*))) + (flet ((install-signal-handlers-and-run-testcase () + (handler-bind + ((assertion-success + (lambda (condition) + (declare (ignore condition)) + (with-slots (total success) *current-testcase-outcome* + (incf total) + (incf success)))) + (assertion-failure + (lambda (condition) + (format *trace-output* "~&Assertion Failure~%~A" condition) + (with-slots (total failure) *current-testcase-outcome* + (incf total) + (incf failure)))) + (assertion-condition + (lambda (condition) + (format *trace-output* "~&Assertion Condition~%~A" condition) + (with-slots (total condition) *current-testcase-outcome* + (incf total) + (incf condition)))) + (testcase-end + (lambda (condition) + (let ((testcase-outcome + (testcase-outcome condition))) + (with-slots (total success failure condition) *current-testcase-outcome* + (with-slots ((testcase-total total) + (testcase-success success) + (testcase-failure failure) + (testcase-condition condition)) + testcase-outcome + (incf total testcase-total) + (incf success testcase-success) + (incf failure testcase-failure) + (incf condition testcase-condition))))))) + (let ((*current-testcase-outcome* this-testcase-outcome)) + (funcall testcase-body) + (setf *last-testsuite-outcome* *current-testcase-outcome*)) + (describe *last-testsuite-outcome*) + (terpri))) + (just-run-testcase () + (let ((*current-testcase-outcome* this-testcase-outcome)) + (funcall testcase-body)) + (signal 'testcase-end :outcome this-testcase-outcome))) + (if testsuite-p + (install-signal-handlers-and-run-testcase) + (just-run-testcase)) + (values *current-testcase-outcome*)))) + + (defmacro define-testcase (testcase-name testcase-args &body body) "Define a test case function TESTCASE-NAME, accepting TESTCASE-ARGS with BODY. @@ -284,18 +539,11 @@ ran and their outcomes." ,@(when doc-string (list doc-string)) ,@declarations (declare (optimize (safety 3) (debug 3))) - (let ((*testsuite-id* - (or *testsuite-id* (make-testsuite-id))) - (*current-testcase-result* - (make-instance - 'testcase-result - :results nil - :name (quote ,testcase-name) - :path *testcase-path*)) - (*testcase-path* - (cons (quote ,testcase-name) *testcase-path*))) - ,@(define-testcase/wrap-confidence-forms remaining-forms) - (maybe-perform-testsuite-epilogue))) + (flet ((testcase-body () + ,@(define-testcase/wrap-assertion-forms remaining-forms))) + (run-testcase + :testcase-name (quote ,testcase-name) + :testcase-body #'testcase-body))) (export (quote ,testcase-name)) (set-testcase-properties ',testcase-name)))) diff --git a/testsuite/entrypoint.lisp b/testsuite/entrypoint.lisp index 6a2c4bc..9cd10b3 100644 --- a/testsuite/entrypoint.lisp +++ b/testsuite/entrypoint.lisp @@ -29,4 +29,8 @@ (testsuite-assertion) (testsuite-testcase)) +(define-testcase run-interactive-tests () + "Run interactive tests." + (testsuite-interactive)) + ;;;; End of file `entrypoint.lisp' diff --git a/testsuite/result.lisp b/testsuite/result.lisp index 95e1eee..6962ea0 100644 --- a/testsuite/result.lisp +++ b/testsuite/result.lisp @@ -13,61 +13,23 @@ (in-package #:org.melusina.confidence/testsuite) -(defun make-some-assertion-success () - (make-instance 'confidence::assertion-success - :name 'confidence:assert-t - :argument-values '(t) - :argument-names '(expr) - :form '(confidence:assert-t t))) - -(defun make-some-assertion-failure () - (make-instance 'confidence::assertion-failure - :name 'confidence:assert-t - :argument-values '(nil) - :argument-names nil - :form '(confidence:assert-t nil) - :description "The assertion (ASSERT-T EXPR) is true, iff EXPR is T.")) - -(defun make-some-assertion-failure-with-keyword-argument () - (confidence::supervise-assertion - (confidence:assert-float-is-essentially-equal 1.0 2.0 :inaccuracy 1))) - -(defun make-some-assertion-condition () - (make-instance 'confidence::assertion-condition - :name 'confidence:assert-t - :argument-values nil - :argument-names nil - :form '(confidence:assert-t (error "Some error")) - :condition (make-instance 'simple-error :format-control "Some error"))) - -(defun make-some-testcase-result () - (make-instance 'confidence::testcase-result - :name 'make-some-testcase-result - :argument-values nil - :argument-names nil - :results (list - (make-some-assertion-success) - (make-some-assertion-failure) - (make-some-assertion-condition)))) - -(define-testcase validate-result-can-be-described () - (loop :for make-some-result - :in '(make-some-assertion-success - make-some-assertion-failure - make-some-assertion-failure-with-keyword-argument - make-some-assertion-condition - make-some-testcase-result) - :do - (assert-string-match - (with-output-to-string (buffer) - (describe (funcall make-some-result) buffer)) - "*Name: *"))) - -(define-testcase validate-result-total () - (assert-eq 3 (slot-value (make-some-testcase-result) 'confidence::total))) +(define-testcase validate-outcome-can-be-described () + (let ((testcase-outcome + (confidence::make-testcase-outcome + :path '(some imaginative testcase path) + :name 'testcase-name + :argument-values '(1 :a 'b '(nil nil nil)) + :total 100 + :success 80 + :failure 17 + :condition 3))) + (assert-type testcase-outcome 'confidence::testcase-outcome) + (assert-string-match + (with-output-to-string (buffer) + (describe testcase-outcome buffer)) + "*Name: *"))) (define-testcase testsuite-result () - (validate-result-can-be-described) - (validate-result-total)) + (validate-outcome-can-be-described)) ;;;; End of file `result.lisp' diff --git a/testsuite/testcase.lisp b/testsuite/testcase.lisp index 090f8c1..75548a3 100644 --- a/testsuite/testcase.lisp +++ b/testsuite/testcase.lisp @@ -21,15 +21,16 @@ (assert-type (confidence::supervise-assertion (assert-t t)) - 'assertion-success) + '%assertion-success) + #+nil (assert-type (confidence::supervise-assertion (assert-t nil)) - 'assertion-failure) - (assert-type - (confidence::supervise-assertion - (assert-t (error "An intentional error condition"))) - 'assertion-condition)) + '%assertion-failure) + (ensure-condition + (confidence::supervise-assertion + (assert-t (error "An intentional error condition"))) + 'simple-error)) (define-testcase a-successful-testsuite () (assert-t t)) @@ -49,18 +50,28 @@ (funcall #'a-successful-testsuite) (apply 'a-successful-testsuite nil) (apply #'a-successful-testsuite nil) - (loop :for a :in '(1 2) - :do (funcall #'a-successful-testsuite))) + (dotimes (_ 2) + (funcall #'a-successful-testsuite))) (define-testcase validate-define-testcase () - (with-testcase-result testcase-result (validate-supervise-assertion) - (assert-type testcase-result 'confidence:testcase-result) - (assert-eq 2 (length (slot-value testcase-result 'confidence::results))))) + (with-testcase-outcome testcase-outcome (validate-supervise-assertion) + (assert-type testcase-outcome 'confidence:testcase-outcome) + (assert-eq 2 (confidence:testcase-total testcase-outcome)) + (assert-eq (confidence:testcase-total testcase-outcome) (confidence:testcase-success testcase-outcome)) + (assert-eq (confidence:testcase-total testcase-outcome) + (+ (confidence:testcase-success testcase-outcome) + (confidence:testcase-failure testcase-outcome) + (confidence:testcase-condition testcase-outcome))))) (define-testcase ensure-that-define-testcase-recognises-sharpsign-single-quote-in-function-names () - (with-testcase-result testcase-result (a-succesful-testsuite-with-function-calls) - (assert-type testcase-result 'confidence:testcase-result) - (assert-eq 6 (length (slot-value testcase-result 'confidence::results))))) + (with-testcase-outcome testcase-outcome (a-succesful-testsuite-with-function-calls) + (assert-type testcase-outcome 'confidence:testcase-outcome) + (assert-eq 7 (confidence:testcase-total testcase-outcome)) + (assert-eq (confidence:testcase-total testcase-outcome) (confidence:testcase-success testcase-outcome)) + (assert-eq (confidence:testcase-total testcase-outcome) + (+ (confidence:testcase-success testcase-outcome) + (confidence:testcase-failure testcase-outcome) + (confidence:testcase-condition testcase-outcome))))) (define-testcase testsuite-testcase () (validate-define-testcase) diff --git a/testsuite/utilities.lisp b/testsuite/utilities.lisp index 21b2326..91490c6 100644 --- a/testsuite/utilities.lisp +++ b/testsuite/utilities.lisp @@ -14,61 +14,110 @@ (in-package #:org.melusina.confidence/testsuite) (defun ensure-unwrap (form) - (labels ((unwrap-record (form) - (if (and (eq 2 (length form)) - (eq 'confidence::record-testcase-result (first form))) - (unwrap-supervise (second form)) - form)) - (unwrap-supervise (form) - (if (and (eq 2 (length form)) - (eq 'confidence::supervise-assertion (first form))) - (second form) - form))) - (unwrap-record form))) + (if (and (eq 2 (length form)) + (eq 'confidence::supervise-assertion (first form))) + (second form) + form)) (dolist (ensure-macro '(ensure-success ensure-failure ensure-condition)) (setf (get ensure-macro :org.melusina.confidence/testcase) t)) -(define-testcase ensure-success-1 (result) - (assert-type result 'assertion-success)) - (defmacro ensure-success (form) "Ensure that FORM yield an assertion success." - `(ensure-success-1 (confidence::supervise-assertion ,(ensure-unwrap form)))) - -(define-testcase ensure-failure-1 (result &optional description-pattern) - (assert-type result 'assertion-failure) - (when (and description-pattern (typep result 'assertion-failure)) - (assert-string-match (slot-value result 'confidence::description) description-pattern))) + `(handler-case + ,form + (confidence::assertion-success (condition) + (signal 'confidence::assertion-success + :path (confidence:assertion-path condition) + :name (confidence:assertion-name condition) + :argument-names (confidence:assertion-argument-names condition) + :argument-values (confidence:assertion-argument-values condition) + :form (confidence:assertion-form condition) + :type (confidence:assertion-type condition))) + (confidence::assertion-outcome (condition) + (signal 'confidence::assertion-failure + :path (confidence:assertion-path condition) + :name (confidence:assertion-name condition) + :argument-names (confidence:assertion-argument-names condition) + :argument-values (confidence:assertion-argument-values condition) + :form (confidence:assertion-form condition) + :type (confidence:assertion-type condition))))) (defmacro ensure-failure (form &optional description-pattern) "Ensure that FORM yield an assertion failure. When DESCRIPTION-PATTERN is provided, it also ensures that the error description satisfies this pattern." - `(ensure-failure-1 - (confidence::supervise-assertion ,(ensure-unwrap form)) - ,description-pattern)) + (alexandria:once-only (description-pattern) + `(handler-case + ,form + (confidence::assertion-failure (condition) + (if (or (not ,description-pattern) + (confidence::string-match ,description-pattern (confidence:assertion-description condition))) + (signal 'confidence::assertion-success + :path (confidence:assertion-path condition) + :name (confidence:assertion-name condition) + :argument-names (confidence:assertion-argument-names condition) + :argument-values (confidence:assertion-argument-values condition) + :form (confidence:assertion-form condition) + :type (confidence:assertion-type condition)) + (signal 'confidence::assertion-failure + :path (confidence:assertion-path condition) + :name (confidence:assertion-name condition) + :argument-names (confidence:assertion-argument-names condition) + :argument-values (confidence:assertion-argument-values condition) + :form (confidence:assertion-form condition) + :type (confidence:assertion-type condition) + :description (format nil "The description~%~% ~S~%~%does not match the pattern ~S." + (confidence:assertion-description condition) ,description-pattern)))) + (confidence::assertion-outcome (condition) + (signal 'confidence::assertion-failure + :path (confidence:assertion-path condition) + :name (confidence:assertion-name condition) + :argument-names (confidence:assertion-argument-names condition) + :argument-values (confidence:assertion-argument-values condition) + :form (confidence:assertion-form condition) + :type (confidence:assertion-type condition)))))) -(define-testcase ensure-condition-1 (result &optional condition-type) - (assert-type result 'assertion-condition) - (when (and condition-type (typep result 'assertion-condition)) - (assert-type (slot-value result 'confidence::condition) condition-type))) - (defmacro ensure-condition (form &optional (condition-type 'condition)) "Ensure that FORM yield an assertion condition. When CONDITION-TYPE is provided, it also ensures that the signalled condition has the required type." - `(ensure-condition-1 - (confidence::supervise-assertion ,(ensure-unwrap form)) - ,condition-type)) - + (alexandria:once-only (condition-type) + `(handler-case + ,form + (confidence::assertion-condition (condition) + (if (typep (confidence:assertion-condition condition) ,condition-type) + (signal 'confidence::assertion-success + :path (confidence:assertion-path condition) + :name (confidence:assertion-name condition) + :argument-names (confidence:assertion-argument-names condition) + :argument-values (confidence:assertion-argument-values condition) + :form (confidence:assertion-form condition) + :type (confidence:assertion-type condition)) + (signal 'confidence::assertion-failure + :path (confidence:assertion-path condition) + :name (confidence:assertion-name condition) + :argument-names (confidence:assertion-argument-names condition) + :argument-values (confidence:assertion-argument-values condition) + :form (confidence:assertion-form condition) + :type (confidence:assertion-type condition) + :description (format nil "The form yielded a condition~%~% ~S~%~%which is not a subtype of condition ~S." + (confidence:assertion-condition condition) ,condition-type)))) + (confidence::assertion-outcome (condition) + (signal 'confidence::assertion-failure + :path (confidence:assertion-path condition) + :name (confidence:assertion-name condition) + :argument-names (confidence:assertion-argument-names condition) + :argument-values (confidence:assertion-argument-values condition) + :form (confidence:assertion-form condition) + :type (confidence:assertion-type condition)))))) ;;;; -;;;; WITH-TESTCASE-RESULT +;;;; WITH-TESTCASE-OUTCOME ;;;; -(defmacro with-testcase-result (var form &body body) - "Bind the testcase result of FORM in VAR and execute BODY." +(defmacro with-testcase-outcome (var form &body body) + "Bind the testcase result of FORM to VAR and execute BODY." `(let ((,var (let ((*standard-output* (make-string-output-stream))