4 files changed, 419 insertions, 0 deletions
diff --git a/src/legacy/README.org b/src/legacy/README.org
new file mode 100644
index 0000000..755a885
--- /dev/null
+++ b/src/legacy/README.org
@@ -0,0 +1,175 @@
+A [[https://en.wiktionary.org/wiki/testiere][testiere]] is armor for the head of a horse and ~testiere~ is armor
+for the head of your ~defun~ forms.  
+
+* Testiere
+
+With ~testiere~ you can program in an interactive TDD-like
+fashion. Tests are included at the top of a ~defun/t~ form. When you
+recompile your functions interactively, the tests are run. If any
+fail, you are dropped into a debugger where you can decide to revert
+the definition to the last known working version, or you can choose to
+unbind it altogether.
+
+The system supports mocking and stubbing in your tests, so that you
+can, e.g. test the system in different dynamic contexts or by mocking
+network request functions.
+
+Here is an example:
+
+#+begin_src lisp
+
+(defun/t sum-3 (x y &key (z 10))
+  "Sums three numbers, Z has a default value of 10"
+  :tests
+  (:program some-test-function)
+  (= (1 2) 13)        ; (sum-3 1 2) == 13
+  (= (1 2 :z 3) 6)    ; (sum-3 1 2 :z 3) == 6
+  (:outputp (0 0)      ; tests that (sum-3 0 0) passes the predicate
+           (lambda (result) (= 10 result)))
+  (:fails             ; ensures that (sum-3 "strings" "ain't" :z "numbers") fails
+   ("strings" "ain't" :z "numbers"))
+  :end
+  (+ x y z))
+
+#+end_src
+
+In the above, a function ~sum-3~ is defined with five embedded
+tests. The test specification syntax is detailed below. If any of the
+tests fail, the function will not be redefined and you will drop into
+the debugger, which asks you how you'd like to proceed.
+
+The approach to TDD-like development taking by ~testiere~ may not be
+appropriate to all circumstances, but it is good for interactive
+development of interactive applications (😉) whose "main loop"
+involves a good sized collection of unit-testable functions.
+
+** Test Specification 
+
+There are a few kinds of tests available. 
+
+*** For the Impatient, Just Use =:program= Tests
+
+Most users will probably benefit from the ~:program~ style test.  Here
+is a quick example:
+
+#+begin_src lisp
+
+(defun test-fibble ()
+  (assert (= 13 (fibble 1 2))))
+
+(defun/t fibble (x y &key (z 10))
+  "Adds three numbers, one of which defaults to 10."
+  :tests
+  (:program test-fibble)
+  :end
+  (+ x y z))
+
+#+end_src
+
+In the above test, we insist that the ~test-fibble~ function not
+signal an error condition in order for ~fibble~ to be successfully
+(re)compiled.
+
+*** Basic Test Specifications
+
+A test suite is a list of forms that appear between ~:tests~ and
+~:end~ in the body of a ~defun/t~ form.  The test suite must appear
+after any optional docstring and before the function body actually
+begins.
+
+A catalog of test form specifications follows.
+
+**** Comparator Test Specifications
+
+: (comparator (&rest args...) value)
+
+The ~comparator~ should be the name of a binary predicate (like ~<~ or
+~eql~).  These tests proceed by calling ~(comparator (apply my-fun args) value)~
+If the comparison fails, an error condition is signaled. 
+
+Amending the above example, we include a comparator test:
+
+
+#+begin_src lisp
+(defun/t fibble (x y &key (z 10))
+  "Adds three numbers, one of which defaults to 10."
+  :tests
+  (:program test-fibble)
+  (= (0 0 :z 30) 30)     ; (assert (= (fibble 0 0 :z 30) 30))
+  :end
+  (+ x y z))
+
+#+end_src
+
+**** Other Test Specifications
+
+Every other form appearing in a test suite is a list that starts with
+a keyword. 
+
+- ~(:program FUNCTION-NAME ARGS...)~ runs a function named
+  FUNCTION-NAME with arguments ARGS. This function is meant to act as
+  a test suite for the function being defined with defun/t. It may
+  call that function and ASSERT things about it.
+- ~(:outputp (..ARGS...) PREDICATE)~ asserts that the output passes
+  the one-argument predicate.
+- ~(:afterp (...ARGS...) THUNK)~ asserts that the thunk should return
+  non-nil after the function has run. Good for testing values of
+  dynamic variables that the function might interact with.
+- ~(:fails (...ARGS...))~ asserts that the function will produce an
+  error with the given arguments.
+- ~(:signals (...ARGS...) CONDITION)~ where ~CONDITION~ is the name of
+  a condition. Asserts that the function will signal a condition of
+  the supplied type when called with the provided arguments.
+
+
+*** Mocking and Stubbing 
+
+The following test forms allow for the running of tests inside a
+context in which certain functions or global values are bound:
+
+Binding variables looks like
+
+: (:let LET-BINDINGS TESTS) 
+    
+and are useful for binding dynamic variables for use during a set of
+tests.
+
+For example 
+
+#+begin_src lisp
+
+    (defvar *count*)
+    
+    (defun/t increment-count ()
+      "Increments the *count* variable."
+      :tests
+      (:let ((*count* 4))
+        (:afterp () (lambda () (= *count* 5))) ; 5 after the first call
+        (= () 6)                               ; 6 after the second
+        (:outputp () (lambda (x) (= x 7))))    ; and 7 after the third
+      :end
+      (incf *count*))
+#+end_src
+    
+The ~:with-stubs~ form is similar, except that it binds temporary
+values to functions that might be called by the form in
+questions. Useful for mocking.
+
+#+begin_src lisp
+
+
+    (defun just-a-function ()
+      (print "Just a function."))
+    
+    (defun/t call-just-a-function ()
+      "Calls JUST-A-FUNCTION."
+      :tests
+      (:with-stubs ((just-a-function () (print "TEMP JUST-A-FUNCTION.")))
+        (equal () "TEMP JUST-A-FUNCTION."))
+      :end
+      (just-a-function))
+
+#+end_src
+      
+In the above, the temporary redefinition of ~JUST-A-FUNCTION~ is used.
+
diff --git a/src/legacy/package.lisp b/src/legacy/package.lisp
new file mode 100644
index 0000000..3724728
--- /dev/null
+++ b/src/legacy/package.lisp
@@ -0,0 +1,14 @@
+;;;; package.lisp
+
+(defpackage #:testiere.legacy
+  (:use #:cl)
+  (:import-from #:trivia #:match)
+  (:export #:defun/t #:with-stubs #:with-stub))
+
+
+
+
+
+
+
+
diff --git a/src/legacy/testiere.lisp b/src/legacy/testiere.lisp
new file mode 100644
index 0000000..010b12d
--- /dev/null
+++ b/src/legacy/testiere.lisp
@@ -0,0 +1,115 @@
+;;;; testiere.lisp
+
+(in-package #:testiere.legacy)
+
+(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))))))))
+
+
+
+
diff --git a/src/legacy/testiere.lisp~ b/src/legacy/testiere.lisp~
new file mode 100644
index 0000000..b606b9f
--- /dev/null
+++ b/src/legacy/testiere.lisp~
@@ -0,0 +1,115 @@
+;;;; 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))))))))
+
+
+
+