ONEBOL for testing

s48/krims/AUTHORS

@@ -1 +1 @@
-Copyright (c) 2003 Rolf-Thomas Happe
+Copyright (c) 2003, 2005 Rolf-Thomas Happe

s48/krims/NEWS

@@ -1,2 +1,5 @@
+version 0.2
+* poor man's testing "framework" ONEBOL
+
 version 0.1
 * New package system.

s48/krims/README

@@ -26,6 +26,53 @@ printable list starting with a symbol.
 
                                   *
 
+structure ONEBOL -- poor man's unit testing framework (sans framework)
+
+Caution, it is really primitive (but ate not much of my time so far:
+its main raison d'etre).
+
+
+(fail msg e0 ...)                                             PROCEDURE
+
+Synopsis:  Signal a failure with message MSG and related values E0 ...
+
+
+
+(assert exp x0 ...)                                              SYNTAX
+
+Signal a failure if EXP is false, reporting both the failed assertion EXP
+(literally) and the values of X0 ...  Don't evaluate X0 ... if EXP holds
+true.
+
+
+(deny exp x0 ...)                                                SYNTAX
+
+Signal a failure if EXP is true, reporting both the failed assertion
+(NOT EXP) literally and the values of X0 ...  Don't evaluate X0 ...
+if EXP doesn't hold true.
+
+
+(should-raise condition exp)                                     SYNTAX
+(should-raise* condition thunk)                               PROCEDURE
+
+Evaluate the expression EXP resp. call the THUNK and signal a failure
+if the expression or thunk doesn't raise the CONDITION.
+
+
+(shouldnt-raise condition exp)                                  SYNTAX
+(shouldnt-raise* condition thunk)                            PROCEDURE
+
+Evaluate the expression EXP resp. call the THUNK and signal a failure
+if the expression or thunk does raise the CONDITION.
+
+
+(failure? condition)                                         PROCEDURE
+(error? condition)                                           PROCEDURE
+
+Convenience exports, also available from structure CONDITIONS.
+
+                                  *
+
 
 structure KRIMS -- Odds and Ends
 

s48/krims/onebol.scm

@@ -0,0 +1,54 @@
+(define-condition-type 'failure '(error))
+
+(define failure? (condition-predicate 'failure))
+
+(define (fail msg . irritants)
+  (apply signal 'failure msg irritants))
+
+(define (with-failure-handler* handler thunk)
+  (with-handler
+    (lambda (condition decline)
+      (if (failure? condition)
+	  (handler (condition-stuff condition))
+          (decline))
+      thunk)))
+
+
+(define-syntax assert
+  (syntax-rules ()
+    ((assert ?x ?y0 ...)
+     (if (not ?x) (fail "Assertion failed" '?x ?y0 ...))) ))
+
+(define-syntax deny
+  (syntax-rules ()
+    ((deny ?x ?y0 ...)
+     (assert (not ?x) ?y0 ...))))
+
+(define (should-raise* condition-predicate? thunk)
+  (with-handler (lambda (condition decline)
+                  (assert (condition-predicate? condition)))
+                thunk))
+
+(define (shouldnt-raise* condition-predicate? thunk)
+  (with-handler (lambda (condition decline)
+                  (deny (condition-predicate? condition))
+                  (decline))
+                thunk))
+
+(define-syntax should-raise
+  (syntax-rules ()
+    ((should-raise condition-predicate? e0 e1 ...)
+     (should-raise* condition-predicate?
+                    (lambda () e0 e1 ...)))))
+
+(define-syntax shouldnt-raise
+  (syntax-rules ()
+    ((shouldnt-raise condition-predicate? e0 e1 ...)
+     (shouldnt-raise* condition-predicate?
+                      (lambda () e0 e1 ...)))))
+
+(define-record-type :testcase
+  (make-testcase description thunk)
+  testcase?
+  (description testcase-description)
+  (thunk testcase-thunk))

s48/krims/packages.scm

@@ -38,6 +38,20 @@
 	  lset-union! lset-intersection! lset-difference! lset-xor!
 	  lset-diff+intersection!))
 
+(define-interface onebol-face
+  (export fail error
+          (assert :syntax)
+          (deny :syntax)
+          should-raise*
+          shouldnt-raise*
+          (should-raise :syntax)
+          (shouldnt-raise :syntax)
+          ;; should we export more or less condition predicates?
+          failure?
+          error?                        ; imported from conditions
+          ))
+
+
 ;; odds and ends
 (define-structure krims
   (export (assert :syntax)
@@ -69,3 +83,21 @@
 	((define-record-type type-name . stuff)
 	 (sys:define-record-type type-name type-name . stuff))))
     (define define-record-discloser sys:define-record-discloser)))
+
+
+;; open
+;; ,open handle conditions signals srfi-9
+;; open (subset handle (with-handler))
+
+(define-structure onebol onebol-face
+  (open (subset handle (with-handler))
+        conditions
+        signals
+        srfi-9
+        scheme)
+  (files onebol))
+
+;; run stuff from test.scm ,in onebol-testbed
+(define-structure onebol-testbed (export )
+  (open onebol scheme)
+  (files ))

s48/krims/pkg-def.scm

@@ -1,5 +1,5 @@
 (define-package "krims"
-  (0 1)
+  (0 2)
   ((install-lib-version (1 2 0)))
   (write-to-load-script
    `((config)
@@ -9,4 +9,6 @@
   (install-file "NEWS" 'doc)
   (install-string (COPYING) "COPYING" 'doc)
   (install-file "packages.scm" 'scheme)
-  (install-file "krims.scm" 'scheme))
+  (install-file "krims.scm" 'scheme)
+  (install-file "onebol.scm" 'scheme)
+  (install-file "test.scm" 'scheme))

s48/krims/test.scm

@@ -0,0 +1,18 @@
+;; poor man's test suite
+;; run stuff  ,in onebol-testbed
+
+(assert #t)
+
+(deny #f)
+
+(should-raise* failure? (lambda () (fail "")))
+
+(should-raise* failure? (lambda () (assert #f)))
+
+(should-raise* failure? (lambda () (deny #t)))
+
+(should-raise* (lambda (condition)
+                 (and (error? condition)
+                      (not (failure? condition))))
+               (lambda ()
+                 (shouldnt-raise* failure? (lambda () (error "")))))