;;; -*- mode: Lisp; Syntax: Common-Lisp; -*- ;;; ;;; Copyright (c) 2006 by the authors. ;;; ;;; See LICENCE for details. (in-package :hu.dwim.stefil) (defun extract-assert-expression-and-message (input-form) "Look into the expression and try to extract a more descriptive failure message; e.g. in case of (= A B) bind A and B to a temp variable and print their values in case the assertion fails. Returns as values: (bindings expression message message-args)" (let* ((negatedp nil) (predicate) (arguments '())) (labels ((process (form) (if (consp form) (case (first form) ((not) (assert (= (length form) 2)) (setf negatedp (not negatedp)) (process (second form))) (t (setf predicate (first form)) (setf arguments (rest form)))) (setf predicate form)))) (process input-form) (cond ((ignore-errors (macro-function predicate)) (values '() input-form "Macro expression ~S evaluated to false." (list `(quote ,input-form)))) ((and (ignore-errors (fdefinition predicate)) ;; let's just skip CL:IF and don't change its evaluation semantics while trying to be more informative... (not (eq predicate 'if))) (cond ((= (length arguments) 0) (values '() input-form "Expression ~A evaluated to false." (list `(quote ,input-form)))) ((= (length arguments) 2) (with-unique-names (x y) (values `((,x ,(first arguments)) (,y ,(second arguments))) (if negatedp `(not (,predicate ,x ,y)) `(,predicate ,x ,y)) "Binary predicate ~A failed.~%~ x: ~S => ~S~%~ y: ~S => ~S" (list (if negatedp `(quote (not (,predicate x y))) `(quote (,predicate x y))) `(quote ,(first arguments)) x `(quote ,(second arguments)) y)))) (t (let* ((arg-values (mapcar (lambda (el) (unless (keywordp el) (gensym))) arguments)) (bindings (loop :for arg :in arguments :for arg-value :in arg-values :when arg-value :collect `(,arg-value ,arg))) (expression-values (mapcar (lambda (arg-value argument) (or arg-value argument)) arg-values arguments)) (expression (if negatedp `(not (,predicate ,@expression-values)) `(,predicate ,@expression-values)))) (loop :with message = "Expression ~A evaluated to ~A" :for arg :in arguments :for idx :upfrom 0 :for arg-value :in arg-values :when arg-value :do (setf message (concatenate 'string message "~%~D: ~A => ~S")) :and :appending `(,idx (quote ,arg) ,arg-value) :into message-args :finally (return (values bindings expression message (nconc (list `(quote (,predicate ,@arguments)) (if negatedp "true" "false")) message-args)))))))) (t (values '() input-form "Expression ~A evaluated to false." (list `(quote ,input-form)))))))) (defun write-progress-char (char) (let* ((global-context (when (has-global-context) *global-context*))) (when (and global-context (print-test-run-progress-p global-context)) (when (and (not (zerop (progress-char-count-of global-context))) (zerop (mod (progress-char-count-of global-context) *test-progress-print-right-margin*))) (terpri *debug-io*)) (incf (progress-char-count-of global-context))) (when (or (and global-context (print-test-run-progress-p global-context)) (and (not global-context) *print-test-run-progress*)) (write-char char *debug-io*)))) (defun record/assertion-begins () (when (has-global-context) (incf (assertion-count-of *global-context*)))) (defun record/assertion-was-successful (form) (write-progress-char #\.) (when (and (has-global-context) (record-success-descriptions-p *global-context*)) (let ((description (make-instance 'succeeded-assertion :form form))) (vector-push-extend description (success-descriptions-of *global-context*))))) (defun record/unexpected-error (condition) (assert (not (typep condition 'assertion-failed))) (record/failure* 'unexpected-error :description-initargs (list :condition condition) :signal-assertion-failed nil) (when (or (debug-on-unexpected-error-p *global-context*) #+sbcl(typep condition 'sb-kernel::control-stack-exhausted)) (invoke-debugger condition)) (values)) (defun record/failure (failure-description-type &rest args) (record/failure* failure-description-type :description-initargs args)) (defun record/failure* (failure-description-type &key (signal-assertion-failed t) description-initargs) (let* ((description (apply #'make-instance failure-description-type :test-context-backtrace (when (has-context) (loop :for context = (current-context) :then (parent-context-of context) :while context :collect context)) description-initargs))) (if (and (has-global-context) (has-context)) (progn (vector-push-extend description (failure-descriptions-of *global-context*)) (incf (number-of-added-failure-descriptions-of *context*)) (write-progress-char (progress-char-of description)) (when signal-assertion-failed (restart-case (error 'assertion-failed :test (test-of *context*) :failure-description description) (continue () :report (lambda (stream) (format stream "~@")))))) (progn (describe description *debug-io*) (when *debug-on-assertion-failure* ; we have no *global-context* (restart-case (error 'assertion-failed :failure-description description) (continue () :report (lambda (stream) (format stream "~@"))))))))) (defmacro is (&whole whole_ form &optional (message nil message-p) &rest message-args) (multiple-value-bind (bindings expression message message-args) (if message-p (values nil form message message-args) (extract-assert-expression-and-message form)) (with-unique-names (result whole) `(let ((,whole ',whole_)) (record/assertion-begins) (let* (,@bindings (,result (multiple-value-list ,expression))) (if (first ,result) (record/assertion-was-successful ,whole) (record/failure 'failed-assertion :form ,whole :format-control ,message :format-arguments (list ,@message-args))) (values-list ,result)))))) (defmacro signals (&whole whole_ what &body body) (let* ((condition-type what)) (when (quoted-form? condition-type) (error "~S expects an unquoted condition-type, probably there's a superfulous quote at ~S." 'signals condition-type)) (with-unique-names (whole) `(let ((,whole ',whole_)) (record/assertion-begins) (block test-block (handler-bind ((,condition-type (lambda (c) (record/assertion-was-successful ,whole) (return-from test-block c)))) ,@body) (record/failure 'missing-condition :form ,whole :condition ',condition-type) (values)))))) (defmacro not-signals (&whole whole_ what &body body) (let* ((condition-type what)) (when (quoted-form? condition-type) (error "~S expects an unquoted condition-type, probably there's a superfulous quote at ~S." 'not-signals condition-type)) (with-unique-names (whole) `(let ((,whole ',whole_)) (record/assertion-begins) (block test-block (multiple-value-prog1 (handler-bind ((,condition-type (lambda (c) (record/failure 'extra-condition :form ,whole :condition c) (return-from test-block c)))) ,@body) (record/assertion-was-successful ,whole))))))) (defmacro finishes (&whole whole_ &body body) ;; could be `(not-signals t ,@body), but that would register a confusing failed-assertion (with-unique-names (success? whole) `(let ((,success? nil) (,whole ',whole_)) (record/assertion-begins) (unwind-protect (multiple-value-prog1 (progn ,@body) (setf ,success? t) (record/assertion-was-successful ,whole)) (unless ,success? ;; TODO painfully broken: when we don't finish due to a restart, then we don't want this here to be triggered... (record/failure 'failed-assertion :form ,whole :format-control "FINISHES block did not finish: ~S" :format-arguments ,whole))))))