diff --git a/pkgs/htdp-pkgs/htdp-lib/test-engine/racket-tests.rkt b/pkgs/htdp-pkgs/htdp-lib/test-engine/racket-tests.rkt index 6ef532f7ca..ee94a26a65 100644 --- a/pkgs/htdp-pkgs/htdp-lib/test-engine/racket-tests.rkt +++ b/pkgs/htdp-pkgs/htdp-lib/test-engine/racket-tests.rkt @@ -174,14 +174,14 @@ (syntax-case stx () [(check-random e1 e2) (let ([test - #`(lambda (rng k) - (parameterize ((current-pseudo-random-generator rng)) (random-seed k) - e1))] - [actuals - (list - #`(lambda (rng k) - (parameterize ((current-pseudo-random-generator rng)) (random-seed k) - e2)))]) + #`(lambda (rng k) + (parameterize ((current-pseudo-random-generator rng)) (random-seed k) + e1))] + [actuals + (list + #`(lambda (rng k) + (parameterize ((current-pseudo-random-generator rng)) (random-seed k) + e2)))]) (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)])) @@ -189,11 +189,13 @@ (syntax-case stx () [(_ actual:exp expected-property:exp) (identifier? #'expected-property:exp) - (check-expect-maker stx - #'check-values-property - #'(lambda (x) (expected-property:exp x)) - (list #'actual:exp (symbol->string (syntax-e #'expected-property:exp))) - 'comes-from-check-satisfied)] + (begin + (check-expect-maker stx + #'check-values-property + #'actual:exp + (list #'(lambda (x) (expected-property:exp x)) + (symbol->string (syntax-e #'expected-property:exp))) + 'comes-from-check-satisfied))] [(_ actual:exp expected-property:exp) (raise-syntax-error 'check-satisfied "expects named function in second position." 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 (send (send test-engine get-info) add-check) (run-and-check - (lambda (v p? _what-is-this?) (p? v)) - (lambda (src format v1 v2 _) (make-satisfied-failed src format v2 property?)) - test - actual - #f - src - test-engine - (list 'check-satisfied property?))) + ;; check + (lambda (p? v _what-is-this?) (p? v)) + ;; maker + (lambda (src format v1 v2 _) (make-satisfied-failed src format v2 property?)) + ;; test + test + ;; expect + actual + #f + src + test-engine + (list 'check-satisfied property?))) ;; check-values-expected: (-> scheme-val) (-> nat scheme-val) src test-engine -> void (define (check-random-values test actual-maker src test-engine) @@ -361,31 +367,42 @@ ;; ( -> scheme-val) scheme-val scheme-val test-engine symbol? -> boolean (define (run-and-check check maker test expect range src test-engine kind) (match-let ([(list result result-val exn) - (with-handlers ([exn:fail:wish? - (lambda (e) - (define display (error-display-handler)) - (define name (exn:fail:wish-name e)) - (define args (exn:fail:wish-args e)) - (list (unimplemented-wish src (test-format) name args) 'error #f))] - [(lambda (x) - (and (exn:fail:contract:arity? x) - (pair? kind) - (eq? 'check-satisfied (car kind)))) - (lambda (_) - (error-check (lambda (v) #f) (cadr kind) SATISFIED-FMT #t))] - [exn:fail? - (lambda (e) - (define display (error-display-handler)) - (define msg (get-rewriten-error-message e)) - (list (make-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)]))]) + (with-handlers ([exn:fail:wish? + (lambda (e) + (define display (error-display-handler)) + (define name (exn:fail:wish-name e)) + (define args (exn:fail:wish-args e)) + (list (unimplemented-wish src (test-format) name args) 'error #f))] + [(lambda (x) + (and (exn:fail:contract:arity? x) + (pair? kind) + (eq? 'check-satisfied (car kind)))) + (lambda (_) + (error-check (lambda (v) #f) (cadr kind) SATISFIED-FMT #t))] + [exn:fail? + (lambda (e) + (define display (error-display-handler)) + (define msg (get-rewriten-error-message e)) + (if (and (pair? kind) (eq? 'check-satisfied (car kind))) + (list (unsatisfied-error src (test-format) (cadr kind) msg e) + 'error e) + (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) - (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)] [else #t]))) +(define (tee x) + (displayln `(tee ,x)) + x) + ;;Wishes (struct exn:fail:wish exn:fail (name args)) diff --git a/pkgs/htdp-pkgs/htdp-lib/test-engine/test-display.scm b/pkgs/htdp-pkgs/htdp-lib/test-engine/test-display.scm index 39a8682a42..9fe22c7dd1 100644 --- a/pkgs/htdp-pkgs/htdp-lib/test-engine/test-display.scm +++ b/pkgs/htdp-pkgs/htdp-lib/test-engine/test-display.scm @@ -274,6 +274,11 @@ (print (string-constant test-engine-check-encountered-error) (formatter (unexpected-error-expected 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) (print (string-constant test-engine-actual-value-differs-error) (formatter (unequal-test fail)) @@ -281,11 +286,7 @@ [(satisfied-failed? fail) (print "Actual value ~F does not satisfy ~a." (formatter (satisfied-failed-actual fail)) - (satisfied-failed-name fail)) - #; - (print (string-constant test-engine-actual-value-differs-error) - (formatter (unequal-test fail)) - (formatter (unequal-actual fail)))] + (satisfied-failed-name fail))] [(outofrange? fail) (print (string-constant test-engine-actual-value-not-within-error) (formatter (outofrange-test fail)) diff --git a/pkgs/htdp-pkgs/htdp-lib/test-engine/test-info.scm b/pkgs/htdp-pkgs/htdp-lib/test-engine/test-info.scm index 7fac35459d..b9ddae370b 100644 --- a/pkgs/htdp-pkgs/htdp-lib/test-engine/test-info.scm +++ b/pkgs/htdp-pkgs/htdp-lib/test-engine/test-info.scm @@ -13,6 +13,7 @@ ;; (make-unexpected-error src format string 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) (define-struct (unequal check-fail) (test actual)) ;; (make-outofrange src format scheme-val scheme-val inexact) @@ -140,6 +141,11 @@ (apply print-with-values fstring print-string print-formatted vals))) (formatter (check-fail-format fail))) (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) (print "check-expect encountered the following error instead of the expected value, ~F. \n :: ~a" diff --git a/pkgs/htdp-pkgs/htdp-test/tests/test-engine/TestEngineTest.rkt b/pkgs/htdp-pkgs/htdp-test/tests/test-engine/TestEngineTest.rkt index 7e7a6261ad..fdb330f30b 100644 --- a/pkgs/htdp-pkgs/htdp-test/tests/test-engine/TestEngineTest.rkt +++ b/pkgs/htdp-pkgs/htdp-test/tests/test-engine/TestEngineTest.rkt @@ -123,3 +123,14 @@ (member x (list 0 1 2 3 4 5 6 7 8 9))) (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)