@@ -1,112 +1,135 @@
11{-# OPTIONS_GHC -Wall #-}
22{-# LANGUAGE OverloadedStrings #-}
3−module Type.Constrain.Effects (constrain) where
3+module Type.Constrain.Effects
4+ ( constrain
5+ )
6+ where
47
8+
9+import Control.Monad (replicateM)
510import qualified Data.Map.Strict as Map
611
7−import qualified AST.Effects as Effects
12+import qualified AST.Expression.Canonical as Can
813import qualified AST.Module.Name as ModuleName
9−import qualified AST.Variable as Var
10−import qualified Reporting.Annotation as A
14+import qualified AST.Type as T
15+import qualified Elm.Name as N
1116import qualified Reporting.Error.Type as Error
17+import qualified Reporting.Region as R
1218import Type.Constraint (Constraint(..), Scheme(Scheme))
13−import Type.Type (Variable, Type(AppN,VarN), (==>), mkFlexVar)
19+import Type.Type (Type(..), Variable, (==>), fromFlexSrcType, mkFlexVar)
1420
1521
1622
17−-- CONSTRAIN EFFECTS
23+-- CONSTRAIN
1824
1925
20−constrain :: ModuleName.Canonical -> Effects.Canonical -> IO Constraint
21−constrain moduleName effects =
26+constrain :: ModuleName.Canonical -> Can.Effects -> IO ( Map.Map N.Name Type, Constraint )
27+constrain home effects =
2228 case effects of
23− Effects.None ->
24− return CSaveEnv
29+ Can.NoEffects ->
30+ return (Map.empty, CSaveEnv)
2531
26− Effects.Port _ ->
27− return CSaveEnv
32+ Can.Ports ports ->
33+ (,)
34+ <$> traverse fromSrcType (Map.map deport ports)
35+ <*> return CSaveEnv
2836
29− Effects.Manager _ info ->
30− constrainHelp moduleName info
37+ Can.Manager r0 r1 r2 manager ->
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)
3144
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
3276
33−never :: Type
34−never =
35− AppN Var.never []
3677
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"])
3784
38−constrainHelp :: ModuleName.Canonical -> Effects.Info -> IO Constraint
39−constrainHelp moduleName (Effects.Info tagRegion r0 r1 r2 managerType) =
85+
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 =
40100 let
41101 task t =
42− AppN Var.task [ never, VarN t ]
102+ AppN ModuleName.platform N.task [ never, VarN t ]
43103
44104 router msg selfMsg =
45− AppN Var.router [ VarN msg, VarN selfMsg ]
105+ AppN ModuleName.platform N.router [ VarN msg, VarN selfMsg ]
46106 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]
64−
65− onEffectsType =
66− router msg1 selfMsg1
67− ==> addEffectArgs moduleName managerType msg1
68− (VarN state1 ==> task state1)
69−
70− onSelfMsgType =
71− router msg2 selfMsg2 ==> VarN selfMsg2 ==> VarN state2 ==> task state2
72−
73− constrains =
74− [ CInstance tagRegion "init" (VarN v0)
75− , CInstance tagRegion "onEffects" (VarN v1)
76− , CInstance tagRegion "onSelfMsg" (VarN v2)
77− , CEqual (Error.Manager "init") r0 (VarN v0) (task state0)
78− , CEqual (Error.Manager "onEffects") r1 (VarN v1) onEffectsType
79− , CEqual (Error.Manager "onSelfMsg") r2 (VarN v2) onSelfMsgType
80− , CEqual (Error.State "onEffects") r1 (VarN state0) (VarN state1)
81− , CEqual (Error.State "onSelfMsg") r2 (VarN state0) (VarN state2)
82− , CEqual Error.SelfMsg r2 (VarN selfMsg1) (VarN selfMsg2)
83− ]
84−
85− return $
86− CLet [Scheme [] vars (CAnd constrains) Map.empty] CSaveEnv
87−
88−
89−addEffectArgs
90− :: ModuleName.Canonical
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
107+ do vars@[v0,v1,v2,s0,s1,s2,msg1,msg2,selfMsg1,selfMsg2] <- replicateM 10 mkFlexVar
108+
109+ let
110+ onEffectsType = router msg1 selfMsg1 ==> toFinalArgs msg1 (VarN s1 ==> task s1)
111+ onSelfMsgType = router msg2 selfMsg2 ==> VarN selfMsg2 ==> VarN s2 ==> task s2
112+ constrains =
113+ [ CInstance r0 "init" (VarN v0)
114+ , CInstance r1 "onEffects" (VarN v1)
115+ , CInstance r2 "onSelfMsg" (VarN v2)
116+ , CEqual (Error.Manager "init") r0 (VarN v0) (task s0)
117+ , CEqual (Error.Manager "onEffects") r1 (VarN v1) onEffectsType
118+ , CEqual (Error.Manager "onSelfMsg") r2 (VarN v2) onSelfMsgType
119+ , CEqual (Error.State "onEffects") r1 (VarN s0) (VarN s1)
120+ , CEqual (Error.State "onSelfMsg") r2 (VarN s0) (VarN s2)
121+ , CEqual Error.SelfMsg r2 (VarN selfMsg1) (VarN selfMsg2)
122+ ]
123+
124+ return $ CLet [ Scheme [] vars (CAnd constrains) Map.empty ] CSaveEnv
125+
126+
127+{-# NOINLINE never #-}
128+never :: Type
129+never =
130+ AppN ModuleName.basics "Never" []
109131
110− Effects.FxManager cmd sub ->
111− effectList cmd ==> effectList sub ==> result
112132
133+effectList :: ModuleName.Canonical -> N.Name -> Variable -> Type
134+effectList home name msg =
135+ AppN ModuleName.list N.list [AppN home name [VarN msg]]