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

rewrite contract error messages for *SL

Browse Source 
The rewrite involves parsing contract expressions and constructing
replacement prose.
This commit is contained in:
Matthew Flatt 2012-06-05 17:52:20 +08:00
parent 53f7a77e8f
commit e44c0809e8
3 changed files with 58 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

53
collects/lang/private/rewrite-error-message.rkt
View File

@ -51,6 +51,57 @@
(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: expected procedure\n given: ([^\n]*)(?:\n arguments: [[]none[]])?"
@ -68,6 +119,8 @@
(lambda (all one two three) (argcount-error-message one two three #t)))
(list #px"application: wrong number of arguments.*\n procedure: ([^\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]*))?(?:\n other arguments:.*)?"
(lambda (all ctc given pos) (contract-error-message ctc given pos)))
(list #rx"^procedure "
(lambda (all) ""))
(list #rx", given: "

6
collects/tests/htdp-lang/beg-adv.rktl
View File

@ -2,7 +2,9 @@
(htdp-err/rt-test (add1) "add1: expects 1 argument, but found none")
(htdp-err/rt-test (add1 'a 'b 'c) "add1: expects only 1 argument, but found 3")
(htdp-err/rt-test (define x x) "x is used here before its definition")
(htdp-err/rt-test (add1 'a) "add1: contract violation")
(htdp-err/rt-test (add1 'a) "add1: expects a number, given 'a")
(htdp-err/rt-test (+ 'a 1) "[+]: expects a number as 1st argument, given 'a")
(htdp-err/rt-test (+ 1 'a) "[+]: expects a number as 2nd argument, given 'a")
(htdp-syntax-test #'() "function call: expected a function after the open parenthesis, but nothing's there")
@ -80,7 +82,7 @@
(htdp-test #t 'a3? (a3? (make-a3 1 2 3)))
(htdp-test #f 'a1? (a1? (make-a3 1 2 3)))
(htdp-test #f 'a3? (a3? (make-a1 1)))
(htdp-err/rt-test (a1-b 10) "a1-b: contract violation\n expected: a1[?]\n given: 10")
(htdp-err/rt-test (a1-b 10) "a1-b: expects an a1, given 10")
(htdp-syntax-test #'(a0 1 2 3) "a0: expected a function after the open parenthesis, but found a structure name")
(htdp-syntax-test #'cond "cond: expected an open parenthesis before cond, but found none")

2
collects/tests/htdp-lang/bega-adv.rktl
View File

@ -28,4 +28,4 @@
(htdp-syntax-test #'unquote-splicing "unquote-splicing: misuse of ,@ or unquote-splicing, not under a quasiquoting backquote")
(htdp-syntax-test #'(unquote-splicing (list 10)) "unquote-splicing: misuse of ,@ or unquote-splicing, not under a quasiquoting backquote")
(htdp-err/rt-test `(,@4) (exn-type-and-msg exn:fail:contract? "append: contract violation\n expected: list?\n given: 4"))
(htdp-err/rt-test `(,@4) (exn-type-and-msg exn:fail:contract? "append: expects a list, given 4"))