@@ -62,40 +62,45 @@ constrain env (A.A region expression) tipe =
63 return (if name == E.saveEnvName then CSaveEnv else name <? tipe)
63 return (if name == E.saveEnvName then CSaveEnv else name <? tipe)
65− E.Range lo hi ->
65+ E.Range lowExpr highExpr ->
66 existsNumber $ \n ->
66 existsNumber $ \n ->
67− do clo <- constrain env lo n
67+ do lowCon <- constrain env lowExpr n
68− chi <- constrain env hi n
68+ highCon <- constrain env highExpr n
69− return $ CAnd [clo, chi, list n === tipe]
69+ return $ CAnd [lowCon, highCon, list n === tipe]
71 E.ExplicitList exprs ->
71 E.ExplicitList exprs ->
72 exists $ \x ->
72 exists $ \x ->
73 do constraints <- mapM (\e -> constrain env e x) exprs
73 do constraints <- mapM (\e -> constrain env e x) exprs
74 return $ CAnd (list x === tipe : constraints)
74 return $ CAnd (list x === tipe : constraints)
76− E.Binop op e1 e2 ->
76+ E.Binop op leftExpr rightExpr ->
77− exists $ \t1 ->
77+ exists $ \leftType ->
78− exists $ \t2 ->
78+ exists $ \rightType ->
79− do c1 <- constrain env e1 t1
79+ do leftCon <- constrain env leftExpr leftType
80− c2 <- constrain env e2 t2
80+ rightCon <- constrain env rightExpr rightType
81− return $ CAnd [ c1, c2, V.toString op <? (t1 ==> t2 ==> tipe) ]
81+ return $ CAnd
84+ , V.toString op <? (leftType ==> rightType ==> tipe)
83 E.Lambda pattern body ->
87 E.Lambda pattern body ->
84− exists $ \t1 ->
88+ exists $ \argType ->
85− exists $ \t2 ->
89+ exists $ \resType ->
86− do fragment <- Pattern.constrain env pattern t1
90+ do fragment <- Pattern.constrain env pattern argType
87− c2 <- constrain env body t2
91+ bodyCon <- constrain env body resType
88− let c = ex (Fragment.vars fragment)
93+ ex (Fragment.vars fragment)
89− (CLet [monoscheme (Fragment.typeEnv fragment)]
94+ (CLet [monoscheme (Fragment.typeEnv fragment)]
90− (Fragment.typeConstraint fragment /\ c2)
95+ (Fragment.typeConstraint fragment /\ bodyCon)
92− return $ c /\ tipe === (t1 ==> t2)
97+ return $ con /\ tipe === (argType ==> resType)
94− E.App e1 e2 ->
99+ E.App func arg ->
95 exists $ \t ->
100 exists $ \t ->
96− do c1 <- constrain env e1 (t ==> tipe)
101+ do funcCon <- constrain env func (t ==> tipe)
97− c2 <- constrain env e2 t
102+ argCon <- constrain env arg t
98− return $ c1 /\ c2
103+ return (funcCon /\ argCon)
100 E.MultiIf branches ->
105 E.MultiIf branches ->
101 CAnd <$> mapM constrain' branches
106 CAnd <$> mapM constrain' branches
@@ -115,7 +120,8 @@ constrain env (A.A region expression) tipe =
116 branch t (pattern, branchExpr) =
121 branch t (pattern, branchExpr) =
117 do fragment <- Pattern.constrain env pattern t
122 do fragment <- Pattern.constrain env pattern t
123+ branchConstraint <- constrain env branchExpr tipe
118− CLet [Fragment.toScheme fragment] <$> constrain env branchExpr tipe
124+ return (CLet [Fragment.toScheme fragment] branchConstraint)
120 E.Data name exprs ->
126 E.Data name exprs ->
121 do vars <- Monad.forM exprs $ \_ -> variable Flexible
127 do vars <- Monad.forM exprs $ \_ -> variable Flexible
@@ -136,12 +142,13 @@ constrain env (A.A region expression) tipe =
136 constrain env expr (record (Map.singleton label [t]) tipe)
142 constrain env expr (record (Map.singleton label [t]) tipe)
138 E.Insert expr label value ->
144 E.Insert expr label value ->
139− exists $ \tVal ->
145+ exists $ \valueType ->
140− exists $ \tRec ->
146+ exists $ \recordType ->
141− do cVal <- constrain env value tVal
147+ do valueCon <- constrain env value valueType
142− cRec <- constrain env expr tRec
148+ recordCon <- constrain env expr recordType
143− let c = tipe === record (Map.singleton label [tVal]) tRec
150+ record (Map.singleton label [valueType]) recordType
144− return (CAnd [cVal, cRec, c])
151+ return (CAnd [valueCon, recordCon, tipe === newRecordType])
146 E.Modify expr fields ->
153 E.Modify expr fields ->
147 exists $ \t ->
154 exists $ \t ->
@@ -158,14 +165,18 @@ constrain env (A.A region expression) tipe =
158 return $ cOld /\ ex newVars (CAnd (cNew : cs))
165 return $ cOld /\ ex newVars (CAnd (cNew : cs))
160 E.Record fields ->
167 E.Record fields ->
161− do vars <- Monad.forM fields $ \_ -> variable Flexible
168+ do vars <- Monad.forM fields (\_ -> variable Flexible)
162− cs <- Monad.zipWithM (constrain env) (map snd fields) (map varN vars)
170+ Monad.zipWithM
163 let fields' = ST.fieldMap (zip (map fst fields) (map varN vars))
174 let fields' = ST.fieldMap (zip (map fst fields) (map varN vars))
164 let recordType = record fields' (termN EmptyRecord1)
175 let recordType = record fields' (termN EmptyRecord1)
165− return . ex vars . CAnd $ tipe === recordType : cs
176+ return (ex vars (CAnd (tipe === recordType : fieldCons)))
167 E.Let defs body ->
178 E.Let defs body ->
168− do c <- constrain env body tipe
179+ do bodyCon <- constrain env body tipe
170 (Info schemes rqs fqs headers c2 c1) <-
181 (Info schemes rqs fqs headers c2 c1) <-
171 Monad.foldM
182 Monad.foldM
@@ -175,7 +186,7 @@ constrain env (A.A region expression) tipe =
176 let letScheme = [ Scheme rqs fqs (CLet [monoscheme headers] c2) headers ]
187 let letScheme = [ Scheme rqs fqs (CLet [monoscheme headers] c2) headers ]
178− return $ CLet schemes (CLet letScheme (c1 /\ c))
189+ return $ CLet schemes (CLet letScheme (c1 /\ bodyCon))
180 E.Port impl ->
191 E.Port impl ->
181 case impl of
192 case impl of