Put dynamic behavior of `check-expect' into functions.

Give those functions types.

svn: r17519

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)

collects/test-engine/scheme-tests.ss

@@ -292,32 +292,41 @@
   (syntax-case stx ()
     [(_)
      (syntax-property
-      #'(dynamic-wind
+      #'(test*)
-	    values
-	    (lambda () (run-tests))
-	    (lambda () (display-results)))
       '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))])
+      #'(display-results*)
-          (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)))))
       'test-call #t)]))
 
 (provide run-tests display-results test builder)

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)

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)

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)])