100 lines
4.0 KiB
Racket
Executable File
100 lines
4.0 KiB
Racket
Executable File
#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 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 "expects ~a~a~a argument~a, but found ~a~a"
|
|
(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 (rewrite-contract-error-message msg)
|
|
(define replacements
|
|
(list (list #rx"procedure application: expected procedure, given: (.*) \\(no arguments\\)"
|
|
(lambda (all one)
|
|
(format "function call: expected a function after the open parenthesis, but received ~a" one)))
|
|
(list #rx"procedure application: expected procedure, given: (.*); arguments were:.*"
|
|
(lambda (all one)
|
|
(format "function call: expected a function after the open parenthesis, but received ~a" 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"expects at least (\\d+) argument.?, given (\\d+)(: .*)?"
|
|
(lambda (all one two three) (argcount-error-message one two #t)))
|
|
(list #px"expects (\\d+) argument.?, given (\\d+)(: .*)?"
|
|
(lambda (all one two three) (argcount-error-message one two)))
|
|
(list #rx"^procedure "
|
|
(lambda (all) ""))
|
|
(list #rx", given: "
|
|
(lambda (all) ", given "))
|
|
(list #rx"; other arguments were:.*"
|
|
(lambda (all) ""))
|
|
(list #rx"expects a (struct:)"
|
|
(lambda (all one) "expects a "))
|
|
(list #rx"list or cyclic list"
|
|
(lambda (all) "list"))
|
|
(list (regexp-quote "given #(struct:object:image% ...)")
|
|
(lambda (all) "given an image"))
|
|
(list (regexp-quote "given #(struct:object:image-snip% ...)")
|
|
(lambda (all) "given an image"))
|
|
(list (regexp-quote "given #(struct:object:cache-image-snip% ...)")
|
|
(lambda (all) "given an image"))
|
|
(list (regexp-quote "#(struct:object:image% ...)")
|
|
(lambda (all) "(image)"))
|
|
(list (regexp-quote "#(struct:object:image-snip% ...)")
|
|
(lambda (all) "(image)"))
|
|
(list (regexp-quote "#(struct:object:cache-image-snip% ...)")
|
|
(lambda (all) "(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)))
|