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

fix check-satisfied to properly deal with errors in predicate check

Browse Source
This commit is contained in:
Matthias Felleisen 2014-10-14 15:35:53 -04:00
parent ef76c273ea
commit da98d60f99
4 changed files with 82 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

101
pkgs/htdp-pkgs/htdp-lib/test-engine/racket-tests.rkt
View File

@ -174,14 +174,14 @@
(syntax-case stx () (syntax-case stx ()
[(check-random e1 e2) [(check-random e1 e2)
(let ([test (let ([test
#`(lambda (rng k) #`(lambda (rng k)
(parameterize ((current-pseudo-random-generator rng)) (random-seed k) (parameterize ((current-pseudo-random-generator rng)) (random-seed k)
e1))] e1))]
[actuals [actuals
(list (list
#`(lambda (rng k) #`(lambda (rng k)
(parameterize ((current-pseudo-random-generator rng)) (random-seed k) (parameterize ((current-pseudo-random-generator rng)) (random-seed k)
e2)))]) e2)))])
(check-expect-maker stx #'check-random-values test actuals 'comes-from-check-expect))] (check-expect-maker stx #'check-random-values test actuals 'comes-from-check-expect))]
[_ (raise-syntax-error 'check-random (argcount-error-message/stx 2 stx) stx)])) [_ (raise-syntax-error 'check-random (argcount-error-message/stx 2 stx) stx)]))
@ -189,11 +189,13 @@
(syntax-case stx () (syntax-case stx ()
[(_ actual:exp expected-property:exp) [(_ actual:exp expected-property:exp)
(identifier? #'expected-property:exp) (identifier? #'expected-property:exp)
(check-expect-maker stx (begin
#'check-values-property (check-expect-maker stx
#'(lambda (x) (expected-property:exp x)) #'check-values-property
(list #'actual:exp (symbol->string (syntax-e #'expected-property:exp))) #'actual:exp
'comes-from-check-satisfied)] (list #'(lambda (x) (expected-property:exp x))
(symbol->string (syntax-e #'expected-property:exp)))
'comes-from-check-satisfied))]
[(_ actual:exp expected-property:exp) [(_ actual:exp expected-property:exp)
(raise-syntax-error 'check-satisfied "expects named function in second position." stx)] (raise-syntax-error 'check-satisfied "expects named function in second position." stx)]
[_ (raise-syntax-error 'check-satisfied (argcount-error-message/stx 2 stx) stx)])) [_ (raise-syntax-error 'check-satisfied (argcount-error-message/stx 2 stx) stx)]))
@ -203,14 +205,18 @@
;; it, but it is possibly weird for students ;; it, but it is possibly weird for students
(send (send test-engine get-info) add-check) (send (send test-engine get-info) add-check)
(run-and-check (run-and-check
(lambda (v p? _what-is-this?) (p? v)) ;; check
(lambda (src format v1 v2 _) (make-satisfied-failed src format v2 property?)) (lambda (p? v _what-is-this?) (p? v))
test ;; maker
actual (lambda (src format v1 v2 _) (make-satisfied-failed src format v2 property?))
#f ;; test
src test
test-engine ;; expect
(list 'check-satisfied property?))) actual
#f
src
test-engine
(list 'check-satisfied property?)))
;; check-values-expected: (-> scheme-val) (-> nat scheme-val) src test-engine -> void ;; check-values-expected: (-> scheme-val) (-> nat scheme-val) src test-engine -> void
(define (check-random-values test actual-maker src test-engine) (define (check-random-values test actual-maker src test-engine)
@ -361,31 +367,42 @@
;; ( -> scheme-val) scheme-val scheme-val test-engine symbol? -> boolean ;; ( -> scheme-val) scheme-val scheme-val test-engine symbol? -> boolean
(define (run-and-check check maker test expect range src test-engine kind) (define (run-and-check check maker test expect range src test-engine kind)
(match-let ([(list result result-val exn) (match-let ([(list result result-val exn)
(with-handlers ([exn:fail:wish? (with-handlers ([exn:fail:wish?
(lambda (e) (lambda (e)
(define display (error-display-handler)) (define display (error-display-handler))
(define name (exn:fail:wish-name e)) (define name (exn:fail:wish-name e))
(define args (exn:fail:wish-args e)) (define args (exn:fail:wish-args e))
(list (unimplemented-wish src (test-format) name args) 'error #f))] (list (unimplemented-wish src (test-format) name args) 'error #f))]
[(lambda (x) [(lambda (x)
(and (exn:fail:contract:arity? x) (and (exn:fail:contract:arity? x)
(pair? kind) (pair? kind)
(eq? 'check-satisfied (car kind)))) (eq? 'check-satisfied (car kind))))
(lambda (_) (lambda (_)
(error-check (lambda (v) #f) (cadr kind) SATISFIED-FMT #t))] (error-check (lambda (v) #f) (cadr kind) SATISFIED-FMT #t))]
[exn:fail? [exn:fail?
(lambda (e) (lambda (e)
(define display (error-display-handler)) (define display (error-display-handler))
(define msg (get-rewriten-error-message e)) (define msg (get-rewriten-error-message e))
(list (make-unexpected-error src (test-format) expect msg e) 'error e))]) (if (and (pair? kind) (eq? 'check-satisfied (car kind)))
(define test-val (test)) (list (unsatisfied-error src (test-format) (cadr kind) msg e)
(cond [(check expect test-val range) (list #t test-val #f)] 'error e)
[else (list (maker src (test-format) test-val expect range) test-val #f)]))]) (list (unexpected-error src (test-format) expect msg e)
'error e)))])
(define test-val (test))
(cond [(check expect test-val range) (list #t test-val #f)]
[else (list (maker src (test-format) test-val expect range)
test-val
#f)]))])
(cond [(check-fail? result) (cond [(check-fail? result)
(send (send test-engine get-info) check-failed result (check-fail-src result) exn) (define c (send test-engine get-info))
(send c check-failed result (check-fail-src result) exn)
(if exn (raise exn) #f)] (if exn (raise exn) #f)]
[else #t]))) [else #t])))
(define (tee x)
(displayln `(tee ,x))
x)
;;Wishes ;;Wishes
(struct exn:fail:wish exn:fail (name args)) (struct exn:fail:wish exn:fail (name args))

11
pkgs/htdp-pkgs/htdp-lib/test-engine/test-display.scm
View File

@ -274,6 +274,11 @@
(print (string-constant test-engine-check-encountered-error) (print (string-constant test-engine-check-encountered-error)
(formatter (unexpected-error-expected fail)) (formatter (unexpected-error-expected fail))
(unexpected-error-message fail))] (unexpected-error-message fail))]
[(unsatisfied-error? fail)
(print
"check-satisfied encountered an error instead of the expected kind of value, ~F. \n :: ~a"
(unsatisfied-error-expected fail)
(unsatisfied-error-message fail))]
[(unequal? fail) [(unequal? fail)
(print (string-constant test-engine-actual-value-differs-error) (print (string-constant test-engine-actual-value-differs-error)
(formatter (unequal-test fail)) (formatter (unequal-test fail))
@ -281,11 +286,7 @@
[(satisfied-failed? fail) [(satisfied-failed? fail)
(print "Actual value ~F does not satisfy ~a." (print "Actual value ~F does not satisfy ~a."
(formatter (satisfied-failed-actual fail)) (formatter (satisfied-failed-actual fail))
(satisfied-failed-name fail)) (satisfied-failed-name fail))]
#;
(print (string-constant test-engine-actual-value-differs-error)
(formatter (unequal-test fail))
(formatter (unequal-actual fail)))]
[(outofrange? fail) [(outofrange? fail)
(print (string-constant test-engine-actual-value-not-within-error) (print (string-constant test-engine-actual-value-not-within-error)
(formatter (outofrange-test fail)) (formatter (outofrange-test fail))

6
pkgs/htdp-pkgs/htdp-lib/test-engine/test-info.scm
View File

@ -13,6 +13,7 @@
;; (make-unexpected-error src format string exn) ;; (make-unexpected-error src format string exn)
(define-struct (unexpected-error check-fail) (expected message exn)) (define-struct (unexpected-error check-fail) (expected message exn))
(define-struct (unsatisfied-error check-fail) (expected message exn))
;; (make-unequal src format scheme-val scheme-val) ;; (make-unequal src format scheme-val scheme-val)
(define-struct (unequal check-fail) (test actual)) (define-struct (unequal check-fail) (test actual))
;; (make-outofrange src format scheme-val scheme-val inexact) ;; (make-outofrange src format scheme-val scheme-val inexact)
@ -140,6 +141,11 @@
(apply print-with-values fstring print-string print-formatted vals))) (apply print-with-values fstring print-string print-formatted vals)))
(formatter (check-fail-format fail))) (formatter (check-fail-format fail)))
(cond (cond
[(unsatisfied-error? fail)
(print
"check-satisfied encountered an error instead of the expected kind of value, ~F. \n :: ~a"
(formatter (unsatisfied-error-expected fail))
(unsatisfied-error-message fail))]
[(unexpected-error? fail) [(unexpected-error? fail)
(print (print
"check-expect encountered the following error instead of the expected value, ~F. \n :: ~a" "check-expect encountered the following error instead of the expected value, ~F. \n :: ~a"

11
pkgs/htdp-pkgs/htdp-test/tests/test-engine/TestEngineTest.rkt
View File

@ -123,3 +123,14 @@
(member x (list 0 1 2 3 4 5 6 7 8 9))) (member x (list 0 1 2 3 4 5 6 7 8 9)))
(check-satisfied 4 odd?) ;; fails (check-satisfied 4 odd?) ;; fails
;; -----------------------------------------------------------------------------
(define (long? x)
(lambda (y)
(< (string-length (substring y 0 1)) x)))
(define long10 (long? 10))
(check-satisfied (trigger-exn-in-pred "") long10)
(define (trigger-exn-in-pred x) x)