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

cs: rewrite error message for car, cadr, etc.

Browse Source 
Closes #2798
This commit is contained in:
Matthew Flatt 2019-08-27 19:43:27 -06:00
parent 1e2019f600
commit fd63d5a1ba
3 changed files with 54 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
pkgs/racket-test-core/tests/racket/basic.rktl
View File

@ -286,6 +286,12 @@
(err/rt-test (list-tail '(1) 2) exn:application:mismatch?)
(err/rt-test (list-tail '(1 2 . 3) 3) exn:application:mismatch?)
(err/rt-test (car 0) exn:fail:contract? #rx"car: contract violation.*expected: pair[?].*given: 0")
(err/rt-test (cdr 0) exn:fail:contract? #rx"cdr: contract violation.*expected: pair[?].*given: 0")
(err/rt-test (cadr 0) exn:fail:contract? #rx"cadr: contract violation.*expected: .cons/c any/c pair[?]..*given: 0")
(err/rt-test (cdadr 0) exn:fail:contract? #rx"cdadr: contract violation.*expected: .cons/c any/c .cons/c pair[?] any/c..*given: 0")
(err/rt-test (cdadar 0) exn:fail:contract? #rx"cdadar: contract violation.*expected: .cons/c .cons/c any/c .cons/c pair[?] any/c.. any/c.*given: 0")
(define (test-mem memq memq-name)
(test '(a b c) memq 'a '(a b c))
(test '(b c) memq 'b '(a b c))

47
racket/src/cs/rumble/error-rewrite.ss
View File

@ -56,7 +56,7 @@
(set! rewrites-added? #t)))
(getprop n 'error-rename n)))
(define (rewrite-format str irritants)
(define (rewrite-format who str irritants)
(cond
[(equal? str "attempt to reference undefined variable ~s")
(values (string-append
@ -66,6 +66,14 @@
[(and (equal? str "undefined for ~s")
(equal? irritants '(0)))
(values "division by zero" null)]
[(equal? str "~s is not a pair")
(values "contract violation\n expected: pair?\n given: ~s"
irritants)]
[(and (equal? str "incorrect list structure ~s")
(cxr->contract who))
=> (lambda (ctc)
(values (string-append "contract violation\n expected: " ctc "\n given: ~s")
irritants))]
[else
(let ([str (string-copy str)]
[len (string-length str)])
@ -98,3 +106,40 @@
(and (>= (string-length str) (string-length p))
(string=? (substring str (- (string-length str) (string-length p)) (string-length str)) p)))
;; Maps a function name like 'cadr to a contract
;; string like "(cons/c any/c pair?)"
(define (cxr->contract who)
(let-syntax ([gen (lambda (stx)
(letrec ([add-all
(lambda (pre p tmpl)
(cond
[(null? p) '()]
[else
(cons
(list (string-append (caar p) pre)
(format tmpl (cadar p)))
(add-all pre (cdr p) tmpl))]))])
(let ([combos
(reverse
(let loop ([alts '(x x x)])
(cond
[(null? alts)
`(["a" "pair?"]
["d" "pair?"])]
[else
(let ([r (loop (cdr alts))])
(append
(add-all "a" r "(cons/c ~a any/c)")
(add-all "d" r "(cons/c any/c ~a)")
r))])))])
(with-syntax ([(combo ...)
(map (lambda (c)
(list (list (datum->syntax
#'here
(string->symbol (string-append "c" (car c) "r"))))
(cadr c)))
combos)])
#`(case who
combo ...
[else #f])))))])
(gen)))

3
racket/src/cs/rumble/error.ss
View File

@ -670,7 +670,8 @@
(exn-message v)]
[(format-condition? v)
(let-values ([(fmt irritants)
(rewrite-format (condition-message v)
(rewrite-format (and (who-condition? v) (condition-who v))
(condition-message v)
(condition-irritants v))])
(apply format fmt irritants))]
[(syntax-violation? v)