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

Make inference on (list a ..) work better.

Browse Source
This commit is contained in:
Eric Dobson 2014-05-31 09:33:03 -07:00
parent 10cc76f22b
commit e55f39dccd
2 changed files with 21 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-list.rkt
View File

@ -9,6 +9,7 @@
(types abbrev utils union substitute) (types abbrev utils union substitute)
(rep type-rep) (rep type-rep)
(env tvar-env) (env tvar-env)
(prefix-in i: (infer infer))
(for-label (for-label
racket/base racket/base
@ -81,19 +82,20 @@
[_ (tc/app-regular #'form expected)]))) [_ (tc/app-regular #'form expected)])))
;; special case for `list' ;; special case for `list'
(pattern (list . args) (pattern (list . args)
(match expected (let ()
[(tc-result1: (Listof: elem-ty)) (define vs (stx-map (λ (x) (gensym)) #'args))
(for ([i (in-syntax #'args)]) (define l-type (-Tuple (map make-F vs)))
(tc-expr/check i (ret elem-ty))) (define subst
(ret (-lst elem-ty))] (match expected
[(tc-result1: (List: (? (lambda (ts) (= (syntax-length #'args) [(tc-result1: t)
(length ts))) ;; We want to infer the largest vs that are still under the element types
ts))) (i:infer vs null (list l-type) (list t) (-values (list (-> l-type Univ))))]
(ret (-Tuple [_ #f]))
(for/list ([ac (in-syntax #'args)] (ret (-Tuple
[exp (in-list ts)]) (for/list ([i (in-syntax #'args)] [v (in-list vs)])
(tc-expr/check/t ac (ret exp)))))] (if subst
[_ (ret (-Tuple (stx-map tc-expr/t #'args)))])) (tc-expr/check/t i (ret (subst-all subst (make-F v))))
(tc-expr/t i)))))))
;; special case for `list*' ;; special case for `list*'
(pattern (list* . args) (pattern (list* . args)
(match-let* ([(list tys ... last) (stx-map tc-expr/t #'args)]) (match-let* ([(list tys ... last) (stx-map tc-expr/t #'args)])

6
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt
View File

@ -2991,6 +2991,12 @@
((letrec ([lp (lambda (x) lp)]) lp) 'y) ((letrec ([lp (lambda (x) lp)]) lp) 'y)
#:ret (ret (t:-> -Symbol Univ)) #:ret (ret (t:-> -Symbol Univ))
#:expected (ret (t:-> -Symbol Univ) -no-filter -no-obj)] #:expected (ret (t:-> -Symbol Univ) -no-filter -no-obj)]
[tc-e
(list (vector 1 2 3))
#:ret (ret (-seq (-vec Univ)))
#:expected (ret (-seq (-vec Univ)))]
) )
(test-suite (test-suite