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

Make row inference slightly smarter

Browse Source 
Now it works as long as one of the arguments is, in
all cases, a row polymorphic class type

original commit: 30c49028cb124bf252d518b60bb4db94a48943c4
This commit is contained in:
Asumu Takikawa 2013-08-29 11:23:57 -04:00
parent 5cbc1369d4
commit 08fa6df119
3 changed files with 34 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/rep/type-rep.rkt
View File

@ -633,6 +633,10 @@
(*ListDots (sb dty)
(if (eq? dbound name) (+ count outer) dbound))]
[#:Mu (Scope: body) (*Mu (*Scope (loop (add1 outer) body)))]
[#:PolyRow constraints body*
(let ([body (remove-scopes 1 body*)])
(*PolyRow constraints
(add-scopes 1 (loop (+ 1 outer) body))))]
[#:PolyDots n body*
(let ([body (remove-scopes n body*)])
(*PolyDots n (add-scopes n (loop (+ n outer) body))))]
@ -681,6 +685,9 @@
(*ListDots (sb dty)
(if (eqv? dbound (+ count outer)) (F-n image) dbound))]
[#:Mu (Scope: body) (*Mu (*Scope (loop (add1 outer) body)))]
[#:PolyRow constraints body*
(let ([body (remove-scopes 1 body*)])
(*PolyRow constraints (add-scopes 1 (loop (+ 1 outer) body))))]
[#:PolyDots n body*
(let ([body (remove-scopes n body*)])
(*PolyDots n (add-scopes n (loop (+ n outer) body))))]

12
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt
View File

@ -1250,11 +1250,11 @@
(match-define (arr: doms rng rest drest kws) arr)
(make-arr (cons self-type doms) rng rest drest kws)))
(make-Function fixed-arrs)]
[(Poly: ns body)
[(Poly-names: ns body)
(make-Poly ns (function->method body self-type))]
[(PolyDots: ns body)
[(PolyDots-names: ns body)
(make-PolyDots ns (function->method body self-type))]
[(PolyRow: ns constraints body)
[(PolyRow-names: ns constraints body)
(make-PolyRow ns constraints (function->method body self-type))]
[_ (int-err "function->method: ~a" type)]))
@ -1268,11 +1268,11 @@
(match-define (arr: doms rng rest drest kws) arr)
(make-arr (cdr doms) rng rest drest kws)))
(make-Function fixed-arrs)]
[(Poly: ns body)
[(Poly-names: ns body)
(make-Poly ns (method->function body))]
[(PolyDots: ns body)
[(PolyDots-names: ns body)
(make-PolyDots ns (method->function type))]
[(PolyRow: ns constraints body)
[(PolyRow-names: ns constraints body)
(make-PolyRow ns constraints (method->function type))]
[_ (tc-error/expr "expected a function type for method")]))

27
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-funapp.rkt
View File

@ -127,13 +127,28 @@
(poly-fail f-stx args-stx t argtys
#:name (and (identifier? f-stx) f-stx)
#:expected expected))
;; only infer if there's 1 argument
(for ([dom doms])
(unless (and (= 1 (length argtys-t) (length dom)))
(fail)))
(cond [(Class? (car argtys-t))
;; there's only one row variable in a PolyRow (for now)
(define row-var (car vars))
;; only infer if there is only one argument type that has the relevant
;; row type variable in its free variables in all cases
(define row-var-idxs
(for/list ([dom doms])
(define num-occurs
(for/list ([dom-type dom] [idx (in-naturals)]
#:when (member row-var (fv dom-type)))
idx))
(unless (<= (length num-occurs) 1)
(fail))
(if (null? num-occurs) 0 (car num-occurs))))
(unless (or (< (length row-var-idxs) 2)
(apply = row-var-idxs))
;; row var wasn't in the same position in some cases
(fail))
(define idx (car row-var-idxs))
(cond [(Class? (list-ref argtys-t idx))
(define substitution
(hash (car vars) (t-subst (infer-row constraints (car argtys-t)))))
(hash row-var
(t-subst (infer-row constraints (list-ref argtys-t idx)))))
(or (for/or ([arr (in-list arrs)])
(tc/funapp1 f-stx args-stx (subst-all substitution arr)
argtys expected #:check #f))