From 938df1800c4c9fa698795513f743b2dea0e8be5b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 13 Jun 2008 17:24:24 +0000 Subject: [PATCH] improve error reporting ands doc for check-expect (PR 9499 and 9500) svn: r10257 --- .../scribblings/htdp-langs/advanced.scrbl | 3 +- .../htdp-langs/beginner-abbr.scrbl | 3 +- .../scribblings/htdp-langs/beginner.scrbl | 4 +- .../htdp-langs/intermediate-lambda.scrbl | 3 +- .../scribblings/htdp-langs/intermediate.scrbl | 3 +- .../scribblings/htdp-langs/std-grammar.ss | 19 ++++++--- collects/test-engine/scheme-tests.ss | 39 +++++++++++-------- 7 files changed, 47 insertions(+), 27 deletions(-) diff --git a/collects/scribblings/htdp-langs/advanced.scrbl b/collects/scribblings/htdp-langs/advanced.scrbl index feb0a2c94d..8a0dab5a4e 100644 --- a/collects/scribblings/htdp-langs/advanced.scrbl +++ b/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})) diff --git a/collects/scribblings/htdp-langs/beginner-abbr.scrbl b/collects/scribblings/htdp-langs/beginner-abbr.scrbl index 247fec0306..117ce6ed02 100644 --- a/collects/scribblings/htdp-langs/beginner-abbr.scrbl +++ b/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})) diff --git a/collects/scribblings/htdp-langs/beginner.scrbl b/collects/scribblings/htdp-langs/beginner.scrbl index 77bd96748f..b4fb30a8b6 100644 --- a/collects/scribblings/htdp-langs/beginner.scrbl +++ b/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})) diff --git a/collects/scribblings/htdp-langs/intermediate-lambda.scrbl b/collects/scribblings/htdp-langs/intermediate-lambda.scrbl index e2a32ea467..c0e3af0b23 100644 --- a/collects/scribblings/htdp-langs/intermediate-lambda.scrbl +++ b/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})) diff --git a/collects/scribblings/htdp-langs/intermediate.scrbl b/collects/scribblings/htdp-langs/intermediate.scrbl index 80ffda0bd7..37fbd3c0e7 100644 --- a/collects/scribblings/htdp-langs/intermediate.scrbl +++ b/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})) diff --git a/collects/scribblings/htdp-langs/std-grammar.ss b/collects/scribblings/htdp-langs/std-grammar.ss index eb105c0568..315e1e9b59 100644 --- a/collects/scribblings/htdp-langs/std-grammar.ss +++ b/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)] - #, @scheme[(require (lib string string ...))] - #, @scheme[(require (planet string package))]]) + [library-require #, @scheme[(require string)] + #, @scheme[(require (lib string string ...))] + #, @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 diff --git a/collects/test-engine/scheme-tests.ss b/collects/test-engine/scheme-tests.ss index e167ea7178..fbf011100b 100644 --- a/collects/test-engine/scheme-tests.ss +++ b/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))))