From e2dfd041994d7b12ab09af75094ad2964f64db18 Mon Sep 17 00:00:00 2001 From: Noel Welsh Date: Wed, 25 Mar 2009 12:34:52 +0000 Subject: [PATCH] Initial import of SchemeUnit into PLT trunk svn: r14263 original commit: 242c28a0b6cb88dfd908bc6751815a25ae4e97fe --- collects/schemeunit/all-schemeunit-tests.ss | 54 +++ collects/schemeunit/base-test.ss | 84 +++++ collects/schemeunit/base.ss | 52 +++ collects/schemeunit/check-info-test.ss | 80 ++++ collects/schemeunit/check-info.ss | 65 ++++ collects/schemeunit/check-test.ss | 323 ++++++++++++++++ collects/schemeunit/check.ss | 269 ++++++++++++++ collects/schemeunit/counter-test.ss | 61 ++++ collects/schemeunit/counter.ss | 96 +++++ collects/schemeunit/format-test.ss | 24 ++ collects/schemeunit/format.ss | 70 ++++ collects/schemeunit/hash-monad-test.ss | 80 ++++ collects/schemeunit/hash-monad.ss | 53 +++ collects/schemeunit/location-test.ss | 97 +++++ collects/schemeunit/location.ss | 49 +++ collects/schemeunit/monad-test.ss | 128 +++++++ collects/schemeunit/monad.ss | 65 ++++ collects/schemeunit/name-collector.ss | 77 ++++ collects/schemeunit/result-test.ss | 45 +++ collects/schemeunit/result.ss | 135 +++++++ .../scribblings/acknowledgements.scrbl | 45 +++ collects/schemeunit/scribblings/api.scrbl | 17 + collects/schemeunit/scribblings/base.ss | 16 + collects/schemeunit/scribblings/check.scrbl | 344 ++++++++++++++++++ .../scribblings/compound-testing.scrbl | 168 +++++++++ .../schemeunit/scribblings/control-flow.scrbl | 52 +++ collects/schemeunit/scribblings/file-test.scm | 24 ++ collects/schemeunit/scribblings/file.scm | 14 + .../schemeunit/scribblings/overview.scrbl | 15 + .../schemeunit/scribblings/philosophy.scrbl | 118 ++++++ .../schemeunit/scribblings/quick-start.scrbl | 166 +++++++++ .../scribblings/release-notes.scrbl | 41 +++ .../schemeunit/scribblings/schemeunit.scrbl | 21 ++ collects/schemeunit/scribblings/ui.scrbl | 35 ++ collects/schemeunit/standalone-check-test.ss | 54 +++ .../schemeunit/standalone-test-case-test.ss | 20 + collects/schemeunit/test-case-test.ss | 57 +++ collects/schemeunit/test-case.ss | 143 ++++++++ collects/schemeunit/test-suite-test.ss | 42 +++ collects/schemeunit/test-suite.ss | 143 ++++++++ collects/schemeunit/test-test.ss | 285 +++++++++++++++ collects/schemeunit/test.ss | 158 ++++++++ collects/schemeunit/text-ui-test.ss | 221 +++++++++++ collects/schemeunit/text-ui-util-test.ss | 55 +++ collects/schemeunit/text-ui-util.ss | 40 ++ collects/schemeunit/text-ui.ss | 247 +++++++++++++ collects/schemeunit/util-test.ss | 51 +++ collects/schemeunit/util.ss | 77 ++++ 48 files changed, 4576 insertions(+) create mode 100644 collects/schemeunit/all-schemeunit-tests.ss create mode 100644 collects/schemeunit/base-test.ss create mode 100644 collects/schemeunit/base.ss create mode 100644 collects/schemeunit/check-info-test.ss create mode 100644 collects/schemeunit/check-info.ss create mode 100644 collects/schemeunit/check-test.ss create mode 100644 collects/schemeunit/check.ss create mode 100644 collects/schemeunit/counter-test.ss create mode 100644 collects/schemeunit/counter.ss create mode 100644 collects/schemeunit/format-test.ss create mode 100644 collects/schemeunit/format.ss create mode 100644 collects/schemeunit/hash-monad-test.ss create mode 100644 collects/schemeunit/hash-monad.ss create mode 100644 collects/schemeunit/location-test.ss create mode 100644 collects/schemeunit/location.ss create mode 100644 collects/schemeunit/monad-test.ss create mode 100644 collects/schemeunit/monad.ss create mode 100644 collects/schemeunit/name-collector.ss create mode 100644 collects/schemeunit/result-test.ss create mode 100644 collects/schemeunit/result.ss create mode 100644 collects/schemeunit/scribblings/acknowledgements.scrbl create mode 100644 collects/schemeunit/scribblings/api.scrbl create mode 100644 collects/schemeunit/scribblings/base.ss create mode 100644 collects/schemeunit/scribblings/check.scrbl create mode 100644 collects/schemeunit/scribblings/compound-testing.scrbl create mode 100644 collects/schemeunit/scribblings/control-flow.scrbl create mode 100644 collects/schemeunit/scribblings/file-test.scm create mode 100644 collects/schemeunit/scribblings/file.scm create mode 100644 collects/schemeunit/scribblings/overview.scrbl create mode 100644 collects/schemeunit/scribblings/philosophy.scrbl create mode 100644 collects/schemeunit/scribblings/quick-start.scrbl create mode 100644 collects/schemeunit/scribblings/release-notes.scrbl create mode 100644 collects/schemeunit/scribblings/schemeunit.scrbl create mode 100644 collects/schemeunit/scribblings/ui.scrbl create mode 100644 collects/schemeunit/standalone-check-test.ss create mode 100644 collects/schemeunit/standalone-test-case-test.ss create mode 100644 collects/schemeunit/test-case-test.ss create mode 100644 collects/schemeunit/test-case.ss create mode 100644 collects/schemeunit/test-suite-test.ss create mode 100644 collects/schemeunit/test-suite.ss create mode 100644 collects/schemeunit/test-test.ss create mode 100644 collects/schemeunit/test.ss create mode 100644 collects/schemeunit/text-ui-test.ss create mode 100644 collects/schemeunit/text-ui-util-test.ss create mode 100644 collects/schemeunit/text-ui-util.ss create mode 100644 collects/schemeunit/text-ui.ss create mode 100644 collects/schemeunit/util-test.ss create mode 100644 collects/schemeunit/util.ss diff --git a/collects/schemeunit/all-schemeunit-tests.ss b/collects/schemeunit/all-schemeunit-tests.ss new file mode 100644 index 0000000..e296bea --- /dev/null +++ b/collects/schemeunit/all-schemeunit-tests.ss @@ -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 "<>")) + )) + diff --git a/collects/schemeunit/base-test.ss b/collects/schemeunit/base-test.ss new file mode 100644 index 0000000..5219fd4 --- /dev/null +++ b/collects/schemeunit/base-test.ss @@ -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 +;; +;; +;; 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)))) + )) + diff --git a/collects/schemeunit/base.ss b/collects/schemeunit/base.ss new file mode 100644 index 0000000..0d52744 --- /dev/null +++ b/collects/schemeunit/base.ss @@ -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)) diff --git a/collects/schemeunit/check-info-test.ss b/collects/schemeunit/check-info-test.ss new file mode 100644 index 0000000..b578a06 --- /dev/null +++ b/collects/schemeunit/check-info-test.ss @@ -0,0 +1,80 @@ +;;; +;;; ---- 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 +;; +;; +;; 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)) + + )) + diff --git a/collects/schemeunit/check-info.ss b/collects/schemeunit/check-info.ss new file mode 100644 index 0000000..dda1c49 --- /dev/null +++ b/collects/schemeunit/check-info.ss @@ -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)) diff --git a/collects/schemeunit/check-test.ss b/collects/schemeunit/check-test.ss new file mode 100644 index 0000000..1e5d1ff --- /dev/null +++ b/collects/schemeunit/check-test.ss @@ -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 +;; +;; +;; 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)) + )) + diff --git a/collects/schemeunit/check.ss b/collects/schemeunit/check.ss new file mode 100644 index 0000000..af1219b --- /dev/null +++ b/collects/schemeunit/check.ss @@ -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) + diff --git a/collects/schemeunit/counter-test.ss b/collects/schemeunit/counter-test.ss new file mode 100644 index 0000000..d6cc563 --- /dev/null +++ b/collects/schemeunit/counter-test.ss @@ -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 +;; +;; +;; 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))) + )) + diff --git a/collects/schemeunit/counter.ss b/collects/schemeunit/counter.ss new file mode 100644 index 0000000..aa56f64 --- /dev/null +++ b/collects/schemeunit/counter.ss @@ -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 +;; +;; +;; 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))) diff --git a/collects/schemeunit/format-test.ss b/collects/schemeunit/format-test.ss new file mode 100644 index 0000000..ec8164d --- /dev/null +++ b/collects/schemeunit/format-test.ss @@ -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")))) + )) diff --git a/collects/schemeunit/format.ss b/collects/schemeunit/format.ss new file mode 100644 index 0000000..88dbe48 --- /dev/null +++ b/collects/schemeunit/format.ss @@ -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))) + diff --git a/collects/schemeunit/hash-monad-test.ss b/collects/schemeunit/hash-monad-test.ss new file mode 100644 index 0000000..40a0e36 --- /dev/null +++ b/collects/schemeunit/hash-monad-test.ss @@ -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 +;; +;; +;; 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))) + + )) + diff --git a/collects/schemeunit/hash-monad.ss b/collects/schemeunit/hash-monad.ss new file mode 100644 index 0000000..cada8c6 --- /dev/null +++ b/collects/schemeunit/hash-monad.ss @@ -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 +;; +;; +;; 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))) + diff --git a/collects/schemeunit/location-test.ss b/collects/schemeunit/location-test.ss new file mode 100644 index 0000000..7e156f7 --- /dev/null +++ b/collects/schemeunit/location-test.ss @@ -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 +;; +;; +;; 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:?:?")) + )) + diff --git a/collects/schemeunit/location.ss b/collects/schemeunit/location.ss new file mode 100644 index 0000000..28b4414 --- /dev/null +++ b/collects/schemeunit/location.ss @@ -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) + "?")) + diff --git a/collects/schemeunit/monad-test.ss b/collects/schemeunit/monad-test.ss new file mode 100644 index 0000000..fbc90c6 --- /dev/null +++ b/collects/schemeunit/monad-test.ss @@ -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 +;; +;; +;; 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)))) + + )) + diff --git a/collects/schemeunit/monad.ss b/collects/schemeunit/monad.ss new file mode 100644 index 0000000..6bde98c --- /dev/null +++ b/collects/schemeunit/monad.ss @@ -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 +;; +;; +;; 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))))) diff --git a/collects/schemeunit/name-collector.ss b/collects/schemeunit/name-collector.ss new file mode 100644 index 0000000..cf225b9 --- /dev/null +++ b/collects/schemeunit/name-collector.ss @@ -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 +;; +;; +;; 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))))) + diff --git a/collects/schemeunit/result-test.ss b/collects/schemeunit/result-test.ss new file mode 100644 index 0000000..b94924c --- /dev/null +++ b/collects/schemeunit/result-test.ss @@ -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) + )) diff --git a/collects/schemeunit/result.ss b/collects/schemeunit/result.ss new file mode 100644 index 0000000..c9ad329 --- /dev/null +++ b/collects/schemeunit/result.ss @@ -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 +;; +;; +;; 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))) + diff --git a/collects/schemeunit/scribblings/acknowledgements.scrbl b/collects/schemeunit/scribblings/acknowledgements.scrbl new file mode 100644 index 0000000..da36a25 --- /dev/null +++ b/collects/schemeunit/scribblings/acknowledgements.scrbl @@ -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} +} diff --git a/collects/schemeunit/scribblings/api.scrbl b/collects/schemeunit/scribblings/api.scrbl new file mode 100644 index 0000000..0bcb5fe --- /dev/null +++ b/collects/schemeunit/scribblings/api.scrbl @@ -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"] + + diff --git a/collects/schemeunit/scribblings/base.ss b/collects/schemeunit/scribblings/base.ss new file mode 100644 index 0000000..4c952bf --- /dev/null +++ b/collects/schemeunit/scribblings/base.ss @@ -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")))) \ No newline at end of file diff --git a/collects/schemeunit/scribblings/check.scrbl b/collects/schemeunit/scribblings/check.scrbl new file mode 100644 index 0000000..1883b00 --- /dev/null +++ b/collects/schemeunit/scribblings/check.scrbl @@ -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: } + +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. } diff --git a/collects/schemeunit/scribblings/compound-testing.scrbl b/collects/schemeunit/scribblings/compound-testing.scrbl new file mode 100644 index 0000000..870c3fe --- /dev/null +++ b/collects/schemeunit/scribblings/compound-testing.scrbl @@ -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.} diff --git a/collects/schemeunit/scribblings/control-flow.scrbl b/collects/schemeunit/scribblings/control-flow.scrbl new file mode 100644 index 0000000..08a6506 --- /dev/null +++ b/collects/schemeunit/scribblings/control-flow.scrbl @@ -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.} diff --git a/collects/schemeunit/scribblings/file-test.scm b/collects/schemeunit/scribblings/file-test.scm new file mode 100644 index 0000000..42c6e6e --- /dev/null +++ b/collects/schemeunit/scribblings/file-test.scm @@ -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))) diff --git a/collects/schemeunit/scribblings/file.scm b/collects/schemeunit/scribblings/file.scm new file mode 100644 index 0000000..80c37e9 --- /dev/null +++ b/collects/schemeunit/scribblings/file.scm @@ -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-*) \ No newline at end of file diff --git a/collects/schemeunit/scribblings/overview.scrbl b/collects/schemeunit/scribblings/overview.scrbl new file mode 100644 index 0000000..0cf7555 --- /dev/null +++ b/collects/schemeunit/scribblings/overview.scrbl @@ -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.} +] diff --git a/collects/schemeunit/scribblings/philosophy.scrbl b/collects/schemeunit/scribblings/philosophy.scrbl new file mode 100644 index 0000000..d1c4949 --- /dev/null +++ b/collects/schemeunit/scribblings/philosophy.scrbl @@ -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. diff --git a/collects/schemeunit/scribblings/quick-start.scrbl b/collects/schemeunit/scribblings/quick-start.scrbl new file mode 100644 index 0000000..61f8de1 --- /dev/null +++ b/collects/schemeunit/scribblings/quick-start.scrbl @@ -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: (# 14 6 252 22) +expression: (check-pred even? elt) +params: (# 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! diff --git a/collects/schemeunit/scribblings/release-notes.scrbl b/collects/schemeunit/scribblings/release-notes.scrbl new file mode 100644 index 0000000..2c70f43 --- /dev/null +++ b/collects/schemeunit/scribblings/release-notes.scrbl @@ -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.} + +] diff --git a/collects/schemeunit/scribblings/schemeunit.scrbl b/collects/schemeunit/scribblings/schemeunit.scrbl new file mode 100644 index 0000000..2665ad8 --- /dev/null +++ b/collects/schemeunit/scribblings/schemeunit.scrbl @@ -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[] diff --git a/collects/schemeunit/scribblings/ui.scrbl b/collects/schemeunit/scribblings/ui.scrbl new file mode 100644 index 0000000..8cc3293 --- /dev/null +++ b/collects/schemeunit/scribblings/ui.scrbl @@ -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. diff --git a/collects/schemeunit/standalone-check-test.ss b/collects/schemeunit/standalone-check-test.ss new file mode 100644 index 0000000..9217729 --- /dev/null +++ b/collects/schemeunit/standalone-check-test.ss @@ -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 + + +;; 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)) \ No newline at end of file diff --git a/collects/schemeunit/standalone-test-case-test.ss b/collects/schemeunit/standalone-test-case-test.ss new file mode 100644 index 0000000..a107da8 --- /dev/null +++ b/collects/schemeunit/standalone-test-case-test.ss @@ -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)) \ No newline at end of file diff --git a/collects/schemeunit/test-case-test.ss b/collects/schemeunit/test-case-test.ss new file mode 100644 index 0000000..e7ab540 --- /dev/null +++ b/collects/schemeunit/test-case-test.ss @@ -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))))))) + + )) \ No newline at end of file diff --git a/collects/schemeunit/test-case.ss b/collects/schemeunit/test-case.ss new file mode 100644 index 0000000..bc265bc --- /dev/null +++ b/collects/schemeunit/test-case.ss @@ -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 ...))))) + diff --git a/collects/schemeunit/test-suite-test.ss b/collects/schemeunit/test-suite-test.ss new file mode 100644 index 0000000..99870dd --- /dev/null +++ b/collects/schemeunit/test-suite-test.ss @@ -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) \ No newline at end of file diff --git a/collects/schemeunit/test-suite.ss b/collects/schemeunit/test-suite.ss new file mode 100644 index 0000000..da39ff4 --- /dev/null +++ b/collects/schemeunit/test-suite.ss @@ -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))])) diff --git a/collects/schemeunit/test-test.ss b/collects/schemeunit/test-test.ss new file mode 100644 index 0000000..5706275 --- /dev/null +++ b/collects/schemeunit/test-test.ss @@ -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) + )) + \ No newline at end of file diff --git a/collects/schemeunit/test.ss b/collects/schemeunit/test.ss new file mode 100644 index 0000000..4f409f3 --- /dev/null +++ b/collects/schemeunit/test.ss @@ -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)) diff --git a/collects/schemeunit/text-ui-test.ss b/collects/schemeunit/text-ui-test.ss new file mode 100644 index 0000000..7e37c65 --- /dev/null +++ b/collects/schemeunit/text-ui-test.ss @@ -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 +;; +;; +;; 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))) + )) + diff --git a/collects/schemeunit/text-ui-util-test.ss b/collects/schemeunit/text-ui-util-test.ss new file mode 100644 index 0000000..1496bc2 --- /dev/null +++ b/collects/schemeunit/text-ui-util-test.ss @@ -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 +;; +;; +;; 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") + )) diff --git a/collects/schemeunit/text-ui-util.ss b/collects/schemeunit/text-ui-util.ss new file mode 100644 index 0000000..b84f900 --- /dev/null +++ b/collects/schemeunit/text-ui-util.ss @@ -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 +;; +;; +;; 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 ""))) + diff --git a/collects/schemeunit/text-ui.ss b/collects/schemeunit/text-ui.ss new file mode 100644 index 0000000..8b8edb3 --- /dev/null +++ b/collects/schemeunit/text-ui.ss @@ -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 +;; +;; +;; 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)))))) + diff --git a/collects/schemeunit/util-test.ss b/collects/schemeunit/util-test.ss new file mode 100644 index 0000000..10b14df --- /dev/null +++ b/collects/schemeunit/util-test.ss @@ -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")))) + )) diff --git a/collects/schemeunit/util.ss b/collects/schemeunit/util.ss new file mode 100644 index 0000000..dc337a9 --- /dev/null +++ b/collects/schemeunit/util.ss @@ -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 +;; +;; +;; 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)) +