diff options
author | Colin Okay <okay@toyful.space> | 2021-06-29 10:29:00 -0500 |
---|---|---|
committer | Colin Okay <okay@toyful.space> | 2021-06-29 10:29:00 -0500 |
commit | 902093ad89a154b267772acc197f7f47f2eeefd4 (patch) | |
tree | 8e7be2b2b665659881f063ba707dbbe5e6402e34 /testiere.lisp |
initial commit, defun+ initial definitino
Diffstat (limited to 'testiere.lisp')
-rw-r--r-- | testiere.lisp | 88 |
1 files changed, 88 insertions, 0 deletions
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. ") + + |