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)]
[n (in-naturals 1)])
(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
(list (rest-proj neg-blame pos-blame src-info
(format "rest argument of ~a" orig-str)))
(cons "rest argument" orig-str)))
null)]
[partial-optional-doms (for/list ([dom (in-list doms-optional-proj)]
[n (in-naturals 1)])
(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)]
[n (in-naturals 1)])
(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)]
[kwd-lit (in-list mandatory-keywords)])
(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)]
[kwd-lit (in-list optional-keywords)])
(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
(λ (val mtd?)
(if has-rest?

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

@ -1,7 +1,8 @@
#lang scheme/base
(require "contract-helpers.ss"
scheme/pretty)
scheme/pretty
(only-in scheme/list add-between))
(require (for-syntax scheme/base
"contract-helpers.ss"))
@ -175,22 +176,35 @@
(lambda (x) (get x 0))
(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)]
[formatted-contract-sexp
(let ([one-line
(let ([sp (open-output-string)])
(parameterize ([pretty-print-columns 'infinity])
(pretty-print contract-sexp sp)
(get-output-string sp)))])
(if (< (string-length one-line) 30)
one-line
(let ([sp (open-output-string)])
(newline sp)
(parameterize ([pretty-print-print-line print-contract-liner]
[pretty-print-columns 50])
(pretty-print contract-sexp sp))
(get-output-string sp))))]
(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 ([sp (open-output-string)])
(parameterize ([pretty-print-columns 'infinity])
(pretty-print contract-sexp sp)
(get-output-string sp)))])
(if (< (string-length one-line) 30)
(add-modifiers-to-contract modifiers one-line)
(let ([sp (open-output-string)])
(newline sp)
(parameterize ([pretty-print-print-line print-contract-liner]
[pretty-print-columns 50])
(pretty-print contract-sexp sp))
(add-modifiers-to-contract modifiers (get-output-string sp))))))]
[specific-blame
(cond
[(syntax? src-info)