;;;; testiere.lisp

(in-package #:testiere)

(defun stub-names (stubs) (mapcar 'first stubs))

(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* :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* :with-bindings 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 defun+ (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)
    `(labels ((,name ,lambda-list ,@function-body))
       (handler-case
           (progn ,@tests
                  (defun ,name ,lambda-list ,@function-body))
         (error (e)
           (format t "~a~%Not defining ~a" e ',name))))))

(defun parse-defmethod (args)
  (match args
    ((guard (list* qualifier lambda-list body)
            (and (not (listp qualifier))
                 (listp lambda-list)))
     (list (list  qualifier lambda-list) body))
    ((list* lambda-list body)
     (list (list lambda-list) body))

    (_ (error "Malformed DEFMETHOD: ~a " args))))

(defmacro defmethod+ (name &rest args)
  "Like regular DEFMETHOD, but with embedded unit tests. If those
  test would fail, the method fails to be defined. "
  (destructuring-bind (qual-and-lambda-list body) (parse-defmethod args)
    (destructuring-bind  (tests function-body) (extract-tests name body)
      `(progn
         (defmethod ,name ,@qual-and-lambda-list ,@function-body)
         ,@tests))))