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

Improved TR's error messages in presence of case-lambda types.

Browse Source 
- When displaying errors involving functions that have case-lambda
  types with branches that are redundant modulo filters (such as <, >
  and others), only the general branches appear in the error message.
  (Real Real Real * -> Boolean, in the case of < and co.).
- For all errors involving case-lambda types, only domains for which
  the return type is consistent with the expected type are displayed
  in the error message. Further simplification is planned.

original commit: 206fe52047f24ab89ac1d538c939c04fbbae59b7
This commit is contained in:
Vincent St-Amour 2010-09-22 18:05:32 -04:00
parent 2e1cf9d4f4
commit 5fab19e4df
3 changed files with 91 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,7 +1,8 @@
#lang scheme/base
(require "../utils/utils.rkt" racket/match unstable/list
(utils tc-utils) (rep type-rep) (types utils union abbrev))
(only-in srfi/1 unzip4) (only-in racket/list make-list)
(utils tc-utils) (rep type-rep) (types utils union abbrev subtype))
(provide (all-defined-out))
@ -59,20 +60,91 @@
""))]
[else
(let ([label (if expected "Types: " "Domains: ")]
[nl+spc (if expected "\n " "\n ")]
[pdoms (map make-printable doms)])
(string-append
label
(stringify (if expected
(map stringify-domain pdoms rests drests rngs)
(map stringify-domain pdoms rests drests))
nl+spc)
"\nArguments: "
arguments-str
"\n"
(if expected
(format "Expected result: ~a\n" (make-printable expected))
"")))]))
[nl+spc (if expected "\n " "\n ")])
;; we restrict the domains shown in the error messages to those that
;; are useful
(let-values ([(pdoms rngs rests drests) (possible-domains doms rests drests rngs expected)])
(let ([pdoms (map make-printable pdoms)])
(string-append
label
(stringify (if expected
(map stringify-domain pdoms rests drests rngs)
(map stringify-domain pdoms rests drests))
nl+spc)
"\nArguments: "
arguments-str
"\n"
(if expected
(format "Expected result: ~a\n" (make-printable expected))
"")))))]))
;; to avoid long and confusing error messages, in the case of functions with
;; multiple similar domains (<, >, +, -, etc.), we show only the domains that
;; are relevant to this specific error
;; this is done in several ways:
;; - if a case-lambda case is subsumed by another, we don't need to show it
;; (subsumed cases may be useful for their filter information, but this is
;; unrelated to error reporting)
;; - 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
(define (possible-domains doms rests drests rngs expected)
;; is fun-ty subsumed by a function type in others?
(define (is-subsumed-in? fun-ty others)
;; assumption: domains go from more specific to less specific
;; thus, a domain can only be subsumed by another that is further down
;; the list.
;; this is reasonable because a more specific domain coming after a more
;; general domain would never be matched
;; a case subsumes another if the first one is a subtype of the other
(ormap (lambda (x) (subtype x fun-ty))
others))
(define expected-ty (and expected (match expected [(tc-result1: t) t])))
(define (returns-subtype-of-expected? fun-ty)
(and fun-ty ; was not skipped by a previous check
(or (not expected)
(match fun-ty
[(Function: (list (arr: _ rng _ _ _)))
(let ([rng (match rng
[(Values: (list (Result: t _ _)))
t]
[(ValuesDots: (list (Result: t _ _)) _ _)
t])])
(subtype rng expected-ty))]))))
(let loop ([cases (map (compose make-Function list make-arr)
doms
(map (lambda (rng) ; strip filters
(match rng
[(Values: (list (Result: t _ _) ...))
(-values t)]
[(ValuesDots: (list (Result: t _ _) ...) _ _)
(-values t)]))
rngs)
rests drests (make-list (length doms) null))]
[candidates '()])
(if (not (null? cases))
;; discard subsumed cases
(let ([head (car cases)] [tail (cdr cases)])
(if (is-subsumed-in? head tail)
(loop tail (cons #f candidates)) ; will be skipped later
(loop tail (cons head candidates))))
;; keep only the domains for which the associated function type
;; fits our criteria
(unzip4 (map cdr ; doms, rests drests
(let* ([orig (map list
(reverse candidates)
doms
rngs
rests
drests)]
[after (filter (compose returns-subtype-of-expected? car)
orig)])
;; if we somehow eliminate all the cases (bogus expected type)
;; fall back to the showing extra cases
(if (null? after) orig after)))))))
(define (poly-fail t argtypes #:name [name #f] #:expected [expected #f])
(match t

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

@ -140,7 +140,9 @@
(tc-error/expr
#:return (or expected (ret (Un)))
(string-append "No function domains matched in function application:\n"
(domain-mismatches arities doms rests drests rngs (map tc-expr (syntax->list pos-args)) #f #f)))
(domain-mismatches arities doms rests drests rngs
(map tc-expr (syntax->list pos-args))
#f #f #:expected expected)))
(tc/funapp (car (syntax-e form)) kw-args
(ret (make-Function new-arities))
(map tc-expr (syntax->list pos-args)) expected)))]))

2
collects/typed-scheme/typecheck/tc-funapp.rkt
View File

@ -58,7 +58,7 @@
(tc-error/expr
#:return (or expected (ret (Un)))
(string-append "No function domains matched in function application:\n"
(domain-mismatches t doms rests drests rngs argtys-t #f #f))))]
(domain-mismatches t doms rests drests rngs argtys-t #f #f #:expected expected))))]
;; any kind of dotted polymorphic function without mandatory keyword args
[((tc-result1: (and t (PolyDots:
(and vars (list fixed-vars ... dotted-var))