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

working on check-within...

Browse Source 
svn: r9579
This commit is contained in:
John Clements 2008-05-01 23:49:45 +00:00
parent ee9fc4a8d7
commit fe552e2483
1 changed files with 47 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -48,43 +48,47 @@
;; (make-expected-error src string scheme-val) ;; (make-expected-error src string scheme-val)
(define-struct (expected-error check-fail) (message value)) (define-struct (expected-error check-fail) (message value))
;; make-src-info : syntax? -> syntax?
;; ... lifting out a shared piece of the annotations.
;; Apparently this must textually precede its use.
(define-for-syntax (make-src-info stx)
(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)))))
(define-syntax (check-expect stx) (define-syntax (check-expect stx)
(syntax-case stx () (syntax-case stx ()
[(_ test actual) [(_ test actual)
(not (eq? (syntax-local-context) 'expression)) (not (eq? (syntax-local-context) 'expression))
(with-syntax ([src-info (make-src-info stx)])
(quasisyntax/loc stx (quasisyntax/loc stx
(define #,(stepper-syntax-property #`#,(gensym 'test) 'stepper-hint 'comes-from-check-expect) (define #,(stepper-syntax-property #`#,(gensym 'test) 'stepper-hide-completed #t)
#,(stepper-syntax-property #,(stepper-syntax-property
#`(let ([test-info (namespace-variable-value #`(let ([test-info (namespace-variable-value
'test~object #f builder (current-namespace))]) 'test~object #f builder (current-namespace))])
(when test-info (when test-info
(insert-test test-info (insert-test test-info
(lambda () (lambda ()
#,(stepper-syntax-property #,(with-stepper-syntax-properties
(['stepper-hint 'comes-from-check-expect]
['stepper-hide-reduction #t])
(quasisyntax/loc stx (quasisyntax/loc stx
(check-values-expected (check-values-expected
(lambda () test) (lambda () test)
actual actual
#,(stepper-syntax-property src-info
#`(list #,@(list #`(quote #,(syntax-source stx)) #,(with-stepper-syntax-properties (['stepper-no-lifting-info #t]
(syntax-line stx) ['stepper-hide-reduction #t])
(syntax-column stx) #'test-info))))))))
(syntax-position stx)
(syntax-span stx)))
'stepper-skip-completely
#t)
#,(stepper-syntax-property
(stepper-syntax-property #`test-info `stepper-no-lifting-info #t)
'stepper-hint
'comes-from-check-expect)))
'stepper-hint
'comes-from-check-expect)))))
`stepper-skipto `stepper-skipto
(append skipto/third ;; let (append skipto/third ;; let
skipto/third skipto/second ;; unless (it expands into a begin) skipto/third skipto/second ;; unless (it expands into a begin)
skipto/cdr skipto/third ;; application of insert-test skipto/cdr skipto/third ;; application of insert-test
'(syntax-e cdr cdr syntax-e car) ;; lambda '(syntax-e cdr cdr syntax-e car) ;; lambda
))))] )))))]
[(_ test) [(_ test)
(not (eq? (syntax-local-context) 'expression)) (not (eq? (syntax-local-context) 'expression))
(raise-syntax-error 'check-expect CHECK-EXPECT-STR stx)] (raise-syntax-error 'check-expect CHECK-EXPECT-STR stx)]
@ -108,21 +112,31 @@
(syntax-case stx () (syntax-case stx ()
[(_ test actual within) [(_ test actual within)
(not (eq? (syntax-local-context) 'expression)) (not (eq? (syntax-local-context) 'expression))
(quasisyntax/loc stx (with-syntax ([bogus-name (stepper-syntax-property #`#,(gensym 'test-within) 'stepper-hint 'stepper-hide-completed)]
(define #,(gensym 'test-within) [src-info (make-src-info stx)])
(let ([test-info (namespace-variable-value (quasisyntax/loc stx
'test~object #f builder (current-namespace))]) (define bogus-name
(when test-info #,(stepper-syntax-property
(insert-test test-info #`(let ([test-info (namespace-variable-value
(lambda () 'test~object #f builder (current-namespace))])
(check-values-within (when test-info
(lambda () test) actual within (insert-test test-info
(list #,@(list #`(quote #,(syntax-source stx)) (lambda ()
(syntax-line stx) #,(with-stepper-syntax-properties (['stepper-hint 'comes-from-check-expect]
(syntax-column stx) ['stepper-hide-reduction #t])
(syntax-position stx) (quasisyntax/loc stx
(syntax-span stx))) (check-values-within
test-info)))))))] (lambda () test) actual within
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
)))))]
[(_ test actual) [(_ test actual)
(not (eq? (syntax-local-context) 'expression)) (not (eq? (syntax-local-context) 'expression))
(raise-syntax-error 'check-within CHECK-WITHIN-STR stx)] (raise-syntax-error 'check-within CHECK-WITHIN-STR stx)]
@ -182,6 +196,7 @@
(send (send test-info get-info) check-failed (send (send test-info get-info) check-failed
(check->message result) (check-fail-src result))))) (check->message result) (check-fail-src result)))))
(define (error-check pred? actual fmt) (define (error-check pred? actual fmt)
(unless (pred? actual) (unless (pred? actual)
(raise (make-exn:fail:contract (format fmt actual) (raise (make-exn:fail:contract (format fmt actual)