├── .github ├── dependabot.yml └── workflows │ └── ci.yml ├── .gitignore ├── LICENSE ├── README.md ├── rackunit-doc ├── info.rkt └── rackunit │ ├── info.rkt │ └── scribblings │ ├── acknowledgements.scrbl │ ├── api.scrbl │ ├── base.rkt │ ├── check.scrbl │ ├── compound-testing.scrbl │ ├── control-flow.scrbl │ ├── file-test.rkt │ ├── file.rkt │ ├── info.rkt │ ├── internals.scrbl │ ├── misc.scrbl │ ├── overview.scrbl │ ├── philosophy.scrbl │ ├── quick-start.scrbl │ ├── rackunit-screen-shot.png │ ├── rackunit.scrbl │ ├── release-notes.scrbl │ ├── ui.scrbl │ ├── utils-label.rkt │ └── utils.scrbl ├── rackunit-gui ├── info.rkt └── rackunit │ ├── gui.rkt │ └── private │ └── gui │ ├── cache-box.rkt │ ├── config.rkt │ ├── controller.rkt │ ├── drracket-link.rkt │ ├── drracket-ui.rkt │ ├── gui.rkt │ ├── interfaces.rkt │ ├── model.rkt │ ├── model2rml.rkt │ ├── output-icon.png │ ├── rml.rkt │ └── view.rkt ├── rackunit-lib ├── info.rkt └── rackunit │ ├── HISTORY.txt │ ├── main.rkt │ ├── private │ ├── base.rkt │ ├── check-info.rkt │ ├── check.rkt │ ├── equal-within.rkt │ ├── format.rkt │ ├── location.rkt │ ├── result.rkt │ ├── test-case.rkt │ ├── test-suite.rkt │ ├── test.rkt │ └── util.rkt │ └── text-ui.rkt ├── rackunit-plugin-lib ├── info.rkt └── rackunit │ ├── info.rkt │ └── tool.rkt ├── rackunit-test ├── info.rkt └── tests │ └── rackunit │ ├── all-rackunit-tests.rkt │ ├── base-test.rkt │ ├── check-info-test.rkt │ ├── check-test.rkt │ ├── failure-test.rkt │ ├── format-test.rkt │ ├── info.rkt │ ├── location-test.rkt │ ├── nested-info-test.rkt │ ├── nested-test-suite.rkt │ ├── pr │ ├── 100.rkt │ ├── 109+138.rkt │ ├── 121.rkt │ ├── 13.rkt │ ├── 5.rkt │ └── 90.rkt │ ├── pr10950.rkt │ ├── result-test.rkt │ ├── run-tests.rkt │ ├── standalone-check-higher-order-test.rkt │ ├── standalone-check-test.rkt │ ├── standalone-test-case-test.rkt │ ├── standalone.rkt │ ├── test-case-test.rkt │ ├── test-suite-test.rkt │ ├── test-test.rkt │ ├── text-ui-test.rkt │ ├── tl.rkt │ ├── typed-test.rkt │ └── util-test.rkt ├── rackunit-typed ├── info.rkt ├── rackunit.rkt └── rackunit │ ├── docs-complete.rkt │ ├── gui.rkt │ ├── main.rkt │ ├── text-ui.rkt │ └── type-env-ext.rkt ├── rackunit └── info.rkt ├── schemeunit ├── gui.rkt ├── info.rkt ├── main.rkt └── text-ui.rkt └── testing-util-lib ├── info.rkt └── rackunit └── log.rkt /.github/dependabot.yml: -------------------------------------------------------------------------------- 1 | version: 2 2 | updates: 3 | - package-ecosystem: "github-actions" 4 | directory: "/" 5 | schedule: 6 | interval: "weekly" 7 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: Build and Test 2 | 3 | on: 4 | push: 5 | branches: 6 | - master 7 | pull_request: 8 | 9 | jobs: 10 | build-test: 11 | runs-on: ubuntu-22.04 12 | container: racket/racket-ci:latest 13 | 14 | strategy: 15 | fail-fast: false 16 | matrix: 17 | racket-version: ["current"] 18 | racket-variant: ['BC', 'CS'] 19 | steps: 20 | - uses: actions/checkout@v4 21 | - uses: Bogdanp/setup-racket@v1.12 22 | with: 23 | architecture: x64 24 | distribution: minimal 25 | variant: ${{ matrix.racket-variant }} 26 | version: ${{ matrix.racket-version }} 27 | dest: '"${HOME}/racketdist-${{ matrix.racket-version }}-${{ matrix.racket-variant }}"' 28 | local_catalogs: $GITHUB_WORKSPACE 29 | sudo: never 30 | - name: Install rackunit 31 | run: raco pkg install -i --auto rackunit-test compiler-lib 32 | - name: Run Tests 33 | run: raco test --table -e --process -p rackunit-test rackunit-lib 34 | - name: Install extra packages 35 | run: raco pkg install -i --auto rackunit-typed rackunit-gui rackunit-plugin-lib 36 | - name: Run extra tests 37 | run: xvfb-run raco test --table -e --process -p rackunit-typed rackunit-plugin-lib rackunit-gui 38 | - name: Install docs 39 | run: raco pkg install -i --auto rackunit-doc 40 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Racket compiled files 2 | compiled/ 3 | doc/ 4 | 5 | # common backups, autosaves, lock files, OS meta-files 6 | *~ 7 | \#* 8 | .#* 9 | .DS_Store 10 | *.bak 11 | TAGS 12 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | This component of Racket is distributed under the under the Apache 2.0 2 | and MIT licenses. The user can choose the license under which they 3 | will be using the software. There may be other licenses within the 4 | distribution with which the user must also comply. 5 | 6 | See the files 7 | https://github.com/racket/racket/blob/master/racket/src/LICENSE-APACHE.txt 8 | and 9 | https://github.com/racket/racket/blob/master/racket/src/LICENSE-MIT.txt 10 | for the full text of the licenses. 11 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # rackunit 2 | 3 | This the source for the Racket packages: "rackunit", "rackunit-doc", "rackunit-gui", "rackunit-lib", "rackunit-plugin-lib", "rackunit-test", "rackunit-typed", "schemeunit", "testing-util-lib". 4 | 5 | ### Contributing 6 | 7 | Contribute to Racket by submitting a [pull request], reporting an 8 | [issue], joining the [development mailing list], or visiting the 9 | IRC or Slack channels. 10 | 11 | ### License 12 | 13 | Racket, including these packages, is free software, see [LICENSE] 14 | for more details. 15 | 16 | By making a contribution, you are agreeing that your contribution 17 | is licensed under the [Apache 2.0] license and the [MIT] license. 18 | 19 | [MIT]: https://github.com/racket/racket/blob/master/racket/src/LICENSE-MIT.txt 20 | [Apache 2.0]: https://www.apache.org/licenses/LICENSE-2.0.txt 21 | [pull request]: https://github.com/racket/rackunit/pulls 22 | [issue]: https://github.com/racket/rackunit/issues 23 | [development mailing list]: https://lists.racket-lang.org 24 | [LICENSE]: LICENSE 25 | -------------------------------------------------------------------------------- /rackunit-doc/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection 'multi) 4 | 5 | (define deps '("base")) 6 | 7 | (define pkg-desc "RackUnit documentation") 8 | 9 | (define pkg-authors '(noel ryanc)) 10 | (define build-deps '("compiler-lib" 11 | "racket-index" 12 | "racket-doc" 13 | "rackunit-gui" 14 | "rackunit-lib" 15 | "scribble-lib")) 16 | (define update-implies '("rackunit-lib")) 17 | 18 | (define license 19 | '(Apache-2.0 OR MIT)) 20 | -------------------------------------------------------------------------------- /rackunit-doc/rackunit/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define scribblings '(("scribblings/rackunit.scrbl" (multi-page) ("Testing")))) 4 | 5 | (define test-responsibles '((all (jay noel ryanc)))) 6 | -------------------------------------------------------------------------------- /rackunit-doc/rackunit/scribblings/acknowledgements.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @(require "base.rkt") 3 | 4 | @title{Acknowlegements} 5 | 6 | The following people have contributed to RackUnit: 7 | 8 | @itemize[ 9 | @item{Robby Findler pushed me to release version 3} 10 | 11 | @item{Matt Jadud and his students at Olin College 12 | suggested renaming @racket[test/text-ui]} 13 | 14 | @item{Dave Gurnell reported a bug in check-not-exn and 15 | suggested improvements to RackUnit} 16 | 17 | @item{Danny Yoo reported a bug in and provided a fix for 18 | trim-current-directory} 19 | 20 | @item{Jacob Matthews and Guillaume Marceau for bug reports 21 | and fixes} 22 | 23 | @item{Eric Hanchrow suggested test/text-ui return a useful 24 | result} 25 | 26 | @item{Ray Racine and Richard Cobbe provided require/expose} 27 | 28 | @item{John Clements suggested several new checks} 29 | 30 | @item{Jose A. Ortega Ruiz alerted me a problem in the 31 | packaging system and helped fix it.} 32 | 33 | @item{Sebastian H. Seidel provided help packaging RackUnit 34 | into a .plt} 35 | 36 | @item{Don Blaheta provided the method for grabbing line number 37 | and file name in checks} 38 | 39 | @item{Patrick Logan ported example.rkt to version 1.3} 40 | 41 | @item{The PLT team made Racket} 42 | 43 | @item{The Extreme Programming community started the whole 44 | testing framework thing} 45 | ] 46 | -------------------------------------------------------------------------------- /rackunit-doc/rackunit/scribblings/api.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @(require "base.rkt") 3 | 4 | @title[#:tag "api"]{RackUnit API} 5 | 6 | @defmodule[rackunit 7 | #:use-sources (rackunit)] 8 | 9 | @include-section["overview.scrbl"] 10 | @include-section["check.scrbl"] 11 | @include-section["compound-testing.scrbl"] 12 | @include-section["control-flow.scrbl"] 13 | @include-section["misc.scrbl"] 14 | @include-section["ui.scrbl"] 15 | -------------------------------------------------------------------------------- /rackunit-doc/rackunit/scribblings/base.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | scribble/eval 5 | scribble/manual 6 | 7 | (for-label racket/base 8 | racket/contract 9 | rackunit 10 | rackunit/text-ui 11 | rackunit/gui)) 12 | 13 | (provide 14 | (all-from-out scribble/eval 15 | scribble/manual) 16 | (for-label (all-from-out racket/base 17 | racket/contract 18 | rackunit 19 | rackunit/text-ui 20 | rackunit/gui))) 21 | -------------------------------------------------------------------------------- /rackunit-doc/rackunit/scribblings/compound-testing.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @(require "base.rkt") 3 | 4 | @title{Compound Testing Forms} 5 | 6 | @section{Test Cases} 7 | 8 | As programs increase in complexity the unit of testing 9 | grows beyond a single check. For example, it may be the case 10 | that if one check fails it doesn't make sense to run 11 | another. To solve this problem compound testing forms can 12 | be used to group expressions. If any expression in a group 13 | fails (by raising an exception) the remaining expressions 14 | will not be evaluated. 15 | 16 | @defform[(test-begin expr ...)]{ 17 | 18 | A @racket[test-begin] form groups the @racket[expr]s into a 19 | single unit. If any @racket[expr] fails the following ones 20 | are not evaluated. } 21 | 22 | For example, in the following code the world is not 23 | destroyed as the preceding check fails: 24 | 25 | @racketblock[ 26 | (test-begin 27 | (check-eq? 'a 'b) 28 | (code:comment "This line won't be run") 29 | (destroy-the-world)) 30 | ] 31 | 32 | @defform[(test-case name body ...+)]{ 33 | 34 | Like a @racket[test-begin] except a name is associated with 35 | the @racket[body]s. The name will be reported if 36 | the test fails. } 37 | 38 | Here's the above example rewritten to use @racket[test-case] 39 | so the test can be named. 40 | 41 | @racketblock[ 42 | (test-case 43 | "Example test" 44 | (check-eq? 'a 'b) 45 | (code:comment "This line won't be run") 46 | (destroy-the-world)) 47 | ] 48 | 49 | 50 | @defproc[(test-case? (obj any/c)) boolean?]{ 51 | True if @racket[obj] is a test case, and false otherwise. 52 | } 53 | 54 | @subsection{Shortcuts for Defining Test Cases} 55 | 56 | @defproc*[([(test-check [name string?] 57 | [operator (-> any/c any/c any/c)] 58 | [v1 any/c] 59 | [v2 any/c]) 60 | void?] 61 | [(test-pred [name string?] 62 | [pred (-> any/c any/c)] 63 | [v any/c]) 64 | void?] 65 | [(test-equal? [name string?] [v1 any/c] [v2 any/c]) void?] 66 | [(test-eq? [name string?] [v1 any/c] [v2 any/c]) void?] 67 | [(test-eqv? [name string?] [v1 any/c] [v2 any/c]) void?] 68 | [(test-= [name string?] [v1 real?] [v2 real?] [epsilon real?]) void?] 69 | [(test-true [name string?] [v any/c]) void?] 70 | [(test-false [name string?] [v any/c]) void?] 71 | [(test-not-false [name string?] [v any/c]) void?] 72 | [(test-exn [name string?] [pred (or/c (-> any/c any/c) regexp?)] [thunk (-> any)]) void?] 73 | [(test-not-exn [name string?] [thunk (-> any)]) void?])]{ 74 | 75 | Creates a test case with the given @racket[name] that performs the 76 | corresponding check. For example, 77 | 78 | @racketblock[(test-equal? "Fruit test" "apple" "pear")] 79 | is equivalent to 80 | @racketblock[(test-case "Fruit test" (check-equal? "apple" "pear"))] 81 | } 82 | 83 | 84 | @section{Test Suites} 85 | 86 | Test cases can themselves be grouped into test suites. A 87 | test suite can contain both test cases and test suites. 88 | Unlike a check or test case, a test suite is not immediately 89 | run. Instead use one of the functions described in 90 | @secref["ui"] or @secref["running"]. 91 | 92 | @defform/subs[(test-suite name-expr maybe-before maybe-after test ...) 93 | ([maybe-before (code:line) 94 | (code:line #:before before-thunk)] 95 | [maybe-after (code:line) 96 | (code:line #:after after-thunk)]) 97 | #:contracts ([name-expr string?])]{ 98 | 99 | Constructs a test suite with the given name and tests. The tests may 100 | be checks, test cases, constructed using @racket[test-begin] or 101 | @racket[test-case], or other test suites. 102 | 103 | The @racket[before-thunk] and @racket[after-thunk] are 104 | optional thunks (functions with no argument). They are run 105 | before and after the tests are run, respectively. 106 | 107 | Unlike a check or test case, a test suite is not immediately 108 | run. Instead use one of the functions described in 109 | @secref["ui"] or @secref["running"].} 110 | 111 | For example, here is a test suite that displays @tt{Before} 112 | before any tests are run, and @tt{After} when the tests have 113 | finished. 114 | 115 | @racketblock[ 116 | (test-suite 117 | "An example suite" 118 | #:before (lambda () (display "Before")) 119 | #:after (lambda () (display "After")) 120 | (test-case 121 | "An example test" 122 | (check-eq? 1 1)) 123 | (test-suite "A nested test suite" 124 | (test-case "Another test" 125 | (check < 1 2)))) 126 | ] 127 | 128 | @defproc[(make-test-suite [name string?] 129 | [tests (listof (or/c test-case? test-suite?))] 130 | [#:before before-thunk (-> any) void] 131 | [#:after after-thunk (-> any) void]) 132 | test-suite?]{ 133 | 134 | Constructs a test suite with the given @racket[name] containing the 135 | given @racket[tests]. Unlike the @racket[test-suite] form, the tests 136 | are represented as a list of test values. 137 | } 138 | 139 | @defproc[(test-suite? (obj any/c)) boolean?]{ True if 140 | @racket[obj] is a test suite, and false otherwise} 141 | 142 | 143 | 144 | @subsection{Utilities for Defining Test Suites} 145 | 146 | There are some macros that simplify the common cases of 147 | defining test suites: 148 | 149 | @defform[(define-test-suite name test ...)]{ The 150 | @racket[define-test-suite] form creates a test suite with 151 | the given name (converted to a string) and tests, and binds 152 | it to the same name.} 153 | 154 | For example, this code creates a binding for the name 155 | @racket[example-suite] as well as creating a test suite with 156 | the name @racket["example-suite"]: 157 | 158 | @racketblock[ 159 | (define-test-suite example-suite 160 | (check = 1 1)) 161 | ] 162 | 163 | @defform[(define/provide-test-suite name test ...)]{ This 164 | form is just like @racket[define-test-suite], and in addition 165 | it @racket[provide]s the test suite.} 166 | 167 | @;{ 168 | Finally, there is the @racket[test-suite*] macro, which 169 | defines a test suite and test cases using a shorthand 170 | syntax: 171 | 172 | @defform[(test-suite* name (test-case-name test-case-body 173 | ...) ...)]{ Defines a test suite with the given name, and 174 | creates test cases within the suite, with the given names and 175 | body expressions. 176 | 177 | As far I know no-one uses this macro, so it might disappear 178 | in future versions of RackUnit.} 179 | } 180 | -------------------------------------------------------------------------------- /rackunit-doc/rackunit/scribblings/control-flow.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @(require "base.rkt") 3 | 4 | @title{Test Control Flow} 5 | 6 | The @racket[before], @racket[after], and @racket[around] 7 | macros allow you to specify code that is always run before, 8 | after, or around expressions in a test case. 9 | 10 | @defform[(before before-expr expr-1 expr-2 ...)]{ 11 | 12 | Whenever control enters the scope execute the @racket[before-expr] 13 | before executing @racket[expr-1], and @racket[expr-2 ...]} 14 | 15 | @defform[(after expr-1 expr-2 ... after-expr)]{ 16 | 17 | Whenever control exits the scope execute the @racket[after-expr] 18 | after executing @racket[expr-1], and @racket[expr-2 ...] The @racket[after-expr] is 19 | executed even if control exits via an exception or other means.} 20 | 21 | @defform[(around before-expr expr-1 expr-2 ... after-expr)]{ 22 | 23 | Whenever control enters the scope execute the 24 | @racket[before-expr] before executing @racket[expr-1 expr-2 25 | ...], and execute @racket[after-expr] whenever control 26 | leaves the scope.} 27 | 28 | Example: 29 | 30 | The test below checks that the file @tt{test.dat} contains 31 | the string @tt{"foo"}. The before action writes to this 32 | file. The after action deletes it. 33 | 34 | @racketblock[ 35 | (around 36 | (with-output-to-file "test.dat" 37 | (lambda () 38 | (write "foo"))) 39 | (with-input-from-file "test.dat" 40 | (lambda () 41 | (check-equal? "foo" (read)))) 42 | (delete-file "test.dat")) 43 | ] 44 | 45 | 46 | @defform[(delay-test test1 test2 ...)]{ 47 | 48 | This somewhat curious macro evaluates the given tests in a 49 | context where @racket[current-test-case-around] is 50 | parameterized to @racket[test-suite-test-case-around]. This 51 | has been useful in testing RackUnit. It might be useful 52 | for you if you create test cases that create test cases.} 53 | -------------------------------------------------------------------------------- /rackunit-doc/rackunit/scribblings/file-test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require rackunit 4 | "file.rkt") 5 | 6 | (check-equal? (my-+ 1 1) 2) 7 | (check-equal? (my-* 1 2) 2) 8 | 9 | (test-begin 10 | (let ((lst (list 2 4 6 9))) 11 | (check = (length lst) 4) 12 | (for-each 13 | (lambda (elt) 14 | (check-pred even? elt)) 15 | lst))) 16 | 17 | (test-case 18 | "List has length 4 and all elements even" 19 | (let ((lst (list 2 4 6 9))) 20 | (check = (length lst) 4) 21 | (for-each 22 | (lambda (elt) 23 | (check-pred even? elt)) 24 | lst))) 25 | -------------------------------------------------------------------------------- /rackunit-doc/rackunit/scribblings/file.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (define (my-+ a b) 4 | (if (zero? a) 5 | b 6 | (my-+ (sub1 a) (add1 b)))) 7 | 8 | (define (my-* a b) 9 | (if (zero? a) 10 | b 11 | (my-* (sub1 a) (my-+ b b)))) 12 | 13 | (provide my-+ 14 | my-*) 15 | -------------------------------------------------------------------------------- /rackunit-doc/rackunit/scribblings/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define test-omit-paths '("file-test.rkt")) 4 | -------------------------------------------------------------------------------- /rackunit-doc/rackunit/scribblings/internals.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @(require "base.rkt") 3 | 4 | @declare-exporting[rackunit #:use-sources (rackunit)] 5 | 6 | @title[#:tag "internals"]{RackUnit Internals and Extension API} 7 | 8 | This section describes RackUnit's facilities for customizing the 9 | behavior of checks and tests and for creating new kinds of test 10 | runners. 11 | 12 | @section{Customizing Check Evaluation} 13 | 14 | The semantics of checks are determined by the parameters 15 | @racket[current-check-around] and 16 | @racket[current-check-handler]. Other testing form such as 17 | @racket[test-begin] and @racket[test-suite] change the value 18 | of these parameters. 19 | 20 | @defparam[current-check-handler handler (-> any/c any)]{ 21 | 22 | Parameter containing the function that handles exceptions 23 | raised by check failures. The default value is a procedure 24 | that will display the exception data in a user-friendly format. 25 | } 26 | 27 | @defparam[current-check-around check (-> (-> any) any)]{ 28 | 29 | Parameter containing the function that handles the execution 30 | of checks. The default value wraps the evaluation of 31 | @racket[thunk] in a @racket[with-handlers] call that calls 32 | @racket[current-check-handler] if an exception is raised and then 33 | (when an exception is not raised) discards the result, returning 34 | @racket[(void)]. 35 | } 36 | 37 | @section{Customizing Test Evaluation} 38 | 39 | Just like with checks, there are several parameters that 40 | control the semantics of compound testing forms. 41 | 42 | @defparam[current-test-name name (or/c string? false/c)]{ 43 | 44 | This parameter stores the name of the current test case. A 45 | value of @racket[#f] indicates a test case with no name, 46 | such as one constructed by @racket[test-begin]. 47 | } 48 | 49 | @defparam[current-test-case-around handler (-> (-> any) any)]{ 50 | 51 | This parameter handles evaluation of test cases. The value 52 | of the parameter is a function that is passed a thunk (a 53 | function of no arguments). The function, when applied, 54 | evaluates the expressions within a test case. The default 55 | value of the @racket[current-test-case-around] parameters 56 | evaluates the thunk in a context that catches exceptions and 57 | prints an appropriate message indicating test case failure. 58 | } 59 | 60 | @defproc[(test-suite-test-case-around [thunk (-> any)]) any]{ 61 | 62 | The @racket[current-test-case-around] parameter is 63 | parameterized to this value within the scope of a 64 | @racket[test-suite]. This function creates a test case 65 | structure instead of immediately evaluating the thunk. 66 | } 67 | 68 | @defproc[(test-suite-check-around [thunk (-> any/c)]) any/c]{ 69 | 70 | The @racket[current-check-around] parameter is parameterized 71 | to this value within the scope of a @racket[test-suite]. 72 | This function creates a test case structure instead of 73 | immediately evaluating a check. 74 | } 75 | 76 | @;{--------} 77 | 78 | @section[#:tag "running"]{Programmatically Running Tests and Inspecting Results} 79 | 80 | RackUnit provides an API for running tests, from which 81 | custom UIs can be created. 82 | 83 | @subsection{Result Types} 84 | 85 | @defstruct[(exn:test exn:fail) ()]{ 86 | 87 | The base structure for RackUnit exceptions. You should 88 | never catch instances of this type, only the subtypes 89 | documented below.} 90 | 91 | @defstruct[(exn:test:check exn:test) ([stack (listof check-info)])]{ 92 | 93 | A @racket[exn:test:check] is raised when an check fails, and 94 | contains the contents of the check-info stack at the 95 | time of failure.} 96 | 97 | @defstruct[test-result ([test-case-name (or/c string #f)])]{ 98 | 99 | A test-result is the result of running the test with 100 | the given name (with @racket[#f] indicating no name is available).} 101 | 102 | @defstruct[(test-failure test-result) ([result any])]{ 103 | 104 | Subtype of test-result representing a test failure.} 105 | 106 | @defstruct[(test-error test-result) ([result exn])]{ 107 | 108 | Subtype of test-result representing a test error.} 109 | 110 | @defstruct[(test-success test-result) ([result any])]{ 111 | 112 | Subtype of test-result representing a test success.} 113 | 114 | 115 | @subsection{Functions to Run Tests} 116 | 117 | @defproc[(run-test-case (name (or/c string #f)) (action (-> any))) 118 | test-result]{ 119 | 120 | Runs the given test case, returning a result representing success, 121 | failure, or error. 122 | } 123 | 124 | 125 | @defproc[(run-test (test (or/c test-case? test-suite?))) 126 | (flat-murec-contract ([R (listof (or/c test-result? R))]) R)]{ 127 | 128 | Runs the given test (test case or test suite) returning a 129 | tree (list of lists) of results} 130 | 131 | Example: 132 | 133 | @racketblock[ 134 | (run-test 135 | (test-suite 136 | "Dummy" 137 | (test-case "Dummy" (check-equal? 1 2)))) 138 | ] 139 | 140 | @defproc[(fold-test-results [result-fn ('b 'c ... 'a . -> . 'a)] 141 | [seed 'a] 142 | [test (or/c test-case? test-suite?)] 143 | [#:run run (string (() -> any) . -> . 'b 'c ...)] 144 | [#:fdown fdown (string 'a . -> . 'a)] 145 | [#:fup fup (string 'a . -> . 'a)]) 146 | 'a]{ 147 | 148 | Fold @racket[result-fn] pre-order left-to-right depth-first 149 | over the results of @racket[run]. By default @racket[run] 150 | is @racket[run-test-case] and @racket[fdown] and 151 | @racket[fup] just return the seed, so @racket[result-fn] is 152 | folded over the test results. 153 | 154 | This function is useful for writing custom folds (and hence UIs) over 155 | test results without you having to take care of all the expected setup 156 | and teardown. For example, @racket[fold-test-results] will run test 157 | suite before and after actions for you. However it is still flexible 158 | enough, via its keyword arguments, to do almost anything that 159 | @racket[foldts-test-suite] can. Hence it should be used in preference to @racket[foldts-test-suite]. 160 | 161 | The @racket[result-fn] argument is a function from the results of 162 | @racket[run] (defaults to a @racket[test-result]) and the seed to a 163 | new seed. 164 | 165 | The @racket[seed] argument is any value. 166 | 167 | The @racket[test] argument is a test case or test suite. 168 | 169 | The @racket[run] argument is a function from a test case name (string) 170 | and action (thunk) to any values. The values produced by @racket[run] 171 | are fed into the @racket[result-fn]. 172 | 173 | The @racket[fdown] argument is a function from a test suite name 174 | (string) and the seed, to a new seed. 175 | 176 | The @racket[fup] argument is a function from a test suite name 177 | (string) and the seed, to a new seed. 178 | } 179 | 180 | Examples: 181 | 182 | The following code counts the number of successes: 183 | 184 | @racketblock[ 185 | (define (count-successes test) 186 | (fold-test-results 187 | (lambda (result seed) 188 | (if (test-success? result) 189 | (add1 seed) 190 | seed)) 191 | 0 192 | test))] 193 | 194 | The following code returns the symbol @racket['burp] instead 195 | of running test cases. Note how the @racket[result-fn] receives the 196 | value of @racket[run]. 197 | 198 | @racketblock[ 199 | (define (burp test) 200 | (fold-test-results 201 | (lambda (result seed) (cons result seed)) 202 | null 203 | test 204 | #:run (lambda (name action) 'burp)))] 205 | 206 | 207 | @defproc[(foldts-test-suite [fdown (test-suite string thunk thunk 'a -> 'a)] 208 | [fup (test-suite string thunk thunk 'a 'a -> 'a)] 209 | [fhere(test-case string thunk 'a -> 'a)] 210 | [seed 'a] 211 | [test (or/c test-case? test-suite?)]) 212 | 'a]{ 213 | 214 | The @racket[foldts-test-suite] function is a nifty tree fold (created by Oleg 215 | Kiselyov) that folds over a test in a useful way 216 | (@racket[fold-test-results] isn't that useful as you can't specify 217 | actions around test cases). 218 | 219 | The @racket[fdown] argument is a function of test suite, test suite 220 | name, before action, after action, and the seed. It is run when a 221 | test suite is encountered on the way down the tree (pre-order). 222 | 223 | The @racket[fup] argument is a function of test suite, test suite 224 | name, before action, after action, the seed at the current level, and 225 | the seed returned by the children. It is run on the way up the tree 226 | (post-order). 227 | 228 | The @racket[fhere] argument is a function of the test case, test case 229 | name, the test case action, and the seed. (Note that this might change 230 | in the near future to just the test case. This change would be to 231 | allow @racket[fhere] to discriminate subtypes of test-case, which in 232 | turn would allow test cases that are, for example, ignored). 233 | } 234 | 235 | Example: 236 | 237 | Here's the implementation of @racket[fold-test-results] in terms of 238 | @racket[foldts-test-suite]: 239 | 240 | @racketblock[ 241 | (define (fold-test-results suite-fn case-fn seed test) 242 | (foldts-test-suite 243 | (lambda (suite name before after seed) 244 | (before) 245 | (suite-fn name seed)) 246 | (lambda (suite name before after seed kid-seed) 247 | (after) 248 | kid-seed) 249 | (lambda (case name action seed) 250 | (case-fn 251 | (run-test-case name action) 252 | seed)) 253 | seed 254 | test)) 255 | ] 256 | 257 | If you're used to folds you'll probably be a bit surprised that the 258 | functions you pass to @racket[foldts-test-suite] receive both the structure they 259 | operate on, and the contents of that structure. This is indeed 260 | unusual. It is done to allow subtypes of test-case and test-suite to 261 | be run in customised ways. For example, you might define subtypes of 262 | test case that are ignored (not run), or have their execution time 263 | recorded, and so on. To do so the functions that run the test cases 264 | need to know what type the test case has, and hence is is necessary to 265 | provide this information. 266 | -------------------------------------------------------------------------------- /rackunit-doc/rackunit/scribblings/misc.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @(require "base.rkt") 3 | 4 | @title{Miscellaneous Utilities} 5 | 6 | The @racket[require/expose] macro allows you to access 7 | bindings that a module does not provide. It is useful for 8 | testing the private functions of modules. 9 | 10 | @defform[(require/expose module (id ...))]{ 11 | 12 | Requires @racket[id] from @racket[module] into the current module. It 13 | doesn't matter if the source module provides the bindings or not; 14 | @racket[require/expose] can still get at them. 15 | 16 | Note that @racket[require/expose] can be a bit fragile, 17 | especially when mixed with compiled code. Use at your own risk! 18 | } 19 | 20 | This example gets @racket[make-failure-test], which is defined in a RackUnit test: 21 | 22 | @racketblock[ 23 | (require/expose rackunit/private/check-test (make-failure-test)) 24 | ] 25 | 26 | @defproc[(dynamic-require/expose [mod (or/c module-path? 27 | module-path-index? 28 | resolved-module-path?)] 29 | [name symbol?]) 30 | any]{ 31 | 32 | Like @racket[dynamic-require], but gets internal bindings like 33 | @racket[require/expose]. 34 | } 35 | 36 | Checks defined with @racket[define-check] provide a 37 | compile-time API to access information associated 38 | with the check. 39 | 40 | @defproc[(check-transformer? [v any/c]) boolean?]{ 41 | Determines if @racket[_v] is a syntax transformer 42 | defined with @racket[define-check]. Typically, this 43 | is used on the result of @racket[syntax-local-value]. 44 | 45 | Provided by @racketmodname[rackunit] at phase 1. 46 | } 47 | 48 | @defproc[(check-transformer-impl-name [ct check-transformer?]) identifier?]{ 49 | Given a transformer @racket[_ct] defined with @racket[define-check], 50 | produces an identifier which names the procedure implementing the 51 | check. This procedure takes the same arguments as the check form, as 52 | well as two mandatory keyword arguments: @racket[#:location] whose argument 53 | must be a list representing a source location as in the third argument of 54 | @racket[datum->syntax], and @racket[#:exp], whose argument is an s-expression 55 | representing the original syntax of the check for printing. 56 | 57 | Provided by @racketmodname[rackunit] at phase 1. 58 | } 59 | -------------------------------------------------------------------------------- /rackunit-doc/rackunit/scribblings/overview.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @(require "base.rkt") 3 | 4 | @title{Overview of RackUnit} 5 | 6 | There are three basic concepts in RackUnit: 7 | 8 | @itemize[ 9 | 10 | @item{A @italic{check} is the basic unit of a test. As the name 11 | suggests, it checks whether some condition is true.} 12 | 13 | @item{A @italic{test case} is a group of checks that form one 14 | conceptual unit. If any check within the case fails, the entire case 15 | fails.} 16 | 17 | @item{A @italic{test suite} is a group of test cases and test suites 18 | that has a name.} 19 | ] 20 | -------------------------------------------------------------------------------- /rackunit-doc/rackunit/scribblings/philosophy.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @(require "base.rkt") 3 | 4 | @title[#:tag "philosophy"]{The Philosophy of RackUnit} 5 | 6 | RackUnit is designed to allow tests to evolve in step with 7 | the evolution of the program under testing. RackUnit 8 | scales from the unstructured checks suitable for simple 9 | programs to the complex structure necessary for large 10 | projects. 11 | 12 | Simple programs, such as those in How to Design Programs, 13 | are generally purely functional with no setup required to 14 | obtain a context in which the function may operate. 15 | Therefore the tests for these programs are extremely simple: 16 | the test expressions are single checks, usually for 17 | equality, and there are no dependencies between expressions. 18 | For example, a HtDP student may be writing simple list 19 | functions such as length, and the properties they are 20 | checking are of the form: 21 | 22 | @racketblock[ 23 | (equal? (length null) 0) 24 | (equal? (length '(a)) 1) 25 | (equal? (length '(a b)) 2) 26 | ] 27 | 28 | RackUnit directly supports this style of testing. A check 29 | on its own is a valid test. So the above examples may be 30 | written in RackUnit as: 31 | 32 | @racketblock[ 33 | (check-equal? (length null) 0) 34 | (check-equal? (length '(a)) 1) 35 | (check-equal? (length '(a b)) 2) 36 | ] 37 | 38 | Simple programs now get all the benefits of RackUnit with 39 | very little overhead. 40 | 41 | There are limitations to this style of testing that more 42 | complex programs will expose. For example, there might be 43 | dependencies between expressions, caused by state, so that 44 | it does not make sense to evaluate some expressions if 45 | earlier ones have failed. This type of program needs a way 46 | to group expressions so that a failure in one group causes 47 | evaluation of that group to stop and immediately proceed to 48 | the next group. In RackUnit all that is required is to 49 | wrap a @racket[test-begin] expression around a group of 50 | expressions: 51 | 52 | @racketblock[ 53 | (test-begin 54 | (setup-some-state!) 55 | (check-equal? (foo! 1) 'expected-value-1) 56 | (check-equal? (foo! 2) 'expected-value-2)) 57 | ] 58 | 59 | Now if any expression within the @racket[test-begin] 60 | expression fails no further expressions in that group will 61 | be evaluated. 62 | 63 | Notice that all the previous tests written in the simple 64 | style are still valid. Introducing grouping is a local 65 | change only. This is a key feature of RackUnit's support 66 | for the evolution of the program. 67 | 68 | The programmer may wish to name a group of tests. This is 69 | done using the @racket[test-case] expression, a simple 70 | variant on test-begin: 71 | 72 | @racketblock[ 73 | (test-case 74 | "The name" 75 | ... test expressions ...) 76 | ] 77 | 78 | Most programs will stick with this style. However, 79 | programmers writing very complex programs may wish to 80 | maintain separate groups of tests for different parts of the 81 | program, or run their tests in different ways to the normal 82 | RackUnit manner (for example, test results may be logged 83 | for the purpose of improving software quality, or they may 84 | be displayed on a website to indicate service quality). For 85 | these programmers it is necessary to delay the execution of 86 | tests so they can be processed in the programmer's chosen 87 | manner. To do this, the programmer simply wraps a test-suite 88 | around their tests: 89 | 90 | @racketblock[ 91 | (test-suite 92 | "Suite name" 93 | (check ...) 94 | (test-begin ...) 95 | (test-case ...)) 96 | ] 97 | 98 | The tests now change from expressions that are immediately 99 | evaluated to objects that may be programmatically 100 | manipulated. Note again this is a local change. Tests 101 | outside the suite continue to evaluate as before. 102 | 103 | 104 | @section{Historical Context} 105 | 106 | Most testing frameworks, including earlier versions of 107 | RackUnit, support only the final form of testing. This is 108 | likely due to the influence of the SUnit testing framework, 109 | which is the ancestor of RackUnit and the most widely used 110 | frameworks in Java, .Net, Python, and Ruby, and many other 111 | languages. That this is insufficient for all users is 112 | apparent if one considers the proliferation of ``simpler'' 113 | testing frameworks in Scheme such as SRFI-78, or the 114 | practice of beginner programmers. Unfortunately these 115 | simpler methods are inadequate for testing larger 116 | systems. To the best of my knowledge RackUnit is the only 117 | testing framework that makes a conscious effort to support 118 | the testing style of all levels of programmer. 119 | -------------------------------------------------------------------------------- /rackunit-doc/rackunit/scribblings/quick-start.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @(require "base.rkt") 3 | 4 | @title[#:tag "quick-start"]{Quick Start Guide for RackUnit} 5 | 6 | Suppose we have code contained in @tt{file.rkt}, which 7 | implements buggy versions of @racket[+] and @racket[*] 8 | called @racket[my-+] and @racket[my-*]: 9 | 10 | @racketmod[ 11 | racket/base 12 | 13 | (define (my-+ a b) 14 | (if (zero? a) 15 | b 16 | (my-+ (sub1 a) (add1 b)))) 17 | 18 | (define (my-* a b) 19 | (if (zero? a) 20 | b 21 | (my-* (sub1 a) (my-+ b b)))) 22 | 23 | (provide my-+ 24 | my-*) 25 | ] 26 | 27 | We want to test this code with RackUnit. We start by 28 | creating a file called @tt{file-test.rkt} to contain our 29 | tests. At the top of @tt{file-test.rkt} we import 30 | RackUnit and @tt{file.rkt}: 31 | 32 | @racketmod[ 33 | racket/base 34 | 35 | (require rackunit 36 | "file.rkt") 37 | ] 38 | 39 | Now we add some tests to check our library: 40 | 41 | @racketblock[ 42 | (check-equal? (my-+ 1 1) 2 "Simple addition") 43 | (check-equal? (my-* 1 2) 2 "Simple multiplication") 44 | ] 45 | 46 | This is all it takes to define tests in RackUnit. Now 47 | evaluate this file and see if the library is correct. 48 | Here's the result I get: 49 | 50 | @verbatim{ 51 | -------------------- 52 | FAILURE 53 | name: check-equal? 54 | location: (file-test.rkt 7 0 117 27) 55 | expression: (check-equal? (my-* 1 2) 2) 56 | params: (4 2) 57 | message: "Simple multiplication" 58 | actual: 4 59 | expected: 2 60 | 61 | --------------------} 62 | 63 | The first test passed and so prints nothing. The 64 | second test failed, as shown by the message. 65 | 66 | Requiring RackUnit and writing checks is all you need to 67 | get started testing, but let's take a little bit more time 68 | to look at some features beyond the essentials. 69 | 70 | Let's say we want to check that a number of properties hold. 71 | How do we do this? So far we've only seen checks of a 72 | single expression. In RackUnit a check is always a single 73 | expression, but we can group checks into units called test 74 | cases. Here's a simple test case written using the 75 | @racket[test-begin] form: 76 | 77 | @racketblock[ 78 | (test-begin 79 | (let ([lst (list 2 4 6 9)]) 80 | (check = (length lst) 4) 81 | (for-each 82 | (lambda (elt) 83 | (check-pred even? elt)) 84 | lst))) 85 | ] 86 | 87 | Evaluate this and you should see an error message like: 88 | 89 | @verbatim{ 90 | -------------------- 91 | A test 92 | ... has a FAILURE 93 | name: check-pred 94 | location: (# 14 6 252 22) 95 | expression: (check-pred even? elt) 96 | params: (# 9) 97 | -------------------- 98 | } 99 | 100 | This tells us that the expression @racket[(check-pred even? 101 | elt)] failed. The arguments of this check were 102 | @racket[even?] and @racket[9], and as 9 is not even the 103 | check failed. A test case fails as soon as any check within 104 | it fails, and no further checks are evaluated once this 105 | takes place. 106 | 107 | Naming our test cases is useful as it helps remind us what 108 | we're testing. We can give a test case a name with the 109 | @racket[test-case] form: 110 | 111 | @racketblock[ 112 | (test-case 113 | "List has length 4 and all elements even" 114 | (let ([lst (list 2 4 6 9)]) 115 | (check = (length lst) 4) 116 | (for-each 117 | (lambda (elt) 118 | (check-pred even? elt)) 119 | lst))) 120 | ] 121 | 122 | Now if we want to structure our tests a bit more we can 123 | group them into a test suite: 124 | 125 | @racketblock[ 126 | (define file-tests 127 | (test-suite 128 | "Tests for file.rkt" 129 | 130 | (check-equal? (my-+ 1 1) 2 "Simple addition") 131 | 132 | (check-equal? (my-* 1 2) 2 "Simple multiplication") 133 | 134 | (test-case 135 | "List has length 4 and all elements even" 136 | (let ([lst (list 2 4 6 9)]) 137 | (check = (length lst) 4) 138 | (for-each 139 | (lambda (elt) 140 | (check-pred even? elt)) 141 | lst))))) 142 | ] 143 | 144 | Evaluate the module now and you'll see the tests no longer 145 | run. This is because test suites delay execution of their 146 | tests, allowing you to choose how you run your tests. You 147 | might, for example, print the results to the screen or log 148 | them to a file. 149 | 150 | Let's run our tests, using RackUnit's simple textual user 151 | interface (there are fancier interfaces available but this 152 | will do for our example). In @tt{file-test.rkt} add the 153 | following lines: 154 | 155 | @racketblock[ 156 | (require rackunit/text-ui) 157 | 158 | (run-tests file-tests) 159 | ] 160 | 161 | Now evaluate the file and you should see similar output 162 | again. 163 | 164 | These are the basics of RackUnit. Refer to the 165 | documentation below for more advanced topics, such as 166 | defining your own checks. Have fun! 167 | -------------------------------------------------------------------------------- /rackunit-doc/rackunit/scribblings/rackunit-screen-shot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/rackunit/bc6f18a8ed5d8d4673d57dee7e33bb388bcebb2a/rackunit-doc/rackunit/scribblings/rackunit-screen-shot.png -------------------------------------------------------------------------------- /rackunit-doc/rackunit/scribblings/rackunit.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @(require "base.rkt") 3 | 4 | @title{RackUnit: Unit Testing} 5 | 6 | @author[(author+email "Noel Welsh" "noelwelsh@gmail.com") 7 | (author+email "Ryan Culpepper" "ryanc@racket-lang.org")] 8 | 9 | RackUnit is a unit-testing framework for Racket. It 10 | is designed to handle the needs of all Racket programmers, 11 | from novices to experts. 12 | 13 | @table-of-contents[] 14 | 15 | @include-section["quick-start.scrbl"] 16 | @include-section["philosophy.scrbl"] 17 | @include-section["api.scrbl"] 18 | @include-section["utils.scrbl"] 19 | @include-section["internals.scrbl"] 20 | @include-section["release-notes.scrbl"] 21 | @include-section["acknowledgements.scrbl"] 22 | 23 | @index-section[] 24 | -------------------------------------------------------------------------------- /rackunit-doc/rackunit/scribblings/release-notes.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @(require "base.rkt") 3 | 4 | @title{Release Notes} 5 | 6 | @section{Version 3.4} 7 | 8 | This version allows arbitrary expressions within test 9 | suites, fixing the semantics issue below. 10 | 11 | There are also miscellaneous Scribble fixes. 12 | 13 | @section{Version 3} 14 | 15 | This version of RackUnit is largely backwards compatible 16 | with version 2 but there are significant changes to the 17 | underlying model, justifying incrementing the major version 18 | number. These changes are best explained in 19 | @secref["philosophy"]. 20 | 21 | There are a few omissions in this release, that will 22 | hopefully be corrected in later minor version releases: 23 | 24 | @itemize[ 25 | 26 | @item{There is no graphical UI, and in particular no 27 | integration with DrRacket.} 28 | 29 | @item{The semantics of @racket[test-suite] are not the 30 | desired ones. In particular, only checks and test cases 31 | have their evaluation delayed by a test suite; other 32 | expressions will be evaluated before the suite is 33 | constructed. This won't affect tests written in the version 34 | 2 style. In particular this doesn't effect test suites that 35 | contain other test suites; they continue to work in the 36 | expected way. However people incrementally developing tests 37 | from plain checks to test suites might be surprised. I'm 38 | hoping that few enough people will do this that no-one will 39 | notice before it's fixed.} 40 | 41 | ] 42 | -------------------------------------------------------------------------------- /rackunit-doc/rackunit/scribblings/ui.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @require["base.rkt" racket/runtime-path] 3 | @define-runtime-path[screenshot]{rackunit-screen-shot.png} 4 | 5 | 6 | @title[#:tag "ui"]{User Interfaces} 7 | 8 | RackUnit provides a textual and a graphical user interface 9 | 10 | @section{Textual User Interface} 11 | 12 | @defmodule[rackunit/text-ui] 13 | 14 | The textual UI is in the @racketmodname[rackunit/text-ui] module. 15 | It is run via the @racket[run-tests] function. 16 | 17 | @defproc[(run-tests (test (or/c test-case? test-suite?)) 18 | (verbosity (symbols 'quiet 'normal 'verbose) 'normal)) 19 | natural-number/c]{ 20 | 21 | The given @racket[test] is run and the result of running it 22 | output to the @racket[current-output-port] if all tests pass, and to 23 | @racket[current-error-port] when there are test failures. 24 | The output is compatible with the (X)Emacs next-error command (as used, 25 | for example, by (X)Emacs's compile function). 26 | 27 | The optional @racket[verbosity] is one of @racket['quiet], 28 | @racket['normal], or @racket['verbose]. Quiet output 29 | displays only the number of successes, failures, and errors. 30 | Normal reporting suppresses some extraneous check 31 | information (such as the expression). Verbose reports all 32 | information. 33 | 34 | @racket[run-tests] returns the number of unsuccessful tests.} 35 | 36 | 37 | @section{Graphical User Interface} 38 | 39 | @defmodule[rackunit/gui] 40 | 41 | RackUnit also provides a GUI test runner, available from the 42 | @racketmodname[rackunit/gui] module. 43 | 44 | @defproc[(test/gui [test (or/c test-case? test-suite?)] ... 45 | [#:wait? wait? boolean? #f]) 46 | void?]{ 47 | 48 | Creates a new RackUnit GUI window and runs each @racket[test]. The 49 | GUI is updated as tests complete. 50 | 51 | When @racket[wait?] is true, @racket[test/gui] does not return until 52 | the test runner window has been closed. 53 | 54 | Given the following program, the RackUnit GUI will look as shown below: 55 | 56 | @racketblock[ 57 | #,(hash-lang) racket 58 | (require rackunit rackunit/gui) 59 | (test/gui 60 | (test-suite 61 | "all tests" 62 | (test-suite 63 | "math tests" 64 | (test-case "addition" (check-equal? (+ 1 1) 2)) 65 | (test-case "subtraction" (check-equal? (- 0 0) 0)) 66 | (test-case "multiplication" (check-equal? (* 2 2) 5))) 67 | (test-suite 68 | "string tests" 69 | (test-case "append" (check-equal? (string-append "a" "b") "ab")) 70 | (test-case "ref" (check-equal? (string-ref "abc" 1) #\b)))))] 71 | 72 | @image[screenshot]{Screenshot of the RackUnit 73 | window. It features a tree representing the nested test suites (with test 74 | cases as leaves) on the left pane, and information about the selected test 75 | failure in the right pane.} 76 | } 77 | 78 | @defproc[(make-gui-runner) 79 | (-> (or/c test-case? test-suite?) ... any)]{ 80 | 81 | Creates a new RackUnit GUI window and returns a procedure that, when 82 | applied, runs the given tests and displays the results in the GUI. 83 | 84 | } 85 | -------------------------------------------------------------------------------- /rackunit-doc/rackunit/scribblings/utils-label.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require scribble/manual 4 | (for-syntax racket/base 5 | syntax/parse 6 | syntax/strip-context) 7 | (for-label raco/testing)) 8 | 9 | (provide raco-testing) 10 | 11 | (define-syntax (raco-testing stx) 12 | (syntax-parse stx 13 | [(_ x) 14 | #:with x* (replace-context #'here #'x) 15 | #'(racket x*)])) 16 | -------------------------------------------------------------------------------- /rackunit-doc/rackunit/scribblings/utils.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | 3 | @(require scribble/manual 4 | "utils-label.rkt" 5 | (for-label racket 6 | rackunit/log 7 | rackunit/docs-complete)) 8 | 9 | @title{Testing Utilities} 10 | 11 | @section{Checking documentation completeness} 12 | @defmodule[rackunit/docs-complete] 13 | 14 | @defproc[(check-docs [lib module-path?] 15 | [#:skip skip 16 | (or/c regexp? 17 | symbol? 18 | (listof (or/c regexp? symbol?)) 19 | (-> symbol? any) 20 | #f) 21 | #f]) 22 | any]{ 23 | 24 | Checks to see if the module path named by @racket[lib] (e.g. @racket['racket/list]) 25 | has documented all of its exports and prints an error message to 26 | @racket[(current-error-port)] if not. 27 | 28 | If @racket[skip] is a regexp, then exporting matching that regexp 29 | are ignored. If it is a symbol, then that export is ignored. If 30 | it is a list of symbols and regexps, then any exporting matching any of the 31 | symbols or regexps are ignored. If it is a function, the function is treated 32 | as a predicate and passed each export of the module. If @racket[skip] is 33 | @racket[#f], no exports are skipped. 34 | 35 | @history[#:changed "1.10" @elem{Changed @racket[lib] to accept any module path.}]} 36 | 37 | @section{Logging Test Results} 38 | @defmodule[rackunit/log] 39 | 40 | @deprecated[@racketmodname[raco/testing]] 41 | 42 | @defproc[(test-log! [result any/c]) void?]{ 43 | Re-exports @raco-testing[test-log!] from @racketmodname[raco/testing].} 44 | 45 | @defproc[(test-log [#:display? display? any/c #f] 46 | [#:exit? exit? any/c #f]) 47 | (cons/c exact-nonnegative-integer? 48 | exact-nonnegative-integer?)]{ 49 | Re-exports @raco-testing[test-report] from @racketmodname[raco/testing]. 50 | @history[#:changed "1.11" @elem{Allow any value for the @racket[display?] 51 | and @racket[exit?] arguments, not just booleans.}]} 52 | 53 | @defboolparam[test-log-enabled? enabled? #:value #t]{ 54 | Re-exports @raco-testing[test-log-enabled?] from @racketmodname[raco/testing]. 55 | @history[#:added "1.1" 56 | #:changed "1.11" @elem{Allow any value for the parameter and coerce it to a boolean.}]} 57 | 58 | @defparam[current-test-invocation-directory test-invocation-directory (or/c #f path-string?) #:value #f]{ 59 | Re-exports @raco-testing[current-test-invocation-directory] from @racketmodname[raco/testing]. 60 | @history[#:added "1.2"] 61 | } 62 | -------------------------------------------------------------------------------- /rackunit-gui/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection 'multi) 4 | 5 | (define deps '("rackunit-lib" 6 | "class-iop-lib" 7 | "data-lib" 8 | "gui-lib" 9 | "base")) 10 | 11 | (define pkg-desc "RackUnit test runner GUI") 12 | 13 | (define pkg-authors '(ryanc)) 14 | 15 | (define license 16 | '(Apache-2.0 OR MIT)) 17 | -------------------------------------------------------------------------------- /rackunit-gui/rackunit/gui.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/contract/base 3 | racket/gui/base 4 | rackunit/private/base 5 | rackunit/private/gui/gui) 6 | 7 | (define (test/gui #:wait? [wait? #f] 8 | . tests) 9 | (let* ([es (make-eventspace)] 10 | [runner 11 | (parameterize ((current-eventspace es)) 12 | (make-gui-runner))]) 13 | (sleep/yield 0.1) ;; give the gui a chance to initialize 14 | (apply runner tests) 15 | (when wait? (void (sync es))))) 16 | 17 | (define test/c (or/c rackunit-test-case? rackunit-test-suite?)) 18 | 19 | (provide/contract 20 | [test/gui 21 | (->* () 22 | (#:wait? any/c) 23 | #:rest (listof test/c) 24 | any)] 25 | [make-gui-runner 26 | (->* () 27 | () 28 | (->* () () #:rest (listof test/c) 29 | any))]) 30 | -------------------------------------------------------------------------------- /rackunit-gui/rackunit/private/gui/cache-box.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/contract/base) 3 | 4 | ;; Add a new kind of promise instead? 5 | 6 | ;; FIXME: handle exceptions like promises? 7 | 8 | (define (make-cache* thunk) 9 | (make-cache thunk #f)) 10 | 11 | (define (cache-ref cb) 12 | (let ([result (cache-result cb)]) 13 | (if result 14 | (apply values result) 15 | (call-with-values (cache-thunk cb) 16 | (lambda result 17 | (set-cache-result! cb result) 18 | (apply values result)))))) 19 | 20 | (define (cache-invalidate! cb) 21 | (set-cache-result! cb #f)) 22 | 23 | (define (cache-printer cb port write?) 24 | (let ([result (cache-result cb)]) 25 | (if result 26 | (fprintf port 27 | (if write? "#" "#") 28 | (if (and (pair? result) (null? (cdr result))) 29 | (car result) 30 | (cons 'values result))) 31 | (fprintf port "#")))) 32 | 33 | (define-struct cache (thunk [result #:mutable]) 34 | #:property prop:custom-write cache-printer) 35 | 36 | (define-syntax-rule (cache* expr) 37 | (make-cache* (lambda () expr))) 38 | 39 | (provide (rename-out [cache* cache])) 40 | (provide/contract 41 | [rename make-cache* make-cache 42 | (-> (-> any) cache?)] 43 | [cache? 44 | (-> any/c boolean?)] 45 | [cache-ref 46 | (-> cache? any)] 47 | [cache-invalidate! 48 | (-> cache? any)]) 49 | -------------------------------------------------------------------------------- /rackunit-gui/rackunit/private/gui/config.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require framework/preferences) 3 | (provide (all-defined-out)) 4 | 5 | ;; Frame size preferences 6 | 7 | (preferences:set-default 'rackunit:frame:width 400 exact-positive-integer?) 8 | (preferences:set-default 'rackunit:frame:height 400 exact-positive-integer?) 9 | (define pref:width (preferences:get/set 'rackunit:frame:width)) 10 | (define pref:height (preferences:get/set 'rackunit:frame:height)) 11 | 12 | ;; CONSTANTS 13 | ;; Some of these are obsolete, given the preferences above. 14 | 15 | (define DETAILS-CANVAS-INIT-WIDTH 400) 16 | (define FRAME-LABEL "RackUnit") 17 | (define FRAME-INIT-HEIGHT 400) 18 | (define TREE-INIT-WIDTH 240) 19 | (define TREE-COLORIZE-CASES #t) 20 | (define DIALOG-ERROR-TITLE "RackUnit: Error") 21 | (define STATUS-SUCCESS 'success) 22 | (define STATUS-FAILURE 'failure) 23 | (define STATUS-ERROR 'error) 24 | (define STATUS-UNEXECUTED 'unexecuted) 25 | (define VIEW-PANE-PERCENTS 26 | (let [(total (+ DETAILS-CANVAS-INIT-WIDTH TREE-INIT-WIDTH))] 27 | (list (/ TREE-INIT-WIDTH total) (/ DETAILS-CANVAS-INIT-WIDTH total)))) 28 | 29 | ;; Conventional assertion-info keys. 30 | ;; These must be kept in sync with assert-base.rkt. 31 | (define prop:failure-assertion 'name) 32 | (define prop:failure-parameters 'params) 33 | (define prop:failure-location 'location) 34 | (define prop:failure-message 'message) 35 | (define prop:test-case-location 'test-case-location) 36 | 37 | ;; / CONSTANTS 38 | 39 | (define (known-property? s) 40 | (case s 41 | ((name params location message test-case-location) #t) 42 | ((actual expected) #t) 43 | ((expression) #t) 44 | (else #f))) 45 | -------------------------------------------------------------------------------- /rackunit-gui/rackunit/private/gui/controller.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/class 3 | racket/class/iop 4 | framework/notify 5 | rackunit/private/base 6 | "interfaces.rkt" 7 | "model.rkt") 8 | (provide controller%) 9 | 10 | (define controller% 11 | (class* object% (controller<%>) 12 | (super-new) 13 | 14 | ;; model-shown : (notify-box (U model<%> #f)) 15 | ;; The model currently displayed in the Details view, of #f is none. 16 | (notify:define-notify selected-model (new notify:notify-box% (value #f))) 17 | 18 | ;; locked? : (notify-box boolean) 19 | (notify:define-notify locked? (new notify:notify-box% (value #f))) 20 | 21 | ;; view : #f or view<%> 22 | (define view #f) 23 | 24 | ;; check-ready : -> void 25 | (define/private (check-ready) 26 | (unless view 27 | (error 'rackunit "The RackUnit GUI is no longer running.")) 28 | (when (get-locked?) 29 | (error 'rackunit "The RackUnit GUI is locked and not accepting tests."))) 30 | 31 | ;; create-model : test suite<%>/#f -> result<%> 32 | (define/public (create-model test parent) 33 | (define _ (check-ready)) 34 | (define result 35 | (cond [(rackunit-test-case? test) 36 | (new case-result% 37 | (controller this) 38 | (test test) 39 | (name (or (rackunit-test-case-name test) 40 | "")) 41 | (parent parent))] 42 | [(rackunit-test-suite? test) 43 | (new suite-result% 44 | (controller this) 45 | (test test) 46 | (name (or (rackunit-test-suite-name test) 47 | "")) 48 | (parent parent))])) 49 | (send/i view view<%> create-view-link result parent) 50 | result) 51 | 52 | ;; on-model-status-change : model<%> -> void 53 | (define/public (on-model-status-change model) 54 | (let ([view view]) ;; view field is async. mutable! 55 | (when view (send view queue-for-update model))) 56 | (let [(parent (send model get-parent))] 57 | (when parent (send parent on-child-status-change model)))) 58 | 59 | ;; register-view : view<%> -> void 60 | (define/public (register-view v) 61 | (set! view v)) 62 | 63 | ;; on-view-shutdown : -> void 64 | (define/public (on-view-shutdown) 65 | (set! view #f)) 66 | )) 67 | -------------------------------------------------------------------------------- /rackunit-gui/rackunit/private/gui/drracket-link.rkt: -------------------------------------------------------------------------------- 1 | ;; Written in #%kernel to avoid adding any module-attachment 2 | ;; dependencies. Initialized by the DrRacket integration tool. 3 | 4 | (module drracket-link '#%kernel 5 | (#%provide link) 6 | 7 | #| 8 | 9 | If initialized (has non-#f value), the box should contain a vector 10 | of the following procedures: 11 | 12 | (vector get-errortrace-backtrace 13 | show-backtrace 14 | show-source) 15 | |# 16 | 17 | (define-values (link) (box #f))) 18 | -------------------------------------------------------------------------------- /rackunit-gui/rackunit/private/gui/drracket-ui.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "drracket-link.rkt") 3 | 4 | ;; Procedures which *may* be overridden by DrRacket to do useful things. 5 | ;; Or they may not be. 6 | 7 | (provide has-backtrace? 8 | has-errortrace-backtrace? 9 | has-primitive-backtrace? 10 | show-errortrace-backtrace 11 | show-primitive-backtrace 12 | can-show-source? 13 | show-source) 14 | 15 | ;; A Backtrace is one of 16 | ;; - exn 17 | ;; - (listof srcloc) 18 | 19 | (define USE-PRIMITIVE-STACKTRACE? #f) 20 | 21 | ;; has-backtrace? : exn -> boolean 22 | (define (has-backtrace? exn) 23 | (or (has-errortrace-backtrace? exn) 24 | (has-primitive-backtrace? exn))) 25 | 26 | ;; has-errortrace-backtrace? : exn -> boolean 27 | (define (has-errortrace-backtrace? exn) 28 | (not (null? (get-errortrace-backtrace exn)))) 29 | 30 | ;; has-primitive-backtrace? : exn -> boolean 31 | (define (has-primitive-backtrace? exn) 32 | (and USE-PRIMITIVE-STACKTRACE? 33 | (pair? (get-primitive-backtrace exn)))) 34 | 35 | ;; get-errortrace-backtrace : exn -> Backtrace 36 | (define (get-errortrace-backtrace exn) 37 | ((get-errortrace-backtrace*) exn)) 38 | 39 | ;; get-primitive-backtrace : exn -> Backtrace 40 | (define (get-primitive-backtrace exn) 41 | (let* ([ctx (continuation-mark-set->context 42 | (exn-continuation-marks exn))] 43 | [srclocs (map cdr ctx)]) 44 | (filter (lambda (s) 45 | (and (srcloc? s) 46 | (let ([src (srcloc-source s)]) 47 | (and (path? src) 48 | (not (regexp-match? 49 | (regexp-quote 50 | (path->string 51 | (collection-path "rackunit" "private" "gui"))) 52 | (path->string src))))))) 53 | srclocs))) 54 | 55 | ;; show-errortrace-backtrace : exn -> void 56 | (define (show-errortrace-backtrace exn) 57 | ((show-backtrace*) 58 | (exn-message exn) 59 | (get-errortrace-backtrace exn))) 60 | 61 | ;; show-primitive-backtrace : exn -> void 62 | (define (show-primitive-backtrace exn) 63 | ((show-backtrace*) 64 | (exn-message exn) 65 | (get-primitive-backtrace exn))) 66 | 67 | ;; can-show-source? : -> boolean 68 | (define (can-show-source?) 69 | (can-show-source?*)) 70 | 71 | ;; show-source : source number number -> void 72 | (define (show-source src pos span) 73 | ((show-source*) src pos span)) 74 | 75 | ;; ---- 76 | 77 | (define (get-link n) 78 | (let ([v (unbox link)]) 79 | (and (vector? v) (vector-ref v n)))) 80 | 81 | (define (get-errortrace-backtrace*) 82 | (or (get-link 0) 83 | (lambda (exn) null))) 84 | 85 | (define (show-backtrace*) 86 | (or (get-link 1) 87 | void)) 88 | 89 | (define (show-source*) 90 | (or (get-link 2) 91 | void)) 92 | 93 | (define (can-show-source?*) 94 | (vector? (unbox link))) 95 | -------------------------------------------------------------------------------- /rackunit-gui/rackunit/private/gui/gui.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/class 3 | racket/class/iop 4 | rackunit/private/base 5 | rackunit/private/result 6 | rackunit/private/check-info 7 | "interfaces.rkt" 8 | "controller.rkt" 9 | "view.rkt") 10 | (provide make-gui-runner) 11 | 12 | (define (make-gui-runner) 13 | (define controller 14 | (new controller%)) 15 | (define frame 16 | (make-view-frame controller)) 17 | (lambda tests 18 | (for ([test (in-list tests)]) 19 | (run test controller)))) 20 | 21 | (define (run test controller) 22 | ;; state = parent result<%> 23 | 24 | (define (for-suite-entry suite name before after state) 25 | (define model 26 | (send/i controller controller<%> create-model suite state)) 27 | (before) 28 | model) 29 | 30 | (define (for-suite-exit suite name before after state kid-state) 31 | (after) 32 | (send/i kid-state suite<%> finish!) 33 | state) 34 | 35 | (define (for-case case name action state) 36 | (define model 37 | (send/i controller controller<%> create-model case state)) 38 | (run-case case model) 39 | state) 40 | 41 | (foldts-test-suite for-suite-entry for-suite-exit for-case 42 | #f test)) 43 | 44 | ;; From old suite-runner: 45 | #| 46 | (define/public (run) 47 | (let ([custodian (make-custodian)] 48 | [before (rackunit-test-suite-before test)] 49 | [after (rackunit-test-suite-after test)]) 50 | (parameterize [(current-custodian custodian)] 51 | (dynamic-wind 52 | before 53 | (lambda () 54 | (for-each (lambda (c) (send c run)) (get-children)) 55 | (custodian-shutdown-all custodian)) 56 | after))) 57 | (on-child-status-change #f)) 58 | |# 59 | 60 | ;; ---- 61 | 62 | (define (run-case test model) 63 | (define primerr (current-error-port)) 64 | (define iport (open-input-string "")) 65 | (define super-cust (current-custodian)) 66 | (define cust (make-custodian)) 67 | (define-values (oport errport get-output) 68 | (make-output-ports)) 69 | (let-values ([(test-result timing) 70 | (parameterize [(current-input-port iport) 71 | (current-output-port oport) 72 | (current-error-port errport) 73 | (current-custodian cust)] 74 | (run/time-test test))]) 75 | ;;(set! timing times) 76 | (define trash 77 | (map (lambda (x) (format "~s" x)) 78 | (custodian-managed-list cust super-cust))) 79 | (cond [(test-success? test-result) 80 | (send/i model case<%> update 81 | test-result 82 | (test-success-result test-result) 83 | null 84 | timing 85 | (get-output) 86 | trash)] 87 | [(test-failure? test-result) 88 | (let* ([exn (test-failure-result test-result)] 89 | [property-stack (exn:test:check-stack exn)]) 90 | (send/i model case<%> update 91 | test-result 92 | (test-failure-result test-result) 93 | (for/list ([pp property-stack]) 94 | (cons (check-info-name pp) (check-info-value pp))) 95 | timing 96 | (get-output) 97 | trash))] 98 | [(test-error? test-result) 99 | (send/i model case<%> update 100 | test-result 101 | (test-error-result test-result) 102 | null 103 | timing 104 | (get-output) 105 | trash)]))) 106 | 107 | (define (run/time-test test) 108 | (let-values ([(results cputime realtime gctime) 109 | (call-with-continuation-prompt 110 | (lambda () 111 | (time-apply run-test-case 112 | (list (rackunit-test-case-name test) 113 | (rackunit-test-case-action test)))))]) 114 | (values (car results) (list cputime realtime gctime)))) 115 | 116 | (define (make-output-ports) 117 | (define output null) 118 | (define output-sema (make-semaphore 1)) 119 | (define (make-output-collector tag) 120 | (define (do-write-out buf start end) 121 | (define subbuf (subbytes buf start end)) 122 | (if (and (pair? output) 123 | (eq? (car (car output)) tag)) 124 | ;; Coalesce 125 | (let ([prev (cdr (car output))]) 126 | (set! output 127 | (cons (cons tag (cons subbuf prev)) (cdr output)))) 128 | (set! output (cons (list tag subbuf) output))) 129 | (- end start)) 130 | (define name #f) 131 | (define evt output-sema) 132 | (define (write-out buf start end buffer? enable-break?) 133 | ((if enable-break? sync/enable-break sync) output-sema) 134 | (begin0 (do-write-out buf start end) (semaphore-post output-sema))) 135 | (define (close) (void)) 136 | (define (get-write-evt buf start end) 137 | (wrap-evt output-sema 138 | (lambda (_) 139 | (begin0 (write-out buf start end #f #f) 140 | (semaphore-post output-sema))))) 141 | (make-output-port name evt write-out close #f 142 | get-write-evt #f)) 143 | (values (make-output-collector 'output) 144 | (make-output-collector 'error) 145 | (lambda () output))) 146 | -------------------------------------------------------------------------------- /rackunit-gui/rackunit/private/gui/interfaces.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/class/iop) 3 | (provide (all-defined-out)) 4 | 5 | ;; controller 6 | ;; Manages the model and view. 7 | ;; Propagates status changes from model to view. 8 | (define-interface controller<%> () 9 | (get-selected-model 10 | set-selected-model 11 | listen-selected-model 12 | 13 | create-model 14 | on-model-status-change 15 | register-view 16 | on-view-shutdown 17 | 18 | ;; field: locked? 19 | )) 20 | 21 | ;; result 22 | ;; Represents a test (case or suite) together with the state associated 23 | ;; with the last run of that test. 24 | (define-interface result<%> () 25 | (get-test 26 | get-parent 27 | get-name 28 | get-controller 29 | 30 | finished? 31 | success? 32 | failure? 33 | error? 34 | has-output? 35 | has-trash? 36 | get-timing 37 | 38 | get-total-cases 39 | get-total-successes 40 | get-total-failures)) 41 | 42 | (define-interface case<%> (result<%>) 43 | (update 44 | get-result 45 | get-output 46 | get-trash 47 | get-property 48 | get-property-set 49 | get-all-properties)) 50 | 51 | (define-interface suite<%> (result<%>) 52 | (get-children 53 | add-child 54 | finish! 55 | on-child-status-change)) 56 | 57 | 58 | ;; view 59 | ;; Presents a graphical interface for inspecting and running tests. 60 | (define-interface view<%> () 61 | (create-view-link 62 | queue-for-update 63 | shutdown)) 64 | 65 | ;; style-map 66 | ;; Maps symbolic style names ('bold, 'red) to GRacket styles. 67 | (define-interface style-map<%> () 68 | (get-style)) 69 | -------------------------------------------------------------------------------- /rackunit-gui/rackunit/private/gui/model.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/class 3 | racket/class/iop 4 | data/gvector 5 | rackunit/private/base 6 | "interfaces.rkt" 7 | "cache-box.rkt") 8 | (provide case-result% 9 | suite-result%) 10 | 11 | (define result% 12 | (class* object% () 13 | (super-new) 14 | 15 | (init-field parent 16 | controller 17 | name 18 | test) 19 | 20 | (when parent 21 | (send/i parent suite<%> add-child this)) 22 | 23 | (define/public (get-parent) parent) 24 | (define/public (get-name) name) 25 | (define/public (get-controller) controller) 26 | (define/public (get-test) test) 27 | )) 28 | 29 | ;; case-result% 30 | (define case-result% 31 | (class* result% (case<%>) 32 | (super-new) 33 | 34 | (inherit get-name 35 | get-parent 36 | get-controller) 37 | 38 | ;; *result : #f or test-result 39 | ;; #f means not finished executing 40 | (define *result #f) 41 | 42 | (define result #f) 43 | (define properties #f) 44 | (define timing #f) 45 | (define output null) 46 | (define trash null) 47 | 48 | (define/public (update *result* result* properties* timing* output* trash*) 49 | (set! *result *result*) 50 | (set! result result*) 51 | (set! properties properties*) 52 | (set! timing timing*) 53 | (set! output output*) 54 | (set! trash trash*) 55 | (send/i (get-controller) controller<%> on-model-status-change this)) 56 | 57 | (define/public (finished?) (and *result #t)) 58 | (define/public (success?) (test-success? *result)) 59 | (define/public (failure?) (test-failure? *result)) 60 | (define/public (error?) (test-error? *result)) 61 | 62 | (define/public (get-total-cases) 1) 63 | (define/public (get-total-successes) 64 | (if (success?) 1 0)) 65 | (define/public (get-total-failures) 66 | (if (or (failure?) (error?)) 1 0)) 67 | 68 | (define/public (get-result) result) 69 | (define/public (get-timing) timing) 70 | (define/public (get-trash) trash) 71 | (define/public (has-trash?) (pair? trash)) 72 | (define/public (get-property p) 73 | (let [(v (assq p properties))] 74 | (and v (cdr v)))) 75 | (define/public (get-property-set p) 76 | (map cdr (filter (lambda (kv) (eq? (car kv) p)) properties))) 77 | (define/public (get-all-properties) 78 | properties) 79 | 80 | (define/public (get-output) (reverse output)) 81 | (define/public (has-output?) (pair? output)))) 82 | 83 | ;; An aggr contains aggregate information about a suite's children. 84 | (struct aggr (cases successes failures has-output? has-trash? tcpu treal tgc) 85 | #:transparent) 86 | 87 | ;; suite-result% 88 | (define suite-result% 89 | (class* result% (suite<%>) 90 | (super-new) 91 | (inherit get-name 92 | get-parent 93 | get-controller) 94 | 95 | (define done? #f) 96 | (define children (make-gvector)) 97 | 98 | ;; get-children : -> (listof result<%>) 99 | (define/public (get-children) 100 | (for/list ([x (in-gvector children)]) x)) 101 | 102 | (define/public (add-child c) 103 | (gvector-add! children c)) 104 | 105 | (define/public (finish!) 106 | (set! done? #t) 107 | (send/i (get-controller) controller<%> on-model-status-change this)) 108 | 109 | (define children-cache 110 | (cache (call-with-values 111 | (lambda () 112 | (for/fold ([cs 0] [ss 0] [fs 0] [out? #f] [trash? #f] 113 | [tcpu 0] [treal 0] [tgc 0]) 114 | ([c (in-gvector children)]) 115 | (let ([timing (or (send/i c result<%> get-timing) '(0 0 0))]) 116 | (values (+ cs (send/i c result<%> get-total-cases)) 117 | (+ ss (send/i c result<%> get-total-successes)) 118 | (+ fs (send/i c result<%> get-total-failures)) 119 | (or out? (send/i c result<%> has-output?)) 120 | (or trash? (send/i c result<%> has-trash?)) 121 | (+ tcpu (car timing)) 122 | (+ treal (cadr timing)) 123 | (+ tgc (caddr timing)))))) 124 | aggr))) 125 | 126 | (define/public (finished?) 127 | done?) 128 | (define/public (get-total-cases) 129 | (aggr-cases (cache-ref children-cache))) 130 | (define/public (get-total-successes) 131 | (aggr-successes (cache-ref children-cache))) 132 | (define/public (get-total-failures) 133 | (aggr-failures (cache-ref children-cache))) 134 | (define/public (has-output?) 135 | (aggr-has-output? (cache-ref children-cache))) 136 | (define/public (has-trash?) 137 | (aggr-has-trash? (cache-ref children-cache))) 138 | (define/public (get-timing) 139 | (let ([a (cache-ref children-cache)]) 140 | (list (aggr-tcpu a) (aggr-treal a) (aggr-tgc a)))) 141 | 142 | (define/public (success?) 143 | (and (finished?) (zero? (get-total-failures)))) 144 | (define/public (failure?) 145 | (positive? (get-total-failures))) 146 | (define/public (error?) #f) 147 | 148 | ;; on-child-status-change : model<%> -> void 149 | (define/public (on-child-status-change child) 150 | (let ([result (cache-ref children-cache)]) 151 | (cache-invalidate! children-cache) 152 | (let ([new-result (cache-ref children-cache)]) 153 | (unless (equal? new-result result) 154 | (send/i (get-controller) controller<%> on-model-status-change this))))))) 155 | -------------------------------------------------------------------------------- /rackunit-gui/rackunit/private/gui/output-icon.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/rackunit/bc6f18a8ed5d8d4673d57dee7e33bb388bcebb2a/rackunit-gui/rackunit/private/gui/output-icon.png -------------------------------------------------------------------------------- /rackunit-gui/rackunit/private/gui/rml.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/class 3 | racket/gui/base 4 | framework 5 | "interfaces.rkt") 6 | 7 | (provide insert-text 8 | ext:text% 9 | rackunit-style-map) 10 | 11 | ;; insert-text : text% string style-delta% -> void 12 | (define (insert-text e text style) 13 | (let ([a (send e last-position)]) 14 | (send e insert text) 15 | (let ([b (send e last-position)]) 16 | (send e change-style style a b)))) 17 | 18 | (define text<%> (class->interface text%)) 19 | 20 | (define ext:text-mixin 21 | (mixin (text<%>) () 22 | (init-field (style-map rackunit-style-map)) 23 | (inherit last-position 24 | change-style 25 | set-clickback 26 | insert 27 | get-canvas 28 | set-styles-sticky 29 | set-autowrap-bitmap) 30 | 31 | (super-new (auto-wrap #t)) 32 | (set-styles-sticky #f) 33 | (set-autowrap-bitmap #f) 34 | 35 | ;; insert/styles : (list-of style-delta%) string ... -> void 36 | ;; A list of styles to be applied. The first style is the last applied. 37 | (define/public (insert/styles styles . texts) 38 | (unless (andmap (lambda (x) (or (string? x) (is-a? x snip%))) texts) 39 | (raise-type-error 'insert/styles "list of strings" texts)) 40 | (let-values ([(a b) (put texts)]) 41 | (for-each (lambda (style) (change-style (resolve style) a b)) 42 | (reverse styles)))) 43 | 44 | ;; insert/styles+click : (list-of style-delta%) (?? -> void) string ...-> void 45 | (define/public (insert/styles+click styles clickback . texts) 46 | (unless (andmap (lambda (x) (or (string? x) (is-a? x snip%))) texts) 47 | (raise-type-error 'insert/styles+click "list of strings" texts)) 48 | (let-values ([(a b) (put texts)]) 49 | (for-each (lambda (style) (change-style (resolve style) a b)) 50 | (reverse styles)) 51 | (set-clickback a b clickback))) 52 | 53 | ;; put : (list-of string) -> int int 54 | (define/private (put texts) 55 | (let ([a (last-position)]) 56 | (let loop ([texts texts] [where a]) 57 | (if (pair? texts) 58 | (begin (insert (car texts) where 'same #f) 59 | (loop (cdr texts) (last-position))) 60 | (values a where))))) 61 | 62 | (define/private (resolve style) 63 | (if (symbol? style) 64 | (send style-map get-style style) 65 | style)) 66 | 67 | ;; newline : -> void 68 | (define/public (newline) 69 | (insert/styles '() "\n")) 70 | 71 | ;; insert-wide-box : (ext:text<%> -> void) -> void 72 | (define/public (insert-wide-box p) 73 | (internal-insert-box p #t) 74 | (newline)) 75 | 76 | ;; internal-insert-box : (ext:text<%> -> void) boolean? -> void 77 | (define/private (internal-insert-box p wide?) 78 | (let* ([seditor (new ext:text%)] 79 | [snip (new editor-snip% (editor seditor))]) 80 | (p seditor) 81 | (let [(canvas (get-canvas))] 82 | (when (and (is-a? canvas canvas:wide-snip<%>) wide?) 83 | (send canvas add-wide-snip snip))) 84 | (insert snip) 85 | (send seditor lock #t))) 86 | 87 | )) 88 | 89 | (define ext:text% 90 | (text:wide-snip-mixin 91 | (ext:text-mixin 92 | text:hide-caret/selection%))) 93 | 94 | (define style:no-change (make-object style-delta% 'change-nothing)) 95 | (define style:normal (make-object style-delta% 'change-normal)) 96 | (define style:large (make-object style-delta% 'change-nothing)) 97 | (void (send style:large set-size-mult 1.5)) 98 | 99 | (define style:blue (make-object style-delta% 'change-nothing)) 100 | (void (send style:blue set-delta-foreground "Blue")) 101 | 102 | (define style:red (make-object style-delta% 'change-nothing)) 103 | (void (send style:red set-delta-foreground "Red")) 104 | 105 | (define style:green (make-object style-delta% 'change-nothing)) 106 | (void (send style:green set-delta-foreground "ForestGreen")) 107 | 108 | (define style:purple (make-object style-delta% 'change-nothing)) 109 | (void (send style:purple set-delta-foreground "Purple")) 110 | 111 | (define style:gray (make-object style-delta% 'change-nothing)) 112 | (void (send style:gray set-delta-foreground "DimGray")) 113 | 114 | (define style:darkblue (make-object style-delta% 'change-nothing)) 115 | (void (send style:darkblue set-delta-foreground "DarkBlue")) 116 | 117 | (define style:clickback (make-object style-delta% 'change-underline #t)) 118 | (void (send style:clickback set-delta-foreground "blue")) 119 | 120 | (define style:bold (make-object style-delta% 'change-nothing)) 121 | (void (send style:bold set-delta 'change-weight 'bold)) 122 | 123 | (define style:italic (make-object style-delta% 'change-nothing)) 124 | (void (send style:italic set-delta 'change-style 'italic)) 125 | 126 | (define basic-styles 127 | `([no-change . ,style:no-change] 128 | [normal . ,style:normal] 129 | [large . ,style:large] 130 | [clickback . ,style:clickback] 131 | [red . ,style:red] 132 | [blue . ,style:blue] 133 | [green . ,style:green] 134 | [purple . ,style:purple] 135 | [darkblue . ,style:darkblue] 136 | [bold . ,style:bold] 137 | [italic . ,style:italic] 138 | [error . ,style:red] 139 | [value . ,style:darkblue])) 140 | 141 | (define rackunit-styles 142 | `([test-unexecuted . ,style:gray] 143 | [test-success . ,style:green] 144 | [test-failure . ,style:red] 145 | [test-error . ,style:red] 146 | 147 | [exn-type . ,style:darkblue] 148 | [exn-message . ,style:red] 149 | [exn-value . ,style:darkblue] 150 | [fail-type . ,style:darkblue])) 151 | 152 | 153 | ;; -- style-map classes 154 | 155 | (define extended-style-map% 156 | (class* object% (style-map<%>) 157 | (init-field styles 158 | base) 159 | (define/public (get-style sym) 160 | (cond [(assq sym styles) => cdr] 161 | [else (send base get-style sym)])) 162 | (super-new))) 163 | 164 | (define empty-style-map% 165 | (class* object% (style-map<%>) 166 | (define/public (get-style sym) 167 | (error 'get-style "unknown style: ~s" sym)) 168 | (super-new))) 169 | 170 | ;; extend-style-map : style-map<%> styles -> style-map<%> 171 | (define (extend-style-map base styles) 172 | (new extended-style-map% (base base) (styles styles))) 173 | 174 | ;; empty-style-map : style-map<%> 175 | (define empty-style-map 176 | (new empty-style-map%)) 177 | 178 | ;; basic-style-map : style-map<%> 179 | (define basic-style-map 180 | (extend-style-map empty-style-map 181 | basic-styles)) 182 | 183 | ;; rackunit-style-map : style-map<%> 184 | (define rackunit-style-map 185 | (extend-style-map basic-style-map 186 | rackunit-styles)) 187 | -------------------------------------------------------------------------------- /rackunit-lib/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection 'multi) 4 | 5 | (define deps '("base" 6 | "testing-util-lib")) 7 | 8 | (define implies '("testing-util-lib")) 9 | 10 | (define pkg-desc "RackUnit testing framework") 11 | 12 | (define pkg-authors '(ryanc noel)) 13 | 14 | (define version "1.11") 15 | 16 | (define license 17 | '(Apache-2.0 OR MIT)) 18 | -------------------------------------------------------------------------------- /rackunit-lib/rackunit/HISTORY.txt: -------------------------------------------------------------------------------- 1 | 6.0 2 | - Improvements/Bugfixes to the Text UI. 3 | - Added an optional message argument to fail-check. 4 | -------------------------------------------------------------------------------- /rackunit-lib/rackunit/main.rkt: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; Time-stamp: <2008-07-30 10:46:00 nhw> 3 | ;;; 4 | ;;; Copyright (C) by Noel Welsh. 5 | ;;; 6 | 7 | ;;; This library is free software; you can redistribute it 8 | ;;; and/or modify it under the terms of the GNU Lesser 9 | ;;; General Public License as published by the Free Software 10 | ;;; Foundation; either version 2.1 of the License, or (at 11 | ;;; your option) any later version. 12 | 13 | ;;; This library is distributed in the hope that it will be 14 | ;;; useful, but WITHOUT ANY WARRANTY; without even the 15 | ;;; implied warranty of MERCHANTABILITY or FITNESS FOR A 16 | ;;; PARTICULAR PURPOSE. See the GNU Lesser General Public 17 | ;;; License for more details. 18 | 19 | ;;; You should have received a copy of the GNU Lesser 20 | ;;; General Public License along with this library; if not, 21 | ;;; write to the Free Software Foundation, Inc., 59 Temple 22 | ;;; Place, Suite 330, Boston, MA 02111-1307 USA 23 | 24 | ;;; Author: Noel Welsh 25 | ;; 26 | ;; 27 | ;; Commentary: 28 | 29 | #lang racket/base 30 | (require "private/test.rkt" 31 | "private/check.rkt") 32 | (provide (all-from-out "private/test.rkt") 33 | (for-syntax check-transformer-impl-name 34 | check-transformer?)) 35 | -------------------------------------------------------------------------------- /rackunit-lib/rackunit/private/base.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/contract/base 3 | "check-info.rkt" 4 | "location.rkt") 5 | 6 | ;; struct test : 7 | (define-struct test ()) 8 | ;; struct (rackunit-test-case test) : (U string #f) thunk 9 | (define-struct (rackunit-test-case test) (name action) #:transparent) 10 | ;; struct (rackunit-test-suite test) : string (fdown fup fhere seed -> (listof test-result)) thunk thunk 11 | (define-struct (rackunit-test-suite test) (name tests before after) #:transparent) 12 | 13 | ;; struct exn:test exn:fail : () 14 | ;; 15 | ;; The exception throw by test failures 16 | (define-struct (exn:test exn:fail) ()) 17 | ;; struct (exn:test:check struct:exn:test) : (list-of check-info) 18 | ;; 19 | ;; The exception thrown to indicate a check has failed 20 | (define-struct (exn:test:check exn:test) (stack) 21 | #:property prop:exn:srclocs 22 | (lambda (self) 23 | ;; Try to get a location from the stack. 24 | (define maybe-location (for/or ([check-info (exn:test:check-stack self)]) 25 | (and (check-location? check-info) check-info))) 26 | (cond [maybe-location 27 | (define loc (location-info-value (check-info-value maybe-location))) 28 | (list (location->srcloc loc))] 29 | [else 30 | (list)]))) 31 | ;; struct (exn:test:check:internal exn:test:check) : () 32 | ;; 33 | ;; Exception thrown to indicate an internal failure in an 34 | ;; check, distinguished from a failure in user code. 35 | (define-struct (exn:test:check:internal exn:test:check) ()) 36 | 37 | ;; struct test-result : (U string #f) 38 | (define-struct test-result (test-case-name)) 39 | ;; struct (test-failure test-result) : exn:test 40 | (define-struct (test-failure test-result) (result)) 41 | ;; struct (test-error test-result) : any 42 | (define-struct (test-error test-result) (result)) 43 | ;; struct (test-success test-result) : any 44 | (define-struct (test-success test-result) (result)) 45 | 46 | (provide/contract 47 | (struct (rackunit-test-case test) 48 | ((name (or/c string? false/c)) 49 | (action (-> any)))) 50 | (struct (rackunit-test-suite test) 51 | ((name string?) 52 | (tests procedure?) 53 | (before (-> any)) 54 | (after (-> any))))) 55 | 56 | (provide (struct-out test) 57 | (struct-out exn:test) 58 | (struct-out exn:test:check) 59 | (struct-out exn:test:check:internal) 60 | (struct-out test-result) 61 | (struct-out test-failure) 62 | (struct-out test-error) 63 | (struct-out test-success)) 64 | -------------------------------------------------------------------------------- /rackunit-lib/rackunit/private/check-info.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base 4 | racket/list 5 | racket/port 6 | racket/pretty 7 | rackunit/log 8 | "location.rkt" 9 | (for-syntax racket/base 10 | racket/syntax)) 11 | 12 | (provide 13 | (contract-out 14 | [struct check-info ([name symbol?] 15 | [value any/c])] 16 | [struct string-info ([value string?])] 17 | [struct location-info ([value location/c])] 18 | [struct pretty-info ([value any/c])] 19 | [struct nested-info ([values (listof check-info?)])] 20 | [struct verbose-info ([value any/c])] 21 | [struct dynamic-info ([proc (-> any/c)])] 22 | [print-info-value (-> any/c any)] 23 | [info-value->string (-> any/c string?)] 24 | [current-check-info (parameter/c (listof check-info?))] 25 | [check-info-contains-key? (check-info-> symbol? boolean?)] 26 | [check-info-ref (check-info-> symbol? (or/c check-info? #f))] 27 | [with-check-info* ((listof check-info?) (-> any) . -> . any)] 28 | [with-default-check-info* ((listof check-info?) (-> any) . -> . any)]) 29 | with-check-info) 30 | 31 | (module+ for-test 32 | (provide trim-current-directory)) 33 | 34 | (define (check-info-> dom cod) 35 | (case-> (-> dom cod) 36 | (-> (listof check-info?) dom cod))) 37 | 38 | ;; Structures -------------------------------------------------- 39 | 40 | (struct check-info (name value) 41 | #:transparent #:constructor-name make-check-info) 42 | 43 | (struct string-info (value) #:transparent) 44 | (struct location-info (value) #:transparent) 45 | (struct pretty-info (value) #:transparent) 46 | (struct verbose-info (value) #:transparent) 47 | (struct nested-info (values) #:transparent) 48 | (struct dynamic-info (proc) #:transparent) 49 | 50 | (define (info-value->string info-value) 51 | (with-output-to-string 52 | (lambda () 53 | (print-info-value info-value)))) 54 | 55 | (define (print-info-value info-value) 56 | (cond 57 | [(string-info? info-value) (display (string-info-value info-value))] 58 | [(location-info? info-value) 59 | (display (trim-current-directory 60 | (location->string (location-info-value info-value))))] 61 | [(pretty-info? info-value) 62 | (pretty-print (pretty-info-value info-value) #:newline? #f)] 63 | [(verbose-info? info-value) 64 | (print-info-value (verbose-info-value info-value))] 65 | [else 66 | (write info-value)])) 67 | 68 | (define (trim-current-directory path) 69 | (define cd (path->string (or (current-test-invocation-directory) 70 | (current-directory)))) 71 | (regexp-replace (regexp-quote cd) path "")) 72 | 73 | ;; Infrastructure ---------------------------------------------- 74 | 75 | (define current-check-info (make-parameter '())) 76 | 77 | ;; with-check-info* : (list-of check-info) thunk -> any 78 | (define (with-check-info* info thunk) 79 | (define all-infos (append (current-check-info) info)) 80 | (define infos/later-overriding-earlier 81 | (reverse (remove-duplicates (reverse all-infos) #:key check-info-name))) 82 | (force/info infos/later-overriding-earlier thunk)) 83 | 84 | ;; with-default-check-info* : (listof check-info) thunk -> any 85 | (define (with-default-check-info* info thunk) 86 | (define old-info (current-check-info)) 87 | (define old-keys (map check-info-name old-info)) 88 | (define (has-new-key? info) 89 | (not (memq (check-info-name info) old-keys))) 90 | (define new-info (filter has-new-key? info)) 91 | (force/info (append old-info new-info) thunk)) 92 | 93 | ;; force/info : (listof check-info) thunk -> any 94 | (define (force/info info thunk) 95 | (parameterize ([current-check-info info]) 96 | (thunk))) 97 | 98 | (define-syntax with-check-info 99 | (syntax-rules () 100 | [(_ ((name val) ...) body ...) 101 | (with-check-info* 102 | (list (make-check-info name val) ...) 103 | (lambda () body ...))])) 104 | 105 | (define-syntax (define-check-type stx) 106 | (syntax-case stx () 107 | [(_ id contract #:wrapper wrapper-proc) 108 | (with-syntax 109 | ([make-check-id (format-id #'id "make-check-~a" #'id)] 110 | [check-id? (format-id #'id "check-~a?" #'id)]) 111 | (syntax/loc stx 112 | (begin 113 | (define (make-check-id a) (make-check-info 'id (wrapper-proc a))) 114 | (define (check-id? info) (eq? (check-info-name info) 'id)) 115 | (provide/contract 116 | [make-check-id (contract . -> . check-info?)] 117 | [check-id? (check-info? . -> . boolean?)]))))] 118 | [(_ id contract) 119 | (syntax/loc stx (define-check-type id contract #:wrapper values))])) 120 | 121 | (define-check-type name any/c) 122 | (define-check-type params any/c #:wrapper pretty-info) 123 | (define-check-type location location/c #:wrapper location-info) 124 | (define-check-type expression any/c #:wrapper verbose-info) 125 | (define-check-type message any/c) 126 | (define-check-type actual any/c #:wrapper pretty-info) 127 | (define-check-type expected any/c #:wrapper pretty-info) 128 | (define-check-type tolerance any/c #:wrapper pretty-info) 129 | 130 | (define check-info-ref 131 | (case-lambda 132 | [(k) 133 | (check-info-ref (current-check-info) k)] 134 | [(info k) 135 | (findf (λ (i) (eq? k (check-info-name i))) info)])) 136 | 137 | (define check-info-contains-key? 138 | (case-lambda 139 | [(k) 140 | (check-info-contains-key? (current-check-info) k)] 141 | [(info k) 142 | (and (check-info-ref info k) #t)])) 143 | -------------------------------------------------------------------------------- /rackunit-lib/rackunit/private/check.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (for-syntax racket/base 4 | racket/syntax 5 | syntax/parse) 6 | racket/contract/base 7 | racket/match 8 | rackunit/log 9 | syntax/parse/define 10 | "base.rkt" 11 | "equal-within.rkt" 12 | "check-info.rkt" 13 | "format.rkt" 14 | "location.rkt") 15 | 16 | (provide 17 | (contract-out 18 | [fail-check (->* () (string?) void?)] 19 | [current-check-handler (parameter/c (-> any/c any))] 20 | [current-check-around (parameter/c (-> (-> any/c) any))] 21 | [plain-check-around (-> (-> void?) void?)])) 22 | 23 | (provide check-around 24 | 25 | define-check 26 | define-binary-check 27 | define-simple-check 28 | 29 | check 30 | check-exn 31 | check-not-exn 32 | check-true 33 | check-false 34 | check-pred 35 | check-eq? 36 | check-eqv? 37 | check-equal? 38 | check-= 39 | check-within 40 | check-not-false 41 | check-not-eq? 42 | check-not-eqv? 43 | check-not-equal? 44 | check-match 45 | fail) 46 | 47 | (define current-check-handler (make-parameter display-test-failure/error)) 48 | (define (not-break-exn? x) (not (exn:break? x))) 49 | 50 | ;; Like default-check-around, except without test logging. This used to be used 51 | ;; by test-case, and is currently undocumented. Typed Racket's wrapper around 52 | ;; rackunit uses this (although it shouldn't) so we can't get rid of it yet. 53 | ;; Setting (current-check-handler) to `raise` makes this equivalent to 54 | ;; plain-check-around. 55 | (define (check-around thunk) 56 | (define handler (current-check-handler)) 57 | (with-handlers ([not-break-exn? handler]) (thunk))) 58 | 59 | ;; Evaluates a check just like a normal function, with no calls to test-log! 60 | ;; or the current check handler. Check failures are raised as plain exceptions. 61 | (define (plain-check-around chk-thunk) (chk-thunk)) 62 | 63 | ;; This is the default for current-check-around, and ensures a check logs 64 | ;; test results appropriately. 65 | (define (default-check-around chk-thunk) 66 | (define handler (current-check-handler)) 67 | (define (log-and-handle! e) (test-log! #f) (handler e)) 68 | ;; Nested checks should be evaluated as normal functions, to avoid double 69 | ;; counting test results. 70 | (parameterize ([current-check-around plain-check-around]) 71 | (with-handlers ([not-break-exn? log-and-handle!]) 72 | (chk-thunk) 73 | (test-log! #t)))) 74 | 75 | (define current-check-around (make-parameter default-check-around)) 76 | 77 | (define (fail-check [message ""]) 78 | (define marks (current-continuation-marks)) 79 | (raise (make-exn:test:check message marks (current-check-info)))) 80 | 81 | ;; refail-check : exn:test:check -> (exception raised) 82 | ;; 83 | ;; Raises an exn:test:check with the contents of the 84 | ;; given exception. Useful for propogating internal 85 | ;; errors to the outside world. 86 | (define (refail-check exn) 87 | (raise 88 | (make-exn:test:check (exn-message exn) 89 | (exn-continuation-marks exn) 90 | (exn:test:check-stack exn)))) 91 | 92 | (define (list/if . vs) (filter values vs)) 93 | 94 | (begin-for-syntax 95 | (require racket/syntax) 96 | ;; xform is the actual macro transformer procedure 97 | ;; impl-name is an identifier naming the `check-impl` procedure 98 | (struct check-transformer (xform impl) 99 | #:property prop:procedure 0) 100 | (provide check-transformer-impl-name check-transformer?) 101 | (define (check-transformer-impl-name s) 102 | (unless (check-transformer? s) 103 | (raise-argument-error 104 | 'check-transformer-impl-name "check-transformer?" s)) 105 | (check-transformer-impl s)) 106 | (define-syntax-class check-name 107 | (pattern i:id 108 | #:with impl-name (format-id #f "~a-impl" #'i)))) 109 | 110 | (define-simple-macro (define-check-func (name:id formal:id ...) #:public-name pub:id body:expr ...) 111 | (define (name #:location [location (list 'unknown #f #f #f #f)] 112 | #:expression [expression 'unknown] 113 | #:check-around [check-around current-check-around]) 114 | (procedure-rename 115 | (λ (formal ... [message #f]) 116 | (when (and message (not (string? message))) 117 | (raise-argument-error 'pub "(or/c #f string?)" message)) 118 | (define infos 119 | (list/if (make-check-name 'pub) 120 | (make-check-location location) 121 | (make-check-expression expression) 122 | (make-check-params (list formal ...)) 123 | (and message (make-check-message message)))) 124 | (with-default-check-info* infos 125 | (λ () ((check-around) (λ () body ... (void)))))) 126 | 'pub))) 127 | 128 | (define-simple-macro (define-check (name:check-name formal:id ...) body:expr ...) 129 | (begin 130 | (define-check-func (name.impl-name formal ...) #:public-name name body ...) 131 | ;; (define check-impl (make-check-func (name.impl-name formal ...) #:public-name name body ...)) 132 | (define-syntax name 133 | (check-transformer 134 | (lambda (stx) 135 | (with-syntax ([loc (datum->syntax #f 'loc stx)]) 136 | (syntax-parse stx 137 | [(chk . args) 138 | #`(let ([location (syntax->location #'loc)]) 139 | (with-default-check-info* 140 | (list (make-check-name 'name) 141 | (make-check-location location) 142 | (make-check-expression '(chk . args))) 143 | #,(syntax/loc #'loc 144 | (λ () 145 | ((current-check-around) 146 | (λ () 147 | ((name.impl-name #:location location 148 | #:expression '(chk . args) 149 | #:check-around (λ () (λ (f) (f)))) 150 | . args)))))))] 151 | [chk:id 152 | #'(name.impl-name #:location (syntax->location #'loc) 153 | #:expression 'chk)]))) 154 | #'name.impl-name)))) 155 | 156 | 157 | (define-syntax-rule (define-simple-check (name param ...) body ...) 158 | (define-check (name param ...) 159 | (or (let () body ...) (fail-check)))) 160 | 161 | (define-syntax define-binary-check 162 | (syntax-rules () 163 | [(_ (name expr1 expr2) body ...) 164 | (define-check (name expr1 expr2) 165 | (with-default-check-info* 166 | (list (make-check-actual expr1) 167 | (make-check-expected expr2)) 168 | (lambda () (or (let () body ...) (fail-check)))))] 169 | [(_ (name pred expr1 expr2)) 170 | (define-binary-check (name expr1 expr2) (pred expr1 expr2))])) 171 | 172 | (define (raise-error-if-not-thunk name thunk) 173 | (unless (and (procedure? thunk) 174 | (procedure-arity-includes? thunk 0)) 175 | (raise-arguments-error name "thunk must be a procedure that accepts 0 arguments" "thunk" thunk))) 176 | 177 | (define-check (check-exn raw-pred thunk) 178 | (let ([pred 179 | (cond [(regexp? raw-pred) 180 | (λ (x) (and (exn:fail? x) (regexp-match raw-pred (exn-message x))))] 181 | [(and (procedure? raw-pred) (procedure-arity-includes? raw-pred 1)) 182 | raw-pred] 183 | [else 184 | (raise-argument-error 'check-exn "(or/c (-> any/c any/c) regexp?)" raw-pred)])]) 185 | (raise-error-if-not-thunk 'check-exn thunk) 186 | (let/ec succeed 187 | (with-handlers 188 | (;; catch the exception we are looking for and 189 | ;; succeed 190 | [pred 191 | (lambda (exn) (succeed #t))] 192 | ;; rethrow check failures if we aren't looking 193 | ;; for them 194 | [exn:test:check? 195 | (lambda (exn) 196 | (refail-check exn))] 197 | ;; catch any other exception and raise an check 198 | ;; failure 199 | [exn:fail? 200 | (lambda (exn) 201 | (with-default-check-info* 202 | (list 203 | (make-check-message "Wrong exception raised") 204 | (make-check-info 'exn-message (exn-message exn)) 205 | (make-check-info 'exn exn)) 206 | (lambda () (fail-check))))]) 207 | (thunk)) 208 | (with-default-check-info* 209 | (list (make-check-message "No exception raised")) 210 | (lambda () (fail-check)))))) 211 | 212 | (define-check (check-not-exn thunk) 213 | (raise-error-if-not-thunk 'check-not-exn thunk) 214 | (with-handlers 215 | ([exn:test:check? refail-check] 216 | [(and/c exn? not-break-exn?) 217 | (lambda (exn) 218 | (with-default-check-info* 219 | (list 220 | (make-check-message "Exception raised") 221 | (make-check-info 'exception-message (exn-message exn)) 222 | (make-check-info 'exception exn)) 223 | (lambda () (fail-check))))]) 224 | (thunk))) 225 | 226 | (define-syntax-rule (define-simple-check-values [header body ...] ...) 227 | (begin (define-simple-check header body ...) ...)) 228 | 229 | (define-simple-check-values 230 | [(check operator expr1 expr2) (operator expr1 expr2)] 231 | [(check-pred predicate expr) (predicate expr)] 232 | [(check-true expr) (eq? expr #t)] 233 | [(check-false expr) (eq? expr #f)] 234 | [(check-not-false expr) expr] 235 | [(check-not-eq? expr1 expr2) (not (eq? expr1 expr2))] 236 | [(check-not-eqv? expr1 expr2) (not (eqv? expr1 expr2))] 237 | [(check-not-equal? expr1 expr2) (not (equal? expr1 expr2))] 238 | [(fail) #f]) 239 | 240 | (define-check (check-= expr1 expr2 epsilon) 241 | (with-check-info* 242 | (list (make-check-actual expr1) 243 | (make-check-expected expr2) 244 | (make-check-tolerance epsilon)) 245 | (lambda () 246 | (unless (<= (magnitude (- expr1 expr2)) epsilon) 247 | (fail-check))))) 248 | 249 | (define-check (check-within expr1 expr2 epsilon) 250 | (with-check-info* 251 | (list (make-check-actual expr1) 252 | (make-check-expected expr2) 253 | (make-check-tolerance epsilon)) 254 | (lambda () 255 | (unless (equal?/within expr1 expr2 epsilon) 256 | (fail-check))))) 257 | 258 | (define-binary-check (check-eq? eq? expr1 expr2)) 259 | (define-binary-check (check-eqv? eqv? expr1 expr2)) 260 | (define-binary-check (check-equal? equal? expr1 expr2)) 261 | 262 | ;; NOTE(jpolitz): This match form isn't eager like the others, hence the 263 | ;; define-syntax and the need to carry around location information 264 | (define-syntax (check-match stx) 265 | (syntax-case stx () 266 | [(_ actual expected pred) 267 | (quasisyntax 268 | (let ([actual-val actual]) 269 | (with-default-check-info* 270 | (list (make-check-name 'check-match) 271 | (make-check-location 272 | (syntax->location (quote-syntax #,(datum->syntax #f 'loc stx)))) 273 | (make-check-expression '#,(syntax->datum stx)) 274 | (make-check-actual actual-val) 275 | (make-check-info 'pattern 'expected) 276 | #,@(cond [(eq? (syntax-e #'pred) #t) '()] 277 | [else #'((make-check-info 'condition 'pred))])) 278 | (lambda () 279 | (check-true (match actual-val 280 | [expected pred] 281 | [_ #f]))))))] 282 | [(_ actual expected) 283 | (syntax/loc stx (check-match actual expected #t))])) 284 | -------------------------------------------------------------------------------- /rackunit-lib/rackunit/private/equal-within.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide equal?/within) 4 | 5 | (require racket/flonum racket/extflonum) 6 | 7 | ;; equal?/within : Any Any Nonnegative-Real -> Boolean 8 | (define (equal?/within a b delta) 9 | ;; equal-proc : Any Any -> Boolean 10 | (define (equal-proc a b) 11 | (cond 12 | [(and (number? a) (number? b)) 13 | (<= (magnitude (- a b)) delta)] 14 | [(and (extflonum? a) (extflonum? b)) 15 | (extfl<= (extflabs (extfl- a b)) (real->extfl delta))] 16 | [(and (flvector? a) (flvector? b)) 17 | (and (= (flvector-length a) (flvector-length b)) 18 | (for/and ([a (in-flvector a)] [b (in-flvector b)]) 19 | (equal-proc a b)))] 20 | [(and (extflvector? a) (extflvector? b)) 21 | (and (= (extflvector-length a) (extflvector-length b)) 22 | (for/and ([a (in-extflvector a)] [b (in-extflvector b)]) 23 | (equal-proc a b)))] 24 | [else 25 | (equal?/recur a b equal-proc)])) 26 | (equal-proc a b)) 27 | 28 | -------------------------------------------------------------------------------- /rackunit-lib/rackunit/private/format.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/list 3 | racket/port 4 | racket/pretty 5 | racket/string 6 | "base.rkt" 7 | "check-info.rkt") 8 | 9 | (provide display-test-result 10 | display-test-failure/error) 11 | 12 | (module+ for-test 13 | (provide display-check-info-stack)) 14 | 15 | ;; continuation-mark-set-parameter-value : Continuation-Mark-Set (Parameterof X) -> X 16 | (module continuation-mark-set-parameter-value racket/base 17 | (require (only-in '#%paramz parameterization-key)) 18 | (provide continuation-mark-set-parameter-value) 19 | (define (continuation-mark-set-parameter-value marks param) 20 | (call-with-parameterization 21 | (continuation-mark-set-first marks parameterization-key) 22 | param))) 23 | (require 'continuation-mark-set-parameter-value) 24 | 25 | ;; name-width : integer 26 | ;; 27 | ;; Number of characters we reserve for the check-info name column 28 | (define minimum-name-width 9) 29 | 30 | (define nested-indent-amount 2) 31 | (define nesting-level (make-parameter 0)) 32 | (define multi-line-indent-amount 2) 33 | 34 | (define (display-test-result res 35 | #:verbose? [verbose? #f] 36 | #:suite-names [suite-names '()]) 37 | (define cname (combine-names (test-result-test-case-name res) suite-names)) 38 | (define (display-err e) 39 | (display-test-failure/error e cname #:verbose? verbose?)) 40 | (cond [(test-failure? res) (display-err (test-failure-result res))] 41 | [(test-error? res) (display-err (test-error-result res))] 42 | [else (void)])) 43 | 44 | (define (combine-names test-name suite-names) 45 | (define any-names? (or test-name (not (empty? suite-names)))) 46 | (and any-names? 47 | (string-join (reverse (cons (or test-name "Unnamed test") 48 | suite-names)) 49 | " > "))) 50 | 51 | (define (string-padding str desired-len) 52 | (make-string (max (- desired-len (string-length str)) 0) #\space)) 53 | 54 | (define (check-info-name-width check-info) 55 | (string-length 56 | (symbol->string 57 | (check-info-name check-info)))) 58 | 59 | (define (check-info-stack-name-width check-info-stack) 60 | (define widths (map check-info-name-width check-info-stack)) 61 | (apply max 0 widths)) 62 | 63 | (define (print-check-info-stack stack* verbose? 64 | #:name-width [name-width* minimum-name-width]) 65 | (define stack (if verbose? stack* (simplify-params stack*))) 66 | (define name-width (max name-width* (check-info-stack-name-width stack))) 67 | (define (print-info info) (print-check-info info verbose? name-width)) 68 | (for-each print-info stack)) 69 | 70 | (define (print-check-info info verbose? name-width) 71 | (define name (symbol->string (check-info-name info))) 72 | (define value (check-info-value info)) 73 | (cond [(and (equal? name "exception") (exn? value)) 74 | (print-name name) 75 | (newline) 76 | (define indentation-step-string 77 | (make-string multi-line-indent-amount #\space)) 78 | (define indentation-string 79 | (string-append* 80 | (make-list (add1 (nesting-level)) 81 | indentation-step-string))) 82 | (define lines 83 | (call-with-output-string 84 | (λ (p) 85 | (parameterize ([current-error-port p]) 86 | ((error-display-handler) (exn-message value) value))))) 87 | (displayln 88 | (string-join 89 | (for/list ([line (in-lines (open-input-string lines))]) 90 | (string-append indentation-string line)) 91 | "\n"))] 92 | [(dynamic-info? value) 93 | (define new-info 94 | (make-check-info (check-info-name info) 95 | ((dynamic-info-proc value)))) 96 | (print-check-info new-info verbose? name-width)] 97 | [(nested-info? value) 98 | (print-name name) 99 | (newline) 100 | (parameterize ([nesting-level (add1 (nesting-level))]) 101 | (print-check-info-stack (nested-info-values value) verbose? #:name-width name-width))] 102 | [else 103 | (define one-line-candidate 104 | (with-output-to-string 105 | (lambda () 106 | (parameterize ([pretty-print-columns 'infinity]) 107 | (print-name name name-width) 108 | (print-info-value value))))) 109 | (cond 110 | [(short-line? one-line-candidate) 111 | (print-name name name-width) 112 | (print-info-value value) 113 | (newline)] 114 | [else 115 | (print-name name) 116 | (newline) 117 | (display (make-string multi-line-indent-amount #\space)) 118 | (print-info-value value) 119 | (newline)])])) 120 | 121 | (define (print-name name [name-width #f]) 122 | (define indent (make-string (* nested-indent-amount (nesting-level)) #\space)) 123 | (define pad 124 | (cond 125 | [name-width (string-append " " (string-padding name name-width))] 126 | [else ""])) 127 | (printf "~a~a:~a" indent name pad)) 128 | 129 | (define (short-line? line) 130 | (and (<= (string-length line) (pretty-print-columns)) 131 | (not (string-contains? line "\n")))) 132 | 133 | ;; display-check-info-stack : (listof check-info) -> void 134 | (define (display-check-info-stack stack #:verbose? [verbose? #f]) 135 | (print-check-info-stack stack verbose?)) 136 | 137 | ;; display-test-name : (U string #f) -> void 138 | (define (display-test-name name) 139 | (displayln (or name "Unnamed test "))) 140 | 141 | ;; simplify-params : (list-of check-info) -> (list-of check-info) 142 | ;; 143 | ;; Remove any 'params infos if there are any 'actual infos, as the latter 144 | ;; usually duplicates values in the former. Also removes any verbose infos. 145 | (define (simplify-params stack) 146 | (define has-actual? (ormap check-actual? stack)) 147 | (define (reject? info) 148 | (or (verbose-info? (check-info-value info)) 149 | (and has-actual? (check-params? info)))) 150 | (filter-not reject? stack)) 151 | 152 | ;; display-test-failure/error : any string/#f -> void 153 | (define (display-test-failure/error e [name #f] #:verbose? [verbose? #f]) 154 | (parameterize ((current-output-port (current-error-port))) 155 | (display-delimiter) 156 | (when name (display-test-name name)) 157 | (cond [(exn:test:check? e) 158 | (display-raised-summary "FAILURE" e) 159 | (display-check-info-stack (exn:test:check-stack e) 160 | #:verbose? verbose?) 161 | (display-raised-message e)] 162 | [(exn? e) 163 | (display-raised-summary "ERROR" e) 164 | (display-check-info-stack (exn-check-info e) 165 | #:verbose? verbose?) 166 | (display-raised-message e)] 167 | [else 168 | (display-raised-summary "ERROR" e) 169 | (display-check-info-stack (current-check-info) 170 | #:verbose? verbose?) 171 | (display-raised-message e)]) 172 | (display-delimiter))) 173 | 174 | (define (display-raised-message v) 175 | (if (exn? v) 176 | (when (not (equal? (exn-message v) "")) 177 | (newline) 178 | (displayln (exn-message v))) 179 | (printf "\nA value other than an exception was raised: ~e\n" v))) 180 | 181 | (define (display-delimiter) (displayln "--------------------")) 182 | 183 | (define (display-raised-summary desc raised-value) 184 | (if (exn? raised-value) 185 | (parameterize ([error-print-context-length 0]) 186 | ((error-display-handler) desc raised-value)) 187 | (displayln desc))) 188 | 189 | ;; exn-check-info : Exn -> (Listof Check-Info) 190 | (define (exn-check-info e) 191 | (continuation-mark-set-parameter-value (exn-continuation-marks e) 192 | current-check-info)) 193 | -------------------------------------------------------------------------------- /rackunit-lib/rackunit/private/location.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/list 3 | racket/contract/base) 4 | 5 | ;; type location = (list any number/#f number/#f number/#f number/#f) 6 | ;; location : source line column position span 7 | (define location/c (list/c any/c (or/c number? false/c) (or/c number? false/c) (or/c number? false/c) (or/c number? false/c))) 8 | 9 | (define location-source first) 10 | (define location-line second) 11 | (define location-column third) 12 | (define location-position fourth) 13 | (define location-span fifth) 14 | 15 | (provide/contract 16 | [location/c contract?] 17 | [location-source (location/c . -> . any/c)] 18 | [location-line (location/c . -> . (or/c number? false/c))] 19 | [location-column (location/c . -> . (or/c number? false/c))] 20 | [location-position (location/c . -> . (or/c number? false/c))] 21 | [location-span (location/c . -> . (or/c number? false/c))] 22 | [syntax->location (syntax? . -> . location/c)] 23 | [location->string (location/c . -> . string?)] 24 | [location->srcloc (location/c . -> . srcloc?)]) 25 | 26 | ;; syntax->location : syntax -> location 27 | (define (syntax->location stx) 28 | (list (syntax-source stx) 29 | (syntax-line stx) 30 | (syntax-column stx) 31 | (syntax-position stx) 32 | (syntax-span stx))) 33 | 34 | ;; location->string : (list-of string) -> string 35 | (define (location->string location) 36 | (string-append (source->string (location-source location)) 37 | ":" 38 | (maybe-number->string (location-line location)) 39 | ":" 40 | (maybe-number->string (location-column location)))) 41 | 42 | ;; location->srcloc: location -> srcloc 43 | (define (location->srcloc location) 44 | (srcloc (location-source location) 45 | (location-line location) 46 | (location-column location) 47 | (location-position location) 48 | (location-span location))) 49 | 50 | (define (source->string source) 51 | (cond 52 | ((string? source) source) 53 | ((path? source) (path->string source)) 54 | ((not source) "unknown") 55 | (else (format "~a" source)))) 56 | 57 | (define (maybe-number->string number) 58 | (if (number? number) 59 | (number->string number) 60 | "?")) 61 | 62 | -------------------------------------------------------------------------------- /rackunit-lib/rackunit/private/result.rkt: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; Time-stamp: <2008-08-11 21:10:24 noel> 3 | ;;; 4 | ;;; Copyright (C) by Noel Welsh. 5 | ;;; 6 | 7 | ;;; This library is free software; you can redistribute it 8 | ;;; and/or modify it under the terms of the GNU Lesser 9 | ;;; General Public License as published by the Free Software 10 | ;;; Foundation; either version 2.1 of the License, or (at 11 | ;;; your option) any later version. 12 | 13 | ;;; This library is distributed in the hope that it will be 14 | ;;; useful, but WITHOUT ANY WARRANTY; without even the 15 | ;;; implied warranty of MERCHANTABILITY or FITNESS FOR A 16 | ;;; PARTICULAR PURPOSE. See the GNU Lesser General Public 17 | ;;; License for more details. 18 | 19 | ;;; You should have received a copy of the GNU Lesser 20 | ;;; General Public License along with this library; if not, 21 | ;;; write to the Free Software Foundation, Inc., 59 Temple 22 | ;;; Place, Suite 330, Boston, MA 02111-1307 USA 23 | 24 | ;;; Author: Noel Welsh 25 | ;; 26 | ;; 27 | ;; Commentary: 28 | 29 | #lang racket/base 30 | 31 | (require "base.rkt" 32 | "test-suite.rkt") 33 | 34 | (provide (all-defined-out)) 35 | 36 | ;; foldts-test-suite : 37 | ;; (test-suite string thunk thunk 'a -> 'a) 38 | ;; (test-suite string thunk thunk 'a 'a -> 'a) 39 | ;; (test-case string thunk 'a -> 'a) 40 | ;; 'a 41 | ;; test 42 | ;; -> 43 | ;; 'a 44 | ;; 45 | ;; Extended tree fold ala SSAX for tests. Note that the 46 | ;; test-case/test-suite is passed to the functions so that 47 | ;; subtypes of test-case/test-suite can be differentiated, 48 | ;; allowing extensibility [This is an interesting difference 49 | ;; between OO and FP. FP gives up extensibility on 50 | ;; functions, OO on data. Here we want extensibility on 51 | ;; data so FP is a bit ugly]. 52 | (define (foldts-test-suite fdown fup fhere seed test) 53 | (cond 54 | ((rackunit-test-case? test) 55 | (fhere test 56 | (rackunit-test-case-name test) 57 | (rackunit-test-case-action test) 58 | seed)) 59 | ((rackunit-test-suite? test) 60 | (apply-test-suite test fdown fup fhere seed)) 61 | (else 62 | (raise 63 | (make-exn:test 64 | (format "foldts-test-suite: Don't know what to do with ~a. It isn't a test case or test suite." test) 65 | (current-continuation-marks)))))) 66 | 67 | 68 | ;; Useful in fold-test-results below 69 | (define 2nd-arg (lambda (a b) b)) 70 | 71 | ;; fold-test-results : 72 | ;; ('b 'c ... 'a -> 'a) 73 | ;; 'a 74 | ;; test 75 | ;; #:run (string (() -> any) -> 'b 'c ...) 76 | ;; #:fdown (string 'a -> 'a) 77 | ;; #:fup (string 'a -> 'a) 78 | ;; -> 79 | ;; 'a 80 | ;; 81 | ;; Fold collector pre-order L-to-R depth-first over the 82 | ;; result of run. By default these are test results, and 83 | ;; hence by default result-fn is 84 | ;; 85 | ;; test-result 'a -> 'a 86 | (define (fold-test-results result-fn seed test 87 | #:run [run run-test-case] 88 | #:fdown [fdown 2nd-arg] 89 | #:fup [fup 2nd-arg]) 90 | (foldts-test-suite 91 | (lambda (suite name before after seed) 92 | '(printf "into ~a\n" name) 93 | (before) 94 | (fdown name seed)) 95 | (lambda (suite name before after seed kid-seed) 96 | '(printf "out of ~a\n" name) 97 | (after) 98 | (fup name kid-seed)) 99 | (lambda (case name action seed) 100 | '(printf "running ~a\n" name) 101 | (apply result-fn 102 | ;; Get the values returned by run-fn into a 103 | ;; list and append the seed 104 | (append (call-with-values 105 | (lambda () (run name action)) 106 | list) 107 | (list seed)))) 108 | seed 109 | test)) 110 | 111 | ;; run-test-case : string thunk -> test-result 112 | (define (run-test-case name action) 113 | '(printf "run-test-case running ~a ~a\n" name action) 114 | (with-handlers 115 | ([exn:test:check? 116 | (lambda (exn) 117 | (make-test-failure name exn))] 118 | [not-break-exn? 119 | (lambda (exn) 120 | (make-test-error name exn))]) 121 | (let ((value (action))) 122 | (make-test-success name value)))) 123 | (define (not-break-exn? x) (not (exn:break? x))) 124 | 125 | ;; run-test : test -> (list-of test-result) 126 | ;; 127 | ;; Run test returning a tree of test-results. Results are 128 | ;; ordered L-to-R as they occur in the tree. 129 | (define (run-test test) 130 | (reverse 131 | (fold-test-results 132 | (lambda (result seed) (cons result seed)) 133 | (list) 134 | test))) 135 | 136 | -------------------------------------------------------------------------------- /rackunit-lib/rackunit/private/test-case.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require (for-syntax racket/base) 3 | racket/contract/base 4 | rackunit/log 5 | syntax/parse/define 6 | "format.rkt" 7 | "base.rkt" 8 | "check.rkt") 9 | 10 | (provide test-begin 11 | test-case 12 | before 13 | after 14 | around) 15 | 16 | (provide 17 | (contract-out 18 | [current-test-name (parameter/c (or/c string? #f))] 19 | [current-test-case-around (parameter/c (-> (-> any) any))])) 20 | 21 | (define current-test-name (make-parameter #f)) 22 | 23 | ;; test-case-around : ( -> a) -> a 24 | ;; 25 | ;; Run a test-case immediately, printing information on failure 26 | (define (default-test-case-around thunk) 27 | (define (not-break-exn? x) (not (exn:break? x))) 28 | (with-handlers ([not-break-exn? log-and-handle!]) 29 | (begin0 30 | (parameterize ((current-custodian (make-custodian))) 31 | (thunk)) 32 | (test-log! #t)))) 33 | 34 | ;; default-test-case-handler : any -> any 35 | (define (default-test-case-handler e) 36 | (display-test-failure/error e (current-test-name))) 37 | 38 | (define current-test-case-around (make-parameter default-test-case-around)) 39 | 40 | (define (log-and-handle! e) 41 | (test-log! #f) 42 | (when (exn:break? e) (raise e)) 43 | (default-test-case-handler e)) 44 | 45 | (define (run-test-case test-thunk #:name [name (current-test-name)]) 46 | (parameterize ([current-test-name name]) 47 | ((current-test-case-around) 48 | (λ () 49 | (parameterize ([current-check-around plain-check-around]) 50 | (test-thunk)))))) 51 | 52 | (define-simple-macro (test-begin body:expr ...) 53 | ;; empty test-begin body is allowed 54 | (run-test-case (λ () (void) body ...))) 55 | 56 | (define-simple-macro (test-case name body:expr ...) 57 | #:declare name (expr/c #'string?) 58 | ;; empty test-case body is allowed 59 | (run-test-case (λ () (void) body ...) #:name name.c)) 60 | 61 | (define-simple-macro (before setup:expr body:expr ...+) 62 | (dynamic-wind (λ () setup) (λ () body ...) void)) 63 | 64 | (define-simple-macro (after body:expr ...+ teardown:expr) 65 | (dynamic-wind void (λ () body ...) (λ () teardown))) 66 | 67 | (define-simple-macro (around setup:expr body:expr ...+ teardown:expr) 68 | (dynamic-wind (λ () setup) (λ () body ...) (λ () teardown))) 69 | -------------------------------------------------------------------------------- /rackunit-lib/rackunit/private/test-suite.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (for-syntax racket/base) 4 | rackunit/log 5 | "base.rkt" 6 | "test-case.rkt" 7 | "check.rkt") 8 | 9 | (provide test-suite 10 | test-suite-test-case-around 11 | test-suite-check-around 12 | delay-test 13 | make-test-suite 14 | 15 | apply-test-suite 16 | 17 | define-test-suite 18 | define/provide-test-suite) 19 | 20 | (define (void-thunk) (void)) 21 | 22 | (define current-seed 23 | (make-parameter 24 | #f 25 | ;; Anything goes for the seed 26 | (lambda (v) v))) 27 | 28 | (define (test-suite-test-case-around fhere) 29 | (lambda (thunk) 30 | (let* ([name (current-test-name)] 31 | [test (make-rackunit-test-case name thunk)] 32 | [seed (current-seed)]) 33 | (current-seed (fhere test name thunk seed))))) 34 | 35 | (define (test-suite-check-around fhere) 36 | (lambda (thunk) 37 | (let* ([name #f] 38 | [test (make-rackunit-test-case name thunk)] 39 | [seed (current-seed)]) 40 | (current-seed (fhere test name thunk seed))))) 41 | 42 | 43 | (define (delayed-test-case-around thunk) 44 | (define name (current-test-name)) 45 | (define (thunk/nolog) 46 | (parameterize ([test-log-enabled? #f]) 47 | (thunk))) 48 | (make-rackunit-test-case name thunk/nolog)) 49 | 50 | (define (delayed-check-around thunk) 51 | (make-rackunit-test-case #f thunk)) 52 | 53 | (define-syntax delay-test 54 | (syntax-rules () 55 | [(delay-test test test1 ...) 56 | (parameterize 57 | ([current-test-case-around delayed-test-case-around] 58 | [current-check-around delayed-check-around]) 59 | test test1 ...)])) 60 | 61 | (define (apply-test-suite suite fdown fup fhere seed) 62 | (let* ([name (rackunit-test-suite-name suite)] 63 | [tests (rackunit-test-suite-tests suite)] 64 | [before (rackunit-test-suite-before suite)] 65 | [after (rackunit-test-suite-after suite)] 66 | [kid-seed (fdown suite name before after seed)] 67 | [kid-seed ((rackunit-test-suite-tests suite) fdown fup fhere kid-seed)]) 68 | (fup suite name before after seed kid-seed))) 69 | 70 | ;; test-suite : name [#:before thunk] [#:after thunk] test ... 71 | ;; -> test-suite 72 | ;; 73 | ;; Creates a test-suite with the given name and tests. 74 | ;; Setup and teardown actions (thunks) may be specified by 75 | ;; preceding the actions with the keyword #:before or 76 | ;; #:after. 77 | (define-syntax (test-suite stx) 78 | (syntax-case stx () 79 | [(test-suite name 80 | #:before before-thunk 81 | #:after after-thunk 82 | test ...) 83 | (syntax 84 | (let ([the-name name] 85 | [the-tests 86 | (lambda (fdown fup fhere seed) 87 | (define (run/inner x) 88 | (cond [(rackunit-test-suite? x) 89 | (current-seed 90 | (apply-test-suite x fdown fup fhere (current-seed)))] 91 | [(list? x) 92 | (for-each run/inner x)] 93 | [else 94 | (void)])) 95 | (parameterize 96 | ([current-seed seed] 97 | [current-test-case-around (test-suite-test-case-around fhere)] 98 | [current-check-around (test-suite-check-around fhere)]) 99 | (let ([t test]) 100 | (run/inner t)) 101 | ... 102 | (current-seed)))]) 103 | (cond 104 | [(not (string? the-name)) 105 | (raise-type-error 'test-suite "test-suite name as string" the-name)] 106 | [else 107 | (make-rackunit-test-suite 108 | the-name 109 | the-tests 110 | before-thunk 111 | after-thunk)])))] 112 | [(test-suite name 113 | #:before before-thunk 114 | test ...) 115 | (syntax 116 | (test-suite name 117 | #:before before-thunk 118 | #:after void-thunk 119 | test ...))] 120 | [(test-suite name 121 | #:after after-thunk 122 | test ...) 123 | (syntax 124 | (test-suite name 125 | #:before void-thunk 126 | #:after after-thunk 127 | test ...))] 128 | [(test-suite name test ...) 129 | (syntax 130 | (test-suite name 131 | #:before void-thunk 132 | #:after void-thunk 133 | test ...))])) 134 | 135 | (define (tests->test-suite-action tests) 136 | (lambda (fdown fup fhere seed) 137 | (parameterize ([current-seed seed]) 138 | (for-each 139 | (lambda (t) 140 | (cond 141 | [(rackunit-test-suite? t) 142 | (current-seed (apply-test-suite t fdown fup fhere (current-seed)))] 143 | [(rackunit-test-case? t) 144 | (current-seed 145 | (fhere t 146 | (rackunit-test-case-name t) 147 | (rackunit-test-case-action t) 148 | (current-seed)))] 149 | [else 150 | (raise 151 | (make-exn:test 152 | (format "tests->test-suite-action received ~a in list of tests ~a, which is not a test." t tests) 153 | (current-continuation-marks)))])) 154 | tests) 155 | (current-seed)))) 156 | 157 | ;; make-test-suite : string [#:before thunk] [#:after thunk] (listof test?) -> test-suite? 158 | ;; 159 | ;; Construct a test suite from a list of tests 160 | (define (make-test-suite name #:before [before void-thunk] #:after [after void-thunk] tests) 161 | (make-rackunit-test-suite name 162 | (tests->test-suite-action tests) 163 | before 164 | after)) 165 | 166 | ;; 167 | ;; Shortcut helpers 168 | ;; 169 | 170 | (define-syntax define-test-suite 171 | (syntax-rules () 172 | [(define-test-suite name test ...) 173 | (define name 174 | (test-suite (symbol->string (quote name)) 175 | test ...))])) 176 | 177 | (define-syntax define/provide-test-suite 178 | (syntax-rules () 179 | [(define/provide-test-suite name test ...) 180 | (begin 181 | (define-test-suite name test ...) 182 | (provide name))])) 183 | -------------------------------------------------------------------------------- /rackunit-lib/rackunit/private/test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (for-syntax racket/base) 4 | "base.rkt" 5 | "check.rkt" 6 | "check-info.rkt" 7 | "result.rkt" 8 | "test-case.rkt" 9 | "test-suite.rkt" 10 | "util.rkt") 11 | 12 | (provide (struct-out exn:test) 13 | (struct-out exn:test:check) 14 | (struct-out check-info) 15 | (struct-out test-result) 16 | (struct-out test-failure) 17 | (struct-out test-error) 18 | (struct-out test-success) 19 | (struct-out rackunit-test-case) 20 | (struct-out rackunit-test-suite) 21 | (struct-out string-info) 22 | (struct-out nested-info) 23 | (struct-out dynamic-info) 24 | 25 | with-check-info 26 | with-check-info* 27 | with-default-check-info* 28 | 29 | make-check-name 30 | make-check-params 31 | make-check-location 32 | make-check-expression 33 | make-check-message 34 | make-check-actual 35 | make-check-expected 36 | 37 | check-name? 38 | check-params? 39 | check-location? 40 | check-expression? 41 | check-message? 42 | check-actual? 43 | check-expected? 44 | 45 | test-begin 46 | test-case 47 | test-suite 48 | make-test-suite 49 | delay-test 50 | (rename-out [make-rackunit-test-case make-test-case] 51 | [rackunit-test-case? test-case?] 52 | [rackunit-test-suite? test-suite?]) 53 | current-test-name 54 | current-test-case-around 55 | test-suite-test-case-around 56 | test-suite-check-around 57 | 58 | define-test-suite 59 | define/provide-test-suite 60 | test-suite* 61 | 62 | before 63 | after 64 | around 65 | 66 | require/expose 67 | dynamic-require/expose 68 | 69 | define-shortcut 70 | 71 | test-check 72 | test-pred 73 | test-equal? 74 | test-eq? 75 | test-eqv? 76 | test-= 77 | test-within 78 | test-true 79 | test-false 80 | test-not-false 81 | test-exn 82 | test-not-exn 83 | 84 | foldts-test-suite 85 | fold-test-results 86 | run-test-case 87 | run-test 88 | 89 | fail-check 90 | 91 | define-check 92 | define-simple-check 93 | define-binary-check 94 | 95 | current-check-handler 96 | current-check-around 97 | 98 | check 99 | check-exn 100 | check-not-exn 101 | check-true 102 | check-false 103 | check-pred 104 | check-eq? 105 | check-eqv? 106 | check-equal? 107 | check-= 108 | check-within 109 | check-not-false 110 | check-not-eq? 111 | check-not-eqv? 112 | check-not-equal? 113 | check-regexp-match 114 | check-match 115 | fail) 116 | 117 | 118 | (define-syntax (define-shortcut stx) 119 | (syntax-case stx () 120 | [(_ (name param ...) expr) 121 | (with-syntax ([expected-form (syntax->datum 122 | #`(#,(syntax name) 123 | test-desc 124 | #,@(syntax (param ...))))]) 125 | (syntax/loc stx 126 | (define-syntax (name name-stx) 127 | (syntax-case name-stx () 128 | [(name test-desc param ...) 129 | (with-syntax ([name-expr (syntax/loc name-stx expr)]) 130 | (syntax/loc name-stx 131 | (test-case test-desc name-expr)))] 132 | [_ 133 | (raise-syntax-error 134 | #f 135 | (format "Correct form is ~a" (quote expected-form)) 136 | name-stx)]))))] 137 | [_ 138 | (raise-syntax-error 139 | #f 140 | "Correct form is (define-shortcut (name param ...) expr)" 141 | stx)])) 142 | 143 | (define-shortcut (test-check operator expr1 expr2) 144 | (check operator expr1 expr2)) 145 | 146 | (define-shortcut (test-pred pred expr) 147 | (check-pred pred expr)) 148 | 149 | (define-shortcut (test-equal? expr1 expr2) 150 | (check-equal? expr1 expr2)) 151 | 152 | (define-shortcut (test-eq? expr1 expr2) 153 | (check-eq? expr1 expr2)) 154 | 155 | (define-shortcut (test-eqv? expr1 expr2) 156 | (check-eqv? expr1 expr2)) 157 | 158 | (define-shortcut (test-= expr1 expr2 epsilon) 159 | (check-= expr1 expr2 epsilon)) 160 | 161 | (define-shortcut (test-within expr1 expr2 epsilon) 162 | (check-within expr1 expr2 epsilon)) 163 | 164 | (define-shortcut (test-true expr) 165 | (check-true expr)) 166 | 167 | (define-shortcut (test-false expr) 168 | (check-false expr)) 169 | 170 | (define-shortcut (test-not-false expr) 171 | (check-not-false expr)) 172 | 173 | (define-shortcut (test-exn pred thunk) 174 | (check-exn pred thunk)) 175 | 176 | (define-shortcut (test-not-exn thunk) 177 | (check-not-exn thunk)) 178 | -------------------------------------------------------------------------------- /rackunit-lib/rackunit/private/util.rkt: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; Time-stamp: <2008-07-28 12:51:11 nhw> 3 | ;;; 4 | ;;; Copyright (C) 2004 by Noel Welsh. 5 | ;;; 6 | 7 | ;;; This library is free software; you can redistribute it 8 | ;;; and/or modify it under the terms of the GNU Lesser 9 | ;;; General Public License as published by the Free Software 10 | ;;; Foundation; either version 2.1 of the License, or (at 11 | ;;; your option) any later version. 12 | 13 | ;;; Web testingis distributed in the hope that it will be 14 | ;;; useful, but WITHOUT ANY WARRANTY; without even the 15 | ;;; implied warranty of MERCHANTABILITY or FITNESS FOR A 16 | ;;; PARTICULAR PURPOSE. See the GNU Lesser General Public 17 | ;;; License for more details. 18 | 19 | ;;; You should have received a copy of the GNU Lesser 20 | ;;; General Public License along with Web testing; if not, 21 | ;;; write to the Free Software Foundation, Inc., 59 Temple 22 | ;;; Place, Suite 330, Boston, MA 02111-1307 USA 23 | 24 | ;;; Author: Noel Welsh 25 | ;; 26 | ;; 27 | ;; Commentary: 28 | 29 | #lang racket/base 30 | 31 | (require (for-syntax racket/base) 32 | racket/runtime-path 33 | "check.rkt" 34 | "test-suite.rkt" 35 | "test-case.rkt") 36 | 37 | (provide require/expose 38 | dynamic-require/expose 39 | test-suite* 40 | check-regexp-match) 41 | 42 | ;; Requires a module and exposes some of its unprovided identifiers. 43 | ;; USAGE: (require/expose MODULE-NAME (IDS ...)) 44 | ;; where MODULE-NAME is as in the MzRacket manual (i.e., 45 | ;; a standard module spec) and IDS are the un-provided 46 | ;; identifiers that you wish to expose in the current 47 | ;; module. 48 | (define-syntax require/expose 49 | (syntax-rules () 50 | [(_ mod (id ...)) 51 | (begin 52 | (require (only-in mod)) 53 | (define-runtime-module-path the-resolved-mod mod) 54 | (define-values (id ...) 55 | ;; Use the correct module-registry 56 | (parameterize ((current-namespace 57 | (variable-reference->namespace (#%variable-reference)))) 58 | (dynamic-require/expose* the-resolved-mod '(id ...)))))])) 59 | 60 | (define (dynamic-require/expose mod name) 61 | (unless (or (path? mod) 62 | (module-path? mod) 63 | (module-path-index? mod) 64 | (resolved-module-path? mod)) 65 | (raise-argument-error 'dynamic-require/expose 66 | "(or/c module-path? module-path-index? resolved-module-path?)" 67 | 0 mod name)) 68 | (unless (symbol? name) 69 | (raise-argument-error 'dynamic-require/expose "symbol?" 1 mod name)) 70 | (dynamic-require/expose* mod (list name))) 71 | 72 | (define (dynamic-require/expose* mod names) 73 | ;; Make sure module the module is instantiated 74 | (dynamic-require mod #f) 75 | ;; Get the module namespace 76 | (parameterize ((current-namespace (module->namespace mod))) 77 | (apply values (map eval names)))) 78 | 79 | (define-syntax test-suite* 80 | (syntax-rules () 81 | ((test-suite* name (case-name case-body ...) ...) 82 | (test-suite 83 | name 84 | (test-case case-name case-body ...) ...)))) 85 | 86 | (define-simple-check (check-regexp-match regex string) 87 | (and (or (string? string) 88 | (bytes? string) 89 | (path? string) 90 | (input-port? string)) 91 | (regexp-match regex string))) 92 | -------------------------------------------------------------------------------- /rackunit-lib/rackunit/text-ui.rkt: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; Time-stamp: <2009-06-11 17:11:22 noel> 3 | ;;; 4 | ;;; Copyright (C) 2005 by Noel Welsh. 5 | ;;; 6 | 7 | ;;; This library is free software; you can redistribute it 8 | ;;; and/or modify it under the terms of the GNU Lesser 9 | ;;; General Public License as published by the Free Software 10 | ;;; Foundation; either version 2.1 of the License, or (at 11 | ;;; your option) any later version. 12 | 13 | ;;; This library is distributed in the hope that it will be 14 | ;;; useful, but WITHOUT ANY WARRANTY; without even the 15 | ;;; implied warranty of MERCHANTABILITY or FITNESS FOR A 16 | ;;; PARTICULAR PURPOSE. See the GNU Lesser General Public 17 | ;;; License for more details. 18 | 19 | ;;; You should have received a copy of the GNU Lesser 20 | ;;; General Public License along with this library; if not, 21 | ;;; write to the Free Software Foundation, Inc., 59 Temple 22 | ;;; Place, Suite 330, Boston, MA 02111-1307 USA 23 | 24 | ;;; Author: Noel Welsh 25 | ;; 26 | ;; 27 | ;; Commentary: 28 | 29 | #lang racket/base 30 | 31 | (require racket/contract/base) 32 | 33 | (provide 34 | (contract-out 35 | [run-tests (->* ((or/c test-case? test-suite?)) 36 | ((or/c 'quiet 'normal 'verbose)) 37 | natural-number/c)])) 38 | 39 | (require racket/list 40 | racket/match 41 | rackunit/log 42 | "private/format.rkt" 43 | "private/test.rkt") 44 | 45 | 46 | ;; As we fold over the test results, there are two pieces of state we must 47 | ;; manage: a counter of failures, errors, and passes, and a stack of names 48 | ;; indicating where we are in the tree of test suites and cases. The former is 49 | ;; used for printing a summary message after running all tests, while the latter 50 | ;; is used in each test to print what cases / suites a test is in. 51 | (struct fold-state (counter names) #:transparent) 52 | 53 | (define init-state (fold-state (hash 'success 0 'failure 0 'error 0) (list))) 54 | 55 | (define (push-suite-name name state) 56 | (struct-copy fold-state state [names (cons name (fold-state-names state))])) 57 | 58 | (define (pop-suite-name name state) 59 | (struct-copy fold-state state [names (rest (fold-state-names state))])) 60 | 61 | (define (result-type res) 62 | (cond [(test-success? res) 'success] 63 | [(test-failure? res) 'failure] 64 | [(test-error? res) 'error])) 65 | 66 | (define (increment-counter res state) 67 | (define type (result-type res)) 68 | (define new-counter (hash-update (fold-state-counter state) type add1)) 69 | (struct-copy fold-state state [counter new-counter])) 70 | 71 | (define (num-unsuccessful cnt) 72 | (+ (hash-ref cnt 'failure) (hash-ref cnt 'error))) 73 | 74 | (define (log-counter! cnt) 75 | (for ([_ (in-range (hash-ref cnt 'success))]) (test-log! #t)) 76 | (for ([_ (in-range (num-unsuccessful cnt))]) (test-log! #f))) 77 | 78 | (define (display-counter cnt) 79 | (match cnt 80 | [(hash-table ['success s] ['failure f] ['error e]) 81 | (define total (+ s f e)) 82 | (define tests-passed? (and (zero? f) (zero? e))) 83 | (define (print-msg) 84 | (printf "~a success(es) ~a failure(s) ~a error(s) ~a test(s) run\n" 85 | s f e total)) 86 | (if tests-passed? 87 | (print-msg) 88 | (parameterize ([current-output-port (current-error-port)]) 89 | (print-msg)))])) 90 | 91 | (define (run-tests test [mode 'normal]) 92 | (define quiet? (eq? mode 'quiet)) 93 | (define (print-result result state) 94 | (unless quiet? 95 | (define verbose? (eq? mode 'verbose)) 96 | (define names (fold-state-names state)) 97 | (display-test-result result #:verbose? verbose? #:suite-names names)) 98 | (increment-counter result state)) 99 | (define (fold-tests) 100 | (fold-test-results print-result init-state test 101 | #:fdown push-suite-name 102 | #:fup pop-suite-name)) 103 | ;; we install a new custodian to ensure resources handled improperly by tests 104 | ;; such as threads, tcp listeners, etc. don't interfere with other tests or 105 | ;; the runner itself 106 | (define final-counter (fold-state-counter (call/new-custodian fold-tests))) 107 | (log-counter! final-counter) 108 | (unless quiet? 109 | (display-counter final-counter)) 110 | (num-unsuccessful final-counter)) 111 | 112 | (define (call/new-custodian thnk) 113 | (parameterize ([current-custodian (make-custodian)]) (thnk))) 114 | -------------------------------------------------------------------------------- /rackunit-plugin-lib/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection 'multi) 4 | 5 | (define deps '("base" 6 | "rackunit-lib" 7 | "rackunit-gui" 8 | "gui-lib" 9 | "drracket-plugin-lib")) 10 | 11 | (define pkg-desc "RackUnit testing framework DrRacket plugin") 12 | 13 | (define pkg-authors '(ryanc noel)) 14 | 15 | (define license 16 | '(Apache-2.0 OR MIT)) 17 | -------------------------------------------------------------------------------- /rackunit-plugin-lib/rackunit/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define tools '(("tool.rkt"))) 4 | (define tool-names '("RackUnit DrRacket integration")) 5 | -------------------------------------------------------------------------------- /rackunit-plugin-lib/rackunit/tool.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/class 3 | racket/gui/base 4 | drscheme/tool 5 | racket/unit) 6 | 7 | (provide tool@) 8 | 9 | ;; CONSTANTS 10 | 11 | (define BACKTRACE-NO-MESSAGE "No message.") 12 | (define LINK-MODULE-SPEC 'rackunit/private/gui/drracket-link) 13 | 14 | ;; ---- 15 | 16 | ;; close/eventspace : (a* -> b) -> (a* -> b) 17 | ;; Returns a procedure that executes the procedure in the 18 | ;; eventspace current when close/eventspace was executed. 19 | ;; Effectively, "close" the procedure in the current eventspace. 20 | (define (close-eventspace f) 21 | (let ([es (current-eventspace)]) 22 | (lambda args 23 | (parameterize [(current-eventspace es)] 24 | (apply f args))))) 25 | 26 | (define (close-eventspace/async f) 27 | (let ([es (current-eventspace)]) 28 | (lambda args 29 | (parameterize ((current-eventspace es)) 30 | (queue-callback (lambda () (apply f args))))))) 31 | 32 | (define tool@ 33 | (unit 34 | (import drscheme:tool^) 35 | (export drscheme:tool-exports^) 36 | 37 | ;; show-backtrace : exn -> void 38 | (define show-backtrace 39 | (close-eventspace/async 40 | (lambda (msg bt) 41 | (drscheme:debug:show-backtrace-window 42 | (or msg BACKTRACE-NO-MESSAGE) 43 | bt)))) 44 | 45 | (define (list->srcloc x) 46 | (make-srcloc (list-ref x 0) 47 | (list-ref x 1) 48 | (list-ref x 2) 49 | (list-ref x 3) 50 | (list-ref x 4))) 51 | 52 | (define (get-errortrace-backtrace exn) 53 | exn) 54 | 55 | ;; show-source : value number number -> void 56 | (define show-source 57 | (close-eventspace/async 58 | (lambda (src pos span) 59 | (drscheme:debug:open-and-highlight-in-file 60 | (list (make-srcloc src #f #f pos span)))))) 61 | 62 | (define interactions-text-mixin 63 | (mixin ((class->interface drscheme:rep:text%)) () 64 | (inherit get-user-namespace) 65 | (super-new) 66 | 67 | (define/private (setup-helper-module) 68 | (let ([link (parameterize ((current-namespace (get-user-namespace))) 69 | (dynamic-require LINK-MODULE-SPEC 'link))]) 70 | (set-box! link (vector get-errortrace-backtrace 71 | show-backtrace 72 | show-source)))) 73 | 74 | (define/override (reset-console) 75 | (super reset-console) 76 | (setup-helper-module)))) 77 | 78 | (drscheme:get/extend:extend-interactions-text interactions-text-mixin) 79 | 80 | (define (phase1) (void)) 81 | (define (phase2) (void)) 82 | 83 | )) 84 | -------------------------------------------------------------------------------- /rackunit-test/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection 'multi) 4 | 5 | (define deps '()) 6 | 7 | (define pkg-desc "RackUnit documentation") 8 | 9 | (define pkg-authors '(noel ryanc)) 10 | (define build-deps '("base" 11 | "eli-tester" 12 | "typed-racket-lib" 13 | "rackunit-typed" 14 | "rackunit-lib" 15 | "compiler-lib")) 16 | (define update-implies '("rackunit-lib")) 17 | 18 | (define license 19 | '(Apache-2.0 OR MIT)) 20 | -------------------------------------------------------------------------------- /rackunit-test/tests/rackunit/all-rackunit-tests.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require rackunit 4 | "check-test.rkt" 5 | "test-case-test.rkt" 6 | "test-suite-test.rkt" 7 | "base-test.rkt" 8 | "location-test.rkt" 9 | "result-test.rkt" 10 | "test-test.rkt" 11 | "util-test.rkt" 12 | "text-ui-test.rkt") 13 | 14 | (provide all-rackunit-tests 15 | failure-tests) 16 | 17 | (define all-rackunit-tests 18 | (test-suite 19 | "All RackUnit Tests" 20 | base-tests 21 | test-case-tests 22 | test-suite-tests 23 | test-suite-define-provide-test 24 | location-tests 25 | test-tests 26 | util-tests 27 | text-ui-tests 28 | )) 29 | 30 | (define failure-tests 31 | (test-suite 32 | "Failures" 33 | (test-case "Intended to fail" (fail)) 34 | (test-case "Also intended to fail" (check-eq? 'apples 'orange)) 35 | (test-equal? "Yet again intended to fail" "apples" "oranges") 36 | (test-case "Intended to throw error" (error 'testing "<>")) 37 | (test-case "Error within a check" (check error 'foo 'bar)) 38 | )) 39 | -------------------------------------------------------------------------------- /rackunit-test/tests/rackunit/base-test.rkt: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; Time-stamp: <2008-06-19 21:03:50 noel> 3 | ;;; 4 | ;;; Copyright (C) 2005 by Noel Welsh. 5 | ;;; 6 | 7 | ;;; This library is free software; you can redistribute it 8 | ;;; and/or modify it under the terms of the GNU Lesser 9 | ;;; General Public License as published by the Free Software 10 | ;;; Foundation; either version 2.1 of the License, or (at 11 | ;;; your option) any later version. 12 | 13 | ;;; This library is distributed in the hope that it will be 14 | ;;; useful, but WITHOUT ANY WARRANTY; without even the 15 | ;;; implied warranty of MERCHANTABILITY or FITNESS FOR A 16 | ;;; PARTICULAR PURPOSE. See the GNU Lesser General Public 17 | ;;; License for more details. 18 | 19 | ;;; You should have received a copy of the GNU Lesser 20 | ;;; General Public License along with this library; if not, 21 | ;;; write to the Free Software Foundation, Inc., 59 Temple 22 | ;;; Place, Suite 330, Boston, MA 02111-1307 USA 23 | 24 | ;;; Author: Noel Welsh 25 | ;; 26 | ;; 27 | ;; Commentary: 28 | 29 | #lang racket/base 30 | 31 | (require rackunit 32 | rackunit/private/base) 33 | 34 | (provide base-tests) 35 | 36 | (define base-tests 37 | (test-suite 38 | "All tests for base" 39 | (test-case 40 | "rackunit-test-case structure has a contract on name" 41 | (check-exn exn:fail? 42 | (lambda () 43 | (make-rackunit-test-case 44 | 'foo 45 | (lambda () #t))))) 46 | (test-case 47 | "rackunit-test-case structure has a contract on action" 48 | (check-exn exn:fail? 49 | (lambda () 50 | (make-rackunit-test-case 51 | "Name" 52 | #f)))) 53 | (test-case 54 | "rackunit-test-suite has a contract on its fields" 55 | (check-exn exn:fail? 56 | (lambda () 57 | (make-rackunit-test-suite 58 | #f 59 | (list) 60 | (lambda () 3) 61 | (lambda () 2)))) 62 | (check-exn exn:fail? 63 | (lambda () 64 | (make-rackunit-test-suite 65 | "Name" 66 | #f 67 | (lambda () 3) 68 | (lambda () 2)))) 69 | (check-exn exn:fail? 70 | (lambda () 71 | (make-rackunit-test-suite 72 | "Name" 73 | (list) 74 | #f 75 | (lambda () 2)))) 76 | (check-exn exn:fail? 77 | (lambda () 78 | (make-rackunit-test-suite 79 | "Name" 80 | (list) 81 | (lambda () 3) 82 | #f)))) 83 | )) 84 | 85 | -------------------------------------------------------------------------------- /rackunit-test/tests/rackunit/check-info-test.rkt: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; ---- Tests for check-util 3 | ;;; Time-stamp: <2009-06-11 17:03:21 noel> 4 | ;;; 5 | ;;; Copyright (C) 2003 by Noel Welsh. 6 | ;;; 7 | ;;; This file is part of RackUnit. 8 | 9 | ;;; RackUnit is free software; you can redistribute it and/or 10 | ;;; modify it under the terms of the GNU Lesser General Public 11 | ;;; License as published by the Free Software Foundation; either 12 | ;;; version 2.1 of the License, or (at your option) any later version. 13 | 14 | ;;; RackUnit is distributed in the hope that it will be useful, 15 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 16 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 17 | ;;; Lesser General Public License for more details. 18 | 19 | ;;; You should have received a copy of the GNU Lesser General Public 20 | ;;; License along with RackUnit; if not, write to the Free Software 21 | ;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 22 | 23 | ;;; Author: Noel Welsh 24 | ;; 25 | ;; 26 | ;; Commentary: 27 | 28 | #lang racket/base 29 | 30 | (require racket/function 31 | racket/list 32 | rackunit 33 | rackunit/private/check-info 34 | syntax/srcloc 35 | raco/testing 36 | (submod rackunit/private/check-info for-test)) 37 | 38 | (module+ test 39 | (test-case "with-check-info stores value in lexical order" 40 | (define stack 41 | (with-check-info (['a 1] ['b 2] ['c 3]) (current-check-info))) 42 | (for ([actual (in-list stack)] 43 | [expected (in-list (list 'a 'b 'c))]) 44 | (check-eq? (check-info-name actual) expected))) 45 | 46 | (test-case "Nested uses of with-check-info store values in lexical order" 47 | (define stack 48 | (with-check-info (['a 1] ['b 2] ['c 3]) 49 | (with-check-info (['d 4] ['e 5] ['f 6]) 50 | (current-check-info)))) 51 | (for ([actual (in-list stack)] 52 | [expected (in-list (list 'a 'b 'c 'd 'e 'f))]) 53 | (check-eq? (check-info-name actual) expected))) 54 | 55 | (test-case 56 | "later with-check-info values override earlier values with same name" 57 | (define stack (with-check-info (['a 1] ['a 2]) (current-check-info))) 58 | (check-equal? stack (list (make-check-info 'a 2)))) 59 | 60 | (test-case "nested uses with-check-info override outer values with same name" 61 | (define stack 62 | (with-check-info (['a 1]) 63 | (with-check-info (['a 2]) 64 | (current-check-info)))) 65 | (check-equal? stack (list (make-check-info 'a 2)))) 66 | 67 | (test-case "check-actual? and check-expected? work" 68 | (check-true (check-actual? (make-check-actual 1))) 69 | (check-true (check-expected? (make-check-expected 1))) 70 | (check-false (check-expected? (make-check-actual 1))) 71 | (check-false (check-expected? (make-check-actual 1)))) 72 | 73 | (test-case "make-check-actual and make-check-expected store param (prettified)" 74 | (check-equal? (check-info-value (make-check-actual 1)) (pretty-info 1)) 75 | (check-equal? (check-info-value (make-check-expected 2)) (pretty-info 2))) 76 | 77 | ;; Utilities for collecting the info present in a check 78 | 79 | (define current-info-box (make-parameter #f)) 80 | 81 | (define-check (check-foo arg1 arg2 arg3) 82 | (set-box! (current-info-box) (current-check-info))) 83 | 84 | (define (call/info-box thnk) 85 | (parameterize ([current-info-box (box 'uninitialized)]) 86 | (thnk) 87 | (map check-info-name (unbox (current-info-box))))) 88 | 89 | (test-case "define-check adds certain infos automatically in a specific order" 90 | (define expected-info-names (list 'name 'location 'expression 'params)) 91 | (check-equal? (call/info-box (thunk (check-foo 'arg1 'arg2 'arg3))) 92 | expected-info-names)) 93 | 94 | (test-case "define-check infos are added before custom infos" 95 | (define-check (check-foo/custom-info arg1 arg2 arg3) 96 | (with-check-info (['custom1 'foo] ['custom2 'bar]) 97 | (set-box! (current-info-box) (current-check-info)))) 98 | (define expected-info-names 99 | (list 'name 'location 'expression 'params 'custom1 'custom2)) 100 | (check-equal? (call/info-box 101 | (thunk (check-foo/custom-info 'arg1 'arg2 'arg3))) 102 | expected-info-names)) 103 | 104 | (test-case "define-check infos are added before calling current-check-around" 105 | ;; The check infos added by define-check are not considered part of the 106 | ;; "check body": the expressions given to define-check that implement the 107 | ;; check. The current-check-around param is called with the check body only, 108 | ;; not the info-adding expressions. This lets rackunit clients use 109 | ;; current-check-around to automatically add infos to certain uses of checks 110 | ;; that appear after the default infos, or even override them while still 111 | ;; preserving their position in the stack (the way a nested use of 112 | ;; with-check-info would). 113 | (define (call-check-foo/extra-infos) 114 | (define old-around (current-check-around)) 115 | (define (new-around chk) 116 | (with-check-info (['custom 'custom]) (old-around chk))) 117 | (parameterize ([current-check-around new-around]) 118 | (check-foo 'arg1 'arg2 'arg3))) 119 | (define info-keys (call/info-box call-check-foo/extra-infos)) 120 | (check-true (< (index-of info-keys 'name) 121 | (index-of info-keys 'location) 122 | (index-of info-keys 'expression) 123 | (index-of info-keys 'custom))) 124 | (check-true (< (index-of info-keys 'name) 125 | (index-of info-keys 'location) 126 | (index-of info-keys 'expression) 127 | (index-of info-keys 'params)))) 128 | 129 | (test-case "check-info-ref / check-info-contains-key" 130 | (define info0 (list (make-check-name 'my-name))) 131 | (define info1 (list (make-check-message 'my-message))) 132 | 133 | (parameterize ([current-check-info info0]) 134 | (check-not-false (check-info-ref 'name)) 135 | (check-false (check-info-ref 'message)) 136 | 137 | (check-not-false (check-info-ref info1 'message)) 138 | (check-false (check-info-ref info1 'name)) 139 | 140 | (check-true (check-info-contains-key? 'name)) 141 | (check-false (check-info-contains-key? 'message)) 142 | (check-true (check-info-contains-key? info1 'message)) 143 | (check-false (check-info-contains-key? info1 'name)))) 144 | 145 | (parameterize ([current-test-invocation-directory (current-directory)]) 146 | (test-case "All tests for trim-current-directory" 147 | (test-case "trim-current-directory leaves directories outside the current directory alone" 148 | (check-equal? (trim-current-directory "/foo/bar/") "/foo/bar/")) 149 | (test-equal? 150 | "trim-current-directory strips directory from files in current directory" 151 | (trim-current-directory 152 | (path->string (build-path (current-directory) "foo.rkt"))) 153 | "foo.rkt") 154 | (test-equal? 155 | "trim-current-directory leaves subdirectories alone" 156 | (trim-current-directory 157 | (path->string (build-path (current-directory) "foo" "bar.rkt"))) 158 | "foo/bar.rkt"))) 159 | 160 | (test-case "Do not trample check-info location" 161 | (let ([srcloc #f] [LINE 1][COL 2][POS 3][SPAN 4]) 162 | ;; first test set!'s `srcloc` var 163 | ;; check-exn (and others) should not overwrite my line, col vals 164 | (with-check-info* 165 | (list (make-check-location (list 'here LINE COL POS SPAN))) 166 | (λ () 167 | (check-exn 168 | exn:fail? 169 | (λ () 170 | (set! srcloc 171 | (location-info-value 172 | (check-info-value 173 | (car 174 | (memf 175 | check-location? (current-check-info)))))) 176 | (error "err"))))) 177 | ;; check that check-exn did not overwrite my vals 178 | (check-equal? (source-location-line srcloc) LINE) 179 | (check-equal? (source-location-column srcloc) COL) 180 | (check-equal? (source-location-position srcloc) POS) 181 | (check-equal? (source-location-span srcloc) SPAN))) 182 | ) 183 | -------------------------------------------------------------------------------- /rackunit-test/tests/rackunit/failure-test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require rackunit 4 | rackunit/text-ui 5 | racket/port 6 | tests/eli-tester) 7 | 8 | (define output 9 | (with-output-to-string 10 | (lambda () 11 | (parameterize ([current-error-port (current-output-port)]) 12 | (run-tests (test-suite "tests" 13 | (check-equal? 1 4) 14 | (check-equal? 1 1))))))) 15 | 16 | (test 17 | (regexp-match 18 | (regexp (regexp-quote "1 success(es) 1 failure(s) 0 error(s) 2 test(s) run\n")) 19 | output)) 20 | 21 | (module test racket/base 22 | (require syntax/location) 23 | ;; Use a separate namespace to avoid logging results 24 | ;; in this namespace (where `raco test` would see errors). 25 | (parameterize ([current-namespace (make-base-namespace)]) 26 | (dynamic-require (quote-module-path "..") #f))) 27 | -------------------------------------------------------------------------------- /rackunit-test/tests/rackunit/format-test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/function 4 | racket/port 5 | racket/list 6 | racket/pretty 7 | rackunit 8 | rackunit/private/check-info 9 | (submod rackunit/private/format for-test)) 10 | 11 | (define-check (check-output expected thnk) 12 | (define actual (with-output-to-string thnk)) 13 | (with-check-info* (list (make-check-actual actual) 14 | (make-check-expected expected)) 15 | (thunk 16 | (unless (equal? actual expected) 17 | (fail-check))))) 18 | 19 | (test-case "display-check-info-stack" 20 | (test-case "basic" 21 | (check-output "name: \"foo\"\nactual: 1\nexpected: 2\n" 22 | (thunk (display-check-info-stack 23 | (list (make-check-name "foo") 24 | (make-check-actual 1) 25 | (make-check-expected 2)))))) 26 | (test-case "string-info" 27 | (check-output "name: foo\n" 28 | (thunk (display-check-info-stack 29 | (list (make-check-info 'name (string-info "foo"))))))) 30 | (test-case "nested-info" 31 | (check-output "name:\n foo: 1\n bar: 2\n" 32 | (thunk 33 | (display-check-info-stack 34 | (list (make-check-name 35 | (nested-info 36 | (list (make-check-info 'foo 1) 37 | (make-check-info 'bar 2))))))))) 38 | (test-case "dynamic-info" 39 | (check-output "foo: 1\n" 40 | (thunk 41 | (display-check-info-stack 42 | (list (make-check-info 'foo (dynamic-info (thunk 1))))))) 43 | (test-case "with-nested-info" 44 | (check-output "name:\n foo: 1\n bar: 2\n" 45 | (thunk 46 | (display-check-info-stack 47 | (list (make-check-name 48 | (dynamic-info 49 | (thunk 50 | (nested-info 51 | (list (make-check-info 'foo 1) 52 | (make-check-info 'bar 2)))))))))))) 53 | (let ([big (make-list 30 99)]) 54 | (test-case "multi-line" 55 | (check-output (format "foo:\n ~s\n" big) 56 | (thunk 57 | (display-check-info-stack 58 | (list (make-check-info 'foo big)))))))) 59 | -------------------------------------------------------------------------------- /rackunit-test/tests/rackunit/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define test-responsibles '((all (jay noel)))) 4 | -------------------------------------------------------------------------------- /rackunit-test/tests/rackunit/location-test.rkt: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; Time-stamp: <2008-07-28 11:14:22 nhw> 3 | ;;; 4 | ;;; Copyright (C) 2005 by Noel Welsh. 5 | ;;; 6 | 7 | ;;; This library is free software; you can redistribute it 8 | ;;; and/or modify it under the terms of the GNU Lesser 9 | ;;; General Public License as published by the Free Software 10 | ;;; Foundation; either version 2.1 of the License, or (at 11 | ;;; your option) any later version. 12 | 13 | ;;; This library is distributed in the hope that it will be 14 | ;;; useful, but WITHOUT ANY WARRANTY; without even the 15 | ;;; implied warranty of MERCHANTABILITY or FITNESS FOR A 16 | ;;; PARTICULAR PURPOSE. See the GNU Lesser General Public 17 | ;;; License for more details. 18 | 19 | ;;; You should have received a copy of the GNU Lesser 20 | ;;; General Public License along with this library; if not, 21 | ;;; write to the Free Software Foundation, Inc., 59 Temple 22 | ;;; Place, Suite 330, Boston, MA 02111-1307 USA 23 | 24 | ;;; Author: Noel Welsh 25 | ;; 26 | ;; 27 | ;; Commentary: 28 | #lang racket/base 29 | 30 | (require rackunit 31 | rackunit/private/location) 32 | 33 | (provide location-tests) 34 | 35 | (define (read-syntax/lang name port) 36 | (parameterize ([read-accept-reader #t]) 37 | (read-syntax name port))) 38 | 39 | (define location-tests 40 | (test-suite 41 | "All tests for location" 42 | 43 | (test-case 44 | "syntax->location ok" 45 | (around 46 | (with-output-to-file "test-file.rkt" 47 | (lambda () (display "#lang racket\n'foo\n"))) 48 | (let* ([stx (read-syntax/lang (string->path "test-file.rkt") 49 | (open-input-file "test-file.rkt"))] 50 | [rep (syntax->location stx)]) 51 | (check-equal? (location-source rep) 52 | (syntax-source stx)) 53 | (check-equal? (location-position rep) 54 | (syntax-position stx)) 55 | (check-equal? (location-span rep) 56 | (syntax-span stx))) 57 | (delete-file "test-file.rkt"))) 58 | 59 | (test-case 60 | "Emacs compatible location strings" 61 | (check string=? 62 | (location->string 63 | (syntax->location 64 | (datum->syntax 65 | #f #f 66 | (list "file.rkt" 42 38 1240 2)))) 67 | "file.rkt:42:38") 68 | (check string=? 69 | (location->string 70 | (syntax->location 71 | (datum->syntax 72 | #f #f 73 | (list (string->path "file.rkt") 42 38 1240 2)))) 74 | "file.rkt:42:38") 75 | (check string=? 76 | (location->string 77 | (syntax->location 78 | (datum->syntax 79 | #f #f 80 | (list #f 42 38 1240 2)))) 81 | "unknown:42:38") 82 | (check string=? 83 | (location->string 84 | (syntax->location 85 | (datum->syntax 86 | #f #f 87 | (list 'foo.rkt 42 38 1240 2)))) 88 | "foo.rkt:42:38") 89 | (check string=? 90 | (location->string 91 | (syntax->location 92 | (datum->syntax 93 | #f #f 94 | (list "foo.rkt" #f #f #f #f)))) 95 | "foo.rkt:?:?")) 96 | )) 97 | 98 | -------------------------------------------------------------------------------- /rackunit-test/tests/rackunit/nested-info-test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (module+ test 4 | 5 | (require racket/function 6 | racket/port 7 | rackunit 8 | (submod rackunit/private/format for-test)) 9 | 10 | (define (info* . name+vs) 11 | (define vec (list->vector name+vs)) 12 | (define len (vector-length vec)) 13 | (for/list ([name-idx (in-range 0 len 2)] 14 | [v-idx (in-range 1 len 2)]) 15 | (make-check-info (vector-ref vec name-idx) (vector-ref vec v-idx)))) 16 | 17 | (define (nested-info* . name+vs) (nested-info (apply info* name+vs))) 18 | 19 | (define-check (check-info-stack-output str-or-rx stack) 20 | (define actual 21 | (with-output-to-string (thunk (display-check-info-stack stack)))) 22 | (with-check-info (['actual actual] ['expected str-or-rx]) 23 | (unless (equal? str-or-rx actual) (fail-check)))) 24 | 25 | (test-case "Nested check info printing" 26 | (define test-info (info* 'foo 1 'nested (nested-info* 'bar 2 'baz 3))) 27 | (define expected-str "foo: 1 28 | nested: 29 | bar: 2 30 | baz: 3 31 | ") 32 | (check-info-stack-output expected-str test-info)) 33 | 34 | (test-case "Double-nested check info printing" 35 | (define test-info 36 | (info* 'nested 37 | (nested-info* 'double-nested (nested-info* 'foo 1 'bar 2)))) 38 | (define expected-str "nested: 39 | double-nested: 40 | foo: 1 41 | bar: 2 42 | ") 43 | (check-info-stack-output expected-str test-info)) 44 | 45 | (test-case "Multiple double-nested check info printing" 46 | (define test-info 47 | (info* 'nested 48 | (nested-info* 'foo (nested-info* 'foo1 1 'foo2 2) 49 | 'bar (nested-info* 'bar1 1 'bar2 2)))) 50 | (define expected-str "nested: 51 | foo: 52 | foo1: 1 53 | foo2: 2 54 | bar: 55 | bar1: 1 56 | bar2: 2 57 | ") 58 | (check-info-stack-output expected-str test-info))) 59 | -------------------------------------------------------------------------------- /rackunit-test/tests/rackunit/nested-test-suite.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (module core racket/base 4 | (require rackunit 5 | rackunit/text-ui) 6 | (run-tests (test-suite "tests" 7 | (test-suite "sub-tests" 8 | (check-equal? 1 2))))) 9 | 10 | (module test racket/base 11 | (require syntax/location 12 | racket/port 13 | rackunit) 14 | ;; Use a separate namespace to avoid logging results 15 | ;; in this namespace (where `raco test` would see errors). 16 | (define output 17 | (with-output-to-string 18 | (lambda () 19 | (parameterize ([current-error-port (current-output-port)] 20 | [current-namespace (make-base-namespace)]) 21 | (dynamic-require (quote-module-path ".." core) #f))))) 22 | (check-regexp-match 23 | (regexp (regexp-quote "--------------------\ntests > sub-tests > Unnamed test\nFAILURE")) 24 | output)) 25 | -------------------------------------------------------------------------------- /rackunit-test/tests/rackunit/pr/100.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require rackunit) 3 | 4 | (module+ test 5 | (define ((arity-exn/rx rx) e) 6 | (and (exn:fail:contract:arity? e) 7 | (regexp-match? rx (exn-message e)))) 8 | 9 | (check-exn (arity-exn/rx #rx"check-exn") 10 | (lambda () (check-exn (lambda () 'hi)))) 11 | (check-exn (arity-exn/rx #rx"check-true") 12 | (lambda () (check-true 1 2 3 4))) 13 | (check-exn (arity-exn/rx #rx"check-equal\\?") 14 | (lambda () (check-equal? (list 1 2)))) 15 | 16 | (let ([cp check-pred]) 17 | (check-true (procedure-arity-includes? cp 2)) 18 | (check-true (procedure-arity-includes? cp 3)) 19 | (check-false (procedure-arity-includes? cp 0)) 20 | (check-false (procedure-arity-includes? cp 1)) 21 | (check-false (procedure-arity-includes? cp 4)))) 22 | -------------------------------------------------------------------------------- /rackunit-test/tests/rackunit/pr/109+138.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require rackunit 4 | rackunit/text-ui 5 | racket/port 6 | tests/eli-tester) 7 | 8 | (define output 9 | (with-output-to-string 10 | (lambda () 11 | (parameterize ([current-error-port (current-output-port)]) 12 | (run-tests (test-suite "tests" 13 | (check-equal? 1 1) 14 | (check-equal? (1) 1) 15 | (check-equal? 1 2) 16 | (check-equal? 1 1))) 17 | (run-tests (test-suite "tests2" 18 | (check-equal? 5 5) 19 | (check-equal? 4 4) 20 | (check-equal? 3 3) 21 | (check-equal? 2 2) 22 | (check-equal? 1 1))))))) 23 | 24 | (test 25 | (regexp-match 26 | (regexp (regexp-quote "2 success(es) 1 failure(s) 1 error(s) 4 test(s) run\n")) 27 | output)) 28 | 29 | (test 30 | (regexp-match 31 | (regexp (regexp-quote "5 success(es) 0 failure(s) 0 error(s) 5 test(s) run\n")) 32 | output)) 33 | 34 | (test 35 | (with-handlers ([exn:fail? (λ (e) 36 | (regexp-match 37 | (regexp (regexp-quote "given: 3")) 38 | (exn-message e)))]) 39 | (define my-check-equal? check-equal?) 40 | (run-tests (test-suite "tests" 41 | (my-check-equal? 1 1) 42 | (my-check-equal? (3) 1) 43 | (my-check-equal? 1 2))) 44 | #f)) 45 | 46 | (module test racket/base 47 | (require syntax/location) 48 | ;; Use a separate namespace to avoid logging results 49 | ;; in this namespace (where `raco test` would see errors). 50 | (parameterize ([current-namespace (make-base-namespace)]) 51 | (dynamic-require (quote-module-path "..") #f))) 52 | -------------------------------------------------------------------------------- /rackunit-test/tests/rackunit/pr/121.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require rackunit racket/port) 3 | (module+ test 4 | (define s (make-semaphore)) 5 | (define op (current-output-port) #;(open-output-nowhere)) 6 | (define answer (make-channel)) 7 | (define t 8 | (thread 9 | (λ () 10 | (parameterize ([current-error-port op] 11 | [current-output-port op]) 12 | (with-handlers ([exn:break? (λ (x) (channel-put answer 'passed))]) 13 | (check-equal? (let () 14 | (semaphore-post s) 15 | (semaphore-wait (make-semaphore 0))) 16 | 5) 17 | (channel-put answer 'failed)))))) 18 | (semaphore-wait s) 19 | (break-thread t) 20 | (unless (equal? (channel-get answer) 'passed) 21 | (error "test for pr 121 failed"))) 22 | -------------------------------------------------------------------------------- /rackunit-test/tests/rackunit/pr/13.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require rackunit 3 | rackunit/text-ui 4 | racket/port 5 | racket/match 6 | racket/system 7 | racket/runtime-path) 8 | 9 | (define-runtime-path me "13.rkt") 10 | 11 | (define a 12 | (test-suite "Test Suite" 13 | (test-case "Test Case" 14 | (check-equal? #t #f)))) 15 | 16 | (define b 17 | (test-suite "Test Suite" 18 | (test-case "Test Case" 19 | (check-equal? (error 'error "I'm an error!") #f)))) 20 | 21 | (module+ test 22 | (define mode (getenv "PR13")) 23 | (printf "\n\nRunning in mode ~v\n\n" mode) 24 | (match mode 25 | ["a" (run-tests a)] 26 | ["a-raw" (check-equal? #t #f)] 27 | ["b" (run-tests b)] 28 | ["b-raw" (check-equal? (error 'error "I'm an error!") #f)] 29 | [#f 30 | (for ([v (in-list '("a" "a-raw" "b" "b-raw"))]) 31 | (putenv "PR13" v) 32 | (printf "Readying mode ~v\n" v) 33 | (check-equal? 34 | (parameterize ([current-output-port (open-output-nowhere)]) 35 | (parameterize ([current-error-port (current-output-port)]) 36 | (system*/exit-code (find-system-path 'exec-file) 37 | "-l" "raco" "--" "test" me))) 38 | 1))])) 39 | -------------------------------------------------------------------------------- /rackunit-test/tests/rackunit/pr/5.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (module+ test 3 | (require rackunit 4 | racket/port 5 | rackunit/text-ui) 6 | 7 | (define t (open-output-string)) 8 | (parameterize ([current-error-port t]) 9 | (run-tests 10 | (test-suite "x" 11 | (check-not-false (displayln 0))))) 12 | (check-equal? (get-output-string t) "")) 13 | -------------------------------------------------------------------------------- /rackunit-test/tests/rackunit/pr/90.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; Test the optional `message` argument to checks: 4 | ;; - if "", output contains "" 5 | ;; - if #f, output nothing 6 | ;; - if unsupplied, output nothing 7 | 8 | (require rackunit 9 | rackunit/text-ui 10 | racket/port 11 | tests/eli-tester) 12 | 13 | ;; --- setup 14 | 15 | ;; Test check forms with no message, #f message, and "" message 16 | (define-syntax-rule (test-check/empty-message (check-name arg* ...) ...) 17 | (begin 18 | (begin 19 | (test (not (regexp-match? #rx"message:" (capture-output (check-name arg* ...))))) 20 | (test (not (regexp-match? #rx"message:" (capture-output (check-name arg* ... #f))))) 21 | (test (regexp-match? #rx"message: *\"\"" (capture-output (check-name arg* ... ""))))) 22 | ...)) 23 | 24 | ;; Evaluate `expr`, return string with error output 25 | (define-syntax-rule (capture-output expr) 26 | (with-output-to-string 27 | (lambda () 28 | (parameterize ([current-error-port (current-output-port)]) 29 | expr)))) 30 | 31 | ;; --- actual tests 32 | 33 | (test-check/empty-message 34 | (check-eq? 'a 'b) 35 | (check-not-eq? 0 0) 36 | (check-eqv? 'a 'b) 37 | (check-not-eqv? 0 0) 38 | (check-equal? 'a 'b) 39 | (check-not-equal? 0 0) 40 | (check-pred values #f) 41 | (check-= 0 1 0) 42 | (check-true #false) 43 | (check-false #true) 44 | (check-not-false #false) 45 | (check = 1 2) 46 | (fail) 47 | ) 48 | 49 | ;; --- copied from "../pr10950.rkt" 50 | 51 | (module test racket/base 52 | (require syntax/location) 53 | ;; Use a separate namespace to avoid logging results 54 | ;; in this namespace (where `raco test` would see errors). 55 | (parameterize ([current-namespace (make-base-namespace)]) 56 | (dynamic-require (quote-module-path "..") #f))) 57 | -------------------------------------------------------------------------------- /rackunit-test/tests/rackunit/pr10950.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require rackunit 3 | rackunit/text-ui 4 | racket/port 5 | tests/eli-tester) 6 | 7 | (define output 8 | (with-output-to-string 9 | (lambda () 10 | (parameterize ([current-error-port (current-output-port)]) 11 | (define-check (check3) 12 | (fail-check)) 13 | 14 | (run-tests (test-suite "tests" (let ((foo check3)) (foo)))))))) 15 | 16 | (test 17 | (regexp-match 18 | (regexp (format "~a.*~a.*~a" 19 | (regexp-quote "--------------------\ntests > Unnamed test\nFAILURE\nname: check3\nlocation: ") 20 | (regexp-quote "pr10950.rkt:14:51") 21 | (regexp-quote "0 success(es) 1 failure(s) 0 error(s) 1 test(s) run\n"))) 22 | output)) 23 | 24 | (module test racket/base 25 | (require syntax/location) 26 | ;; Use a separate namespace to avoid logging results 27 | ;; in this namespace (where `raco test` would see errors). 28 | (parameterize ([current-namespace (make-base-namespace)]) 29 | (dynamic-require (quote-module-path "..") #f))) -------------------------------------------------------------------------------- /rackunit-test/tests/rackunit/result-test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require rackunit 4 | rackunit/private/result) 5 | 6 | (test-case "All tests for result" 7 | 8 | (test-equal? 9 | "fold-test-results returns seed" 10 | (fold-test-results 11 | (lambda (result seed) seed) 12 | 'hello 13 | (delay-test (test-case "Demo" (check = 1 1))) 14 | #:fdown (lambda (name seed) seed) 15 | #:run run-test-case) 16 | 'hello) 17 | 18 | (test-equal? 19 | "fold-test-results return values of run to result-fn" 20 | (fold-test-results 21 | (lambda (v1 v2 seed) 22 | (check-equal? v1 'v1) 23 | (check-equal? v2 'v2) 24 | seed) 25 | 'hello 26 | (delay-test (test-case "Demo" (check = 1 1))) 27 | #:run (lambda (name action) (values 'v1 'v2))) 28 | 'hello) 29 | 30 | (test-equal? 31 | "fold-test-results calls run with name and action" 32 | (fold-test-results 33 | (lambda (result seed) seed) 34 | 'hello 35 | (delay-test (test-case "Demo" 'boo)) 36 | #:run (lambda (name action) 37 | (check string=? name "Demo") 38 | (check-equal? (action) 'boo))) 39 | 'hello)) 40 | -------------------------------------------------------------------------------- /rackunit-test/tests/rackunit/run-tests.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require rackunit 4 | rackunit/text-ui 5 | "all-rackunit-tests.rkt") 6 | 7 | (run-tests all-rackunit-tests) 8 | 9 | ;; These tests should all error, so we switch the meaning of correct and incorrect. If the error display changes significantly, DrDr will catch it 10 | (parameterize ([current-error-port (current-output-port)] 11 | [current-output-port (current-error-port)]) 12 | (run-tests failure-tests)) 13 | 14 | (module test racket/base 15 | (require syntax/location) 16 | ;; Use a separate namespace to avoid logging results 17 | ;; in this namespace (where `raco test` would see errors). 18 | (parameterize ([current-namespace (make-base-namespace)]) 19 | (dynamic-require (quote-module-path "..") #f))) 20 | -------------------------------------------------------------------------------- /rackunit-test/tests/rackunit/standalone-check-higher-order-test.rkt: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; Time-stamp: <2008-06-06 15:32:49 noel> 3 | ;;; 4 | ;;; Copyright (C) by Noel Welsh. 5 | ;;; 6 | 7 | ;;; This library is free software; you can redistribute it 8 | ;;; and/or modify it under the terms of the GNU Lesser 9 | ;;; General Public License as published by the Free Software 10 | ;;; Foundation; either version 2.1 of the License, or (at 11 | ;;; your option) any later version. 12 | 13 | ;;; This library is distributed in the hope that it will be 14 | ;;; useful, but WITHOUT ANY WARRANTY; without even the 15 | ;;; implied warranty of MERCHANTABILITY or FITNESS FOR A 16 | ;;; PARTICULAR PURPOSE. See the GNU Lesser General Public 17 | ;;; License for more details. 18 | 19 | ;;; You should have received a copy of the GNU Lesser 20 | ;;; General Public License along with this library; if not, 21 | ;;; write to the Free Software Foundation, Inc., 59 Temple 22 | ;;; Place, Suite 330, Boston, MA 02111-1307 USA 23 | 24 | ;;; Author: Noel Welsh 25 | 26 | 27 | ;; Here we check the standalone (not within a test-case or 28 | ;; test-suite) semantics of checks. These tests are not 29 | ;; part of the standard test suite and must be run 30 | ;; separately. 31 | 32 | #lang racket/base 33 | 34 | (require rackunit/private/check) 35 | 36 | ;; Don't run this test automatically: 37 | (module test racket/base 38 | (displayln "run as program for tests")) 39 | 40 | (define my-check check) 41 | 42 | ;; This check should succeed 43 | (my-check = 1 1) 44 | 45 | ;; This check should display an error including the message "Outta here!" 46 | ((values check-pred) (procedure-rename (lambda (x) (error "Outta here!")) 'proc) 'foo) 47 | 48 | 49 | ;; This check should display a failure 50 | (my-check = 1 2) 51 | 52 | ;; This check should display "Oh HAI!" 53 | (parameterize 54 | ([current-check-handler (lambda (e) (display "Oh HAI!\n"))]) 55 | (my-check = 1 2)) 56 | 57 | ;; This check should display "I didn't run" 58 | (parameterize 59 | ([current-check-around (lambda (t) (display "I didn't run\n"))]) 60 | (my-check = 1 1)) 61 | -------------------------------------------------------------------------------- /rackunit-test/tests/rackunit/standalone-check-test.rkt: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; Time-stamp: <2008-06-06 15:32:49 noel> 3 | ;;; 4 | ;;; Copyright (C) by Noel Welsh. 5 | ;;; 6 | 7 | ;;; This library is free software; you can redistribute it 8 | ;;; and/or modify it under the terms of the GNU Lesser 9 | ;;; General Public License as published by the Free Software 10 | ;;; Foundation; either version 2.1 of the License, or (at 11 | ;;; your option) any later version. 12 | 13 | ;;; This library is distributed in the hope that it will be 14 | ;;; useful, but WITHOUT ANY WARRANTY; without even the 15 | ;;; implied warranty of MERCHANTABILITY or FITNESS FOR A 16 | ;;; PARTICULAR PURPOSE. See the GNU Lesser General Public 17 | ;;; License for more details. 18 | 19 | ;;; You should have received a copy of the GNU Lesser 20 | ;;; General Public License along with this library; if not, 21 | ;;; write to the Free Software Foundation, Inc., 59 Temple 22 | ;;; Place, Suite 330, Boston, MA 02111-1307 USA 23 | 24 | ;;; Author: Noel Welsh 25 | 26 | 27 | ;; Here we check the standalone (not within a test-case or 28 | ;; test-suite) semantics of checks. These tests are not 29 | ;; part of the standard test suite and must be run 30 | ;; separately. 31 | 32 | #lang racket/base 33 | 34 | (require rackunit/private/check) 35 | 36 | ;; Don't run this test automatically: 37 | (module test racket/base 38 | (displayln "run as program for tests")) 39 | 40 | ;; This check should succeed 41 | (check = 1 1) 42 | 43 | ;; This check should display an error including the message "Outta here!" 44 | (check-pred (procedure-rename (lambda (x) (error "Outta here!")) 'proc) 'foo) 45 | 46 | 47 | ;; This check should display a failure 48 | (check = 1 2) 49 | 50 | ;; This check should display "Oh HAI!" 51 | (parameterize 52 | ([current-check-handler (lambda (e) (display "Oh HAI!\n"))]) 53 | (check = 1 2)) 54 | 55 | ;; This check should display "I didn't run" 56 | (parameterize 57 | ([current-check-around (lambda (t) (display "I didn't run\n"))]) 58 | (check = 1 1)) 59 | -------------------------------------------------------------------------------- /rackunit-test/tests/rackunit/standalone-test-case-test.rkt: -------------------------------------------------------------------------------- 1 | ;; Here we check the standalone (not within a test-suite) 2 | ;; semantics of checks. These tests are not part of the 3 | ;; standard test suite and must be run separately. 4 | 5 | #lang racket/base 6 | 7 | (require rackunit/private/check 8 | rackunit/private/test-case) 9 | 10 | ;; Don't run this test automatically: 11 | (module test racket/base 12 | (displayln "run as program for tests")) 13 | 14 | ;; These tests should succeeds 15 | (test-begin (check-eq? 1 1)) 16 | (test-case "succeed" (check-eq? 1 1)) 17 | 18 | ;; These should raise errors 19 | (test-begin (error "First Outta here!")) 20 | (test-case "error" (error "Second Outta here!")) 21 | 22 | ;; Thesse should raise failures 23 | (test-begin (check-eq? 1 2)) 24 | (test-case "failure" (check-eq? 1 2)) 25 | -------------------------------------------------------------------------------- /rackunit-test/tests/rackunit/standalone.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/runtime-path 3 | rackunit 4 | racket/path) 5 | 6 | (module test racket/base 7 | (require syntax/location) 8 | ;; Use a separate namespace to avoid logging results 9 | ;; in this namespace (where `raco test` would see errors). 10 | (parameterize ([current-namespace (make-base-namespace)]) 11 | (dynamic-require (quote-module-path "..") #f))) 12 | 13 | (define-runtime-path here ".") 14 | (define collects 15 | (normalize-path (build-path here ".." ".."))) 16 | (define (collect-trim bs) 17 | (regexp-replace* (regexp-quote (path->bytes collects)) bs #"PLTHOME/collects")) 18 | 19 | (define (require&catch path) 20 | (define out-bs (open-output-bytes)) 21 | (define err-bs (open-output-bytes)) 22 | (parameterize ([current-output-port out-bs] 23 | [current-error-port err-bs] 24 | ;; Don't test error display handler output; it's too fragile. 25 | [error-display-handler (λ (msg exn) (displayln msg))]) 26 | (dynamic-require path #f)) 27 | (close-output-port out-bs) 28 | (close-output-port err-bs) 29 | (values (collect-trim (get-output-bytes out-bs)) 30 | (collect-trim (get-output-bytes err-bs)))) 31 | 32 | (define-syntax-rule (test-file pth out err) 33 | (begin 34 | (define-runtime-module-path mod (file pth)) 35 | (define-values (cout cerr) (require&catch mod)) 36 | (check-equal? cout out) 37 | (check-equal? cerr err))) 38 | 39 | (test-file "standalone-check-test.rkt" 40 | #"Oh HAI!\nI didn't run\n" 41 | #"\ 42 | -------------------- 43 | ERROR 44 | name: check-pred 45 | location: standalone-check-test.rkt:44:0 46 | params: '(# foo) 47 | 48 | Outta here! 49 | -------------------- 50 | -------------------- 51 | FAILURE 52 | name: check 53 | location: standalone-check-test.rkt:48:0 54 | params: '(# 1 2) 55 | -------------------- 56 | ") 57 | 58 | (test-file "standalone-check-higher-order-test.rkt" 59 | #"Oh HAI!\nI didn't run\n" 60 | #"\ 61 | -------------------- 62 | ERROR 63 | name: check-pred 64 | location: standalone-check-higher-order-test.rkt:46:9 65 | params: '(# foo) 66 | 67 | Outta here! 68 | -------------------- 69 | -------------------- 70 | FAILURE 71 | name: check 72 | location: standalone-check-higher-order-test.rkt:40:17 73 | params: '(# 1 2) 74 | -------------------- 75 | ") 76 | 77 | (test-file "standalone-test-case-test.rkt" 78 | #"" 79 | #"\ 80 | -------------------- 81 | ERROR 82 | 83 | First Outta here! 84 | -------------------- 85 | -------------------- 86 | error 87 | ERROR 88 | 89 | Second Outta here! 90 | -------------------- 91 | -------------------- 92 | FAILURE 93 | name: check-eq? 94 | location: standalone-test-case-test.rkt:23:12 95 | actual: 1 96 | expected: 2 97 | -------------------- 98 | -------------------- 99 | failure 100 | FAILURE 101 | name: check-eq? 102 | location: standalone-test-case-test.rkt:24:21 103 | actual: 1 104 | expected: 2 105 | -------------------- 106 | ") 107 | -------------------------------------------------------------------------------- /rackunit-test/tests/rackunit/test-case-test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require rackunit/private/base 4 | rackunit/private/check 5 | rackunit/private/test-case 6 | rackunit/private/test-suite 7 | rackunit/private/result) 8 | 9 | (provide test-case-tests) 10 | 11 | (define test-case-tests 12 | (test-suite 13 | "test-case-tests" 14 | 15 | (check-exn #rx"contract" (λ () (test-case 'foo))) 16 | 17 | (test-case 18 | "test-begin terminates when sub-expression fails" 19 | (let ([fail? #f]) 20 | (delay-test 21 | (run-test 22 | (test-begin 23 | (check-eq? 'a 'b) 24 | (set! fail? #t))) 25 | (check-false fail?)))) 26 | 27 | (test-case 28 | "test-case terminates when sub-expression fails" 29 | (let ([fail? #f]) 30 | (delay-test 31 | (run-test 32 | (test-case 33 | "foo" 34 | (check-eq? 'a 'b) 35 | (set! fail? #t))) 36 | (check-false fail?)))) 37 | 38 | (test-case 39 | "define allowed within test-begin" 40 | (check-pred 41 | test-success? 42 | (delay-test 43 | (car (run-test 44 | (test-begin 45 | (define yes #t) 46 | (check-true yes))))))) 47 | 48 | (test-case 49 | "define allowed within test-case" 50 | (check-pred 51 | test-success? 52 | (delay-test 53 | (car (run-test 54 | (test-case 55 | "dummy" 56 | (define yes #t) 57 | (check-true yes))))))))) 58 | 59 | (module+ not-test 60 | (require rackunit/text-ui) 61 | (run-tests test-case-tests)) 62 | -------------------------------------------------------------------------------- /rackunit-test/tests/rackunit/test-suite-test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require rackunit 4 | rackunit/private/check) 5 | 6 | (define run? #f) 7 | 8 | (define-test-suite define-test 9 | (check = 1 1)) 10 | 11 | (define/provide-test-suite test-suite-define-provide-test 12 | (check = 1 1)) 13 | 14 | (define test-suite-tests 15 | (test-suite 16 | "test-suite-tests" 17 | 18 | ;; We rely on order of evaluation to test that checks are 19 | ;; converted to test cases 20 | 21 | (test-begin 22 | (check-false run?)) 23 | 24 | (check-not-exn (lambda () (begin (set! run? #t) run?))) 25 | 26 | (test-begin 27 | (check-true run?)) 28 | 29 | ;; Reset state so tests can be run again. 30 | (set! run? #f) 31 | 32 | (test-case 33 | "define-test" 34 | (check-pred test-suite? define-test)) 35 | 36 | (test-case 37 | "test-suite name must be string" 38 | (check-exn exn:fail:contract? 39 | (lambda () 40 | (test-suite (check = 1 1))))) 41 | 42 | (test-case 43 | "make-test-suite" 44 | (let* ([before? #f] 45 | [after? #f] 46 | [ran? #f] 47 | [results 48 | (run-test 49 | (make-test-suite 50 | "dummy1" 51 | (list 52 | (make-test-case 53 | "dummy-test-1" 54 | (lambda () (check-true #t))) 55 | (make-test-suite 56 | "dummy2" 57 | #:before (lambda () (set! before? #t)) 58 | #:after (lambda () (set! after? #t)) 59 | (list 60 | (make-test-case 61 | "dummy-test-2" 62 | (lambda () 63 | (set! ran? #t) 64 | (check-true #t))))))))]) 65 | (check-equal? (length results) 2) 66 | (map (lambda (r) (check-pred test-success? r)) results) 67 | (check-true before?) 68 | (check-true after?) 69 | (check-true ran?))) 70 | )) 71 | 72 | 73 | 74 | (provide test-suite-tests) 75 | -------------------------------------------------------------------------------- /rackunit-test/tests/rackunit/test-test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/string 4 | rackunit 5 | rackunit/private/check-info 6 | rackunit/private/util 7 | rackunit/private/location) 8 | 9 | (provide test-tests) 10 | 11 | (define successful-suite 12 | (test-suite 13 | "Example A" 14 | (test-case 15 | "Example 1" 16 | #t) 17 | (test-case 18 | "Example 2" 19 | #t) 20 | (test-case 21 | "Example 3" 22 | #t))) 23 | 24 | (define-check (check-test-results test successes failures errors) 25 | (let ((results (run-test test))) 26 | (check = (length results) (+ successes failures errors)) 27 | (check = 28 | (length (filter test-success? results)) 29 | successes 30 | "Successes not the expected number") 31 | (check = 32 | (length (filter test-failure? results)) 33 | failures 34 | "Failures not the expected number") 35 | (check = 36 | (length (filter test-error? results)) 37 | errors 38 | "Errors not the expected number"))) 39 | 40 | (define-check (check-syntax-error msg sexp) 41 | (let ((destns (make-base-namespace)) 42 | (cns (current-namespace))) 43 | (parameterize ((current-namespace destns)) 44 | (namespace-require 'rackunit) 45 | (check-exn (lambda (e) 46 | (check-pred exn:fail:syntax? e) 47 | (check string-contains? (exn-message e) msg)) 48 | (lambda () 49 | (eval sexp)))))) 50 | 51 | (define test-tests 52 | (test-suite 53 | "Test tests" 54 | (test-case "Empty test" #t) 55 | 56 | (test-case 57 | "After action is executed" 58 | (let ((foo 1)) 59 | (after (check = foo 1) (set! foo 2)) 60 | (check = foo 2))) 61 | 62 | (test-case 63 | "Before action is executed" 64 | (let ((foo 1)) 65 | (before (set! foo 2) (check = foo 2)) 66 | (check = foo 2))) 67 | 68 | (test-case 69 | "After action is executed in presence of exception" 70 | (let ((foo 1)) 71 | (check-exn exn? 72 | (lambda () 73 | (after (error "quit") (set! foo 2)))) 74 | (check = foo 2))) 75 | 76 | (test-case 77 | "Around action is executed in presence of exception" 78 | (let ((foo 1)) 79 | (check-exn exn? 80 | (lambda () 81 | (around 82 | (set! foo 0) 83 | (check = foo 0) 84 | (error "quit") 85 | (set! foo 2)))) 86 | (check = foo 2))) 87 | 88 | (test-case 89 | "Before macro catches badly formed syntax w/ helpful message" 90 | (check-syntax-error "before: expected more terms" '(before 1)) 91 | (check-syntax-error "before: expected more terms" '(before))) 92 | 93 | (test-case 94 | "After macro catches badly formed syntax w/ helpful message" 95 | (check-syntax-error "after: expected more terms" '(after 1)) 96 | (check-syntax-error "after: expected more terms" '(after))) 97 | 98 | (test-case 99 | "Around macro catches badly formed syntax w/ helpful message" 100 | (check-syntax-error "around: expected more terms" '(around)) 101 | (check-syntax-error "around: expected more terms" '(around 1)) 102 | (check-syntax-error "around: expected more terms" '(around 1 2))) 103 | 104 | (test-case 105 | "Test around action" 106 | (around (with-output-to-file "test.dat" 107 | (lambda () (display "hello"))) 108 | (check-true (file-exists? "test.dat")) 109 | (delete-file "test.dat"))) 110 | 111 | (test-case 112 | "Before and after on test suite are run" 113 | (let ((foo 1)) 114 | (check-equal? foo 1) 115 | (run-test 116 | (test-suite 117 | "Dummy suite" 118 | #:before (lambda () (set! foo 2)) 119 | #:after (lambda () (set! foo 3)) 120 | (test-case 121 | "Test foo" 122 | (check-equal? foo 2)))) 123 | (check-equal? foo 3))) 124 | 125 | (test-case 126 | "Before on test suite is run" 127 | (let ((foo 1)) 128 | (check-equal? foo 1) 129 | (run-test 130 | (test-suite 131 | "Dummy suite" 132 | #:before (lambda () (set! foo 2)) 133 | (test-case 134 | "Test foo" 135 | (check-equal? foo 2)))) 136 | (check-equal? foo 2))) 137 | 138 | (test-case 139 | "After on test suite is run" 140 | (let ((foo 1)) 141 | (check-equal? foo 1) 142 | (run-test 143 | (test-suite 144 | "Dummy suite" 145 | #:after (lambda () (set! foo 3)) 146 | (test-case 147 | "Test foo" 148 | (check-equal? foo 2)))) 149 | (check-equal? foo 3))) 150 | 151 | (test-case 152 | "Test simple foldts-test-suite" 153 | (check-equal? 154 | '(S (C C C)) 155 | (foldts-test-suite 156 | (lambda (suite name before after seed) 157 | seed) 158 | (lambda (suite name before after seed kid-seed) 159 | (list 'S kid-seed)) 160 | (lambda (case name action seed) 161 | (cons 'C seed)) 162 | (list) 163 | successful-suite))) 164 | 165 | (test-case 166 | "Test fold-test-results" 167 | (andmap 168 | (lambda (result) 169 | (check-pred test-success? result)) 170 | (fold-test-results 171 | (lambda (result seed) 172 | (cons result null)) 173 | null 174 | successful-suite 175 | #:fdown (lambda (name seed) (check-equal? name "Example A") seed)))) 176 | 177 | (test-case 178 | "Test run-test" 179 | (let ((result (run-test successful-suite))) 180 | (check = (length result) 3) 181 | (check-true (test-success? (car result))) 182 | (check-true (test-success? (cadr result))) 183 | (check-true (test-success? (caddr result))))) 184 | 185 | (test-case 186 | "Shortcuts work as expected" 187 | 188 | (delay-test 189 | (check-test-results (test-check "dummy" = 1 1) 1 0 0) 190 | (check-test-results (test-check "dummy" string=? "foo" "bar") 0 1 0) 191 | (check-test-results (test-check "dummy" string=? 'a 'b) 0 0 1) 192 | 193 | (check-test-results (test-pred "dummy" number? 1) 1 0 0) 194 | (check-test-results (test-pred "dummy" number? #t) 0 1 0) 195 | (check-test-results (test-pred "dummy" number? (error 'a)) 0 0 1) 196 | (check-test-results (test-equal? "dummy" 1 1) 1 0 0) 197 | (check-test-results (test-equal? "dummy" 1 2) 0 1 0) 198 | (check-test-results (test-equal? "dummy" (error 'a) 2) 0 0 1) 199 | 200 | (check-test-results (test-eq? "dummy" 'a 'a) 1 0 0) 201 | (check-test-results (test-eq? "dummy" 'a 'b) 0 1 0) 202 | (check-test-results (test-eq? "dummy" (error 'a) 'a) 0 0 1) 203 | 204 | (check-test-results (test-eqv? "dummy" 'a 'a) 1 0 0) 205 | (check-test-results (test-eqv? "dummy" 'a 'b) 0 1 0) 206 | (check-test-results (test-eqv? "dummy" (error 'a) 'a) 0 0 1) 207 | 208 | (check-test-results (test-= "dummy" 1.0 1.0 0.001) 1 0 0) 209 | (check-test-results (test-= "dummy" '1.0 1.0 0.0) 0 1 0) 210 | (check-test-results (test-= "dummy" (error 'a) 'a 0.01) 0 0 1) 211 | 212 | (check-test-results (test-true "dummy" #t) 1 0 0) 213 | (check-test-results (test-true "dummy" #f) 0 1 0) 214 | (check-test-results (test-true "dummy" (error 'a)) 0 0 1) 215 | 216 | (check-test-results (test-false "dummy" #f) 1 0 0) 217 | (check-test-results (test-false "dummy" #t) 0 1 0) 218 | (check-test-results (test-false "dummy" (error 'a)) 0 0 1) 219 | 220 | (check-test-results (test-not-false "dummy" 1) 1 0 0) 221 | (check-test-results (test-not-false "dummy" #f) 0 1 0) 222 | (check-test-results (test-not-false "dummy" (error 'a)) 0 0 1) 223 | 224 | (check-test-results 225 | (test-exn "dummy" exn? (lambda () (error 'a))) 1 0 0) 226 | (check-test-results 227 | (test-exn "dummy" exn? (lambda () 1)) 0 1 0) 228 | (check-test-results 229 | (test-exn "dummy" (lambda (exn) (error 'a)) (lambda () (error 'a))) 0 0 1) 230 | 231 | (check-test-results 232 | (test-not-exn "dummy" (lambda () 2)) 1 0 0) 233 | (check-test-results 234 | (test-not-exn "dummy" (lambda () (error 'a))) 0 1 0))) 235 | 236 | (test-case 237 | "test-case captures location" 238 | (let ([failure 239 | (car 240 | (run-test 241 | (delay-test (test-case "dummy" (check-equal? 1 2)))))]) 242 | (check-pred test-failure? failure) 243 | (let* ([stack (exn:test:check-stack 244 | (test-failure-result failure))] 245 | [loc (location-info-value 246 | (check-info-value 247 | (car (filter check-location? stack))))]) 248 | (check-regexp-match #rx"test-test\\.rkt" (location->string loc))))) 249 | 250 | (test-case 251 | "Shortcuts capture location" 252 | (let ((failure 253 | (car 254 | (run-test 255 | (delay-test (test-equal? "dummy" 1 2)))))) 256 | (check-pred test-failure? failure) 257 | (let* ((stack (exn:test:check-stack 258 | (test-failure-result failure))) 259 | (loc (location-info-value 260 | (check-info-value 261 | (car (filter check-location? stack)))))) 262 | (check-regexp-match #rx"test-test\\.rkt" (location->string loc))))) 263 | 264 | (test-case 265 | "All names that should be exported are exported" 266 | check-info? 267 | check-info-name 268 | check-info-value) 269 | 270 | (test-case 271 | "make-test-case constructs a test case" 272 | (check-pred 273 | test-success? 274 | (car 275 | (run-test 276 | (make-test-case "dummy" (lambda () (check-true #t))))))) 277 | )) 278 | -------------------------------------------------------------------------------- /rackunit-test/tests/rackunit/text-ui-test.rkt: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; Time-stamp: <2010-03-29 13:56:54 noel> 3 | ;;; 4 | ;;; Copyright (C) 2005 by Noel Welsh. 5 | ;;; 6 | 7 | ;;; This library is free software; you can redistribute it 8 | ;;; and/or modify it under the terms of the GNU Lesser 9 | ;;; General Public License as published by the Free Software 10 | ;;; Foundation; either version 2.1 of the License, or (at 11 | ;;; your option) any later version. 12 | 13 | ;;; This library is distributed in the hope that it will be 14 | ;;; useful, but WITHOUT ANY WARRANTY; without even the 15 | ;;; implied warranty of MERCHANTABILITY or FITNESS FOR A 16 | ;;; PARTICULAR PURPOSE. See the GNU Lesser General Public 17 | ;;; License for more details. 18 | 19 | ;;; You should have received a copy of the GNU Lesser 20 | ;;; General Public License along with this library; if not, 21 | ;;; write to the Free Software Foundation, Inc., 59 Temple 22 | ;;; Place, Suite 330, Boston, MA 02111-1307 USA 23 | 24 | ;;; Author: Noel Welsh 25 | ;; 26 | ;; 27 | ;; Commentary: 28 | 29 | #lang racket/base 30 | 31 | (require racket/list 32 | racket/pretty 33 | racket/port 34 | racket/runtime-path 35 | racket/string 36 | rackunit 37 | rackunit/text-ui) 38 | 39 | (provide text-ui-tests) 40 | 41 | (define-syntax-rule (with-all-output-to-string e ...) 42 | (with-all-output-to-string* (lambda () e ...))) 43 | 44 | (define (with-all-output-to-string* thnk) 45 | (with-output-to-string 46 | (lambda () 47 | (port-count-lines! (current-output-port)) ;; needed by pretty-info 48 | (parameterize ([current-error-port (current-output-port)]) 49 | (thnk))))) 50 | 51 | (define-runtime-path here ".") 52 | 53 | ;; with-silent-output (() -> any) -> any 54 | (define (with-silent-output thunk) 55 | (parameterize ([current-output-port (open-output-nowhere)] 56 | [current-error-port (open-output-nowhere)]) 57 | (thunk))) 58 | 59 | (define (failing-test) 60 | (run-tests 61 | (test-suite 62 | "Dummy" 63 | (test-case "Dummy" (check-equal? 1 2))))) 64 | 65 | (define (failing-binary-test/complex-params) 66 | (run-tests 67 | (test-suite 68 | "Dummy" 69 | (test-case "Dummy" 70 | (check-equal? 71 | (list (range 15) (range 15) (range 15)) 72 | 1))))) 73 | 74 | (define (failing-test/complex-params) 75 | (run-tests 76 | (test-suite 77 | "Dummy" 78 | (test-case "Dummy" 79 | (check-false 80 | (list (range 15) (range 15) (range 15))))))) 81 | 82 | (define (failing-test/issue-91) 83 | (run-tests 84 | (test-suite 85 | "Dummy" 86 | (test-case "Dummy" 87 | (check-equal? 88 | (make-list 10 'xfdjkalf) 89 | (make-list 11 'xfdjkalf)))))) 90 | 91 | (define (quiet-failing-test) 92 | (run-tests 93 | (test-suite 94 | "Dummy" 95 | (test-case "Dummy" (check-equal? 1 2))) 96 | 'quiet)) 97 | 98 | (define (quiet-error-test) 99 | (run-tests 100 | (test-suite 101 | "Dummy" 102 | (test-case "Dummy" (error "kabloom!"))) 103 | 'quiet)) 104 | 105 | (define text-ui-tests 106 | (test-suite 107 | "All tests for text-ui" 108 | 109 | (test-case 110 | "Binary check displays actual and expected in failure error message" 111 | (let ((op (with-all-output-to-string (failing-test)))) 112 | (check string-contains? 113 | op 114 | "expected") 115 | (check string-contains? 116 | op 117 | "actual"))) 118 | 119 | (test-case 120 | "Binary check doesn't display params" 121 | (let ((op (with-all-output-to-string (failing-test)))) 122 | (check (lambda (out str) (not (string-contains? out str))) 123 | op 124 | "params"))) 125 | 126 | (test-case 127 | "Binary check output is pretty printed" 128 | (let ([op (parameterize ([pretty-print-columns 80]) 129 | (with-all-output-to-string (failing-binary-test/complex-params)))]) 130 | (check string-contains? 131 | op 132 | " '((0 1 2 3 4 5 6 7 8 9 10 11 12 13 14) 133 | (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14) 134 | (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14))"))) 135 | 136 | (test-case 137 | "Non-binary check output is pretty printed" 138 | (let ([op (parameterize ([pretty-print-columns 80]) 139 | (with-all-output-to-string (failing-test/complex-params)))]) 140 | (check string-contains? 141 | op 142 | " '(((0 1 2 3 4 5 6 7 8 9 10 11 12 13 14) 143 | (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14) 144 | (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14)))"))) 145 | 146 | (test-case 147 | "Pretty printing test from github issue #91" 148 | (let ([op (parameterize ([pretty-print-columns 80]) 149 | (with-all-output-to-string (failing-test/issue-91)))]) 150 | (check string-contains? 151 | op 152 | " 153 | actual: 154 | '(xfdjkalf 155 | xfdjkalf 156 | xfdjkalf 157 | xfdjkalf 158 | xfdjkalf 159 | xfdjkalf 160 | xfdjkalf 161 | xfdjkalf 162 | xfdjkalf 163 | xfdjkalf) 164 | expected: 165 | '(xfdjkalf 166 | xfdjkalf 167 | xfdjkalf 168 | xfdjkalf 169 | xfdjkalf 170 | xfdjkalf 171 | xfdjkalf 172 | xfdjkalf 173 | xfdjkalf 174 | xfdjkalf 175 | xfdjkalf)"))) 176 | 177 | (test-case 178 | "Location trimmed when file is under current directory" 179 | (parameterize ((current-directory here)) 180 | (let ((op (with-all-output-to-string (failing-test)))) 181 | (check string-contains? 182 | op 183 | "location: text-ui-test.rkt")))) 184 | 185 | (test-case 186 | "Name and location displayed before actual/expected" 187 | (let ((op (with-all-output-to-string (failing-test)))) 188 | (check-regexp-match "name:.+location:.+actual:.+expected:.+" op))) 189 | 190 | (test-case 191 | "Quiet mode is quiet" 192 | (let ((op1 (with-all-output-to-string (quiet-failing-test))) 193 | (op2 (with-all-output-to-string (quiet-error-test)))) 194 | (check string=? op1 "") 195 | (check string=? op2 ""))) 196 | 197 | (test-case 198 | "Number of unsuccessful tests returned" 199 | (check-equal? (with-silent-output failing-test) 1) 200 | (check-equal? (with-silent-output quiet-failing-test) 1) 201 | (check-equal? (with-silent-output quiet-error-test) 1) 202 | (check-equal? (with-silent-output 203 | (lambda () 204 | (run-tests 205 | (test-suite 206 | "Dummy" 207 | (test-case "Dummy" (check-equal? 1 1))) 208 | 'quiet))) 209 | 0)) 210 | 211 | (test-case 212 | "run-tests runs suite before/after actions in quiet mode" 213 | (with-silent-output 214 | (λ () 215 | (let ([foo 1]) 216 | (run-tests 217 | (test-suite 218 | "Foo" 219 | #:before (lambda () (set! foo 2)) 220 | #:after (lambda () (set! foo 3)) 221 | (test-case 222 | "Foo check" 223 | (check = foo 2))) 224 | 'quiet) 225 | (check = foo 3))))) 226 | 227 | (test-case 228 | "run-tests runs suite before/after actions in normal mode" 229 | (with-silent-output 230 | (λ () 231 | (let ([foo 1]) 232 | (run-tests 233 | (test-suite 234 | "Foo" 235 | #:before (lambda () (set! foo 2)) 236 | #:after (lambda () (set! foo 3)) 237 | (test-case 238 | "Foo check" 239 | (check = foo 2))) 240 | 'normal) 241 | (check = foo 3))))) 242 | 243 | (test-case 244 | "run-tests runs suite before/after actions in verbose mode" 245 | (with-silent-output 246 | (λ () 247 | (let ([foo 1]) 248 | (run-tests 249 | (test-suite 250 | "Foo" 251 | #:before (lambda () (set! foo 2)) 252 | #:after (lambda () (set! foo 3)) 253 | (test-case 254 | "Foo check" 255 | (check = foo 2))) 256 | 'verbose) 257 | (check = foo 3))))) 258 | 259 | (test-case 260 | "cannot kill current thread in test case" 261 | (check-equal? (call-in-nested-thread 262 | (lambda () 263 | (with-silent-output 264 | (lambda () 265 | (run-tests 266 | (test-suite "tests" 267 | (test-case "kill-thread" 268 | (kill-thread (current-thread))))))))) 269 | ;; If the kill-thread were successful, call-in-nested-thread 270 | ;; would raise error. We expect kill-thread to raise error, 271 | ;; caught by run-tests. 272 | 1)) 273 | )) 274 | -------------------------------------------------------------------------------- /rackunit-test/tests/rackunit/tl.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require rackunit) 3 | 4 | ;; test to make sure that the various check functions 5 | ;; return what they are promised to at the top-level 6 | 7 | ;; make drdr notice when a check prints something. 8 | (current-output-port (current-error-port)) 9 | 10 | (check-equal? (check + 1 2) (void)) 11 | 12 | (check-equal? (check-eq? 1 1) (void)) 13 | (check-equal? (check-not-eq? #f #t) (void)) 14 | (check-equal? (check-eqv? (expt 2 100) (expt 2 100)) (void)) 15 | (check-equal? (check-not-eqv? (expt 2 100) 1) (void)) 16 | (check-equal? (check-equal? (list 1 2) (list 1 2)) (void)) 17 | (check-equal? (check-not-equal? (list 1 2) (list 2 1)) (void)) 18 | 19 | (check-equal? (check-pred not #f) (void)) 20 | (check-equal? (check-= 1.1 1.2 0.5) (void)) 21 | (check-equal? (check-true #t) (void)) 22 | (check-equal? (check-false #f) (void)) 23 | (check-equal? (check-not-false 3) (void)) 24 | 25 | (check-equal? (check-exn #rx"car" (λ () (car 1))) (void)) 26 | (check-equal? (check-not-exn (λ () 1)) (void)) 27 | 28 | (check-equal? (check-regexp-match #rx"a*b" "aaaaaaab") (void)) 29 | -------------------------------------------------------------------------------- /rackunit-test/tests/rackunit/typed-test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (module typed-success1 typed/racket/base 4 | (require typed/rackunit) 5 | (check-eq? 10 10)) 6 | 7 | (module typed-success2 typed/racket/base 8 | check-eq? 9 | (check-eq? 10 10) 10 | (require typed/rackunit)) 11 | 12 | 13 | (module typed-fail1 typed/racket/base 14 | (require typed/rackunit) 15 | (require (for-syntax syntax/parse syntax/srcloc racket/base)) 16 | (require syntax/location) 17 | 18 | (define-syntax (def-test stx) 19 | (syntax-parse stx 20 | [(_ test-name loc-id expr) 21 | (define-values (_ fn __) (split-path (source-location-source stx))) 22 | (define loc-str (format "~a:~a:~a" 23 | fn 24 | (source-location-line #'expr) 25 | (source-location-column #'expr))) 26 | #`(begin 27 | (define loc-id #,loc-str) 28 | (provide loc-id test-name) 29 | (define test-name (test-suite "test" 30 | (test-case "test1" 31 | expr))))])) 32 | (def-test 33 | test1 34 | test1-report-loc 35 | (check-eq? 10 20))) 36 | 37 | (module typed-check-regexp-match typed/racket/base 38 | (require typed/rackunit 39 | racket/port) 40 | (check-regexp-match #rx"a+bba" "aaaaaabba") 41 | (check-regexp-match #rx#"a+bba" "aaaaaabba") 42 | (check-regexp-match "a+bba" "aaaaaabba") 43 | (check-regexp-match #"a+bba" "aaaaaabba") 44 | (check-regexp-match "a+bba" #"aaaaaabba") 45 | (check-regexp-match "a+bba" (string->path "aaaaaabba")) 46 | (call-with-input-string "aaaaaabba" 47 | (lambda ([in : Input-Port]) 48 | (check-regexp-match "a+bba" in)))) 49 | 50 | 51 | 52 | (require rackunit racket/port rackunit/text-ui) 53 | (require 'typed-fail1) 54 | 55 | (define report 56 | (call-with-output-string 57 | (lambda (p) 58 | (parameterize ([current-error-port p] 59 | [current-output-port p]) 60 | (run-tests test1))))) 61 | 62 | (module+ test 63 | (require (submod ".." typed-success1)) 64 | (require (submod ".." typed-success2)) 65 | (require (submod ".." typed-check-regexp-match)) 66 | (check-regexp-match (regexp-quote test1-report-loc) 67 | report)) 68 | -------------------------------------------------------------------------------- /rackunit-test/tests/rackunit/util-test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require rackunit 4 | rackunit/private/util) 5 | 6 | (provide util-tests) 7 | 8 | ;; FIXME: Two problems 9 | ;; 1 - This is not the way to test require/expose: if this fails, it 10 | ;; prevents the tests from loading. 11 | ;; 2 - For whatever reason, it *does* fail when loaded via PLaneT. 12 | ;; Still waiting for resolution on a bug report. 13 | (require/expose "check-test.rkt" (make-failure-test)) 14 | 15 | (define util-tests 16 | (test-suite 17 | "Util tests" 18 | (test-case 19 | "make-failure-test required from check-test.rkt" 20 | (begin 21 | (check-true (procedure? make-failure-test)) 22 | (check-equal? (make-arity-at-least 2) 23 | (procedure-arity make-failure-test)) 24 | (check-pred rackunit-test-case? 25 | (delay-test (make-failure-test "foo" string?))))) 26 | 27 | (test-case 28 | "Test test-suite*" 29 | (let ((result 30 | (run-test 31 | (test-suite* 32 | "Test test-suite*" 33 | ("Test 1" (check = 1 1)) 34 | ("Test 2" (check = 1 1) (check = 2 4)))))) 35 | (check = (length result) 2) 36 | (check-true (test-success? (car result))) 37 | (check-true (test-failure? (cadr result))))) 38 | 39 | (test-case 40 | "Simple check-regexp test" 41 | (check-regexp-match "a*bba" 42 | "aaaaaabba")) 43 | 44 | (test-case 45 | "check-regexp-match failure" 46 | (check-exn 47 | exn:test:check? 48 | (lambda () 49 | (check-regexp-match "a+bba" "aaaabbba")))) 50 | )) 51 | -------------------------------------------------------------------------------- /rackunit-typed/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection "typed") 4 | 5 | (define test-responsibles '((all jay))) 6 | 7 | (define deps 8 | '("racket-index" 9 | "rackunit-gui" 10 | "rackunit-lib" 11 | "typed-racket-lib" 12 | "base" 13 | "testing-util-lib")) 14 | 15 | (define pkg-desc "Typed Racket types for RackUnit") 16 | 17 | (define pkg-authors '(samth stamourv)) 18 | 19 | (define version "1.0") 20 | 21 | (define license 22 | '(Apache-2.0 OR MIT)) 23 | -------------------------------------------------------------------------------- /rackunit-typed/rackunit.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require typed/rackunit/main) 3 | (provide (all-from-out typed/rackunit/main)) 4 | -------------------------------------------------------------------------------- /rackunit-typed/rackunit/docs-complete.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket/base 2 | 3 | (require/typed/provide 4 | rackunit/docs-complete 5 | [check-docs (Symbol 6 | [#:skip (U Regexp 7 | Symbol 8 | (Listof (U Regexp Symbol)) 9 | (Symbol -> Any) 10 | #f)] 11 | -> Any)]) 12 | -------------------------------------------------------------------------------- /rackunit-typed/rackunit/gui.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket 2 | (require typed/rackunit 3 | typed/private/utils) 4 | 5 | (require/typed/provide 6 | rackunit/gui 7 | [test/gui 8 | (Test * -> Any)] 9 | [make-gui-runner 10 | (-> (Test * -> Any))]) 11 | 12 | ;; this library transitively imports the gui framework and fails in Travis due 13 | ;; to gui-related configuration not being set, so we don't run it in tests 14 | (module test racket/base) 15 | -------------------------------------------------------------------------------- /rackunit-typed/rackunit/text-ui.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket 2 | (require typed/rackunit 3 | typed/private/utils) 4 | 5 | (define-type Verbosity 6 | (U 'quiet 'normal 'verbose)) 7 | 8 | (require/typed/provide 9 | rackunit/text-ui 10 | [run-tests 11 | (case-lambda 12 | (Test -> Natural) 13 | (Test Verbosity -> Natural))]) 14 | (provide Verbosity) 15 | -------------------------------------------------------------------------------- /rackunit-typed/rackunit/type-env-ext.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (prefix-in ru: rackunit) 4 | (for-syntax 5 | racket/base syntax/parse 6 | typed-racket/utils/tc-utils 7 | typed-racket/env/init-envs 8 | typed-racket/rep/prop-rep 9 | typed-racket/rep/object-rep 10 | typed-racket/rep/type-rep 11 | typed-racket/types/abbrev)) 12 | 13 | (define-for-syntax unit-env 14 | (make-env 15 | [ru:current-test-case-around 16 | (-poly (a) (-> (-> a) a))])) 17 | 18 | (begin-for-syntax (initialize-type-env unit-env)) 19 | -------------------------------------------------------------------------------- /rackunit/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection 'multi) 4 | 5 | (define deps '("rackunit-lib" 6 | "rackunit-doc" 7 | "rackunit-gui" 8 | "rackunit-plugin-lib")) 9 | (define implies '("rackunit-lib" 10 | "rackunit-doc" 11 | "rackunit-gui" 12 | "rackunit-plugin-lib")) 13 | 14 | (define pkg-desc "RackUnit testing framework") 15 | 16 | (define pkg-authors '(ryanc noel)) 17 | 18 | (define license 19 | '(Apache-2.0 OR MIT)) 20 | -------------------------------------------------------------------------------- /schemeunit/gui.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require rackunit/gui) 3 | (provide (all-from-out rackunit/gui)) 4 | -------------------------------------------------------------------------------- /schemeunit/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection "schemeunit") 4 | (define deps '("base" 5 | "rackunit-lib" 6 | "rackunit-gui")) 7 | 8 | (define pkg-desc "Legacy SchemeUnit testing framework") 9 | 10 | (define pkg-authors '(jay)) 11 | 12 | (define license 13 | '(Apache-2.0 OR MIT)) 14 | -------------------------------------------------------------------------------- /schemeunit/main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require rackunit) 3 | (provide (all-from-out rackunit)) 4 | -------------------------------------------------------------------------------- /schemeunit/text-ui.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require rackunit/text-ui) 3 | (provide (all-from-out rackunit/text-ui)) 4 | -------------------------------------------------------------------------------- /testing-util-lib/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | (define collection 'multi) 3 | 4 | (define deps '("base" 5 | ["compiler-lib" #:version "1.14"])) 6 | 7 | (define pkg-desc "Utilities for interoperating between testing frameworks") 8 | 9 | (define version "1.2") 10 | 11 | (define pkg-authors '(florence)) 12 | 13 | (define license 14 | '(Apache-2.0 OR MIT)) 15 | -------------------------------------------------------------------------------- /testing-util-lib/rackunit/log.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide (all-defined-out)) 4 | (require (prefix-in rt: raco/testing)) 5 | 6 | ;; we don't immediately export the imported ids so that Scribble doesn't treat 7 | ;; them as re-exports. 8 | 9 | (define test-log-enabled? rt:test-log-enabled?) 10 | (define test-log! rt:test-log!) 11 | (define test-log rt:test-report) 12 | (define current-test-invocation-directory rt:current-test-invocation-directory) 13 | --------------------------------------------------------------------------------