The rewriting machanism no longer inserts with-handler everywhere.
This commit is contained in:
Guillaume Marceau
parent
01b9bde7fa
commit
6fc14b269d
|
|
@ -81,8 +81,11 @@
|
|||
|
||||
(provide/contract [get-error-colored-srclocs (exn? . -> . (listof (list/c srcloc-syntax/c color/c)))])
|
||||
(define (get-error-colored-srclocs exn)
|
||||
(get-message-colored-srclocs (get-error-message/color exn)))
|
||||
|
||||
(provide/contract [get-message-colored-srclocs (colored-error-message? . -> . (listof (list/c srcloc-syntax/c color/c)))])
|
||||
(define (get-message-colored-srclocs msg)
|
||||
(define (promote srcloc) (if (list? srcloc) srcloc (list srcloc #f)))
|
||||
(define msg (get-error-message/color exn))
|
||||
(map promote
|
||||
(append
|
||||
(append*
|
||||
|
|
@ -183,8 +186,9 @@
|
|||
(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 additional-highlights/c]) #:rest [_ any/c]
|
||||
. ->i . [_ colored-error-message?])])
|
||||
(define colored-format/c (([fmt string?]) (#:additional-highlights [additional-highlights additional-highlights/c]) #:rest [_ any/c]
|
||||
. ->i . [_ colored-error-message?]))
|
||||
(provide/contract [colored-format colored-format/c])
|
||||
|
||||
;; 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
|
||||
|
|
@ -273,6 +277,7 @@
|
|||
;; 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.
|
||||
(provide/contract [raise-colored-syntax-error colored-format/c])
|
||||
(define (raise-colored-syntax-error fmt #:additional-highlights [additional-highlights empty] . args)
|
||||
(define formatted (apply colored-format fmt #:additional-highlights additional-highlights args))
|
||||
(raise (exn:fail:colored:syntax (uncolor-message formatted)
|
||||
|
|
|
|||
|
|
@ -68,7 +68,7 @@
|
|||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(id . args)
|
||||
((wrap-for-contract-error-message #'beginner-app) #'orig-name stx)]
|
||||
(syntax/loc stx (beginner-app orig-name . args))]
|
||||
[_else
|
||||
(raise-syntax-error
|
||||
#f
|
||||
|
|
|
|||
|
|
@ -23,7 +23,8 @@
|
|||
|
||||
;; this module is shared between the drscheme's namespace (so loaded here)
|
||||
;; and the user's namespace in the teaching languages
|
||||
"private/set-result.rkt"
|
||||
"private/set-result.ss"
|
||||
"private/rewrite-error-message.rkt"
|
||||
|
||||
"private/continuation-mark-key.rkt"
|
||||
|
||||
|
|
@ -1035,7 +1036,7 @@
|
|||
;; adds in the bug icon, if there are contexts to display
|
||||
(define (teaching-languages-error-display-handler msg exn)
|
||||
(if (exn? exn)
|
||||
(display (exn-message exn) (current-error-port))
|
||||
(display (get-rewriten-error-message exn) (current-error-port))
|
||||
(fprintf (current-error-port) "uncaught exception: ~e" exn))
|
||||
(fprintf (current-error-port) "\n")
|
||||
|
||||
|
|
|
|||
|
|
@ -1,36 +0,0 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require scheme/list)
|
||||
|
||||
(provide rewrite-lookup-error-message
|
||||
rewrite-contract-error-message)
|
||||
|
||||
(define (rewrite-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 (change-contract-exn-messages e msg)
|
||||
(define constructor
|
||||
(cond [(exn:fail:contract:arity? e) make-exn:fail:contract:arity]
|
||||
[(exn:fail:contract:divide-by-zero? e) make-exn:fail:contract:divide-by-zero]
|
||||
[(exn:fail:contract:non-fixnum-result? e) make-exn:fail:contract:non-fixnum-result]
|
||||
[(exn:fail:contract:continuation? e) make-exn:fail:contract:continuation]
|
||||
[else make-exn:fail:contract]))
|
||||
(constructor msg (exn-continuation-marks e)))
|
||||
|
||||
(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)))
|
||||
(list #rx"^procedure "
|
||||
(lambda (all) ""))
|
||||
))
|
||||
(define new-message
|
||||
(for/fold ([msg (exn-message e)]) ([repl. replacements])
|
||||
(regexp-replace* (first repl.) msg (second repl.))))
|
||||
(change-contract-exn-messages e new-message))
|
||||
|
|
@ -2,28 +2,66 @@
|
|||
|
||||
(require mzlib/etc
|
||||
mzlib/list
|
||||
(for-template scheme/base "rewrite-error-message-for-tpl.rkt")
|
||||
(for-syntax "firstorder.ss"
|
||||
scheme/base))
|
||||
|
||||
(provide wrap-top-for-lookup-error-message
|
||||
wrap-for-contract-error-message)
|
||||
(provide rewrite-contract-error-message
|
||||
reraise-rewriten-lookup-error-message
|
||||
get-rewriten-error-message
|
||||
plural
|
||||
raise-not-bound-error
|
||||
argcount-error-message)
|
||||
|
||||
(define (wrap-top-for-lookup-error-message stx was-in-app-position)
|
||||
(syntax-case stx ()
|
||||
[(_ . id)
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(with-handlers ([exn:fail:contract:variable?
|
||||
(lambda (e) (rewrite-lookup-error-message e #'id #,was-in-app-position))])
|
||||
(#%top . id)))]))
|
||||
(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 ((wrap-for-contract-error-message app) orig-name stx)
|
||||
(syntax-case stx ()
|
||||
[(id . args)
|
||||
(quasisyntax/loc stx
|
||||
(with-handlers ([exn:fail:contract? (compose raise rewrite-contract-error-message)])
|
||||
#,(quasisyntax/loc stx (#,app #,orig-name . args))))]))
|
||||
(define (plural n)
|
||||
(if (> (string->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)
|
||||
(define fn-is-large (> (string->number arity) (string->number found)))
|
||||
(format "expects ~a~a argument~a, but found ~a~a"
|
||||
(if fn-is-large "" "only ")
|
||||
arity (plural arity)
|
||||
(if fn-is-large "only " "")
|
||||
found))
|
||||
|
||||
(define (rewrite-contract-error-message msg)
|
||||
(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)))
|
||||
(list #px"expects at least (\\d+) argument.?, given (\\d+): .*"
|
||||
(lambda (all one two) (format "expects at least ~a argument~a, but found only ~a."
|
||||
one (plural one) two)))
|
||||
(list #px"expects (\\d+) argument.?, given (\\d+): .*"
|
||||
(lambda (all one two) (argcount-error-message one two)))
|
||||
(list #rx"^procedure "
|
||||
(lambda (all) ""))
|
||||
))
|
||||
(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)))
|
||||
|
|
|
|||
|
|
@ -54,13 +54,16 @@
|
|||
beginner-equal? beginner-equal~? teach-equal?
|
||||
advanced-cons advanced-list*))
|
||||
|
||||
(require "rewrite-error-message.rkt")
|
||||
|
||||
(require-for-syntax "teachhelp.ss"
|
||||
"teach-shared.ss"
|
||||
"rewrite-error-message.rkt"
|
||||
"teach-shared.ss"
|
||||
syntax/kerncase
|
||||
syntax/stx
|
||||
syntax/struct
|
||||
syntax/context
|
||||
syntax/colored-errors
|
||||
mzlib/include
|
||||
scheme/list
|
||||
(rename racket/base racket:define-struct define-struct)
|
||||
|
|
@ -107,6 +110,9 @@
|
|||
#t)))
|
||||
(raise-syntax-error #f "this name was defined previously and cannot be re-defined" id)))
|
||||
|
||||
(define (top/check-defined id)
|
||||
(namespace-variable-value (syntax-e id) #t (lambda () (raise-not-bound-error id))))
|
||||
|
||||
;; For quasiquote and shared:
|
||||
(require (rename "teachprims.rkt" the-cons advanced-cons))
|
||||
(require (only "teachprims.rkt" cyclic-list?))
|
||||
|
|
@ -234,6 +240,7 @@
|
|||
(raise-syntax-error form msg stx detail)
|
||||
(raise-syntax-error form msg stx))))
|
||||
|
||||
|
||||
(define (teach-syntax-error* form stx details msg . args)
|
||||
(let ([exn (with-handlers ([exn:fail:syntax?
|
||||
(lambda (x) x)])
|
||||
|
|
@ -1208,40 +1215,31 @@
|
|||
;; top-level variables (beginner)
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; Report errors for undefined names (but only in modules)
|
||||
|
||||
(define (beginner-top/proc stx)
|
||||
(syntax-case stx ()
|
||||
[(_ . id)
|
||||
;; If we're in a module, we'll need to check that the name
|
||||
;; is bound....
|
||||
(if (and (not (identifier-binding #'id))
|
||||
(syntax-source-module #'id))
|
||||
;; ... but it might be defined later in the module, so
|
||||
;; delay the check.
|
||||
(stepper-ignore-checker
|
||||
(syntax/loc stx (#%app values (beginner-top-continue id))))
|
||||
(if (not (identifier-binding #'id))
|
||||
(if (syntax-source-module #'id)
|
||||
;; If we're in a module, we'll need to check that the name
|
||||
;; is bound but it might be defined later in the module, so
|
||||
;; delay the check.
|
||||
(stepper-ignore-checker
|
||||
(syntax/loc stx (#%app values (beginner-top-continue id))))
|
||||
|
||||
;; identifier-finding only returns useful information when inside a module. At the top-level we need to
|
||||
;; do the check at runtime. Also, note that at the top level there is no need for stepper annotations
|
||||
(syntax/loc stx (#%app top/check-defined #'id)))
|
||||
|
||||
(syntax/loc stx (#%top . id)))]))
|
||||
|
||||
(wrap-top-for-lookup-error-message
|
||||
stx
|
||||
(syntax-property #'id 'was-in-app-position)))]))
|
||||
|
||||
(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
|
||||
#f
|
||||
#'id
|
||||
#f
|
||||
"this function is not defined")
|
||||
(teach-syntax-error
|
||||
#f
|
||||
#'id
|
||||
#f
|
||||
"this variable is not defined"))
|
||||
;; If there's still no binding, it's an "unknown name" error.
|
||||
(raise-not-bound-error #'id)
|
||||
|
||||
;; Don't use #%top here; id might have become bound to something
|
||||
;; that isn't a value.
|
||||
#'id)]))
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
(module teachhelp mzscheme
|
||||
(require "firstorder.rkt"
|
||||
(require "firstorder.ss"
|
||||
"rewrite-error-message.rkt"
|
||||
stepper/private/shared)
|
||||
|
||||
(require-for-syntax stepper/private/shared)
|
||||
|
|
@ -67,13 +68,11 @@
|
|||
stx
|
||||
#f)]
|
||||
[(id . rest)
|
||||
(let ([l (length (syntax->list #'rest))])
|
||||
(unless (= l arity)
|
||||
(let ([found (length (syntax->list #'rest))])
|
||||
(unless (= found arity)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
(format "this function expects ~a argument~a, here it is provided ~a argument~a"
|
||||
arity (if (= 1 arity) "" "s")
|
||||
l (if (= 1 l) "" "s"))
|
||||
(argcount-error-message arity found)
|
||||
stx
|
||||
#f))
|
||||
(datum->syntax-object
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user