diff --git a/collects/rackunit/private/check-info.rkt b/collects/rackunit/private/check-info.rkt index 127c2cb..de601b6 100644 --- a/collects/rackunit/private/check-info.rkt +++ b/collects/rackunit/private/check-info.rkt @@ -24,7 +24,11 @@ ;; (continuation-mark-set -> (listof check-info)) (define (check-info-stack marks) - (apply append (continuation-mark-set->list marks check-info-mark))) + (let ([ht (make-hash)]) + (for ([x (in-list (apply append (continuation-mark-set->list marks check-info-mark)))] + [i (in-naturals)]) + (hash-set! ht (check-info-name x) (cons i x))) + (map cdr (sort (hash-map ht (λ (k v) v)) < #:key car)))) ;; with-check-info* : (list-of check-info) thunk -> any (define (with-check-info* info thunk) diff --git a/collects/rackunit/private/check.rkt b/collects/rackunit/private/check.rkt index c67285d..3a059a4 100644 --- a/collects/rackunit/private/check.rkt +++ b/collects/rackunit/private/check.rkt @@ -2,7 +2,6 @@ (require (for-syntax racket/base "location.rkt") - srfi/1 "base.rkt" "check-info.rkt" "format.rkt" @@ -34,39 +33,50 @@ check-not-equal? fail) + +(define USE-ERROR-HANDLER? #f) + +;; default-check-handler : exn -> any +(define (default-check-handler e) + (let ([out (open-output-string)]) + ;;(display "check failed\n" out) + (parameterize ((current-output-port out)) + (display-delimiter) + (cond [(exn:test:check? e) + (display-failure) + (newline) + (display-check-info-stack + (exn:test:check-stack e))] + [(exn? e) + (display-error) + (newline) + (display-exn e)]) + (display-delimiter)) + (cond [USE-ERROR-HANDLER? + ((error-display-handler) (get-output-string out) + ;; So that DrRacket won't recognize exn:fail:syntax, etc + (make-exn (exn-message exn) (exn-continuation-marks exn)))] + [else + (display (get-output-string out) (current-error-port))]))) + ;; parameter current-check-handler : (-> exn any) (define current-check-handler (make-parameter - (lambda (e) - (cond - [(exn:test:check? e) - (display-delimiter) - (display-failure)(newline) - (display-check-info-stack - (exn:test:check-stack e)) - (display-delimiter)] - [(exn? e) - (display-delimiter) - (display-error)(newline) - (display-exn e) - (display-delimiter)])) + default-check-handler (lambda (v) (if (procedure? v) v (raise-type-error 'current-check-handler "procedure" v))))) ;; check-around : ( -> a) -> a -(define check-around - (lambda (thunk) - (with-handlers - ([exn? (current-check-handler)]) - (thunk)))) +(define (check-around thunk) + (with-handlers ([exn? (current-check-handler)]) + (thunk))) ;; top-level-check-around : ( -> a) -> a -(define top-level-check-around - (lambda (thunk) - (check-around thunk) - (void))) +(define (top-level-check-around thunk) + (check-around thunk) + (void)) ;; parameter current-check-around : (( -> a) -> a) (define current-check-around @@ -161,7 +171,15 @@ (name (identifier? #'name) (syntax/loc stx - check-secret-name))))) + (case-lambda + [(formal ...) + (check-secret-name formal ... + #:location (quote loc) + #:expression (quote (name actual ...)))] + [(formal ... msg) + (check-secret-name formal ... msg + #:location (quote loc) + #:expression (quote (name actual ...)))])))))) )))))) (define-syntax define-simple-check @@ -195,32 +213,35 @@ #t (fail-check)))))])) -(define-check (check-exn pred thunk) - (let/ec succeed - (with-handlers - (;; catch the exception we are looking for and - ;; succeed - [pred - (lambda (exn) (succeed #t))] - ;; rethrow check failures if we aren't looking - ;; for them - [exn:test:check? - (lambda (exn) - (refail-check exn))] - ;; catch any other exception and raise an check - ;; failure - [exn:fail? - (lambda (exn) - (with-check-info* - (list - (make-check-message "Wrong exception raised") - (make-check-info 'exn-message (exn-message exn)) - (make-check-info 'exn exn)) - (lambda () (fail-check))))]) - (thunk)) - (with-check-info* - (list (make-check-message "No exception raised")) - (lambda () (fail-check))))) +(define-check (check-exn raw-pred thunk) + (let ([pred (if (regexp? raw-pred) + (λ (x) (and (exn:fail? x) (regexp-match raw-pred (exn-message x)))) + raw-pred)]) + (let/ec succeed + (with-handlers + (;; catch the exception we are looking for and + ;; succeed + [pred + (lambda (exn) (succeed #t))] + ;; rethrow check failures if we aren't looking + ;; for them + [exn:test:check? + (lambda (exn) + (refail-check exn))] + ;; catch any other exception and raise an check + ;; failure + [exn:fail? + (lambda (exn) + (with-check-info* + (list + (make-check-message "Wrong exception raised") + (make-check-info 'exn-message (exn-message exn)) + (make-check-info 'exn exn)) + (lambda () (fail-check))))]) + (thunk)) + (with-check-info* + (list (make-check-message "No exception raised")) + (lambda () (fail-check)))))) (define-check (check-not-exn thunk) (with-handlers diff --git a/collects/rackunit/private/gui/gui.rkt b/collects/rackunit/private/gui/gui.rkt index 61050b2..2904ac8 100644 --- a/collects/rackunit/private/gui/gui.rkt +++ b/collects/rackunit/private/gui/gui.rkt @@ -1,7 +1,7 @@ #lang racket/base (require racket/class unstable/class-iop - racket/gui + racket/gui/base "../base.rkt" "../result.rkt" "../check-info.rkt" diff --git a/collects/rackunit/private/gui/model.rkt b/collects/rackunit/private/gui/model.rkt index 110efad..74e25cc 100644 --- a/collects/rackunit/private/gui/model.rkt +++ b/collects/rackunit/private/gui/model.rkt @@ -2,7 +2,7 @@ (require racket/class unstable/class-iop racket/list - "gvector.rkt" + data/gvector "../base.rkt" "interfaces.rkt" "cache-box.rkt") diff --git a/collects/rackunit/private/gui/model2rml.rkt b/collects/rackunit/private/gui/model2rml.rkt index fb10840..f874cf3 100644 --- a/collects/rackunit/private/gui/model2rml.rkt +++ b/collects/rackunit/private/gui/model2rml.rkt @@ -2,9 +2,10 @@ (require racket/class unstable/class-iop racket/list - racket/gui + racket/gui/base racket/match racket/file + racket/path mrlib/include-bitmap (prefix-in drlink: "drracket-ui.rkt") "interfaces.rkt" diff --git a/collects/rackunit/private/gui/rml.rkt b/collects/rackunit/private/gui/rml.rkt index 596f028..eea40bf 100644 --- a/collects/rackunit/private/gui/rml.rkt +++ b/collects/rackunit/private/gui/rml.rkt @@ -1,7 +1,7 @@ #lang racket/base (require racket/class unstable/class-iop - racket/gui + racket/gui/base framework "interfaces.rkt") diff --git a/collects/rackunit/private/gui/view.rkt b/collects/rackunit/private/gui/view.rkt index 0372b99..4de4a14 100644 --- a/collects/rackunit/private/gui/view.rkt +++ b/collects/rackunit/private/gui/view.rkt @@ -3,7 +3,7 @@ unstable/class-iop unstable/gui/notify racket/list - racket/gui + racket/gui/base framework mrlib/hierlist "interfaces.rkt" @@ -71,8 +71,16 @@ still be there, just not visible? (view this) (controller controller))) - ;; for update management - (define update-queue (make-hasheq)) + ;; Update management + ;; Do adds in order, then updates in any order (hash). + + ;; add-queue : (listof (-> void)) + (define add-queue null) + + ;; update-queue : (imm-hashof model<%> #t) + (define update-queue '#hasheq()) + + ;; update-lock : semaphore (define update-lock (make-semaphore 1)) (send editor lock #t) @@ -83,12 +91,6 @@ still be there, just not visible? ;; View Links - (define/public (create-view-link model parent) - (parameterize ((current-eventspace eventspace)) - (queue-callback - (lambda () - (send tree-view create-view-link model parent))))) - (define/private (get-view-link model) (send tree-view get-view-link model)) @@ -108,10 +110,18 @@ still be there, just not visible? ;; Update Management + ;; create-view-link : model suite-result<%>/#f -> void + (define/public (create-view-link model parent) + (let ([proc (lambda () (send tree-view create-view-link model parent))]) + (semaphore-wait update-lock) + (set! add-queue (cons proc add-queue)) + (semaphore-post update-lock) + (process-updates))) + ;; queue-for-update : model -> void (define/public (queue-for-update model) (semaphore-wait update-lock) - (hash-set! update-queue model #t) + (set! update-queue (hash-set update-queue model #t)) (semaphore-post update-lock) (process-updates)) @@ -120,38 +130,33 @@ still be there, just not visible? (parameterize ((current-eventspace eventspace)) (queue-callback (lambda () - (let ([models-to-update (grab+clear-update-queue)]) - (for ([model models-to-update]) + (let-values ([(adds updates) (grab+clear-update-queue)]) + (for ([add (in-list adds)]) + (add)) + (for ([model (in-hash-keys updates)]) (do-model-update model))))))) - ;; grab+clear-update-queue : -> void + ;; grab+clear-update-queue : -> (values list hash) ;; ** Must be called from eventspace thread. (define/private (grab+clear-update-queue) (semaphore-wait update-lock) - (if (positive? (hash-count update-queue)) - (let ([old-queue update-queue]) - (set! update-queue (make-hasheq)) - (semaphore-post update-lock) - (reverse - (hash-map old-queue (lambda (k v) k)))) - (begin (semaphore-post update-lock) - null))) + (begin0 + (values (reverse add-queue) + update-queue) + (set! add-queue null) + (set! update-queue '#hasheq()) + (semaphore-post update-lock))) ;; do-model-update : model<%> -> void ;; ** Must be called from eventspace thread. (define/private (do-model-update model) (let ([view-link (get-view-link model)]) - (cond [view-link - (send tree-view update-item view-link) - (when (eq? model (get-selected-model)) - (show-model model))] - [(not view-link) - ;; If the view-link has not been created, - ;; yield until it is. - (unless (yield) - (error 'rackunit-gui - "internal error: no progress waiting for view-link")) - (do-model-update model)]))) + (unless view-link + ;; should not be possible + (error 'rackunit-gui "internal error: no view-link")) + (send tree-view update-item view-link) + (when (eq? model (get-selected-model)) + (show-model model)))) ;; Update display diff --git a/collects/rackunit/private/test-case.rkt b/collects/rackunit/private/test-case.rkt index ff1f578..36f18b2 100644 --- a/collects/rackunit/private/test-case.rkt +++ b/collects/rackunit/private/test-case.rkt @@ -16,47 +16,52 @@ after around) +(define USE-ERROR-HANDLER? #f) + (define current-test-name (make-parameter #f (lambda (v) (if (string? v) v - (raise-mismatch-error - 'current-test-name - "string?" - v))))) + (raise-type-error 'current-test-name "string" v))))) ;; test-case-around : ( -> a) -> a ;; ;; Run a test-case immediately, printing information on failure -(define test-case-around - (lambda (thunk) - (with-handlers - ([exn:test:check? - (lambda (e) - (display-delimiter) - (display-test-name (current-test-name)) - (display-failure)(newline) - (display-check-info-stack (exn:test:check-stack e)) - (display-delimiter))] - [exn? - (lambda (e) - (display-delimiter) - (display-test-name (current-test-name)) - (display-error)(newline) - (display-exn e) - (display-delimiter))]) - (thunk)))) - +(define (default-test-case-around thunk) + (with-handlers ([exn? default-test-case-handler]) + (thunk))) + +;; default-test-case-handler : exn -> any +(define (default-test-case-handler e) + (let ([out (open-output-string)]) + ;;(display "test case failed\n" out) + (parameterize ((current-output-port out)) + (display-delimiter) + (display-test-name (current-test-name)) + (cond [(exn:test:check? e) + (display-failure)(newline) + (display-check-info-stack (exn:test:check-stack e))] + [(exn? e) + (display-error)(newline) + (display-exn e)]) + (display-delimiter)) + (cond [USE-ERROR-HANDLER? + ((error-display-handler) (get-output-string out) + ;; So that DrRacket won't recognize exn:fail:syntax, etc + (make-exn (exn-message e) (exn-continuation-marks e)))] + [else + (display (get-output-string out) (current-error-port))]))) + (define current-test-case-around (make-parameter - test-case-around + default-test-case-around (lambda (v) (if (procedure? v) v - (raise-type-error 'current-test-case-around "procedure" v))))) - + (raise-type-error 'current-test-case-around "procedure" v))))) + (define-syntax (test-begin stx) (syntax-case stx () [(_ expr ...) @@ -66,6 +71,7 @@ (parameterize ([current-check-handler raise] [current-check-around check-around]) + (void) expr ...))))] [_ (raise-syntax-error @@ -73,7 +79,6 @@ "Correct form is (test-begin expr ...)" stx)])) - (define-syntax test-case (syntax-rules () [(test-case name expr ...) @@ -81,7 +86,6 @@ ([current-test-name name]) (test-begin expr ...))])) - (define-syntax before (syntax-rules () ((_ before-e expr1 expr2 ...) @@ -132,4 +136,3 @@ "Incorrect use of around macro. Correct format is (around before-expr expr1 expr2 ... after-expr)" 'around '(error ...))))) - diff --git a/collects/rackunit/scribblings/api.scrbl b/collects/rackunit/scribblings/api.scrbl index 75dee08..32665de 100644 --- a/collects/rackunit/scribblings/api.scrbl +++ b/collects/rackunit/scribblings/api.scrbl @@ -12,6 +12,3 @@ @include-section["control-flow.scrbl"] @include-section["misc.scrbl"] @include-section["ui.scrbl"] -@include-section["running-tests.scrbl"] - - diff --git a/collects/rackunit/scribblings/check.scrbl b/collects/rackunit/scribblings/check.scrbl index 869bfc2..18895d8 100644 --- a/collects/rackunit/scribblings/check.scrbl +++ b/collects/rackunit/scribblings/check.scrbl @@ -5,7 +5,7 @@ Checks are the basic building block of RackUnit. A check checks some condition. If the condition holds the check -evaluates to @racket[#t]. If the condition doesn't hold the +evaluates to @racket[(void)]. If the condition doesn't hold the check raises an instance of @racket[exn:test:check] with information detailing the failure. @@ -19,75 +19,74 @@ source locations if you do so. The following are the basic checks RackUnit provides. You can create your own checks using @racket[define-check]. -@defproc[(check (op (-> any any any)) - (v1 any) - (v2 any) - (message string? "")) - any]{ +@defproc*[([(check-eq? (v1 any) (v2 any) (message string? "")) void?] + [(check-not-eq? (v1 any) (v2 any) (message string? "")) void?] + [(check-eqv? (v1 any) (v2 any) (message string? "")) void?] + [(check-not-eqv? (v1 any) (v2 any) (message string? "")) void?] + [(check-equal? (v1 any) (v2 any) (message string? "")) void?] + [(check-not-equal? (v1 any) (v2 any) (message string? "")) void?])]{ -The simplest check. Succeeds if @racket[op] applied to @racket[v1] and @racket[v2] is not @racket[#f], otherwise raises an exception of type @racket[exn:test:check]. The optional @racket[message] is included in the output if the check fails. If the check succeeds, the value returned by @racket[op] is the value returned by the check.} - -For example, the following check succeeds: - -@racketblock[ - (check < 2 3) -] - -@defproc*[([(check-eq? (v1 any) (v2 any) (message string? "")) #t] - [(check-not-eq? (v1 any) (v2 any) (message string? "")) #t] - [(check-eqv? (v1 any) (v2 any) (message string? "")) #t] - [(check-not-eqv? (v1 any) (v2 any) (message string? "")) #t] - [(check-equal? (v1 any) (v2 any) (message string? "")) #t] - [(check-not-equal? (v1 any) (v2 any) (message string? "")) #t])]{ - -Checks that @racket[v1] is (not) @racket[eq?], -@racket[eqv?], or @racket[equal?] to @racket[v2]. The -optional @racket[message] is included in the output if the -check fails.} +Checks that @racket[v1] is equal (or not equal) to @racket[v2], using +@racket[eq?], @racket[eqv?], or @racket[equal?], respectively. The +optional @racket[message] is included in the output if the check +fails. For example, the following checks all fail: @racketblock[ (check-eq? (list 1) (list 1) "allocated data not eq?") - (check-not-eq? 1 1 "integers are eq?") + (check-not-eq? 1 1 "fixnums are eq?") (check-eqv? 1 1.0 "not eqv?") (check-not-eqv? 1 1 "integers are eqv?") (check-equal? 1 1.0 "not equal?") (check-not-equal? (list 1) (list 1) "equal?") ] +} @defproc[(check-pred (pred (-> any any)) (v any) (message string? "")) - #t]{Checks that @racket[pred] returns a value that is not @racket[#f] when applied to @racket[v]. The optional @racket[message] is included in the output if the check fails. The value returned by a successful check is the value returned by @racket[pred].} + void?]{ -Here's an example that passes and an example that fails: +Checks that @racket[pred] returns a value that is not @racket[#f] when +applied to @racket[v]. The optional @racket[message] is included in +the output if the check fails. The value returned by a successful +check is the value returned by @racket[pred]. +For example, the following check passes: @racketblock[ (check-pred string? "I work") +] +The following check fails: +@racketblock[ (check-pred number? "I fail") ] +} - -@defproc[(check-= (v1 any) (v2 any) (epsilon number?) (message string? "")) #t]{ +@defproc[(check-= (v1 any) (v2 any) (epsilon number?) (message string? "")) + void?]{ Checks that @racket[v1] and @racket[v2] are within @racket[epsilon] of one another. The optional @racket[message] is included in the output if the check -fails.} +fails. -Here's an example that passes and an example that fails: +For example, the following check passes: @racketblock[ (check-= 1.0 1.01 0.01 "I work") +] +The following check fails: +@racketblock[ (check-= 1.0 1.01 0.005 "I fail") ] +} -@defproc*[([(check-true (v any) (message string? "")) #t] - [(check-false (v any) (message string? "")) #t] - [(check-not-false (v any) (message string? "")) #t])]{ +@defproc*[([(check-true (v any) (message string? "")) void?] + [(check-false (v any) (message string? "")) void?] + [(check-not-false (v any) (message string? "")) void?])]{ -Checks that @racket[v] is @racket[#t], @racket[#f], or not -@racket[#f] as appropriate. The optional @racket[message] -is included in the output if the check fails.} +Checks that @racket[v] is @racket[#t], is @racket[#f], or is not +@racket[#f], respectively. The optional @racket[message] is included +in the output if the check fails. For example, the following checks all fail: @@ -96,55 +95,112 @@ For example, the following checks all fail: (check-false 1) (check-not-false #f) ] +} +@defproc[(check-exn (exn-predicate (or/c (-> any boolean?) regexp?)) + (thunk (-> any)) (message string? "")) + void?]{ -@defproc[(check-exn (exn-predicate (-> any (or/c #t #f))) (thunk (-> any)) (message string? "")) - #t]{ +Checks that @racket[thunk] raises an exception and that either +@racket[exn-predicate] returns @racket[#t] if it is a function, or +that it matches the message in the exception if @racket[exn-predicate] +is a regexp. In the latter case, the exception raised must be an +@racket[exn:fail?]. The optional @racket[message] is included in the +output if the check fails. A common error is to use an expression +instead of a function of no arguments for @racket[thunk]. Remember +that checks are conceptually functions. -Checks that @racket[thunk] raises an exception for which -@racket[exn-predicate] returns @racket[#t]. The optional -@racket[message] is included in the output if the check -fails. A common error is to use an expression instead of a -function of no arguments for @racket[thunk]. Remember that -checks are conceptually functions.} - -Here are two example, one showing a test that succeeds, and one showing a common error: +For example, the following check succeeds: @racketblock[ - (check-exn exn? + (check-exn exn:fail? (lambda () (raise (make-exn "Hi there" (current-continuation-marks))))) - (code:comment "Forgot to wrap the expression in a thunk. Don't do this!") - (check-exn exn? - (raise (make-exn "Hi there" - (current-continuation-marks)))) ] -@defproc[(check-not-exn (thunk (-> any)) (message string? "")) #t]{ +The following check fails: + +@racketblock[ + (check-exn exn:fail? + (lambda () + (break-thread (current-thread)))) +] + +The following example is a common mistake. The call to @racket[error] +is not within a @racket[lambda], so it bypasses @racket[check-exn] +entirely. + +@racketblock[ + (code:comment "Forgot to wrap the expression in a thunk. Don't do this!") + (check-exn exn:fail? + (error 'hi "there")) +] +} + +@defproc[(check-not-exn (thunk (-> any)) (message string? "")) void?]{ Checks that @racket[thunk] does not raise any exceptions. The optional @racket[message] is included in the output if -the check fails.} +the check fails. +} -@defproc[(fail (message string? "")) #t]{This checks fails unconditionally. Good for creating test stubs that youintend to fill out later. The optional @racket[message] is included in the output if the check fails.} +@defproc[(check-regexp-match (regexp regexp?) + (string string?)) + void?]{ + +Checks that @racket[regexp] matches the @racket[string]. -@defproc[(check-regexp-match (regexp regexp?) (string string?)) #t]{Checks that @racket[regexp] matches the @racket[string].} +For example, the following check succeeds: -The following check will succeed: +@racketblock[ + (check-regexp-match "a+bba" "aaaaaabba") +] -@racketblock[(check-regexp-match "a+bba" "aaaaaabba")] +The following check fails: -This check will fail: - -@racketblock[(check-regexp-match "a+bba" "aaaabbba")] +@racketblock[ + (check-regexp-match "a+bba" "aaaabbba") +] +} +@defproc[(check (op (-> any any any)) + (v1 any) + (v2 any) + (message string? "")) + void?]{ + +The most generic check. Succeeds if @racket[op] applied to +@racket[v1] and @racket[v2] is not @racket[#f], otherwise raises an +exception of type @racket[exn:test:check]. The optional +@racket[message] is included in the output if the check fails. + +For example, the following check succeeds: + +@racketblock[ + (check < 2 3) +] + +The following check fails: + +@racketblock[ + (check memq 'pine '(apple orange pear)) +] +} + +@defproc[(fail (message string? "")) + void?]{ + +This check fails unconditionally. Good for creating test stubs that +you intend to fill out later. The optional @racket[message] is +included in the output. +} @section{Augmenting Information on Check Failure} -When an check fails it stores information including the name +When a check fails it stores information including the name of the check, the location and message (if available), the expression the check is called with, and the parameters to the check. Additional information can be stored by using @@ -154,7 +210,7 @@ the @racket[with-check-info*] function, and the @defstruct[check-info ([name symbol?] [value any])]{ A check-info structure stores information associated -with the context of execution of an check.} +with the context of execution of a check.} The are several predefined functions that create check information structures with predefined names. This avoids @@ -188,8 +244,7 @@ When this check fails the message @verbatim{time: } -will be printed along with the usual information on an -check failure. +is printed along with the usual information on an check failure. @defform[(with-check-info ((name val) ...) body ...)]{ @@ -213,8 +268,7 @@ When this test fails the message @verbatim{current-element: 8} -will be displayed along with the usual information on an -check failure. +is displayed along with the usual information on an check failure. @@ -229,23 +283,21 @@ Firstly, a check should be considered a function, even though most uses are actually macros. In particular, checks always evaluate their arguments exactly once before executing any expressions in the body of the checks. Hence -if you wish to write checks that evalute user defined code +if you wish to write checks that evaluate user defined code that code must be wrapped in a thunk (a function of no arguments) by the user. The predefined @racket[check-exn] is an example of this type of check. -It is also useful to understand how the check information -stack operates. The stack is stored in a parameter and the +It is also useful to understand how the check information stack +operates. The stack is stored in a parameter and the @racket[with-check-info] forms evaluate to calls to -@racket[parameterize]. Hence check information has lexical -scope. For this reason simple checks (see below) cannot -usefully contain calls to @racket[with-check-info] to report +@racket[parameterize]. For this reason simple checks (see below) +cannot usefully contain calls to @racket[with-check-info] to report additional information. All checks created using -@racket[define-simple-check] or @racket[define-check] grab -some information by default: the name of the checks and the -values of the parameters. Additionally the macro forms of -checks grab location information and the expressions passed -as parameters. +@racket[define-simple-check] or @racket[define-check] grab some +information by default: the name of the checks and the values of the +parameters. Additionally the macro forms of checks grab location +information and the expressions passed as parameters. @defform[(define-simple-check (name param ...) expr ...)]{ @@ -257,9 +309,7 @@ check fails if the result of the @racket[expr]s is simple checks cannot report extra information using @racket[with-check-info].} -Example: - -To define a check @racket[check-odd?] +For example, the following code defines a check @racket[check-odd?] @racketblock[ (define-simple-check (check-odd? number) @@ -308,7 +358,6 @@ tests a number if within 0.01 of the expected value: (< (abs (- actual expected)) 0.01)) ] - @defform[(define-check (name param ...) expr ...)]{ The @racket[define-check] macro acts in exactly the same way @@ -317,29 +366,9 @@ if the macro @racket[fail-check] is called in the body of the check. This allows more flexible checks, and in particular more flexible reporting options.} -@defform[(fail-check)]{The @racket[fail-check] macro raises an @racket[exn:test:check] with -the contents of the check information stack.} +@defform[(fail-check)]{ +The @racket[fail-check] macro raises an @racket[exn:test:check] with +the contents of the check information stack. -@section{The Check Evaluation Context} - -The semantics of checks are determined by the parameters -@racket[current-check-around] and -@racket[current-check-handler]. Other testing form such as -@racket[test-begin] and @racket[test-suite] change the value -of these parameters. - -@defparam[current-check-handler handler (-> any/c any/c)]{ - -Parameter containing the function that handles exceptions -raised by check failures. The default value is @racket[raise]. } - -@defparam[current-check-around check (-> thunk any/c)]{ - -Parameter containing the function that handles the execution -of checks. The default value wraps the evaluation of -@racket[thunk] in a @racket[with-handlers] call that calls -@racket[current-check-handler] if an exception is raised and then -(when an exception is not raised) discards the result, returning -@racket[(void)]. } diff --git a/collects/rackunit/scribblings/compound-testing.scrbl b/collects/rackunit/scribblings/compound-testing.scrbl index 8b5016e..6618454 100644 --- a/collects/rackunit/scribblings/compound-testing.scrbl +++ b/collects/rackunit/scribblings/compound-testing.scrbl @@ -48,9 +48,37 @@ so the test can be named. @defproc[(test-case? (obj any)) boolean?]{ - True if @racket[obj] is a test case, and false otherwise + True if @racket[obj] is a test case, and false otherwise. } +@subsection{Shortcuts for Defining Test Cases} + +@defproc*[([(test-check [name string?] + [operator (-> any/c any/c any/c)] + [v1 any/c] + [v2 any/c]) + void?] + [(test-pred [name string?] + [pred (-> any/c any/c)] + [v any/c]) + void?] + [(test-equal? [name string?] [v1 any/c] [v2 any/c]) (void?)] + [(test-eq? [name string?] [v1 any/c] [v2 any/c]) void?] + [(test-eqv? [name string?] [v1 any/c] [v2 any/c]) void?] + [(test-= [name string?] [v1 real?] [v2 real?] [epsilon real?]) void?] + [(test-true [name string?] [v any/c]) void?] + [(test-false [name string?] [v any/c]) void?] + [(test-not-false [name string?] [v any/c]) void?] + [(test-exn [name string?] [pred (-> exn? any/c)] [thunk (-> any)]) void?] + [(test-not-exn [name string?] [thunk (-> any)]) void?])]{ + +Creates a test case with the given @racket[name] that performs the +corresponding check. For example, + +@racketblock[(test-equal? "Fruit test" "apple" "pear")] +is equivalent to +@racketblock[(test-case "Fruit test" (check-equal? "apple" "pear"))] +} @section{Test Suites} @@ -150,38 +178,3 @@ As far I know no-one uses this macro, so it might disappear in future versions of RackUnit.} } - -@section{Compound Testing Evaluation Context} - -Just like with checks, there are several parameters that -control the semantics of compound testing forms. - -@defparam[current-test-name name (or/c string? false/c)]{ - -This parameter stores the name of the current test case. A -value of @racket[#f] indicates a test case with no name, -such as one constructed by @racket[test-begin]. } - -@defparam[current-test-case-around handler (-> (-> any/c) any/c)]{ - -This parameter handles evaluation of test cases. The value -of the parameter is a function that is passed a thunk (a -function of no arguments). The function, when applied, -evaluates the expressions within a test case. The default -value of the @racket[current-test-case-around] parameters -evaluates the thunk in a context that catches exceptions and -prints an appropriate message indicating test case failure.} - -@defproc[(test-suite-test-case-around [thunk (-> any/c)]) any/c]{ - -The @racket[current-test-case-around] parameter is -parameterized to this value within the scope of a -@racket[test-suite]. This function creates a test case -structure instead of immediately evaluating the thunk.} - -@defproc[(test-suite-check-around [thunk (-> any/c)]) any/c]{ - -The @racket[current-check-around] parameter is parameterized -to this value within the scope of a @racket[test-suite]. -This function creates a test case structure instead of -immediately evaluating a check.} diff --git a/collects/rackunit/scribblings/internals.scrbl b/collects/rackunit/scribblings/internals.scrbl new file mode 100644 index 0000000..0e58bcd --- /dev/null +++ b/collects/rackunit/scribblings/internals.scrbl @@ -0,0 +1,271 @@ +#lang scribble/doc +@(require "base.rkt") + +@declare-exporting[rackunit #:use-sources (rackunit)] + +@title[#:tag "internals"]{RackUnit Internals and Extension API} + +This section describes RackUnit's facilities for customizing the +behavior of checks and tests and for creating new kinds of test +runners. + +@section{Customizing Check Evaluation} + +The semantics of checks are determined by the parameters +@racket[current-check-around] and +@racket[current-check-handler]. Other testing form such as +@racket[test-begin] and @racket[test-suite] change the value +of these parameters. + +@defparam[current-check-handler handler (-> any/c any)]{ + +Parameter containing the function that handles exceptions +raised by check failures. The default value is @racket[raise]. +} + +@defparam[current-check-around check (-> (-> any) any)]{ + +Parameter containing the function that handles the execution +of checks. The default value wraps the evaluation of +@racket[thunk] in a @racket[with-handlers] call that calls +@racket[current-check-handler] if an exception is raised and then +(when an exception is not raised) discards the result, returning +@racket[(void)]. +} + +@section{Customizing Test Evaluation} + +Just like with checks, there are several parameters that +control the semantics of compound testing forms. + +@defparam[current-test-name name (or/c string? false/c)]{ + +This parameter stores the name of the current test case. A +value of @racket[#f] indicates a test case with no name, +such as one constructed by @racket[test-begin]. +} + +@defparam[current-test-case-around handler (-> (-> any) any)]{ + +This parameter handles evaluation of test cases. The value +of the parameter is a function that is passed a thunk (a +function of no arguments). The function, when applied, +evaluates the expressions within a test case. The default +value of the @racket[current-test-case-around] parameters +evaluates the thunk in a context that catches exceptions and +prints an appropriate message indicating test case failure. +} + +@defproc[(test-suite-test-case-around [thunk (-> any)]) any]{ + +The @racket[current-test-case-around] parameter is +parameterized to this value within the scope of a +@racket[test-suite]. This function creates a test case +structure instead of immediately evaluating the thunk. +} + +@defproc[(test-suite-check-around [thunk (-> any/c)]) any/c]{ + +The @racket[current-check-around] parameter is parameterized +to this value within the scope of a @racket[test-suite]. +This function creates a test case structure instead of +immediately evaluating a check. +} + +@;{--------} + +@section[#:tag "running"]{Programmatically Running Tests and Inspecting Results} + +RackUnit provides an API for running tests, from which +custom UIs can be created. + +@subsection{Result Types} + +@defstruct[(exn:test exn) ()]{ + +The base structure for RackUnit exceptions. You should +never catch instances of this type, only the subtypes +documented below.} + +@defstruct[(exn:test:check exn:test) ([stack (listof check-info)])]{ + +A @racket[exn:test:check] is raised when an check fails, and +contains the contents of the check-info stack at the +time of failure.} + +@defstruct[test-result ([test-case-name (or/c string #f)])]{ + +A test-result is the result of running the test with +the given name (with @racket[#f] indicating no name is available).} + +@defstruct[(test-failure test-result) ([result any])]{ + +Subtype of test-result representing a test failure.} + +@defstruct[(test-error test-result) ([result exn])]{ + +Subtype of test-result representing a test error.} + +@defstruct[(test-success test-result) ([result any])]{ + +Subtype of test-result representing a test success.} + + +@subsection{Functions to Run Tests} + +@defproc[(run-test-case (name (or/c string #f)) (action (-> any))) + test-result]{ + +Runs the given test case, returning a result representing success, +failure, or error. +} + + +@defproc[(run-test (test (or/c test-case? test-suite?))) + (flat-murec-contract ([R (listof (or/c test-result? R))]) R)]{ + +Runs the given test (test case or test suite) returning a +tree (list of lists) of results} + +Example: + +@racketblock[ + (run-test + (test-suite + "Dummy" + (test-case "Dummy" (check-equal? 1 2)))) +] + +@defproc[(fold-test-results [result-fn ('b 'c ... 'a . -> . 'a)] + [seed 'a] + [test (or/c test-case? test-suite?)] + [#:run run (string (() -> any) . -> . 'b 'c ...)] + [#:fdown fdown (string 'a . -> . 'a)] + [#:fup fup (string 'a . -> . 'a)]) + 'a]{ + +Fold @racket[result-fn] pre-order left-to-right depth-first +over the results of @racket[run]. By default @racket[run] +is @racket[run-test-case] and @racket[fdown] and +@racket[fup] just return the seed, so @racket[result-fn] is +folded over the test results. + +This function is useful for writing custom folds (and hence UIs) over +test results without you having to take care of all the expected setup +and teardown. For example, @racket[fold-test-results] will run test +suite before and after actions for you. However it is still flexible +enough, via its keyword arguments, to do almost anything that +@racket[foldts] can. Hence it should be used in preference to @racket[foldts]. + +The @racket[result-fn] argument is a function from the results of +@racket[run] (defaults to a @racket[test-result]) and the seed to a +new seed. + +The @racket[seed] argument is any value. + +The @racket[test] argument is a test case or test suite. + +The @racket[run] argument is a function from a test case name (string) +and action (thunk) to any values. The values produced by @racket[run] +are fed into the @scheme[result-fn]. + +The @racket[fdown] argument is a function from a test suite name +(string) and the seed, to a new seed. + +The @racket[fup] argument is a function from a test suite name +(string) and the seed, to a new seed. +} + +Examples: + +The following code counts the number of successes: + +@racketblock[ +(define (count-successes test) + (fold-test-results + (lambda (result seed) + (if (test-success? result) + (add1 seed) + seed)) + 0 + test))] + +The following code returns the symbol @racket['burp] instead +of running test cases. Note how the @racket[result-fn] receives the +value of @racket[run]. + +@racketblock[ +(define (burp test) + (fold-test-results + (lambda (result seed) (cons result seed)) + null + test + #:run (lambda (name action) 'burp)))] + + +@defproc[(foldts [fdown (test-suite string thunk thunk 'a -> 'a)] + [fup (test-suite string thunk thunk 'a 'a -> 'a)] + [fhere(test-case string thunk 'a -> 'a)] + [seed 'a] + [test (or/c test-case? test-suite?)]) + 'a]{ + +The @racket[foldts] function is a nifty tree fold (created by Oleg +Kiselyov) that folds over a test in a useful way +(@racket[fold-test-results] isn't that useful as you can't specify +actions around test cases). + +The @racket[fdown] argument is a function of test suite, test suite +name, before action, after action, and the seed. It is run when a +test suite is encountered on the way down the tree (pre-order). + +The @racket[fup] argument is a function of test suite, test suite +name, before action, after action, the seed at the current level, and +the seed returned by the children. It is run on the way up the tree +(post-order). + +The @racket[fhere] argument is a function of the test case, test case +name, the test case action, and the seed. (Note that this might change +in the near future to just the test case. This change would be to +allow @racket[fhere] to discriminate subtypes of test-case, which in +turn would allow test cases that are, for example, ignored). +} + +Example: + +Here's the implementation of @racket[fold-test-results] in terms of +@racket[foldts]: + +@racketblock[ +(define (fold-test-results suite-fn case-fn seed test) + (foldts + (lambda (suite name before after seed) + (before) + (suite-fn name seed)) + (lambda (suite name before after seed kid-seed) + (after) + kid-seed) + (lambda (case name action seed) + (case-fn + (run-test-case name action) + seed)) + seed + test)) +] + +If you're used to folds you'll probably be a bit surprised that the +functions you pass to @racket[foldts] receive both the structure they +operate on, and the contents of that structure. This is indeed +unusual. It is done to allow subtypes of test-case and test-suite to +be run in customised ways. For example, you might define subtypes of +test case that are ignored (not run), or have their execution time +recorded, and so on. To do so the functions that run the test cases +need to know what type the test case has, and hence is is necessary to +provide this information. + +If you've made it this far you truly are a master RackUnit hacker. As +a bonus prize we'll just mention that the code in +@racketfont{hash-monad.rkt} and @racketfont{monad.rkt} might be of +interest for constructing user interfaces. The API is still in flux, +so isn't documented here. However, do look at the implementation of +@racket[run-tests] for examples of use. diff --git a/collects/rackunit/scribblings/misc.scrbl b/collects/rackunit/scribblings/misc.scrbl index 2b0c3f3..dcd1803 100644 --- a/collects/rackunit/scribblings/misc.scrbl +++ b/collects/rackunit/scribblings/misc.scrbl @@ -8,7 +8,10 @@ bindings that a module does not provide. It is useful for testing the private functions of modules. @defform[(require/expose module (id ...))]{ -Requires @racket[id] from @racket[module] into the current module. It doesn't matter if the source module provides the bindings or not; @racket[require/expose] can still get at them. + +Requires @racket[id] from @racket[module] into the current module. It +doesn't matter if the source module provides the bindings or not; +@racket[require/expose] can still get at them. Note that @racket[require/expose] can be a bit fragile, especially when mixed with compiled code. Use at your own risk! diff --git a/collects/rackunit/scribblings/overview.scrbl b/collects/rackunit/scribblings/overview.scrbl index bc3aec4..6c05a19 100644 --- a/collects/rackunit/scribblings/overview.scrbl +++ b/collects/rackunit/scribblings/overview.scrbl @@ -3,13 +3,17 @@ @title{Overview of RackUnit} -There are three basic data types in RackUnit: +There are three basic concepts in RackUnit: @itemize[ -@item{A @italic{check} is the basic unit of a test. As the name suggests, it checks some condition is true.} +@item{A @italic{check} is the basic unit of a test. As the name +suggests, it checks some condition is true.} -@item{A @italic{test case} is a group of checks that form one conceptual unit. If any check within the case fails, the entire case fails.} +@item{A @italic{test case} is a group of checks that form one +conceptual unit. If any check within the case fails, the entire case +fails.} -@item{A @italic{test suite} is a group of test cases and test suites that has a name.} +@item{A @italic{test suite} is a group of test cases and test suites +that has a name.} ] diff --git a/collects/rackunit/scribblings/philosophy.scrbl b/collects/rackunit/scribblings/philosophy.scrbl index 4d0434c..5b439a0 100644 --- a/collects/rackunit/scribblings/philosophy.scrbl +++ b/collects/rackunit/scribblings/philosophy.scrbl @@ -5,7 +5,7 @@ RackUnit is designed to allow tests to evolve in step with the evolution of the program under testing. RackUnit -scales from the unstructed checks suitable for simple +scales from the unstructured checks suitable for simple programs to the complex structure necessary for large projects. @@ -83,7 +83,7 @@ RackUnit manner (for example, test results may be logged for the purpose of improving software quality, or they may be displayed on a website to indicate service quality). For these programmers it is necessary to delay the execution of -tests so they can processed in the programmer's chosen +tests so they can be processed in the programmer's chosen manner. To do this, the programmer simply wraps a test-suite around their tests: diff --git a/collects/rackunit/scribblings/quick-start.scrbl b/collects/rackunit/scribblings/quick-start.scrbl index ed4c80f..28f7ed5 100644 --- a/collects/rackunit/scribblings/quick-start.scrbl +++ b/collects/rackunit/scribblings/quick-start.scrbl @@ -48,19 +48,19 @@ evaluate this file and see if the library is correct. Here's the result I get: @verbatim{ -#t -------------------- FAILURE name: check-equal? location: (file-test.rkt 7 0 117 27) expression: (check-equal? (my-* 1 2) 2) params: (4 2) +message: "Simple multiplication" actual: 4 expected: 2 --------------------} -The first @racket[#t] indicates the first test passed. The +The first test passed and so prints nothing. The second test failed, as shown by the message. Requiring RackUnit and writing checks is all you need to @@ -119,7 +119,7 @@ we're testing. We can give a test case a name with the lst))) ] -Now if we want to structure our tests are bit more we can +Now if we want to structure our tests a bit more we can group them into a test suite: @racketblock[ diff --git a/collects/rackunit/scribblings/rackunit.scrbl b/collects/rackunit/scribblings/rackunit.scrbl index c8bdc2b..16da247 100644 --- a/collects/rackunit/scribblings/rackunit.scrbl +++ b/collects/rackunit/scribblings/rackunit.scrbl @@ -4,7 +4,7 @@ @title{@bold{RackUnit}: Unit Testing for Racket} @author[(author+email "Noel Welsh" "noelwelsh@gmail.com") - (author+email "Ryan Culpepper" "ryan_sml@yahoo.com")] + (author+email "Ryan Culpepper" "ryanc@racket-lang.org")] RackUnit is a unit-testing framework for Racket. It is designed to handle the needs of all Racket programmers, @@ -15,6 +15,7 @@ from novices to experts. @include-section["quick-start.scrbl"] @include-section["philosophy.scrbl"] @include-section["api.scrbl"] +@include-section["internals.scrbl"] @include-section["release-notes.scrbl"] @include-section["acknowledgements.scrbl"] diff --git a/collects/rackunit/tool.rkt b/collects/rackunit/tool.rkt index 20bfd5e..ba75e1a 100644 --- a/collects/rackunit/tool.rkt +++ b/collects/rackunit/tool.rkt @@ -1,6 +1,6 @@ #lang racket/base (require racket/class - racket/gui + racket/gui/base framework drscheme/tool racket/unit diff --git a/collects/tests/rackunit/pr10950.rkt b/collects/tests/rackunit/pr10950.rkt index 1663aaa..c99dd9d 100644 --- a/collects/tests/rackunit/pr10950.rkt +++ b/collects/tests/rackunit/pr10950.rkt @@ -4,13 +4,19 @@ racket/port tests/eli-tester) -(test - (with-output-to-string +(define output + (with-output-to-string (lambda () (parameterize ([current-error-port (current-output-port)]) (define-check (check3) (fail-check)) - (run-tests (test-suite "tests" (let ((foo check3)) (foo))))))) - => - "--------------------\ntests > #f\nUnnamed test \nFAILURE\nname: check3\nlocation: unknown:?:?\nparams: \n--------------------\n0 success(es) 1 failure(s) 0 error(s) 1 test(s) run\n") \ No newline at end of file + (run-tests (test-suite "tests" (let ((foo check3)) (foo)))))))) + +(test + (regexp-match + (regexp (format "~a.*~a" + (regexp-quote "--------------------\ntests > #f\nUnnamed test \nFAILURE\nname: check3\nlocation: ") + + (regexp-quote "/collects/tests/rackunit/pr10950.rkt:14:51\nparams: \n--------------------\n0 success(es) 1 failure(s) 0 error(s) 1 test(s) run\n"))) + output)) \ No newline at end of file diff --git a/collects/tests/rackunit/standalone-test-case-test.rkt b/collects/tests/rackunit/standalone-test-case-test.rkt index 3398469..78f9abc 100644 --- a/collects/tests/rackunit/standalone-test-case-test.rkt +++ b/collects/tests/rackunit/standalone-test-case-test.rkt @@ -12,8 +12,8 @@ (test-case "succeed" (check-eq? 1 1)) ;; These should raise errors -(test-begin (error "Outta here!")) -(test-case "error" (error "Outta here!")) +(test-begin (error "First Outta here!")) +(test-case "error" (error "Second Outta here!")) ;; Thesse should raise failures (test-begin (check-eq? 1 2)) diff --git a/collects/tests/rackunit/standalone.rkt b/collects/tests/rackunit/standalone.rkt new file mode 100644 index 0000000..78d4a1a --- /dev/null +++ b/collects/tests/rackunit/standalone.rkt @@ -0,0 +1,37 @@ +#lang racket/base +(require racket/runtime-path + rackunit + racket/path) + +(define-runtime-path here ".") +(define collects + (normalize-path (build-path here ".." ".."))) +(define (collect-trim bs) + (regexp-replace* (regexp-quote (path->bytes collects)) bs #"PLTHOME/collects")) + +(define (require&catch path) + (define out-bs (open-output-bytes)) + (define err-bs (open-output-bytes)) + (parameterize ([current-output-port out-bs] + [current-error-port err-bs]) + (dynamic-require path #f)) + (close-output-port out-bs) + (close-output-port err-bs) + (values (collect-trim (get-output-bytes out-bs)) + (collect-trim (get-output-bytes err-bs)))) + +(define-syntax-rule (test-file pth out err) + (begin + (define-runtime-module-path mod (file pth)) + (define-values (cout cerr) (require&catch mod)) + (check-equal? cout out) + (check-equal? cerr err))) + +(test-file "standalone-check-test.rkt" + #"Oh HAI!\nI didn't run\n" + #"--------------------\nERROR\nOutta here!\n\n === context ===\nPLTHOME/collects/tests/rackunit/standalone-check-test.rkt:40:12: temp7\nPLTHOME/collects/rackunit/private/check.rkt:144:29\nPLTHOME/collects/racket/private/more-scheme.rkt:207:2: call-handled-body\nPLTHOME/collects/rackunit/private/check.rkt:77:0: top-level-check-around\n\n\n--------------------\n--------------------\nFAILURE\nname: check\nlocation: (# 44 0 1344 17)\nexpression: (check = 1 2)\nparams: (# 1 2)\nmessage: 0.0\n\n--------------------\n") + +(test-file "standalone-test-case-test.rkt" + #"#t\n#t\n" + #"--------------------\nUnnamed test \nERROR\nFirst Outta here!\n\n === context ===\nPLTHOME/collects/racket/private/more-scheme.rkt:207:2: call-handled-body\n\n\n--------------------\n--------------------\nerror\nERROR\nSecond Outta here!\n\n === context ===\nPLTHOME/collects/racket/private/more-scheme.rkt:207:2: call-handled-body\n\n\n--------------------\n--------------------\nUnnamed test \nFAILURE\nname: check-eq?\nlocation: (# 19 12 520 15)\nexpression: (check-eq? 1 2)\nparams: (1 2)\nactual: 1\nexpected: 2\n\n--------------------\n--------------------\nfailure\nFAILURE\nname: check-eq?\nlocation: (# 20 21 558 15)\nexpression: (check-eq? 1 2)\nparams: (1 2)\nactual: 1\nexpected: 2\n\n--------------------\n") + diff --git a/collects/tests/rackunit/tl.rkt b/collects/tests/rackunit/tl.rkt new file mode 100644 index 0000000..5a88d0d --- /dev/null +++ b/collects/tests/rackunit/tl.rkt @@ -0,0 +1,28 @@ +#lang racket/base +(require rackunit) + +;; test to make sure that the various check functions +;; return what they are promised to at the top-level + +;; make drdr notice when a check prints something. +(current-output-port (current-error-port)) + +(check-equal? (check + 1 2) (void)) + +(check-equal? (check-eq? 1 1) (void)) +(check-equal? (check-not-eq? #f #t) (void)) +(check-equal? (check-eqv? (expt 2 100) (expt 2 100)) (void)) +(check-equal? (check-not-eqv? (expt 2 100) 1) (void)) +(check-equal? (check-equal? (list 1 2) (list 1 2)) (void)) +(check-equal? (check-not-equal? (list 1 2) (list 2 1)) (void)) + +(check-equal? (check-pred not #f) (void)) +(check-equal? (check-= 1.1 1.2 0.5) (void)) +(check-equal? (check-true #t) (void)) +(check-equal? (check-false #f) (void)) +(check-equal? (check-not-false 3) (void)) + +(check-equal? (check-exn #rx"car" (λ () (car 1))) (void)) +(check-equal? (check-not-exn (λ () 1)) (void)) + +(check-equal? (check-regexp-match #rx"a*b" "aaaaaaab") (void))