git.iko.soy/elk
on master help sign in
Update to use canonical variables
d99e412Evan Czaplicki
compiler/Type/Constrain/Expression.hs+13−9
compare with master
unifiedsplit
@@ -11,6 +11,7 @@ import qualified Text.PrettyPrint as PP
11import AST.Literal as Lit
11import AST.Literal as Lit
12import AST.Annotation as Ann
12import AST.Annotation as Ann
13import AST.Expression.General
13import AST.Expression.General
14+import qualified AST.Expression.Canonical as Canonical
14import qualified AST.Pattern as P
15import qualified AST.Pattern as P
15import qualified AST.Type as ST
16import qualified AST.Type as ST
16import qualified AST.Variable as V
17import qualified AST.Variable as V
@@ -20,7 +21,8 @@ import qualified Type.Environment as Env
20import qualified Type.Constrain.Literal as Literal
21import qualified Type.Constrain.Literal as Literal
21import qualified Type.Constrain.Pattern as Pattern
22import qualified Type.Constrain.Pattern as Pattern
22
23
23−constrain :: Env.Environment -> Expr -> Type -> ErrorT [PP.Doc] IO TypeConstraint
24+constrain :: Env.Environment -> Canonical.Expr -> Type
25+ -> ErrorT [PP.Doc] IO TypeConstraint
24constrain env (A region expr) tipe =
26constrain env (A region expr) tipe =
25 let list t = Env.get env Env.types "_List" <| t
27 let list t = Env.get env Env.types "_List" <| t
26 and = A region . CAnd
28 and = A region . CAnd
@@ -48,9 +50,11 @@ constrain env (A region expr) tipe =
48 varying = makeRec Lit.varying (TermN EmptyRecord1)
50 varying = makeRec Lit.varying (TermN EmptyRecord1)
49 in return . A region $ CEqual tipe (shaderTipe attribute uniform varying)
51 in return . A region $ CEqual tipe (shaderTipe attribute uniform varying)
50
52
51− Var (V.Raw name)
53+ Var var
52 | name == saveEnvName -> return (A region CSaveEnv)
54 | name == saveEnvName -> return (A region CSaveEnv)
53 | otherwise -> return (name <? tipe)
55 | otherwise -> return (name <? tipe)
56+ where
57+ name = V.toString var
54
58
55 Range lo hi ->
59 Range lo hi ->
56 existsNumber $ \n -> do
60 existsNumber $ \n -> do
@@ -68,7 +72,7 @@ constrain env (A region expr) tipe =
68 exists $ \t2 -> do
72 exists $ \t2 -> do
69 c1 <- constrain env e1 t1
73 c1 <- constrain env e1 t1
70 c2 <- constrain env e2 t2
74 c2 <- constrain env e2 t2
71− return $ and [ c1, c2, op <? (t1 ==> t2 ==> tipe) ]
75+ return $ and [ c1, c2, V.toString op <? (t1 ==> t2 ==> tipe) ]
72
76
73 Lambda p e ->
77 Lambda p e ->
74 exists $ \t1 ->
78 exists $ \t1 ->
@@ -169,7 +173,7 @@ constrain env (A region expr) tipe =
169 PortOut _ _ signal ->
173 PortOut _ _ signal ->
170 constrain env signal tipe
174 constrain env signal tipe
171
175
172−constrainDef env info (Definition pattern expr maybeTipe) =
176+constrainDef env info (Canonical.Definition pattern expr maybeTipe) =
173 let qs = [] -- should come from the def, but I'm not sure what would live there...
177 let qs = [] -- should come from the def, but I'm not sure what would live there...
174 (schemes, rigidQuantifiers, flexibleQuantifiers, headers, c2, c1) = info
178 (schemes, rigidQuantifiers, flexibleQuantifiers, headers, c2, c1) = info
175 in
179 in
@@ -208,16 +212,16 @@ constrainDef env info (Definition pattern expr maybeTipe) =
208
212
209 _ -> error (show pattern)
213 _ -> error (show pattern)
210
214
211−expandPattern :: Def -> [Def]
215+expandPattern :: Canonical.Def -> [Canonical.Def]
212−expandPattern def@(Definition pattern lexpr@(A r _) maybeType) =
216+expandPattern def@(Canonical.Definition pattern lexpr@(A r _) maybeType) =
213 case pattern of
217 case pattern of
214 P.Var _ -> [def]
218 P.Var _ -> [def]
215− _ -> Definition (P.Var x) lexpr maybeType : map toDef vars
219+ _ -> Canonical.Definition (P.Var x) lexpr maybeType : map toDef vars
216 where
220 where
217 vars = P.boundVarList pattern
221 vars = P.boundVarList pattern
218 x = "$" ++ concat vars
222 x = "$" ++ concat vars
219− mkVar = A r . rawVar
223+ mkVar = A r . localVar
220− toDef y = Definition (P.Var y) (A r $ Case (mkVar x) [(pattern, mkVar y)]) Nothing
224+ toDef y = Canonical.Definition (P.Var y) (A r $ Case (mkVar x) [(pattern, mkVar y)]) Nothing
221
225
222try :: Region -> ErrorT (Region -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a
226try :: Region -> ErrorT (Region -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a
223try region computation = do
227try region computation = do
compiler/Type/Constrain/Pattern.hs+5−3
@@ -11,6 +11,7 @@ import qualified Text.PrettyPrint as PP
11
11
12import qualified AST.Annotation as A
12import qualified AST.Annotation as A
13import qualified AST.Pattern as P
13import qualified AST.Pattern as P
14+import qualified AST.Variable as V
14import AST.PrettyPrint (pretty)
15import AST.PrettyPrint (pretty)
15import Type.Type
16import Type.Type
16import Type.Fragment
17import Type.Fragment
@@ -18,7 +19,8 @@ import Type.Environment as Env
18import qualified Type.Constrain.Literal as Literal
19import qualified Type.Constrain.Literal as Literal
19
20
20
21
22+constrain :: Environment -> P.CanonicalPattern -> Type
21−constrain :: Environment -> P.Pattern -> Type -> ErrorT (A.Region -> PP.Doc) IO Fragment
23+ -> ErrorT (A.Region -> PP.Doc) IO Fragment
22constrain env pattern tipe =
24constrain env pattern tipe =
23 let region = A.None (pretty pattern)
25 let region = A.None (pretty pattern)
24 t1 === t2 = A.A region (CEqual t1 t2)
26 t1 === t2 = A.A region (CEqual t1 t2)
@@ -47,8 +49,8 @@ constrain env pattern tipe =
47 }
49 }
48
50
49 P.Data name patterns -> do
51 P.Data name patterns -> do
50− (kind, cvars, args, result) <- liftIO $ freshDataScheme env name
52+ (kind, cvars, args, result) <- liftIO $ freshDataScheme env (V.toString name)
51− let msg = concat [ "Constructor '", name, "' expects ", show kind
53+ let msg = concat [ "Constructor '", V.toString name, "' expects ", show kind
52 , " argument", if kind == 1 then "" else "s"
54 , " argument", if kind == 1 then "" else "s"
53 , " but was given ", show (length patterns), "." ]
55 , " but was given ", show (length patterns), "." ]
54 err span = PP.vcat [ PP.text $ "Type error " ++ show span
56 err span = PP.vcat [ PP.text $ "Type error " ++ show span