suzanne.soy/rackunit
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial import of SchemeUnit into PLT trunk

Browse Source 
svn: r14263

original commit: 242c28a0b6cb88dfd908bc6751815a25ae4e97fe
This commit is contained in:
Noel Welsh 2009-03-25 12:34:52 +00:00
commit e2dfd04199
48 changed files with 4576 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
collects/schemeunit/all-schemeunit-tests.ss Normal file
View File

@ -0,0 +1,54 @@
#lang scheme/base
(require "main.ss"
"check-test.ss"
"check-info-test.ss"
"format-test.ss"
"test-case-test.ss"
"test-suite-test.ss"
"base-test.ss"
"location-test.ss"
"result-test.ss"
"test-test.ss"
"util-test.ss"
"text-ui-test.ss"
"monad-test.ss"
"hash-monad-test.ss"
"counter-test.ss"
"text-ui-util-test.ss"
)
(provide all-schemeunit-tests
success-and-failure-tests)
(define all-schemeunit-tests
(test-suite
"All SchemeUnit Tests"
check-tests
base-tests
check-info-tests
test-case-tests
test-suite-tests
test-suite-define-provide-test
location-tests
result-tests
test-tests
util-tests
text-ui-tests
monad-tests
hash-monad-tests
counter-tests
text-ui-util-tests
format-tests
))
(define success-and-failure-tests
(test-suite
"Successes and Failures"
all-schemeunit-tests
(test-case "Intended to fail" (fail))
(test-case "Also intended to fail" (check-eq? 'apples 'orange))
(test-equal? "Yet again intended to fail" "apples" "oranges")
(test-case "Intended to throw error" (error 'testing "<<This is an error message>>"))
))

84
collects/schemeunit/base-test.ss Normal file
View File

@ -0,0 +1,84 @@
;;;
;;; Time-stamp: <2008-06-19 21:03:50 noel>
;;;
;;; Copyright (C) 2005 by Noel Welsh.
;;;
;;; This library is free software; you can redistribute it
;;; and/or modify it under the terms of the GNU Lesser
;;; General Public License as published by the Free Software
;;; Foundation; either version 2.1 of the License, or (at
;;; your option) any later version.
;;; This library is distributed in the hope that it will be
;;; useful, but WITHOUT ANY WARRANTY; without even the
;;; implied warranty of MERCHANTABILITY or FITNESS FOR A
;;; PARTICULAR PURPOSE. See the GNU Lesser General Public
;;; License for more details.
;;; You should have received a copy of the GNU Lesser
;;; General Public License along with this library; if not,
;;; write to the Free Software Foundation, Inc., 59 Temple
;;; Place, Suite 330, Boston, MA 02111-1307 USA
;;; Author: Noel Welsh <noelwelsh@yahoo.com>
;;
;;
;; Commentary:
#lang scheme/base
(require "test.ss")
(require "base.ss")
(provide base-tests)
(define base-tests
(test-suite
"All tests for base"
(test-case
"schemeunit-test-case structure has a contract on name"
(check-exn exn:fail?
(lambda ()
(make-schemeunit-test-case
'foo
(lambda () #t)))))
(test-case
"schemeunit-test-case structure has a contract on action"
(check-exn exn:fail?
(lambda ()
(make-schemeunit-test-case
"Name"
#f))))
(test-case
"schemeunit-test-suite has a contract on its fields"
(check-exn exn:fail?
(lambda ()
(make-schemeunit-test-suite
#f
(list)
(lambda () 3)
(lambda () 2))))
(check-exn exn:fail?
(lambda ()
(make-schemeunit-test-suite
"Name"
#f
(lambda () 3)
(lambda () 2))))
(check-exn exn:fail?
(lambda ()
(make-schemeunit-test-suite
"Name"
(list)
#f
(lambda () 2))))
(check-exn exn:fail?
(lambda ()
(make-schemeunit-test-suite
"Name"
(list)
(lambda () 3)
#f))))
))

52
collects/schemeunit/base.ss Normal file
View File

@ -0,0 +1,52 @@
#lang scheme/base
(require scheme/contract)
;; struct test :
(define-struct test ())
;; struct (schemeunit-test-case test) : (U string #f) thunk
(define-struct (schemeunit-test-case test) (name action) #:transparent)
;; struct (schemeunit-test-suite test) : string (fdown fup fhere seed -> (listof test-result)) thunk thunk
(define-struct (schemeunit-test-suite test) (name tests before after) #:transparent)
;; struct exn:test exn : ()
;;
;; The exception throw by test failures
(define-struct (exn:test exn) ())
;; struct (exn:test:check struct:exn:test) : (list-of check-info)
;;
;; The exception thrown to indicate a check has failed
(define-struct (exn:test:check exn:test) (stack))
;; struct (exn:test:check:internal exn:test:check) : ()
;;
;; Exception thrown to indicate an internal failure in an
;; check, distinguished from a failure in user code.
(define-struct (exn:test:check:internal exn:test:check) ())
;; struct test-result : (U string #f)
(define-struct test-result (test-case-name))
;; struct (test-failure test-result) : exn:test
(define-struct (test-failure test-result) (result))
;; struct (test-error test-result) : any
(define-struct (test-error test-result) (result))
;; struct (test-success test-result) : any
(define-struct (test-success test-result) (result))
(provide/contract
(struct (schemeunit-test-case test)
((name (or/c string? false/c))
(action (-> any))))
(struct (schemeunit-test-suite test)
((name string?)
(tests procedure?)
(before (-> any))
(after (-> any)))))
(provide (struct-out test)
(struct-out exn:test)
(struct-out exn:test:check)
(struct-out exn:test:check:internal)
(struct-out test-result)
(struct-out test-failure)
(struct-out test-error)
(struct-out test-success))

80
collects/schemeunit/check-info-test.ss Normal file
View File

@ -0,0 +1,80 @@
;;;
;;; <check-util-test.ss> ---- Tests for check-util
;;; Time-stamp: <2008-06-19 21:04:14 noel>
;;;
;;; Copyright (C) 2003 by Noel Welsh.
;;;
;;; This file is part of SchemeUnit.
;;; SchemeUnit is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
;;; License as published by the Free Software Foundation; either
;;; version 2.1 of the License, or (at your option) any later version.
;;; SchemeUnitis distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details.
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with SchemeUnit; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;; Author: Noel Welsh <noelwelsh@yahoo.com>
;;
;;
;; Commentary:
#lang scheme/base
(require "test.ss"
"check-info.ss")
(provide check-info-tests)
(define check-info-tests
(test-suite "All check-info tests"
(test-case
"with-check-info stores value in lexical order"
(let ((stack (with-check-info
(('1 1)
('2 2)
('3 3))
(check-info-stack))))
(for-each (lambda (actual expected)
(check-eq? (check-info-name actual)
expected))
stack
(list '1 '2 '3))))
(test-case
"Nested uses of with-check-info store values in lexical order"
(let ((stack (with-check-info
(('1 1)
('2 2)
('3 3))
(with-check-info
(('4 4)
('5 5)
('6 6))
(check-info-stack)))))
(for-each (lambda (actual expected)
(check-eq? (check-info-name actual)
expected))
stack
(list '1 '2 '3 '4 '5 '6))))
(test-case
"check-actual? and check-expected? work"
(check-true (check-actual? (make-check-actual 1)))
(check-true (check-expected? (make-check-expected 1)))
(check-false (check-expected? (make-check-actual 1)))
(check-false (check-expected? (make-check-actual 1))))
(test-case
"make-check-actual and make-check-expected store param"
(check-equal? (check-info-value (make-check-actual 1)) 1)
(check-equal? (check-info-value (make-check-expected 2)) 2))
))

65
collects/schemeunit/check-info.ss Normal file
View File

@ -0,0 +1,65 @@
#lang scheme/base
(provide (all-defined-out))
;; Structures --------------------------------------------------
;; struct check-info : symbol any
(define-struct check-info (name value))
;; Infrastructure ----------------------------------------------
;; parameter check-info-stack : (listof check-info)
(define check-info-stack
(make-parameter
(list)
(lambda (v)
(if (list? v)
v
(raise-type-error 'check-info-stack "list" v)))))
;; with-check-info* : (list-of check-info) thunk -> any
(define (with-check-info* info thunk)
(parameterize
((check-info-stack (append (check-info-stack) info)))
(thunk)))
(define-syntax with-check-info
(syntax-rules ()
((_ ((name val) ...) body ...)
(with-check-info*
(list (make-check-info name val) ...)
(lambda ()
body ...)))))
(define (make-check-name name)
(make-check-info 'name name))
(define (make-check-params params)
(make-check-info 'params params))
(define (make-check-location stx)
(make-check-info 'location stx))
(define (make-check-expression msg)
(make-check-info 'expression msg))
(define (make-check-message msg)
(make-check-info 'message msg))
(define (make-check-actual param)
(make-check-info 'actual param))
(define (make-check-expected param)
(make-check-info 'expected param))
(define (check-name? info)
(eq? (check-info-name info) 'name))
(define (check-params? info)
(eq? (check-info-name info) 'params))
(define (check-location? info)
(eq? (check-info-name info) 'location))
(define (check-expression? info)
(eq? (check-info-name info) 'expression))
(define (check-message? info)
(eq? (check-info-name info) 'message))
(define (check-actual? info)
(eq? (check-info-name info) 'actual))
(define (check-expected? info)
(eq? (check-info-name info) 'expected))

323
collects/schemeunit/check-test.ss Normal file
View File

@ -0,0 +1,323 @@
;;;
;;; Time-stamp: <2009-03-25 12:32:55 noel>
;;;
;;; Copyright (C) by Noel Welsh.
;;;
;;; This library is free software; you can redistribute it
;;; and/or modify it under the terms of the GNU Lesser
;;; General Public License as published by the Free Software
;;; Foundation; either version 2.1 of the License, or (at
;;; your option) any later version.
;;; This library is distributed in the hope that it will be
;;; useful, but WITHOUT ANY WARRANTY; without even the
;;; implied warranty of MERCHANTABILITY or FITNESS FOR A
;;; PARTICULAR PURPOSE. See the GNU Lesser General Public
;;; License for more details.
;;; You should have received a copy of the GNU Lesser
;;; General Public License along with this library; if not,
;;; write to the Free Software Foundation, Inc., 59 Temple
;;; Place, Suite 330, Boston, MA 02111-1307 USA
;;; Author: Noel Welsh <noelwelsh@yahoo.com>
;;
;;
;; Commentary:
#lang scheme/base
(require
(lib "list.ss" "srfi" "1")
(file "check.ss")
(file "result.ss")
(file "test.ss")
(file "test-suite.ss"))
(provide check-tests)
(define (make-failure-test name pred . args)
(test-case
name
(check-exn exn:test:check?
(lambda ()
(apply pred args)))))
(define-check (good)
#t)
(define-check (bad)
(fail-check))
(define check-tests
(test-suite
"Check tests"
;; Successes
(test-case "Simple check-equal? test"
(check-equal? 1 1))
(test-case "Simple check-eq? test"
(check-eq? 'a 'a))
(test-case "Simple check-eqv? test"
(check-eqv? 'a 'a))
(test-case "Simple check test"
(check string=? "hello" "hello"))
(test-case "Simple check-true test"
(check-true (eq? 'a 'a)))
(test-case "Simple check-pred test"
(check-pred null? (list)))
(test-case "Simple check-exn test"
(check-exn exn:test:check?
(lambda ()
(check = 1 2))))
(test-case "Simple check-not-exn test"
(check-not-exn
(lambda ()
(check = 1 1))))
(test-case "Simple check-not-eq?"
(check-not-eq? (cons 'a 'a) (cons 'a 'a)))
(test-case "Simple check-not-equal?"
(check-not-equal? 1 2))
(test-case "Defined check succeeds"
(good))
(test-case "Simple check-not-false test"
(check-not-false 3))
(test-case "Simple check-= test"
(check-= 1.0 1.0 0.0001))
(test-case "Use of check as expression"
(for-each check-false '(#f #f #f)))
(test-case "Use of local check as expression"
(let ()
(define-simple-check (check-symbol? x)
(symbol? x))
(for-each check-symbol? '(a b c))))
;; Failures
(make-failure-test "check-equal? failure"
check-equal? 1 2)
(make-failure-test "check-eq? failure"
check-eq? 'a 'b)
(make-failure-test "check-eqv? failure"
check-eqv? 'a 'b)
(make-failure-test "check failure"
check string=? "hello" "bye")
(make-failure-test "check-true failure"
check-true (eq? 'a 'b))
(make-failure-test "check-pred failure"
check-pred null? (list 1 2 3))
(make-failure-test "check-exn failure"
check-exn exn:test:check? (lambda () (check = 1 1)))
(make-failure-test "check-exn wrong exception"
check-exn exn:fail:contract:arity? (lambda () (+ 1 2)))
(make-failure-test "check-not-exn"
check-not-exn (lambda () (/ 1 0)))
(make-failure-test "fail with message failure"
fail "With message")
(make-failure-test "fail without message failure"
fail)
(make-failure-test "Defined check fails"
bad)
(make-failure-test "check-not-false failure"
check-not-false #f)
(make-failure-test "check-= failure"
check-= 1.0 2.0 0.0)
(test-case "check-= allows differences within epsilon"
(check-= 1.0 1.09 1.1))
(make-failure-test "check-= failure > epsilon"
check-= 1 12/10 1/10)
(test-case "check-as-expression failure"
(check-exn exn:test:check?
(lambda ()
(for-each check-false '(#f not-false)))))
(test-case
"Check allows optional message"
(begin
(check = 1 1 "message")))
;; Some necessary semantics
(test-case
"Check macro parameters evaluated once (simple-check)"
(let ((counter 0))
(check-true (begin (set! counter (add1 counter))
#t))
(check = counter 1)))
(test-case
"Check macro parameters evaluated once (binary-check)"
(let ((counter 0))
(check-equal? (begin (set! counter (add1 counter))
1)
(begin (set! counter (add1 counter))
1))
(check = counter 2)))
(test-case
"Check function parameters evaluated once (simple-check)"
(let ((counter 0))
(check-true (begin (set! counter (add1 counter))
#t))
(check = counter 1)))
(test-case
"Check function parameters evaluated once (binary-check)"
(let ((counter 0))
(check-equal? (begin (set! counter (add1 counter))
1)
(begin (set! counter (add1 counter))
1))
(check = counter 2)))
;; Exceptions have the correct types
(test-case
"Macro w/ no message, message is a string"
(let ((exn (with-handlers ([exn? (lambda (exn)
exn)])
(check-true #f))))
(check-pred string? (exn-message exn))))
(test-case
"Function w/ no message, message is a string"
(let ((exn (with-handlers ([exn? (lambda (exn)
exn)])
(check-true #f))))
(check-pred string? (exn-message exn))))
;; The check construction language
(test-case
"with-check-info* captures information"
(let ((name (make-check-info 'name "name"))
(info (make-check-info 'info "info")))
(with-handlers
[(exn:test:check?
(lambda (exn)
(let ((stack (exn:test:check-stack exn)))
(check = (length stack) 2)
(let ((actual-name (first stack))
(actual-info (second stack)))
(check-equal? name actual-name)
(check-equal? info actual-info)))))]
(with-check-info*
(list name info)
(lambda ()
(fail-check))))))
(test-case
"with-check-info captures information"
(with-handlers
[(exn:test:check?
(lambda (exn)
(let ((stack (exn:test:check-stack exn)))
(check = (length stack) 2)
(let ((name (first stack))
(info (second stack)))
(check-eq? (check-info-name name) 'name)
(check string=? (check-info-value name) "name")
(check-eq? (check-info-name info) 'info)
(check string=? (check-info-value info) "info")))))]
(with-check-info
(('name "name") ('info "info"))
(fail-check))))
(test-case
"check information stack unwinds"
(with-handlers
[(exn:test:check?
(lambda (exn)
(let ((stack (exn:test:check-stack exn)))
(check = (length stack) 2)
(let ((name (first stack))
(info (second stack)))
(check-eq? (check-info-name name) 'name)
(check string=? (check-info-value name) "name")
(check-eq? (check-info-name info) 'info)
(check string=? (check-info-value info) "info")))))]
(with-check-info
(('name "name") ('info "info"))
(with-check-info
(('name "name") ('info "info"))
#t)
(fail-check))))
;; If check-exn isn't working correctly many tests above will
;; silently fail. Here we test check-exn is working.
(test-case
"check-exn traps exception"
(with-handlers
((exn?
(lambda (exn) (fail "Received exception"))))
(check-exn exn:fail:contract:arity?
(lambda () (= 1)))))
(test-case
"check-exn fails if no exception raised"
(with-handlers
((exn:test:check?
(lambda (exn) #t))
(exn:fail:contract:arity?
(lambda (exn) (fail "check-exn didn't fail"))))
(check-exn exn? (lambda () (= 1 1)))
(= 1)))
(test-case
"check-not-exn captures exception information if one raised"
(let* ([case (delay-test
(test-case "check-not-exn"
(check-not-exn
(lambda () (error "Oh dear!")))))]
[result (test-failure-result (car (run-test case)))]
[names (map check-info-name
(exn:test:check-stack result))])
(check-true
(fold (lambda (name found?)
(if (eq? name 'exception)
#t
found?))
#f names))
(check-true
(fold (lambda (name found?)
(if (eq? name 'exception-message)
#t
found?))
#f names))))
;; Regression test
;; Uses of check (and derived forms) used to be un-compilable!
;; We check that (write (compile --code-using-check--)) works.
;; That involves some namespace hacking.
(test-case
"Checks are compilable"
(let ((destns (make-base-namespace))
(cns (current-namespace)))
(parameterize ((current-namespace destns))
(namespace-require '(for-syntax scheme/base))
(namespace-require '(file "check.ss"))
;; First check that the right check macro got
;; used: ie that it didn't just compile the thing
;; as an application.
(let ((ecode
(syntax->datum (expand '(check = 1 2)))))
(check-false (and (pair? ecode)
(eq? (car ecode) '#%app)
(pair? (cdr ecode))
(equal? (cadr ecode)
'(#%top . check)))))
;; Then check to make sure that the compiled code
;; is writable
(let ((stx-string "(check = 1 2)"))
(write (compile (read-syntax
(string->path "file")
(open-input-string stx-string)))
(open-output-string))))))
;; Check evaluation contexts
(test-case
"current-check-around is used by checks"
(check-eq? (parameterize ([current-check-around (lambda (t) 'foo)])
(check-eq? 'a 'b))
'foo))
(test-case
"current-check-handler is used by checks"
(check-eq? (parameterize ([current-check-handler (lambda (e) 'foo)])
(check-eq? 'a 'b))
'foo))
))

269
collects/schemeunit/check.ss Normal file
View File

@ -0,0 +1,269 @@
#lang scheme/base
(require (for-syntax scheme/base
"location.ss"))
(require srfi/1)
(require "base.ss"
"check-info.ss"
"format.ss"
"location.ss")
(provide current-check-handler
check-around
current-check-around
fail-check
define-check
define-binary-check
define-simple-check
check
check-exn
check-not-exn
check-true
check-false
check-pred
check-eq?
check-eqv?
check-equal?
check-=
check-not-false
check-not-eq?
check-not-equal?
fail)
;; parameter current-check-handler : (-> exn any)
(define current-check-handler
(make-parameter
(lambda (e)
(cond
[(exn:test:check? e)
(display-delimiter)
(display-failure)(newline)
(display-check-info-stack
(exn:test:check-stack e))
(display-delimiter)]
[(exn? e)
(display-delimiter)
(display-error)(newline)
(display-exn e)
(display-delimiter)]))
(lambda (v)
(if (procedure? v)
v
(raise-type-error 'current-check-handler "procedure" v)))))
;; check-around : ( -> a) -> a
(define check-around
(lambda (thunk)
(with-handlers
([exn? (current-check-handler)])
(thunk))))
;; parameter current-check-around : (( -> a) -> a)
(define current-check-around
(make-parameter
check-around
(lambda (v)
(if (procedure? v)
v
(raise-type-error 'current-check-around "procedure" v)))))
(define-syntax fail-check
(syntax-rules ()
((_)
(raise
(make-exn:test:check
"Check failure"
(current-continuation-marks)
(check-info-stack))))))
(define-syntax fail-internal
(syntax-rules ()
((_)
(raise
(make-exn:test:check:internal
"Internal failure"
(current-continuation-marks)
(check-info-stack))))))
;; refail-check : exn:test:check -> (exception raised)
;;
;; Raises an exn:test:check with the contents of the
;; given parameter. Useful for propogating internal
;; errors to the outside world.
(define (refail-check exn)
(raise
(make-exn:test:check "Check failure"
(exn-continuation-marks exn)
(exn:test:check-stack exn))))
(define-syntax (define-check stx)
(syntax-case stx ()
((define-check (name formal ...) expr ...)
(with-syntax ([reported-name
(symbol->string
(syntax->datum (syntax name)))]
[(actual ...)
(datum->syntax
stx
(map gensym
(syntax->datum (syntax (formal ...)))))]
[check-fn
(syntax
(lambda (formal ...
[message #f]
#:location [location 'unknown]
#:expression [expression 'unknown])
((current-check-around)
(lambda ()
(with-check-info*
(list* (make-check-name (quote name))
(make-check-location location)
(make-check-expression expression)
(make-check-params (list formal ...))
(if message
(list (make-check-message message))
null))
(lambda () (begin expr ...)))))))]
[check-secret-name (datum->syntax stx (gensym (syntax->datum (syntax name))))])
(syntax/loc stx
(begin
;; The distinction between formal and actual parameters
;; is made to avoid evaluating the check arguments
;; more than once. This technique is based on advice
;; received from Ryan Culpepper.
(define check-secret-name check-fn)
(define-syntax (name stx)
(with-syntax
([loc (syntax->location stx)])
(syntax-case stx ()
((name actual ...)
(syntax/loc stx
(check-secret-name actual ...
#:location (quote loc)
#:expression (quote (name actual ...)))))
((name actual ... msg)
(syntax/loc stx
(check-secret-name actual ... msg
#:location (quote loc)
#:expression (quote (name actual ...)))))
(name
(identifier? #'name)
(syntax/loc stx
check-secret-name)))))
))))))
(define-syntax define-simple-check
(syntax-rules ()
((_ (name param ...) expr ...)
(define-check (name param ...)
(let ((result (begin expr ...)))
(if result
result
(fail-check)))))))
(define-syntax define-binary-check
(syntax-rules ()
((_ (name expr1 expr2) expr ...)
(define-check (name expr1 expr2)
(with-check-info*
(list (make-check-actual expr1)
(make-check-expected expr2))
(lambda ()
(let ((result (begin expr ...)))
(if result
result
(fail-check)))))))
((_ (name pred expr1 expr2))
(define-check (name expr1 expr2)
(with-check-info*
(list (make-check-actual expr1)
(make-check-expected expr2))
(lambda ()
(if (pred expr1 expr2)
#t
(fail-check))))))))
(define-check (check-exn pred thunk)
(let/ec succeed
(with-handlers
(;; catch the exception we are looking for and
;; succeed
[pred
(lambda (exn) (succeed #t))]
;; rethrow check failures if we aren't looking
;; for them
[exn:test:check?
(lambda (exn)
(refail-check exn))]
;; catch any other exception and raise an check
;; failure
[exn:fail?
(lambda (exn)
(with-check-info*
(list
(make-check-message "Wrong exception raised")
(make-check-info 'exn-message (exn-message exn))
(make-check-info 'exn exn))
(lambda () (fail-check))))])
(thunk))
(with-check-info*
(list (make-check-message "No exception raised"))
(lambda () (fail-check)))))
(define-check (check-not-exn thunk)
(with-handlers
([exn:test:check?
(lambda (exn) (refail-check exn))]
[exn?
(lambda (exn)
(with-check-info*
(list
(make-check-message "Exception raised")
(make-check-info 'exception-message (exn-message exn))
(make-check-info 'exception exn))
(lambda () (fail-check))))])
(thunk)))
(define-simple-check (check operator expr1 expr2)
(operator expr1 expr2))
(define-simple-check (check-pred predicate expr)
(predicate expr))
(define-binary-check (check-eq? eq? expr1 expr2))
(define-binary-check (check-eqv? eqv? expr1 expr2))
(define-binary-check (check-equal? expr1 expr2)
(equal? expr1 expr2))
(define-simple-check (check-= expr1 expr2 epsilon)
(<= (abs (- expr1 expr2)) epsilon))
(define-simple-check (check-true expr)
(eq? expr #t))
(define-simple-check (check-false expr)
(eq? expr #f))
(define-simple-check (check-not-false expr)
expr)
(define-simple-check (check-not-eq? expr1 expr2)
(not (eq? expr1 expr2)))
(define-simple-check (check-not-equal? expr1 expr2)
(not (equal? expr1 expr2)))
(define-simple-check (fail)
#f)

61
collects/schemeunit/counter-test.ss Normal file
View File

@ -0,0 +1,61 @@
;;;
;;; Time-stamp: <2008-06-19 21:05:15 noel>
;;;
;;; Copyright (C) 2005 by Noel Welsh.
;;;
;;; This library is free software; you can redistribute it
;;; and/or modify it under the terms of the GNU Lesser
;;; General Public License as published by the Free Software
;;; Foundation; either version 2.1 of the License, or (at
;;; your option) any later version.
;;; This library is distributed in the hope that it will be
;;; useful, but WITHOUT ANY WARRANTY; without even the
;;; implied warranty of MERCHANTABILITY or FITNESS FOR A
;;; PARTICULAR PURPOSE. See the GNU Lesser General Public
;;; License for more details.
;;; You should have received a copy of the GNU Lesser
;;; General Public License along with this library; if not,
;;; write to the Free Software Foundation, Inc., 59 Temple
;;; Place, Suite 330, Boston, MA 02111-1307 USA
;;; Author: Noel Welsh <noelwelsh@yahoo.com>
;;
;;
;; Commentary:
#lang scheme/base
(require (lib "plt-match.ss")
"test.ss")
(require "counter.ss"
"monad.ss"
"hash-monad.ss")
(provide counter-tests)
(define a-success (make-test-success "success" #t))
(define an-error (make-test-error "error" #f))
(define a-failure (make-test-failure "failure" #f))
(define counter-tests
(test-suite
"All tests for counter"
(test-case
"counter->vector is correct"
(let ((monad ((put-initial-counter) (make-empty-hash))))
((compose
(sequence* (update-counter! a-success)
(update-counter! a-failure)
(update-counter! an-error)
(counter->vector))
(match-lambda
((vector s f e)
(check = s 1)
(check = f 1)
(check = e 1)
(return-hash (void)))))
monad)))
))

96
collects/schemeunit/counter.ss Normal file
View File

@ -0,0 +1,96 @@
;;;
;;; Time-stamp: <2008-06-19 21:14:02 noel>
;;;
;;; Copyright (C) 2005 by Noel Welsh.
;;;
;;; This library is free software; you can redistribute it
;;; and/or modify it under the terms of the GNU Lesser
;;; General Public License as published by the Free Software
;;; Foundation; either version 2.1 of the License, or (at
;;; your option) any later version.
;;; This library is distributed in the hope that it will be
;;; useful, but WITHOUT ANY WARRANTY; without even the
;;; implied warranty of MERCHANTABILITY or FITNESS FOR A
;;; PARTICULAR PURPOSE. See the GNU Lesser General Public
;;; License for more details.
;;; You should have received a copy of the GNU Lesser
;;; General Public License along with this library; if not,
;;; write to the Free Software Foundation, Inc., 59 Temple
;;; Place, Suite 330, Boston, MA 02111-1307 USA
;;; Author: Noel Welsh <noelwelsh@yahoo.com>
;;
;;
;; Commentary:
#lang scheme/base
(require
(file "base.ss")
(file "monad.ss")
(file "hash-monad.ss"))
(provide display-counter
update-counter!
put-initial-counter
counter->vector)
(define key (gensym))
;; struct counter : integer integer integer
(define-struct counter (successes failures errors) #:mutable)
;; display-counter : () -> (hash-monad-of ())
(define (display-counter)
(compose
(get key)
(lambda (counter)
(let ((s (counter-successes counter))
(f (counter-failures counter))
(e (counter-errors counter)))
(display s) (display " success(es) ")
(display f) (display " failure(s) ")
(display e) (display " error(s) ")
(display (+ s f e)) (display " test(s) run")
(newline)
(return-hash (void))))))
;; counter->vector : () -> (hash-monad-of vector)
(define (counter->vector)
(compose
(get key)
(lambda (counter)
(return-hash
(vector (counter-successes counter)
(counter-failures counter)
(counter-errors counter))))))
;; update-counter! : test-result -> (hash-monad-of ())
(define (update-counter! result)
(define (add-success! counter)
(set-counter-successes! counter
(add1 (counter-successes counter))))
(define (add-failure! counter)
(set-counter-failures! counter
(add1 (counter-failures counter))))
(define (add-error! counter)
(set-counter-errors! counter
(add1 (counter-errors counter))))
(compose
(get key)
(lambda (counter)
(cond
((test-error? result)
(add-error! counter))
((test-failure? result)
(add-failure! counter))
(else
(add-success! counter)))
(put key counter))))
;; put-initial-counter : () -> (hash-monad-of ())
(define (put-initial-counter)
(put key (make-counter 0 0 0)))

24
collects/schemeunit/format-test.ss Normal file
View File

@ -0,0 +1,24 @@
#lang scheme/base
(require (file "test.ss")
(file "check-info.ss")
(file "format.ss"))
(provide format-tests)
(define format-tests
(test-suite
"All tests for format"
(test-case
"display-check-info-stack"
(let ([p (open-output-string)])
(parameterize ([current-output-port p])
(check string=?
(begin (display-check-info-stack
(list (make-check-name "foo")
(make-check-actual 1)
(make-check-expected 2)))
(get-output-string p))
"name: \"foo\"\nactual: 1\nexpected: 2\n\n"))))
))

70
collects/schemeunit/format.ss Normal file
View File

@ -0,0 +1,70 @@
#lang scheme/base
(require scheme/match
srfi/13)
(require "check-info.ss")
(provide
display-check-info-name-value
display-check-info
display-check-info-stack
display-test-name
display-exn
display-delimiter
display-failure
display-error)
;; name-width : integer
;;
;; Number of characters we reserve for the check-info name column
(define name-width 12)
(define (display-delimiter)
(display "--------------------") (newline))
(define (display-failure)
(display "FAILURE"))
(define (display-error)
(display "ERROR"))
(define (display-check-info-name-value name value [value-printer write])
(display (string-pad-right
(string-append (symbol->string name) ": ")
name-width))
(value-printer value)
(newline))
(define display-check-info
(match-lambda [(struct check-info (name value))
(display-check-info-name-value name value)]))
;; display-check-info-stack : (listof check-info) -> void
(define (display-check-info-stack check-info-stack)
(for-each
display-check-info
check-info-stack)
(newline))
;; display-test-name : (U string #f) -> void
(define (display-test-name name)
(if name
(begin
(display name) (newline))
(begin
(display "Unnamed test ")(newline))))
;; display-exn : exn -> void
;;
;; Outputs a printed representation of the exception to
;; the current-output-port
(define (display-exn exn)
(let ([op (open-output-string)])
(parameterize ([current-error-port op])
((error-display-handler)
(exn-message exn)
exn))
(display (get-output-string op))
(newline)))

80
collects/schemeunit/hash-monad-test.ss Normal file
View File

@ -0,0 +1,80 @@
;;;
;;; Time-stamp: <2008-06-19 21:06:21 noel>
;;;
;;; Copyright (C) 2005 by Noel Welsh.
;;;
;;; This library is free software; you can redistribute it
;;; and/or modify it under the terms of the GNU Lesser
;;; General Public License as published by the Free Software
;;; Foundation; either version 2.1 of the License, or (at
;;; your option) any later version.
;;; This library is distributed in the hope that it will be
;;; useful, but WITHOUT ANY WARRANTY; without even the
;;; implied warranty of MERCHANTABILITY or FITNESS FOR A
;;; PARTICULAR PURPOSE. See the GNU Lesser General Public
;;; License for more details.
;;; You should have received a copy of the GNU Lesser
;;; General Public License along with this library; if not,
;;; write to the Free Software Foundation, Inc., 59 Temple
;;; Place, Suite 330, Boston, MA 02111-1307 USA
;;; Author: Noel Welsh <noelwelsh@yahoo.com>
;;
;;
;; Commentary:
#lang scheme/base
(require "test.ss")
(require "monad.ss"
"hash-monad.ss")
(provide hash-monad-tests)
(define hash-monad-tests
(test-suite
"All tests for hash-monad"
(test-case
"Gets retrieves puts"
((compose*
(put 'foo 10)
(lambda (v)
(get 'foo))
(lambda (v)
(check = v 10)
(return-hash #t)))
(make-empty-hash)))
(test-case
"Get raises exception when no value exists"
(check-exn
exn:fail:contract?
(lambda ()
((compose
(get 'foo)
(lambda (v)
(fail "Should not be executed")))
(make-empty-hash)))))
(test-case
"Put overwrites existing entries"
((compose*
(put 'foo 10)
(lambda (v)
(get 'foo))
(lambda (v)
(check = v 10)
(put 'foo 20))
(lambda (v)
(get 'foo))
(lambda (v)
(check = v 20)
(get 'foo)))
(make-empty-hash)))
))

53
collects/schemeunit/hash-monad.ss Normal file
View File

@ -0,0 +1,53 @@
;;;
;;; Time-stamp: <2008-06-19 21:13:49 noel>
;;;
;;; Copyright (C) 2005 by Noel Welsh.
;;;
;;; This library is free software; you can redistribute it
;;; and/or modify it under the terms of the GNU Lesser
;;; General Public License as published by the Free Software
;;; Foundation; either version 2.1 of the License, or (at
;;; your option) any later version.
;;; This library is distributed in the hope that it will be
;;; useful, but WITHOUT ANY WARRANTY; without even the
;;; implied warranty of MERCHANTABILITY or FITNESS FOR A
;;; PARTICULAR PURPOSE. See the GNU Lesser General Public
;;; License for more details.
;;; You should have received a copy of the GNU Lesser
;;; General Public License along with this library; if not,
;;; write to the Free Software Foundation, Inc., 59 Temple
;;; Place, Suite 330, Boston, MA 02111-1307 USA
;;; Author: Noel Welsh <noelwelsh@yahoo.com>
;;
;;
;; Commentary:
#lang scheme/base
(require "monad.ss")
(provide (all-defined-out))
(define (make-empty-hash)
(make-monad (void) (make-hash)))
(define (return-hash value)
(lambda (hash)
(set-monad-value! hash value)
hash))
(define (put key val)
(lambda (hash)
(hash-set! (monad-state hash) key val)
hash))
(define (get key)
(lambda (hash)
(let ((val (hash-ref (monad-state hash) key)))
(set-monad-value! hash val)
hash)))

97
collects/schemeunit/location-test.ss Normal file
View File

@ -0,0 +1,97 @@
;;;
;;; Time-stamp: <2008-07-28 11:14:22 nhw>
;;;
;;; Copyright (C) 2005 by Noel Welsh.
;;;
;;; This library is free software; you can redistribute it
;;; and/or modify it under the terms of the GNU Lesser
;;; General Public License as published by the Free Software
;;; Foundation; either version 2.1 of the License, or (at
;;; your option) any later version.
;;; This library is distributed in the hope that it will be
;;; useful, but WITHOUT ANY WARRANTY; without even the
;;; implied warranty of MERCHANTABILITY or FITNESS FOR A
;;; PARTICULAR PURPOSE. See the GNU Lesser General Public
;;; License for more details.
;;; You should have received a copy of the GNU Lesser
;;; General Public License along with this library; if not,
;;; write to the Free Software Foundation, Inc., 59 Temple
;;; Place, Suite 330, Boston, MA 02111-1307 USA
;;; Author: Noel Welsh <noelwelsh@yahoo.com>
;;
;;
;; Commentary:
#lang scheme/base
(require "test.ss"
"location.ss")
(provide location-tests)
(define (read-syntax/lang name port)
(parameterize ([read-accept-reader #t])
(read-syntax name port)))
(define location-tests
(test-suite
"All tests for location"
(test-case
"syntax->location ok"
(around
(with-output-to-file "test-file.ss"
(lambda () (display "#lang scheme\n'foo\n")))
(let* ([stx (read-syntax/lang (string->path "test-file.ss")
(open-input-file "test-file.ss"))]
[rep (syntax->location stx)])
(check-equal? (location-source rep)
(syntax-source stx))
(check-equal? (location-position rep)
(syntax-position stx))
(check-equal? (location-span rep)
(syntax-span stx)))
(delete-file "test-file.ss")))
(test-case
"Emacs compatible location strings"
(check string=?
(location->string
(syntax->location
(datum->syntax
#f #f
(list "file.ss" 42 38 1240 2))))
"file.ss:42:38")
(check string=?
(location->string
(syntax->location
(datum->syntax
#f #f
(list (string->path "file.ss") 42 38 1240 2))))
"file.ss:42:38")
(check string=?
(location->string
(syntax->location
(datum->syntax
#f #f
(list #f 42 38 1240 2))))
"unknown:42:38")
(check string=?
(location->string
(syntax->location
(datum->syntax
#f #f
(list 'foo.ss 42 38 1240 2))))
"foo.ss:42:38")
(check string=?
(location->string
(syntax->location
(datum->syntax
#f #f
(list "foo.ss" #f #f #f #f))))
"foo.ss:?:?"))
))

49
collects/schemeunit/location.ss Normal file
View File

@ -0,0 +1,49 @@
#lang scheme/base
(require scheme/list)
(provide location-source
location-line
location-column
location-position
location-span
syntax->location
location->string)
;; type location = (list any number/#f number/#f number/#f number/#f)
;; location : source line column position span
(define location-source first)
(define location-line second)
(define location-column third)
(define location-position fourth)
(define location-span fifth)
;; syntax->location : syntax -> location
(define (syntax->location stx)
(list (syntax-source stx)
(syntax-line stx)
(syntax-column stx)
(syntax-position stx)
(syntax-span stx)))
;; location->string : (list-of string) -> string
(define (location->string location)
(string-append (source->string (location-source location))
":"
(maybe-number->string (location-line location))
":"
(maybe-number->string (location-column location))))
(define (source->string source)
(cond
((string? source) source)
((path? source) (path->string source))
((not source) "unknown")
(else (format "~a" source))))
(define (maybe-number->string number)
(if (number? number)
(number->string number)
"?"))

128
collects/schemeunit/monad-test.ss Normal file
View File

@ -0,0 +1,128 @@
;;;
;;; Time-stamp: <2008-06-19 21:07:07 noel>
;;;
;;; Copyright (C) 2005 by Noel Welsh.
;;;
;;; This library is free software; you can redistribute it
;;; and/or modify it under the terms of the GNU Lesser
;;; General Public License as published by the Free Software
;;; Foundation; either version 2.1 of the License, or (at
;;; your option) any later version.
;;; This library is distributed in the hope that it will be
;;; useful, but WITHOUT ANY WARRANTY; without even the
;;; implied warranty of MERCHANTABILITY or FITNESS FOR A
;;; PARTICULAR PURPOSE. See the GNU Lesser General Public
;;; License for more details.
;;; You should have received a copy of the GNU Lesser
;;; General Public License along with this library; if not,
;;; write to the Free Software Foundation, Inc., 59 Temple
;;; Place, Suite 330, Boston, MA 02111-1307 USA
;;; Author: Noel Welsh <noelwelsh@yahoo.com>
;;
;;
;; Commentary:
#lang scheme/base
(require "test.ss")
(require "monad.ss")
(provide monad-tests)
;; A simple monad we'll use to thread a counter through
;; code
(define (counter-monad v s)
(make-monad v s))
(define (return-counter value)
(lambda (counter)
(counter-monad value
(monad-state counter))))
(define (increment-counter)
(lambda (counter)
(set-monad-state! counter
(add1 (monad-state counter)))
(set-monad-value! counter (void))
counter))
(define (set-counter s)
(lambda (counter)
(set-monad-state! counter s)
(set-monad-value! counter (void))
counter))
(define (get-counter)
(lambda (counter)
(set-monad-value! counter
(monad-state counter))
counter))
(define monad-tests
(test-suite
"All tests for monad"
(test-case
"compose threads state"
(let ((m ((compose (get-counter)
(lambda (c)
(check = c 0)
(increment-counter)))
(counter-monad (void) 0))))
(check = (monad-state m) 1)))
(test-case
"compose* threads state"
(let ((m
((compose* (get-counter)
(lambda (c)
(check = c 0)
(increment-counter))
(lambda (r)
(check-pred void? r)
(increment-counter))
(lambda (r)
(check-pred void? r)
(get-counter))
(lambda (c)
(check = c 2)
(return-counter #t)))
(counter-monad (void) 0))))
(check = 2 (monad-state m))
(check-true (monad-value m))))
(test-case
"sequence threads state"
(let ((m ((sequence (increment-counter)
(increment-counter))
(counter-monad (void) 0))))
(check = 2 (monad-state m))
(check-pred void? (monad-value m))))
(test-case
"sequence* threads state"
(let ((m ((sequence* (increment-counter)
(increment-counter)
(increment-counter)
(increment-counter))
(counter-monad (void) 0))))
(check = 4 (monad-state m))
(check-pred void? (monad-value m))))
(test-case
"sequence* executes in correct order"
(let ((m ((sequence* (set-counter 0)
(set-counter 1)
(set-counter 2)
(set-counter 4))
(counter-monad (void) 0))))
(check = 4 (monad-state m))
(check-pred void? (monad-value m))))
))

65
collects/schemeunit/monad.ss Normal file
View File

@ -0,0 +1,65 @@
;;;
;;; Time-stamp: <2008-06-19 21:11:59 noel>
;;;
;;; Copyright (C) 2005 by Noel Welsh.
;;;
;;; This library is free software; you can redistribute it
;;; and/or modify it under the terms of the GNU Lesser
;;; General Public License as published by the Free Software
;;; Foundation; either version 2.1 of the License, or (at
;;; your option) any later version.
;;; This library is distributed in the hope that it will be
;;; useful, but WITHOUT ANY WARRANTY; without even the
;;; implied warranty of MERCHANTABILITY or FITNESS FOR A
;;; PARTICULAR PURPOSE. See the GNU Lesser General Public
;;; License for more details.
;;; You should have received a copy of the GNU Lesser
;;; General Public License along with this library; if not,
;;; write to the Free Software Foundation, Inc., 59 Temple
;;; Place, Suite 330, Boston, MA 02111-1307 USA
;;; Author: Noel Welsh <noelwelsh@yahoo.com>
;;
;;
;; Commentary:
#lang scheme/base
(provide (all-defined-out))
;; struct monad : any any
(define-struct monad (value state) #:mutable)
;; compose : (monad-of 'a) ('a -> (monad-of 'b)) -> (monad-of 'b)
(define (compose comp build-comp)
(lambda (seed0)
(let* ((seed1 (comp seed0))
(value (monad-value seed1)))
((build-comp value) seed1))))
;; compose*: (monad-of 'a) ('a -> (monad-of 'b)) ... -> (monad-of 'b)
(define (compose* monad . actions)
(if (null? actions)
monad
(compose monad
(lambda (value)
(apply
compose*
((car actions) value)
(cdr actions))))))
;; sequence : (monad-of 'a) (monad-of 'b) -> (monad-of 'b)
(define (sequence monad-a monad-b)
(compose monad-a (lambda (v) monad-b)))
(define (sequence* monad . monads)
(if (null? monads)
monad
(sequence monad
(apply
sequence*
(car monads)
(cdr monads)))))

77
collects/schemeunit/name-collector.ss Normal file
View File

@ -0,0 +1,77 @@
;;;
;;; Time-stamp: <2008-06-19 22:16:19 noel>
;;;
;;; Copyright (C) 2005 by Noel Welsh.
;;;
;;; This library is free software; you can redistribute it
;;; and/or modify it under the terms of the GNU Lesser
;;; General Public License as published by the Free Software
;;; Foundation; either version 2.1 of the License, or (at
;;; your option) any later version.
;;; This library is distributed in the hope that it will be
;;; useful, but WITHOUT ANY WARRANTY; without even the
;;; implied warranty of MERCHANTABILITY or FITNESS FOR A
;;; PARTICULAR PURPOSE. See the GNU Lesser General Public
;;; License for more details.
;;; You should have received a copy of the GNU Lesser
;;; General Public License along with this library; if not,
;;; write to the Free Software Foundation, Inc., 59 Temple
;;; Place, Suite 330, Boston, MA 02111-1307 USA
;;; Author: Noel Welsh <noelwelsh@yahoo.com>
;;
;;
;; Commentary:
#lang scheme/base
(require "base.ss"
"monad.ss"
"hash-monad.ss"
(lib "list.ss" "srfi" "1"))
(provide display-test-case-name
push-suite-name!
pop-suite-name!
put-initial-name)
(define key (gensym))
;; put-initial-name : () -> (hash-monad-of void)
(define (put-initial-name)
(put key null))
;; display-test-case-name : test-result -> (hash-monad-of void)
(define (display-test-case-name result)
(compose
(get key)
(lambda (names)
(cond
((test-success? result) (return-hash (void)))
(else
(fold-right
(lambda (name seed)
(printf "~a > " name))
(void)
names)
(display (test-result-test-case-name result))
(newline)
(return-hash (void)))))))
;; push-suite-name! : string -> (hash-monad-of void)
(define (push-suite-name! name)
(compose
(get key)
(lambda (names)
(put key (cons name names)))))
;; pop-suite-name! : -> (hash-monad-of void)
(define (pop-suite-name!)
(compose
(get key)
(lambda (names)
(put key (cdr names)))))

45
collects/schemeunit/result-test.ss Normal file
View File

@ -0,0 +1,45 @@
#lang scheme/base
(require
(file "test.ss")
(file "result.ss"))
(provide result-tests)
(define result-tests
(test-suite
"All tests for result"
(test-equal?
"fold-test-results returns seed"
(fold-test-results
(lambda (result seed) seed)
'hello
(delay-test (test-case "Demo" (check = 1 1)))
#:fdown (lambda (name seed) seed)
#:run run-test-case)
'hello)
(test-equal?
"fold-test-results return values of run to result-fn"
(fold-test-results
(lambda (v1 v2 seed)
(check-equal? v1 'v1)
(check-equal? v2 'v2)
seed)
'hello
(delay-test (test-case "Demo" (check = 1 1)))
#:run (lambda (name action) (values 'v1 'v2)))
'hello)
(test-equal?
"fold-test-results calls run with name and action"
(fold-test-results
(lambda (result seed) seed)
'hello
(delay-test (test-case "Demo" 'boo))
#:run (lambda (name action)
(check string=? name "Demo")
(check-equal? (action) 'boo)))
'hello)
))

135
collects/schemeunit/result.ss Normal file
View File

@ -0,0 +1,135 @@
;;;
;;; Time-stamp: <2008-08-11 21:10:24 noel>
;;;
;;; Copyright (C) by Noel Welsh.
;;;
;;; This library is free software; you can redistribute it
;;; and/or modify it under the terms of the GNU Lesser
;;; General Public License as published by the Free Software
;;; Foundation; either version 2.1 of the License, or (at
;;; your option) any later version.
;;; This library is distributed in the hope that it will be
;;; useful, but WITHOUT ANY WARRANTY; without even the
;;; implied warranty of MERCHANTABILITY or FITNESS FOR A
;;; PARTICULAR PURPOSE. See the GNU Lesser General Public
;;; License for more details.
;;; You should have received a copy of the GNU Lesser
;;; General Public License along with this library; if not,
;;; write to the Free Software Foundation, Inc., 59 Temple
;;; Place, Suite 330, Boston, MA 02111-1307 USA
;;; Author: Noel Welsh <noelwelsh@yahoo.com>
;;
;;
;; Commentary:
#lang scheme/base
(require
(file "base.ss")
(file "test-suite.ss"))
(provide (all-defined-out))
;; foldts :
;; (test-suite string thunk thunk 'a -> 'a)
;; (test-suite string thunk thunk 'a 'a -> 'a)
;; (test-case string thunk 'a -> 'a)
;; 'a
;; test
;; ->
;; 'a
;;
;; Extended tree fold ala SSAX for tests. Note that the
;; test-case/test-suite is passed to the functions so that
;; subtypes of test-case/test-suite can be differentiated,
;; allowing extensibility [This is an interesting difference
;; between OO and FP. FP gives up extensibility on
;; functions, OO on data. Here we want extensibility on
;; data so FP is a bit ugly].
(define (foldts fdown fup fhere seed test)
(cond
((schemeunit-test-case? test)
(fhere test
(schemeunit-test-case-name test)
(schemeunit-test-case-action test)
seed))
((schemeunit-test-suite? test)
(apply-test-suite test fdown fup fhere seed))
(else
(raise
(make-exn:test
(format "foldts: Don't know what to do with ~a. It isn't a test case or test suite." test)
(current-continuation-marks))))))
;; Useful in fold-test-results below
(define 2nd-arg (lambda (a b) b))
;; fold-test-results :
;; ('b 'c ... 'a -> 'a)
;; 'a
;; test
;; #:run (string (() -> any) -> 'b 'c ...)
;; #:fdown (string 'a -> 'a)
;; #:fup (string 'a -> 'a)
;; ->
;; 'a
;;
;; Fold collector pre-order L-to-R depth-first over the
;; result of run. By default these are test results, and
;; hence by default result-fn is
;;
;; test-result 'a -> 'a
(define (fold-test-results result-fn seed test
#:run [run run-test-case]
#:fdown [fdown 2nd-arg]
#:fup [fup 2nd-arg])
(foldts
(lambda (suite name before after seed)
'(printf "into ~a\n" name)
(before)
(fdown name seed))
(lambda (suite name before after seed kid-seed)
'(printf "out of ~a\n" name)
(after)
(fup name kid-seed))
(lambda (case name action seed)
'(printf "running ~a\n" name)
(apply result-fn
;; Get the values returned by run-fn into a
;; list and append the seed
(append (call-with-values
(lambda () (run name action))
list)
(list seed))))
seed
test))
;; run-test-case : string thunk -> test-result
(define (run-test-case name action)
'(printf "run-test-case running ~a ~a\n" name action)
(with-handlers
([exn:test:check?
(lambda (exn)
(make-test-failure name exn))]
[(lambda _ #t)
(lambda (exn)
(make-test-error name exn))])
(let ((value (action)))
(make-test-success name value))))
;; run-test : test -> (list-of test-result)
;;
;; Run test returning a tree of test-results. Results are
;; ordered L-to-R as they occur in the tree.
(define (run-test test)
(reverse
(fold-test-results
(lambda (result seed) (cons result seed))
(list)
test)))

45
collects/schemeunit/scribblings/acknowledgements.scrbl Normal file
View File

@ -0,0 +1,45 @@
#lang scribble/doc
@(require "base.ss")
@title{Acknowlegements}
The following people have contributed to SchemeUnit:
@itemize{
@item{Robby Findler pushed me to release version 3}
@item{Matt Jadud and his students at Olin College
suggested renaming @scheme[test/text-ui]}
@item{Dave Gurnell reported a bug in check-not-exn and
suggested improvements to SchemeUnit}
@item{Danny Yoo reported a bug in and provided a fix for
trim-current-directory}
@item{Jacob Matthews and Guillaume Marceau for bug reports
and fixes}
@item{Eric Hanchow suggested test/text-ui return a useful
result}
@item{Ray Racine and Richard Cobbe provided require/expose}
@item{John Clements suggested several new checks}
@item{Jose A. Ortega Ruiz alerted me a problem in the
packaging system and helped fix it.}
@item{Sebastian H. Seidel provided help packaging SchemeUnit
into a .plt}
@item{Don Blaheta provided the method for grabbing line number
and file name in checks}
@item{Patrick Logan ported example.ss to version 1.3}
@item{The PLT team made PLT Scheme}
@item{The Extreme Programming community started the whole
testing framework thing}
}

17
collects/schemeunit/scribblings/api.scrbl Normal file
View File

@ -0,0 +1,17 @@
#lang scribble/doc
@(require "base.ss")
@title[#:tag "api"]{SchemeUnit API}
@defmodule[schemeunit
#:use-sources (schemeunit/test)]
@include-section["overview.scrbl"]
@include-section["check.scrbl"]
@include-section["compound-testing.scrbl"]
@include-section["control-flow.scrbl"]
@include-section["misc.scrbl"]
@include-section["ui.scrbl"]
@include-section["running-tests.scrbl"]

16
collects/schemeunit/scribblings/base.ss Normal file
View File

@ -0,0 +1,16 @@
#lang scheme/base
(require
scribble/eval
scribble/manual
(for-label scheme/base
(file "../test.ss")
(file "../text-ui.ss")))
(provide
(all-from-out scribble/eval
scribble/manual)
(for-label (all-from-out scheme/base
(file "../test.ss")
(file "../text-ui.ss"))))

344
collects/schemeunit/scribblings/check.scrbl Normal file
View File

@ -0,0 +1,344 @@
#lang scribble/doc
@(require "base.ss")
@title{Checks}
Checks are the basic building block of SchemeUnit. A check
checks some condition. If the condition holds the check
evaluates to @scheme[#t]. If the condition doesn't hold the
check raises an instance of @scheme[exn:test:check] with
information detailing the failure.
Although checks are implemented as macros, which is
necessary to grab source location, they are conceptually
functions. This means, for instance, checks always evaluate
their arguments. You can use check as first class
functions, though you will lose precision in the reported
source locations if you do so.
The following are the basic checks SchemeUnit provides. You
can create your own checks using @scheme[define-check].
@defproc[(check (op (-> any any (or/c #t #f)))
(v1 any)
(v2 any)
(message string? ""))
#t]{
The simplest check. Succeeds if @scheme[op] applied to
@scheme[v1] and @scheme[v2] is not @scheme[#f], otherwise
raises an exception of type @scheme[exn:test:check]. The
optional @scheme[message] is included in the output if the
check fails.}
For example, the following check succeeds:
@schemeblock[
(check < 2 3)
]
@defproc*[([(check-eq? (v1 any) (v2 any) (message string? "")) #t]
[(check-not-eq? (v1 any) (v2 any) (message string? "")) #t]
[(check-eqv? (v1 any) (v2 any) (message string? "")) #t]
[(check-equal? (v1 any) (v2 any) (message string? "")) #t]
[(check-not-equal? (v1 any) (v2 any) (message string? "")) #t])]{
Checks that @scheme[v1] is (not) @scheme[eq?],
@scheme[eqv?], or @scheme[equal?] to @scheme[v2]. The
optional @scheme[message] is included in the output if the
check fails.}
For example, the following checks all fail:
@schemeblock[
(check-eq? (list 1) (list 1) "allocated data not eq?")
(check-not-eq? 1 1 "integers are eq?")
(check-eqv? 1 1.0 "not eqv?")
(check-equal? 1 1.0 "not equal?")
(check-not-equal? (list 1) (list 1) "equal?")
]
@defproc[(check-pred (pred (-> any (or/c #t #f))) (v any) (message string? ""))
#t]{Checks that @scheme[pred] returns @scheme[#t] when applied to @scheme[v]. The optional @scheme[message] is included in the output if the check fails.}
Here's an example that passes and an example that fails:
@schemeblock[
(check-pred string? "I work")
(check-pred number? "I fail")
]
@defproc[(check-= (v1 any) (v2 any) (epsilon number?) (message string? "")) #t]{
Checks that @scheme[v1] and @scheme[v2] are within
@scheme[epsilon] of one another. The optional
@scheme[message] is included in the output if the check
fails.}
Here's an example that passes and an example that fails:
@schemeblock[
(check-= 1.0 1.01 0.01 "I work")
(check-= 1.0 1.01 0.005 "I fail")
]
@defproc*[([(check-true (v any) (message string? "")) #t]
[(check-false (v any) (message string? "")) #t]
[(check-not-false (v any) (message string? "")) #t])]{
Checks that @scheme[v] is @scheme[#t], @scheme[#f], or not
@scheme[#f] as appropriate. The optional @scheme[message]
is included in the output if the check fails.}
For example, the following checks all fail:
@schemeblock[
(check-true 1)
(check-false 1)
(check-not-false #f)
]
@defproc[(check-exn (exn-predicate (-> any (or/c #t #f))) (thunk (-> any)) (message string? ""))
#t]{
Checks that @scheme[thunk] raises an exception for which
@scheme[exn-predicate] returns @scheme[#t]. The optional
@scheme[message] is included in the output if the check
fails. A common error is to use an expression instead of a
function of no arguments for @scheme[thunk]. Remember that
checks are conceptually functions.}
Here are two example, one showing a test that succeeds, and one showing a common error:
@schemeblock[
(check-exn exn?
(lambda ()
(raise (make-exn "Hi there"
(current-continuation-marks)))))
(code:comment "Forgot to wrap the expression in a thunk. Don't do this!")
(check-exn exn?
(raise (make-exn "Hi there"
(current-continuation-marks))))
]
@defproc[(check-not-exn (thunk (-> any)) (message string? "")) #t]{
Checks that @scheme[thunk] does not raise any exceptions.
The optional @scheme[message] is included in the output if
the check fails.}
@defproc[(fail (message string? "")) #t]{This checks fails unconditionally. Good for creating test stubs that youintend to fill out later. The optional @scheme[message] is included in the output if the check fails.}
@defproc[(check-regexp-match (regexp regexp?) (string string?)) #t]{Checks that @scheme[regexp] matches the @scheme[string].}
The following check will succeed:
@schemeblock[(check-regexp-match "a+bba" "aaaaaabba")]
This check will fail:
@schemeblock[(check-regexp-match "a+bba" "aaaabbba")]
@section{Augmenting Information on Check Failure}
When an check fails it stores information including the name
of the check, the location and message (if available), the
expression the check is called with, and the parameters to
the check. Additional information can be stored by using
the @scheme[with-check-info*] function, and the
@scheme[with-check-info] macro.
@defstruct[check-info ([name symbol?] [value any])]{
A check-info structure stores information associated
with the context of execution of an check.}
The are several predefined functions that create check
information structures with predefined names. This avoids
misspelling errors:
@defproc*[([(make-check-name (name string?)) check-info?]
[(make-check-params (params (listof any))) check-info?]
[(make-check-location (loc (list any (or/c number? #f) (or/c number? #f) (or/c number? #f) (or/c number? #f)))) check-info?]
[(make-check-expression (msg any)) check-info?]
[(make-check-message (msg string?)) check-info?]
[(make-check-actual (param any)) check-info?]
[(make-check-expected (param any)) check-info?])]{}
@defproc[(with-check-info* (info (listof check-info?)) (thunk (-> any))) any]{
Stores the given @scheme[info] on the check-info stack for
the duration (the dynamic extent) of the execution of
@scheme[thunk]}
Example:
@schemeblock[
(with-check-info*
(list (make-check-info 'time (current-seconds)))
(lambda () (check = 1 2)))
]
When this check fails the message
@verbatim{time: <current-seconds-at-time-of-running-check>}
will be printed along with the usual information on an
check failure.
@defform[(with-check-info ((name val) ...) body ...)]{
The @scheme[with-check-info] macro stores the given
information in the check information stack for the duration
of the execution of the body expressions. @scheme[Name] is
a quoted symbol and @scheme[val] is any value.}
Example:
@schemeblock[
(for-each
(lambda (elt)
(with-check-info
(('current-element elt))
(check-pred odd? elt)))
(list 1 3 5 7 8))
]
When this test fails the message
@verbatim{current-element: 8}
will be displayed along with the usual information on an
check failure.
@section{Custom Checks}
Custom checks can be defined using @scheme[define-check] and
its variants. To effectively use these macros it is useful
to understand a few details about a check's evaluation
model.
Firstly, a check should be considered a function, even
though most uses are actually macros. In particular, checks
always evaluate their arguments exactly once before
executing any expressions in the body of the checks. Hence
if you wish to write checks that evalute user defined code
that code must be wrapped in a thunk (a function of no
arguments) by the user. The predefined @scheme[check-exn]
is an example of this type of check.
It is also useful to understand how the check information
stack operates. The stack is stored in a parameter and the
@scheme[with-check-info] forms evaluate to calls to
@scheme[parameterize]. Hence check information has lexical
scope. For this reason simple checks (see below) cannot
usefully contain calls to @scheme[with-check-info] to report
additional information. All checks created using
@scheme[define-simple-check] or @scheme[define-check] grab
some information by default: the name of the checks and the
values of the parameters. Additionally the macro forms of
checks grab location information and the expressions passed
as parameters.
@defform[(define-simple-check (name param ...) expr ...)]{
The @scheme[define-simple-check] macro constructs a check
called @scheme[name] that takes the params and an optional
message as arguments and evaluates the @scheme[expr]s. The
check fails if the result of the @scheme[expr]s is
@scheme[#f]. Otherwise the check succeeds. Note that
simple checks cannot report extra information using
@scheme[with-check-info].}
Example:
To define a check @scheme[check-odd?]
@schemeblock[
(define-simple-check (check-odd? number)
(odd? number))
]
We can use these checks in the usual way:
@schemeblock[
(check-odd? 3) (code:comment "Success")
(check-odd? 2) (code:comment "Failure")
]
@defform*[[(define-binary-check (name pred actual expected))
(define-binary-check (name actual expected) expr ...)]]{
The @scheme[define-binary-check] macro constructs a check
that tests a binary predicate. It's benefit over
@scheme[define-simple-check] is in better reporting on check
failure. The first form of the macro accepts a binary
predicate and tests if the predicate holds for the given
values. The second form tests if @scheme[expr] non-false.
}
Examples:
Here's the first form, where we use a predefined predicate
to construct a binary check:
@schemeblock[
(define-binary-check (check-char=? char=? actual expected))
]
In use:
@schemeblock[
(check-char=? (read-char a-port) #\a)
]
If the expression is more complicated the second form should
be used. For example, below we define a binary check that
tests a number if within 0.01 of the expected value:
@schemeblock[
(define-binary-check (check-in-tolerance actual expected)
(< (abs (- actual expected)) 0.01))
]
@defform[(define-check (name param ...) expr ...)]{
The @scheme[define-check] macro acts in exactly the same way
as @scheme[define-simple-check], except the check only fails
if the macro @scheme[fail-check] is called in the body of
the check. This allows more flexible checks, and in
particular more flexible reporting options.}
@defform[(fail-check)]{The @scheme[fail-check] macro raises an @scheme[exn:test:check] with
the contents of the check information stack.}
@section{The Check Evaluation Context}
The semantics of checks are determined by the parameters
@scheme[current-check-around] and
@scheme[current-check-handler]. Other testing form such as
@scheme[test-begin] and @scheme[test-suite] change the value
of these parameters.
@defparam[current-check-handler handler (-> any/c any/c)]{
Parameter containing the function that handles exceptions
raised by check failures. The default behaviour is to print
an error message including the exception message and stack
trace. }
@defparam[current-check-around check (-> thunk any/c)]{
Parameter containing the function that handles the execution
of checks. The default value wraps the evaluation of
@scheme[thunk] in a @scheme[with-handlers] call that calls
@scheme[current-check-handler] if an exception is raised. }

168
collects/schemeunit/scribblings/compound-testing.scrbl Normal file
View File

@ -0,0 +1,168 @@
#lang scribble/doc
@(require "base.ss")
@title{Compound Testing Forms}
@section{Test Cases}
As programs increase in complexity the unit of testing
grows beyond a single check. For example, it may be the case
that if one check fails it doesn't make sense to run
another. To solve this problem compound testing forms can
be used to group expressions. If any expression in a group
fails (by raising an exception) the remaining expressions
will not be evaluated.
@defform[(test-begin expr ...)]{
A @scheme[test-begin] form groups the @scheme[expr]s into a
single unit. If any @scheme[expr] fails the following ones
are not evaluated. }
For example, in the following code the world is not
destroyed as the preceding check fails:
@schemeblock[
(test-begin
(check-eq? 'a 'b)
(code:comment "This line won't be run")
(destroy-the-world))
]
@defform[(test-case name expr ...)]{
Like a @scheme[test-begin] except a name is associated with
the group of @scheme[expr]s. The name will be reported if
the test fails. }
Here's the above example rewritten to use @scheme[test-case]
so the test can be named.
@schemeblock[
(test-case
"Example test"
(check-eq? 'a 'b)
(code:comment "This line won't be run")
(destroy-the-world))
]
@defproc[(test-case? (obj any)) boolean?]{
True if @scheme[obj] is a test case, and false otherwise
}
@section{Test Suites}
Test cases can themselves be grouped into test suites. A
test suite can contain both test cases and test suites.
Unlike a check or test case, a test suite is not immediately
run. Instead use one of the functions described in
@secref["ui"] or @secref["running"].
@defform[(test-suite name [#:before before-thunk] [#:after after-thunk] test ...)]{
Constructs a test suite with the given name and tests. The
tests may be test cases, constructed using
@scheme[test-begin] or @scheme[test-case], or other test
suites.
The @scheme[before-thunk] and @scheme[after-thunk] are
optional thunks (functions are no argument). They are run
before and after the tests are run, respectively.
Unlike a check or test case, a test suite is not immediately
run. Instead use one of the functions described in
@secref["ui"] or @secref["running"].}
For example, here is a test suite that displays @tt{Before}
before any tests are run, and @tt{After} when the tests have
finished.
@schemeblock[
(test-suite
"An example suite"
#:before (lambda () (display "Before"))
#:after (lambda () (display "After"))
(test-case
"An example test"
(check-eq? 1 1)))
]
@defproc[(test-suite? (obj any)) boolean?]{ True if
@scheme[obj] is a test suite, and false otherwise}
@subsection{Utilities for Defining Test Suites}
There are some macros that simplify the common cases of
defining test suites:
@defform[(define-test-suite name test ...)]{ The
@scheme[define-test-suite] form creates a test suite with
the given name (converted to a string) and tests, and binds
it to the same name.}
For example, this code creates a binding for the name
@scheme[example-suite] as well as creating a test suite with
the name @scheme["example-suite"]:
@schemeblock[
(define-test-suite example-suite
(check = 1 1))
]
@defform[(define/provide-test-suite name test ...)]{ This
for is just like @scheme[define-test-suite], and in addition
it @scheme[provide]s the test suite.}
Finally, there is the @scheme[test-suite*] macro, which
defines a test suite and test cases using a shorthand
syntax:
@defform[(test-suite* name (test-case-name test-case-body
...) ...)]{ Defines a test suite with the given name, and
creates test cases within the suite, with the given names and
body expressions.
As far I know no-one uses this macro, so it might disappear
in future versions of SchemeUnit.}
@section{Compound Testing Evaluation Context}
Just like with checks, there are several parameters that
control the semantics of compound testing forms.
@defparam[current-test-name name (or/c string? false/c)]{
This parameter stores the name of the current test case. A
value of @scheme[#f] indicates a test case with no name,
such as one constructed by @scheme[test-begin]. }
@defparam[current-test-case-around handler (-> (-> any/c) any/c)]{
This parameter handles evaluation of test cases. The value
of the parameter is a function that is passed a thunk (a
function of no arguments). The function, when applied,
evaluates the expressions within a test case. The default
value of the @scheme[current-test-case-around] parameters
evaluates the thunk in a context that catches exceptions and
prints an appropriate message indicating test case failure.}
@defproc[(test-suite-test-case-around [thunk (-> any/c)]) any/c]{
The @scheme[current-test-case-around] parameter is
parameterized to this value within the scope of a
@scheme[test-suite]. This function creates a test case
structure instead of immediately evaluating the thunk.}
@defproc[(test-suite-check-around [thunk (-> any/c)]) any/c]{
The @scheme[current-check-around] parameter is parameterized
to this value within the scope of a @scheme[test-suite].
This function creates a test case structure instead of
immediately evaluating a check.}

52
collects/schemeunit/scribblings/control-flow.scrbl Normal file
View File

@ -0,0 +1,52 @@
#lang scribble/doc
@(require "base.ss")
@title{Test Control Flow}
The @scheme[before], @scheme[after], and @scheme[around]
macros allow you to specify code that is always run before,
after, or around expressions in a test case.
@defform[(before before-expr expr1 expr2 ...)]{
Whenever control enters the scope execute the @scheme[before-expr]
before executing @scheme[expr-1], and @scheme[expr-2 ...]}
@defform[(after expr-1 expr-2 ... after-expr)]{
Whenever control exits the scope execute the @scheme[after-expr]
after executing @scheme[expr-1], and @scheme[expr-2 ...] The @scheme[after-expr] is
executed even if control exits via an exception or other means.}
@defform[(around before-expr expr-1 expr-2 ... after-expr)]{
Whenever control enters the scope execute the
@scheme[before-expr] before executing @scheme[expr-1 expr-2
...], and execute @scheme[after-expr] whenever control
leaves the scope.}
Example:
The test below checks that the file @tt{test.dat} contains
the string @tt{"foo"}. The before action writes to this
file. The after action deletes it.
@schemeblock[
(around
(with-output-to-file "test.dat"
(lambda ()
(write "foo")))
(with-input-from-file "test.dat"
(lambda ()
(check-equal? "foo" (read))))
(delete-file "test.dat"))
]
@defform[(delay-test test1 test2 ...)]{
This somewhat curious macro evaluates the given tests in a
context where @scheme[current-test-case-around] is
parameterized to @scheme[test-suite-test-case-around]. This
has been useful in testing SchemeUnit. It might be useful
for you if you create test cases that create test cases.}

24
collects/schemeunit/scribblings/file-test.scm Normal file
View File

@ -0,0 +1,24 @@
#lang scheme/base
(require schemeunit/test
"file.scm")
(check-equal? (my-+ 1 1) 2)
(check-equal? (my-* 1 2) 2)
(test-begin
(let ((lst (list 2 4 6 9)))
(check = (length lst) 4)
(for-each
(lambda (elt)
(check-pred even? elt))
lst)))
(test-case
"List has length 4 and all elements even"
(let ((lst (list 2 4 6 9)))
(check = (length lst) 4)
(for-each
(lambda (elt)
(check-pred even? elt))
lst)))

14
collects/schemeunit/scribblings/file.scm Normal file
View File

@ -0,0 +1,14 @@
#lang scheme/base
(define (my-+ a b)
(if (zero? a)
b
(my-+ (sub1 a) (add1 b))))
(define (my-* a b)
(if (zero? a)
b
(my-* (sub1 a) (my-+ b b))))
(provide my-+
my-*)

15
collects/schemeunit/scribblings/overview.scrbl Normal file
View File

@ -0,0 +1,15 @@
#lang scribble/doc
@(require "base.ss")
@title{Overview of SchemeUnit}
There are three basic data types in SchemeUnit:
@itemize[
@item{A @italic{check} is the basic unit of a test. As the name suggests, it checks some condition is true.}
@item{A @italic{test case} is a group of checks that form one conceptual unit. If any check within the case fails, the entire case fails.}
@item{A @italic{test suite} is a group of test cases and test suites that has a name.}
]

118
collects/schemeunit/scribblings/philosophy.scrbl Normal file
View File

@ -0,0 +1,118 @@
#lang scribble/doc
@(require "base.ss")
@title[#:tag "philosophy"]{The Philosophy of SchemeUnit}
SchemeUnit is designed to allow tests to evolve in step with
the evolution of the program under testing. SchemeUnit
scales from the unstructed checks suitable for simple
programs to the complex structure necessary for large
projects.
Simple programs, such as those in How to Design Programs,
are generally purely functional with no setup required to
obtain a context in which the function may operate.
Therefore the tests for these programs are extremely simple:
the test expressions are single checks, usually for
equality, and there are no dependencies between expressions.
For example, a HtDP student may be writing simple list
functions such as length, and the properties they are
checking are of the form:
@schemeblock[
(equal? (length null) 0)
(equal? (length '(a)) 1)
(equal? (length '(a b)) 2)
]
SchemeUnit directly supports this style of testing. A check
on its own is a valid test. So the above examples may be
written in SchemeUnit as:
@schemeblock[
(check-equal? (length null) 0)
(check-equal? (length '(a)) 1)
(check-equal? (length '(a b)) 2)
]
Simple programs now get all the benefits of SchemeUnit with
very little overhead.
There are limitations to this style of testing that more
complex programs will expose. For example, there might be
dependencies between expressions, caused by state, so that
it does not make sense to evaluate some expressions if
earlier ones have failed. This type of program needs a way
to group expressions so that a failure in one group causes
evaluation of that group to stop and immediately proceed to
the next group. In SchemeUnit all that is required is to
wrap a @scheme[test-begin] expression around a group of
expressions:
@schemeblock[
(test-begin
(setup-some-state!)
(check-equal? (foo! 1) 'expected-value-1)
(check-equal? (foo! 2) 'expected-value-2))
]
Now if any expression within the @scheme[test-begin]
expression fails no further expressions in that group will
be evaluated.
Notice that all the previous tests written in the simple
style are still valid. Introducing grouping is a local
change only. This is a key feature of SchemeUnit's support
for the evolution of the program.
The programmer may wish to name a group of tests. This is
done using the @scheme[test-case] expression, a simple
variant on test-begin:
@schemeblock[
(test-case
"The name"
... test expressions ...)
]
Most programs will stick with this style. However,
programmers writing very complex programs may wish to
maintain separate groups of tests for different parts of the
program, or run their tests in different ways to the normal
SchemeUnit manner (for example, test results may be logged
for the purpose of improving software quality, or they may
be displayed on a website to indicate service quality). For
these programmers it is necessary to delay the execution of
tests so they can processed in the programmer's chosen
manner. To do this, the programmer simply wraps a test-suite
around their tests:
@schemeblock[
(test-suite
"Suite name"
(check ...)
(test-begin ...)
(test-case ...))
]
The tests now change from expressions that are immediately
evaluated to objects that may be programmatically
manipulated. Note again this is a local change. Tests
outside the suite continue to evaluate as before.
@section{Historical Context}
Most testing frameworks, including earlier versions of
SchemeUnit, support only the final form of testing. This is
likely due to the influence of the SUnit testing framework,
which is the ancestor of SchemeUnit and the most widely used
frameworks in Java, .Net, Python, and Ruby, and many other
languages. That this is insufficient for all users is
apparent if one considers the proliferation of "simpler"
testing frameworks in Scheme such as SRFI-78, or the the
practice of beginner programmers. Unfortunately these
simpler methods are inadequate for testing larger
systems. To the best of my knowledge SchemeUnit is the only
testing framework that makes a conscious effort to support
the testing style of all levels of programmer.

166
collects/schemeunit/scribblings/quick-start.scrbl Normal file
View File

@ -0,0 +1,166 @@
#lang scribble/doc
@(require "base.ss")
@title[#:tag "quick-start"]{Quick Start Guide for SchemeUnit}
Suppose we have code contained in @tt{file.scm}, which
implements buggy versions of @scheme[+] and @scheme[-]
called @scheme[my-+] and @scheme[my--]:
@schememod[
scheme/base
(define (my-+ a b)
(if (zero? a)
b
(my-+ (sub1 a) (add1 b))))
(define (my-* a b)
(if (zero? a)
b
(my-* (sub1 a) (my-+ b b))))
(provide my-+
my-*)
]
We want to test this code with SchemeUnit. We start by
creating a file called @tt{file-test.scm} to contain our
tests. At the top of @tt{file-test.scm} we import
SchemeUnit and @tt{file.scm}:
@schememod[
scheme/base
(require schemeunit
"file.scm")
]
Now we add some tests to check our library:
@schemeblock[
(check-equal? (my-+ 1 1) 2 "Simple addition")
(check-equal? (my-* 1 2) 2 "Simple multiplication")
]
This is all it takes to define tests in SchemeUnit. Now
evaluate this file and see if the library is correct.
Here's the result I get:
@verbatim{
#t
--------------------
FAILURE
name: check-equal?
location: (file-test.scm 7 0 117 27)
expression: (check-equal? (my-* 1 2) 2)
params: (4 2)
actual: 4
expected: 2
--------------------}
The first @scheme[#t] indicates the first test passed. The
second test failed, as shown by the message.
Requiring SchemeUnit and writing checks is all you need to
get started testing, but let's take a little bit more time
to look at some features beyond the essentials.
Let's say we want to check that a number of properties hold.
How do we do this? So far we've only seen checks of a
single expression. In SchemeUnit a check is always a single
expression, but we can group checks into units called test
cases. Here's a simple test case written using the
@scheme[test-begin] form:
@schemeblock[
(test-begin
(let ((lst (list 2 4 6 9)))
(check = (length lst) 4)
(for-each
(lambda (elt)
(check-pred even? elt))
lst)))
]
Evalute this and you should see an error message like:
@verbatim{
--------------------
A test
... has a FAILURE
name: check-pred
location: (#<path:/Users/noel/programming/schematics/schemeunit/branches/v3/doc/file-test.scm> 14 6 252 22)
expression: (check-pred even? elt)
params: (#<procedure:even?> 9)
--------------------
}
This tells us that the expression @scheme[(check-pred even?
elt)] failed. The arguments of this check were
@scheme[even?] and @scheme[9], and as 9 is not even the
check failed. A test case fails as soon as any check within
it fails, and no further checks are evaluated once this
takes place.
Naming our test cases if useful as it helps remind us what
we're testing. We can give a test case a name with the
@scheme[test-case] form:
@schemeblock[
(test-case
"List has length 4 and all elements even"
(let ((lst (list 2 4 6 9)))
(check = (length lst) 4)
(for-each
(lambda (elt)
(check-pred even? elt))
lst)))
]
Now if we want to structure our tests are bit more we can
group them into a test suite:
@schemeblock[
(define file-tests
(test-suite
"Tests for file.scm"
(check-equal? (my-+ 1 1) 2 "Simple addition")
(check-equal? (my-* 1 2) 2 "Simple multiplication")
(test-case
"List has length 4 and all elements even"
(let ((lst (list 2 4 6 9)))
(check = (length lst) 4)
(for-each
(lambda (elt)
(check-pred even? elt))
lst)))))
]
Evaluate the module now and you'll see the tests no longer
run. This is because test suites delay execution of their
tests, allowing you to choose how you run your tests. You
might, for example, print the results to the screen or log
them to a file.
Let's run our tests, using SchemeUnit's simple textual user
interface (there are fancier interfaces available but this
will do for our example). In @tt{file-test.scm} add the
following lines:
@schemeblock[
(require schemeunit/text-ui)
(run-tests file-tests)
]
Now evaluate the file and you should see similar output
again.
These are the basics of SchemeUnit. Refer to the
documentation below for more advanced topics, such as
defining your own checks. Have fun!

41
collects/schemeunit/scribblings/release-notes.scrbl Normal file
View File

@ -0,0 +1,41 @@
#lang scribble/doc
@(require "base.ss")
@title{Release Notes}
@section{Version 3.4}
This version allows arbitrary expressions within test
suites, fixing the semantics issue below.
There are also miscellaneous Scribble fixes.
@section{Version 3}
This version of SchemeUnit is largely backwards compatible
with version 2 but there are significant changes to the
underlying model, justifying incrementing the major version
number. These changes are best explained in
@secref["philosophy"].
There are a few omissions in this release, that will
hopefully be corrected in later minor version releases:
@itemize[
@item{There is no graphical UI, and in particular no
integration with DrScheme.}
@item{The semantics of @scheme[test-suite] are not the
desired ones. In particular, only checks and test cases
have their evaluation delayed by a test suite; other
expressions will be evaluated before the suite is
constructed. This won't affect tests written in the version
2 style. In particular this doesn't effect test suites that
contain other test suites; they continue to work in the
expected way. However people incrementally developing tests
from plain checks to test suites might be surprised. I'm
hoping that few enough people will do this that no-one will
notice before it's fixed.}
]

21
collects/schemeunit/scribblings/schemeunit.scrbl Normal file
View File

@ -0,0 +1,21 @@
#lang scribble/doc
@(require "base.ss")
@title{@bold{SchemeUnit}: Unit Testing for Scheme}
by Noel Welsh (@tt{noelwelsh at GMail})
and Ryan Culpepper (@tt{ryan_sml at yahoo dot com})
SchemeUnit is a unit-testing framework for PLT Scheme. It
is designed to handle the needs of all Scheme programmers,
from novices to experts.
@table-of-contents[]
@include-section["quick-start.scrbl"]
@include-section["philosophy.scrbl"]
@include-section["api.scrbl"]
@include-section["release-notes.scrbl"]
@include-section["acknowledgements.scrbl"]
@index-section[]

35
collects/schemeunit/scribblings/ui.scrbl Normal file
View File

@ -0,0 +1,35 @@
#lang scribble/doc
@(require "base.ss")
@title[#:tag "ui"]{User Interfaces}
SchemeUnit provides a textual and a graphical user interface
@section{Textual User Interface}
@defmodule[schemeunit/text-ui]
The textual UI is in the @scheme[text-ui] module. It is run
via the @scheme[run-tests] function
@defproc[(run-tests (test (or/c test-case? test-suite?)) (verbosity (symbols 'quite 'normal 'verbose) 'normal)) natural-number/c]{
The given @scheme[test] is run and the result of running it
output to the @scheme[current-output-port]. The output is
compatable with the (X)Emacs next-error command (as used,
for example, by (X)Emac's compile function)
The optional @scheme[verbosity] is one of @scheme['quiet],
@scheme['normal], or @scheme['verbose]. Quiet output
displays only the number of successes, failures, and errors.
Normal reporting suppresses some extraneous check
information (such as the expression). Verbose reports all
information.
@scheme[run-tests] returns the number of unsuccessful tests.}
@section{Graphical User Interface}
The GUI has not yet been updated to this version of SchemeUnit.

54
collects/schemeunit/standalone-check-test.ss Normal file
View File

@ -0,0 +1,54 @@
;;;
;;; Time-stamp: <2008-06-06 15:32:49 noel>
;;;
;;; Copyright (C) by Noel Welsh.
;;;
;;; This library is free software; you can redistribute it
;;; and/or modify it under the terms of the GNU Lesser
;;; General Public License as published by the Free Software
;;; Foundation; either version 2.1 of the License, or (at
;;; your option) any later version.
;;; This library is distributed in the hope that it will be
;;; useful, but WITHOUT ANY WARRANTY; without even the
;;; implied warranty of MERCHANTABILITY or FITNESS FOR A
;;; PARTICULAR PURPOSE. See the GNU Lesser General Public
;;; License for more details.
;;; You should have received a copy of the GNU Lesser
;;; General Public License along with this library; if not,
;;; write to the Free Software Foundation, Inc., 59 Temple
;;; Place, Suite 330, Boston, MA 02111-1307 USA
;;; Author: Noel Welsh <noelwelsh@yahoo.com>
;; Here we check the standalone (not within a test-case or
;; test-suite) semantics of checks. These tests are not
;; part of the standard test suite and must be run
;; separately.
#lang scheme/base
(require "check.ss")
;; This check should succeed
(check = 1 1 0.0)
;; This check should display an error including the message "Outta here!"
(check-pred (lambda (x) (error "Outta here!")) 'foo)
;; This check should display a failure
(check = 1 2 0.0)
;; This check should display "Oh HAI!"
(parameterize
([current-check-handler (lambda (e) (display "Oh HAI!\n"))])
(check = 1 2 0.0))
;; This check should display "I didn't run"
(parameterize
([current-check-around (lambda (t) (display "I didn't run\n"))])
(check = 1 1 0.0))

20
collects/schemeunit/standalone-test-case-test.ss Normal file
View File

@ -0,0 +1,20 @@
;; Here we check the standalone (not within a test-suite)
;; semantics of checks. These tests are not part of the
;; standard test suite and must be run separately.
#lang scheme/base
(require "check.ss"
"test-case.ss")
;; These tests should succeeds
(test-begin (check-eq? 1 1))
(test-case "succeed" (check-eq? 1 1))
;; These should raise errors
(test-begin (error "Outta here!"))
(test-case "error" (error "Outta here!"))
;; Thesse should raise failures
(test-begin (check-eq? 1 2))
(test-case "failure" (check-eq? 1 2))

57
collects/schemeunit/test-case-test.ss Normal file
View File

@ -0,0 +1,57 @@
#lang scheme/base
(require "base.ss"
"check.ss"
"test-case.ss"
"test-suite.ss"
"result.ss")
(provide test-case-tests)
(define test-case-tests
(test-suite
"test-case-tests"
(test-case
"test-begin terminates when sub-expression fails"
(let ([fail? #f])
(delay-test
(run-test
(test-begin
(check-eq? 'a 'b)
(set! fail? #t)))
(check-false fail?))))
(test-case
"test-case terminates when sub-expression fails"
(let ([fail? #f])
(delay-test
(run-test
(test-case
"foo"
(check-eq? 'a 'b)
(set! fail? #t)))
(check-false fail?))))
(test-case
"define allowed within test-begin"
(check-pred
test-success?
(delay-test
(car (run-test
(test-begin
(define yes #t)
(check-true yes)))))))
(test-case
"define allowed within test-case"
(check-pred
test-success?
(delay-test
(car (run-test
(test-case
"dummy"
(define yes #t)
(check-true yes)))))))
))

143
collects/schemeunit/test-case.ss Normal file
View File

@ -0,0 +1,143 @@
#lang scheme/base
(require (for-syntax scheme/base))
(require (file "base.ss")
(file "format.ss")
(file "check-info.ss")
(file "check.ss"))
(provide current-test-name
current-test-case-around
test-begin
test-case
before
after
around)
(define current-test-name
(make-parameter
#f
(lambda (v)
(if (string? v)
v
(raise-mismatch-error
'current-test-name
"string?"
v)))))
;; test-case-around : ( -> a) -> a
;;
;; Run a test-case immediately, printing information on failure
(define test-case-around
(lambda (thunk)
(with-handlers
([exn:test:check?
(lambda (e)
(display-delimiter)
(display-test-name (current-test-name))
(display-failure)(newline)
(display-check-info-stack (exn:test:check-stack e))
(display-delimiter))]
[exn?
(lambda (e)
(display-delimiter)
(display-test-name (current-test-name))
(display-error)(newline)
(display-exn e)
(display-delimiter))])
(thunk))))
(define current-test-case-around
(make-parameter
test-case-around
(lambda (v)
(if (procedure? v)
v
(raise-type-error 'current-test-case-around "procedure" v)))))
;; test-case-check-handler : (-> exn void)
;;
;; Raise any exceptions that occur in checks, halting
;; evaluation of following expression within the scope of
;; the test case
(define test-case-check-handler raise)
(define-syntax (test-begin stx)
(syntax-case stx ()
[(_ expr ...)
(syntax/loc stx
((current-test-case-around)
(lambda ()
(parameterize
([current-check-handler test-case-check-handler]
[current-check-around check-around])
expr ...))))]
[_
(raise-syntax-error
#f
"Correct form is (test-begin expr ...)"
stx)]))
(define-syntax test-case
(syntax-rules ()
[(test-case name expr ...)
(parameterize
([current-test-name name])
(test-begin expr ...))]))
(define-syntax before
(syntax-rules ()
((_ before-e expr1 expr2 ...)
(dynamic-wind
(lambda ()
before-e)
(lambda ()
expr1 expr2 ...)
(lambda ()
(void))))
((before error ...)
(raise-syntax-error
'before
"Incorrect use of before macro. Correct format is (before before-expr expr1 expr2 ...)"
'before
'(error ...)))))
(define-syntax after
(syntax-rules ()
((_ expr1 expr2 ... after-e)
(dynamic-wind
(lambda ()
(void))
(lambda ()
expr1 expr2 ...)
(lambda ()
after-e)))
((after error ...)
(raise-syntax-error
'before
"Incorrect use of after macro. Correct format is (after expr1 expr2 ... after-expr)"
'after
'(error ...)))))
(define-syntax around
(syntax-rules ()
((_ before-e expr1 expr2 ... after-e)
(dynamic-wind
(lambda ()
before-e)
(lambda ()
expr1 expr2 ...)
(lambda ()
after-e)))
((around error ...)
(raise-syntax-error
'around
"Incorrect use of around macro. Correct format is (around before-expr expr1 expr2 ... after-expr)"
'around
'(error ...)))))

42
collects/schemeunit/test-suite-test.ss Normal file
View File

@ -0,0 +1,42 @@
#lang scheme/base
(require "check.ss"
"test.ss")
(define run? #f)
(define-test-suite define-test
(check = 1 1))
(define/provide-test-suite test-suite-define-provide-test
(check = 1 1))
(define test-suite-tests
(test-suite
"test-suite-tests"
;; We rely on order of evaluation to test that checks are
;; converted to test cases
(test-begin
(check-false run?))
(check-not-exn (lambda () (begin (set! run? #t) run?)))
(test-begin
(check-true run?))
(test-case
"define-test"
(check-pred test-suite? define-test))
(test-case
"test-suite name must be string"
(check-exn exn:fail:contract?
(lambda ()
(test-suite (check = 1 1)))))
))
(provide test-suite-tests)

143
collects/schemeunit/test-suite.ss Normal file
View File

@ -0,0 +1,143 @@
#lang scheme/base
(require (for-syntax scheme/base))
(require "base.ss"
"test-case.ss"
"check.ss")
(provide test-suite
test-suite-test-case-around
test-suite-check-around
delay-test
apply-test-suite
define-test-suite
define/provide-test-suite)
(define (void-thunk) (void))
(define current-seed
(make-parameter
#f
;; Anything goes for the seed
(lambda (v) v)))
(define (test-suite-test-case-around fhere)
(lambda (thunk)
(let* ([name (current-test-name)]
[test (make-schemeunit-test-case name thunk)]
[seed (current-seed)])
(current-seed (fhere test name thunk seed)))))
(define (test-suite-check-around fhere)
(lambda (thunk)
(let* ([name #f]
[test (make-schemeunit-test-case name thunk)]
[seed (current-seed)])
(current-seed (fhere test name thunk seed)))))
(define delayed-test-case-around
(lambda (thunk)
(let ([name (current-test-name)])
(make-schemeunit-test-case name thunk))))
(define delayed-check-around
(lambda (thunk)
(let ([name #f])
(make-schemeunit-test-case name thunk))))
(define-syntax delay-test
(syntax-rules ()
[(delay-test test test1 ...)
(parameterize
([current-test-case-around delayed-test-case-around]
[current-check-around delayed-check-around])
test test1 ...)]))
(define (apply-test-suite suite fdown fup fhere seed)
(let* ([name (schemeunit-test-suite-name suite)]
[tests (schemeunit-test-suite-tests suite)]
[before (schemeunit-test-suite-before suite)]
[after (schemeunit-test-suite-after suite)]
[kid-seed (fdown suite name before after seed)]
[kid-seed ((schemeunit-test-suite-tests suite) fdown fup fhere kid-seed)])
(fup suite name before after seed kid-seed)))
;; test-suite : name [#:before thunk] [#:after thunk] test ...
;; -> test-suite
;;
;; Creates a test-suite with the given name and tests.
;; Setup and teardown actions (thunks) may be specified by
;; preceding the actions with the keyword #:before or
;; #:after.
(define-syntax (test-suite stx)
(syntax-case stx ()
[(test-suite name
#:before before-thunk
#:after after-thunk
test ...)
(syntax
(let ([the-name name]
[the-tests
(lambda (fdown fup fhere seed)
(parameterize
([current-seed seed]
[current-test-case-around (test-suite-test-case-around fhere)]
[current-check-around (test-suite-check-around fhere)])
(let ([t test])
(if (schemeunit-test-suite? t)
(current-seed (apply-test-suite t fdown fup fhere (current-seed)))
t))
... (current-seed)))])
(cond
[(not (string? the-name))
(raise-type-error 'test-suite "test-suite name as string" the-name)]
[else
(make-schemeunit-test-suite
the-name
the-tests
before-thunk
after-thunk)])))]
[(test-suite name
#:before before-thunk
test ...)
(syntax
(test-suite name
#:before before-thunk
#:after void-thunk
test ...))]
[(test-suite name
#:after after-thunk
test ...)
(syntax
(test-suite name
#:before void-thunk
#:after after-thunk
test ...))]
[(test-suite name test ...)
(syntax
(test-suite name
#:before void-thunk
#:after void-thunk
test ...))]))
;;
;; Shortcut helpers
;;
(define-syntax define-test-suite
(syntax-rules ()
[(define-test-suite name test ...)
(define name
(test-suite (symbol->string (quote name))
test ...))]))
(define-syntax define/provide-test-suite
(syntax-rules ()
[(define/provide-test-suite name test ...)
(begin
(define-test-suite name test ...)
(provide name))]))

285
collects/schemeunit/test-test.ss Normal file
View File

@ -0,0 +1,285 @@
#lang scheme/base
(require (for-syntax scheme/base))
(require srfi/1
srfi/13)
(require (file "test.ss")
(file "util.ss")
(file "location.ss"))
(provide test-tests)
(define successful-suite
(test-suite
"Example A"
(test-case
"Example 1"
#t)
(test-case
"Example 2"
#t)
(test-case
"Example 3"
#t)))
(define-check (check-test-results test successes failures errors)
(let ((results (run-test test)))
(check = (length results) (+ successes failures errors))
(check =
(length (filter test-success? results))
successes
"Successes not the expected number")
(check =
(length (filter test-failure? results))
failures
"Failures not the expected number")
(check =
(length (filter test-error? results))
errors
"Errors not the expected number")))
(define-check (check-syntax-error msg sexp)
(let ((destns (make-base-namespace))
(cns (current-namespace)))
(parameterize ((current-namespace destns))
(namespace-require '(file "test.ss"))
(check-exn (lambda (e)
(check-pred exn:fail:syntax? e)
(check string-contains (exn-message e) msg))
(lambda ()
(eval sexp))))))
(define test-tests
(test-suite
"Test tests"
(test-case "Empty test" #t)
(test-case
"After action is executed"
(let ((foo 1))
(after (check = foo 1) (set! foo 2))
(check = foo 2)))
(test-case
"Before action is executed"
(let ((foo 1))
(before (set! foo 2) (check = foo 2))
(check = foo 2)))
(test-case
"After action is executed in presence of exception"
(let ((foo 1))
(check-exn exn?
(lambda ()
(after (error "quit") (set! foo 2))))
(check = foo 2)))
(test-case
"Around action is executed in presence of exception"
(let ((foo 1))
(check-exn exn?
(lambda ()
(around
(set! foo 0)
(check = foo 0)
(error "quit")
(set! foo 2))))
(check = foo 2)))
(test-case
"Before macro catches badly formed syntax w/ helpful message"
(check-syntax-error
"Incorrect use of before macro. Correct format is (before before-expr expr1 expr2 ...)"
'(before 1))
(check-syntax-error
"Incorrect use of before macro. Correct format is (before before-expr expr1 expr2 ...)"
'(before)))
(test-case
"After macro catches badly formed syntax w/ helpful message"
(check-syntax-error
"Incorrect use of after macro. Correct format is (after expr1 expr2 ... after-expr)"
'(after 1))
(check-syntax-error
"Incorrect use of after macro. Correct format is (after expr1 expr2 ... after-expr)"
'(after)))
(test-case
"Around macro catches badly formed syntax w/ helpful message"
(check-syntax-error
"Incorrect use of around macro. Correct format is (around before-expr expr1 expr2 ... after-expr)"
'(around))
(check-syntax-error
"Incorrect use of around macro. Correct format is (around before-expr expr1 expr2 ... after-expr)"
'(around 1))
(check-syntax-error
"Incorrect use of around macro. Correct format is (around before-expr expr1 expr2 ... after-expr)"
'(around 1 2)))
(test-case
"Test around action"
(around (with-output-to-file "test.dat"
(lambda () (display "hello")))
(check-true (file-exists? "test.dat"))
(delete-file "test.dat")))
(test-case
"Before and after on test suite are run"
(let ((foo 1))
(check-equal? foo 1)
(run-test
(test-suite
"Dummy suite"
#:before (lambda () (set! foo 2))
#:after (lambda () (set! foo 3))
(test-case
"Test foo"
(check-equal? foo 2))))
(check-equal? foo 3)))
(test-case
"Before on test suite is run"
(let ((foo 1))
(check-equal? foo 1)
(run-test
(test-suite
"Dummy suite"
#:before (lambda () (set! foo 2))
(test-case
"Test foo"
(check-equal? foo 2))))
(check-equal? foo 2)))
(test-case
"After on test suite is run"
(let ((foo 1))
(check-equal? foo 1)
(run-test
(test-suite
"Dummy suite"
#:after (lambda () (set! foo 3))
(test-case
"Test foo"
(check-equal? foo 2))))
(check-equal? foo 3)))
(test-case
"Test simple foldts"
(check-equal?
'(S (C C C))
(foldts
(lambda (suite name before after seed)
seed)
(lambda (suite name before after seed kid-seed)
(list 'S kid-seed))
(lambda (case name action seed)
(cons 'C seed))
(list)
successful-suite)))
(test-case
"Test fold-test-results"
(andmap
(lambda (result)
(check-pred test-success? result))
(fold-test-results
(lambda (result seed)
(cons result null))
null
successful-suite
#:fdown (lambda (name seed) (check-equal? name "Example A") seed))))
(test-case
"Test run-test"
(let ((result (run-test successful-suite)))
(check = (length result) 3)
(check-true (test-success? (car result)))
(check-true (test-success? (cadr result)))
(check-true (test-success? (caddr result)))))
(test-case
"Shortcuts work as expected"
(delay-test
(check-test-results (test-check "dummy" = 1 1) 1 0 0)
(check-test-results (test-check "dummy" string=? "foo" "bar") 0 1 0)
(check-test-results (test-check "dummy" string=? 'a 'b) 0 0 1)
(check-test-results (test-pred "dummy" number? 1) 1 0 0)
(check-test-results (test-pred "dummy" number? #t) 0 1 0)
(check-test-results (test-pred "dummy" number? (error 'a)) 0 0 1)
(check-test-results (test-equal? "dummy" 1 1) 1 0 0)
(check-test-results (test-equal? "dummy" 1 2) 0 1 0)
(check-test-results (test-equal? "dummy" (error 'a) 2) 0 0 1)
(check-test-results (test-eq? "dummy" 'a 'a) 1 0 0)
(check-test-results (test-eq? "dummy" 'a 'b) 0 1 0)
(check-test-results (test-eq? "dummy" (error 'a) 'a) 0 0 1)
(check-test-results (test-eqv? "dummy" 'a 'a) 1 0 0)
(check-test-results (test-eqv? "dummy" 'a 'b) 0 1 0)
(check-test-results (test-eqv? "dummy" (error 'a) 'a) 0 0 1)
(check-test-results (test-= "dummy" 1.0 1.0 0.001) 1 0 0)
(check-test-results (test-= "dummy" '1.0 1.0 0.0) 0 1 0)
(check-test-results (test-= "dummy" (error 'a) 'a 0.01) 0 0 1)
(check-test-results (test-true "dummy" #t) 1 0 0)
(check-test-results (test-true "dummy" #f) 0 1 0)
(check-test-results (test-true "dummy" (error 'a)) 0 0 1)
(check-test-results (test-false "dummy" #f) 1 0 0)
(check-test-results (test-false "dummy" #t) 0 1 0)
(check-test-results (test-false "dummy" (error 'a)) 0 0 1)
(check-test-results (test-not-false "dummy" 1) 1 0 0)
(check-test-results (test-not-false "dummy" #f) 0 1 0)
(check-test-results (test-not-false "dummy" (error 'a)) 0 0 1)
(check-test-results
(test-exn "dummy" exn? (lambda () (error 'a))) 1 0 0)
(check-test-results
(test-exn "dummy" exn? (lambda () 1)) 0 1 0)
(check-test-results
(test-exn "dummy" (lambda (exn) (error 'a)) (lambda () (error 'a))) 0 0 1)
(check-test-results
(test-not-exn "dummy" (lambda () 2)) 1 0 0)
(check-test-results
(test-not-exn "dummy" (lambda () (error 'a))) 0 1 0)))
(test-case
"test-case captures location"
(let ([failure
(car
(run-test
(delay-test (test-case "dummy" (check-equal? 1 2)))))])
(check-pred test-failure? failure)
(let* ([stack (exn:test:check-stack
(test-failure-result failure))]
[loc (check-info-value
(car (filter check-location? stack)))])
(check-regexp-match #rx"test-test\\.ss" (location->string loc)))))
(test-case
"Shortcuts capture location"
(let ((failure
(car
(run-test
(delay-test (test-equal? "dummy" 1 2))))))
(check-pred test-failure? failure)
(let* ((stack (exn:test:check-stack
(test-failure-result failure)))
(loc (check-info-value
(car (filter check-location? stack)))))
(check-regexp-match #rx"test-test\\.ss" (location->string loc)))))
(test-case
"All names that should be exported are exported"
check-info?
check-info-name
check-info-value)
))

158
collects/schemeunit/test.ss Normal file
View File

@ -0,0 +1,158 @@
#lang scheme/base
(require (for-syntax scheme/base))
(require "base.ss"
"check.ss"
"check-info.ss"
"result.ss"
"test-case.ss"
"test-suite.ss"
"util.ss")
(provide (struct-out exn:test:check)
(struct-out check-info)
(struct-out test-result)
(struct-out test-failure)
(struct-out test-error)
(struct-out test-success)
(struct-out schemeunit-test-case)
(struct-out schemeunit-test-suite)
with-check-info
with-check-info*
make-check-name
make-check-params
make-check-location
make-check-expression
make-check-message
make-check-actual
make-check-expected
check-name?
check-params?
check-location?
check-expression?
check-message?
check-actual?
check-expected?
test-begin
test-case
test-suite
delay-test
(rename-out [schemeunit-test-case? test-case?]
[schemeunit-test-suite? test-suite?])
define-test-suite
define/provide-test-suite
test-suite*
before
after
around
require/expose
define-shortcut
test-check
test-pred
test-equal?
test-eq?
test-eqv?
test-=
test-true
test-false
test-not-false
test-exn
test-not-exn
foldts
fold-test-results
run-test-case
run-test
fail-check
define-check
define-simple-check
define-binary-check
check
check-exn
check-not-exn
check-true
check-false
check-pred
check-eq?
check-eqv?
check-equal?
check-=
check-not-false
check-not-eq?
check-not-equal?
check-regexp-match
fail)
(define (void-thunk) (void))
(define-syntax (define-shortcut stx)
(syntax-case stx ()
[(_ (name param ...) expr)
(with-syntax ([expected-form (syntax->datum
#`(#,(syntax name)
test-desc
#,@(syntax (param ...))))])
(syntax/loc stx
(define-syntax (name name-stx)
(syntax-case name-stx ()
[(name test-desc param ...)
(with-syntax ([name-expr (syntax/loc name-stx expr)])
(syntax/loc name-stx
(test-case test-desc name-expr)))]
[_
(raise-syntax-error
#f
(format "Correct form is ~a" (quote expected-form))
name-stx)]))))]
[_
(raise-syntax-error
#f
"Correct form is (define-shortcut (name param ...) expr)"
stx)]))
(define-shortcut (test-check operator expr1 expr2)
(check operator expr1 expr2))
(define-shortcut (test-pred pred expr)
(check-pred pred expr))
(define-shortcut (test-equal? expr1 expr2)
(check-equal? expr1 expr2))
(define-shortcut (test-eq? expr1 expr2)
(check-eq? expr1 expr2))
(define-shortcut (test-eqv? expr1 expr2)
(check-eqv? expr1 expr2))
(define-shortcut (test-= expr1 expr2 epsilon)
(check-= expr1 expr2 epsilon))
(define-shortcut (test-true expr)
(check-true expr))
(define-shortcut (test-false expr)
(check-false expr))
(define-shortcut (test-not-false expr)
(check-not-false expr))
(define-shortcut (test-exn pred thunk)
(check-exn pred thunk))
(define-shortcut (test-not-exn thunk)
(check-not-exn thunk))

221
collects/schemeunit/text-ui-test.ss Normal file
View File

@ -0,0 +1,221 @@
;;;
;;; Time-stamp: <2008-07-31 10:11:42 noel>
;;;
;;; Copyright (C) 2005 by Noel Welsh.
;;;
;;; This library is free software; you can redistribute it
;;; and/or modify it under the terms of the GNU Lesser
;;; General Public License as published by the Free Software
;;; Foundation; either version 2.1 of the License, or (at
;;; your option) any later version.
;;; This library is distributed in the hope that it will be
;;; useful, but WITHOUT ANY WARRANTY; without even the
;;; implied warranty of MERCHANTABILITY or FITNESS FOR A
;;; PARTICULAR PURPOSE. See the GNU Lesser General Public
;;; License for more details.
;;; You should have received a copy of the GNU Lesser
;;; General Public License along with this library; if not,
;;; write to the Free Software Foundation, Inc., 59 Temple
;;; Place, Suite 330, Boston, MA 02111-1307 USA
;;; Author: Noel Welsh <noelwelsh@yahoo.com>
;;
;;
;; Commentary:
#lang scheme/base
(require scheme/runtime-path
srfi/1
srfi/13)
(require "test.ss"
"text-ui.ss")
(provide text-ui-tests)
;; Reimplement with-output-to-string to avoid dependency on
;; io.plt, which in turn depends on SchemeUnit 1.2, which
;; has not been ported to PLT 4.
(define-syntax with-output-to-string
(syntax-rules ()
[(with-output-to-string expr ...)
(let ([p (open-output-string)])
(parameterize ([current-output-port p])
expr ...)
(get-output-string p))]))
(define-runtime-path here ".")
;; with-silent-output (() -> any) -> any
(define (with-silent-output thunk)
(let ((op (open-output-string)))
(parameterize ((current-output-port op))
(thunk))))
(define (failing-test)
(run-tests
(test-suite
"Dummy"
(test-case "Dummy" (check-equal? 1 2)))))
(define (failing-binary-test/complex-params)
(run-tests
(test-suite
"Dummy"
(test-case "Dummy"
(check-equal?
(list (iota 15) (iota 15) (iota 15))
1)))))
(define (failing-test/complex-params)
(run-tests
(test-suite
"Dummy"
(test-case "Dummy"
(check-false
(list (iota 15) (iota 15) (iota 15)))))))
(define (quiet-failing-test)
(run-tests
(test-suite
"Dummy"
(test-case "Dummy" (check-equal? 1 2)))
'quiet))
(define (quiet-error-test)
(run-tests
(test-suite
"Dummy"
(test-case "Dummy" (error "kabloom!")))
'quiet))
(define text-ui-tests
(test-suite
"All tests for text-ui"
(test-case
"Binary check displays actual and expected in failure error message"
(let ((op (with-output-to-string (failing-test))))
(check string-contains
op
"expected")
(check string-contains
op
"actual")))
(test-case
"Binary check doesn't display params"
(let ((op (with-output-to-string (failing-test))))
(check (lambda (out str) (not (string-contains out str)))
op
"params")))
(test-case
"Binary check output is pretty printed"
(let ([op (with-output-to-string (failing-binary-test/complex-params))])
(check string-contains
op
"((0 1 2 3 4 5 6 7 8 9 10 11 12 13 14)
(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14)
(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14))")))
(test-case
"Non-binary check output is pretty printed"
(let ([op (with-output-to-string (failing-test/complex-params))])
(check string-contains
op
"((0 1 2 3 4 5 6 7 8 9 10 11 12 13 14)
(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14)
(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14))")))
(test-case
"Location trimmed when file is under current directory"
(parameterize ((current-directory here))
(let ((op (with-output-to-string (failing-test))))
(check string-contains
op
"location: text-ui-test.ss"))))
(test-case
"Name and location displayed before actual/expected"
(let ((op (with-output-to-string (failing-test))))
(let ((name-idx (string-contains op "name:"))
(loc-idx (string-contains op "location:"))
(actual-idx (string-contains op "actual:"))
(expected-idx (string-contains op "expected:")))
(check < name-idx loc-idx)
(check < loc-idx actual-idx)
(check < actual-idx expected-idx))))
(test-case
"Quiet mode is quiet"
(let ((op1 (with-output-to-string (quiet-failing-test)))
(op2 (with-output-to-string (quiet-error-test))))
(check string=?
op1
"0 success(es) 1 failure(s) 0 error(s) 1 test(s) run\n")
(check string=?
op2
"0 success(es) 0 failure(s) 1 error(s) 1 test(s) run\n")))
(test-case
"Number of unsuccessful tests returned"
(check-equal? (with-silent-output failing-test) 1)
(check-equal? (with-silent-output quiet-failing-test) 1)
(check-equal? (with-silent-output quiet-error-test) 1)
(check-equal? (with-silent-output
(lambda ()
(run-tests
(test-suite
"Dummy"
(test-case "Dummy" (check-equal? 1 1)))
'quiet)))
0))
(test-case
"run-tests runs suite before/after actions in quiet mode"
(let ([foo 1])
(run-tests
(test-suite
"Foo"
#:before (lambda () (set! foo 2))
#:after (lambda () (set! foo 3))
(test-case
"Foo check"
(check = foo 2)))
'quiet)
(check = foo 3)))
(test-case
"run-tests runs suite before/after actions in normal mode"
(let ([foo 1])
(run-tests
(test-suite
"Foo"
#:before (lambda () (set! foo 2))
#:after (lambda () (set! foo 3))
(test-case
"Foo check"
(check = foo 2)))
'normal)
(check = foo 3)))
(test-case
"run-tests runs suite before/after actions in verbose mode"
(let ([foo 1])
(run-tests
(test-suite
"Foo"
#:before (lambda () (set! foo 2))
#:after (lambda () (set! foo 3))
(test-case
"Foo check"
(check = foo 2)))
'verbose)
(check = foo 3)))
))

55
collects/schemeunit/text-ui-util-test.ss Normal file
View File

@ -0,0 +1,55 @@
;;;
;;; Time-stamp: <2008-06-19 21:08:18 noel>
;;;
;;; Copyright (C) by Noel Welsh.
;;;
;;; This library is free software; you can redistribute it
;;; and/or modify it under the terms of the GNU Lesser
;;; General Public License as published by the Free Software
;;; Foundation; either version 2.1 of the License, or (at
;;; your option) any later version.
;;; This library is distributed in the hope that it will be
;;; useful, but WITHOUT ANY WARRANTY; without even the
;;; implied warranty of MERCHANTABILITY or FITNESS FOR A
;;; PARTICULAR PURPOSE. See the GNU Lesser General Public
;;; License for more details.
;;; You should have received a copy of the GNU Lesser
;;; General Public License along with this library; if not,
;;; write to the Free Software Foundation, Inc., 59 Temple
;;; Place, Suite 330, Boston, MA 02111-1307 USA
;;; Author: Noel Welsh <noelwelsh@yahoo.com>
;;
;;
;; Commentary:
#lang scheme/base
(require "test.ss")
(require "text-ui-util.ss")
(provide text-ui-util-tests)
(define text-ui-util-tests
(test-suite
"All tests for text-ui-util"
(test-equal?
"trim-current-directory leaves directories outside the current directory alone"
(trim-current-directory "/foo/bar/")
"/foo/bar/")
(test-equal?
"trim-current-directory strips directory from files in current directory"
(trim-current-directory
(path->string (build-path (current-directory) "foo.ss")))
"foo.ss")
(test-equal?
"trim-current-directory leaves subdirectories alone"
(trim-current-directory
(path->string (build-path (current-directory) "foo" "bar.ss")))
"foo/bar.ss")
))

40
collects/schemeunit/text-ui-util.ss Normal file
View File

@ -0,0 +1,40 @@
;;;
;;; Time-stamp: <2008-06-19 21:14:36 noel>
;;;
;;; Copyright (C) by Noel Welsh.
;;;
;;; This library is free software; you can redistribute it
;;; and/or modify it under the terms of the GNU Lesser
;;; General Public License as published by the Free Software
;;; Foundation; either version 2.1 of the License, or (at
;;; your option) any later version.
;;; This library is distributed in the hope that it will be
;;; useful, but WITHOUT ANY WARRANTY; without even the
;;; implied warranty of MERCHANTABILITY or FITNESS FOR A
;;; PARTICULAR PURPOSE. See the GNU Lesser General Public
;;; License for more details.
;;; You should have received a copy of the GNU Lesser
;;; General Public License along with this library; if not,
;;; write to the Free Software Foundation, Inc., 59 Temple
;;; Place, Suite 330, Boston, MA 02111-1307 USA
;;; Author: Noel Welsh <noelwelsh@yahoo.com>
;;
;;
;; Commentary:
#lang scheme/base
(require (only-in srfi/13 string-contains string-drop))
(provide trim-current-directory)
;; trim-current-directory : string -> string
(define (trim-current-directory path)
(let ((cd (path->string (current-directory))))
(regexp-replace (regexp-quote cd) path "")))

247
collects/schemeunit/text-ui.ss Normal file
View File

@ -0,0 +1,247 @@
;;;
;;; Time-stamp: <2008-08-08 21:38:07 noel>
;;;
;;; Copyright (C) 2005 by Noel Welsh.
;;;
;;; This library is free software; you can redistribute it
;;; and/or modify it under the terms of the GNU Lesser
;;; General Public License as published by the Free Software
;;; Foundation; either version 2.1 of the License, or (at
;;; your option) any later version.
;;; This library is distributed in the hope that it will be
;;; useful, but WITHOUT ANY WARRANTY; without even the
;;; implied warranty of MERCHANTABILITY or FITNESS FOR A
;;; PARTICULAR PURPOSE. See the GNU Lesser General Public
;;; License for more details.
;;; You should have received a copy of the GNU Lesser
;;; General Public License along with this library; if not,
;;; write to the Free Software Foundation, Inc., 59 Temple
;;; Place, Suite 330, Boston, MA 02111-1307 USA
;;; Author: Noel Welsh <noelwelsh@yahoo.com>
;;
;;
;; Commentary:
#lang scheme/base
(require scheme/match
scheme/pretty
srfi/13
srfi/26)
(require "base.ss"
"counter.ss"
"format.ss"
"location.ss"
"result.ss"
"test.ss"
"monad.ss"
"hash-monad.ss"
"name-collector.ss"
"text-ui-util.ss")
(provide run-tests
display-context
display-exn
display-summary+return
display-ticker
display-result)
;; display-ticker : test-result -> void
;;
;; Prints a summary of the test result
(define (display-ticker result)
(cond
((test-error? result)
(display "!"))
((test-failure? result)
(display "-"))
(else
(display "."))))
;; display-test-preamble : test-result -> (hash-monad-of void)
(define (display-test-preamble result)
(lambda (hash)
(if (test-success? result)
hash
(begin
(display-delimiter)
hash))))
;; display-test-postamble : test-result -> (hash-monad-of void)
(define (display-test-postamble result)
(lambda (hash)
(if (test-success? result)
hash
(begin
(display-delimiter)
hash))))
;; display-result : test-result -> void
(define (display-result result)
(cond
((test-error? result)
(display-test-name (test-result-test-case-name result))
(display-error)
(newline))
((test-failure? result)
(display-test-name (test-result-test-case-name result))
(display-failure)
(newline))
(else
(void))))
;; strip-redundant-parms : (list-of check-info) -> (list-of check-info)
;;
;; Strip any check-params? is there is an
;; actual/expected check-info in the same stack frame. A
;; stack frame is delimited by occurrence of a check-name?
(define (strip-redundant-params stack)
(define (binary-check-this-frame? stack)
(let loop ([stack stack])
(cond
[(null? stack) #f]
[(check-name? (car stack)) #f]
[(check-actual? (car stack)) #t]
[else (loop (cdr stack))])))
(let loop ([stack stack])
(cond
[(null? stack) null]
[(check-params? (car stack))
(if (binary-check-this-frame? stack)
(loop (cdr stack))
(cons (car stack) (loop (cdr stack))))]
[else (cons (car stack) (loop (cdr stack)))])))
;; display-context : test-result [(U #t #f)] -> void
(define (display-context result [verbose? #f])
(cond
[(test-failure? result)
(let* ([exn (test-failure-result result)]
[stack (exn:test:check-stack exn)])
(for-each
(lambda (info)
(cond
[(check-name? info)
(display-check-info info)]
[(check-location? info)
(display-check-info-name-value
'location
(trim-current-directory
(location->string
(check-info-value info)))
display)]
[(check-params? info)
(display-check-info-name-value
'params
(check-info-value info)
(lambda (v) (map pretty-print v)))]
[(check-actual? info)
(display-check-info-name-value
'actual
(check-info-value info)
pretty-print)]
[(check-expected? info)
(display-check-info-name-value
'expected
(check-info-value info)
pretty-print)]
[(and (check-expression? info)
(not verbose?))
(void)]
[else
(display-check-info info)]))
(if verbose?
stack
(strip-redundant-params stack))))]
[(test-error? result)
(display-exn (test-error-result result))]
[else (void)]))
;; display-verbose-check-info : test-result -> void
(define (display-verbose-check-info result)
(cond
((test-failure? result)
(let* ((exn (test-failure-result result))
(stack (exn:test:check-stack exn)))
(for-each
(lambda (info)
(cond
((check-location? info)
(display "location: ")
(display (trim-current-directory
(location->string
(check-info-value info)))))
(else
(display (check-info-name info))
(display ": ")
(write (check-info-value info))))
(newline))
stack)))
((test-error? result)
(display-exn (test-error-result result)))
(else
(void))))
(define (std-test/text-ui display-context test)
(begin0 (fold-test-results
(lambda (result seed)
((sequence* (update-counter! result)
(display-test-preamble result)
(display-test-case-name result)
(lambda (hash)
(display-result result)
(display-context result)
hash)
(display-test-postamble result))
seed))
((sequence
(put-initial-counter)
(put-initial-name))
(make-empty-hash))
test
#:fdown (lambda (name seed) ((push-suite-name! name) seed))
#:fup (lambda (name kid-seed) ((pop-suite-name!) kid-seed)))))
(define (display-summary+return monad)
(monad-value
((compose
(sequence*
(display-counter)
(counter->vector))
(match-lambda
((vector s f e)
(return-hash (+ f e)))))
monad)))
;; run-tests : test [(U 'quiet 'normal 'verbose)] -> integer
(define (run-tests test [mode 'normal])
(monad-value
((compose
(sequence*
(display-counter)
(counter->vector))
(match-lambda
((vector s f e)
(return-hash (+ f e)))))
(case mode
((quiet)
(fold-test-results
(lambda (result seed)
((update-counter! result) seed))
((put-initial-counter)
(make-empty-hash))
test))
((normal) (std-test/text-ui display-context test))
((verbose) (std-test/text-ui
(cut display-context <> #t)
test))))))

51
collects/schemeunit/util-test.ss Normal file
View File

@ -0,0 +1,51 @@
#lang scheme/base
(require
(file "test.ss")
(file "util.ss"))
(provide util-tests)
;; FIXME: Two problems
;; 1 - This is not the way to test require/expose: if this fails, it
;; prevents the tests from loading.
;; 2 - For whatever reason, it *does* fail when loaded via PLaneT.
;; Still waiting for resolution on a bug report.
(require/expose "check-test.ss" (make-failure-test))
(define util-tests
(test-suite
"Util tests"
(test-case
"make-failure-test required from check-test.ss"
(begin
(check-true (procedure? make-failure-test))
(check-equal? (make-arity-at-least 2)
(procedure-arity make-failure-test))
(check-pred schemeunit-test-case?
(delay-test (make-failure-test "foo" string?)))))
(test-case
"Test test-suite*"
(let ((result
(run-test
(test-suite*
"Test test-suite*"
("Test 1" (check = 1 1))
("Test 2" (check = 1 1) (check = 2 4))))))
(check = (length result) 2)
(check-true (test-success? (car result)))
(check-true (test-failure? (cadr result)))))
(test-case
"Simple check-regexp test"
(check-regexp-match "a*bba"
"aaaaaabba"))
(test-case
"check-regexp-match failure"
(check-exn
exn:test:check?
(lambda ()
(check-regexp-match "a+bba" "aaaabbba"))))
))

77
collects/schemeunit/util.ss Normal file
View File

@ -0,0 +1,77 @@
;;;
;;; Time-stamp: <2008-07-28 12:51:11 nhw>
;;;
;;; Copyright (C) 2004 by Noel Welsh.
;;;
;;; This library is free software; you can redistribute it
;;; and/or modify it under the terms of the GNU Lesser
;;; General Public License as published by the Free Software
;;; Foundation; either version 2.1 of the License, or (at
;;; your option) any later version.
;;; Web testingis distributed in the hope that it will be
;;; useful, but WITHOUT ANY WARRANTY; without even the
;;; implied warranty of MERCHANTABILITY or FITNESS FOR A
;;; PARTICULAR PURPOSE. See the GNU Lesser General Public
;;; License for more details.
;;; You should have received a copy of the GNU Lesser
;;; General Public License along with Web testing; if not,
;;; write to the Free Software Foundation, Inc., 59 Temple
;;; Place, Suite 330, Boston, MA 02111-1307 USA
;;; Author: Noel Welsh <noelwelsh@yahoo.com>
;;
;;
;; Commentary:
#lang scheme/base
(require (for-syntax scheme/base))
(require mzlib/etc)
(require "check.ss"
"test-suite.ss"
"test-case.ss")
(provide require/expose
test-suite*
check-regexp-match)
;; Requires a module and exposes some of its unprovided
;; (non-syntax!) identifiers.
;; USAGE: (require/expose MODULE-NAME (IDS ...))
;; where MODULE-NAME is as in the MzScheme manual (i.e.,
;; a standard module spec) and IDS are the un-provided
;; identifiers that you wish to expose in the current
;; module.
(define-syntax (require/expose stx)
(syntax-case stx ()
[(_ mod (ids ...))
(quasisyntax/loc stx
(begin
(require (only-in mod))
(define-values (ids ...)
(parameterize
([current-load-relative-directory
#,(datum->syntax
stx
`(,#'this-expression-source-directory)
stx)])
(let ([ns (module->namespace 'mod)])
(parameterize ([current-namespace ns])
(values
(namespace-variable-value 'ids)...)))))))]))
(define-syntax test-suite*
(syntax-rules ()
((test-suite* name (case-name case-body ...) ...)
(test-suite
name
(test-case case-name case-body ...) ...))))
(define-simple-check (check-regexp-match regex string)
(regexp-match regex string))