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

Changed the wording of BSL error messages

Browse Source
This commit is contained in:
Guillaume Marceau 2010-10-20 02:34:26 -04:00
parent 103474a5f5
commit 2f3da4c4cd
10 changed files with 387 additions and 256 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

107
collects/drracket/private/colored-errors.rkt
View File

@ -1,18 +1,54 @@
#lang racket #lang racket
(require unstable/contract)
(define-syntax (test stx) #'(begin)) ;; TODO: convert my test into DrRacket's test framework
(require #;gmarceau/test
parser-tools/lex
(prefix-in : parser-tools/lex-sre)
(rename-in srfi/26 [cut //])
(only-in srfi/1 break)
unstable/contract)
;; An error message has many fragments. The fragments will be concatenated
;; before being presented to the user. Some fragment are simply string.
(struct msg-fragment:str (str) #:transparent) (struct msg-fragment:str (str) #:transparent)
;; Some fragment are arbitrary values. They will be turned into snips if the error message display
;; context supports them. Otherwise, they will be turned into a string.
(struct msg-fragment:v (v) #:transparent) (struct msg-fragment:v (v) #:transparent)
;; colored-msg-fragment represent a fragment of text in the error message that refers (in English)
;; to a particular piece of the code. DrRacket will highlight both the fragment text of the error message
;; and the piece with the same color.
;;
;; locs : which srcloc to highlight, one or many
;; frags : which fragments of text to highlight. (nested coloring in the error test is not allowed)
;; important : when true, the srcloc corresponding to this fragment will be highlighted even in contexts
;; that do not support highlighting of the error message text.
;; color : if false, DrRacket will assign a color to each fragment, from left to right order of the
;; messag text. Otherwise it should be a symbolic color (TBA).
(struct colored-msg-fragment (locs frags important color) #:transparent) (struct colored-msg-fragment (locs frags important color) #:transparent)
;; msg-fragment? : Returns true if v is a fragment.
(define (msg-fragment? v) (or (msg-fragment:str v) (msg-fragment:v v) (colored-msg-fragment v))) (define (msg-fragment? v) (or (msg-fragment:str v) (msg-fragment:v v) (colored-msg-fragment v)))
;; srcloc-syntax/c : Contract for specifications of code piece to highlight.
(define srcloc-syntax/c (rename-contract (or/c srcloc? syntax? (listof (or/c srcloc? syntax?))) 'srcloc-syntax/c)) (define srcloc-syntax/c (rename-contract (or/c srcloc? syntax? (listof (or/c srcloc? syntax?))) 'srcloc-syntax/c))
;; additional-highligts can specify their color
(define additional-highlights/c (listof (or/c srcloc-syntax/c (list/c srcloc-syntax/c symbol?))))
;; colored-error-message : Exceptions that support highlighting contain a colored-error-message
;; in addition to a string. The string message is automatically generated from
;; the colored-error-message for backward compatibility.
;; A colored-error-message has a list of fragments (some of which will be highlighted) and a list
;; of additional source locations. These additional location will also be highlighted in the code,
;; even though they do not correspond to any section of the text of the error message.
(struct colored-error-message (fragments additional-highlights) #:transparent) (struct colored-error-message (fragments additional-highlights) #:transparent)
(provide/contract [struct colored-error-message (provide/contract [struct colored-error-message
([fragments (listof msg-fragment?)] ([fragments (listof msg-fragment?)]
[additional-highlights srcloc-syntax/c])] [additional-highlights additional-highlights/c])]
[struct msg-fragment:str ([str string?])] [struct msg-fragment:str ([str string?])]
[struct msg-fragment:v ([v any/c])] [struct msg-fragment:v ([v any/c])]
[struct colored-msg-fragment ([locs srcloc-syntax/c] [struct colored-msg-fragment ([locs srcloc-syntax/c]
@ -20,6 +56,8 @@
[important boolean?] [important boolean?]
[color (or/c #f symbol?)])]) [color (or/c #f symbol?)])])
;; prop:exn:colored-message : The property of exceptions that contain colored-message information.
;; The property's value is a function that when given an exception, returns the colored-error-message.
(define-values (prop:exn:colored-message (define-values (prop:exn:colored-message
exn:colored-message? exn:colored-message?
exn:colored-message-accessor) exn:colored-message-accessor)
@ -29,6 +67,9 @@
(contract (exn? . -> . colored-error-message?) v (contract (exn? . -> . colored-error-message?) v
'struct-definition 'color-error-accessor)))) 'struct-definition 'color-error-accessor))))
;; get-error-message/color : When given an exception, if that exception contains coloring information,
;; returns it, otherwise, returns a colored-error-message that capture the information provided by
;; by field message and the srclocs property (if any) of the exception.
(provide/contract [get-error-messages/color (exn? . -> . colored-error-message?)]) (provide/contract [get-error-messages/color (exn? . -> . colored-error-message?)])
(define (get-error-messages/color exn) (define (get-error-messages/color exn)
(cond [(exn:colored-message? exn) ((exn:colored-message-accessor exn) exn)] (cond [(exn:colored-message? exn) ((exn:colored-message-accessor exn) exn)]
@ -38,13 +79,6 @@
[else [else
(colored-error-message (list (msg-fragment:str (exn-message exn))) empty)])) (colored-error-message (list (msg-fragment:str (exn-message exn))) empty)]))
(require gmarceau/test gmarceau/cut gmarceau/list gmarceau/contract gmarceau/util parser-tools/lex
(prefix-in : parser-tools/lex-sre)
(only-in srfi/1 break)
unstable/function)
(define lex (lexer (define lex (lexer
[(eof) empty] [(eof) empty]
@ -62,6 +96,11 @@
(test 'lex (check-equal? (lex (open-input-string "~~foo ~| ~~| bar ~v|~ foo ~ ")) (test 'lex (check-equal? (lex (open-input-string "~~foo ~| ~~| bar ~v|~ foo ~ "))
'("~~foo " TildaPipe " ~~| bar " TildaV PipeTilda " foo ~ "))) '("~~foo " TildaPipe " ~~| bar " TildaV PipeTilda " foo ~ ")))
(define-syntax (match? stx)
(syntax-case stx ()
[(_ v pattern) (syntax/loc stx
(match v [pattern #t] [_ #f]))]))
(define (check-tildas-are-paired parsed) (define (check-tildas-are-paired parsed)
(let loop ([tildas (filter (// match? <> (or 'TildaPipe 'PipeTilda)) parsed)] [i 1]) (let loop ([tildas (filter (// match? <> (or 'TildaPipe 'PipeTilda)) parsed)] [i 1])
(match tildas (match tildas
@ -133,8 +172,25 @@
(define color (and (list? the-arg) (findf symbol? the-arg))) (define color (and (list? the-arg) (findf symbol? the-arg)))
(values (colored-msg-fragment (if (list? the-arg) (first the-arg) the-arg) sub is-important color) rest-args)) (values (colored-msg-fragment (if (list? the-arg) (first the-arg) the-arg) sub is-important color) rest-args))
(provide/contract [colored-format (([fmt string?]) (#:additional-highlights [additional-highlights srcloc-syntax/c]) #:rest [_ any/c] (provide/contract [colored-format (([fmt string?]) (#:additional-highlights [additional-highlights additional-highlights/c]) #:rest [_ any/c]
. ->i . [_ colored-error-message?])]) . ->i . [_ colored-error-message?])])
;; colored-format : Takes a format string and a number of arguments, and produces a string where each
;; format marker has been replaced by their corresponding argument. This function support
;; all the formatting option of fprintf, plus:
;;
;; ~| ... |~ : The text between ~| and |~ will be highlighted with the same color as the corresponding piece
;; of code. Arbitrary text and formatting options can occur between ~| and |~, but not another ~| |~
;; (there is no nesting of ~| |~).
;; The argument is either a srcloc-syntax/c, or a list contain a srcloc-syntax/c in first position and
;; then one or two of (in either order): a boolean indicating whether this highlight is important
;; a symbol, indication the highlight color
;; The argument to ~| |~ should be given first, before the arguments for the formatting options appearing
;; between ~| and |~.
;;
;; ~v : Inserts an arbitrary value in this position. If the value can be converted to a snip, it will be,
;; otherwise ~v is equivalent to ~a.
;;
(define (colored-format fmt #:additional-highlights [additional-highlights empty] . args) (define (colored-format fmt #:additional-highlights [additional-highlights empty] . args)
(define parsed (lex (open-input-string fmt))) (define parsed (lex (open-input-string fmt)))
@ -186,13 +242,14 @@
(match f (match f
[(msg-fragment:str str) str] [(msg-fragment:str str) str]
[(msg-fragment:v v) (format "~a" v)] [(msg-fragment:v v) (format "~a" v)]
[(colored-msg-fragment locs frags imp col) [(colored-msg-fragment locs frags imp col) (loop frags)]
(string-append* (map loop frags))]))) [(? list?) (string-append* (map loop f))])))
(define (important-srclocs msg) (define (important-srclocs msg)
(flatten (append
(filter-map (// match <> [(colored-msg-fragment locs _ #t _) locs] [_ #f]) (flatten
(colored-error-message-fragments msg)) (filter-map (// match <> [(colored-msg-fragment locs _ #t _) locs] [_ #f])
(colored-error-message-fragments msg)))
(colored-error-message-additional-highlights msg))) (colored-error-message-additional-highlights msg)))
(struct exn:fail:colored:syntax exn:fail:syntax (colored-message) (struct exn:fail:colored:syntax exn:fail:syntax (colored-message)
@ -201,14 +258,30 @@
(define vec (struct->vector v)) (define vec (struct->vector v))
(vector-ref vec (sub1 (vector-length vec))))) (vector-ref vec (sub1 (vector-length vec)))))
;; raise-colored-syntax-error : Formats the message string with colored-format, then raises a exn:fail:colored:syntax error.
;; The message and srcloc fields of the exception are populated from the information
;; in the fmt. additional-highlights specifies srclocs that should be highlighted, in addition
;; to the highlights used to explicate the correspondance between the text and the piece of codes.
(define (raise-colored-syntax-error fmt #:additional-highlights [additional-highlights empty] . args) (define (raise-colored-syntax-error fmt #:additional-highlights [additional-highlights empty] . args)
(define formatted (apply colored-format fmt #:additional-highlights [additional-highlights empty] args)) (define formatted (apply colored-format fmt #:additional-highlights empty args))
(raise (exn:fail:colored:syntax (uncolor-message formatted) (raise (exn:fail:colored:syntax (uncolor-message formatted)
(current-continuation-marks) (current-continuation-marks)
(important-srclocs formatted) (important-srclocs formatted)
formatted))) formatted)))
(test 'raise-colored-syntax-error
(check-exn-msg exn:fail:colored:syntax? #rx"only one part"
(lambda () (raise-colored-syntax-error "~|cond|~: expected a clause with a question and answer, but found a clause with only ~|one part|~"
#'stx #'question)))
(check-match (with-handlers ([void (lambda (e) (get-error-messages/color e))])
(raise-colored-syntax-error "~|cond|~: expected a clause with a question and answer, but found a clause with only ~|one part|~"
#'stx #'question))
(colored-error-message (list (colored-msg-fragment
(? syntax?)
(list (msg-fragment:str "cond")) #f #f)
(msg-fragment:str ": expected a clause with a question and answer, but found a clause with only ")
(colored-msg-fragment (? syntax?) (list (msg-fragment:str "one part")) #f #f))
empty)))
(test 'get-error-messages/color (test 'get-error-messages/color

4
collects/lang/error.rkt
View File

@ -55,7 +55,7 @@
(define arity-error "expects at least ~a arguments, given ~e") (define arity-error "expects at least ~a arguments, given ~e")
;; String [format: String[expected] Any[given] ;; String [format: String[expected] Any[given]
(define proc-error "procedure expected as ~s argument, given ~e") (define proc-error "a function was expected as ~s argument, given ~e")
;; check-proc : ;; check-proc :
;; sym (... *->* ...) num (union sym str) (union sym str) -> void ;; sym (... *->* ...) num (union sym str) (union sym str) -> void
@ -74,5 +74,5 @@
[else (format "multiple arities (~s)" arity-of-f)]))))) [else (format "multiple arities (~s)" arity-of-f)])))))
;; String [format: String[expected], String[position] Number[given] ;; String [format: String[expected], String[position] Number[given]
(define arity-error2 "procedure of ~a expected as ~s argument, given procedure of ~a ") (define arity-error2 "a function that expects ~a expected as ~s argument, given a function that expects ~a ")
) )

19
collects/lang/htdp-beginner.rkt
View File

@ -4,13 +4,15 @@
(module htdp-beginner scheme/base (module htdp-beginner scheme/base
(require mzlib/etc (require mzlib/etc
mzlib/list mzlib/list
syntax/docprovide syntax/docprovide
"private/rewrite-error-message.rkt"
(for-syntax "private/rewrite-error-message.rkt")
(for-syntax scheme/base)) (for-syntax scheme/base))
;; Implements the forms: ;; Implements the forms:
(require "private/teach.rkt" (require "private/teach.ss"
"private/teach-module-begin.rkt" "private/teach-module-begin.ss"
test-engine/scheme-tests) test-engine/scheme-tests)
;; syntax: ;; syntax:
@ -84,15 +86,14 @@
(lambda (stx) (lambda (stx)
(syntax-case stx () (syntax-case stx ()
[(id . args) [(id . args)
(syntax/loc stx (beginner-app orig-name . args))] (syntax/loc stx
(with-handlers ([exn:fail:contract? (compose raise rewrite-contract-error-message)])
(beginner-app orig-name . args)))]
[_else [_else
(raise-syntax-error (raise-syntax-error
#f #f
(format (format
"this ~a must be ~a; expected an open parenthesis before the ~a name" "found a use that does not follow an open parenthesis")
what
something
what)
stx)])) stx)]))
#'orig-name)))))])) #'orig-name)))))]))

14
collects/lang/htdp-intermediate.rkt
View File

@ -1,10 +1,12 @@
(module htdp-intermediate scheme/base (module htdp-intermediate scheme/base
(require "private/teach.rkt"
"private/teachprims.rkt" (require "private/teach.ss"
"private/teach-module-begin.rkt" "private/teachprims.ss"
mzlib/etc "private/teach-module-begin.ss"
mzlib/list "private/rewrite-error-message.rkt"
syntax/docprovide mzlib/etc
mzlib/list
syntax/docprovide
test-engine/scheme-tests) test-engine/scheme-tests)
;; syntax: ;; syntax:

30
collects/lang/prim.rkt
View File

@ -44,9 +44,7 @@
[_ [_
(raise-syntax-error (raise-syntax-error
#f #f
(string-append "found a use that does not follow an open parenthesis"
"this primitive operator must be applied to arguments; "
"expected an open parenthesis before the operator name")
stx)]))) stx)])))
((syntax-local-certifier #t) ((syntax-local-certifier #t)
#'impl))))])) #'impl))))]))
@ -59,7 +57,7 @@
(let ([args (syntax->list (syntax (arg ...)))]) (let ([args (syntax->list (syntax (arg ...)))])
(for-each (lambda (id) (for-each (lambda (id)
(unless (identifier? id) (unless (identifier? id)
(raise-syntax-error #f "not an identifier" stx id))) (raise-syntax-error #f "expected a variable" stx id)))
(cons (syntax name) (cons (syntax name)
args)) args))
(let ([new-args (generate-temporaries args)]) (let ([new-args (generate-temporaries args)])
@ -72,9 +70,7 @@
(raise-syntax-error (raise-syntax-error
#f #f
(format (format
"primitive operator ~a expects a defined procedure name (usually `~a') in this position" "expects a function in this position")
'name
'#,arg)
s s
(#,#'syntax #,new-arg))))) (#,#'syntax #,new-arg)))))
args new-args)] args new-args)]
@ -113,18 +109,20 @@
(syntax/loc s (tagged-impl wrapped-arg ...)) (syntax/loc s (tagged-impl wrapped-arg ...))
)] )]
[(_ . rest) [(_ . rest)
(raise-syntax-error (let ([num-actuals (length (syntax->list #'rest))])
#f (raise-syntax-error
(format #f
"primitive operator requires ~a arguments" (format
num-arguments) "this function expects ~a argument~a, here it is provided ~a argument~a"
s)] num-arguments
(if (= num-arguments 1) "" "s")
num-actuals
(if (= num-actuals 1) "" "s"))
s))]
[_ [_
(raise-syntax-error (raise-syntax-error
#f #f
(string-append "found a use that does not follow an open parenthesis"
"this primitive operator must be applied to arguments; "
"expected an open parenthesis before the operator name")
s)]))) s)])))
((syntax-local-certifier #t) ((syntax-local-certifier #t)
#'impl))))))))])) #'impl))))))))]))

11
collects/lang/private/and-or-map.rkt
View File

@ -13,9 +13,8 @@
(define (arity-check t r f a) (define (arity-check t r f a)
(unless (and (procedure? f) (procedure-arity-includes? f a)) (unless (and (procedure? f) (procedure-arity-includes? f a))
(if (= a 1) (if (= a 1)
(hocheck t "~a argument must be a <procedure> that accepts one argument, given ~e" r f) (hocheck t "~a argument must be a function that accepts one argument, given ~e" r f)
(hocheck t "~a argument must be a <procedure> that accepts ~a arguments, given ~e" r a f)))) (hocheck t "~a argument must be a function that accepts ~a arguments, given ~e" r a f))))
(define-syntax-rule (define-syntax-rule
(boolean-test-wrapper tag (f z ...)) (boolean-test-wrapper tag (f z ...))
@ -27,12 +26,12 @@
(define f@x (f z ...)) (define f@x (f z ...))
(if (boolean? f@x) (if (boolean? f@x)
f@x f@x
(error tag "the results of ~a must be of type <boolean>, produced ~e" name f@x))) (error tag "expected a boolean from ~a, but received ~e" name f@x)))
g)) g))
(define (list-check? name msg l) (define (list-check? name msg l)
(unless (beginner-list? l) (unless (beginner-list? l)
(hocheck name "~a argument must be of type <list>, given ~e" msg l))) (hocheck name "expected a list for the ~a argument, given ~e" msg l)))
;; --- refined function definitions --- ;; --- refined function definitions ---
@ -43,7 +42,7 @@
(arity-check 'name "first" f 1) (arity-check 'name "first" f 1)
(list-check? 'name "second" l) (list-check? 'name "second" l)
(unless (beginner-list? l) (unless (beginner-list? l)
(hocheck 'name "second argument must be of type <list>, given ~e" l)) (hocheck 'name "expected a list for the second argument, given ~e" l))
(define g (boolean-test-wrapper 'name (f x))) (define g (boolean-test-wrapper 'name (f x)))
(name g l)))) (name g l))))

56
collects/lang/private/rewrite-error-message.rkt Executable file
View File

@ -0,0 +1,56 @@
#lang scheme/base
(require mzlib/etc mzlib/list)
(require (for-syntax scheme/base))
(require (for-syntax "firstorder.ss"))
(provide rewrite-contract-error-message
rewrite-lookup-error-message/rand
rewrite-lookup-error-message/rator
wrap-for-contract-error-message
wrap-for-lookup-error-message
::)
(define (rewrite-lookup-error-message/rator e)
(rewrite-lookup-error-message e "function"))
(define (rewrite-lookup-error-message/rand e)
(rewrite-lookup-error-message e "variable"))
(define (rewrite-lookup-error-message e var-or-function)
(define new-message
(regexp-replace* #rx"reference to an identifier before its definition"
(exn-message e)
(format "this is ~a not defined" var-or-function)))
(struct-copy exn e [message new-message]))
(define-syntax (wrap-for-lookup-error-message stx)
(syntax-case stx ()
[(_ . id)
(with-syntax ([top (syntax/loc stx #%top)])
(syntax/loc stx
(with-handlers ([exn:fail:contract:variable?
(compose raise rewrite-lookup-error-message)])
(top . id))))]))
(define (rewrite-contract-error-message e)
(define replacements
(list (list #rx"expects argument of type (<([^>]+)>)"
(lambda (all one two) (format "expects a ~a" two)))
(list #rx"expects type (<([^>]+)>)"
(lambda (all one two) (format "expects a ~a" two)))))
(define new-message
(for/fold ([msg (exn-message e)]) ([repl. replacements])
(regexp-replace* (first repl.) msg (second repl.))))
(struct-copy exn e [message new-message]))
(define-for-syntax (wrap-for-contract-error-message* stx)
(syntax-case stx ()
[(_ new old)
#'(define (new . args)
(with-handlers ([exn:fail:contract? (compose raise rewrite-contract-error-message)])
(apply old args)))]))
(define-syntax wrap-for-contract-error-message wrap-for-contract-error-message*)
(define-syntax :: wrap-for-contract-error-message*) ;; to circumvent most of the ugliness of provide-and-document/wrap's renaming of the function's infered name

314
collects/lang/private/teach.rkt
View File

@ -40,15 +40,16 @@
scheme/match scheme/match
"set-result.rkt" "set-result.rkt"
(only racket/base define-struct) (only racket/base define-struct)
racket/struct-info "rewrite-error-message.rkt"
deinprogramm/signature/signature-english racket/struct-info
(all-except deinprogramm/signature/signature signature-violation) deinprogramm/signature/signature-english
(all-except lang/private/signature-syntax property) (all-except deinprogramm/signature/signature signature-violation)
(rename lang/private/signature-syntax signature:property property) (all-except lang/private/signature-syntax property)
(all-except deinprogramm/quickcheck/quickcheck property) (rename lang/private/signature-syntax signature:property property)
(rename deinprogramm/quickcheck/quickcheck quickcheck:property property) (all-except deinprogramm/quickcheck/quickcheck property)
test-engine/racket-tests (rename deinprogramm/quickcheck/quickcheck quickcheck:property property)
scheme/class test-engine/racket-tests
scheme/class
"../posn.rkt" "../posn.rkt"
(only lang/private/teachprims (only lang/private/teachprims
beginner-equal? beginner-equal~? teach-equal? beginner-equal? beginner-equal~? teach-equal?
@ -256,8 +257,7 @@
name name
stx stx
#f #f
"found a use of `~a' that does not follow an open parenthesis" "found a use that does not follow an open parenthesis"))
name))
;; Use for messages "expected ..., found <something else>" ;; Use for messages "expected ..., found <something else>"
(define (something-else v) (define (something-else v)
@ -265,6 +265,7 @@
(cond (cond
[(number? v) "a number"] [(number? v) "a number"]
[(string? v) "a string"] [(string? v) "a string"]
[(list? v) "a part"]
[else "something else"]))) [else "something else"])))
(define (ordinal n) (define (ordinal n)
@ -319,11 +320,9 @@
(when b (when b
(teach-syntax-error (teach-syntax-error
'duplicate 'duplicate
name stx
#f #f
(if (binding-in-this-module? b) "~a was defined previously and cannot be re-defined" (syntax-e name)))))
"this name was defined previously and cannot be re-defined"
"this name has a built-in meaning and cannot be re-defined")))))
names) names)
(if assign (if assign
(with-syntax ([(name ...) (if (eq? assign #t) (with-syntax ([(name ...) (if (eq? assign #t)
@ -394,11 +393,10 @@
who who
stx stx
(cadr exprs) (cadr exprs)
"expected only one expression ~a, but found ~a extra part" "expected only one expression ~a, but found ~a extra part~a"
where where
(if (null? (cddr exprs)) (sub1 (length exprs))
"one" (if (> (length exprs) 2) "s" ""))))
"at least one"))))
(define (check-single-result-expr exprs where enclosing-expr will-bind) (define (check-single-result-expr exprs where enclosing-expr will-bind)
(check-single-expression where (check-single-expression where
@ -540,7 +538,7 @@
'define 'define
stx stx
names names
"expected a function name for a definition, but the name is missing")) "expected a name for the function, but nothing's there"))
(let loop ([names names][pos 0]) (let loop ([names names][pos 0])
(unless (null? names) (unless (null? names)
(unless (identifier/non-kw? (car names)) (unless (identifier/non-kw? (car names))
@ -548,10 +546,10 @@
'define 'define
stx stx
(car names) (car names)
"expected a name for ~a, but found ~a" "expected ~a, but found ~a"
(cond (cond
[(zero? pos) "a function"] [(zero? pos) "the name of the function"]
[else (format "the function's ~a argument" (ordinal pos))]) [else "a variable"])
(something-else/kw (car names)))) (something-else/kw (car names))))
(loop (cdr names) (add1 pos)))) (loop (cdr names) (add1 pos))))
(when (null? (cdr names)) (when (null? (cdr names))
@ -559,14 +557,14 @@
'define 'define
stx stx
(syntax name-seq) (syntax name-seq)
"expected at least one argument name after the function name, but found none")) "expected at least one variable after the function name, but found none"))
(let ([dup (check-duplicate-identifier (cdr names))]) (let ([dup (check-duplicate-identifier (cdr names))])
(when dup (when dup
(teach-syntax-error (teach-syntax-error
'define 'define
stx stx
dup dup
"found an argument name that was used more than once: ~a" "found a variable that was used more than once: ~a"
(syntax-e dup)))) (syntax-e dup))))
(check-single-result-expr (syntax->list (syntax (expr ...))) (check-single-result-expr (syntax->list (syntax (expr ...)))
#f #f
@ -604,7 +602,7 @@
(identifier/non-kw? (syntax name)) (identifier/non-kw? (syntax name))
(let ([exprs (syntax->list (syntax (expr ...)))]) (let ([exprs (syntax->list (syntax (expr ...)))])
(check-single-expression 'define (check-single-expression 'define
(format "after the defined name ~a" (format "after the variable name ~a"
(syntax-e (syntax name))) (syntax-e (syntax name)))
stx stx
exprs exprs
@ -617,7 +615,7 @@
'define 'define
stx stx
(syntax non-name) (syntax non-name)
"expected a function name, constant name, or function header for `define', but found ~a" "expected a variable name, or a function name and its variables (in parentheses), but found ~a"
(something-else/kw (syntax non-name)))] (something-else/kw (syntax non-name)))]
;; Missing name: ;; Missing name:
[(_) [(_)
@ -625,8 +623,7 @@
'define 'define
stx stx
#f #f
"expected a function name, constant name, or function header after `define', ~ "expected a variable name, or a function name and its variables (in parentheses), but nothing's there")]
but nothing's there")]
[_else [_else
(bad-use-error 'define stx)])) (bad-use-error 'define stx)]))
@ -668,7 +665,7 @@
'lambda 'lambda
stx stx
#f #f
"found a `lambda' expression that is not a function definition")] "found a lambda that is not a function definition")]
[_else [_else
(bad-use-error 'lambda stx)])) (bad-use-error 'lambda stx)]))
@ -691,7 +688,7 @@
'lambda 'lambda
rhs rhs
arg arg
"expected a name for a function argument, but found ~a" "expected a variable, but found ~a"
(something-else/kw arg)))) (something-else/kw arg))))
args) args)
(when (null? args) (when (null? args)
@ -699,14 +696,14 @@
'lambda 'lambda
rhs rhs
(syntax arg-seq) (syntax arg-seq)
"expected at least one argument name in the sequence after `lambda', but found none")) "expected at least one variable after lambda, but found none"))
(let ([dup (check-duplicate-identifier args)]) (let ([dup (check-duplicate-identifier args)])
(when dup (when dup
(teach-syntax-error (teach-syntax-error
'lambda 'lambda
rhs rhs
dup dup
"found an argument name that was used more than once: ~a" "found a variable that was used more than once: ~a"
(syntax-e dup)))) (syntax-e dup))))
(check-single-result-expr (syntax->list (syntax (lexpr ...))) (check-single-result-expr (syntax->list (syntax (lexpr ...)))
#f #f
@ -719,7 +716,7 @@
'lambda 'lambda
rhs rhs
(syntax args) (syntax args)
"expected a sequence of function arguments after `lambda', but found ~a" "expected at least one variable (in parentheses) after lambda, but found ~a"
(something-else (syntax args)))] (something-else (syntax args)))]
;; Bad lambda, no args: ;; Bad lambda, no args:
[(lam) [(lam)
@ -727,7 +724,7 @@
'lambda 'lambda
rhs rhs
(syntax args) (syntax args)
"expected a sequence of function arguments after `lambda', but nothing's there")] "expected at least one variable (in parentheses) after lambda, but nothing's there")]
[_else 'ok])] [_else 'ok])]
[_else 'ok])) [_else 'ok]))
@ -753,7 +750,7 @@
'define-struct 'define-struct
stx stx
(syntax name) (syntax name)
"expected a structure type name after `define-struct', but found ~a" "expected the structure name after define-struct, but found ~a"
(something-else/kw (syntax name)))] (something-else/kw (syntax name)))]
;; Main case (`rest' is for nice error messages): ;; Main case (`rest' is for nice error messages):
[(_ name_ (field_ ...) . rest) [(_ name_ (field_ ...) . rest)
@ -767,7 +764,7 @@
'define-struct 'define-struct
stx stx
field field
"expected a structure field name, found ~a" "expected a field name, but found ~a"
(something-else field))) (something-else field)))
(let ([sym (syntax-e field)]) (let ([sym (syntax-e field)])
(when (hash-table-get ht sym (lambda () #f)) (when (hash-table-get ht sym (lambda () #f))
@ -785,11 +782,9 @@
'define-struct 'define-struct
stx stx
(car rest) (car rest)
"expected nothing after the field name sequence in `define-struct', ~ "expected nothing after the field names, but found ~a extra part~a"
but found ~a extra part" (length rest)
(if (null? (cdr rest)) (if (> (length rest) 1) "s" ""))))
"one"
"at least one"))))
(let-values ([(struct: constructor-name predicate-name getter-names setter-names) (let-values ([(struct: constructor-name predicate-name getter-names setter-names)
(make-struct-names name fields stx)] (make-struct-names name fields stx)]
[(field-count) (length fields)] [(field-count) (length fields)]
@ -973,22 +968,20 @@
'define-struct 'define-struct
stx stx
(syntax something) (syntax something)
"expected a sequence of field names after the structure type name in `define-struct', ~ "expected at least one field name after the structure name, but found ~a"
but found ~a"
(something-else (syntax something)))] (something-else (syntax something)))]
[(_ name_) [(_ name_)
(teach-syntax-error (teach-syntax-error
'define-struct 'define-struct
stx stx
(syntax something) (syntax something)
"expected a sequence of field names after the structure type name in `define-struct', ~ "expected at least one field name (in parentheses) after the structure name, but nothing's there")]
but nothing's there")]
[(_) [(_)
(teach-syntax-error (teach-syntax-error
'define-struct 'define-struct
stx stx
#f #f
"expected a structure type name after `define-struct', but nothing's there")] "expected the structure name after define-struct, but nothing's there")]
[_else (bad-use-error 'define-struct stx)])) [_else (bad-use-error 'define-struct stx)]))
(define (beginner-define-struct/proc stx) (define (beginner-define-struct/proc stx)
@ -1148,14 +1141,11 @@
'|function call| '|function call|
stx stx
fun fun
"expected a ~a after an open parenthesis, but found ~a" "expected a function after the open parenthesis, but found ~a"
(if lex-ok?
"name"
"defined function name or a primitive operation name")
what))]) what))])
(unless (and (identifier? fun) (or lex-ok? undef-check? (not lex?))) (unless (and (identifier? fun) (or lex-ok? undef-check? (not lex?)))
(bad-app (if lex? (bad-app (if lex?
"a function argument name" "a variable"
(something-else fun)))) (something-else fun))))
;; The following check disallows calling thunks. ;; The following check disallows calling thunks.
;; It's disabled because we need to allow calls to ;; It's disabled because we need to allow calls to
@ -1165,31 +1155,29 @@
'|function call| '|function call|
stx stx
#f #f
"expected an argument after the function name for a function call, ~ "expected an argument after the function, but nothing's there"))
but nothing's there"))
(cond (cond
[(and (not lex-ok?) (binding-in-this-module? binding)) [(and (not lex-ok?) (binding-in-this-module? binding))
;; An application of something defined as a constant ;; An application of something defined as a constant
(bad-app "something else")] (bad-app "a variable")]
[(or lex-ok? (and binding (not (binding-in-this-module? binding)))) [(or lex-ok? (and binding (not (binding-in-this-module? binding))))
(syntax/loc stx (#%app rator rand ...))] (with-syntax ([new-rator (syntax-property #'rator 'was-in-app-position #t)])
(syntax/loc stx (#%app new-rator rand ...)))]
[else [else
;; We don't know what rator is, yet, and it might be local: ;; We don't know what rator is, yet, and it might be local:
(quasisyntax/loc (with-syntax ([new-rator (syntax-property #'rator 'was-in-app-position #t)])
stx (quasisyntax/loc
(#%app values #,(quasisyntax/loc stx
stx (#%app values #,(quasisyntax/loc
(beginner-app-continue rator rand ...))))]))] stx
(beginner-app-continue new-rator rand ...)))))]))]
[(_) [(_)
(teach-syntax-error (teach-syntax-error
'|function call| '|function call|
stx stx
#f #f
(format (format
"expected a ~a after an open parenthesis, but nothing's there" "expected a function after the open parenthesis, but nothing's there"))]
(if lex-ok?
"name"
"defined function name or a primitive operation name")))]
[_else (bad-use-error '#%app stx)])))]) [_else (bad-use-error '#%app stx)])))])
(values (mk-app #f) (mk-app #t)))) (values (mk-app #f) (mk-app #t))))
@ -1206,9 +1194,11 @@
;; Something for which we probably need to report an error, ;; Something for which we probably need to report an error,
;; but let beginner-app take care of it: ;; but let beginner-app take care of it:
(syntax/loc stx (beginner-app rator rand ...))) (syntax/loc stx (beginner-app rator rand ...)))
;; Something undefined; let beginner-top take care of it:
(syntax/loc stx (#%app rator rand ...))))]))
;; Something undefined; let beginner-top take care of it:
(with-syntax ([new-rator (syntax-property #'rator 'was-in-app-position #t)])
(syntax/loc stx (#%app new-rator rand ...)))
))]))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; top-level variables (beginner) ;; top-level variables (beginner)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -1218,29 +1208,42 @@
(define (beginner-top/proc stx) (define (beginner-top/proc stx)
(syntax-case stx () (syntax-case stx ()
[(_ . id) [(_ . id)
;; If we're in a module, we'll need to check that the name ;; If we're in a module, we'll need to check that the name
;; is bound.... ;; is bound....
(if (and (not (identifier-binding #'id)) (if (and (not (identifier-binding #'id))
(syntax-source-module #'id)) (syntax-source-module #'id))
;; ... but it might be defined later in the module, so ;; ... but it might be defined later in the module, so
;; delay the check. ;; delay the check.
(stepper-ignore-checker (stepper-ignore-checker
(syntax/loc stx (#%app values (beginner-top-continue id)))) (syntax/loc stx (#%app values (beginner-top-continue id))))
(syntax/loc stx (#%top . id)))])) (with-syntax ([rewriter
(if (syntax-property #'id 'was-in-app-position)
'rewrite-lookup-error-message/rator
'rewrite-lookup-error-message/rand)])
(syntax/loc stx
(with-handlers ([exn:fail:contract:variable?
(compose raise rewriter)])
(#%top . id)))))]))
(define (beginner-top-continue/proc stx) (define (beginner-top-continue/proc stx)
(syntax-case stx () (syntax-case stx ()
[(_ id) [(_ id)
;; If there's still no binding, it's an "unknown name" error. ;; If there's still no binding, it's an "unknown name" error.
(if (not (identifier-binding #'id)) (if (not (identifier-binding #'id))
(teach-syntax-error (if (syntax-property #'id 'was-in-app-position)
'unknown (teach-syntax-error
#'id 'unknown
#f #'id
"name is not defined, not a parameter, and not a primitive name") #f
;; Don't use #%top here; id might have become bound to something "this function is not defined")
;; that isn't a value. (teach-syntax-error
#'id)])) 'unknown
#'id
#f
"this variable is not defined"))
;; Don't use #%top here; id might have become bound to something
;; that isn't a value.
#'id)]))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; cond ;; cond
@ -1256,7 +1259,7 @@
'cond 'cond
stx stx
#f #f
"expected a question--answer clause after `cond', but nothing's there")] "expected a clause after cond, but nothing's there")]
[(_ clause ...) [(_ clause ...)
(let* ([clauses (syntax->list (syntax (clause ...)))] (let* ([clauses (syntax->list (syntax (clause ...)))]
[check-preceding-exprs [check-preceding-exprs
@ -1284,8 +1287,8 @@
'cond 'cond
stx stx
clause clause
"found an `else' clause that isn't the last clause ~ "found an else clause that isn't the last clause ~
in its `cond' expression")) in its cond expression"))
(with-syntax ([new-test (stepper-syntax-property (syntax #t) 'stepper-else #t)]) (with-syntax ([new-test (stepper-syntax-property (syntax #t) 'stepper-else #t)])
(syntax/loc clause (new-test answer))))] (syntax/loc clause (new-test answer))))]
[(question answer) [(question answer)
@ -1297,14 +1300,14 @@
'cond 'cond
stx stx
clause clause
"expected a question--answer clause, but found an empty clause")] "expected a clause with a question and an answer, but found an empty part")]
[(question?) [(question?)
(check-preceding-exprs clause) (check-preceding-exprs clause)
(teach-syntax-error (teach-syntax-error
'cond 'cond
stx stx
clause clause
"expected a clause with a question and answer, but found a clause with only one part")] "expected a clause with a question and an answer, but found a clause with only one part")]
[(question? answer? ...) [(question? answer? ...)
(check-preceding-exprs clause) (check-preceding-exprs clause)
(let ([parts (syntax->list clause)]) (let ([parts (syntax->list clause)])
@ -1320,14 +1323,14 @@
'cond 'cond
stx stx
parts parts
"expected a clause with one question and one answer, but found a clause with ~a parts" "expected a clause with a question and an answer, but found a clause with ~a parts"
(length parts)))] (length parts)))]
[_else [_else
(teach-syntax-error (teach-syntax-error
'cond 'cond
stx stx
clause clause
"expected a question--answer clause, but found ~a" "expected a clause with a question and an answer, but found ~a"
(something-else clause))])) (something-else clause))]))
clauses)]) clauses)])
;; Add `else' clause for error (always): ;; Add `else' clause for error (always):
@ -1347,7 +1350,7 @@
'else 'else
expr expr
#f #f
"not allowed here, because this is not an immediate question in a `cond' clause")) "not allowed here, because this is not a question in a clause"))
(syntax-case stx (set! x) (syntax-case stx (set! x)
[(set! e expr) (bad #'e)] [(set! e expr) (bad #'e)]
[(e . expr) (bad #'e)] [(e . expr) (bad #'e)]
@ -1374,7 +1377,7 @@
'if 'if
stx stx
#f #f
"expected one question expression and two answer expressions, but found ~a expression~a" "expected a question and two answers, but found ~a part~a"
(if (zero? n) "no" n) (if (zero? n) "no" n)
(if (= n 1) "" "s")))] (if (= n 1) "" "s")))]
[_else (bad-use-error 'if stx)])))) [_else (bad-use-error 'if stx)]))))
@ -1402,7 +1405,7 @@
where where
stx stx
#f #f
"expected at least two expressions after `~a', but found ~a" "expected at least two expressions after ~a, but found ~a"
where where
(if (zero? n) "no expressions" "only one expression"))) (if (zero? n) "no expressions" "only one expression")))
(let loop ([clauses-consumed 0] (let loop ([clauses-consumed 0]
@ -1441,7 +1444,7 @@
'quote 'quote
stx stx
#f #f
"expected a name after a ', found ~a" "expected the name of the symbol after the quote, found ~a"
(something-else sym))) (something-else sym)))
(syntax/loc stx (quote expr)))] (syntax/loc stx (quote expr)))]
[_else (bad-use-error 'quote stx)])) [_else (bad-use-error 'quote stx)]))
@ -1640,7 +1643,7 @@
'local 'local
stx stx
orig orig
"expected only definitions within the definition sequence, but found ~a" "expected a definition, but found ~a"
(something-else orig))])) (something-else orig))]))
l origs)))] l origs)))]
[val-defns [val-defns
@ -1679,7 +1682,7 @@
'local 'local
stx stx
dup dup
"found a name that was defined locally more than once: ~a" "~a was defined locally more than once"
(syntax-e dup))) (syntax-e dup)))
(let ([exprs (syntax->list (syntax exprs))]) (let ([exprs (syntax->list (syntax exprs))])
(check-single-expression 'local (check-single-expression 'local
@ -1740,14 +1743,14 @@
'local 'local
stx stx
(syntax def-non-seq) (syntax def-non-seq)
"expected a parenthesized definition sequence after `local', but found ~a" "expected at least one definition (in square brackets) after local, but found ~a"
(something-else (syntax def-non-seq)))] (something-else (syntax def-non-seq)))]
[(_) [(_)
(teach-syntax-error (teach-syntax-error
'local 'local
stx stx
#f #f
"expected a parenthesized definition sequence after `local', but nothing's there")] "expected at least one definition (in square brackets) after local, but nothing's there")]
[_else (bad-use-error 'local stx)])))) [_else (bad-use-error 'local stx)]))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -1885,12 +1888,12 @@
who who
orig-stx orig-stx
name name
"expected a name for a local binding, but found ~a" "expected a variable for the binding, but found ~a"
(something-else/kw name))))] (something-else/kw name))))]
[(name . exprs) [(name . exprs)
(identifier/non-kw? (syntax name)) (identifier/non-kw? (syntax name))
(check-single-expression who (check-single-expression who
(format "after the name `~a'" (format "after the name ~a"
(syntax-e (syntax name))) (syntax-e (syntax name)))
binding binding
(syntax->list (syntax exprs)) (syntax->list (syntax exprs))
@ -1900,16 +1903,14 @@
who who
orig-stx orig-stx
(syntax something) (syntax something)
"expected a name after the parenthesis for a ~a local definition, but found ~a" "expected a variable after the square bracket, but found ~a"
who
(something-else/kw (syntax something)))] (something-else/kw (syntax something)))]
[_else [_else
(teach-syntax-error (teach-syntax-error
who who
orig-stx orig-stx
binding binding
"expected a parenthesized name and expression for a ~a local definition, but found ~a" "expected a binding with a variable and an expression, but found ~a"
who
(something-else binding))])) (something-else binding))]))
bindings) bindings)
(unless (eq? who 'let*) (unless (eq? who 'let*)
@ -1922,7 +1923,7 @@
who who
orig-stx orig-stx
dup dup
"found a name that was defined locally more than once: ~a" "~a was defined locally more than once"
(syntax-e dup))))) (syntax-e dup)))))
(let ([exprs (syntax->list (syntax exprs))]) (let ([exprs (syntax->list (syntax exprs))])
(check-single-expression who (check-single-expression who
@ -1935,7 +1936,7 @@
who who
orig-stx orig-stx
(syntax binding-non-seq) (syntax binding-non-seq)
"expected a parenthesized sequence of local name definitions after `~a', but found ~a" "expected at least one binding (in parentheses) after ~a, but found ~a"
who who
(something-else (syntax binding-non-seq)))] (something-else (syntax binding-non-seq)))]
[(_) [(_)
@ -1943,7 +1944,7 @@
who who
orig-stx orig-stx
#f #f
"expected a sequence of local name definitions after `~a', but nothing's there" "expected at least one binding (in parentheses) after ~a, but nothing's there"
who)] who)]
[_else [_else
(bad-use-error who stx)])) (bad-use-error who stx)]))
@ -1992,8 +1993,7 @@
'recur 'recur
stx stx
(syntax empty-seq) (syntax empty-seq)
"expected a non-empty sequence of bindings after the function name, ~ "expected at least one binding (in parentheses) after the function name, but found none")]
but found an empty sequence")]
[(_form fname . rest) [(_form fname . rest)
(identifier/non-kw? (syntax fname)) (identifier/non-kw? (syntax fname))
(bad-let-form 'recur (syntax (_form . rest)) stx)] (bad-let-form 'recur (syntax (_form . rest)) stx)]
@ -2002,14 +2002,14 @@
'recur 'recur
stx stx
#f #f
"expected a function name after `recur', but found ~a" "expected a function name after recur, but found ~a"
(something-else/kw (syntax fname)))] (something-else/kw (syntax fname)))]
[(_form) [(_form)
(teach-syntax-error (teach-syntax-error
'recur 'recur
stx stx
#f #f
"expected a function name after `recur', but nothing's there")] "expected a function name after recur, but nothing's there")]
[_else [_else
(bad-use-error 'recur stx)])))))]) (bad-use-error 'recur stx)])))))])
(values (mk #f) (mk #t)))) (values (mk #f) (mk #t))))
@ -2032,7 +2032,7 @@
'lambda 'lambda
stx stx
arg arg
"expected a name for a function argument, but found ~a" "expected a variable, but found ~a"
(something-else/kw arg)))) (something-else/kw arg))))
args) args)
(when (null? args) (when (null? args)
@ -2040,14 +2040,14 @@
'lambda 'lambda
stx stx
(syntax arg-seq) (syntax arg-seq)
"expected at least one argument name in the sequence after `lambda', but found none")) "expected at least one variable after lambda, but found none"))
(let ([dup (check-duplicate-identifier args)]) (let ([dup (check-duplicate-identifier args)])
(when dup (when dup
(teach-syntax-error (teach-syntax-error
'lambda 'lambda
stx stx
dup dup
"found an argument name that is used more than once: ~a" "found a variable that is used more than once: ~a"
(syntax-e dup)))) (syntax-e dup))))
(check-single-expression 'lambda (check-single-expression 'lambda
"within lambda" "within lambda"
@ -2061,14 +2061,14 @@
'lambda 'lambda
stx stx
(syntax args) (syntax args)
"expected a sequence of function arguments after `lambda', but found ~a" "expected at least one variable (in parentheses) after lambda, but found ~a"
(something-else (syntax args)))] (something-else (syntax args)))]
[(_) [(_)
(teach-syntax-error (teach-syntax-error
'lambda 'lambda
stx stx
#f #f
"expected a sequence of argument names after `lambda', but nothing's there")] "expected at least one variable (in parentheses) after lambda, but nothing's there")]
[_else [_else
(bad-use-error 'lambda stx)])))) (bad-use-error 'lambda stx)]))))
@ -2082,7 +2082,7 @@
[(_ expr ...) [(_ expr ...)
(begin (begin
(check-single-expression 'quote (check-single-expression 'quote
"after the `quote' keyword" "after the quote keyword"
stx stx
(syntax->list (syntax (expr ...))) (syntax->list (syntax (expr ...)))
;; Don't expand expr! ;; Don't expand expr!
@ -2106,7 +2106,7 @@
'quasiquote 'quasiquote
stx stx
#f #f
"misuse of `quasiquote'")] "misuse of quasiquote")]
[_else (bad-use-error 'quasiquote stx)])] [_else (bad-use-error 'quasiquote stx)])]
[depth 0]) [depth 0])
(syntax-case stx (intermediate-unquote intermediate-unquote-splicing intermediate-quasiquote) (syntax-case stx (intermediate-unquote intermediate-unquote-splicing intermediate-quasiquote)
@ -2121,7 +2121,7 @@
'quasiquote 'quasiquote
stx stx
#f #f
"misuse of `unquote' within a quasiquoting backquote")] "misuse of unquote within a quasiquoting backquote")]
[((intermediate-unquote-splicing x) . rest) [((intermediate-unquote-splicing x) . rest)
(if (zero? depth) (if (zero? depth)
(with-syntax ([rest (loop (syntax rest) depth)]) (with-syntax ([rest (loop (syntax rest) depth)])
@ -2137,7 +2137,7 @@
'quasiquote 'quasiquote
stx stx
#f #f
"misuse of ,@ or `unquote-splicing' within a quasiquoting backquote")] "misuse of ,@ or unquote-splicing within a quasiquoting backquote")]
[(intermediate-quasiquote x) [(intermediate-quasiquote x)
(with-syntax ([x (loop (syntax x) (add1 depth))] (with-syntax ([x (loop (syntax x) (add1 depth))]
[qq (stx-car stx)]) [qq (stx-car stx)])
@ -2156,14 +2156,14 @@
'unquote 'unquote
stx stx
#f #f
"misuse of a comma or `unquote', not under a quasiquoting backquote")) "misuse of a comma or unquote, not under a quasiquoting backquote"))
(define (intermediate-unquote-splicing/proc stx) (define (intermediate-unquote-splicing/proc stx)
(teach-syntax-error (teach-syntax-error
'unquote-splicing 'unquote-splicing
stx stx
#f #f
"misuse of ,@ or `unquote-splicing', not under a quasiquoting backquote")) "misuse of ,@ or unquote-splicing, not under a quasiquoting backquote"))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; time ;; time
@ -2176,7 +2176,7 @@
(syntax-case stx () (syntax-case stx ()
[(_ . exprs) [(_ . exprs)
(check-single-expression 'time (check-single-expression 'time
"after `time'" "after time"
stx stx
(syntax->list (syntax exprs)) (syntax->list (syntax exprs))
null) null)
@ -2249,7 +2249,7 @@
'lambda 'lambda
stx stx
name name
"expected a name for an argument, but found ~a" "expected a variable, but found ~a"
(something-else/kw name)))) (something-else/kw name))))
names) names)
(let ([dup (check-duplicate-identifier names)]) (let ([dup (check-duplicate-identifier names)])
@ -2258,10 +2258,10 @@
'lambda 'lambda
stx stx
dup dup
"found an argument name that is used more than once: ~a" "found a variable that is used more than once: ~a"
(syntax-e dup)))) (syntax-e dup))))
(check-single-expression 'lambda (check-single-expression 'lambda
"after the argument-name sequence" "after the variables"
stx stx
(syntax->list (syntax exprs)) (syntax->list (syntax exprs))
names) names)
@ -2271,14 +2271,14 @@
'lambda 'lambda
stx stx
(syntax arg-non-seq) (syntax arg-non-seq)
"expected a parenthesized sequence of argument names after `lambda', but found ~a" "expected at least one variable (in parentheses) after lambda, but found ~a"
(something-else (syntax arg-non-seq)))] (something-else (syntax arg-non-seq)))]
[(_) [(_)
(teach-syntax-error (teach-syntax-error
'lambda 'lambda
stx stx
#f #f
"expected a sequence of argument names after `lambda', but nothing's there")] "expected at least one variable (in parentheses) after lambda, but nothing's there")]
[_else [_else
(bad-use-error 'lambda stx)])))) (bad-use-error 'lambda stx)]))))
@ -2292,14 +2292,14 @@
(lambda () (lambda ()
(syntax-case stx () (syntax-case stx ()
[(_ rator rand ...) [(_ rator rand ...)
(syntax/loc stx (#%app rator rand ...))] (with-syntax ([new-rator (syntax-property #'rator 'was-in-app-position #t)])
(syntax/loc stx (#%app new-rator rand ...)))]
[(_) [(_)
(teach-syntax-error (teach-syntax-error
'|function call| '|function call|
stx stx
#f #f
"expected a defined function name or a primitive operation name after an ~ "expected a function after the open parenthesis, but nothing's there")]
open parenthesis, but nothing's there")]
[_else (bad-use-error '#%app stx)])))) [_else (bad-use-error '#%app stx)]))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -2333,14 +2333,14 @@
'set! 'set!
stx stx
(syntax id) (syntax id)
"expected a defined name after `set!', but found a keyword")))))) "expected a variable after set!, but found a ~a" (syntax-e #'id)))))))
;; Now try lexical: ;; Now try lexical:
(when (eq? 'lexical (identifier-binding (syntax id))) (when (eq? 'lexical (identifier-binding (syntax id)))
(teach-syntax-error (teach-syntax-error
'set! 'set!
stx stx
(syntax id) (syntax id)
"expected a defined name after `set!', but found a function argument name"))) "expected a mutable variable after set!, but found a variable that cannot be modified")))
;; If we're in a module, we'd like to check here whether ;; If we're in a module, we'd like to check here whether
;; the identier is bound, but we need to delay that check ;; the identier is bound, but we need to delay that check
;; in case the id is defined later in the module. So only ;; in case the id is defined later in the module. So only
@ -2354,7 +2354,7 @@
'unknown 'unknown
#'id #'id
#f #f
"name is not defined")] "this variable is not defined")]
[(and (list? binding) [(and (list? binding)
(or (not (module-path-index? (car binding))) (or (not (module-path-index? (car binding)))
(let-values ([(path rel) (module-path-index-split (car binding))]) (let-values ([(path rel) (module-path-index-split (car binding))])
@ -2363,7 +2363,7 @@
'unknown 'unknown
#'id #'id
#f #f
"cannot set a primitive name")]))) "expected a mutable variable after set!, but found a variable that cannot be modified")])))
;; Check the RHS ;; Check the RHS
(check-single-expression 'set! (check-single-expression 'set!
"for the new value" "for the new value"
@ -2382,14 +2382,14 @@
'set! 'set!
stx stx
(syntax id) (syntax id)
"expected a defined name after `set!', but found ~a" "expected a variable after set!, but found ~a"
(something-else (syntax id)))] (something-else (syntax id)))]
[(_) [(_)
(teach-syntax-error (teach-syntax-error
'set! 'set!
stx stx
(syntax id) (syntax id)
"expected a defined name after `set!', but nothing's there")] "expected a variable after set!, but nothing's there")]
[_else (bad-use-error 'set! stx)])))))]) [_else (bad-use-error 'set! stx)])))))])
(values (proc #f) (values (proc #f)
(proc #t)))) (proc #t))))
@ -2409,7 +2409,7 @@
[(_ q expr ...) [(_ q expr ...)
(let ([exprs (syntax->list (syntax (expr ...)))]) (let ([exprs (syntax->list (syntax (expr ...)))])
(check-single-expression who (check-single-expression who
(format "for the answer in `~a'" (format "for the answer in ~a"
who) who)
stx stx
exprs exprs
@ -2422,7 +2422,7 @@
who who
stx stx
#f #f
"expected a question expression after `~a', but nothing's there" "expected a question after ~a, but nothing's there"
who)] who)]
[_else [_else
(bad-use-error who stx)])))))]) (bad-use-error who stx)])))))])
@ -2454,7 +2454,7 @@
'let 'let
stx stx
#f #f
"bad syntax for named `let'")] "bad syntax for named let")]
[(_ . rest) [(_ . rest)
(syntax/loc stx (intermediate-let . rest))] (syntax/loc stx (intermediate-let . rest))]
[_else [_else
@ -2472,7 +2472,7 @@
'begin 'begin
stx stx
#f #f
"expected a sequence of expressions after `begin', but nothing's there")] "expected at least one expression after begin, but nothing's there")]
[(_ e ...) [(_ e ...)
(stepper-syntax-property (syntax/loc stx (let () e ...)) (stepper-syntax-property (syntax/loc stx (let () e ...))
'stepper-hint 'stepper-hint
@ -2491,7 +2491,7 @@
'begin 'begin
stx stx
#f #f
"expected a sequence of expressions after `begin0', but nothing's there")] "expected at least one expression after begin0, but nothing's there")]
[(_ e ...) [(_ e ...)
(syntax/loc stx (begin0 e ...))] (syntax/loc stx (begin0 e ...))]
[_else [_else
@ -2511,13 +2511,13 @@
'case 'case
stx stx
#f #f
"expected an expression after `case', but nothing's there")] "expected an expression after case, but nothing's there")]
[(_ expr) [(_ expr)
(teach-syntax-error (teach-syntax-error
'case 'case
stx stx
#f #f
"expected a choices--answer clause after the expression following `case', but nothing's there")] "expected a clause with choices and an answer after the expression, but nothing's there")]
[(_ v-expr clause ...) [(_ v-expr clause ...)
(let ([clauses (syntax->list (syntax (clause ...)))]) (let ([clauses (syntax->list (syntax (clause ...)))])
(for-each (for-each
@ -2530,8 +2530,8 @@
'case 'case
stx stx
clause clause
"found an `else' clause that isn't the last clause ~ "found an else clause that isn't the last clause ~
in its `case' expression")) in its case expression"))
(let ([answers (syntax->list (syntax (answer ...)))]) (let ([answers (syntax->list (syntax (answer ...)))])
(check-single-expression 'case (check-single-expression 'case
"for the answer in a case clause" "for the answer in a case clause"
@ -2552,23 +2552,23 @@
'case 'case
stx stx
e e
"expected a name (for a symbol) or a number as a choice value, but found ~a" "expected a symbol (without its quote) or a number as a choice, but found ~a"
(something-else e))))) (something-else e)))))
elems))] elems))]
[_else (teach-syntax-error [_else (teach-syntax-error
'case 'case
stx stx
choices choices
"expected a parenthesized sequence of choice values, but found ~a" "expected at least one choice (in parentheses), but found ~a"
(something-else choices))]) (something-else choices))])
(when (stx-null? choices) (when (stx-null? choices)
(teach-syntax-error (teach-syntax-error
'case 'case
stx stx
choices choices
"expected at least once choice in a parenthesized sequence of choice values, but nothing's there")) "expected at least one choice (in parentheses), but nothing's there"))
(check-single-expression 'case (check-single-expression 'case
"for the answer in a `case' clause" "for the answer in a case clause"
clause clause
answers answers
null))] null))]
@ -2577,13 +2577,13 @@
'case 'case
stx stx
clause clause
"expected a choices--answer clause, but found an empty clause")] "expected a clause with at least one choice (in parentheses) and an answer, but found an empty part")]
[_else [_else
(teach-syntax-error (teach-syntax-error
'case 'case
stx stx
clause clause
"expected a choices--answer clause, but found ~a" "expected a clause with at least one choice (in parentheses) and an answer, but found ~a"
(something-else clause))])) (something-else clause))]))
clauses) clauses)
;; Add `else' clause for error, if necessary: ;; Add `else' clause for error, if necessary:
@ -2743,7 +2743,7 @@
[(_ expr ...) [(_ expr ...)
(begin (begin
(check-single-expression 'delay (check-single-expression 'delay
"after the `delay' keyword" "after the delay keyword"
stx stx
(syntax->list (syntax (expr ...))) (syntax->list (syntax (expr ...)))
null) null)
@ -2793,20 +2793,20 @@
'shared 'shared
stx stx
(syntax a) (syntax a)
"expected a name for the binding, but found ~a" "expected a variable for the binding, but found ~a"
(something-else/kw (syntax a)))] (something-else/kw (syntax a)))]
[() [()
(teach-syntax-error (teach-syntax-error
'shared 'shared
stx stx
(syntax a) (syntax a)
"expected a name for a binding, but nothing's there")] "expected a variable for a binding, but nothing's there")]
[_else [_else
(teach-syntax-error (teach-syntax-error
'shared 'shared
stx stx
binding binding
"expected a name--expression pair for a binding, but found ~a" "expected a binding with a variable and an expression, but found ~a"
(something-else binding))])) (something-else binding))]))
bindings) bindings)
(check-single-expression 'shared (check-single-expression 'shared
@ -2819,14 +2819,14 @@
'shared 'shared
stx stx
(syntax bad-bind) (syntax bad-bind)
"expected a sequence of bindings after `shared', but found ~a" "expected at least one binding (in parentheses) after shared, but found ~a"
(something-else (syntax bad-bind)))] (something-else (syntax bad-bind)))]
[(_) [(_)
(teach-syntax-error (teach-syntax-error
'shared 'shared
stx stx
(syntax bad-bind) (syntax bad-bind)
"expected a sequence of bindings after `shared', but nothing's there")] "expected at least one binding (in parentheses) after shared, but nothing's there")]
[_else (bad-use-error 'shared stx)]) [_else (bad-use-error 'shared stx)])
;; The main implementation ;; The main implementation

