diff --git a/s48/krims/AUTHORS b/s48/krims/AUTHORS index ea94477..288277d 100644 --- a/s48/krims/AUTHORS +++ b/s48/krims/AUTHORS @@ -1 +1 @@ -Copyright (c) 2003 Rolf-Thomas Happe +Copyright (c) 2003, 2005 Rolf-Thomas Happe diff --git a/s48/krims/NEWS b/s48/krims/NEWS index f54a97c..cb5812e 100644 --- a/s48/krims/NEWS +++ b/s48/krims/NEWS @@ -1,2 +1,5 @@ +version 0.2 +* poor man's testing "framework" ONEBOL + version 0.1 * New package system. diff --git a/s48/krims/README b/s48/krims/README index 1b1c96d..ad44641 100644 --- a/s48/krims/README +++ b/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 diff --git a/s48/krims/onebol.scm b/s48/krims/onebol.scm new file mode 100644 index 0000000..7f4a913 --- /dev/null +++ b/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)) diff --git a/s48/krims/packages.scm b/s48/krims/packages.scm index 10a9672..7c023e4 100644 --- a/s48/krims/packages.scm +++ b/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 )) diff --git a/s48/krims/pkg-def.scm b/s48/krims/pkg-def.scm index 822a940..26299e6 100644 --- a/s48/krims/pkg-def.scm +++ b/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)) diff --git a/s48/krims/test.scm b/s48/krims/test.scm new file mode 100644 index 0000000..230e81f --- /dev/null +++ b/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 "")))))