suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source 
Give those functions types.

svn: r17519
This commit is contained in:
Sam Tobin-Hochstadt 2010-01-06 23:03:08 +00:00
parent a7b8ff1313
commit c7cb124c95
5 changed files with 82 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/test-engine/scheme-gui.ss
View File

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

35
collects/test-engine/scheme-tests.ss
View File

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

6
collects/tests/typed-scheme/fail/check-expect-fail.ss Normal file
View File

@ -0,0 +1,6 @@
#lang typed/scheme
(require test-engine/scheme-tests)
(check-expect 3 (+ 1 'foo))
(test)

6
collects/tests/typed-scheme/succeed/check-expect.ss Normal file
View File

@ -0,0 +1,6 @@
#lang typed/scheme
(require test-engine/scheme-tests)
(check-expect 3 4)
(test)

58
collects/typed-scheme/private/base-special-env.ss
View File

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