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

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

@ -1,18 +1,54 @@
#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)
;; 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)
;; 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)
;; 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)))
;; 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))
;; 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)
(provide/contract [struct colored-error-message
([fragments (listof msg-fragment?)]
[additional-highlights srcloc-syntax/c])]
[additional-highlights additional-highlights/c])]
[struct msg-fragment:str ([str string?])]
[struct msg-fragment:v ([v any/c])]
[struct colored-msg-fragment ([locs srcloc-syntax/c]
@ -20,6 +56,8 @@
[important boolean?]
[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
exn:colored-message?
exn:colored-message-accessor)
@ -29,6 +67,9 @@
(contract (exn? . -> . colored-error-message?) v
'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?)])
(define (get-error-messages/color exn)
(cond [(exn:colored-message? exn) ((exn:colored-message-accessor exn) exn)]
@ -38,13 +79,6 @@
[else
(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
[(eof) empty]
@ -62,6 +96,11 @@
(test 'lex (check-equal? (lex (open-input-string "~~foo ~| ~~| bar ~v|~ 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)
(let loop ([tildas (filter (// match? <> (or 'TildaPipe 'PipeTilda)) parsed)] [i 1])
(match tildas
@ -133,8 +172,25 @@
(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))
(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?])])
;; 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 parsed (lex (open-input-string fmt)))
@ -186,13 +242,14 @@
(match f
[(msg-fragment:str str) str]
[(msg-fragment:v v) (format "~a" v)]
[(colored-msg-fragment locs frags imp col)
(string-append* (map loop frags))])))
[(colored-msg-fragment locs frags imp col) (loop frags)]
[(? list?) (string-append* (map loop f))])))
(define (important-srclocs msg)
(append
(flatten
(filter-map (// match <> [(colored-msg-fragment locs _ #t _) locs] [_ #f])
(colored-error-message-fragments msg))
(colored-error-message-fragments msg)))
(colored-error-message-additional-highlights msg)))
(struct exn:fail:colored:syntax exn:fail:syntax (colored-message)
@ -201,14 +258,30 @@
(define vec (struct->vector v))
(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 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)
(current-continuation-marks)
(important-srclocs 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

4
collects/lang/error.rkt
View File

@ -55,7 +55,7 @@
(define arity-error "expects at least ~a arguments, given ~e")
;; 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 :
;; sym (... *->* ...) num (union sym str) (union sym str) -> void
@ -74,5 +74,5 @@
[else (format "multiple arities (~s)" arity-of-f)])))))
;; 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 ")
)

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

@ -6,11 +6,13 @@
(require mzlib/etc
mzlib/list
syntax/docprovide
"private/rewrite-error-message.rkt"
(for-syntax "private/rewrite-error-message.rkt")
(for-syntax scheme/base))
;; Implements the forms:
(require "private/teach.rkt"
"private/teach-module-begin.rkt"
(require "private/teach.ss"
"private/teach-module-begin.ss"
test-engine/scheme-tests)
;; syntax:
@ -84,15 +86,14 @@
(lambda (stx)
(syntax-case stx ()
[(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
(raise-syntax-error
#f
(format
"this ~a must be ~a; expected an open parenthesis before the ~a name"
what
something
what)
"found a use that does not follow an open parenthesis")
stx)]))
#'orig-name)))))]))

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

@ -1,7 +1,9 @@
(module htdp-intermediate scheme/base
(require "private/teach.rkt"
"private/teachprims.rkt"
"private/teach-module-begin.rkt"
(require "private/teach.ss"
"private/teachprims.ss"
"private/teach-module-begin.ss"
"private/rewrite-error-message.rkt"
mzlib/etc
mzlib/list
syntax/docprovide

24
collects/lang/prim.rkt
View File

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

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

@ -13,9 +13,8 @@
(define (arity-check t r f a)
(unless (and (procedure? f) (procedure-arity-includes? f a))
(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 <procedure> that accepts ~a arguments, given ~e" r a f))))
(hocheck t "~a argument must be a function that accepts one argument, given ~e" r f)
(hocheck t "~a argument must be a function that accepts ~a arguments, given ~e" r a f))))
(define-syntax-rule
(boolean-test-wrapper tag (f z ...))
@ -27,12 +26,12 @@
(define f@x (f z ...))
(if (boolean? 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))
(define (list-check? name msg 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 ---
@ -43,7 +42,7 @@
(arity-check 'name "first" f 1)
(list-check? 'name "second" 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)))
(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

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

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

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

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

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

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