suzanne.soy/typed-racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Improve error messages and printing.

Browse Source 
Turn off contracts.

svn: r14947

original commit: c27dccb9d8a5e475bc4b592995c183e1d946cd2b
This commit is contained in:
Sam Tobin-Hochstadt 2009-05-22 22:30:24 +00:00
parent ec01788aeb
commit 63589b9574
5 changed files with 30 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
collects/typed-scheme/typecheck/tc-app-helper.ss
View File

@ -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])

14
collects/typed-scheme/typecheck/tc-expr-unit.ss
View File

@ -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)

4
collects/typed-scheme/typed-scheme.ss
View File

@ -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])

12
collects/typed-scheme/types/printer.ss
View File

@ -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))]
))

2
collects/typed-scheme/utils/utils.ss
View File

@ -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