1dc0072d03
Add extra intitial-message lines, use "..." on a field name to indicate that it could reasonably be hidden by default, and refine some existing messages.
152 lines
6.2 KiB
Racket
152 lines
6.2 KiB
Racket
#lang scheme/base
|
|
|
|
(require mzlib/etc
|
|
mzlib/list
|
|
(for-syntax "firstorder.rkt"
|
|
scheme/base))
|
|
|
|
(provide rewrite-contract-error-message
|
|
reraise-rewriten-lookup-error-message
|
|
get-rewriten-error-message
|
|
plural
|
|
raise-not-bound-error
|
|
argcount-error-message)
|
|
|
|
(define (reraise-rewriten-lookup-error-message e id was-in-app-position)
|
|
(let ([var-or-function (if was-in-app-position "function" "variable")])
|
|
(raise-syntax-error
|
|
#f
|
|
(format "this ~a is not defined" var-or-function)
|
|
id)))
|
|
|
|
(define (exn-needs-rewriting? exn)
|
|
(exn:fail:contract? exn))
|
|
|
|
(define (ensure-number n-or-str)
|
|
(if (string? n-or-str) (string->number n-or-str) n-or-str))
|
|
|
|
(define (plural n)
|
|
(if (> (ensure-number n) 1) "s" ""))
|
|
|
|
(define (raise-not-bound-error id)
|
|
(if (syntax-property id 'was-in-app-position)
|
|
(raise-syntax-error
|
|
#f
|
|
"this function is not defined"
|
|
id)
|
|
(raise-syntax-error
|
|
#f
|
|
"this variable is not defined"
|
|
id)))
|
|
|
|
(define (argcount-error-message name arity found [at-least #f])
|
|
(define arity:n (ensure-number arity))
|
|
(define found:n (ensure-number found))
|
|
(define fn-is-large (> arity:n found:n))
|
|
(format "~a~aexpects ~a~a~a argument~a, but found ~a~a"
|
|
(or name "") (if name ": " "")
|
|
(if at-least "at least " "")
|
|
(if (or (= arity:n 0) fn-is-large) "" "only ")
|
|
(if (= arity:n 0) "no" arity:n) (plural arity:n)
|
|
(if (and (not (= found:n 0)) fn-is-large) "only " "")
|
|
(if (= found:n 0) "none" found:n)))
|
|
|
|
(define (format-enum conj l)
|
|
(if (= (length l) 2)
|
|
(format "~a ~a ~a" (car l) conj (cadr l))
|
|
(apply string-append
|
|
(let loop ([l l])
|
|
(cond
|
|
[(null? (cdr l)) l]
|
|
[(null? (cddr l))
|
|
(list* (car l) ", " conj " " (loop (cdr l)))]
|
|
[else
|
|
(list* (car l) ", " (loop (cdr l)))])))))
|
|
|
|
(define (contract-to-desc ctc)
|
|
(with-handlers ([exn:fail:read? (lambda (exn) ctc)])
|
|
(define s (read (open-input-string ctc)))
|
|
(let loop ([s s])
|
|
(cond
|
|
[(not s) "false"]
|
|
[(and (symbol? s) (regexp-match? #rx"[?]$" (symbol->string s)))
|
|
(define str (symbol->string s))
|
|
(format "a~a ~a"
|
|
(if (and ((string-length str) . > . 0)
|
|
(memv (string-ref str 0) '(#\a #\e #\i #\o #\u)))
|
|
"n"
|
|
"")
|
|
(substring str 0 (sub1 (string-length str))))]
|
|
[(null? s) "an impossible value"]
|
|
[(not (list? s)) ctc] ;; ???
|
|
[(eq? 'or/c (car s))
|
|
(format-enum "or" (map loop (cdr s)))]
|
|
[(eq? 'and/c (car s))
|
|
(string-append "a value that is " (format-enum "and" (map loop (cdr s))))]
|
|
[(eq? 'not/c (car s))
|
|
(format "a value that is not ~a" (loop (cadr s)))]
|
|
[(and (eq? '>/c (car s)) (zero? (cadr s)))
|
|
"a positive number"]
|
|
[(and (eq? '</c (car s)) (zero? (cadr s)))
|
|
"a negative number"]
|
|
[(and (eq? '>=/c (car s)) (zero? (cadr s)))
|
|
"a non-negative number"]
|
|
[else ctc]))))
|
|
|
|
(define (contract-error-message ctc given pos)
|
|
(define d (contract-to-desc ctc))
|
|
(format "expects ~a~a~a~a, given ~a"
|
|
d
|
|
(if pos " as " "")
|
|
(or pos "")
|
|
(if pos " argument" "")
|
|
given))
|
|
|
|
(define (rewrite-contract-error-message msg)
|
|
(define replacements
|
|
(list (list #rx"application: not a procedure;\n [^\n]*?\n given: ([^\n]*)(?:\n arguments[.][.][.]:(?: [[]none[]]|(?:\n [^\n]*)*))?"
|
|
(lambda (all one)
|
|
(format "function call: expected a function after the open parenthesis, but received ~a" one)))
|
|
(list #rx"([^\n]*): undefined;\n cannot reference an identifier before its definition"
|
|
(lambda (all one) (format "~a is used here before its definition" one)))
|
|
(list #rx"expects argument of type (<([^>]+)>)"
|
|
(lambda (all one two) (format "expects a ~a" two)))
|
|
(list #rx"expected 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)))
|
|
(list #px"([^\n]*): arity mismatch;\n[^\n]*\n expected[^:]*: at least (\\d+)\n given[^:]*: (\\d+)(?:\n arguments[.][.][.]:(?:\n [^\n]*)*)?"
|
|
(lambda (all one two three) (argcount-error-message one two three #t)))
|
|
(list #px"([^\n]*): arity mismatch;\n[^\n]*\n expected[^:]*: (\\d+)\n given[^:]*: (\\d+)(?:\n arguments[.][.][.]:(?:\n [^\n]*)*)?"
|
|
(lambda (all one two three) (argcount-error-message one two three)))
|
|
(list #px"contract violation\n expected: (.*?)\n given: ([^\n]*)(?:\n argument position: ([^\n]*))?"
|
|
(lambda (all ctc given pos) (contract-error-message ctc given pos)))
|
|
(list #rx"^procedure "
|
|
(lambda (all) ""))
|
|
(list #rx", given: "
|
|
(lambda (all) ", given "))
|
|
(list #rx"; other arguments were:.*"
|
|
(lambda (all) ""))
|
|
(list #px"(?:\n other arguments[.][.][.]:(?:\n [^\n]*)*)"
|
|
(lambda (all) ""))
|
|
(list #rx"expects a (struct:)"
|
|
(lambda (all one) "expects a "))
|
|
(list #rx"list or cyclic list"
|
|
(lambda (all) "list"))
|
|
(list #rx"assignment disallowed;\n cannot set variable before its definition\n variable:"
|
|
(lambda (all) "cannot set variable before its definition:"))
|
|
;; When do these show up? I see only `#<image>' errors, currently.
|
|
(list (regexp-quote "#(struct:object:image% ...)")
|
|
(lambda (all) "an image"))
|
|
(list (regexp-quote "#(struct:object:image-snip% ...)")
|
|
(lambda (all) "an image"))
|
|
(list (regexp-quote "#(struct:object:cache-image-snip% ...)")
|
|
(lambda (all) "an image"))))
|
|
(for/fold ([msg msg]) ([repl. replacements])
|
|
(regexp-replace* (first repl.) msg (second repl.))))
|
|
|
|
(define (get-rewriten-error-message exn)
|
|
(if (exn-needs-rewriting? exn)
|
|
(rewrite-contract-error-message (exn-message exn))
|
|
(exn-message exn)))
|