improve error reporting ands doc for check-expect (PR 9499 and 9500)

svn: r10257

collects/scribblings/htdp-langs/advanced.scrbl

@@ -39,9 +39,11 @@
 #:literals (define define-struct lambda cond else if and or empty true false require lib planet
             local let let* letrec time begin begin0 set! delay shared recur when case unless
             check-expect check-within check-error)
+(check-expect check-within check-error require)
 [program (code:line def-or-expr ...)]
 [def-or-expr definition
              expr
+             test-case
              library-require]
 [definition (define (id id id ...) expr)
             (define id expr)
@@ -71,7 +73,6 @@
       (and expr expr expr ...)
       (or expr expr expr ...)
       (time expr)
-      test-case
       empty
       (code:line id (code:comment #, @seclink["intermediate-id"]{identifier}))
       (code:line prim-op (code:comment #, @seclink["intermediate-lambda-prim-op"]{primitive operation}))

collects/scribblings/htdp-langs/beginner-abbr.scrbl

@@ -25,9 +25,11 @@
 @schemegrammar*+qq[
 #:literals (define define-struct lambda cond else if and or empty true false require lib planet
             check-expect check-within check-error)
+(check-expect check-within check-error require)
 [program (code:line def-or-expr ...)]
 [def-or-expr definition
              expr
+             test-case
              library-require]
 [definition (define (id id id ...) expr)
             (define id expr)
@@ -40,7 +42,6 @@
       (if expr expr expr)
       (and expr expr expr ...)
       (or expr expr expr ...)
-      test-case
       empty
       id
       (code:line #, @elem{@schemevalfont{'}@scheme[quoted]} (code:comment #, @seclink["beginner-abbr-quote"]{quoted value}))

collects/scribblings/htdp-langs/beginner.scrbl

@@ -12,10 +12,11 @@
 @schemegrammar*+library[
 #:literals (define define-struct lambda cond else if and or empty true false require lib planet
             check-expect check-within check-error)
+(check-expect check-within check-error require)
 [program (code:line def-or-expr ...)]
 [def-or-expr definition
              expr
-             
+             test-case             
              library-require]
 [definition (define (id id id ...) expr)
             (define id expr)
@@ -28,7 +29,6 @@
       (if expr expr expr)
       (and expr expr expr ...)
       (or expr expr expr ...)
-      test-case
       empty
       id
       (code:line id (code:comment #, @seclink["beginner-id"]{identifier}))

collects/scribblings/htdp-langs/intermediate-lambda.scrbl

@@ -37,9 +37,11 @@
 @schemegrammar*+qq[
 #:literals (define define-struct lambda cond else if and or empty true false require lib planet
             local let let* letrec time check-expect check-within check-error)
+(check-expect check-within check-error require)
 [program (code:line def-or-expr ...)]
 [def-or-expr definition
              expr
+             test-case
              library-require]
 [definition (define (id id id ...) expr)
             (define id expr)
@@ -56,7 +58,6 @@
       (and expr expr expr ...)
       (or expr expr expr ...)
       (time expr)
-      test-case
       empty
       (code:line id (code:comment #, @seclink["intermediate-id"]{identifier}))
       (code:line prim-op (code:comment #, @seclink["intermediate-lambda-prim-op"]{primitive operation}))

collects/scribblings/htdp-langs/intermediate.scrbl

@@ -24,9 +24,11 @@
 @schemegrammar*+qq[
 #:literals (define define-struct lambda cond else if and or empty true false require lib planet
             local let let* letrec time check-expect check-within check-error)
+(check-expect check-within check-error require)
 [program (code:line def-or-expr ...)]
 [def-or-expr definition
              expr
+             test-case
              library-require]
 [definition (define (id id id ...) expr)
             (define id expr)
@@ -44,7 +46,6 @@
       (and expr expr expr ...)
       (or expr expr expr ...)
       (time expr)
-      test-case
       empty
       (code:line id (code:comment #, @seclink["intermediate-id"]{identifier}))
       (code:line prim-op (code:comment #, @seclink["intermediate-prim-op"]{primitive operation}))

collects/scribblings/htdp-langs/std-grammar.ss

@@ -10,21 +10,30 @@
 
 (define ex-str "This is a string with \" inside")
 
-(define-syntax-rule (schemegrammar*+library form ...)
+(define-syntax-rule (schemegrammar*+library 
+                     #:literals lits
+                     (check-expect check-within check-error require)
+                     form ...)
   (schemegrammar*
+   #:literals lits
    form ...
    [test-case #, @scheme[(check-expect expr expr)]
               #, @scheme[(check-within expr expr expr)]
               #, @scheme[(check-error expr expr)]]
    (...
-    [libray-require #, @scheme[(require string)]
+    [library-require #, @scheme[(require string)]
-                    #, @scheme[(require (lib string string ...))]
+                     #, @scheme[(require (lib string string ...))]
-                    #, @scheme[(require (planet string package))]])
+                     #, @scheme[(require (planet string package))]])
    (...
     [package #, @scheme[(string string number number)]])))
 
-(define-syntax-rule (schemegrammar*+qq form ...)
+(define-syntax-rule (schemegrammar*+qq 
+                     #:literals lits
+                     (check-expect check-within check-error require)
+                     form ...)
   (schemegrammar*+library
+   #:literals lits
+   (check-expect check-within check-error require)
    form ...
    (...
     [quoted id

collects/test-engine/scheme-tests.ss

@@ -30,11 +30,11 @@
   "check-within requires three expressions. Try (check-within test expected range).")
 
 (define-for-syntax CHECK-EXPECT-DEFN-STR
-  "check-expect cannot be used as an expression")
+  "found a test that is not at the top level")
 (define-for-syntax CHECK-WITHIN-DEFN-STR
-  "check-within cannot be used as an expression")
+  CHECK-EXPECT-DEFN-STR)
 (define-for-syntax CHECK-ERROR-DEFN-STR
-  "check-error cannot be used as an expression")
+  CHECK-EXPECT-DEFN-STR)
 
 (define-struct check-fail (src))
 
@@ -84,21 +84,24 @@
                    '(syntax-e cdr cdr syntax-e car) ;; lambda
                    ))))))
 
+(define-for-syntax (check-context?)
+  (let ([c (syntax-local-context)])
+    (memq c '(module top-level))))
 
 ;; check-expect
 (define-syntax (check-expect stx)
   (syntax-case stx ()
     [(_ test actual)
-     (not (eq? (syntax-local-context) 'expression))
+     (check-context?)
      (check-expect-maker stx #'check-values-expected (list #`(lambda () test) #`actual) 'comes-from-check-expect)]
     [(_ test)
-     (not (eq? (syntax-local-context) 'expression))
+     (check-context?)
      (raise-syntax-error 'check-expect CHECK-EXPECT-STR stx)]
     [(_ test actual extra ...)
-     (not (eq? (syntax-local-context) 'expression))
+     (check-context?)
      (raise-syntax-error 'check-expect CHECK-EXPECT-STR stx)]
     [(_ test ...)
-     (eq? (syntax-local-context) 'expression)
+     (not (check-context?))
      (raise-syntax-error 'check-expect CHECK-EXPECT-DEFN-STR stx)]))
 
 ;; check-values-expected: (-> scheme-val) scheme-val src -> void
@@ -113,19 +116,19 @@
 (define-syntax (check-within stx)
   (syntax-case stx ()
     [(_ test actual within)
-     (not (eq? (syntax-local-context) 'expression))
+     (check-context?)
      (check-expect-maker stx #'check-values-within (list #`(lambda () test) #`actual #`within) 'comes-from-check-within)]
     [(_ test actual)
-     (not (eq? (syntax-local-context) 'expression))
+     (check-context?)
      (raise-syntax-error 'check-within CHECK-WITHIN-STR stx)]
     [(_ test)
-     (not (eq? (syntax-local-context) 'expression))
+     (check-context?)
      (raise-syntax-error 'check-within CHECK-WITHIN-STR stx)]
     [(_ test actual within extra ...)
-     (not (eq? (syntax-local-context) 'expression))
+     (check-context?)
      (raise-syntax-error 'check-within CHECK-WITHIN-STR stx)]
     [(_ test ...)
-     (eq? (syntax-local-context) 'expression)
+     (not (check-context?))
      (raise-syntax-error 'check-within CHECK-WITHIN-DEFN-STR stx)]))
 
 (define (check-values-within test actual within src test-info)
@@ -139,13 +142,13 @@
 (define-syntax (check-error stx)
   (syntax-case stx ()
     [(_ test error)
-     (not (eq? (syntax-local-context) 'expression))
+     (check-context?)
      (check-expect-maker stx #'check-values-error (list #'(lambda () test) #`error) 'comes-from-check-error)]
     [(_ test)
-     (not (eq? (syntax-local-context) 'expression))
+     (check-context?)
      (raise-syntax-error 'check-error CHECK-ERROR-STR stx)]
     [(_ test ...)
-     (eq? (syntax-local-context) 'expression)
+     (not (check-context?))
      (raise-syntax-error 'check-error CHECK-ERROR-DEFN-STR stx)]))
 
 (define (check-values-error test error src test-info)
@@ -162,7 +165,11 @@
         (begin
           (send (send test-info get-info) check-failed
                 (check->message result) (check-fail-src result))
-          (list 'check-error-failed (incorrect-error-message result) error))
+          (list 'check-error-failed 
+                (if (expected-error? result)
+                    (expected-error-message result)
+                    (incorrect-error-message result))
+                error))
         (list 'check-error-succeeded error error))))