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

Further improvements for TR's error messages.

Browse Source 
Only the most permissive domains whose associated return type is
consistent with the expected type are shown in error messages.

For example, for a function with the following type:
Fixnum -> Fixnum
Integer -> Integer
and an expected type of Integer, only the latter domain is shown in
the error message.
This commit is contained in:
Vincent St-Amour 2010-09-24 17:43:12 -04:00
parent d6684dad8c
commit e011ea00bd
1 changed files with 88 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

122
collects/typed-scheme/typecheck/tc-app-helper.rkt
View File

@ -88,6 +88,15 @@
;; unrelated to error reporting) ;; unrelated to error reporting)
;; - if we have an expected type, we don't need to show the domains for which ;; - if we have an expected type, we don't need to show the domains for which
;; the result type is not a subtype of the expected type ;; the result type is not a subtype of the expected type
;; - we can disregard domains that are more restricted than required to get
;; the expected type (or all but the most liberal domain when no type is
;; expected)
;; ex: if we have the 2 following possible domains for an operator:
;; Fixnum -> Fixnum
;; Integer -> Integer
;; and an expected type of Integer for the result of the application,
;; we can disregard the Fixnum domain since it imposes a restriction that
;; is not necessary to get the expected type
(define (possible-domains doms rests drests rngs expected) (define (possible-domains doms rests drests rngs expected)
;; is fun-ty subsumed by a function type in others? ;; is fun-ty subsumed by a function type in others?
@ -103,48 +112,93 @@
(define expected-ty (and expected (match expected [(tc-result1: t) t]))) (define expected-ty (and expected (match expected [(tc-result1: t) t])))
(define (returns-subtype-of-expected? fun-ty) (define (returns-subtype-of-expected? fun-ty)
(and fun-ty ; was not skipped by a previous check (or (not expected)
(or (not expected) (match fun-ty
(match fun-ty [(Function: (list (arr: _ rng _ _ _)))
[(Function: (list (arr: _ rng _ _ _))) (let ([rng (match rng
(let ([rng (match rng [(Values: (list (Result: t _ _)))
[(Values: (list (Result: t _ _))) t]
t] [(ValuesDots: (list (Result: t _ _)) _ _)
[(ValuesDots: (list (Result: t _ _)) _ _) t])])
t])]) (subtype rng expected-ty))])))
(subtype rng expected-ty))]))))
;; original info that the error message would have used
;; kept in case we discard all the cases
(define orig (map list doms rngs rests drests))
;; iterate in lock step over the function types we analyze and the parts
;; that we will need to print the error message, to make sure we throw
;; away cases consistently
(let loop ([cases (map (compose make-Function list make-arr) (let loop ([cases (map (compose make-Function list make-arr)
doms doms
(map (lambda (rng) ; strip filters (map (match-lambda ; strip filters
(match rng [(Values: (list (Result: t _ _) ...))
[(Values: (list (Result: t _ _) ...)) (-values t)]
(-values t)] [(ValuesDots: (list (Result: t _ _) ...) _ _)
[(ValuesDots: (list (Result: t _ _) ...) _ _) (-values t)])
(-values t)]))
rngs) rngs)
rests drests (make-list (length doms) null))] rests drests (make-list (length doms) null))]
[candidates '()]) ;; the parts we'll need to print the error message
[parts orig]
;; accumulators
[candidates '()] ; from cases
[parts-acc '()]) ; from parts
;; discard subsumed cases (supertype modulo filters)
(if (not (null? cases)) (if (not (null? cases))
;; discard subsumed cases
(let ([head (car cases)] [tail (cdr cases)]) (let ([head (car cases)] [tail (cdr cases)])
(if (is-subsumed-in? head tail) (if (is-subsumed-in? head tail)
(loop tail (cons #f candidates)) ; will be skipped later (loop tail (cdr parts)
(loop tail (cons head candidates)))) candidates parts-acc) ; we discard this one
(loop tail (cdr parts)
(cons head candidates) ; we keep this one
(cons (car parts) parts-acc))))
;; keep only the domains for which the associated function type ;; keep only the domains for which the associated function type
;; fits our criteria ;; is consistent with the expected type
(unzip4 (map cdr ; doms, rests drests (let loop ([cases candidates]
(let* ([orig (map list [parts parts-acc]
(reverse candidates) ;; accumulators
doms [candidates '()]
rngs [parts-acc '()])
rests (if (not (null? cases))
drests)] (if (returns-subtype-of-expected? (car cases))
[after (filter (compose returns-subtype-of-expected? car) (loop (cdr cases) (cdr parts)
orig)]) (cons (car cases) candidates) ; we keep this one
;; if we somehow eliminate all the cases (bogus expected type) (cons (car parts) parts-acc))
;; fall back to the showing extra cases (loop (cdr cases) (cdr parts)
(if (null? after) orig after))))))) candidates parts-acc)) ; we discard this one
;; among the domains that fit with the expected type, we only
;; need to keep the most liberal
;; since we only care about permissiveness of domains, we
;; reconstruct function types with a return type of any then test
;; for subtyping
(let ([fun-tys-ret-any
(map (match-lambda
[(Function: (list (arr: dom _ rest drest _)))
(make-Function (list (make-arr dom Univ rest drest null)))])
candidates)])
(let loop ([cases fun-tys-ret-any]
[parts parts-acc]
;; accumulators
;; final pass, we only need the parts to print the
;; error message
[parts-acc '()])
(if (not (null? cases))
;; if a case is a supertype of another, we discard it
(let ([head (car cases)])
(if (is-subsumed-in? head (remove head fun-tys-ret-any))
(loop (cdr cases) (cdr parts)
parts-acc) ; we discard this one
(loop (cdr cases) (cdr parts)
(cons (car parts) parts-acc)))) ; we keep this one
;; if we somehow eliminate all the cases (bogus expected
;; type) fall back to the showing extra cases
(unzip4 (if (null? parts-acc)
orig
(reverse parts-acc)))))))))))
(define (poly-fail t argtypes #:name [name #f] #:expected [expected #f]) (define (poly-fail t argtypes #:name [name #f] #:expected [expected #f])
(match t (match t