From fb9c65e5ef24a2c09f147da02b6626a14624143f Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Wed, 8 Oct 2008 16:16:18 +0000 Subject: [PATCH] Let's make this more structured so we can actually print this out nicely. svn: r11979 --- collects/scheme/private/contract-arrow.ss | 12 +++--- collects/scheme/private/contract-guts.ss | 46 +++++++++++++++-------- 2 files changed, 36 insertions(+), 22 deletions(-) diff --git a/collects/scheme/private/contract-arrow.ss b/collects/scheme/private/contract-arrow.ss index 32c555a76e..d21ee1a85d 100644 --- a/collects/scheme/private/contract-arrow.ss +++ b/collects/scheme/private/contract-arrow.ss @@ -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? diff --git a/collects/scheme/private/contract-guts.ss b/collects/scheme/private/contract-guts.ss index 66b497ce88..45b99da8a4 100644 --- a/collects/scheme/private/contract-guts.ss +++ b/collects/scheme/private/contract-guts.ss @@ -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) @@ -513,4 +527,4 @@ #:property name-prop (λ (ctc) (predicate-contract-name ctc)) #:property flat-prop (λ (ctc) (predicate-contract-pred ctc))) -(define (build-flat-contract name pred) (make-predicate-contract name pred)) \ No newline at end of file +(define (build-flat-contract name pred) (make-predicate-contract name pred))