git.iko.soy/elk
on master help sign in
Update type constraint generation for effects
c49ac3aEvan Czaplicki
src/Type/Constrain/Effects.hs+108−85
compare with master
unifiedsplit
@@ -1,112 +1,135 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3−module Type.Constrain.Effects (constrain) where
3+module Type.Constrain.Effects
4+ ( constrain
5+ )
6+ where
4
7
8+
9+import Control.Monad (replicateM)
5import qualified Data.Map.Strict as Map
10import qualified Data.Map.Strict as Map
6
11
7−import qualified AST.Effects as Effects
12+import qualified AST.Expression.Canonical as Can
8import qualified AST.Module.Name as ModuleName
13import qualified AST.Module.Name as ModuleName
9−import qualified AST.Variable as Var
14+import qualified AST.Type as T
10−import qualified Reporting.Annotation as A
15+import qualified Elm.Name as N
11import qualified Reporting.Error.Type as Error
16import qualified Reporting.Error.Type as Error
17+import qualified Reporting.Region as R
12import Type.Constraint (Constraint(..), Scheme(Scheme))
18import Type.Constraint (Constraint(..), Scheme(Scheme))
13−import Type.Type (Variable, Type(AppN,VarN), (==>), mkFlexVar)
19+import Type.Type (Type(..), Variable, (==>), fromFlexSrcType, mkFlexVar)
14
20
15
21
16
22
17−-- CONSTRAIN EFFECTS
23+-- CONSTRAIN
18
24
19
25
20−constrain :: ModuleName.Canonical -> Effects.Canonical -> IO Constraint
26+constrain :: ModuleName.Canonical -> Can.Effects -> IO ( Map.Map N.Name Type, Constraint )
21−constrain moduleName effects =
27+constrain home effects =
22 case effects of
28 case effects of
23− Effects.None ->
29+ Can.NoEffects ->
24− return CSaveEnv
30+ return (Map.empty, CSaveEnv)
25
31
26− Effects.Port _ ->
32+ Can.Ports ports ->
33+ (,)
34+ <$> traverse fromSrcType (Map.map deport ports)
27− return CSaveEnv
35+ <*> return CSaveEnv
28
36
29− Effects.Manager _ info ->
37+ Can.Manager r0 r1 r2 manager ->
30− constrainHelp moduleName info
38+ case manager of
39+ Can.Cmd cmdName ->
40+ do cmd <- command home cmdName
41+ con <- constrainEffects r0 r1 r2 $ \msg result ->
42+ effectList home cmdName msg ==> result
43+ return (Map.singleton "command" cmd, con)
31
44
45+ Can.Sub subName ->
46+ do sub <- subscription home subName
47+ con <- constrainEffects r0 r1 r2 $ \msg result ->
48+ effectList home subName msg ==> result
49+ return (Map.singleton "subscription" sub, con)
50+
51+ Can.Fx cmdName subName ->
52+ do cmd <- command home cmdName
53+ sub <- subscription home subName
54+ con <- constrainEffects r0 r1 r2 $ \msg result ->
55+ effectList home cmdName msg ==> effectList home subName msg ==> result
56+ return (Map.fromList [("command", cmd),("subscription", sub)], con)
57+
58+
59+
60+-- HELPERS
61+
62+
63+deport :: Can.Port -> T.Canonical
64+deport port_ =
65+ case port_ of
66+ Can.Incoming tipe ->
67+ tipe
68+
69+ Can.Outgoing tipe ->
70+ tipe
71+
72+
73+fromSrcType :: T.Canonical -> IO Type
74+fromSrcType tipe =
75+ fst <$> fromFlexSrcType tipe
32
76
33−never :: Type
34−never =
35− AppN Var.never []
36
77
78+command :: ModuleName.Canonical -> N.Name -> IO Type
79+command home typeName =
80+ fromSrcType $
81+ T.Lambda
82+ (T.Type home typeName [T.Var "msg"])
83+ (T.Type ModuleName.cmd N.cmd [T.Var "msg"])
37
84
38−constrainHelp :: ModuleName.Canonical -> Effects.Info -> IO Constraint
85+
39−constrainHelp moduleName (Effects.Info tagRegion r0 r1 r2 managerType) =
86+subscription :: ModuleName.Canonical -> N.Name -> IO Type
87+subscription home typeName =
88+ fromSrcType $
89+ T.Lambda
90+ (T.Type home typeName [T.Var "msg"])
91+ (T.Type ModuleName.sub N.sub [T.Var "msg"])
92+
93+
94+
95+-- CONSTRAINTS FOR EFFECT MANAGER STUFF
96+
97+
98+constrainEffects :: R.Region -> R.Region -> R.Region -> (Variable -> Type -> Type) -> IO Constraint
99+constrainEffects r0 r1 r2 toFinalArgs =
40 let
100 let
41 task t =
101 task t =
42− AppN Var.task [ never, VarN t ]
102+ AppN ModuleName.platform N.task [ never, VarN t ]
43
103
44 router msg selfMsg =
104 router msg selfMsg =
45− AppN Var.router [ VarN msg, VarN selfMsg ]
105+ AppN ModuleName.platform N.router [ VarN msg, VarN selfMsg ]
46 in
106 in
47− do v0 <- mkFlexVar
48− v1 <- mkFlexVar
49− v2 <- mkFlexVar
50−
51− state0 <- mkFlexVar
52− state1 <- mkFlexVar
53− state2 <- mkFlexVar
54−
55− msg1 <- mkFlexVar
56− msg2 <- mkFlexVar
57−
58− selfMsg1 <- mkFlexVar
59− selfMsg2 <- mkFlexVar
60−
61− let
62− vars =
63− [v0, v1, v2, state0, state1, state2, msg1, msg2, selfMsg1, selfMsg2]
107+ do vars@[v0,v1,v2,s0,s1,s2,msg1,msg2,selfMsg1,selfMsg2] <- replicateM 10 mkFlexVar
64−
108+
65− onEffectsType =
109+ let
66− router msg1 selfMsg1
110+ onEffectsType = router msg1 selfMsg1 ==> toFinalArgs msg1 (VarN s1 ==> task s1)
67− ==> addEffectArgs moduleName managerType msg1
68− (VarN state1 ==> task state1)
69−
70− onSelfMsgType =
71− router msg2 selfMsg2 ==> VarN selfMsg2 ==> VarN state2 ==> task state2
111+ onSelfMsgType = router msg2 selfMsg2 ==> VarN selfMsg2 ==> VarN s2 ==> task s2
72−
73− constrains =
112+ constrains =
74− [ CInstance tagRegion "init" (VarN v0)
113+ [ CInstance r0 "init" (VarN v0)
75− , CInstance tagRegion "onEffects" (VarN v1)
114+ , CInstance r1 "onEffects" (VarN v1)
76− , CInstance tagRegion "onSelfMsg" (VarN v2)
115+ , CInstance r2 "onSelfMsg" (VarN v2)
77− , CEqual (Error.Manager "init") r0 (VarN v0) (task state0)
116+ , CEqual (Error.Manager "init") r0 (VarN v0) (task s0)
78− , CEqual (Error.Manager "onEffects") r1 (VarN v1) onEffectsType
117+ , CEqual (Error.Manager "onEffects") r1 (VarN v1) onEffectsType
79− , CEqual (Error.Manager "onSelfMsg") r2 (VarN v2) onSelfMsgType
118+ , CEqual (Error.Manager "onSelfMsg") r2 (VarN v2) onSelfMsgType
80− , CEqual (Error.State "onEffects") r1 (VarN state0) (VarN state1)
119+ , CEqual (Error.State "onEffects") r1 (VarN s0) (VarN s1)
81− , CEqual (Error.State "onSelfMsg") r2 (VarN state0) (VarN state2)
120+ , CEqual (Error.State "onSelfMsg") r2 (VarN s0) (VarN s2)
82− , CEqual Error.SelfMsg r2 (VarN selfMsg1) (VarN selfMsg2)
121+ , CEqual Error.SelfMsg r2 (VarN selfMsg1) (VarN selfMsg2)
83− ]
122+ ]
84−
123+
85− return $
86− CLet [Scheme [] vars (CAnd constrains) Map.empty] CSaveEnv
124+ return $ CLet [ Scheme [] vars (CAnd constrains) Map.empty ] CSaveEnv
87−
125+
88−
126+
89−addEffectArgs
127+{-# NOINLINE never #-}
128+never :: Type
129+never =
90− :: ModuleName.Canonical
130+ AppN ModuleName.basics "Never" []
91− -> Effects.RawManagerType
92− -> Variable
93− -> Type
94− -> Type
95−addEffectArgs moduleName managerType msg result =
96− let
97− toVar (A.A _ name) =
98− Var.fromModule moduleName name
99−
100− effectList fxName =
101− AppN Var.list [AppN (toVar fxName) [VarN msg]]
102− in
103− case managerType of
104− Effects.CmdManager cmd ->
105− effectList cmd ==> result
106−
107− Effects.SubManager sub ->
108− effectList sub ==> result
109
131
110− Effects.FxManager cmd sub ->
111− effectList cmd ==> effectList sub ==> result
112
132
133+effectList :: ModuleName.Canonical -> N.Name -> Variable -> Type
134+effectList home name msg =
135+ AppN ModuleName.list N.list [AppN home name [VarN msg]]