git.iko.soy/elk
on ed80d49 help sign in
elk/src/Type/Constrain/Module.hs
191 lines 6.0 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Type.Constrain.Module
4 ( constrain
5 )
6 where
9import Control.Monad (replicateM)
10import qualified Data.Map.Strict as Map
12import qualified AST.Canonical as Can
13import qualified AST.Module.Name as ModuleName
14import qualified Elm.Name as N
15import qualified Reporting.Annotation as A
16import qualified Reporting.Region as R
17import Type.Constraint
18import qualified Type.Constrain.Expression as Expr
19import qualified Type.Instantiate as Instantiate
20import Type.Type (Type(..), Variable, (==>), mkFlexVar, never)
24-- CONSTRAIN
27constrain :: Can.Module -> IO Constraint
28constrain (Can.Module home _ _ decls _ _ _ effects) =
29 case effects of
30 Can.NoEffects ->
31 constrainDecls decls CSaveTheEnvironment
33 Can.Ports ports ->
34 Map.foldrWithKey letPort (constrainDecls decls CSaveTheEnvironment) ports
36 Can.Manager r0 r1 r2 manager ->
37 case manager of
38 Can.Cmd cmdName ->
39 letCmd home cmdName =<<
40 constrainDecls decls =<< constrainEffects home r0 r1 r2 manager
42 Can.Sub subName ->
43 letSub home subName =<<
44 constrainDecls decls =<< constrainEffects home r0 r1 r2 manager
46 Can.Fx cmdName subName ->
47 letCmd home cmdName =<<
48 letSub home subName =<<
49 constrainDecls decls =<< constrainEffects home r0 r1 r2 manager
53-- CONSTRAIN DECLARATIONS
56constrainDecls :: Can.Decls -> Constraint -> IO Constraint
57constrainDecls decls finalConstraint =
58 case decls of
59 Can.Declare def otherDecls ->
60 Expr.constrainDef Map.empty def =<< constrainDecls otherDecls finalConstraint
62 Can.DeclareRec defs otherDecls ->
63 Expr.constrainRecursiveDefs Map.empty defs =<< constrainDecls otherDecls finalConstraint
65 Can.SaveTheEnvironment ->
66 return finalConstraint
70-- PORT HELPERS
73letPort :: N.Name -> Can.Port -> IO Constraint -> IO Constraint
74letPort name port_ makeConstraint =
75 case port_ of
76 Can.Incoming freeVars srcType ->
77 do vars <- traverse (\_ -> mkFlexVar) freeVars
78 tipe <- Instantiate.fromSrcType (Map.map VarN vars) srcType
79 let header = Map.singleton name (A.At zero tipe)
80 CLet (Map.elems vars) [] header CTrue <$> makeConstraint
82 Can.Outgoing freeVars srcType ->
83 do vars <- traverse (\_ -> mkFlexVar) freeVars
84 tipe <- Instantiate.fromSrcType (Map.map VarN vars) srcType
85 let header = Map.singleton name (A.At zero tipe)
86 CLet (Map.elems vars) [] header CTrue <$> makeConstraint
89{-# NOINLINE zero #-}
90zero :: R.Region
91zero =
92 R.Region (R.Position 0 0) (R.Position 0 0)
96-- EFFECT MANAGER HELPERS
99letCmd :: ModuleName.Canonical -> N.Name -> Constraint -> IO Constraint
100letCmd home tipe constraint =
101 do msgVar <- mkFlexVar
102 let msg = VarN msgVar
103 let cmdType = FunN (AppN home tipe [msg]) (AppN ModuleName.cmd N.cmd [msg])
104 let header = Map.singleton "command" (A.At zero cmdType)
105 return $ CLet [msgVar] [] header CTrue constraint
108letSub :: ModuleName.Canonical -> N.Name -> Constraint -> IO Constraint
109letSub home tipe constraint =
110 do msgVar <- mkFlexVar
111 let msg = VarN msgVar
112 let subType = FunN (AppN home tipe [msg]) (AppN ModuleName.sub N.sub [msg])
113 let header = Map.singleton "subscription" (A.At zero subType)
114 return $ CLet [msgVar] [] header CTrue constraint
117constrainEffects :: ModuleName.Canonical -> R.Region -> R.Region -> R.Region -> Can.Manager -> IO Constraint
118constrainEffects home r0 r1 r2 manager =
119 do s0 <- mkFlexVar
120 s1 <- mkFlexVar
121 s2 <- mkFlexVar
122 m1 <- mkFlexVar
123 m2 <- mkFlexVar
124 sm1 <- mkFlexVar
125 sm2 <- mkFlexVar
127 let state0 = VarN s0
128 let state1 = VarN s1
129 let state2 = VarN s2
130 let msg1 = VarN m1
131 let msg2 = VarN m2
132 let self1 = VarN sm1
133 let self2 = VarN sm2
135 let onSelfMsg = router msg2 self2 ==> self2 ==> state2 ==> task state2
136 let onEffects =
137 case manager of
138 Can.Cmd cmd -> router msg1 self1 ==> effectList home cmd msg1 ==> state1 ==> task state1
139 Can.Sub sub -> router msg1 self1 ==> effectList home sub msg1 ==> state1 ==> task state1
140 Can.Fx cmd sub -> router msg1 self1 ==> effectList home cmd msg1 ==> effectList home sub msg1 ==> state1 ==> task state1
142 let effectCons =
143 CAnd
144 [ CLocal r0 "init" (NoExpectation (task state0))
145 , CLocal r1 "onEffects" (NoExpectation onEffects)
146 , CLocal r2 "onSelfMsg" (NoExpectation onSelfMsg)
147 , CEqual r1 Effects state0 (NoExpectation state1)
148 , CEqual r2 Effects state0 (NoExpectation state2)
149 , CEqual r2 Effects self1 (NoExpectation self2)
150 ]
152 CLet [] [s0,s1,s2,m1,m2,sm1,sm2] Map.empty effectCons <$>
153 case manager of
154 Can.Cmd cmd ->
155 checkMap "cmdMap" home cmd CSaveTheEnvironment
157 Can.Sub sub ->
158 checkMap "subMap" home sub CSaveTheEnvironment
160 Can.Fx cmd sub ->
161 checkMap "cmdMap" home cmd =<<
162 checkMap "subMap" home sub CSaveTheEnvironment
165effectList :: ModuleName.Canonical -> N.Name -> Type -> Type
166effectList home name msg =
167 AppN ModuleName.list N.list [AppN home name [msg]]
170task :: Type -> Type
171task answer =
172 AppN ModuleName.platform N.task [ never, answer ]
175router :: Type -> Type -> Type
176router msg self =
177 AppN ModuleName.platform N.router [ msg, self ]
180checkMap :: N.Name -> ModuleName.Canonical -> N.Name -> Constraint -> IO Constraint
181checkMap name home tipe constraint =
182 do a <- mkFlexVar
183 b <- mkFlexVar
184 let mapType = toMapType home tipe (VarN a) (VarN b)
185 let mapCon = CLocal zero name (NoExpectation mapType)
186 return $ CLet [a,b] [] Map.empty mapCon constraint
189toMapType :: ModuleName.Canonical -> N.Name -> Type -> Type -> Type
190toMapType home tipe a b =
191 (a ==> b) ==> AppN home tipe [a] ==> AppN home tipe [b]