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

Putting check ... inspect ... in part ii --- a working subset, sufficient for a demo

Browse Source 
svn: r14417
This commit is contained in:
Kathy Gray 2009-04-03 21:00:25 +00:00
parent 6d302a9304
commit d999a7c3ba
4 changed files with 159 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
collects/profj/check.ss
View File

@ -3024,11 +3024,22 @@
(add-var-to-env "result" command-type final-method-var env-p))])
(parameterize ([inspect-test? #t] [snaps null])
(let ([posts/te (check-e posts env-posts)])
(set-check-inspect-snaps! exp (snaps))
(set-check-inspect-snaps! exp (remove-dup-snaps (snaps)))
(unless (eq? 'boolean (type/env-t posts/te))
(check-inspect-post-error (type/env-t posts/te) (expr-src posts)))
;SKIPS RANGE FOR NOW
(make-type/env 'boolean (remove-var-from-env "result" (type/env-e posts/te)))))))
(define (remove-dup-snaps snaps)
(cond
[(null? snaps) snaps]
[(snap-member? (car snaps) (cdr snaps)) (remove-dup-snaps (cdr snaps))]
[else (cons (car snaps) (remove-dup-snaps (cdr snaps)))]))
(define (snap-member? snap snaps)
(cond
[(null? snaps) #f]
[(equal? (snap-name snap) (snap-name (car snaps))) #t]
[else (snap-member? snap (cdr snaps))]))
;check-test-effect: (list access) (list exp) (list exp) (exp env -> type/env) env src type-records -> type/env

94
collects/profj/libs/java/runtime.ss
View File

@ -354,11 +354,29 @@
(set! fail? #t)
(list exception #t e "eval"))])
(test)))
(let ([res (if fail? #f (check test))])
(if (in-check-mutate?)
(stored-checks (cons (list res 'check-inspect info null src) (stored-checks)))
(report-check-result res 'check-inspect info null src test-obj))
res)))
(let ([res (if fail? (list #f 'exn-fail test) (check test))])
(cond
[(eq? 'oror (cadr res))
(cond
[(car res)
(report-check-result (car res) 'check-inspect info (list 'or (caddr res)) src test-obj)
(car res)]
[else
(let ([right-res ((cadddr res))])
(report-check-result (car right-res) 'check-inspect info (list 'or (caddr res) (caddr right-res)) src test-obj)
(car right-res))])]
[(eq? '&& (cadr res))
(cond
[(car res)
(let ([right-res ((cadddr res))])
(report-check-result (car right-res) 'check-inspect info (list 'and (caddr res) (caddr right-res)) src test-obj)
(car right-res))]
[else
(report-check-result (car res) 'check-inspect info (list 'and (caddr res)) src test-obj)
(car res)])]
[else
(report-check-result (car res) 'check-inspect info (cdr res) src test-obj)
(car res)]))))
;check-effects: (-> (listof val)) (-> (listof val)) (list string) src object -> boolean
(define (check-effect tests checks info src test-obj)
@ -375,22 +393,24 @@
(compose-message test-obj check-kind info values #f)
src #f))))
;compose-message: object symbol (list symbol strings) (listof value) boolean -> (listof string)
(define (compose-message test-obj check-kind info values mutate-message)
(letrec ([test-format (construct-info-msg info)]
[eval-exception-raised? #f]
[comp-exception-raised? #f]
[exception-not-error? #f]
[formatted-values (map (lambda (v)
(cond
[(and (pair? v) (eq? (car v) exception))
(if (equal? (cadddr v) "eval")
(set! eval-exception-raised? #t)
(set! comp-exception-raised? #t))
(set! exception-not-error? (cadr v))
(send test-obj format-value (caddr v))]
[(pair? v)
(map (lambda (v) (send test-obj format-value v)) v)]
[else (send test-obj format-value v)])) values)]
[formater (lambda (v)
(cond
[(and (pair? v) (eq? (car v) exception))
(if (equal? (cadddr v) "eval")
(set! eval-exception-raised? #t)
(set! comp-exception-raised? #t))
(set! exception-not-error? (cadr v))
(send test-obj format-value (caddr v))]
[(pair? v)
(map (lambda (v) (send test-obj format-value v)) v)]
[else (send test-obj format-value v)]))]
[formatted-values (unless (eq? 'check-inspect check-kind) (map formater values))]
[expected-format
(case check-kind
((check-expect check-by) "to produce ")
@ -398,6 +418,29 @@
((check-inspect) "to satisfy the post-conditions given ")
((check-catch) "to throw an instance of "))])
(cond
[(eq? 'check-inspect check-kind)
(append (list "check expected "
test-format
"to satisfy the given post-condition.\n ")
(case (car values)
[(< <= > >= ==)
(append (cons "The comparison of " (construct-value-message (cadr values) formater))
(cons " with " (construct-value-message (caddr values) formater))
(list (format " by ~a failed." (car values))))]
[(and)
(cond
[(> (length (cdr values)) 1)
(append
(cons "Both conditions were false because "
(construct-value-message (cadr values) formater))
(cons " and "
(construct-value-message (caddr values) formater)))]
[else (cons "The first condition was false because " (construct-value-message (cadr values) formater))])]
[(or)
(cons "Neither condition was true because "
(append (construct-value-message (cadr values) formater)
(construct-value-message (caddr values) formater)))]
[else (list "")]))]
[(not (eq? 'check-by check-kind))
(append (list (if mutate-message mutate-message "check expected ")
test-format
@ -481,6 +524,25 @@
((assignment) (format "the assignment of ~a" (construct-info-msg (cdr info))))
((value) "value ")))
(define (construct-value-message val-list format-v)
(case (first val-list)
[(local) (list "local variable " (format-v (cadr val-list)) " was "
(format-v (caddr val-list)))]
[(lit) (list (format-v (cadr val-list)))]
[(field-old)
(list "old value of field " (format-v (caddr val-list)) " in " (format-v (cadr val-list)))]
[(field-access)
(append (list "value of field " (format-v (caddr val-list)) " in " )
(construct-value-message (cadr val-list) format-v))]
[(< > <= >= ==)
(append (list "comparison of ")
(construct-value-message (cadr val-list) format-v)
(list " with ")
(construct-value-message (caddr val-list) format-v)
(list (format "by ~a failed" (first val-list))))]
[else "unimplemented support"]))
;array->list: java-array -> (list 'a)
(define (array->list v)
(letrec ((len (send v length))

73
collects/profj/to-scheme.ss
View File

@ -1150,6 +1150,19 @@
(hash-set! field-map field value)
value)
(define/public (my-name) (send o my-name))
(define/public (fields-for-display)
(let ((field-name-list (send o field-names))
(field-value-list (send o field-values)))
(lambda ()
(if (null? field-name-list)
#f
(begin0 (list (car field-name-list)
(or (hash-ref field-map
(string->symbol (string-append (car field-name-list) "~f"))
#f)
(car field-value-list)))
(set! field-name-list (cdr field-name-list))
(set! field-value-list (cdr field-value-list)))))))
,@(generate-stm-fields fields)
,@(generate-stm-methods methods))))
#f))
@ -3142,11 +3155,11 @@
(define inspect-test? (make-parameter #f))
;IGNORES RANGE
;IGNORES COLLECTING PRINTING INFORMATION
;translate-check-inspect: expr expr (U #f expr) (listof snap) src -> syntax
(define (translate-check-inspect val post range snaps src)
(let ([command (create-syntax #f `(lambda () ,(translate-expression val)) #f)]
[post (create-syntax #f `(lambda (result~f) ,(parameterize ([inspect-test? #t]) (translate-expression post))) #f)])
[post (create-syntax #f `(lambda (result~f)
,(parameterize ([inspect-test? #t]) (translate-post-conds post))) #f)])
(make-syntax #f
`(let (,@(apply
append
@ -3166,10 +3179,62 @@
obj@)])))))
snaps)))
(javaRuntime:check-inspect ,command ,post
'test-info (quote ,(src->list src))
,(checked-info val)
(quote ,(src->list src))
(namespace-variable-value 'current~test~object% #f (lambda () #f))))
(build-src src))))
;translate-post-conds: expr -> syntax
(define (translate-post-conds exp)
(create-syntax #f
(cond
[(bin-op? exp)
(case (bin-op-op exp)
[(oror &&)
`(list ,(translate-expression (bin-op-left exp))
(quote ,(bin-op-op exp))
,(extract-report (bin-op-left exp))
(lambda ()
,(translate-post-conds (bin-op-right exp))))]
[else
`(list ,(translate-expression exp)
(quote ,(bin-op-op exp))
,(extract-report (bin-op-left exp))
,(extract-report (bin-op-right exp)))])]
[(call? exp)
`(list ,(translate-expression exp)
'call ,(id-string (call-method-name exp))
,(extract-report (call-expr exp))
,@(map extract-report (call-args exp)))]
[else `(list ,(translate-expression exp) 'other null)])
#f))
;extract-report: expr -> (listof syntax)
(define (extract-report exp)
(cond
[(and (access? exp) (local-access? (access-name exp)))
`(list 'local ,(id-string (local-access-name (access-name exp))) ,(translate-expression exp))]
[(and (access? exp) (field-access? (access-name exp)))
(if (old-call? (field-access-object (access-name exp)))
`(list 'field-old ,(old-var (field-access-object (access-name exp)))
,(id-string (field-access-field (access-name exp))))
`(list 'field-access ,(extract-report (field-access-object (access-name exp)))
,(id-string (field-access-field (access-name exp)))))]
[(literal? exp) `(list (quote lit) ,(translate-expression exp))]
[(call? exp) '...]
[(array-access? exp) '...]
[(bin-op? exp) `(list (quote ,(bin-op-op exp)) ,(extract-report (bin-op-left exp))
,(extract-report (bin-op-right exp)))]))
;old-call? exp -> bool
(define (old-call? exp)
(and (call? exp)
(eq? 'test-method-old (call-method-record exp))))
;old-var: exp -> syntax
(define (old-var exp) (translate-expression exp))
;translate-check-effect: (listof access) (listof expression) (listof expression) src -> syntax
(define (translate-check-effect ids conds test src)
(let ([cs (map (lambda (c) (create-syntax #f `(lambda () ,(translate-expression c)) #f)) conds)]
@ -3197,7 +3262,7 @@
(namespace-variable-value 'current~test~object% #f
(lambda () #f))))
(build-src src))))
(require "error-messaging.ss")
;checked-info: expression -> (list sym string...)

3
collects/tests/profj/TestEngineTest.ss
View File

@ -10,7 +10,6 @@
(check-expect (count 3) 3) ; fails
(check-expect (count 3) 4)
(check-expect (count (/ 1 0)) 2) ; fails
(check-within 1.345 1.3 .05)
(check-within 1.345 1.3 .005) ; fails
@ -18,7 +17,6 @@
(check-expect (cons 1 (cons 2 (cons 3 empty))) (cons 2 (cons 2 (cons 2 empty)))) ;fails
(check-expect (cons 1 (cons 2 (cons 3 empty))) empty) ;fails
(check-expect (cons 1 (cons 2 (cons 3 empty))) (cons 1 (cons 2 (cons 3 empty))))
(check-expect (first empty) empty) ;fails
(check-within (cons 1 (cons 2 (cons 3 empty))) (cons 1.1 (cons 2.1 (cons 3.1 empty))) .2)
(check-within (cons 1 (cons 2 (cons 3 empty))) (cons 1.1 (cons 2.1 (cons 3.1 empty))) .01) ;fails
@ -39,7 +37,6 @@
(check-expect (make-ball 3 (make-posn 1 2) "blue") (make-ball (make-posn 1 2) 3.3 "blue")) ;fails
(check-within (make-ball (make-posn 1 3) 3.4 "blue") (make-ball (make-posn 1 3) 3.3 "blue") .1)
(check-within (make-ball (make-posn 1 3) 3.4 "blue") (make-ball (make-posn 1 3) 3.3 "blue") .01) ;fails
(check-expect (posn-x (ball-point 3)) 3) ;fails
(check-error (error 'test "hi") "test: hi")
(check-error (/ 1 0) "/: division by zero")