diff --git a/scheme/assert.scm b/scheme/assert.scm new file mode 100644 index 00000000..99828669 --- /dev/null +++ b/scheme/assert.scm @@ -0,0 +1,58 @@ +;;; +;;; Unit test framework for Scheme +;;; Copyright (c) 2018, Peter Kofler, http://www.code-cop.org/ +;;; BSD licensed. +;;; +;;; Non S5RS used functions: +;;; * (error) from R6RS +;;; + +;; SchemeUnit from http://c2.com/cgi/wiki?SchemeUnit + +(define (fail msg) + (error (string-append "AssertionError" ": " msg))) + +(define (check msg condition) + (if (not condition) + (fail msg) + #t)) + +(define (assert msg condition) + (lambda () (check msg condition))) + +;; extensions + +;; private +(define (make-string-message prefix to-string expected actual) + (make-message prefix + (to-string expected) + (to-string actual))) + +;; private +(define (make-message prefix expected actual) + (string-append prefix "expected:<" expected "> but was:<" actual ">")) + +(define (assert-equal to-string eq-op expected actual) + (assert (make-string-message "" to-string expected actual) + (eq-op expected actual))) + +(define (assert= expected actual) + (assert-equal number->string = expected actual)) + +(define (assert-string= expected actual) + (assert-equal values string=? expected actual)) + +;; private +(define (test-case-name name) + (display name) + (display " ... ")) + +;; private +(define (test-case-success) + (display "OK") + (newline)) + +(define (test-case name . assertions) + (test-case-name name) + (for-each (lambda (a) (a)) assertions) + (test-case-success)) diff --git a/scheme/gilded-rose-test.scm b/scheme/gilded-rose-test.scm new file mode 100644 index 00000000..b0d67e09 --- /dev/null +++ b/scheme/gilded-rose-test.scm @@ -0,0 +1,7 @@ +(include "assert.scm") +(include "gilded-rose.scm") + +(test-case "foo" + (let ((items (list (make-item "foo" 0 0)))) + (update-quality items) + (assert-string= "fixme" (item-name (car items)))))