From d999a7c3bae861b680954d7d900f860e6b28057b Mon Sep 17 00:00:00 2001 From: Kathy Gray Date: Fri, 3 Apr 2009 21:00:25 +0000 Subject: [PATCH] Putting check ... inspect ... in part ii --- a working subset, sufficient for a demo svn: r14417 --- collects/profj/check.ss | 13 +++- collects/profj/libs/java/runtime.ss | 94 +++++++++++++++++++++----- collects/profj/to-scheme.ss | 73 ++++++++++++++++++-- collects/tests/profj/TestEngineTest.ss | 3 - 4 files changed, 159 insertions(+), 24 deletions(-) diff --git a/collects/profj/check.ss b/collects/profj/check.ss index dbd004c330..1cdc4453fe 100644 --- a/collects/profj/check.ss +++ b/collects/profj/check.ss @@ -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 diff --git a/collects/profj/libs/java/runtime.ss b/collects/profj/libs/java/runtime.ss index a57c401a03..5a2cadfb83 100644 --- a/collects/profj/libs/java/runtime.ss +++ b/collects/profj/libs/java/runtime.ss @@ -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)) diff --git a/collects/profj/to-scheme.ss b/collects/profj/to-scheme.ss index a576ab0dd9..7186046b9e 100644 --- a/collects/profj/to-scheme.ss +++ b/collects/profj/to-scheme.ss @@ -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...) diff --git a/collects/tests/profj/TestEngineTest.ss b/collects/tests/profj/TestEngineTest.ss index 6a7d25f826..504c1dd714 100644 --- a/collects/tests/profj/TestEngineTest.ss +++ b/collects/tests/profj/TestEngineTest.ss @@ -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")