9
collects/lang/private/teachhelp.rkt
View File

@ -41,7 +41,7 @@
'stepper-skipto 'stepper-skipto
(append skipto/cdr (append skipto/cdr
skipto/third))]))))) skipto/third))])))))
#;
(define (appropriate-use what) (define (appropriate-use what)
(case what (case what
[(constructor) [(constructor)
@ -63,9 +63,7 @@
(identifier? #'id) (identifier? #'id)
(raise-syntax-error (raise-syntax-error
#f #f
(format "this is a ~a, so it must be ~a (which requires using a parenthesis before the name)" (format "found a use that does not follow an open parenthesis")
what
(appropriate-use what))
stx stx
#f)] #f)]
[(id . rest) [(id . rest)
@ -73,8 +71,7 @@
(unless (= l arity) (unless (= l arity)
(raise-syntax-error (raise-syntax-error
#f #f
(format "this ~a expects ~a argument~a, here it is provided ~a argument~a" (format "this function expects ~a argument~a, here it is provided ~a argument~a"
what
arity (if (= 1 arity) "" "s") arity (if (= 1 arity) "" "s")
l (if (= 1 l) "" "s")) l (if (= 1 l) "" "s"))
stx stx

69
collects/lang/private/teachprims.rkt
View File

@ -67,8 +67,8 @@ namespace.
(unless (ok? b) (unless (ok? b)
(raise (raise
(make-exn:fail:contract (make-exn:fail:contract
(format "~a: second argument must be of type <~a>, given ~e and ~e" (format "~a: second argument must be ~a ~a, but received ~e and ~e"
prim-name type prim-name (a-or-an type) type
a b) a b)
(current-continuation-marks)))))) (current-continuation-marks))))))
@ -88,8 +88,8 @@ namespace.
(unless (ok? last) (unless (ok? last)
(raise (raise
(make-exn:fail:contract (make-exn:fail:contract
(format "~a: last argument must be of type <~a>, given ~e; other args:~a" (format "~a: last argument must be ~a ~a, but received ~e; the other arguments were: ~a"
prim-name type prim-name (a-or-an type) type
last last
;; all-but-last: ;; all-but-last:
(build-arg-list (build-arg-list
@ -111,7 +111,7 @@ namespace.
(lambda (v which type) (lambda (v which type)
(raise (raise
(make-exn:fail:contract (make-exn:fail:contract
(format "~a: ~a argument must be of type <~a>, given ~e, ~e, and ~e" (format "~a: ~a argument must be of a ~a, given ~e, ~e, and ~e"
prim-name which type prim-name which type
a b c) a b c)
(current-continuation-marks))))]) (current-continuation-marks))))])
@ -154,7 +154,7 @@ namespace.
(unless (number? a) (unless (number? a)
(raise (raise
(make-exn:fail:contract (make-exn:fail:contract
(format "sqr: expected number; given ~e" a) (format "sqr: expected a number; given ~e" a)
(current-continuation-marks)))) (current-continuation-marks))))
(sqr a))) (sqr a)))
@ -335,30 +335,31 @@ namespace.
(define-teach intermediate foldr (define-teach intermediate foldr
(lambda (f e l) (lambda (f e l)
(unless (and (procedure? f) (procedure-arity-includes? f 2)) (unless (and (procedure? f) (procedure-arity-includes? f 2))
(hocheck 'foldr "first argument must be a <procedure> that accepts two arguments, given ~e" f)) (hocheck 'foldr "first argument must be a function that expects two arguments, given ~e" f))
(unless (beginner-list? l) (unless (beginner-list? l)
(hocheck 'foldr "third argument must be of type <list>, given ~e" l)) (hocheck 'foldr "third argument must be a list, given ~e" l))
(foldr f e l))) (foldr f e l)))
(define-teach intermediate foldl (define-teach intermediate foldl
(lambda (f e l) (lambda (f e l)
(unless (and (procedure? f) (procedure-arity-includes? f 2)) (unless (and (procedure? f) (procedure-arity-includes? f 2))
(hocheck 'foldl "first argument must be a <procedure> that accepts two arguments, given ~e" f)) (hocheck 'foldl "first argument must be a function that expects two arguments, given ~e" f))
(unless (beginner-list? l) (unless (beginner-list? l)
(hocheck 'foldl "third argument must be of type <list>, given ~e" l)) (hocheck 'foldl "third argument must be a list, given ~e" l))
(foldl f e l))) (foldl f e l)))
(define-teach intermediate build-string (define-teach intermediate build-string
(lambda (n f) (lambda (n f)
(unless (and (procedure? f) (procedure-arity-includes? f 1)) (unless (and (procedure? f) (procedure-arity-includes? f 1))
(hocheck 'build-string "second argument must be a <procedure> that accepts one argument, given ~e" f)) (hocheck 'build-string "second argument must be a function that accepts one argument, given ~e" f))
(unless (and (number? n) (integer? n) (>= n 0)) (unless (and (number? n) (integer? n) (>= n 0))
(hocheck 'build-string "first argument must be of type <natural number>, given ~e" n)) (hocheck 'build-string "first argument must be a natural number, given ~e" n))
(build-string n (lambda (i) (build-string n (lambda (i)
(define r (f i)) (define r (f i))
(unless (char? r) (unless (char? r)
(hocheck 'build-string (hocheck 'build-string
"second argument must be a <procedure> that produces a <char>, given ~e, which produced ~e for ~e" f r i)) "the second argument must be a function that produces a character, ~
given ~e, which produced ~e for ~e" f r i))
r)))) r))))
@ -447,24 +448,24 @@ namespace.
;; auxiliary stuff, ignore ;; auxiliary stuff, ignore
(define 1-LET "1-letter string") (define 1-LET "1-letter string")
(define 1-LETTER (format "<~a>" 1-LET)) (define 1-LETTER (format "~a" 1-LET))
(define 1-LETTER* (format "<list of ~as>" 1-LET)) (define 1-LETTER* (format "list of ~as" 1-LET))
(define NAT "<natural number>") (define NAT "natural number")
;; Symbol Any -> Boolean ;; Symbol Any -> Boolean
;; is this a 1-letter string? ;; is this a 1-letter string?
(define (1-letter? tag s) (define (1-letter? tag s)
(unless (string? s) (err tag "~a expected, not a string: ~e" 1-LETTER s)) (unless (string? s) (err tag "expected a ~a, but received a string: ~e" 1-LETTER s))
(= (string-length s) 1)) (= (string-length s) 1))
;; Symbol Any -> Boolean ;; Symbol Any -> Boolean
;; is s a list of 1-letter strings ;; is s a list of 1-letter strings
;; effect: not a list, not a list of strings ;; effect: not a list, not a list of strings
(define (1-letter*? tag s) (define (1-letter*? tag s)
(unless (list? s) (err tag "~a expected, not a <list>: ~e" 1-LETTER* s)) (unless (list? s) (err tag "expected a ~a, but received a list: ~e" 1-LETTER* s))
(for-each (for-each
(lambda (c) (lambda (c)
(unless (string? c) (err tag "~a expected, not a <string>: ~e" 1-LETTER* c))) (unless (string? c) (err tag "expected a ~a, but received a string: ~e" 1-LETTER* c)))
s) s)
(andmap (compose (curry = 1) string-length) s)) (andmap (compose (curry = 1) string-length) s))
@ -474,25 +475,29 @@ namespace.
(apply format (string-append (symbol->string tag) ": " msg-format) args) (apply format (string-append (symbol->string tag) ": " msg-format) args)
(current-continuation-marks)))) (current-continuation-marks))))
(define (a-or-an after)
(if (member (string-ref (format "~a" after) 0) '(#\a #\e #\i #\o #\u))
"an" "a"))
(define cerr (define cerr
(case-lambda (case-lambda
[(tag check-result format-msg actual) [(tag check-result format-msg actual)
(unless check-result (unless check-result
(err tag (string-append format-msg " expected, given ~e") actual))] (err tag (string-append "expected " (a-or-an format-msg) " " format-msg ", but received ~e") actual))]
[(tag check-result format-msg actual snd) [(tag check-result format-msg actual snd)
(unless check-result (unless check-result
(err tag (string-append format-msg " for ~a argument expected, given ~e") (err tag (string-append "expected " (a-or-an format-msg) " " format-msg " for the ~a argument, but received ~e")
snd actual))])) snd actual))]))
;; ----------------------------------------------------------------------------- ;; -----------------------------------------------------------------------------
(define-teach beginner string-ith (define-teach beginner string-ith
(lambda (s n) (lambda (s n)
(define f "<exact integer in [0, length of the given string (~s))>") (define f "exact integer in [0, length of the given string]")
(cerr 'string-ith (string? s) "<string>" s "first") (cerr 'string-ith (string? s) "string" s "first")
(cerr 'string-ith (and (number? n) (integer? n) (>= n 0)) NAT n "second") (cerr 'string-ith (and (number? n) (integer? n) (>= n 0)) NAT n "second")
(let ([l (string-length s)]) (let ([l (string-length s)])
(cerr 'string-ith (< n l) (format f l) n "second")) (cerr 'string-ith (< n l) f n "second"))
(string (string-ref s n)))) (string (string-ref s n))))
;; ----------------------------------------------------------------------------- ;; -----------------------------------------------------------------------------
@ -500,7 +505,7 @@ namespace.
(define-teach beginner replicate (define-teach beginner replicate
(lambda (n s1) (lambda (n s1)
(cerr 'replicate (and (number? n) (exact-integer? n) (>= n 0)) NAT n) (cerr 'replicate (and (number? n) (exact-integer? n) (>= n 0)) NAT n)
(cerr 'replicate (string? s1) "<string>" s1) (cerr 'replicate (string? s1) "string" s1)
(apply string-append (build-list n (lambda (i) s1))))) (apply string-append (build-list n (lambda (i) s1)))))
;; ----------------------------------------------------------------------------- ;; -----------------------------------------------------------------------------
@ -509,7 +514,7 @@ namespace.
(lambda (i) (lambda (i)
(cerr 'int->string (cerr 'int->string
(and (exact-integer? i) (or (<= 0 i 55295) (<= 57344 i 1114111))) (and (exact-integer? i) (or (<= 0 i 55295) (<= 57344 i 1114111)))
"<exact integer in [0,55295] or [57344 1114111]>" "exact integer in [0,55295] or [57344 1114111]"
i) i)
(string (integer->char i)))) (string (integer->char i))))
@ -524,7 +529,7 @@ namespace.
(define-teach beginner explode (define-teach beginner explode
(lambda (s) (lambda (s)
(cerr 'explode (string? s) "<string>" s) (cerr 'explode (string? s) "string" s)
(map string (string->list s)))) (map string (string->list s))))
;; ----------------------------------------------------------------------------- ;; -----------------------------------------------------------------------------
@ -539,7 +544,7 @@ namespace.
(define-teach beginner string-numeric? (define-teach beginner string-numeric?
;; is this: (number? (string->number s)) enough? ;; is this: (number? (string->number s)) enough?
(lambda (s1) (lambda (s1)
(cerr 'string-numeric? (string? s1) "<string>" s1) (cerr 'string-numeric? (string? s1) "string" s1)
(andmap char-numeric? (string->list s1)))) (andmap char-numeric? (string->list s1))))
;; ----------------------------------------------------------------------------- ;; -----------------------------------------------------------------------------
@ -548,14 +553,14 @@ namespace.
(define-teach beginner string-alphabetic? (define-teach beginner string-alphabetic?
(lambda (s1) (lambda (s1)
(cerr 'string-alphabetic? (string? s1) "<string>" s1) (cerr 'string-alphabetic? (string? s1) "string" s1)
(andmap char-alphabetic? (string->list s1)))) (andmap char-alphabetic? (string->list s1))))
;; ----------------------------------------------------------------------------- ;; -----------------------------------------------------------------------------
(define-teach beginner string-whitespace? (define-teach beginner string-whitespace?
(lambda (s) (lambda (s)
(cerr 'string-whitespace? (string? s) "<string>" s) (cerr 'string-upper-case? (string? s) "string" s)
(andmap char-whitespace? (string->list s)))) (andmap char-whitespace? (string->list s))))
;; ----------------------------------------------------------------------------- ;; -----------------------------------------------------------------------------
@ -563,14 +568,14 @@ namespace.
(define-teach beginner string-upper-case? (define-teach beginner string-upper-case?
(lambda (s) (lambda (s)
(cerr 'string-upper-case? (string? s) "<string>" s) (cerr 'string-upper-case? (string? s) "string" s)
(andmap char-upper-case? (string->list s)))) (andmap char-upper-case? (string->list s))))
;; ----------------------------------------------------------------------------- ;; -----------------------------------------------------------------------------
(define-teach beginner string-lower-case? (define-teach beginner string-lower-case?
(lambda (s) (lambda (s)
(cerr 'string-lower-case? (string? s) "<string>" s) (cerr 'string-lower-case? (string? s) "string" s)
(andmap char-lower-case? (string->list s)))) (andmap char-lower-case? (string->list s))))
(provide (provide