From e640308b0e468f71506f6a31ef4fa081c61f9979 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Mon, 6 Jan 2014 17:49:48 -0500 Subject: [PATCH] Use type pretty-printing in TR messages Closes PR 11271 original commit: 130f6673903b72a7813c357405acb85ee886dc37 --- .../typed-racket/base-env/top-interaction.rkt | 9 +++++---- .../typed-racket-lib/typed-racket/core.rkt | 11 +++++++++-- .../typed-racket/typecheck/check-below.rkt | 7 +++++-- 3 files changed, 19 insertions(+), 8 deletions(-) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/top-interaction.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/top-interaction.rkt index 41897e24..22b90460 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/top-interaction.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/top-interaction.rkt @@ -81,10 +81,11 @@ (λ (expanded type) #`(display #,(parameterize ([print-multi-line-case-> #t]) - (format "~a\n" (match type - [(tc-result1: t f o) t] - [(tc-results: t) (-values t)] - [(tc-any-results:) ManyUniv]))))))] + (pretty-format-type + (match type + [(tc-result1: t f o) t] + [(tc-results: t) (-values t)] + [(tc-any-results:) ManyUniv]))))))] [form (raise-syntax-error #f "must be applied to exactly one argument" #'form)])) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/core.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/core.rkt index 0a134578..fea8aec0 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/core.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/core.rkt @@ -11,6 +11,7 @@ (rep type-rep) (for-template (base-env top-interaction)) (utils utils tc-utils arm) + (only-in (types printer) pretty-format-type) "standard-inits.rkt" "tc-setup.rkt") @@ -82,7 +83,7 @@ (define tc (cleanup-type t)) (define tg (generalize tc)) (format "- : ~a~a~a\n" - tg + (pretty-format-type tg #:indent 4) (cond [(equal? tc tg) ""] [else (format " [more precisely: ~a]" tc)]) (cond [(equal? tc t) ""] @@ -92,9 +93,15 @@ [(tc-results: t) (define tcs (map cleanup-type t)) (define tgs (map generalize tcs)) + (define tgs-val (make-Values tgs)) + (define formatted (pretty-format-type tgs-val #:indent 4)) + (define indented? (regexp-match? #rx"\n" formatted)) (format "- : ~a~a~a\n" - (cons 'Values tgs) + formatted (cond [(andmap equal? tgs tcs) ""] + [indented? + (format "\n[more precisely: ~a]" + (pretty-format-type (make-Values tcs) #:indent 17))] [else (format " [more precisely: ~a]" (cons 'Values tcs))]) ;; did any get pruned? (cond [(andmap equal? t tcs) ""] diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-below.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-below.rkt index 10c9e5cb..b31eac04 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-below.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-below.rkt @@ -4,7 +4,8 @@ racket/match (prefix-in - (contract-req)) (types utils union subtype filter-ops) (utils tc-utils) - (rep type-rep object-rep filter-rep)) + (rep type-rep object-rep filter-rep) + (only-in (types printer) pretty-format-type)) (provide/cond-contract [check-below (-->d ([s (-or/c Type/c tc-results/c)] [t (-or/c Type/c tc-results/c)]) () @@ -46,7 +47,9 @@ (type-mismatch (format "`~a'" t1) (format "a different `~a'" t2) "type variables bound in different scopes")] [(_ _) - (type-mismatch t1 t2)])) + (type-mismatch + (if (Type/c? t1) (pretty-format-type t1 #:indent 12) t1) + (if (Type/c? t2) (pretty-format-type t2 #:indent 9) t2))])) ;; check-below : (/\ (Results Type -> Result) ;; (Results Results -> Result)