path: root/src/testiere.lisp

;;;; testiere.lisp -- core testiere functionality

(in-package #:testiere)

(defstruct testiere-hook
  ;; a function that extracts '(:tests ...), returning them and the modified form
  (extractor (error "required")) 
  ;; a function that accepts a form and returns a list of restart handlers
  (restarts-expander nil)
  ;; a function that accepts an sexpr and returns a list of symbols
  ;; (MACRO NAME . MORE) where MACRO names the macro being expanded,
  ;; NAME is some kind of unique name in the package where the form is
  ;; being defined, and MORE is a possibly empty list of arbitrary
  ;; symbols.  These lists should uniquely name, a particular
  ;; invocation of a macro up to comparison by EQUAL.
  (form-key-fn (error "required"))) 

(defvar *testiere-hooks*
  (make-hash-table)
  "Registry of macro functions and testiere-hook")

(defvar *suite-dict*
  (make-hash-table :test #'eq)
  "PACKAGE -> {FORM-KEY -> TEST-LAMBDA}")

(defun add-test-to-package-suite (form-key test-thunk)
  (let ((suite (or (gethash (symbol-package (second form-key)) *suite-dict*)
                   (setf (gethash (symbol-package (second form-key)) *suite-dict*)
                         (make-hash-table :test #'equal)))))
    (setf (gethash form-key suite) test-thunk)))

(define-condition testiere-error (error)
  ((reason :initarg :reason)))

(define-condition test-failure-error (testiere-error)
  ((test :initarg :test))
  (:report (lambda (err stream)
             (with-slots (test reason) err
               (format stream "~{~s~^ ~} failed:~%  ~a" test reason)))))

(defun failed (test reason-fmt &rest fmt-args)
  "Signal a TEST-FAILURE-ERROR. TEST is a deignator for the
test. REASON-FMT is a format string and FMT-ARGS are arguments to that
string, to be processed by CL:FORMAT."
  (error 'test-failure-error
         :test test
         :reason (apply #'format nil reason-fmt fmt-args)))

(defun report (fmt-string &rest args)
  (apply #'format *standard-output* fmt-string args))

(defun run-test (key thunk)
  (report "  Testing ~{~a~^ ~}~65,1t~:[[FAIL]~;[pass]~]~%"
          key
          (restart-case (funcall thunk)
            (report-and-continue-tests () nil))))

(defun report-and-continue-tests (e)
  (declare (ignore e))
  (invoke-restart 'report-and-continue-tests))

(defun run-package-suite (package &optional required)
  (let ((suite (gethash (find-package package) *suite-dict*)))
    (cond ((not suite)
           (if required
               (error 'testiere-error
                      :reason (format nil "No test suite found for package ~s"
                                      (package-name package)))
               (report "~%No tests found for package ~s~%" (package-name package))))
          (t
           (report "~%Running tests for package ~s~%" (package-name package))
           (loop :for form-key :being :the :hash-keys :of suite
                   :using (:hash-value test-thunk)
                 :do (run-test form-key test-thunk))))))

(defun run-suites (&key packages (automatic-continue nil) (require-all t))
  "PACKAGES is a list of pacakge designators. Attempts to run test
suites named in PACKAGES. If PACKAGES is NIL, then all known test
suites are run.

If AUTOMATIC-CONTINUE is T then all TEST-FAILURE-ERRORs will be
handled by printing a test failure before continuing with the suite.

If REQUIRE-ALL is T then an error will be signalled if no suite exists
for one of the members of PACKAGES."
  (let ((packages
          (if packages packages
              (loop :for p :being :the :hash-keys :of *suite-dict*
                    :collect p))))
    (if automatic-continue
        (handler-bind ((test-failure-error #'report-and-continue-tests))
          (loop :for p :in packages :do (run-package-suite p require-all)))
        (loop :for p :in packages :do (run-package-suite p require-all)))))

(defun register-hook (macro extractor form-key-fn &optional restarts-expander)
  "Register a new hook for use with testiere. 

MACRO is a symbol naming a macro-function

EXTRACTOR is a function of one argument, FORM representing the &WHOLE
of the macro-function call. It returns two values: a modified s form
identical with FORM except (:tests ...) forms have been
removed. The second value should be the conatenation of the CDRs of
these (:tests ...) forms.

RESTARTS-EXPANDER is an optional functionof one argument. It returns
the restart handler clauses of a RESTART-CASE form.  These are the
restarts to try when tests fail."
  (setf (gethash (macro-function macro) *testiere-hooks*)
        (make-testiere-hook
         :extractor extractor
         :form-key-fn form-key-fn
         :restarts-expander restarts-expander)))

(defvar *cached-macroexpand-hook* nil)

(defun testiere-hook (expander form environment)
  (let* ((hook (gethash expander *testiere-hooks*)))
    (cond
      (hook
       (with-slots (extractor restarts-expander form-key-fn) hook
         (multiple-value-bind (form test-forms) (funcall extractor form)
           (if test-forms 
               (let* ((key   (funcall form-key-fn form))
                      (tests (expand-test-forms key test-forms)))
                 (if restarts-expander 
                     `(prog1 ,(funcall expander form environment)
                        (restart-case (progn ,@tests)
                          ,@(funcall restarts-expander form))
                        (add-test-to-package-suite ',key (lambda () ,@tests t)))
                     `(prog1 ,(funcall expander form environment)
                        ,@tests
                        (add-test-to-package-suite ',key (lambda () ,@tests t)))))
               (funcall expander form environment)))))
      (t
       (funcall expander form environment)))))

(defun expand-test-forms (key forms)
  (loop :for form :in forms :collect (expand-test-form key form)))

(defun expand-test-form (key form)
  (ematch form
    ((list :fails failing-form)
     `(unless (handler-case (progn ,failing-form nil)
                (error () t))
        (failed ',key "~s should have signalled an error but did not."
                ',failing-form)))

    ((list :signals condition signalling-form)
     `(unless (handler-case (progn ,signalling-form)
                (,condition () t)
                (condition () nil))
        (failed ',key "~s should have signalled ~s but did not."
                ',signalling-form
                ',condition)))

    ((list* :funcall function args)
     (let ((err (gensym "ERROR-")))
       `(handler-case (funcall ,function ,@args)
          (error (,err) (failed ',key "~s signalled an error: ~s"
                                '(funcall ,function ,@args)
                                ,err)))))

    ((list* :with-defuns (list* stubs) body)
     (expand-defun-stubs key stubs body))

    ((list* :with-generic name (list* method-stubs) body)
     (expand-generic-stub key name method-stubs body))

    ((list* :let (list* bindings) body)
     `(let ,bindings ,@(expand-test-forms key body)))

    ((list :do form)
     (let ((err (gensym "ERROR-")))
       `(handler-case ,form
          (error (,err)
            (failed ',key "Side effecting code ~s signalled an error ~s"
                    ',form ,err)))))

    ((list :is form)
     `(unless ,form
        (failed ',key "~s returned NIL" ',form)))
    
    ((list comparator a b)
     (let ((left (gensym "LEFT-"))
           (right (gensym "RIGHT-"))
           (pred-result (gensym "RESULT-")))
       `(let* ((,left ,a)
               (,right ,b)
               (,pred-result (,comparator ,left ,right)))
          (unless ,pred-result
            (failed ',key "~s is NIL" ',form)))))))

(defun expand-defun-stubs (key defs body)
  (let* ((redef-names
           (mapcar #'car defs))

         (defun-cache
           (loop :for name :in redef-names
                 :collect `(cons ',name
                                 (and (fboundp ',name)
                                      (fdefinition ',name)))))

         (defun-cache-var
           (gensym "DEFUN-CACHE"))

         (defun-redefs
           (loop :for (name lambda-list . fbod) :in defs
                 :collect `(setf (fdefinition ',name)
                                 (lambda ,lambda-list ,@fbod))))

         (defun-restore
           (loop :for name :in redef-names
                 :collect `(if (cdr (assoc ',name ,defun-cache-var))
                               (setf (fdefinition ',name)
                                     (cdr (assoc ',name ,defun-cache-var)))
                               (fmakunbound ',name)))))
    `(let ((,defun-cache-var (list ,@defun-cache)))
       (unwind-protect
            (progn ,@defun-redefs
                   ,@(expand-test-forms key body))
         ,@defun-restore))))

(defun expand-generic-stub (key name method-stubs body)
  (let* ((orig-generic
           (gensym "DEFGENERIC-CACHE"))

         (method-defs
           (loop :for stub :in method-stubs
                 :collect `(defmethod ,name ,@stub))))
    
    `(let ((,orig-generic (and (fboundp ',name) (fdefinition ',name))))
       (unwind-protect
            (progn
              ,@method-defs
              ,@(expand-test-forms key body))
         (when ,orig-generic
           (setf (fdefinition ',name) ',orig-generic))))))

(defun on ()
  (unless (member :testiere *features*)
    (pushnew :testiere *features*)
    (setf
     *cached-macroexpand-hook* *macroexpand-hook*
     *macroexpand-hook* 'testiere-hook )))

(defun off ()
  (when (member :testiere *features*) 
    (setf *features* (delete :testiere *features*))
    (setf *macroexpand-hook* *cached-macroexpand-hook*
          *cached-macroexpand-hook* nil)))