Skip to content

Commit 4f17c9b

Browse files
pnwamkpnwamk
committed
swag at fixing inference for improved function application
1 parent e4a1542 commit 4f17c9b

File tree

5 files changed

+62
-13
lines changed

5 files changed

+62
-13
lines changed

‎typed-racket-lib/typed-racket/infer/constraints.rkt

Lines changed: 2 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -2,7 +2,6 @@
22

33
(require "../utils/utils.rkt"
44
(types abbrev subtype)
5-
racket/dict
65
"fail.rkt" "signatures.rkt" "constraint-structs.rkt"
76
racket/match
87
racket/list)
@@ -67,8 +66,8 @@
6766
[(x y)
6867
(match* (x y)
6968
[((struct cset (maps1)) (struct cset (maps2)))
70-
(define maps (for*/list ([(map1 dmap1) (in-dict (remove-duplicates maps1))]
71-
[(map2 dmap2) (in-dict (remove-duplicates maps2))]
69+
(define maps (for*/list ([(map1 dmap1) (in-assoc (remove-duplicates maps1))]
70+
[(map2 dmap2) (in-assoc (remove-duplicates maps2))]
7271
[v (in-value (% cons
7372
(hash-union/fail map1 map2 #:combine c-meet)
7473
(dmap-meet dmap1 dmap2)))]

‎typed-racket-lib/typed-racket/infer/infer-unit.rkt

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -975,7 +975,8 @@
975975

976976
;; like infer, but T-var is the vararg type:
977977
(define (infer/vararg X Y S T T-var R [expected #f]
978-
#:objs [objs '()])
978+
#:objs [objs '()]
979+
#:multiple? [multiple? #f])
979980
(and ((length S) . >= . (length T))
980981
(let* ([fewer-ts (- (length S) (length T))]
981982
[new-T (match T-var
@@ -985,7 +986,7 @@
985986
(append T (repeat-list rst-ts
986987
(quotient fewer-ts (length rst-ts))))]
987988
[_ T])])
988-
(infer X Y S new-T R expected #:objs objs))))
989+
(infer X Y S new-T R expected #:objs objs #:multiple? multiple?))))
989990

990991
;; like infer, but dotted-var is the bound on the ...
991992
;; and T-dotted is the repeated type

‎typed-racket-lib/typed-racket/infer/signatures.rkt

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -55,6 +55,8 @@
5555
(or/c #f Values/c ValuesDots?))
5656
;; [optional] expected type
5757
((or/c #f Values/c AnyValues? ValuesDots?)
58+
;; optional multiple substitutions?
59+
#:multiple? boolean?
5860
#:objs (listof OptObject?))
5961
. ->* . any)]
6062
[cond-contracted infer/dots (((listof symbol?)

‎typed-racket-lib/typed-racket/rep/type-rep.rkt

Lines changed: 13 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -963,9 +963,17 @@
963963
[(t) t]
964964
[args
965965
(let loop ([ts '()]
966+
[arrows '()]
966967
[elems (hash)]
967968
[prop -tt]
968969
[args args])
970+
(define fty (let ([arrows (remove-duplicates arrows)])
971+
(if (null? arrows)
972+
#f
973+
(make-Fun arrows))))
974+
(when fty
975+
(set! ts (cons fty ts))
976+
(set! elems (hash-set elems fty #t)))
969977
(match args
970978
[(list)
971979
(match ts
@@ -975,17 +983,19 @@
975983
(-refine t prop))])]
976984
[(cons arg args)
977985
(match arg
978-
[(Univ:) (loop ts elems prop args)]
979-
[(Intersection: ts* (TrueProp:) _) (loop ts elems prop (append ts* args))]
986+
[(Univ:) (loop ts arrows elems prop args)]
987+
[(Fun: arrows*) (loop ts (append arrows* arrows) elems prop args)]
988+
[(Intersection: ts* (TrueProp:) _) (loop ts arrows elems prop (append ts* args))]
980989
[(Intersection: ts* prop* _)
981990
(loop ts
991+
arrows
982992
elems
983993
(-and prop* prop)
984994
(append ts* args))]
985995
[_ #:when (for/or ([elem (in-list args)])
986996
(not (overlap? elem arg)))
987997
-Bottom]
988-
[t (loop (cons t ts) (hash-set elems t #t) prop args)])]))]))
998+
[t (loop (cons t ts) arrows (hash-set elems t #t) prop args)])]))]))
989999

9901000
(define/provide (Intersection-w/o-prop t)
9911001
(match t

‎typed-racket-lib/typed-racket/typecheck/tc-funapp.rkt

Lines changed: 42 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -42,8 +42,45 @@
4242
#:when when-expr
4343
(let ([substitution infer-expr])
4444
(and substitution
45-
(tc/funapp1 f-stx args-stx (subst-all substitution arr)
46-
args-res expected #:check #f)))]
45+
(cond
46+
[(list? substitution)
47+
(define applicable-arrows
48+
(for/list ([s (in-list substitution)])
49+
(subst-all s arr)))
50+
;; call a separate function so that we get
51+
;; the appropriate props/objects
52+
(define app-result
53+
(intersect-tc-results
54+
(for/list ([a (in-list applicable-arrows)])
55+
(tc/funapp1 f-stx args-stx a args-res expected
56+
#:check #f
57+
#:tooltip? #f))))
58+
(define applicable-domain
59+
;; gather and intersect applicable domains to report to user
60+
;; generally what class of inputs produces the resulting output
61+
(for/fold ([domtys (build-list (length args-res) (λ (_) Univ))])
62+
([a (in-list applicable-arrows)])
63+
(match a
64+
[(Arrow: dom rst _ _) (for/list ([domty (in-list domtys)]
65+
[idx (in-naturals)])
66+
(intersect domty (dom+rst-ref dom rst idx)))])))
67+
(add-typeof-expr
68+
f-stx
69+
(ret (make-Fun (list (-Arrow applicable-domain (tc-results->values app-result))))))
70+
(cond
71+
[expected
72+
(check-below app-result expected)]
73+
[else
74+
app-result])
75+
app-result]
76+
[else
77+
(define app-result
78+
(tc/funapp1 f-stx args-stx (subst-all substitution arr)
79+
args-res expected #:check #f))
80+
(cond
81+
[expected
82+
(check-below app-result expected)]
83+
[else app-result])])))]
4784
[_ #f]))
4885
(poly-fail f-stx args-stx t args-res
4986
#:name (and (identifier? f-stx) f-stx)
@@ -223,9 +260,9 @@
223260
(let ([rng (subst-dom-objs argtys argobjs rng)])
224261
(extend-tvars vars
225262
(infer/vararg vars null argtys dom rst rng
226-
(and expected
227-
(tc-results->values expected))
228-
#:objs argobjs)))
263+
#f
264+
#:objs argobjs
265+
#:multiple? #t)))
229266
#:function-type f-type
230267
#:args-results args-res
231268
#:expected expected)]

0 commit comments

Comments
 (0)