From 791178a5492e73fa6eb7a2c9f2b1346ebe671095 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Tue, 19 Jan 2010 09:28:28 +0000 Subject: [PATCH] Fixed printing of blame error messages to use display and write appropriately. svn: r17753 --- collects/scheme/contract/private/blame.ss | 20 ++++++++++++++------ 1 file changed, 14 insertions(+), 6 deletions(-) diff --git a/collects/scheme/contract/private/blame.ss b/collects/scheme/contract/private/blame.ss index 447d5de8c4..73df3ad37a 100644 --- a/collects/scheme/contract/private/blame.ss +++ b/collects/scheme/contract/private/blame.ss @@ -47,10 +47,10 @@ (define (default-blame-format b x custom-message) (let* ([source-message (source-location->prefix (blame-source b))] - [guilty-message (show (blame-guilty b))] - [contract-message (show (blame-contract b))] + [guilty-message (show/display (blame-guilty b))] + [contract-message (show/write (blame-contract b))] [value-message (if (blame-value b) - (format " on ~a" (show (blame-value b))) + (format " on ~a" (show/display (blame-value b))) "")]) (format "~a~a broke the contract ~a~a; ~a" source-message @@ -59,15 +59,23 @@ value-message custom-message))) -(define (show v) +(define ((show f) v) (let* ([line (parameterize ([pretty-print-columns 'infinity]) - (pretty-format v))]) + (f v))]) (if (< (string-length line) 30) line (parameterize ([pretty-print-print-line show-line-break] [pretty-print-columns 50]) - (pretty-format v))))) + (f v))))) + +(define (pretty-format/display v [columns (pretty-print-columns)]) + (let ([port (open-output-string)]) + (pretty-display v port) + (get-output-string port))) + +(define show/display (show pretty-format/display)) +(define show/write (show pretty-format)) (define (show-line-break line port len cols) (newline port)