From 84eae2b5e3fbf382bcd17f4afc85a3a33059bf7e Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 4 Jun 2010 17:58:49 -0400 Subject: [PATCH] scheme -> racket in test-engine --- collects/test-engine/racket-gui.rkt | 57 +++ collects/test-engine/racket-tests.rkt | 369 +++++++++++++++++++ collects/test-engine/scheme-gui.rkt | 60 +--- collects/test-engine/scheme-tests.rkt | 372 +------------------- collects/test-engine/test-engine.scrbl | 16 +- collects/typed/test-engine/racket-tests.rkt | 5 + collects/typed/test-engine/type-env-ext.rkt | 2 +- 7 files changed, 446 insertions(+), 435 deletions(-) create mode 100644 collects/test-engine/racket-gui.rkt create mode 100644 collects/test-engine/racket-tests.rkt create mode 100644 collects/typed/test-engine/racket-tests.rkt diff --git a/collects/test-engine/racket-gui.rkt b/collects/test-engine/racket-gui.rkt new file mode 100644 index 0000000000..d0d7fef8b1 --- /dev/null +++ b/collects/test-engine/racket-gui.rkt @@ -0,0 +1,57 @@ +(module scheme-gui scheme/base + + (require mred framework scheme/class + mzlib/pconvert mzlib/pretty + (for-syntax scheme/base)) + + (require (except-in "scheme-tests.ss" test) "test-display.scm") + + (define (make-formatter printer) + (lambda (value) + (let* ([text* (new (editor:standard-style-list-mixin text%))] + [text-snip (new editor-snip% [editor text*])]) + (printer value (open-output-text-editor text* 0)) + (send text* delete (send text* get-end-position) 'back) + (send text* lock #t) + text-snip))) + + (define (format-value value) + (parameterize ([constructor-style-printing #t] + [pretty-print-columns 40]) + (make-formatter (lambda (v o) (pretty-print (print-convert v) o))))) + + #;(define (format-value value) + (cond + [(is-a? value snip%) value] + [(or (pair? value) (struct? value)) + (parameterize ([constructor-style-printing #t] + [pretty-print-columns 40]) + (let* ([text* (new (editor:standard-style-list-mixin text%))] + [text-snip (new editor-snip% [editor text*])]) + (pretty-print (print-convert value) (open-output-text-editor text*)) + (send text* lock #t) + text-snip))] + [else (format "~v" value)])) + + (define (test*) + (run-tests) + (pop-up)) + + (define-syntax (test stx) + (syntax-case stx () + [(_) + (syntax-property + #'(test*) + 'test-call #t)])) + + (define (pop-up) + (let ([test-info (namespace-variable-value 'test~object #f builder (current-namespace))]) + (parameterize ([test-format format-value]) + (and test-info + (send test-info refine-display-class test-display%) + (send test-info setup-display #f #f) + (send test-info summarize-results (current-output-port)))))) + + (provide test format-value make-formatter (all-from-out "scheme-tests.ss")) + + ) diff --git a/collects/test-engine/racket-tests.rkt b/collects/test-engine/racket-tests.rkt new file mode 100644 index 0000000000..319350bd98 --- /dev/null +++ b/collects/test-engine/racket-tests.rkt @@ -0,0 +1,369 @@ +#lang mzscheme + +(require lang/private/teachprims + scheme/class + scheme/match + (only scheme/base for memf) + "test-engine.scm" + "test-info.scm" + ) + +(require-for-syntax stepper/private/shared) + +(provide + check-expect ;; syntax : (check-expect ) + check-within ;; syntax : (check-within ) + check-member-of ;; syntax : (check-member-of ) + check-range ;; syntax : (check-range ) + check-error ;; syntax : (check-error ) + ) + +; for other modules implementing check-expect-like forms +(provide + (for-syntax check-expect-maker)) + +(define INEXACT-NUMBERS-FMT + "check-expect cannot compare inexact numbers. Try (check-within test ~a range).") +(define FUNCTION-FMT + "check-expect cannot compare functions.") +(define CHECK-ERROR-STR-FMT + "check-error requires a string for the second argument, representing the expected error message. Given ~s") +(define CHECK-WITHIN-INEXACT-FMT + "check-within requires an inexact number for the range. ~a is not inexact.") +(define CHECK-WITHIN-FUNCTION-FMT + "check-within cannot compare functions.") +(define LIST-FMT + "check-member-of requires a list for the second argument, containing the possible outcomes. Given ~s") +(define CHECK-MEMBER-OF-FUNCTION-FMT + "check-member-of cannot compare functions.") +(define RANGE-MIN-FMT + "check-range requires a number for the minimum value. Given ~a") +(define RANGE-MAX-FMT + "check-range requires a number for the maximum value. Given ~a") +(define CHECK-RANGE-FUNCTION-FMT + "check-range cannot compare functions.") + + +(define-for-syntax CHECK-EXPECT-STR + "check-expect requires two expressions. Try (check-expect test expected).") +(define-for-syntax CHECK-ERROR-STR + "check-error requires two expressions. Try (check-error test message).") +(define-for-syntax CHECK-WITHIN-STR + "check-within requires three expressions. Try (check-within test expected range).") +(define-for-syntax CHECK-MEMBER-OF-STR + "check-member-of requires at least two expressions. Try (check-member-of test option options ...).") +(define-for-syntax CHECK-RANGE-STR + "chech-range requires three expressions. Try (check-range test min max).") + +(define-for-syntax CHECK-EXPECT-DEFN-STR + "found a test that is not at the top level") +(define-for-syntax CHECK-WITHIN-DEFN-STR + CHECK-EXPECT-DEFN-STR) +(define-for-syntax CHECK-ERROR-DEFN-STR + CHECK-EXPECT-DEFN-STR) + +;; check-expect-maker : syntax? syntax? (listof syntax?) symbol? -> syntax? +;; the common part of all three test forms. +(define-for-syntax (check-expect-maker + stx checker-proc-stx test-expr embedded-stxes hint-tag) + (define bogus-name + (stepper-syntax-property #`#,(gensym 'test) 'stepper-hide-completed #t)) + (define src-info + (with-stepper-syntax-properties (['stepper-skip-completely #t]) + #`(list #,@(list #`(quote #,(syntax-source stx)) + (syntax-line stx) + (syntax-column stx) + (syntax-position stx) + (syntax-span stx))))) + (if (eq? 'module (syntax-local-context)) + #`(define #,bogus-name + #,(stepper-syntax-property + #`(let ([test-info (namespace-variable-value + 'test~object #f builder (current-namespace))]) + (when test-info + (insert-test test-info + (lambda () + #,(with-stepper-syntax-properties + (['stepper-hint hint-tag] + ['stepper-hide-reduction #t] + ['stepper-use-val-as-final #t]) + (quasisyntax/loc stx + (#,checker-proc-stx + #,(with-stepper-syntax-properties + (['stepper-hide-reduction #t]) + #`(car + #,(with-stepper-syntax-properties + (['stepper-hide-reduction #t]) + #`(list + (lambda () #,test-expr) + #,(syntax/loc stx (void)))))) + #,@embedded-stxes + #,src-info + #,(with-stepper-syntax-properties + (['stepper-no-lifting-info #t] + ['stepper-hide-reduction #t]) + #'test-info)))))))) + 'stepper-skipto + (append skipto/third ;; let + skipto/third skipto/second ;; unless (it expands into a begin) + skipto/cdr skipto/third ;; application of insert-test + '(syntax-e cdr cdr syntax-e car) ;; lambda + ))) + #`(begin + (let ([test-info (namespace-variable-value + 'test~object #f builder (current-namespace))]) + (when test-info + (begin + (send test-info reset-info) + (insert-test test-info + (lambda () + #,(with-stepper-syntax-properties + (['stepper-hint hint-tag] + ['stepper-hide-reduction #t] + ['stepper-use-val-as-final #t]) + (quasisyntax/loc stx + (#,checker-proc-stx + #,(with-stepper-syntax-properties + (['stepper-hide-reduction #t]) + #`(car + #,(with-stepper-syntax-properties + (['stepper-hide-reduction #t]) + #`(list + (lambda () #,test-expr) + #,(syntax/loc stx (void)))))) + #,@embedded-stxes + #,src-info + #,(with-stepper-syntax-properties + (['stepper-no-lifting-info #t] + ['stepper-hide-reduction #t]) + #'test-info))))))))) + (test)))) + +(define-for-syntax (check-context?) + (let ([c (syntax-local-context)]) + (memq c '(module top-level)))) + +;; check-expect +(define-syntax (check-expect stx) + (unless (check-context?) + (raise-syntax-error 'check-expect CHECK-EXPECT-DEFN-STR stx)) + (syntax-case stx () + [(_ test actual) + (check-expect-maker stx #'check-values-expected #`test (list #`actual) + 'comes-from-check-expect)] + [_ (raise-syntax-error 'check-expect CHECK-EXPECT-STR stx)])) + +;; check-values-expected: (-> scheme-val) scheme-val src test-object -> void +(define (check-values-expected test actual src test-info) + (error-check (lambda (v) (if (number? v) (exact? v) #t)) + actual INEXACT-NUMBERS-FMT #t) + (error-check (lambda (v) (not (procedure? v))) actual FUNCTION-FMT #f) + (send (send test-info get-info) add-check) + (run-and-check (lambda (v1 v2 _) (beginner-equal? v1 v2)) + (lambda (src format v1 v2 _) (make-unequal src format v1 v2)) + test actual #f src test-info 'check-expect)) + +;;check-within +(define-syntax (check-within stx) + (unless (check-context?) + (raise-syntax-error 'check-within CHECK-WITHIN-DEFN-STR stx)) + (syntax-case stx () + [(_ test actual within) + (check-expect-maker stx #'check-values-within #`test (list #`actual #`within) + 'comes-from-check-within)] + [_ (raise-syntax-error 'check-within CHECK-WITHIN-STR stx)])) + +;; check-values-within: (-> scheme-val) scheme-val number src test-object -> void +(define (check-values-within test actual within src test-info) + (error-check number? within CHECK-WITHIN-INEXACT-FMT #t) + (error-check (lambda (v) (not (procedure? v))) actual CHECK-WITHIN-FUNCTION-FMT #f) + (send (send test-info get-info) add-check) + (run-and-check beginner-equal~? make-outofrange test actual within src + test-info + 'check-within)) + +;; check-error +(define-syntax (check-error stx) + (unless (check-context?) + (raise-syntax-error 'check-error CHECK-ERROR-DEFN-STR stx)) + (syntax-case stx () + [(_ test error) + (check-expect-maker stx #'check-values-error #`test (list #`error) + 'comes-from-check-error)] + [_ (raise-syntax-error 'check-error CHECK-ERROR-STR stx)])) + +;; check-values-error: (-> scheme-val) scheme-val src test-object -> void +(define (check-values-error test error src test-info) + (error-check string? error CHECK-ERROR-STR-FMT #t) + (send (send test-info get-info) add-check) + (let ([result (with-handlers ([exn? + (lambda (e) + (or (equal? (exn-message e) error) + (make-incorrect-error src (test-format) error + (exn-message e) e)))]) + (let ([test-val (test)]) + (make-expected-error src (test-format) error test-val)))]) + (if (check-fail? result) + (begin + (send (send test-info get-info) check-failed + result (check-fail-src result) + (and (incorrect-error? result) (incorrect-error-exn result))) + #f) + #t))) + + +;;error-check: (scheme-val -> boolean) format-string boolean) -> void : raise exn:fail:contract +(define (error-check pred? actual fmt fmt-act?) + (unless (pred? actual) + (raise (make-exn:fail:contract (if fmt-act? (format fmt actual) fmt) + (current-continuation-marks))))) + +;;check-member-of +(define-syntax (check-member-of stx) + (unless (check-context?) + (raise-syntax-error 'check-member-of CHECK-EXPECT-DEFN-STR stx)) + (syntax-case stx () + [(_ test actual actuals ...) + (check-expect-maker stx #'check-member-of-values-expected #`test (list #`actual #`(list actuals ...)) + 'comes-from-check-member-of)] + [_ (raise-syntax-error 'check-member-of CHECK-MEMBER-OF-STR stx)])) + +;; check-member-of-values-expected: (-> scheme-val) scheme-val src test-object -> void +(define (check-member-of-values-expected test first-actual actuals src test-info) + (error-check (lambda (v) (not (procedure? v))) first-actual CHECK-MEMBER-OF-FUNCTION-FMT #f) + (send (send test-info get-info) add-check) + (run-and-check (lambda (v2 v1 _) (memf (lambda (i) (beginner-equal? v1 i)) v2)) + (lambda (src format v1 v2 _) (make-not-mem src format v1 v2)) + test (cons first-actual actuals) #f src test-info 'check-member-of)) + +;;check-range +(define-syntax (check-range stx) + (unless (check-context?) + (raise-syntax-error 'check-member-of CHECK-EXPECT-DEFN-STR stx)) + (syntax-case stx () + [(_ test min max) + (check-expect-maker stx #'check-range-values-expected #`test (list #`min #`max) + 'comes-from-check-range)] + [_ (raise-syntax-error 'check-range CHECK-RANGE-STR stx)])) + +;; check-range-values-expected: (-> scheme-val) scheme-val src test-object -> void +(define (check-range-values-expected test min max src test-info) + (error-check number? min RANGE-MIN-FMT #t) + (error-check number? max RANGE-MAX-FMT #t) + (error-check (lambda (v) (not (procedure? v))) min CHECK-RANGE-FUNCTION-FMT #f) + (error-check (lambda (v) (not (procedure? v))) max CHECK-RANGE-FUNCTION-FMT #f) + (send (send test-info get-info) add-check) + (run-and-check (lambda (v2 v1 v3) (and (number? v1) (and (<= v2 v1) (<= v1 v3)))) + (lambda (src format v1 v2 v3) (make-not-range src format v1 v2 v3)) + test min max src test-info 'check-range)) + + +;; run-and-check: (scheme-val scheme-val scheme-val -> boolean) +;; (src format scheme-val scheme-val scheme-val -> check-fail) +;; ( -> scheme-val) scheme-val scheme-val object symbol? -> void +(define (run-and-check check maker test expect range src test-info kind) + (match-let ([(list result result-val exn) + (with-handlers ([exn:fail? + (lambda (e) + (let ([display (error-display-handler)]) + (list (make-unexpected-error src (test-format) expect + (exn-message e) + e) + 'error + e)))]) + (let ([test-val (test)]) + (cond [(check expect test-val range) (list #t test-val #f)] + [else + (list (maker src (test-format) test-val expect range) test-val #f)])))]) + (cond [(check-fail? result) + (send (send test-info get-info) check-failed result (check-fail-src result) exn) + (if exn + (raise exn) + #f)] + [else + #t]))) + +(define (builder) + (let ([te (build-test-engine)]) + (namespace-set-variable-value! 'test~object te (current-namespace)) + te)) + +(define-syntax (test stx) + (syntax-case stx () + [(_) + (syntax-property + #'(test*) + 'test-call #t)])) + +(define (test*) + (dynamic-wind + values + (lambda () (run-tests)) + (lambda () (display-results)))) + +(define-syntax (run-tests stx) + (syntax-case stx () + [(_) + (syntax-property + #'(run) + 'test-call #t)])) + +(define (run) + (let ([test-info + (namespace-variable-value 'test~object #f builder (current-namespace))]) + (and test-info (send test-info run)))) + +(define (display-results*) + (let ([test-info (namespace-variable-value 'test~object #f builder (current-namespace))]) + (and test-info + (let ([display-data (scheme-test-data)]) + (when (caddr display-data) + (send test-info refine-display-class (caddr display-data))) + (send test-info setup-display (car display-data) (cadr display-data)) + (send test-info summarize-results (current-output-port)))))) + +(define-syntax (display-results stx) + (syntax-case stx () + [(_) + (syntax-property + #'(display-results*) + 'test-call #t)])) + +(provide run-tests display-results test builder) + +(define (build-test-engine) + (let ([engine (make-object scheme-test%)]) + (send engine setup-info 'test-check) + engine)) + +(define (insert-test test-info test) (send test-info add-test test)) + +(define scheme-test-data (make-parameter (list #f #f #f))) + +(define scheme-test% + (class* test-engine% () + (super-instantiate ()) + (inherit-field test-info test-display) + (inherit setup-info) + + (field [tests null] + [test-objs null]) + + (define/public (add-test tst) + (set! tests (cons tst tests))) + (define/public (get-info) + (unless test-info (send this setup-info 'check-require)) + test-info) + (define/public (reset-info) + (set! tests null) + #;(send this setup-info 'check-require)) + + (define/augment (run) + (inner (void) run) + (for ([t (reverse tests)]) (run-test t))) + + (define/augment (run-test test) + (test) + (inner (void) run-test test)))) + +(provide scheme-test-data test-format test-execute test-silence error-handler) diff --git a/collects/test-engine/scheme-gui.rkt b/collects/test-engine/scheme-gui.rkt index d0d7fef8b1..abcd280408 100644 --- a/collects/test-engine/scheme-gui.rkt +++ b/collects/test-engine/scheme-gui.rkt @@ -1,57 +1,3 @@ -(module scheme-gui scheme/base - - (require mred framework scheme/class - mzlib/pconvert mzlib/pretty - (for-syntax scheme/base)) - - (require (except-in "scheme-tests.ss" test) "test-display.scm") - - (define (make-formatter printer) - (lambda (value) - (let* ([text* (new (editor:standard-style-list-mixin text%))] - [text-snip (new editor-snip% [editor text*])]) - (printer value (open-output-text-editor text* 0)) - (send text* delete (send text* get-end-position) 'back) - (send text* lock #t) - text-snip))) - - (define (format-value value) - (parameterize ([constructor-style-printing #t] - [pretty-print-columns 40]) - (make-formatter (lambda (v o) (pretty-print (print-convert v) o))))) - - #;(define (format-value value) - (cond - [(is-a? value snip%) value] - [(or (pair? value) (struct? value)) - (parameterize ([constructor-style-printing #t] - [pretty-print-columns 40]) - (let* ([text* (new (editor:standard-style-list-mixin text%))] - [text-snip (new editor-snip% [editor text*])]) - (pretty-print (print-convert value) (open-output-text-editor text*)) - (send text* lock #t) - text-snip))] - [else (format "~v" value)])) - - (define (test*) - (run-tests) - (pop-up)) - - (define-syntax (test stx) - (syntax-case stx () - [(_) - (syntax-property - #'(test*) - 'test-call #t)])) - - (define (pop-up) - (let ([test-info (namespace-variable-value 'test~object #f builder (current-namespace))]) - (parameterize ([test-format format-value]) - (and test-info - (send test-info refine-display-class test-display%) - (send test-info setup-display #f #f) - (send test-info summarize-results (current-output-port)))))) - - (provide test format-value make-formatter (all-from-out "scheme-tests.ss")) - - ) +#lang racket/base +(require "racket-gui.rkt") +(provide (all-from-out "racket-gui.rkt")) \ No newline at end of file diff --git a/collects/test-engine/scheme-tests.rkt b/collects/test-engine/scheme-tests.rkt index 319350bd98..c3cfbde57f 100644 --- a/collects/test-engine/scheme-tests.rkt +++ b/collects/test-engine/scheme-tests.rkt @@ -1,369 +1,3 @@ -#lang mzscheme - -(require lang/private/teachprims - scheme/class - scheme/match - (only scheme/base for memf) - "test-engine.scm" - "test-info.scm" - ) - -(require-for-syntax stepper/private/shared) - -(provide - check-expect ;; syntax : (check-expect ) - check-within ;; syntax : (check-within ) - check-member-of ;; syntax : (check-member-of ) - check-range ;; syntax : (check-range ) - check-error ;; syntax : (check-error ) - ) - -; for other modules implementing check-expect-like forms -(provide - (for-syntax check-expect-maker)) - -(define INEXACT-NUMBERS-FMT - "check-expect cannot compare inexact numbers. Try (check-within test ~a range).") -(define FUNCTION-FMT - "check-expect cannot compare functions.") -(define CHECK-ERROR-STR-FMT - "check-error requires a string for the second argument, representing the expected error message. Given ~s") -(define CHECK-WITHIN-INEXACT-FMT - "check-within requires an inexact number for the range. ~a is not inexact.") -(define CHECK-WITHIN-FUNCTION-FMT - "check-within cannot compare functions.") -(define LIST-FMT - "check-member-of requires a list for the second argument, containing the possible outcomes. Given ~s") -(define CHECK-MEMBER-OF-FUNCTION-FMT - "check-member-of cannot compare functions.") -(define RANGE-MIN-FMT - "check-range requires a number for the minimum value. Given ~a") -(define RANGE-MAX-FMT - "check-range requires a number for the maximum value. Given ~a") -(define CHECK-RANGE-FUNCTION-FMT - "check-range cannot compare functions.") - - -(define-for-syntax CHECK-EXPECT-STR - "check-expect requires two expressions. Try (check-expect test expected).") -(define-for-syntax CHECK-ERROR-STR - "check-error requires two expressions. Try (check-error test message).") -(define-for-syntax CHECK-WITHIN-STR - "check-within requires three expressions. Try (check-within test expected range).") -(define-for-syntax CHECK-MEMBER-OF-STR - "check-member-of requires at least two expressions. Try (check-member-of test option options ...).") -(define-for-syntax CHECK-RANGE-STR - "chech-range requires three expressions. Try (check-range test min max).") - -(define-for-syntax CHECK-EXPECT-DEFN-STR - "found a test that is not at the top level") -(define-for-syntax CHECK-WITHIN-DEFN-STR - CHECK-EXPECT-DEFN-STR) -(define-for-syntax CHECK-ERROR-DEFN-STR - CHECK-EXPECT-DEFN-STR) - -;; check-expect-maker : syntax? syntax? (listof syntax?) symbol? -> syntax? -;; the common part of all three test forms. -(define-for-syntax (check-expect-maker - stx checker-proc-stx test-expr embedded-stxes hint-tag) - (define bogus-name - (stepper-syntax-property #`#,(gensym 'test) 'stepper-hide-completed #t)) - (define src-info - (with-stepper-syntax-properties (['stepper-skip-completely #t]) - #`(list #,@(list #`(quote #,(syntax-source stx)) - (syntax-line stx) - (syntax-column stx) - (syntax-position stx) - (syntax-span stx))))) - (if (eq? 'module (syntax-local-context)) - #`(define #,bogus-name - #,(stepper-syntax-property - #`(let ([test-info (namespace-variable-value - 'test~object #f builder (current-namespace))]) - (when test-info - (insert-test test-info - (lambda () - #,(with-stepper-syntax-properties - (['stepper-hint hint-tag] - ['stepper-hide-reduction #t] - ['stepper-use-val-as-final #t]) - (quasisyntax/loc stx - (#,checker-proc-stx - #,(with-stepper-syntax-properties - (['stepper-hide-reduction #t]) - #`(car - #,(with-stepper-syntax-properties - (['stepper-hide-reduction #t]) - #`(list - (lambda () #,test-expr) - #,(syntax/loc stx (void)))))) - #,@embedded-stxes - #,src-info - #,(with-stepper-syntax-properties - (['stepper-no-lifting-info #t] - ['stepper-hide-reduction #t]) - #'test-info)))))))) - 'stepper-skipto - (append skipto/third ;; let - skipto/third skipto/second ;; unless (it expands into a begin) - skipto/cdr skipto/third ;; application of insert-test - '(syntax-e cdr cdr syntax-e car) ;; lambda - ))) - #`(begin - (let ([test-info (namespace-variable-value - 'test~object #f builder (current-namespace))]) - (when test-info - (begin - (send test-info reset-info) - (insert-test test-info - (lambda () - #,(with-stepper-syntax-properties - (['stepper-hint hint-tag] - ['stepper-hide-reduction #t] - ['stepper-use-val-as-final #t]) - (quasisyntax/loc stx - (#,checker-proc-stx - #,(with-stepper-syntax-properties - (['stepper-hide-reduction #t]) - #`(car - #,(with-stepper-syntax-properties - (['stepper-hide-reduction #t]) - #`(list - (lambda () #,test-expr) - #,(syntax/loc stx (void)))))) - #,@embedded-stxes - #,src-info - #,(with-stepper-syntax-properties - (['stepper-no-lifting-info #t] - ['stepper-hide-reduction #t]) - #'test-info))))))))) - (test)))) - -(define-for-syntax (check-context?) - (let ([c (syntax-local-context)]) - (memq c '(module top-level)))) - -;; check-expect -(define-syntax (check-expect stx) - (unless (check-context?) - (raise-syntax-error 'check-expect CHECK-EXPECT-DEFN-STR stx)) - (syntax-case stx () - [(_ test actual) - (check-expect-maker stx #'check-values-expected #`test (list #`actual) - 'comes-from-check-expect)] - [_ (raise-syntax-error 'check-expect CHECK-EXPECT-STR stx)])) - -;; check-values-expected: (-> scheme-val) scheme-val src test-object -> void -(define (check-values-expected test actual src test-info) - (error-check (lambda (v) (if (number? v) (exact? v) #t)) - actual INEXACT-NUMBERS-FMT #t) - (error-check (lambda (v) (not (procedure? v))) actual FUNCTION-FMT #f) - (send (send test-info get-info) add-check) - (run-and-check (lambda (v1 v2 _) (beginner-equal? v1 v2)) - (lambda (src format v1 v2 _) (make-unequal src format v1 v2)) - test actual #f src test-info 'check-expect)) - -;;check-within -(define-syntax (check-within stx) - (unless (check-context?) - (raise-syntax-error 'check-within CHECK-WITHIN-DEFN-STR stx)) - (syntax-case stx () - [(_ test actual within) - (check-expect-maker stx #'check-values-within #`test (list #`actual #`within) - 'comes-from-check-within)] - [_ (raise-syntax-error 'check-within CHECK-WITHIN-STR stx)])) - -;; check-values-within: (-> scheme-val) scheme-val number src test-object -> void -(define (check-values-within test actual within src test-info) - (error-check number? within CHECK-WITHIN-INEXACT-FMT #t) - (error-check (lambda (v) (not (procedure? v))) actual CHECK-WITHIN-FUNCTION-FMT #f) - (send (send test-info get-info) add-check) - (run-and-check beginner-equal~? make-outofrange test actual within src - test-info - 'check-within)) - -;; check-error -(define-syntax (check-error stx) - (unless (check-context?) - (raise-syntax-error 'check-error CHECK-ERROR-DEFN-STR stx)) - (syntax-case stx () - [(_ test error) - (check-expect-maker stx #'check-values-error #`test (list #`error) - 'comes-from-check-error)] - [_ (raise-syntax-error 'check-error CHECK-ERROR-STR stx)])) - -;; check-values-error: (-> scheme-val) scheme-val src test-object -> void -(define (check-values-error test error src test-info) - (error-check string? error CHECK-ERROR-STR-FMT #t) - (send (send test-info get-info) add-check) - (let ([result (with-handlers ([exn? - (lambda (e) - (or (equal? (exn-message e) error) - (make-incorrect-error src (test-format) error - (exn-message e) e)))]) - (let ([test-val (test)]) - (make-expected-error src (test-format) error test-val)))]) - (if (check-fail? result) - (begin - (send (send test-info get-info) check-failed - result (check-fail-src result) - (and (incorrect-error? result) (incorrect-error-exn result))) - #f) - #t))) - - -;;error-check: (scheme-val -> boolean) format-string boolean) -> void : raise exn:fail:contract -(define (error-check pred? actual fmt fmt-act?) - (unless (pred? actual) - (raise (make-exn:fail:contract (if fmt-act? (format fmt actual) fmt) - (current-continuation-marks))))) - -;;check-member-of -(define-syntax (check-member-of stx) - (unless (check-context?) - (raise-syntax-error 'check-member-of CHECK-EXPECT-DEFN-STR stx)) - (syntax-case stx () - [(_ test actual actuals ...) - (check-expect-maker stx #'check-member-of-values-expected #`test (list #`actual #`(list actuals ...)) - 'comes-from-check-member-of)] - [_ (raise-syntax-error 'check-member-of CHECK-MEMBER-OF-STR stx)])) - -;; check-member-of-values-expected: (-> scheme-val) scheme-val src test-object -> void -(define (check-member-of-values-expected test first-actual actuals src test-info) - (error-check (lambda (v) (not (procedure? v))) first-actual CHECK-MEMBER-OF-FUNCTION-FMT #f) - (send (send test-info get-info) add-check) - (run-and-check (lambda (v2 v1 _) (memf (lambda (i) (beginner-equal? v1 i)) v2)) - (lambda (src format v1 v2 _) (make-not-mem src format v1 v2)) - test (cons first-actual actuals) #f src test-info 'check-member-of)) - -;;check-range -(define-syntax (check-range stx) - (unless (check-context?) - (raise-syntax-error 'check-member-of CHECK-EXPECT-DEFN-STR stx)) - (syntax-case stx () - [(_ test min max) - (check-expect-maker stx #'check-range-values-expected #`test (list #`min #`max) - 'comes-from-check-range)] - [_ (raise-syntax-error 'check-range CHECK-RANGE-STR stx)])) - -;; check-range-values-expected: (-> scheme-val) scheme-val src test-object -> void -(define (check-range-values-expected test min max src test-info) - (error-check number? min RANGE-MIN-FMT #t) - (error-check number? max RANGE-MAX-FMT #t) - (error-check (lambda (v) (not (procedure? v))) min CHECK-RANGE-FUNCTION-FMT #f) - (error-check (lambda (v) (not (procedure? v))) max CHECK-RANGE-FUNCTION-FMT #f) - (send (send test-info get-info) add-check) - (run-and-check (lambda (v2 v1 v3) (and (number? v1) (and (<= v2 v1) (<= v1 v3)))) - (lambda (src format v1 v2 v3) (make-not-range src format v1 v2 v3)) - test min max src test-info 'check-range)) - - -;; run-and-check: (scheme-val scheme-val scheme-val -> boolean) -;; (src format scheme-val scheme-val scheme-val -> check-fail) -;; ( -> scheme-val) scheme-val scheme-val object symbol? -> void -(define (run-and-check check maker test expect range src test-info kind) - (match-let ([(list result result-val exn) - (with-handlers ([exn:fail? - (lambda (e) - (let ([display (error-display-handler)]) - (list (make-unexpected-error src (test-format) expect - (exn-message e) - e) - 'error - e)))]) - (let ([test-val (test)]) - (cond [(check expect test-val range) (list #t test-val #f)] - [else - (list (maker src (test-format) test-val expect range) test-val #f)])))]) - (cond [(check-fail? result) - (send (send test-info get-info) check-failed result (check-fail-src result) exn) - (if exn - (raise exn) - #f)] - [else - #t]))) - -(define (builder) - (let ([te (build-test-engine)]) - (namespace-set-variable-value! 'test~object te (current-namespace)) - te)) - -(define-syntax (test stx) - (syntax-case stx () - [(_) - (syntax-property - #'(test*) - 'test-call #t)])) - -(define (test*) - (dynamic-wind - values - (lambda () (run-tests)) - (lambda () (display-results)))) - -(define-syntax (run-tests stx) - (syntax-case stx () - [(_) - (syntax-property - #'(run) - 'test-call #t)])) - -(define (run) - (let ([test-info - (namespace-variable-value 'test~object #f builder (current-namespace))]) - (and test-info (send test-info run)))) - -(define (display-results*) - (let ([test-info (namespace-variable-value 'test~object #f builder (current-namespace))]) - (and test-info - (let ([display-data (scheme-test-data)]) - (when (caddr display-data) - (send test-info refine-display-class (caddr display-data))) - (send test-info setup-display (car display-data) (cadr display-data)) - (send test-info summarize-results (current-output-port)))))) - -(define-syntax (display-results stx) - (syntax-case stx () - [(_) - (syntax-property - #'(display-results*) - 'test-call #t)])) - -(provide run-tests display-results test builder) - -(define (build-test-engine) - (let ([engine (make-object scheme-test%)]) - (send engine setup-info 'test-check) - engine)) - -(define (insert-test test-info test) (send test-info add-test test)) - -(define scheme-test-data (make-parameter (list #f #f #f))) - -(define scheme-test% - (class* test-engine% () - (super-instantiate ()) - (inherit-field test-info test-display) - (inherit setup-info) - - (field [tests null] - [test-objs null]) - - (define/public (add-test tst) - (set! tests (cons tst tests))) - (define/public (get-info) - (unless test-info (send this setup-info 'check-require)) - test-info) - (define/public (reset-info) - (set! tests null) - #;(send this setup-info 'check-require)) - - (define/augment (run) - (inner (void) run) - (for ([t (reverse tests)]) (run-test t))) - - (define/augment (run-test test) - (test) - (inner (void) run-test test)))) - -(provide scheme-test-data test-format test-execute test-silence error-handler) +#lang racket/base +(require "racket-tests.rkt") +(provide (all-from-out "racket-tests.rkt")) \ No newline at end of file diff --git a/collects/test-engine/test-engine.scrbl b/collects/test-engine/test-engine.scrbl index 3e0bb26b34..760961aa10 100644 --- a/collects/test-engine/test-engine.scrbl +++ b/collects/test-engine/test-engine.scrbl @@ -1,8 +1,8 @@ #lang scribble/doc @(require scribble/manual - (for-label scheme/base - test-engine/scheme-tests - (prefix-in gui: test-engine/scheme-gui))) + (for-label racket/base + test-engine/racket-tests + (prefix-in gui: test-engine/racket-gui))) @title{Test Support} @@ -14,7 +14,7 @@ @section{Using Check Forms} -@defmodule[test-engine/scheme-tests] +@defmodule[test-engine/racket-tests] This module provides test forms for use in Racket programs, as well as parameters to configure the behavior of test reports. @@ -22,7 +22,7 @@ as parameters to configure the behavior of test reports. Each check form may only occur at the top-level; results are collected and reported by the test function. Note that the check forms only register checks to be performed. The checks are actually run by the -@scheme[test] function. +@racket[test] function. @defproc[(check-expect (test any/c) (expected any/c)) void?]{ @@ -34,7 +34,7 @@ It is an error to produce a function value or an inexact number.} @defproc[(check-within (test any/c) (expected any/c) (delta number?)) void?]{ -Like @scheme[check-expect], but with an extra expression that produces +Like @racket[check-expect], but with an extra expression that produces a number delta. Every number in the first expression must be within delta of the cooresponding number in the second expression. @@ -85,14 +85,14 @@ suppress evaluation of test expressions. @section{GUI Interface} -@defmodule[test-engine/scheme-gui] +@defmodule[test-engine/racket-gui] @; FIXME: need to actually list the bindings here, so they're found in @; the index This module requires GRacket and produces an independent window when displaying test results. It provides the same bindings as -@scheme[test-engine/scheme-tests]. +@racket[test-engine/racket-tests]. @section{Integrating languages with Test Engine} diff --git a/collects/typed/test-engine/racket-tests.rkt b/collects/typed/test-engine/racket-tests.rkt new file mode 100644 index 0000000000..d5ec9e48bc --- /dev/null +++ b/collects/typed/test-engine/racket-tests.rkt @@ -0,0 +1,5 @@ +#lang scheme/base + +(require test-engine/racket-tests + "type-env-ext.ss") +(provide (all-from-out test-engine/racket-tests)) \ No newline at end of file diff --git a/collects/typed/test-engine/type-env-ext.rkt b/collects/typed/test-engine/type-env-ext.rkt index 2e1fa26fde..9ac8bfa0d7 100644 --- a/collects/typed/test-engine/type-env-ext.rkt +++ b/collects/typed/test-engine/type-env-ext.rkt @@ -1,7 +1,7 @@ #lang scheme/base (require typed-scheme/utils/utils - (prefix-in ce: test-engine/scheme-tests) + (prefix-in ce: test-engine/racket-tests) (for-syntax scheme/base syntax/parse (utils tc-utils)