@@ -21,155 +21,164 @@ import qualified Type.Fragment as Fragment
2121import Type.Type hiding (Descriptor(..))
2222
2323
24+
2425constrain
2526 :: Env.Environment
2627 -> Canonical.Expr
2728 -> Type
2829 -> IO TypeConstraint
2930constrain env annotatedExpr@(A.A region expression) tipe =
30− let list t = Env.getType env "List" <| t
31− (<?) = CInstance region
32− in
33− case expression of
34− E.Literal lit ->
35− Literal.constrain env region lit tipe
36−
37− E.GLShader _uid _src gltipe ->
38− exists $ \attr ->
39− exists $ \unif ->
40− let
41− shaderTipe a u v =
42− Env.getType env "WebGL.Shader" <| a <| u <| v
43−
44− glToType glTipe =
45− Env.getType env (Lit.glTipeName glTipe)
46−
47− makeRec accessor baseRec =
48− let decls = accessor gltipe
49− in
50− if Map.size decls == 0 then
51− baseRec
52− else
53− record (Map.map glToType decls) baseRec
54−
55− attribute = makeRec Lit.attribute attr
56− uniform = makeRec Lit.uniform unif
57− varying = makeRec Lit.varying (TermN EmptyRecord1)
31+ let
32+ list t =
33+ Env.getType env "List" <| t
34+
35+ (<?) =
36+ CInstance region
37+ in
38+ case expression of
39+ E.Literal lit ->
40+ Literal.constrain env region lit tipe
41+
42+ E.GLShader _uid _src gltipe ->
43+ exists $ \attr ->
44+ exists $ \unif ->
45+ let
46+ shaderTipe a u v =
47+ Env.getType env "WebGL.Shader" <| a <| u <| v
48+
49+ glToType glTipe =
50+ Env.getType env (Lit.glTipeName glTipe)
51+
52+ makeRec accessor baseRec =
53+ let decls = accessor gltipe
5854 in
59− return (CEqual Error.Shader region (shaderTipe attribute uniform varying) tipe)
60−
61− E.Var var ->
62− let name = V.toString var
63− in
64− return (if name == E.saveEnvName then CSaveEnv else name <? tipe)
65−
66− E.Range lowExpr highExpr ->
67− existsNumber $ \n ->
68− do lowCon <- constrain env lowExpr n
69− highCon <- constrain env highExpr n
70− return $ CAnd
71− [ lowCon
72− , highCon
73− , CEqual Error.Range region (list n) tipe
74− ]
75−
76− E.ExplicitList exprs ->
77− constrainList env region exprs tipe
78−
79− E.Binop op leftExpr rightExpr ->
80− constrainBinop env region op leftExpr rightExpr tipe
81−
82− E.Lambda pattern body ->
83− exists $ \argType ->
84− exists $ \resType ->
85− do fragment <- Pattern.constrain env pattern argType
86− bodyCon <- constrain env body resType
87− let con =
88− ex (Fragment.vars fragment)
89− (CLet [monoscheme (Fragment.typeEnv fragment)]
90− (Fragment.typeConstraint fragment /\ bodyCon)
91− )
92− return $ con /\ CEqual Error.Lambda region (argType ==> resType) tipe
93−
94− E.App _ _ ->
95− let
96− (f:args) = E.collectApps annotatedExpr
97− in
98− constrainApp env region f args tipe
99−
100− E.If branches finally ->
101− constrainIf env region branches finally tipe
102−
103− E.Case expr branches ->
104− constrainCase env region expr branches tipe
105−
106− E.Data name exprs ->
107− do vars <- Monad.forM exprs $ \_ -> mkVar Nothing
108− let pairs = zip exprs (map VarN vars)
109− (ctipe, cs) <- Monad.foldM step (tipe, CTrue) (reverse pairs)
110− return $ ex vars (cs /\ name <? ctipe)
111− where
112− step (t,c) (e,x) =
113− do c' <- constrain env e x
114− return (x ==> t, c /\ c')
115−
116− E.Access expr label ->
117− exists $ \t ->
118− constrain env expr (record (Map.singleton label tipe) t)
119−
120− E.Update expr fields ->
121− exists $ \t ->
122− do oldVars <- mapM (\_ -> mkVar Nothing) fields
123− let oldFields = Map.fromList (zip (map fst fields) (map VarN oldVars))
124− cOld <- ex oldVars <$> constrain env expr (record oldFields t)
125−
126− newVars <- mapM (\_ -> mkVar Nothing) fields
127− let newFields = Map.fromList (zip (map fst fields) (map VarN newVars))
128− let cNew = CEqual Error.Record region (record newFields t) tipe
129−
130− cs <- Monad.zipWithM (constrain env) (map snd fields) (map VarN newVars)
131−
132− return $ cOld /\ ex newVars (CAnd (cNew : cs))
133−
134− E.Record fields ->
135− do vars <- Monad.forM fields (\_ -> mkVar Nothing)
136− fieldCons <-
137− Monad.zipWithM
138− (constrain env)
139− (map snd fields)
140− (map VarN vars)
141− let fields' = Map.fromList (zip (map fst fields) (map VarN vars))
142− let recordType = record fields' (TermN EmptyRecord1)
143− return (ex vars (CAnd (fieldCons ++ [CEqual Error.Record region recordType tipe])))
144−
145− E.Let defs body ->
146− do bodyCon <- constrain env body tipe
147−
148− (Info schemes rqs fqs headers c2 c1) <-
149− Monad.foldM
150− (constrainDef env)
151− (Info [] [] [] Map.empty CTrue CTrue)
152− (concatMap expandPattern defs)
153−
154− let letScheme =
155− [ Scheme rqs fqs (CLet [monoscheme headers] c2) headers ]
156−
157− return $ CLet schemes (CLet letScheme (c1 /\ bodyCon))
158−
159− E.Port impl ->
160− case impl of
161− E.In _ _ ->
162− return CTrue
163−
164− E.Out _ expr _ ->
165− constrain env expr tipe
166−
167− E.Task _ expr _ ->
168− constrain env expr tipe
55+ if Map.size decls == 0 then
56+ baseRec
57+ else
58+ record (Map.map glToType decls) baseRec
59+
60+ attribute = makeRec Lit.attribute attr
61+ uniform = makeRec Lit.uniform unif
62+ varying = makeRec Lit.varying (TermN EmptyRecord1)
63+ in
64+ return (CEqual Error.Shader region (shaderTipe attribute uniform varying) tipe)
65+
66+ E.Var var ->
67+ let
68+ name =
69+ V.toString var
70+ in
71+ return (if name == E.saveEnvName then CSaveEnv else name <? tipe)
72+
73+ E.Range lowExpr highExpr ->
74+ existsNumber $ \n ->
75+ do lowCon <- constrain env lowExpr n
76+ highCon <- constrain env highExpr n
77+ return $ CAnd
78+ [ lowCon
79+ , highCon
80+ , CEqual Error.Range region (list n) tipe
81+ ]
82+
83+ E.ExplicitList exprs ->
84+ constrainList env region exprs tipe
85+
86+ E.Binop op leftExpr rightExpr ->
87+ constrainBinop env region op leftExpr rightExpr tipe
88+
89+ E.Lambda pattern body ->
90+ exists $ \argType ->
91+ exists $ \resType ->
92+ do fragment <- Pattern.constrain env pattern argType
93+ bodyCon <- constrain env body resType
94+ let con =
95+ ex (Fragment.vars fragment)
96+ (CLet [monoscheme (Fragment.typeEnv fragment)]
97+ (Fragment.typeConstraint fragment /\ bodyCon)
98+ )
99+ return $ con /\ CEqual Error.Lambda region (argType ==> resType) tipe
100+
101+ E.App _ _ ->
102+ let
103+ (f:args) = E.collectApps annotatedExpr
104+ in
105+ constrainApp env region f args tipe
106+
107+ E.If branches finally ->
108+ constrainIf env region branches finally tipe
109+
110+ E.Case expr branches ->
111+ constrainCase env region expr branches tipe
112+
113+ E.Data name exprs ->
114+ do vars <- Monad.forM exprs $ \_ -> mkVar Nothing
115+ let pairs = zip exprs (map VarN vars)
116+ (ctipe, cs) <- Monad.foldM step (tipe, CTrue) (reverse pairs)
117+ return $ ex vars (cs /\ name <? ctipe)
118+ where
119+ step (t,c) (e,x) =
120+ do c' <- constrain env e x
121+ return (x ==> t, c /\ c')
122+
123+ E.Access expr label ->
124+ exists $ \t ->
125+ constrain env expr (record (Map.singleton label tipe) t)
126+
127+ E.Update expr fields ->
128+ exists $ \t ->
129+ do oldVars <- mapM (\_ -> mkVar Nothing) fields
130+ let oldFields = Map.fromList (zip (map fst fields) (map VarN oldVars))
131+ cOld <- ex oldVars <$> constrain env expr (record oldFields t)
132+
133+ newVars <- mapM (\_ -> mkVar Nothing) fields
134+ let newFields = Map.fromList (zip (map fst fields) (map VarN newVars))
135+ let cNew = CEqual Error.Record region (record newFields t) tipe
136+
137+ cs <- Monad.zipWithM (constrain env) (map snd fields) (map VarN newVars)
138+
139+ return $ cOld /\ ex newVars (CAnd (cNew : cs))
140+
141+ E.Record fields ->
142+ do vars <- Monad.forM fields (\_ -> mkVar Nothing)
143+ fieldCons <-
144+ Monad.zipWithM
145+ (constrain env)
146+ (map snd fields)
147+ (map VarN vars)
148+ let fields' = Map.fromList (zip (map fst fields) (map VarN vars))
149+ let recordType = record fields' (TermN EmptyRecord1)
150+ return (ex vars (CAnd (fieldCons ++ [CEqual Error.Record region recordType tipe])))
151+
152+ E.Let defs body ->
153+ do bodyCon <- constrain env body tipe
154+
155+ (Info schemes rqs fqs headers c2 c1) <-
156+ Monad.foldM
157+ (constrainDef env)
158+ (Info [] [] [] Map.empty CTrue CTrue)
159+ (concatMap expandPattern defs)
160+
161+ let letScheme =
162+ [ Scheme rqs fqs (CLet [monoscheme headers] c2) headers ]
163+
164+ return $ CLet schemes (CLet letScheme (c1 /\ bodyCon))
165+
166+ E.Port impl ->
167+ case impl of
168+ E.In _ _ ->
169+ return CTrue
170+
171+ E.Out _ expr _ ->
172+ constrain env expr tipe
173+
174+ E.Task _ expr _ ->
175+ constrain env expr tipe
176+
169177
170178
171179-- CONSTRAIN APP
172180
181+
173182constrainApp
174183 :: Env.Environment
175184 -> R.Region
@@ -250,9 +259,9 @@ argConstraints env name region totalArgs overallVar index args =
250259
251260
252261
253−
254262-- CONSTRAIN BINOP
255263
264+
256265constrainBinop
257266 :: Env.Environment
258267 -> R.Region
@@ -285,8 +294,10 @@ constrainBinop env region op leftExpr@(A.A leftRegion _) rightExpr@(A.A rightReg
285294 ]
286295
287296
297+
288298-- CONSTRAIN LISTS
289299
300+
290301constrainList
291302 :: Env.Environment
292303 -> R.Region
@@ -310,8 +321,10 @@ constrainList env region exprs tipe =
310321 CEqual Error.List region (Env.getType env "List" <| VarN var) tipe
311322
312323
324+
313325-- CONSTRAIN IF EXPRESSIONS
314326
327+
315328constrainIf
316329 :: Env.Environment
317330 -> R.Region
@@ -367,8 +380,10 @@ constrainIf env region branches finally tipe =
367380 CEqual Error.If region (VarN var) tipe
368381
369382
383+
370384-- CONSTRAIN CASE EXPRESSIONS
371385
386+
372387constrainCase
373388 :: Env.Environment
374389 -> R.Region
@@ -400,8 +415,10 @@ constrainCase env region expr branches tipe =
400415 CEqual Error.Case region tipe (VarN var)
401416
402417
418+
403419-- COLLECT PAIRS
404420
421+
405422data Pair = Pair
406423 { _index :: Int
407424 , _var1 :: Variable
@@ -423,11 +440,11 @@ pairCons region pairHint varToCon items =
423440 in
424441 case collectPairs 2 items of
425442 Nothing ->
426− do var <- mkVar Nothing
427− return ([var], [varToCon var])
443+ do var <- mkVar Nothing
444+ return ([var], [varToCon var])
428445
429446 Just (pairs, var) ->
430− return (map fst items, map pairToCon pairs ++ [varToCon var])
447+ return (map fst items, map pairToCon pairs ++ [varToCon var])
431448
432449
433450collectPairs :: Int -> [(Variable, R.Region)] -> Maybe ([Pair], Variable)
@@ -444,11 +461,15 @@ collectPairs index items =
444461 return (Pair index var var' region : pairs, summaryVar)
445462
446463
464+
447465-- EXPAND PATTERNS
448466
467+
449468expandPattern :: Canonical.Def -> [Canonical.Def]
450469expandPattern def@(Canonical.Definition facts lpattern expr maybeType) =
451− let (A.A patternRegion pattern) = lpattern
470+ let
471+ (A.A patternRegion pattern) =
472+ lpattern
452473 in
453474 case pattern of
454475 P.Var _ ->
@@ -476,8 +497,10 @@ expandPattern def@(Canonical.Definition facts lpattern expr maybeType) =
476497 Canonical.Definition facts (pvar name) (A.A patternRegion extract) Nothing
477498
478499
500+
479501-- CONSTRAIN DEFINITIONS
480502
503+
481504data Info = Info
482505 { iSchemes :: [TypeScheme]
483506 , iRigid :: [Variable]