From 63589b9574f35843b5bf13fe5eefa724299afdc4 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 22 May 2009 22:30:24 +0000 Subject: [PATCH] Improve error messages and printing. Turn off contracts. svn: r14947 original commit: c27dccb9d8a5e475bc4b592995c183e1d946cd2b --- .../typed-scheme/typecheck/tc-app-helper.ss | 17 +++++++++++------ collects/typed-scheme/typecheck/tc-expr-unit.ss | 14 +++++++------- collects/typed-scheme/typed-scheme.ss | 4 +++- collects/typed-scheme/types/printer.ss | 12 ++++++++---- collects/typed-scheme/utils/utils.ss | 2 +- 5 files changed, 30 insertions(+), 19 deletions(-) diff --git a/collects/typed-scheme/typecheck/tc-app-helper.ss b/collects/typed-scheme/typecheck/tc-app-helper.ss index 4ea2ff30..170c7ee2 100644 --- a/collects/typed-scheme/typecheck/tc-app-helper.ss +++ b/collects/typed-scheme/typecheck/tc-app-helper.ss @@ -5,14 +5,19 @@ (provide (all-defined-out)) +(define (make-printable t) + (match t + [(tc-result1: t) t] + [_ t])) + (define (stringify-domain dom rst drst [rng #f]) - (let ([doms-string (if (null? dom) "" (string-append (stringify dom) " "))] + (let ([doms-string (if (null? dom) "" (string-append (stringify (map make-printable dom)) " "))] [rng-string (if rng (format " -> ~a" rng) "")]) (cond [drst (format "~a~a ... ~a~a" doms-string (car drst) (cdr drst) rng-string)] [rst (format "~a~a *~a" doms-string rst rng-string)] - [else (string-append (stringify dom) rng-string)]))) + [else (string-append (stringify (map make-printable dom)) rng-string)]))) (define (domain-mismatches ty doms rests drests rngs arg-tys tail-ty tail-bound #:expected [expected #f]) (define arguments-str @@ -26,18 +31,18 @@ arguments-str (if expected (format "Result type: ~a~nExpected result: ~a~n" - (car rngs) expected) + (car rngs) (make-printable expected)) ""))] [else (format "~a: ~a~nArguments: ~a~n~a" (if expected "Types" "Domains") (stringify (if expected - (map stringify-domain doms rests drests rngs) - (map stringify-domain doms rests drests)) + (map stringify-domain (map make-printable doms) rests drests rngs) + (map stringify-domain (map make-printable doms) rests drests)) "~n\t") arguments-str (if expected - (format "Expected result: ~a~n" expected) + (format "Expected result: ~a~n" (make-printable expected)) ""))])) (define (poly-fail t argtypes #:name [name #f] #:expected [expected #f]) diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.ss b/collects/typed-scheme/typecheck/tc-expr-unit.ss index e42ad506..3fac7230 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.ss +++ b/collects/typed-scheme/typecheck/tc-expr-unit.ss @@ -137,30 +137,30 @@ expected] [((tc-results: t1) (tc-results: t2)) (unless (= (length t1) (length t2)) - (tc-error/expr "0.5 Expected ~a values, but got ~a" (length t2) (length t1))) + (tc-error/expr "Expected ~a values, but got ~a" (length t2) (length t1))) (unless (for/and ([t t1] [s t2]) (subtype t s)) - (tc-error/expr "1 Expected ~a, but got ~a" t2 t1)) + (tc-error/expr "Expected ~a, but got ~a" (stringify t2) (stringify t1))) expected] [((tc-results: t1 f o dty dbound) (tc-results: t2 f o dty dbound)) (unless (andmap subtype t1 t2) - (tc-error/expr "1.5 Expected ~a, but got ~a" t2 t1)) + (tc-error/expr "Expected ~a, but got ~a" (stringify t2) (stringify t1))) expected] [((tc-result1: t1 f o) (? Type? t2)) (unless (subtype t1 t2) - (tc-error/expr "1 Expected ~a, but got ~a" t2 t1)) + (tc-error/expr "Expected ~a, but got ~a" t2 t1)) (ret t2 f o)] [((? Type? t1) (tc-result1: t2 (FilterSet: (list) (list)) (Empty:))) (unless (subtype t1 t2) - (tc-error/expr "3 Expected ~a, but got ~a" t2 t1)) + (tc-error/expr "Expected ~a, but got ~a" t2 t1)) t1] [((? Type? t1) (tc-result1: t2 f o)) (if (subtype t1 t2) (tc-error/expr "Expected result with filter ~a and object ~a, got ~a" f o t1) - (tc-error/expr "4 Expected ~a, but got ~a" t2 t1)) + (tc-error/expr "Expected ~a, but got ~a" t2 t1)) t1] [((? Type? t1) (? Type? t2)) (unless (subtype t1 t2) - (tc-error/expr "5 Expected ~a, but got ~a" t2 t1)) + (tc-error/expr "Expected ~a, but got ~a" t2 t1)) expected])) (define (tc-expr/check/type form expected) diff --git a/collects/typed-scheme/typed-scheme.ss b/collects/typed-scheme/typed-scheme.ss index 3679a8f4..323d7713 100644 --- a/collects/typed-scheme/typed-scheme.ss +++ b/collects/typed-scheme/typed-scheme.ss @@ -132,8 +132,10 @@ body2] [_ (let ([ty-str (match type [(tc-result1: (? (lambda (t) (type-equal? t -Void)))) #f] + [(tc-result1: t) + (format "- : ~a\n" t)] [(tc-results: t) - (format "- : ~a\n" type)] + (format "- : ~a\n" (cons 'Values t))] [x (int-err "bad type result: ~a" x)])]) (if ty-str #`(let ([type '#,ty-str]) diff --git a/collects/typed-scheme/types/printer.ss b/collects/typed-scheme/types/printer.ss index 9eeca9b2..55aefcd2 100644 --- a/collects/typed-scheme/types/printer.ss +++ b/collects/typed-scheme/types/printer.ss @@ -90,14 +90,17 @@ (when drest (fp "~a ... ~a " (car drest) (cdr drest))) (match rng - #| [(Values: (list (Result: t (LFilterSet: (list) (list)) (LEmpty:)))) (fp "-> ~a" t)] + [(Values: (list (Result: t + (LFilterSet: (list (LTypeFilter: ft '() 0)) + (list (LNotTypeFilter: ft '() 0))) + (LEmpty:)))) + (fp "-> ~a : ~a" t ft)] [(Values: (list (Result: t fs (LEmpty:)))) (fp "-> ~a : ~a" t fs)] [(Values: (list (Result: t lf lo))) (fp "-> ~a : ~a ~a" t lf lo)] -|# [_ (fp "-> ~a" rng)]) (fp ")")])) @@ -116,7 +119,7 @@ ;; names are just the printed as the original syntax [(Name: stx) (fp "~a" (syntax-e stx))] [(App: rator rands stx) - (fp "~a" (list* '@ rator rands))] + (fp "~a" (list* rator rands))] ;; special cases for lists [(Mu: var (Union: (list (Value: '()) (Pair: elem-ty (F: var))))) (fp "(Listof ~a)" elem-ty)] @@ -153,7 +156,7 @@ [(Pair: l r) (fp "(Pair ~a ~a)" l r)] [(F: nm) (fp "~a" nm)] ;; FIXME - ;[(Values: (list v)) (fp "~a" v)] + [(Values: (list v)) (fp "~a" v)] [(Values: (list v ...)) (fp "~a" (cons 'values v))] [(ValuesDots: v dty dbound) (fp "~a" (cons 'values (append v (list dty '... dbound))))] [(Param: in out) @@ -195,6 +198,7 @@ [(Result: t fs lo) (fp "(~a : ~a : ~a)" t fs lo)] [(Refinement: parent p? _) (fp "(Refinement ~a ~a)" parent (syntax-e p?))] + [(Error:) (fp "Error")] [else (fp "Unknown Type: ~a" (struct->vector c))] )) diff --git a/collects/typed-scheme/utils/utils.ss b/collects/typed-scheme/utils/utils.ss index 79c0b385..4baf94b3 100644 --- a/collects/typed-scheme/utils/utils.ss +++ b/collects/typed-scheme/utils/utils.ss @@ -273,7 +273,7 @@ at least theoretically. (define (extend s t extra) (append t (build-list (- (length s) (length t)) (lambda _ extra)))) -(define-for-syntax enable-contracts? #t) +(define-for-syntax enable-contracts? #f) (provide (for-syntax enable-contracts?) p/c w/c cnt d-s/c d/c) (define-syntax p/c