@@ -62,40 +62,45 @@ constrain env (A.A region expression) tipe =
6262 in
6363 return (if name == E.saveEnvName then CSaveEnv else name <? tipe)
6464
65− E.Range lo hi ->
65+ E.Range lowExpr highExpr ->
6666 existsNumber $ \n ->
67− do clo <- constrain env lo n
68− chi <- constrain env hi n
69− return $ CAnd [clo, chi, list n === tipe]
67+ do lowCon <- constrain env lowExpr n
68+ highCon <- constrain env highExpr n
69+ return $ CAnd [lowCon, highCon, list n === tipe]
7070
7171 E.ExplicitList exprs ->
7272 exists $ \x ->
7373 do constraints <- mapM (\e -> constrain env e x) exprs
7474 return $ CAnd (list x === tipe : constraints)
7575
76− E.Binop op e1 e2 ->
77− exists $ \t1 ->
78− exists $ \t2 ->
79− do c1 <- constrain env e1 t1
80− c2 <- constrain env e2 t2
81− return $ CAnd [ c1, c2, V.toString op <? (t1 ==> t2 ==> tipe) ]
76+ E.Binop op leftExpr rightExpr ->
77+ exists $ \leftType ->
78+ exists $ \rightType ->
79+ do leftCon <- constrain env leftExpr leftType
80+ rightCon <- constrain env rightExpr rightType
81+ return $ CAnd
82+ [ leftCon
83+ , rightCon
84+ , V.toString op <? (leftType ==> rightType ==> tipe)
85+ ]
8286
8387 E.Lambda pattern body ->
84− exists $ \t1 ->
85− exists $ \t2 ->
86− do fragment <- Pattern.constrain env pattern t1
87− c2 <- constrain env body t2
88− let c = ex (Fragment.vars fragment)
89− (CLet [monoscheme (Fragment.typeEnv fragment)]
90− (Fragment.typeConstraint fragment /\ c2)
91− )
92− return $ c /\ tipe === (t1 ==> t2)
93−
94− E.App e1 e2 ->
88+ exists $ \argType ->
89+ exists $ \resType ->
90+ do fragment <- Pattern.constrain env pattern argType
91+ bodyCon <- constrain env body resType
92+ let con =
93+ ex (Fragment.vars fragment)
94+ (CLet [monoscheme (Fragment.typeEnv fragment)]
95+ (Fragment.typeConstraint fragment /\ bodyCon)
96+ )
97+ return $ con /\ tipe === (argType ==> resType)
98+
99+ E.App func arg ->
95100 exists $ \t ->
96− do c1 <- constrain env e1 (t ==> tipe)
97− c2 <- constrain env e2 t
98− return $ c1 /\ c2
101+ do funcCon <- constrain env func (t ==> tipe)
102+ argCon <- constrain env arg t
103+ return (funcCon /\ argCon)
99104
100105 E.MultiIf branches ->
101106 CAnd <$> mapM constrain' branches
@@ -115,7 +120,8 @@ constrain env (A.A region expression) tipe =
115120 where
116121 branch t (pattern, branchExpr) =
117122 do fragment <- Pattern.constrain env pattern t
118− CLet [Fragment.toScheme fragment] <$> constrain env branchExpr tipe
123+ branchConstraint <- constrain env branchExpr tipe
124+ return (CLet [Fragment.toScheme fragment] branchConstraint)
119125
120126 E.Data name exprs ->
121127 do vars <- Monad.forM exprs $ \_ -> variable Flexible
@@ -136,12 +142,13 @@ constrain env (A.A region expression) tipe =
136142 constrain env expr (record (Map.singleton label [t]) tipe)
137143
138144 E.Insert expr label value ->
139− exists $ \tVal ->
140− exists $ \tRec ->
141− do cVal <- constrain env value tVal
142− cRec <- constrain env expr tRec
143− let c = tipe === record (Map.singleton label [tVal]) tRec
144− return (CAnd [cVal, cRec, c])
145+ exists $ \valueType ->
146+ exists $ \recordType ->
147+ do valueCon <- constrain env value valueType
148+ recordCon <- constrain env expr recordType
149+ let newRecordType =
150+ record (Map.singleton label [valueType]) recordType
151+ return (CAnd [valueCon, recordCon, tipe === newRecordType])
145152
146153 E.Modify expr fields ->
147154 exists $ \t ->
@@ -158,14 +165,18 @@ constrain env (A.A region expression) tipe =
158165 return $ cOld /\ ex newVars (CAnd (cNew : cs))
159166
160167 E.Record fields ->
161− do vars <- Monad.forM fields $ \_ -> variable Flexible
162− cs <- Monad.zipWithM (constrain env) (map snd fields) (map varN vars)
168+ do vars <- Monad.forM fields (\_ -> variable Flexible)
169+ fieldCons <-
170+ Monad.zipWithM
171+ (constrain env)
172+ (map snd fields)
173+ (map varN vars)
163174 let fields' = ST.fieldMap (zip (map fst fields) (map varN vars))
164175 let recordType = record fields' (termN EmptyRecord1)
165− return . ex vars . CAnd $ tipe === recordType : cs
176+ return (ex vars (CAnd (tipe === recordType : fieldCons)))
166177
167178 E.Let defs body ->
168− do c <- constrain env body tipe
179+ do bodyCon <- constrain env body tipe
169180
170181 (Info schemes rqs fqs headers c2 c1) <-
171182 Monad.foldM
@@ -175,7 +186,7 @@ constrain env (A.A region expression) tipe =
175186
176187 let letScheme = [ Scheme rqs fqs (CLet [monoscheme headers] c2) headers ]
177188
178− return $ CLet schemes (CLet letScheme (c1 /\ c))
189+ return $ CLet schemes (CLet letScheme (c1 /\ bodyCon))
179190
180191 E.Port impl ->
181192 case impl of