git.iko.soy/elk
on 32ff950 help sign in
elk/compiler/src/Type/Constrain/Module.hs
184 lines 6.0 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Type.Constrain.Module
4 ( constrain
5 )
6 where
9import qualified Data.Map.Strict as Map
11import qualified AST.Canonical as Can
12import qualified AST.Module.Name as ModuleName
13import qualified Elm.Name as N
14import qualified Reporting.Annotation as A
15import qualified Reporting.Error.Type as E
16import qualified Reporting.Region as R
17import qualified Type.Constrain.Expression as Expr
18import qualified Type.Instantiate as Instantiate
19import Type.Type (Type(..), Constraint(..), (==>), mkFlexVar, never)
23-- CONSTRAIN
26constrain :: Can.Module -> IO Constraint
27constrain (Can.Module home _ _ decls _ _ _ effects) =
28 case effects of
29 Can.NoEffects ->
30 constrainDecls decls CSaveTheEnvironment
32 Can.Ports ports ->
33 Map.foldrWithKey letPort (constrainDecls decls CSaveTheEnvironment) ports
35 Can.Manager r0 r1 r2 manager ->
36 case manager of
37 Can.Cmd cmdName ->
38 letCmd home cmdName =<<
39 constrainDecls decls =<< constrainEffects home r0 r1 r2 manager
41 Can.Sub subName ->
42 letSub home subName =<<
43 constrainDecls decls =<< constrainEffects home r0 r1 r2 manager
45 Can.Fx cmdName subName ->
46 letCmd home cmdName =<<
47 letSub home subName =<<
48 constrainDecls decls =<< constrainEffects home r0 r1 r2 manager
52-- CONSTRAIN DECLARATIONS
55constrainDecls :: Can.Decls -> Constraint -> IO Constraint
56constrainDecls decls finalConstraint =
57 case decls of
58 Can.Declare def otherDecls ->
59 Expr.constrainDef Map.empty def =<< constrainDecls otherDecls finalConstraint
61 Can.DeclareRec defs otherDecls ->
62 Expr.constrainRecursiveDefs Map.empty defs =<< constrainDecls otherDecls finalConstraint
64 Can.SaveTheEnvironment ->
65 return finalConstraint
69-- PORT HELPERS
72letPort :: N.Name -> Can.Port -> IO Constraint -> IO Constraint
73letPort name port_ makeConstraint =
74 case port_ of
75 Can.Incoming freeVars _ srcType ->
76 do vars <- traverse (\_ -> mkFlexVar) freeVars
77 tipe <- Instantiate.fromSrcType (Map.map VarN vars) srcType
78 let header = Map.singleton name (A.At R.zero tipe)
79 CLet (Map.elems vars) [] header CTrue <$> makeConstraint
81 Can.Outgoing freeVars _ srcType ->
82 do vars <- traverse (\_ -> mkFlexVar) freeVars
83 tipe <- Instantiate.fromSrcType (Map.map VarN vars) srcType
84 let header = Map.singleton name (A.At R.zero tipe)
85 CLet (Map.elems vars) [] header CTrue <$> makeConstraint
89-- EFFECT MANAGER HELPERS
92letCmd :: ModuleName.Canonical -> N.Name -> Constraint -> IO Constraint
93letCmd home tipe constraint =
94 do msgVar <- mkFlexVar
95 let msg = VarN msgVar
96 let cmdType = FunN (AppN home tipe [msg]) (AppN ModuleName.cmd N.cmd [msg])
97 let header = Map.singleton "command" (A.At R.zero cmdType)
98 return $ CLet [msgVar] [] header CTrue constraint
101letSub :: ModuleName.Canonical -> N.Name -> Constraint -> IO Constraint
102letSub home tipe constraint =
103 do msgVar <- mkFlexVar
104 let msg = VarN msgVar
105 let subType = FunN (AppN home tipe [msg]) (AppN ModuleName.sub N.sub [msg])
106 let header = Map.singleton "subscription" (A.At R.zero subType)
107 return $ CLet [msgVar] [] header CTrue constraint
110constrainEffects :: ModuleName.Canonical -> R.Region -> R.Region -> R.Region -> Can.Manager -> IO Constraint
111constrainEffects home r0 r1 r2 manager =
112 do s0 <- mkFlexVar
113 s1 <- mkFlexVar
114 s2 <- mkFlexVar
115 m1 <- mkFlexVar
116 m2 <- mkFlexVar
117 sm1 <- mkFlexVar
118 sm2 <- mkFlexVar
120 let state0 = VarN s0
121 let state1 = VarN s1
122 let state2 = VarN s2
123 let msg1 = VarN m1
124 let msg2 = VarN m2
125 let self1 = VarN sm1
126 let self2 = VarN sm2
128 let onSelfMsg = router msg2 self2 ==> self2 ==> state2 ==> task state2
129 let onEffects =
130 case manager of
131 Can.Cmd cmd -> router msg1 self1 ==> effectList home cmd msg1 ==> state1 ==> task state1
132 Can.Sub sub -> router msg1 self1 ==> effectList home sub msg1 ==> state1 ==> task state1
133 Can.Fx cmd sub -> router msg1 self1 ==> effectList home cmd msg1 ==> effectList home sub msg1 ==> state1 ==> task state1
135 let effectCons =
136 CAnd
137 [ CLocal r0 "init" (E.NoExpectation (task state0))
138 , CLocal r1 "onEffects" (E.NoExpectation onEffects)
139 , CLocal r2 "onSelfMsg" (E.NoExpectation onSelfMsg)
140 , CEqual r1 E.Effects state0 (E.NoExpectation state1)
141 , CEqual r2 E.Effects state0 (E.NoExpectation state2)
142 , CEqual r2 E.Effects self1 (E.NoExpectation self2)
143 ]
145 CLet [] [s0,s1,s2,m1,m2,sm1,sm2] Map.empty effectCons <$>
146 case manager of
147 Can.Cmd cmd ->
148 checkMap "cmdMap" home cmd CSaveTheEnvironment
150 Can.Sub sub ->
151 checkMap "subMap" home sub CSaveTheEnvironment
153 Can.Fx cmd sub ->
154 checkMap "cmdMap" home cmd =<<
155 checkMap "subMap" home sub CSaveTheEnvironment
158effectList :: ModuleName.Canonical -> N.Name -> Type -> Type
159effectList home name msg =
160 AppN ModuleName.list N.list [AppN home name [msg]]
163task :: Type -> Type
164task answer =
165 AppN ModuleName.platform N.task [ never, answer ]
168router :: Type -> Type -> Type
169router msg self =
170 AppN ModuleName.platform N.router [ msg, self ]
173checkMap :: N.Name -> ModuleName.Canonical -> N.Name -> Constraint -> IO Constraint
174checkMap name home tipe constraint =
175 do a <- mkFlexVar
176 b <- mkFlexVar
177 let mapType = toMapType home tipe (VarN a) (VarN b)
178 let mapCon = CLocal R.zero name (E.NoExpectation mapType)
179 return $ CLet [a,b] [] Map.empty mapCon constraint
182toMapType :: ModuleName.Canonical -> N.Name -> Type -> Type -> Type
183toMapType home tipe a b =
184 (a ==> b) ==> AppN home tipe [a] ==> AppN home tipe [b]