git.iko.soy/elk
on master help sign in
cosmetic: modernize whitespace
4e73834Evan Czaplicki
src/Type/Constrain/Expression.hs+166−143
compare with master
unifiedsplit
@@ -21,155 +21,164 @@ import qualified Type.Fragment as Fragment
21import Type.Type hiding (Descriptor(..))
21import Type.Type hiding (Descriptor(..))
22
22
23
23
24+
24constrain
25constrain
25 :: Env.Environment
26 :: Env.Environment
26 -> Canonical.Expr
27 -> Canonical.Expr
27 -> Type
28 -> Type
28 -> IO TypeConstraint
29 -> IO TypeConstraint
29constrain env annotatedExpr@(A.A region expression) tipe =
30constrain env annotatedExpr@(A.A region expression) tipe =
31+ let
32+ list t =
30− let list t = Env.getType env "List" <| t
33+ Env.getType env "List" <| t
34+
35+ (<?) =
31− (<?) = CInstance region
36+ CInstance region
32− in
37+ in
33− case expression of
38+ case expression of
34− E.Literal lit ->
39+ E.Literal lit ->
35− Literal.constrain env region lit tipe
40+ Literal.constrain env region lit tipe
36−
41+
37− E.GLShader _uid _src gltipe ->
42+ E.GLShader _uid _src gltipe ->
38− exists $ \attr ->
43+ exists $ \attr ->
39− exists $ \unif ->
44+ exists $ \unif ->
40− let
45+ let
41− shaderTipe a u v =
46+ shaderTipe a u v =
42− Env.getType env "WebGL.Shader" <| a <| u <| v
47+ Env.getType env "WebGL.Shader" <| a <| u <| v
43−
48+
44− glToType glTipe =
49+ glToType glTipe =
45− Env.getType env (Lit.glTipeName glTipe)
50+ Env.getType env (Lit.glTipeName glTipe)
46−
51+
47− makeRec accessor baseRec =
52+ makeRec accessor baseRec =
48− let decls = accessor gltipe
53+ 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)
58 in
54 in
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
59− return (CEqual Error.Shader region (shaderTipe attribute uniform varying) tipe)
64+ return (CEqual Error.Shader region (shaderTipe attribute uniform varying) tipe)
60−
65+
61− E.Var var ->
66+ E.Var var ->
67+ let
68+ name =
62− let name = V.toString var
69+ V.toString var
63− in
70+ in
64− return (if name == E.saveEnvName then CSaveEnv else name <? tipe)
71+ return (if name == E.saveEnvName then CSaveEnv else name <? tipe)
65−
72+
66− E.Range lowExpr highExpr ->
73+ E.Range lowExpr highExpr ->
67− existsNumber $ \n ->
74+ existsNumber $ \n ->
68− do lowCon <- constrain env lowExpr n
75+ do lowCon <- constrain env lowExpr n
69− highCon <- constrain env highExpr n
76+ highCon <- constrain env highExpr n
70− return $ CAnd
77+ return $ CAnd
71− [ lowCon
78+ [ lowCon
72− , highCon
79+ , highCon
73− , CEqual Error.Range region (list n) tipe
80+ , CEqual Error.Range region (list n) tipe
74− ]
81+ ]
75−
82+
76− E.ExplicitList exprs ->
83+ E.ExplicitList exprs ->
77− constrainList env region exprs tipe
84+ constrainList env region exprs tipe
78−
85+
79− E.Binop op leftExpr rightExpr ->
86+ E.Binop op leftExpr rightExpr ->
80− constrainBinop env region op leftExpr rightExpr tipe
87+ constrainBinop env region op leftExpr rightExpr tipe
81−
88+
82− E.Lambda pattern body ->
89+ E.Lambda pattern body ->
83− exists $ \argType ->
90+ exists $ \argType ->
84− exists $ \resType ->
91+ exists $ \resType ->
85− do fragment <- Pattern.constrain env pattern argType
92+ do fragment <- Pattern.constrain env pattern argType
86− bodyCon <- constrain env body resType
93+ bodyCon <- constrain env body resType
87− let con =
94+ let con =
88− ex (Fragment.vars fragment)
95+ ex (Fragment.vars fragment)
89− (CLet [monoscheme (Fragment.typeEnv fragment)]
96+ (CLet [monoscheme (Fragment.typeEnv fragment)]
90− (Fragment.typeConstraint fragment /\ bodyCon)
97+ (Fragment.typeConstraint fragment /\ bodyCon)
91− )
98+ )
92− return $ con /\ CEqual Error.Lambda region (argType ==> resType) tipe
99+ return $ con /\ CEqual Error.Lambda region (argType ==> resType) tipe
93−
100+
94− E.App _ _ ->
101+ E.App _ _ ->
95− let
102+ let
96− (f:args) = E.collectApps annotatedExpr
103+ (f:args) = E.collectApps annotatedExpr
97− in
104+ in
98− constrainApp env region f args tipe
105+ constrainApp env region f args tipe
99−
106+
100− E.If branches finally ->
107+ E.If branches finally ->
101− constrainIf env region branches finally tipe
108+ constrainIf env region branches finally tipe
102−
109+
103− E.Case expr branches ->
110+ E.Case expr branches ->
104− constrainCase env region expr branches tipe
111+ constrainCase env region expr branches tipe
105−
112+
106− E.Data name exprs ->
113+ E.Data name exprs ->
107− do vars <- Monad.forM exprs $ \_ -> mkVar Nothing
114+ do vars <- Monad.forM exprs $ \_ -> mkVar Nothing
108− let pairs = zip exprs (map VarN vars)
115+ let pairs = zip exprs (map VarN vars)
109− (ctipe, cs) <- Monad.foldM step (tipe, CTrue) (reverse pairs)
116+ (ctipe, cs) <- Monad.foldM step (tipe, CTrue) (reverse pairs)
110− return $ ex vars (cs /\ name <? ctipe)
117+ return $ ex vars (cs /\ name <? ctipe)
111− where
118+ where
112− step (t,c) (e,x) =
119+ step (t,c) (e,x) =
113− do c' <- constrain env e x
120+ do c' <- constrain env e x
114− return (x ==> t, c /\ c')
121+ return (x ==> t, c /\ c')
115−
122+
116− E.Access expr label ->
123+ E.Access expr label ->
117− exists $ \t ->
124+ exists $ \t ->
118− constrain env expr (record (Map.singleton label tipe) t)
125+ constrain env expr (record (Map.singleton label tipe) t)
119−
126+
120− E.Update expr fields ->
127+ E.Update expr fields ->
121− exists $ \t ->
128+ exists $ \t ->
122− do oldVars <- mapM (\_ -> mkVar Nothing) fields
129+ do oldVars <- mapM (\_ -> mkVar Nothing) fields
123− let oldFields = Map.fromList (zip (map fst fields) (map VarN oldVars))
130+ let oldFields = Map.fromList (zip (map fst fields) (map VarN oldVars))
124− cOld <- ex oldVars <$> constrain env expr (record oldFields t)
131+ cOld <- ex oldVars <$> constrain env expr (record oldFields t)
125−
132+
126− newVars <- mapM (\_ -> mkVar Nothing) fields
133+ newVars <- mapM (\_ -> mkVar Nothing) fields
127− let newFields = Map.fromList (zip (map fst fields) (map VarN newVars))
134+ let newFields = Map.fromList (zip (map fst fields) (map VarN newVars))
128− let cNew = CEqual Error.Record region (record newFields t) tipe
135+ let cNew = CEqual Error.Record region (record newFields t) tipe
129−
136+
130− cs <- Monad.zipWithM (constrain env) (map snd fields) (map VarN newVars)
137+ cs <- Monad.zipWithM (constrain env) (map snd fields) (map VarN newVars)
131−
138+
132− return $ cOld /\ ex newVars (CAnd (cNew : cs))
139+ return $ cOld /\ ex newVars (CAnd (cNew : cs))
133−
140+
134− E.Record fields ->
141+ E.Record fields ->
135− do vars <- Monad.forM fields (\_ -> mkVar Nothing)
142+ do vars <- Monad.forM fields (\_ -> mkVar Nothing)
136− fieldCons <-
143+ fieldCons <-
137− Monad.zipWithM
144+ Monad.zipWithM
138− (constrain env)
145+ (constrain env)
139− (map snd fields)
146+ (map snd fields)
140− (map VarN vars)
147+ (map VarN vars)
141− let fields' = Map.fromList (zip (map fst fields) (map VarN vars))
148+ let fields' = Map.fromList (zip (map fst fields) (map VarN vars))
142− let recordType = record fields' (TermN EmptyRecord1)
149+ let recordType = record fields' (TermN EmptyRecord1)
143− return (ex vars (CAnd (fieldCons ++ [CEqual Error.Record region recordType tipe])))
150+ return (ex vars (CAnd (fieldCons ++ [CEqual Error.Record region recordType tipe])))
144−
151+
145− E.Let defs body ->
152+ E.Let defs body ->
146− do bodyCon <- constrain env body tipe
153+ do bodyCon <- constrain env body tipe
147−
154+
148− (Info schemes rqs fqs headers c2 c1) <-
155+ (Info schemes rqs fqs headers c2 c1) <-
149− Monad.foldM
156+ Monad.foldM
150− (constrainDef env)
157+ (constrainDef env)
151− (Info [] [] [] Map.empty CTrue CTrue)
158+ (Info [] [] [] Map.empty CTrue CTrue)
152− (concatMap expandPattern defs)
159+ (concatMap expandPattern defs)
153−
160+
154− let letScheme =
161+ let letScheme =
155− [ Scheme rqs fqs (CLet [monoscheme headers] c2) headers ]
162+ [ Scheme rqs fqs (CLet [monoscheme headers] c2) headers ]
156−
163+
157− return $ CLet schemes (CLet letScheme (c1 /\ bodyCon))
164+ return $ CLet schemes (CLet letScheme (c1 /\ bodyCon))
158−
165+
159− E.Port impl ->
166+ E.Port impl ->
160− case impl of
167+ case impl of
161− E.In _ _ ->
168+ E.In _ _ ->
162− return CTrue
169+ return CTrue
163−
170+
164− E.Out _ expr _ ->
171+ E.Out _ expr _ ->
165− constrain env expr tipe
172+ constrain env expr tipe
166−
173+
167− E.Task _ expr _ ->
174+ E.Task _ expr _ ->
168− constrain env expr tipe
175+ constrain env expr tipe
176+
169
177
170
178
171-- CONSTRAIN APP
179-- CONSTRAIN APP
172
180
181+
173constrainApp
182constrainApp
174 :: Env.Environment
183 :: Env.Environment
175 -> R.Region
184 -> R.Region
@@ -250,9 +259,9 @@ argConstraints env name region totalArgs overallVar index args =
250
259
251
260
252
261
253−
254-- CONSTRAIN BINOP
262-- CONSTRAIN BINOP
255
263
264+
256constrainBinop
265constrainBinop
257 :: Env.Environment
266 :: Env.Environment
258 -> R.Region
267 -> R.Region
@@ -285,8 +294,10 @@ constrainBinop env region op leftExpr@(A.A leftRegion _) rightExpr@(A.A rightReg
285 ]
294 ]
286
295
287
296
297+
288-- CONSTRAIN LISTS
298-- CONSTRAIN LISTS
289
299
300+
290constrainList
301constrainList
291 :: Env.Environment
302 :: Env.Environment
292 -> R.Region
303 -> R.Region
@@ -310,8 +321,10 @@ constrainList env region exprs tipe =
310 CEqual Error.List region (Env.getType env "List" <| VarN var) tipe
321 CEqual Error.List region (Env.getType env "List" <| VarN var) tipe
311
322
312
323
324+
313-- CONSTRAIN IF EXPRESSIONS
325-- CONSTRAIN IF EXPRESSIONS
314
326
327+
315constrainIf
328constrainIf
316 :: Env.Environment
329 :: Env.Environment
317 -> R.Region
330 -> R.Region
@@ -367,8 +380,10 @@ constrainIf env region branches finally tipe =
367 CEqual Error.If region (VarN var) tipe
380 CEqual Error.If region (VarN var) tipe
368
381
369
382
383+
370-- CONSTRAIN CASE EXPRESSIONS
384-- CONSTRAIN CASE EXPRESSIONS
371
385
386+
372constrainCase
387constrainCase
373 :: Env.Environment
388 :: Env.Environment
374 -> R.Region
389 -> R.Region
@@ -400,8 +415,10 @@ constrainCase env region expr branches tipe =
400 CEqual Error.Case region tipe (VarN var)
415 CEqual Error.Case region tipe (VarN var)
401
416
402
417
418+
403-- COLLECT PAIRS
419-- COLLECT PAIRS
404
420
421+
405data Pair = Pair
422data Pair = Pair
406 { _index :: Int
423 { _index :: Int
407 , _var1 :: Variable
424 , _var1 :: Variable
@@ -423,11 +440,11 @@ pairCons region pairHint varToCon items =
423 in
440 in
424 case collectPairs 2 items of
441 case collectPairs 2 items of
425 Nothing ->
442 Nothing ->
426− do var <- mkVar Nothing
443+ do var <- mkVar Nothing
427− return ([var], [varToCon var])
444+ return ([var], [varToCon var])
428
445
429 Just (pairs, var) ->
446 Just (pairs, var) ->
430− return (map fst items, map pairToCon pairs ++ [varToCon var])
447+ return (map fst items, map pairToCon pairs ++ [varToCon var])
431
448
432
449
433collectPairs :: Int -> [(Variable, R.Region)] -> Maybe ([Pair], Variable)
450collectPairs :: Int -> [(Variable, R.Region)] -> Maybe ([Pair], Variable)
@@ -444,11 +461,15 @@ collectPairs index items =
444 return (Pair index var var' region : pairs, summaryVar)
461 return (Pair index var var' region : pairs, summaryVar)
445
462
446
463
464+
447-- EXPAND PATTERNS
465-- EXPAND PATTERNS
448
466
467+
449expandPattern :: Canonical.Def -> [Canonical.Def]
468expandPattern :: Canonical.Def -> [Canonical.Def]
450expandPattern def@(Canonical.Definition facts lpattern expr maybeType) =
469expandPattern def@(Canonical.Definition facts lpattern expr maybeType) =
470+ let
451− let (A.A patternRegion pattern) = lpattern
471+ (A.A patternRegion pattern) =
472+ lpattern
452 in
473 in
453 case pattern of
474 case pattern of
454 P.Var _ ->
475 P.Var _ ->
@@ -476,8 +497,10 @@ expandPattern def@(Canonical.Definition facts lpattern expr maybeType) =
476 Canonical.Definition facts (pvar name) (A.A patternRegion extract) Nothing
497 Canonical.Definition facts (pvar name) (A.A patternRegion extract) Nothing
477
498
478
499
500+
479-- CONSTRAIN DEFINITIONS
501-- CONSTRAIN DEFINITIONS
480
502
503+
481data Info = Info
504data Info = Info
482 { iSchemes :: [TypeScheme]
505 { iSchemes :: [TypeScheme]
483 , iRigid :: [Variable]
506 , iRigid :: [Variable]