git.iko.soy/elk
on b5df201 help sign in
elk/src/Type/Constrain/Module.hs
190 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 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 zero tipe)
85 CLet (Map.elems vars) [] header CTrue <$> makeConstraint
88{-# NOINLINE zero #-}
89zero :: R.Region
90zero =
91 R.Region (R.Position 0 0) (R.Position 0 0)
95-- EFFECT MANAGER HELPERS
98letCmd :: ModuleName.Canonical -> N.Name -> Constraint -> IO Constraint
99letCmd home tipe constraint =
100 do msgVar <- mkFlexVar
101 let msg = VarN msgVar
102 let cmdType = FunN (AppN home tipe [msg]) (AppN ModuleName.cmd N.cmd [msg])
103 let header = Map.singleton "command" (A.At zero cmdType)
104 return $ CLet [msgVar] [] header CTrue constraint
107letSub :: ModuleName.Canonical -> N.Name -> Constraint -> IO Constraint
108letSub home tipe constraint =
109 do msgVar <- mkFlexVar
110 let msg = VarN msgVar
111 let subType = FunN (AppN home tipe [msg]) (AppN ModuleName.sub N.sub [msg])
112 let header = Map.singleton "subscription" (A.At zero subType)
113 return $ CLet [msgVar] [] header CTrue constraint
116constrainEffects :: ModuleName.Canonical -> R.Region -> R.Region -> R.Region -> Can.Manager -> IO Constraint
117constrainEffects home r0 r1 r2 manager =
118 do s0 <- mkFlexVar
119 s1 <- mkFlexVar
120 s2 <- mkFlexVar
121 m1 <- mkFlexVar
122 m2 <- mkFlexVar
123 sm1 <- mkFlexVar
124 sm2 <- mkFlexVar
126 let state0 = VarN s0
127 let state1 = VarN s1
128 let state2 = VarN s2
129 let msg1 = VarN m1
130 let msg2 = VarN m2
131 let self1 = VarN sm1
132 let self2 = VarN sm2
134 let onSelfMsg = router msg2 self2 ==> self2 ==> state2 ==> task state2
135 let onEffects =
136 case manager of
137 Can.Cmd cmd -> router msg1 self1 ==> effectList home cmd msg1 ==> state1 ==> task state1
138 Can.Sub sub -> router msg1 self1 ==> effectList home sub msg1 ==> state1 ==> task state1
139 Can.Fx cmd sub -> router msg1 self1 ==> effectList home cmd msg1 ==> effectList home sub msg1 ==> state1 ==> task state1
141 let effectCons =
142 CAnd
143 [ CLocal r0 "init" (E.NoExpectation (task state0))
144 , CLocal r1 "onEffects" (E.NoExpectation onEffects)
145 , CLocal r2 "onSelfMsg" (E.NoExpectation onSelfMsg)
146 , CEqual r1 E.Effects state0 (E.NoExpectation state1)
147 , CEqual r2 E.Effects state0 (E.NoExpectation state2)
148 , CEqual r2 E.Effects self1 (E.NoExpectation self2)
149 ]
151 CLet [] [s0,s1,s2,m1,m2,sm1,sm2] Map.empty effectCons <$>
152 case manager of
153 Can.Cmd cmd ->
154 checkMap "cmdMap" home cmd CSaveTheEnvironment
156 Can.Sub sub ->
157 checkMap "subMap" home sub CSaveTheEnvironment
159 Can.Fx cmd sub ->
160 checkMap "cmdMap" home cmd =<<
161 checkMap "subMap" home sub CSaveTheEnvironment
164effectList :: ModuleName.Canonical -> N.Name -> Type -> Type
165effectList home name msg =
166 AppN ModuleName.list N.list [AppN home name [msg]]
169task :: Type -> Type
170task answer =
171 AppN ModuleName.platform N.task [ never, answer ]
174router :: Type -> Type -> Type
175router msg self =
176 AppN ModuleName.platform N.router [ msg, self ]
179checkMap :: N.Name -> ModuleName.Canonical -> N.Name -> Constraint -> IO Constraint
180checkMap name home tipe constraint =
181 do a <- mkFlexVar
182 b <- mkFlexVar
183 let mapType = toMapType home tipe (VarN a) (VarN b)
184 let mapCon = CLocal zero name (E.NoExpectation mapType)
185 return $ CLet [a,b] [] Map.empty mapCon constraint
188toMapType :: ModuleName.Canonical -> N.Name -> Type -> Type -> Type
189toMapType home tipe a b =
190 (a ==> b) ==> AppN home tipe [a] ==> AppN home tipe [b]