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

pkgs/htdp-pkgs/htdp-lib/test-engine/racket-tests.rkt

@@ -189,11 +189,13 @@
   (syntax-case stx ()
     [(_ actual:exp expected-property:exp)
      (identifier? #'expected-property:exp)
+     (begin 
        (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)]
+                           #'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,9 +205,13 @@
   ;; 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))
+   ;; 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
@@ -377,15 +383,26 @@
                                 (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))])
+                                  (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)]))])
+                       [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))
 

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))

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"

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)