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

Let's make this more structured so we can actually print this out nicely.

Browse Source 
svn: r11979
This commit is contained in:
Stevie Strickland 2008-10-08 16:16:18 +00:00
parent 86bae10310
commit fb9c65e5ef
2 changed files with 36 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/scheme/private/contract-arrow.ss
View File

@ -119,27 +119,27 @@ v4 todo:
(let ([partial-doms (for/list ([dom (in-list doms-proj)] (let ([partial-doms (for/list ([dom (in-list doms-proj)]
[n (in-naturals 1)]) [n (in-naturals 1)])
(dom neg-blame pos-blame src-info (dom neg-blame pos-blame src-info
(format "required argument ~a of ~a" n orig-str)))] (cons (format "required argument ~a" n) orig-str)))]
[partial-rest (if rest-proj [partial-rest (if rest-proj
(list (rest-proj neg-blame pos-blame src-info (list (rest-proj neg-blame pos-blame src-info
(format "rest argument of ~a" orig-str))) (cons "rest argument" orig-str)))
null)] null)]
[partial-optional-doms (for/list ([dom (in-list doms-optional-proj)] [partial-optional-doms (for/list ([dom (in-list doms-optional-proj)]
[n (in-naturals 1)]) [n (in-naturals 1)])
(dom neg-blame pos-blame src-info (dom neg-blame pos-blame src-info
(format "optional argument ~a of ~a" n orig-str)))] (cons (format "optional argument ~a" n) orig-str)))]
[partial-ranges (for/list ([rng (in-list rngs-proj)] [partial-ranges (for/list ([rng (in-list rngs-proj)]
[n (in-naturals 1)]) [n (in-naturals 1)])
(rng pos-blame neg-blame src-info (rng pos-blame neg-blame src-info
(format "result ~a of ~a" n orig-str)))] (cons (format "result ~a" n) orig-str)))]
[partial-mandatory-kwds (for/list ([kwd (in-list mandatory-kwds-proj)] [partial-mandatory-kwds (for/list ([kwd (in-list mandatory-kwds-proj)]
[kwd-lit (in-list mandatory-keywords)]) [kwd-lit (in-list mandatory-keywords)])
(kwd neg-blame pos-blame src-info (kwd neg-blame pos-blame src-info
(format "keyword argument ~a of ~a" kwd-lit orig-str)))] (cons (format "keyword argument ~a" kwd-lit) orig-str)))]
[partial-optional-kwds (for/list ([kwd (in-list optional-kwds-proj)] [partial-optional-kwds (for/list ([kwd (in-list optional-kwds-proj)]
[kwd-lit (in-list optional-keywords)]) [kwd-lit (in-list optional-keywords)])
(kwd neg-blame pos-blame src-info (kwd neg-blame pos-blame src-info
(format "keyword argument ~a of ~a" kwd-lit orig-str)))]) (cons (format "keyword argument ~a" kwd-lit) orig-str)))])
(apply func (apply func
(λ (val mtd?) (λ (val mtd?)
(if has-rest? (if has-rest?

22
collects/scheme/private/contract-guts.ss
View File

@ -1,7 +1,8 @@
#lang scheme/base #lang scheme/base
(require "contract-helpers.ss" (require "contract-helpers.ss"
scheme/pretty) scheme/pretty
(only-in scheme/list add-between))
(require (for-syntax scheme/base (require (for-syntax scheme/base
"contract-helpers.ss")) "contract-helpers.ss"))
@ -175,22 +176,35 @@
(lambda (x) (get x 0)) (lambda (x) (get x 0))
(lambda (x) (get x 1))))) (lambda (x) (get x 1)))))
(define (default-contract-violation->string val src-info to-blame contract-sexp msg) (define (default-contract-violation->string val src-info to-blame contract-sexp+extra msg)
(define (add-modifiers-to-contract modifiers contract-str)
(if (null? modifiers)
contract-str
(string-append "from "
(apply string-append (add-between modifiers " of "))
" in " contract-str)))
(let ([blame-src (src-info-as-string src-info)] (let ([blame-src (src-info-as-string src-info)]
[formatted-contract-sexp [formatted-contract-sexp
(let-values ([(modifiers contract-sexp)
(let loop ([dlist contract-sexp+extra]
[modifiers null])
(if (and (pair? dlist)
(string? (car dlist)))
(loop (cdr dlist) (cons (car dlist) modifiers))
(values (reverse modifiers) dlist)))])
(let ([one-line (let ([one-line
(let ([sp (open-output-string)]) (let ([sp (open-output-string)])
(parameterize ([pretty-print-columns 'infinity]) (parameterize ([pretty-print-columns 'infinity])
(pretty-print contract-sexp sp) (pretty-print contract-sexp sp)
(get-output-string sp)))]) (get-output-string sp)))])
(if (< (string-length one-line) 30) (if (< (string-length one-line) 30)
one-line (add-modifiers-to-contract modifiers one-line)
(let ([sp (open-output-string)]) (let ([sp (open-output-string)])
(newline sp) (newline sp)
(parameterize ([pretty-print-print-line print-contract-liner] (parameterize ([pretty-print-print-line print-contract-liner]
[pretty-print-columns 50]) [pretty-print-columns 50])
(pretty-print contract-sexp sp)) (pretty-print contract-sexp sp))
(get-output-string sp))))] (add-modifiers-to-contract modifiers (get-output-string sp))))))]
[specific-blame [specific-blame
(cond (cond
[(syntax? src-info) [(syntax? src-info)