initial commit, defun+ initial definitino

4 files changed, 115 insertions, 0 deletions

diff --git a/README.md b/README.md
new file mode 100644
index 0000000..02a79ad
--- /dev/null
+++ b/README.md
@@ -0,0 +1,9 @@
+# testiere
+### _Your Name <your.name@example.com>_
+
+This is a project to do ... something.
+
+## License
+
+Specify license here
+
diff --git a/package.lisp b/package.lisp
new file mode 100644
index 0000000..145dadd
--- /dev/null
+++ b/package.lisp
@@ -0,0 +1,7 @@
+;;;; package.lisp
+
+(defpackage #:testiere
+  (:use #:cl)
+  (:import-from #:trivia #:match #:guard))
+
+
diff --git a/testiere.asd b/testiere.asd
new file mode 100644
index 0000000..8e0b682
--- /dev/null
+++ b/testiere.asd
@@ -0,0 +1,11 @@
+;;;; testiere.asd
+
+(asdf:defsystem #:testiere
+  :description "Up Front Testing for DEFUN and DEFMETHOD"
+  :author "Colin Okay <okay@toyful.space>"
+  :license  "GPLv3"
+  :version "0.0.1"
+  :depends-on (:trivia)
+  :serial t
+  :components ((:file "package")
+               (:file "testiere")))
diff --git a/testiere.lisp b/testiere.lisp
new file mode 100644
index 0000000..949e492
--- /dev/null
+++ b/testiere.lisp
@@ -0,0 +1,88 @@
+;;;; testiere.lisp
+
+(in-package #:testiere)
+
+(defun stub-names (stubs) (mapcar 'first stubs))
+
+
+(defun build-test (name spec)
+  (match spec
+    ((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)))
+        (values (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. "
+  (multiple-value-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+ plus-at-least-two (a b &rest more)
+;;   "Adds at least two numbers together"
+;;   :tests
+;;   (= (1 2 3 4) 10)
+;;   (= (0 0) 0)
+;;   (:stubs ((some-function (x y z) (print "stubbed") (list x y z)))
+;;           :before 'do-some-stuff-before-hand
+;;           :test (= (1 1) 2)
+;;           :after-with-outptu 'check-output-all-good-p)
+;;   (:fails (1))
+;;   (:throws ("foo" "bar") 'type-error)
+;;   (:after (1 1) 'all-good-after-p)
+;;   (:after-with-output (1 1) 'output-all-good-after-p)
+;;   (:setup 'do-some-stuff-before-hand
+;;    :then :test (= (1 1) 2)
+;;          :after 'all-good-after-p)
+;;   :end
+;;   (reduce '+ more :initial-value (+ a b)))
+
+ 
+
+(defmacro defmethod+ (name (&optional combination) lambda-list &body body)
+  "Like regular DEFMETHOD, but with embedded unit tests. If those
+  test would fail, the method fails to be defined. ")
+
+