From 4025722943ae814c88da1fa8fe5778cffecce4ad Mon Sep 17 00:00:00 2001
From: colin <colin@cicadas.surf>
Date: Sat, 9 Sep 2023 11:09:10 -0700
Subject: Testiere2

Add examples

changed some internal names; improved some error messages

Added more examples

renaming exports

Added New Readme
---
 testiere.lisp | 115 ----------------------------------------------------------
 1 file changed, 115 deletions(-)
 delete mode 100644 testiere.lisp

(limited to 'testiere.lisp')

diff --git a/testiere.lisp b/testiere.lisp
deleted file mode 100644
index b606b9f..0000000
--- a/testiere.lisp
+++ /dev/null
@@ -1,115 +0,0 @@
-;;;; 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))))))))
-
-
-
-
-- 
cgit v1.2.3