diff --git a/collects/test-engine/scheme-gui.ss b/collects/test-engine/scheme-gui.ss index f67b988755..d0d7fef8b1 100644 --- a/collects/test-engine/scheme-gui.ss +++ b/collects/test-engine/scheme-gui.ss @@ -33,11 +33,15 @@ text-snip))] [else (format "~v" value)])) + (define (test*) + (run-tests) + (pop-up)) + (define-syntax (test stx) (syntax-case stx () [(_) (syntax-property - #'(begin (run-tests) (pop-up)) + #'(test*) 'test-call #t)])) (define (pop-up) diff --git a/collects/test-engine/scheme-tests.ss b/collects/test-engine/scheme-tests.ss index dabe0ee492..319350bd98 100644 --- a/collects/test-engine/scheme-tests.ss +++ b/collects/test-engine/scheme-tests.ss @@ -292,32 +292,41 @@ (syntax-case stx () [(_) (syntax-property - #'(dynamic-wind - values - (lambda () (run-tests)) - (lambda () (display-results))) + #'(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 (namespace-variable-value 'test~object #f builder (current-namespace))) + #'(run) 'test-call #t)])) -(define (run test-info) (and test-info (send test-info run))) +(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 - #'(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))))) + #'(display-results*) 'test-call #t)])) (provide run-tests display-results test builder) diff --git a/collects/tests/typed-scheme/fail/check-expect-fail.ss b/collects/tests/typed-scheme/fail/check-expect-fail.ss new file mode 100644 index 0000000000..92b38e8a25 --- /dev/null +++ b/collects/tests/typed-scheme/fail/check-expect-fail.ss @@ -0,0 +1,6 @@ +#lang typed/scheme + +(require test-engine/scheme-tests) +(check-expect 3 (+ 1 'foo)) + +(test) diff --git a/collects/tests/typed-scheme/succeed/check-expect.ss b/collects/tests/typed-scheme/succeed/check-expect.ss new file mode 100644 index 0000000000..dddc43afae --- /dev/null +++ b/collects/tests/typed-scheme/succeed/check-expect.ss @@ -0,0 +1,6 @@ +#lang typed/scheme + +(require test-engine/scheme-tests) +(check-expect 3 4) + +(test) diff --git a/collects/typed-scheme/private/base-special-env.ss b/collects/typed-scheme/private/base-special-env.ss index 0e5de96260..187da6e51d 100644 --- a/collects/typed-scheme/private/base-special-env.ss +++ b/collects/typed-scheme/private/base-special-env.ss @@ -9,20 +9,18 @@ '#%paramz (only-in scheme/match/runtime match:error) scheme/promise - string-constants/string-constant) + string-constants/string-constant + (prefix-in ce: test-engine/scheme-tests) + (for-syntax + scheme/base syntax/parse + (utils tc-utils) + (env init-envs) + (except-in (rep filter-rep object-rep type-rep) make-arr) + (types convenience union) + (only-in (types convenience) [make-arr* make-arr]) + (typecheck tc-structs))) - -;; these are all for constructing the types given to variables -(require (for-syntax - scheme/base - (utils tc-utils) - (env init-envs) - (except-in (rep filter-rep object-rep type-rep) make-arr) - (types convenience union) - (only-in (types convenience) [make-arr* make-arr]) - (typecheck tc-structs))) - (define-for-syntax (initialize-others) (d-s srcloc ([source : Univ] @@ -46,7 +44,7 @@ (define-syntax (define-initial-env stx) (syntax-case stx () - [(_ initial-env make-promise-ty language-ty qq-append-ty [id ty] ...) + [(_ initial-env make-promise-ty language-ty qq-append-ty cl ...) (with-syntax ([(_ make-promise . _) (local-expand #'(delay 3) 'expression @@ -64,7 +62,7 @@ [make-promise make-promise-ty] [language language-ty] [qq-append qq-append-ty] - [id ty] ...)))])) + cl ...)))])) @@ -78,7 +76,37 @@ (-poly (a b) (cl->* (-> (-lst a) (-val '()) (-lst a)) - (-> (-lst a) (-lst b) (-lst (*Un a b)))))) + (-> (-lst a) (-lst b) (-lst (*Un a b))))) + [(syntax-parse (local-expand #'(ce:test) 'expression null) + #:context #'ce:test + [(_ ce-t:id) #'ce-t]) + (-> -Void)] + + [(syntax-parse (local-expand #'(ce:check-expect 1 1) 'module #f) + #:literals (let when define-values) + [(define-values _ + (let ((_ _)) + (when _ + (insert-test _ (lambda () (check-values-expected _ _ _ _)))))) + #'insert-test]) + (Univ (-> Univ) . -> . -Void)] + [(syntax-parse (local-expand #'(ce:check-expect 1 1) 'module #f) + #:literals (let when define-values) + ;#:literal-sets (kernel-literals) + [(define-values _ + (let ((_ _)) + (when _ + (insert-test _ (lambda () (check-values-expected _ _ _ _)))))) + #'check-values-expected]) + ((-> Univ) Univ Univ Univ . -> . -Void)] + [(syntax-parse (local-expand #'(ce:check-expect 1 1) 'module #f) + #:literals (let when define-values) + ;#:literal-sets (kernel-literals) + [(define-values _ + (let ((_ (nvv _ _ builder _))) + _)) + #'builder]) + (-> Univ)])