git.iko.soy/elk
on master help sign in
Get Type.Constrain.Module working

This organizes all the constraints from the value declarations and the ports/effects in the module. It seems like having the Type.Inference module is kind of pointless now, since all it would hold is something like: Solver.run =<< Module.constrain modul Which does not really deserve a whole file.

commit7c33c1342d3ebb030cccc744a69c7ac1e0c70322 authorEvan Czaplicki <evancz@users.noreply.github.com> dateTue 21 Nov 2017, 14:16 (9 years ago) parent8b03cb7
10 files changed+175−276
compare with master
unifiedsplit
src/AST/Canonical.hs+3−3 src/Canonicalize/Effects.hs+3−3 src/Canonicalize/Module.hs+2−2 src/Type/Constrain/Effects.hs−136 src/Type/Constrain/Expression.hs+2 src/Type/Constrain/Module.hs+155 src/Type/Constraint.hs+1 src/Type/Inference.hs−128 src/Type/Solve.hs+3−3 src/Type/Type.hs+6−1
src/AST/Canonical.hs+3−3
@@ -178,7 +178,7 @@ data AliasType
178178
179179data Decls
180180 = Declare Def Decls
181− | DeclareRec Def [Def] Decls
181+ | DeclareRec [Def] Decls
182182 | SaveTheEnvironment
183183
184184
@@ -244,8 +244,8 @@ data Effects
244244
245245
246246data Port
247− = Incoming Type
248− | Outgoing Type
247+ = Incoming FreeVars Type
248+ | Outgoing FreeVars Type
249249
250250
251251data Manager
src/Canonicalize/Effects.hs+3−3
@@ -78,7 +78,7 @@ canonicalize env decls unions effects =
7878
7979canonicalizePort :: Env.Env -> Valid.Port -> Result (N.Name, Can.Port)
8080canonicalizePort env (Valid.Port (A.At region portName) tipe) =
81− do ctipe <- Type.canonicalize env tipe
81+ do (Can.Forall freeVars ctipe) <- Type.toAnnotation env tipe
8282 case Type.deepDealias ctipe of
8383 Can.TLambda outgoingType (Can.TType home name [Can.TVar _])
8484 | home == ModuleName.cmd && name == "Cmd" ->
@@ -87,7 +87,7 @@ canonicalizePort env (Valid.Port (A.At region portName) tipe) =
8787 Result.throw region (Error.PortPayloadInvalid portName badType err)
8888
8989 Right () ->
90− Result.ok (portName, Can.Outgoing ctipe)
90+ Result.ok (portName, Can.Outgoing freeVars ctipe)
9191
9292 Can.TLambda (Can.TLambda incomingType (Can.TVar msg1)) (Can.TType home name [Can.TVar msg2])
9393 | home == ModuleName.sub && name == "Sub" && msg1 == msg2 ->
@@ -96,7 +96,7 @@ canonicalizePort env (Valid.Port (A.At region portName) tipe) =
9696 Result.throw region (Error.PortPayloadInvalid portName badType err)
9797
9898 Right () ->
99− Result.ok (portName, Can.Incoming ctipe)
99+ Result.ok (portName, Can.Incoming freeVars ctipe)
100100
101101 _ ->
102102 Result.throw region (Error.PortTypeInvalid portName ctipe)
src/Canonicalize/Module.hs+2−2
@@ -156,9 +156,9 @@ detectCycles sccs =
156156 Graph.CyclicSCC [] ->
157157 detectCycles otherSccs
158158
159− Graph.CyclicSCC (def:defs) ->
159+ Graph.CyclicSCC cyclicDefs@(def:defs) ->
160160 do detectBadCycles def defs
161− Can.DeclareRec def defs <$> detectCycles otherSccs
161+ Can.DeclareRec cyclicDefs <$> detectCycles otherSccs
162162
163163
164164toNode :: Env.Env -> A.Located Valid.Decl -> Result (Can.Def, N.Name, [N.Name])
src/Type/Constrain/Effects.hsdeleted−136
@@ -1,136 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Type.Constrain.Effects
4− ( constrain
5− )
6− where
7−
8−
9−import Control.Monad (replicateM)
10−import qualified Data.Map.Strict as Map
11−
12−import qualified AST.Canonical as Can
13−import qualified AST.Module.Name as ModuleName
14−import qualified AST.Type as T
15−import qualified Elm.Name as N
16−import qualified Reporting.Error.Type as Error
17−import qualified Reporting.Region as R
18−import Type.Constraint (Constraint(..), Scheme(Scheme))
19−import qualified Type.Instantiate as Instantiate
20−import Type.Type (Type(..), Variable, (==>), mkFlexVar)
21−
22−
23−
24−-- CONSTRAIN
25−
26−
27−constrain :: ModuleName.Canonical -> Can.Effects -> IO ( Map.Map N.Name Type, Constraint )
28−constrain home effects =
29− case effects of
30− Can.NoEffects ->
31− return (Map.empty, CSaveEnv)
32−
33− Can.Ports ports ->
34− (,)
35− <$> traverse fromSrcType (Map.map deport ports)
36− <*> return CSaveEnv
37−
38− Can.Manager r0 r1 r2 manager ->
39− case manager of
40− Can.Cmd cmdName ->
41− do cmd <- command home cmdName
42− con <- constrainEffects r0 r1 r2 $ \msg result ->
43− effectList home cmdName msg ==> result
44− return (Map.singleton "command" cmd, con)
45−
46− Can.Sub subName ->
47− do sub <- subscription home subName
48− con <- constrainEffects r0 r1 r2 $ \msg result ->
49− effectList home subName msg ==> result
50− return (Map.singleton "subscription" sub, con)
51−
52− Can.Fx cmdName subName ->
53− do cmd <- command home cmdName
54− sub <- subscription home subName
55− con <- constrainEffects r0 r1 r2 $ \msg result ->
56− effectList home cmdName msg ==> effectList home subName msg ==> result
57− return (Map.fromList [("command", cmd),("subscription", sub)], con)
58−
59−
60−
61−-- HELPERS
62−
63−
64−deport :: Can.Port -> T.Canonical
65−deport port_ =
66− case port_ of
67− Can.Incoming tipe ->
68− tipe
69−
70− Can.Outgoing tipe ->
71− tipe
72−
73−
74−fromSrcType :: T.Canonical -> IO Type
75−fromSrcType tipe =
76− fst <$> Instantiate.flexible tipe
77−
78−
79−command :: ModuleName.Canonical -> N.Name -> IO Type
80−command home typeName =
81− fromSrcType $
82− T.Lambda
83− (T.Type home typeName [T.Var "msg"])
84− (T.Type ModuleName.cmd N.cmd [T.Var "msg"])
85−
86−
87−subscription :: ModuleName.Canonical -> N.Name -> IO Type
88−subscription home typeName =
89− fromSrcType $
90− T.Lambda
91− (T.Type home typeName [T.Var "msg"])
92− (T.Type ModuleName.sub N.sub [T.Var "msg"])
93−
94−
95−
96−-- CONSTRAINTS FOR EFFECT MANAGER STUFF
97−
98−
99−constrainEffects :: R.Region -> R.Region -> R.Region -> (Variable -> Type -> Type) -> IO Constraint
100−constrainEffects r0 r1 r2 toFinalArgs =
101− let
102− task t =
103− AppN ModuleName.platform N.task [ never, VarN t ]
104−
105− router msg selfMsg =
106− AppN ModuleName.platform N.router [ VarN msg, VarN selfMsg ]
107− in
108− do vars@[v0,v1,v2,s0,s1,s2,msg1,msg2,selfMsg1,selfMsg2] <- replicateM 10 mkFlexVar
109−
110− let
111− onEffectsType = router msg1 selfMsg1 ==> toFinalArgs msg1 (VarN s1 ==> task s1)
112− onSelfMsgType = router msg2 selfMsg2 ==> VarN selfMsg2 ==> VarN s2 ==> task s2
113− constrains =
114− [ CInstance r0 "init" (VarN v0)
115− , CInstance r1 "onEffects" (VarN v1)
116− , CInstance r2 "onSelfMsg" (VarN v2)
117− , CEqual (Error.Manager "init") r0 (VarN v0) (task s0)
118− , CEqual (Error.Manager "onEffects") r1 (VarN v1) onEffectsType
119− , CEqual (Error.Manager "onSelfMsg") r2 (VarN v2) onSelfMsgType
120− , CEqual (Error.State "onEffects") r1 (VarN s0) (VarN s1)
121− , CEqual (Error.State "onSelfMsg") r2 (VarN s0) (VarN s2)
122− , CEqual Error.SelfMsg r2 (VarN selfMsg1) (VarN selfMsg2)
123− ]
124−
125− return $ CLet [ Scheme [] vars Map.empty (CAnd constrains) ] CSaveEnv
126−
127−
128−{-# NOINLINE never #-}
129−never :: Type
130−never =
131− AppN ModuleName.basics "Never" []
132−
133−
134−effectList :: ModuleName.Canonical -> N.Name -> Variable -> Type
135−effectList home name msg =
136− AppN ModuleName.list N.list [AppN home name [VarN msg]]
src/Type/Constrain/Expression.hs+2
@@ -1,6 +1,8 @@
11{-# OPTIONS_GHC -Wall #-}
22module Type.Constrain.Expression
33 ( constrain
4+ , constrainDef
5+ , constrainRecursiveDefs
46 )
57 where
68
src/Type/Constrain/Module.hsnew file+155
@@ -0,0 +1,155 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Type.Constrain.Module
4+ ( constrain
5+ )
6+ where
7+
8+
9+import Control.Monad (replicateM)
10+import qualified Data.Map.Strict as Map
11+
12+import qualified AST.Canonical as Can
13+import qualified AST.Module.Name as ModuleName
14+import qualified Elm.Name as N
15+import qualified Reporting.Annotation as A
16+import qualified Reporting.Region as R
17+import Type.Constraint
18+import qualified Type.Constrain.Expression as Expr
19+import qualified Type.Instantiate as Instantiate
20+import Type.Type (Type(..), Variable, (==>), mkFlexVar, never)
21+
22+
23+
24+-- CONSTRAIN
25+
26+
27+constrain :: Can.Module -> IO Constraint
28+constrain (Can.Module home _ _ decls _ _ _ effects) =
29+ case effects of
30+ Can.NoEffects ->
31+ constrainDecls CSaveTheEnvironment decls
32+
33+ Can.Ports ports ->
34+ do header <- traverse portToHeader ports
35+ CLet [] [] header CTrue
36+ <$> constrainDecls CSaveTheEnvironment decls
37+
38+ Can.Manager r0 r1 r2 manager ->
39+ case manager of
40+ Can.Cmd cmdName ->
41+ do header <- mkCmd home cmdName
42+ fxCon <- constrainEffects r0 r1 r2 $ \msg result ->
43+ effectList home cmdName msg ==> result
44+ CLet [] [] header CTrue <$> constrainDecls fxCon decls
45+
46+ Can.Sub subName ->
47+ do header <- mkSub home subName
48+ fxCon <- constrainEffects r0 r1 r2 $ \msg result ->
49+ effectList home subName msg ==> result
50+ CLet [] [] header CTrue <$> constrainDecls fxCon decls
51+
52+ Can.Fx cmdName subName ->
53+ do header <- Map.union <$> mkCmd home cmdName <*> mkSub home subName
54+ fxCon <- constrainEffects r0 r1 r2 $ \msg result ->
55+ effectList home cmdName msg ==> effectList home subName msg ==> result
56+ CLet [] [] header CTrue <$> constrainDecls fxCon decls
57+
58+
59+
60+-- CONSTRAIN DECLARATIONS
61+
62+
63+constrainDecls :: Constraint -> Can.Decls -> IO Constraint
64+constrainDecls finalConstraint decls =
65+ case decls of
66+ Can.Declare def otherDecls ->
67+ Expr.constrainDef Map.empty def
68+ =<< constrainDecls finalConstraint otherDecls
69+
70+ Can.DeclareRec defs otherDecls ->
71+ Expr.constrainRecursiveDefs Map.empty defs
72+ =<< constrainDecls finalConstraint otherDecls
73+
74+ Can.SaveTheEnvironment ->
75+ return finalConstraint
76+
77+
78+
79+-- PORT HELPERS
80+
81+
82+portToHeader :: Can.Port -> IO (A.Located Type)
83+portToHeader port_ =
84+ case port_ of
85+ Can.Incoming freeVars tipe ->
86+ do vars <- traverse (\_ -> VarN <$> mkFlexVar) freeVars
87+ A.At zero <$> Instantiate.fromSrcType vars tipe
88+
89+ Can.Outgoing freeVars tipe ->
90+ do vars <- traverse (\_ -> VarN <$> mkFlexVar) freeVars
91+ A.At zero <$> Instantiate.fromSrcType vars tipe
92+
93+
94+{-# NOINLINE zero #-}
95+zero :: R.Region
96+zero =
97+ R.Region (R.Position 0 0) (R.Position 0 0)
98+
99+
100+
101+-- EFFECT MANAGER HELPERS
102+
103+
104+mkCmd :: ModuleName.Canonical -> N.Name -> IO (Map.Map N.Name (A.Located Type))
105+mkCmd home typeName =
106+ do msg <- VarN <$> mkFlexVar
107+ return $ Map.singleton "command" $ A.At zero $
108+ FunN (AppN home typeName [msg]) (AppN ModuleName.cmd N.cmd [msg])
109+
110+
111+mkSub :: ModuleName.Canonical -> N.Name -> IO (Map.Map N.Name (A.Located Type))
112+mkSub home typeName =
113+ do msg <- VarN <$> mkFlexVar
114+ return $ Map.singleton "subscription" $ A.At zero $
115+ FunN (AppN home typeName [msg]) (AppN ModuleName.sub N.sub [msg])
116+
117+
118+constrainEffects
119+ :: R.Region
120+ -> R.Region
121+ -> R.Region
122+ -> (Variable -> Type -> Type)
123+ -> IO Constraint
124+constrainEffects r0 r1 r2 toFinalArgs =
125+ let
126+ task t =
127+ AppN ModuleName.platform N.task [ never, VarN t ]
128+
129+ router msg selfMsg =
130+ AppN ModuleName.platform N.router [ VarN msg, VarN selfMsg ]
131+
132+ equal region var tipe =
133+ CEqual region Effects (VarN var) (NoExpectation tipe)
134+ in
135+ do vars@[s0,s1,s2,msg1,msg2,selfMsg1,selfMsg2] <- replicateM 7 mkFlexVar
136+ return $
137+ CLet [] vars Map.empty
138+ (CAnd
139+ [ CLookup r0 "init" $ NoExpectation $
140+ task s0
141+ , CLookup r1 "onEffects" $ NoExpectation $
142+ router msg1 selfMsg1 ==> toFinalArgs msg1 (VarN s1 ==> task s1)
143+ , CLookup r2 "onSelfMsg" $ NoExpectation $
144+ router msg2 selfMsg2 ==> VarN selfMsg2 ==> VarN s2 ==> task s2
145+ , equal r1 s0 (VarN s1)
146+ , equal r2 s0 (VarN s2)
147+ , equal r2 selfMsg1 (VarN selfMsg2)
148+ ]
149+ )
150+ CSaveTheEnvironment
151+
152+
153+effectList :: ModuleName.Canonical -> N.Name -> Variable -> Type
154+effectList home name msg =
155+ AppN ModuleName.list N.list [AppN home name [VarN msg]]
src/Type/Constraint.hs+1
@@ -112,6 +112,7 @@ data Category
112112 | Tuple
113113 | Unit
114114 | Shader
115+ | Effects
115116
116117
117118
src/Type/Inference.hsdeleted−128
@@ -1,128 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Type.Inference where
3−
4−import Control.Arrow (first, second)
5−import Control.Monad.Except (Except, forM, liftIO, runExceptT, throwError)
6−import qualified Data.Map.Strict as Map
7−import qualified Data.Set as Set
8−import Data.Monoid ((<>))
9−import Data.Text (Text)
10−
11−import qualified AST.Module as Module
12−import qualified AST.Module.Name as ModuleName
13−import qualified AST.Type as Type
14−import qualified AST.Variable as Var
15−import qualified Reporting.Annotation as A
16−import qualified Reporting.Error.Type as Error
17−import qualified Type.Constraint as T
18−import qualified Type.Constrain.Expression as TcExpr
19−import qualified Type.Environment as Env
20−import qualified Type.Solve as Solve
21−import qualified Type.State as TS
22−import qualified Type.Type as T
23−
24−import System.IO.Unsafe
25− -- Maybe possible to switch over to ST instead of IO.
26− -- I don't think that'd be worthwhile though.
27−
28−
29−infer
30− :: Module.Interfaces
31− -> Module.Canonical
32− -> Except [A.Located Error.Error] (Map.Map Text Type.Canonical)
33−infer interfaces modul =
34− either throwError return $ unsafePerformIO $ runExceptT $
35− do (header, constraint) <-
36− liftIO (genConstraints interfaces modul)
37−
38− state <- Solve.solve constraint
39−
40− let header' = Map.delete "::" header
41− let types = Map.map A.drop (Map.difference (TS._savedEnv state) header')
42−
43− liftIO (traverse T.toSrcType types)
44−
45−
46−genConstraints
47− :: Module.Interfaces
48− -> Module.Canonical
49− -> IO (Map.Map Text T.Type, T.Constraint)
50−genConstraints allInterfaces modul@(Module.Module _ info) =
51− do let directDeps = toDirectDeps (Set.fromList (Module.imports info)) allInterfaces
52− let env = Env.initialize (canonicalizeUnions directDeps modul)
53−
54− ctors <-
55− {-# SCC elm_compiler_mk_ctor_types #-}
56− forM (Env.ctorNames env) $ \name ->
57− do (_, vars, args, result) <- Env.freshDataScheme env name
58− return (name, (vars, foldr T.FunN result args))
59−
60− importedVars <- mapM (canonicalizeValues env) directDeps
61−
62− let allTypes = concat (ctors : importedVars)
63− let vars = concatMap (fst . snd) allTypes
64− let header = Map.map snd (Map.fromList allTypes)
65− let environ = T.CLet [ T.Scheme vars [] T.CTrue (Map.map (A.A undefined) header) ]
66−
67− fvar <- T.mkFlexVar
68−
69− constraint <-
70− {-# SCC elm_compiler_constrain #-}
71− TcExpr.constrain env (Module.program info) (T.VarN fvar)
72−
73− return (header, environ constraint)
74−
75−
76−toDirectDeps :: Set.Set ModuleName.Raw -> Module.Interfaces -> [(ModuleName.Canonical, Module.Interface)]
77−toDirectDeps imports interfaces =
78− let
79− isDirect (ModuleName.Canonical _ name, _) =
80− Set.member name imports
81− in
82− filter isDirect (Map.toList interfaces)
83−
84−
85−canonicalizeValues
86− :: Env.Env
87− -> (ModuleName.Canonical, Module.Interface)
88− -> IO [(Text, ([T.Variable], T.Type))]
89−canonicalizeValues env (moduleName, iface) =
90− forM (Map.toList (Module.iTypes iface)) $ \(name, tipe) ->
91− do (flexType, flexVars) <- Env.instantiateFlex env tipe
92− return
93− ( ModuleName.canonicalToText moduleName <> "." <> name
94− , ( Map.elems flexVars
95− , flexType
96− )
97− )
98−
99−
100−canonicalizeUnions
101− :: [(ModuleName.Canonical, Module.Interface)]
102− -> Module.Canonical
103− -> [Module.CanonicalUnion]
104−canonicalizeUnions directDeps (Module.Module name info) =
105− localUnions ++ importedUnions
106− where
107− localUnions :: [Module.CanonicalUnion]
108− localUnions =
109− format (name, Module.unions info)
110−
111− importedUnions :: [Module.CanonicalUnion]
112− importedUnions =
113− concatMap (format . second Module.iUnions) directDeps
114−
115−
116−format :: (ModuleName.Canonical, Module.Unions) -> [Module.CanonicalUnion]
117−format (home, unions) =
118− map canonical (Map.toList unions)
119− where
120− canonical :: (Text, Module.UnionInfo Text) -> Module.CanonicalUnion
121− canonical (name, (tvars, ctors)) =
122− ( toVar name
123− , (tvars, map (first toVar) ctors)
124− )
125−
126− toVar :: Text -> Var.Canonical
127− toVar name =
128− Var.fromModule home name
src/Type/Solve.hs+3−3
@@ -24,10 +24,10 @@ import qualified Type.UnionFind as UF
2424
2525
2626
27−-- RUN
27+-- RUN SOLVER
2828
2929
30−run :: Constraint -> IO (Either [Error.Error] Env)
30+run :: Constraint -> IO (Either [Error.Error] (Map.Map N.Name Can.Type))
3131run constraint =
3232 do pools <- MVector.replicate 16 []
3333
@@ -36,7 +36,7 @@ run constraint =
3636
3737 case errors of
3838 [] ->
39− return $ Right env
39+ Right <$> traverse toSrcType env
4040
4141 _ ->
4242 return $ Left errors
src/Type/Type.hs+6−1
@@ -13,7 +13,7 @@ module Type.Type
1313 , noMark
1414 , nextMark
1515 , (==>)
16− , int, float, char, string, bool
16+ , int, float, char, string, bool, never
1717 , vec2, vec3, vec4, mat4, texture
1818 , mkFlexVar
1919 , mkFlexNumber
@@ -193,6 +193,11 @@ bool :: Type
193193bool = AppN ModuleName.basics "Bool" []
194194
195195
196+{-# NOINLINE never #-}
197+never :: Type
198+never = AppN ModuleName.basics "Never" []
199+
200+
196201
197202-- WEBGL TYPES
198203