;;;; testiere.lisp

(in-package #:testiere)

(defun build-test (name spec)
  (match spec
    ((list :fails inputs)
     `(assert
       (handler-case (progn (,name ,@inputs) nil)
         (error (e) (declare (ignore e)) t))))

    ((list :signals inputs condition)
     `(assert
       (handler-case (progn (,name ,@inputs) nil)
         (,condition (c) (declare (ignore c)) t)
         (condition (c) (declare (ignore c)) nil))))

    ((list* :program function-name  args)
     `(when (fboundp ',function-name)
        (funcall ',function-name ,@args)))
    
    ((list* :with-stubs redefs more-specs)
     (let* ((assoc-vars
              (loop for (stub-name . more) in redefs
                    collect (list stub-name (gensym (symbol-name stub-name)))))
            (cache-binding-forms
              (loop for (stub-name tmp-var) in assoc-vars
                    collect `(,tmp-var (fdefinition ',stub-name))))
            (redef-forms
              (loop for (stub-name lambda-list . body) in redefs
                    collect `(setf (fdefinition ',stub-name)
                                   (function (lambda ,lambda-list ,@body)))))
            (clean-up
              (loop for (stub-name . more) in redefs
                    for binding = (assoc stub-name assoc-vars)
                    collect `(setf (fdefinition ',stub-name) ,(second binding)))))
       `(let ,cache-binding-forms
          (unwind-protect
               (progn
                 ,@redef-forms
                 ,@(mapcar (lambda (s) (build-test name s)) more-specs))
            ,@clean-up))))
    ((list* :let bindings more-specs)
     `(let ,bindings
        ,@(mapcar (lambda (s) (build-test name s)) more-specs)))
    ((list :afterp inputs thunk-test)
     `(progn (,name ,@inputs)
             (assert (funcall ,thunk-test))))
    ((list :outputp inputs output-test)
     `(assert (funcall ,output-test (,name ,@inputs))))
    ((list comparator-function inputs expected-output)
     `(assert (,comparator-function (,name ,@inputs) ,expected-output)))))

(defun extract-tests (name body)
  (let ((end-pos (position :end body))
        (start-pos (position :tests body)))
    (when (and end-pos start-pos)
      (let ((specs (subseq body (1+  start-pos) end-pos))
            (before (subseq body 0 start-pos))
            (after (nthcdr (1+ end-pos) body)))
        (list (mapcar (lambda (spec) (build-test name spec)) specs)
              (append before after))))))

(defmacro with-stub ((name lambda-list &body body) &body forms)
  "Runs forms in a context where NAME is temporarily rebound to a
different function. If NAME is not FBOUNDP then it is temporarily
defined."
  (let ((cached (gensym)))
    `(let ((,cached
             (when (fboundp ',name)
               (fdefinition ',name))))
       (unwind-protect
            (progn
              (setf (fdefinition ',name) 
                    (lambda ,lambda-list ,@body))
              ,@forms)
         (if ,cached
             (setf (fdefinition ',name)
                   ,cached)
             (fmakunbound ',name))))))

(defmacro with-stubs (redefinitions &body forms)
  "Like WITH-STUB, but REDEFINITIONS is a list of (NAME LAMBDA-LIST
. BODY) list, suitable for defining a function."
  (loop
    with inner = `(progn ,@forms)
    for (name lambda-list . body) in (reverse redefinitions)
    do (setf inner `(with-stub (,name ,lambda-list ,@body)
                      ,inner))
    finally (return inner)))


(defmacro defun/t (name lambda-list &body body)
  "Like regular DEFUN, but with embedded unit tests. If those tests
  would fail, the function fails to be defined. "
  (destructuring-bind (tests function-body) (extract-tests name body)
    (let ((cached (gensym)))
      `(let ((,cached
               (when (fboundp ',name)
                 (fdefinition ',name))))
         (restart-case
             (eval-when (:compile-toplevel :load-toplevel :execute) 
               (progn
                 (defun ,name ,lambda-list ,@function-body)
                 ,@tests))
           (make-unbound () (fmakunbound ',name))
           (revert-to-last-good-version ()
             (if ,cached
                 (setf (symbol-function ',name)
                       ,cached)
                 (fmakunbound ',name))))))))