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

(in-package #:testiere)

(defstruct testiere-hook
  ;; a function that extracts '(:tests ...), returning them and the modified form
  (extractor nil) 
  ;; a function that accepts a form and returns a list of restart handlers
  (restarts-expander nil)) 

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

(defun register-hook (macro extractor &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
         :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) hook
         (multiple-value-bind (form test-forms) (funcall extractor form)
           (if test-forms 
               (let ((tests (expand-test-forms test-forms)))
                 (if restarts-expander 
                     `(prog1 ,(funcall expander form environment)
                        (restart-case (progn ,@tests)
                          ,@(funcall restarts-expander form)))
                     `(prog1 ,(funcall expander form environment)
                        ,@tests)))
               (funcall expander form environment)))))
      (t
       (funcall expander form environment)))))

(defun expand-test-forms (forms)
  (mapcar #'expand-test-form forms))

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

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

    ((list* :funcall function args)
     `(funcall ,function ,@args))

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

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

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

    ((list :do form)
     form)

    ((list :is form)
     `(assert ,form () "~s failed" ',form))
    
    ((list comparator a b)
     (let ((a-result (gensym))
           (b-result (gensym))
           (pred-result (gensym)))
       `(let* ((,a-result ,a)
               (,b-result ,b)
               (,pred-result (,comparator ,a-result ,b-result)))
          (assert ,pred-result () "~s failed with ~s"
                  ',form
                  (list ',comparator ,a-result ,b-result)))))))

(defun expand-defun-stubs (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 body))
         ,@defun-restore))))

(defun expand-generic-stub (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 body))
         (when ,orig-generic
           (setf (fdefinition ',name) ',orig-generic))))))


(defun standard-extractor (orig-form)
  "A somewhat naive default test form extractor. Returns two values,
orig-form without test forms included, and a collection of test forms."
  (loop
    :for form :in orig-form
    :when (and (listp form)
               (eq :tests  (first form)))
      :append (cdr form) :into tests-forms
    :else
      :collect form :into defun-form
    :finally (return (values defun-form tests-forms))))


(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)))