git.iko.soy/elk
on 1238607 help sign in
elk/compiler/src/Type/Constrain/Module.hs
183 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
10import qualified Data.Name as Name
12import qualified AST.Canonical as Can
13import qualified Elm.ModuleName as ModuleName
14import qualified Reporting.Annotation as A
15import qualified Reporting.Error.Type as E
16import qualified Type.Constrain.Expression as Expr
17import qualified Type.Instantiate as Instantiate
18import Type.Type (Type(..), Constraint(..), (==>), mkFlexVar, nameToRigid, never)
22-- CONSTRAIN
25constrain :: Can.Module -> IO Constraint
26constrain (Can.Module home _ decls _ _ _ effects) =
27 case effects of
28 Can.NoEffects ->
29 constrainDecls decls CSaveTheEnvironment
31 Can.Ports ports ->
32 Map.foldrWithKey letPort (constrainDecls decls CSaveTheEnvironment) ports
34 Can.Manager r0 r1 r2 manager ->
35 case manager of
36 Can.Cmd cmdName ->
37 letCmd home cmdName =<<
38 constrainDecls decls =<< constrainEffects home r0 r1 r2 manager
40 Can.Sub subName ->
41 letSub home subName =<<
42 constrainDecls decls =<< constrainEffects home r0 r1 r2 manager
44 Can.Fx cmdName subName ->
45 letCmd home cmdName =<<
46 letSub home subName =<<
47 constrainDecls decls =<< constrainEffects home r0 r1 r2 manager
51-- CONSTRAIN DECLARATIONS
54constrainDecls :: Can.Decls -> Constraint -> IO Constraint
55constrainDecls decls finalConstraint =
56 case decls of
57 Can.Declare def otherDecls ->
58 Expr.constrainDef Map.empty def =<< constrainDecls otherDecls finalConstraint
60 Can.DeclareRec def defs otherDecls ->
61 Expr.constrainRecursiveDefs Map.empty (def:defs) =<< constrainDecls otherDecls finalConstraint
63 Can.SaveTheEnvironment ->
64 return finalConstraint
68-- PORT HELPERS
71letPort :: Name.Name -> Can.Port -> IO Constraint -> IO Constraint
72letPort name port_ makeConstraint =
73 case port_ of
74 Can.Incoming freeVars _ srcType ->
75 do vars <- Map.traverseWithKey (\k _ -> nameToRigid k) freeVars
76 tipe <- Instantiate.fromSrcType (Map.map VarN vars) srcType
77 let header = Map.singleton name (A.At A.zero tipe)
78 CLet (Map.elems vars) [] header CTrue <$> makeConstraint
80 Can.Outgoing freeVars _ srcType ->
81 do vars <- Map.traverseWithKey (\k _ -> nameToRigid k) freeVars
82 tipe <- Instantiate.fromSrcType (Map.map VarN vars) srcType
83 let header = Map.singleton name (A.At A.zero tipe)
84 CLet (Map.elems vars) [] header CTrue <$> makeConstraint
88-- EFFECT MANAGER HELPERS
91letCmd :: ModuleName.Canonical -> Name.Name -> Constraint -> IO Constraint
92letCmd home tipe constraint =
93 do msgVar <- mkFlexVar
94 let msg = VarN msgVar
95 let cmdType = FunN (AppN home tipe [msg]) (AppN ModuleName.cmd Name.cmd [msg])
96 let header = Map.singleton "command" (A.At A.zero cmdType)
97 return $ CLet [msgVar] [] header CTrue constraint
100letSub :: ModuleName.Canonical -> Name.Name -> Constraint -> IO Constraint
101letSub home tipe constraint =
102 do msgVar <- mkFlexVar
103 let msg = VarN msgVar
104 let subType = FunN (AppN home tipe [msg]) (AppN ModuleName.sub Name.sub [msg])
105 let header = Map.singleton "subscription" (A.At A.zero subType)
106 return $ CLet [msgVar] [] header CTrue constraint
109constrainEffects :: ModuleName.Canonical -> A.Region -> A.Region -> A.Region -> Can.Manager -> IO Constraint
110constrainEffects home r0 r1 r2 manager =
111 do s0 <- mkFlexVar
112 s1 <- mkFlexVar
113 s2 <- mkFlexVar
114 m1 <- mkFlexVar
115 m2 <- mkFlexVar
116 sm1 <- mkFlexVar
117 sm2 <- mkFlexVar
119 let state0 = VarN s0
120 let state1 = VarN s1
121 let state2 = VarN s2
122 let msg1 = VarN m1
123 let msg2 = VarN m2
124 let self1 = VarN sm1
125 let self2 = VarN sm2
127 let onSelfMsg = router msg2 self2 ==> self2 ==> state2 ==> task state2
128 let onEffects =
129 case manager of
130 Can.Cmd cmd -> router msg1 self1 ==> effectList home cmd msg1 ==> state1 ==> task state1
131 Can.Sub sub -> router msg1 self1 ==> effectList home sub msg1 ==> state1 ==> task state1
132 Can.Fx cmd sub -> router msg1 self1 ==> effectList home cmd msg1 ==> effectList home sub msg1 ==> state1 ==> task state1
134 let effectCons =
135 CAnd
136 [ CLocal r0 "init" (E.NoExpectation (task state0))
137 , CLocal r1 "onEffects" (E.NoExpectation onEffects)
138 , CLocal r2 "onSelfMsg" (E.NoExpectation onSelfMsg)
139 , CEqual r1 E.Effects state0 (E.NoExpectation state1)
140 , CEqual r2 E.Effects state0 (E.NoExpectation state2)
141 , CEqual r2 E.Effects self1 (E.NoExpectation self2)
142 ]
144 CLet [] [s0,s1,s2,m1,m2,sm1,sm2] Map.empty effectCons <$>
145 case manager of
146 Can.Cmd cmd ->
147 checkMap "cmdMap" home cmd CSaveTheEnvironment
149 Can.Sub sub ->
150 checkMap "subMap" home sub CSaveTheEnvironment
152 Can.Fx cmd sub ->
153 checkMap "cmdMap" home cmd =<<
154 checkMap "subMap" home sub CSaveTheEnvironment
157effectList :: ModuleName.Canonical -> Name.Name -> Type -> Type
158effectList home name msg =
159 AppN ModuleName.list Name.list [AppN home name [msg]]
162task :: Type -> Type
163task answer =
164 AppN ModuleName.platform Name.task [ never, answer ]
167router :: Type -> Type -> Type
168router msg self =
169 AppN ModuleName.platform Name.router [ msg, self ]
172checkMap :: Name.Name -> ModuleName.Canonical -> Name.Name -> Constraint -> IO Constraint
173checkMap name home tipe constraint =
174 do a <- mkFlexVar
175 b <- mkFlexVar
176 let mapType = toMapType home tipe (VarN a) (VarN b)
177 let mapCon = CLocal A.zero name (E.NoExpectation mapType)
178 return $ CLet [a,b] [] Map.empty mapCon constraint
181toMapType :: ModuleName.Canonical -> Name.Name -> Type -> Type -> Type
182toMapType home tipe a b =
183 (a ==> b) ==> AppN home tipe [a] ==> AppN home tipe [b]