git.iko.soy/elk
on master help sign in
Get type checks on effect modules working properly
ab555e7Evan Czaplicki
src/Type/Constrain/Module.hs+117−81
compare with master
unifiedsplit
@@ -28,48 +28,39 @@ constrain :: Can.Module -> IO Constraint
28constrain (Can.Module home _ _ decls _ _ _ effects) =
28constrain (Can.Module home _ _ decls _ _ _ effects) =
29 case effects of
29 case effects of
30 Can.NoEffects ->
30 Can.NoEffects ->
31− constrainDecls CSaveTheEnvironment decls
31+ constrainDecls decls CSaveTheEnvironment
32
32
33 Can.Ports ports ->
33 Can.Ports ports ->
34− do header <- traverse portToHeader ports
34+ Map.foldrWithKey letPort (constrainDecls decls CSaveTheEnvironment) ports
35− CLet [] [] header CTrue
36− <$> constrainDecls CSaveTheEnvironment decls
37
35
38 Can.Manager r0 r1 r2 manager ->
36 Can.Manager r0 r1 r2 manager ->
39 case manager of
37 case manager of
40 Can.Cmd cmdName ->
38 Can.Cmd cmdName ->
41− do header <- mkCmd home cmdName
39+ letCmd home cmdName =<<
42− fxCon <- constrainEffects r0 r1 r2 $ \msg result ->
40+ constrainDecls decls =<< constrainEffects home r0 r1 r2 manager
43− effectList home cmdName msg ==> result
44− CLet [] [] header CTrue <$> constrainDecls fxCon decls
45
41
46 Can.Sub subName ->
42 Can.Sub subName ->
47− do header <- mkSub home subName
43+ letSub home subName =<<
48− fxCon <- constrainEffects r0 r1 r2 $ \msg result ->
44+ constrainDecls decls =<< constrainEffects home r0 r1 r2 manager
49− effectList home subName msg ==> result
50− CLet [] [] header CTrue <$> constrainDecls fxCon decls
51
45
52 Can.Fx cmdName subName ->
46 Can.Fx cmdName subName ->
53− do header <- Map.union <$> mkCmd home cmdName <*> mkSub home subName
47+ letCmd home cmdName =<<
48+ letSub home subName =<<
54− fxCon <- constrainEffects r0 r1 r2 $ \msg result ->
49+ constrainDecls decls =<< constrainEffects home r0 r1 r2 manager
55− effectList home cmdName msg ==> effectList home subName msg ==> result
56− CLet [] [] header CTrue <$> constrainDecls fxCon decls
57
50
58
51
59
52
60-- CONSTRAIN DECLARATIONS
53-- CONSTRAIN DECLARATIONS
61
54
62
55
63−constrainDecls :: Constraint -> Can.Decls -> IO Constraint
56+constrainDecls :: Can.Decls -> Constraint -> IO Constraint
64−constrainDecls finalConstraint decls =
57+constrainDecls decls finalConstraint =
65 case decls of
58 case decls of
66 Can.Declare def otherDecls ->
59 Can.Declare def otherDecls ->
67− Expr.constrainDef Map.empty def
60+ Expr.constrainDef Map.empty def =<< constrainDecls otherDecls finalConstraint
68− =<< constrainDecls finalConstraint otherDecls
69
61
70 Can.DeclareRec defs otherDecls ->
62 Can.DeclareRec defs otherDecls ->
71− Expr.constrainRecursiveDefs Map.empty defs
63+ Expr.constrainRecursiveDefs Map.empty defs =<< constrainDecls otherDecls finalConstraint
72− =<< constrainDecls finalConstraint otherDecls
73
64
74 Can.SaveTheEnvironment ->
65 Can.SaveTheEnvironment ->
75 return finalConstraint
66 return finalConstraint
@@ -79,16 +70,20 @@ constrainDecls finalConstraint decls =
79-- PORT HELPERS
70-- PORT HELPERS
80
71
81
72
82−portToHeader :: Can.Port -> IO (A.Located Type)
73+letPort :: N.Name -> Can.Port -> IO Constraint -> IO Constraint
83−portToHeader port_ =
74+letPort name port_ makeConstraint =
84 case port_ of
75 case port_ of
85− Can.Incoming freeVars tipe ->
76+ Can.Incoming freeVars srcType ->
86− do vars <- traverse (\_ -> VarN <$> mkFlexVar) freeVars
77+ do vars <- traverse (\_ -> mkFlexVar) freeVars
87− A.At zero <$> Instantiate.fromSrcType vars tipe
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
88
81
89− Can.Outgoing freeVars tipe ->
82+ Can.Outgoing freeVars srcType ->
90− do vars <- traverse (\_ -> VarN <$> mkFlexVar) freeVars
83+ do vars <- traverse (\_ -> mkFlexVar) freeVars
91− A.At zero <$> Instantiate.fromSrcType vars tipe
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
92
87
93
88
94{-# NOINLINE zero #-}
89{-# NOINLINE zero #-}
@@ -101,55 +96,96 @@ zero =
101-- EFFECT MANAGER HELPERS
96-- EFFECT MANAGER HELPERS
102
97
103
98
104−mkCmd :: ModuleName.Canonical -> N.Name -> IO (Map.Map N.Name (A.Located Type))
99+letCmd :: ModuleName.Canonical -> N.Name -> Constraint -> IO Constraint
105−mkCmd home typeName =
100+letCmd home tipe constraint =
106− do msg <- VarN <$> mkFlexVar
101+ do msgVar <- mkFlexVar
102+ let msg = VarN msgVar
103+ let cmdType = FunN (AppN home tipe [msg]) (AppN ModuleName.cmd N.cmd [msg])
107− return $ Map.singleton "command" $ A.At zero $
104+ let header = Map.singleton "command" (A.At zero cmdType)
108− FunN (AppN home typeName [msg]) (AppN ModuleName.cmd N.cmd [msg])
105+ return $ CLet [msgVar] [] header CTrue constraint
109−
106+
110−
107+
111−mkSub :: ModuleName.Canonical -> N.Name -> IO (Map.Map N.Name (A.Located Type))
108+letSub :: ModuleName.Canonical -> N.Name -> Constraint -> IO Constraint
112−mkSub home typeName =
109+letSub home tipe constraint =
110+ do msgVar <- mkFlexVar
113− do msg <- VarN <$> mkFlexVar
111+ let msg = VarN msgVar
112+ let subType = FunN (AppN home tipe [msg]) (AppN ModuleName.sub N.sub [msg])
114− return $ Map.singleton "subscription" $ A.At zero $
113+ let header = Map.singleton "subscription" (A.At zero subType)
115− FunN (AppN home typeName [msg]) (AppN ModuleName.sub N.sub [msg])
114+ return $ CLet [msgVar] [] header CTrue constraint
116−
115+
117−
116+
118−constrainEffects
117+constrainEffects :: ModuleName.Canonical -> R.Region -> R.Region -> R.Region -> Can.Manager -> IO Constraint
119− :: R.Region
120− -> R.Region
121− -> R.Region
122− -> (Variable -> Type -> Type)
123− -> IO Constraint
124−constrainEffects r0 r1 r2 toFinalArgs =
118+constrainEffects home r0 r1 r2 manager =
125− let
119+ do s0 <- mkFlexVar
126− task t =
120+ s1 <- mkFlexVar
127− AppN ModuleName.platform N.task [ never, VarN t ]
121+ s2 <- mkFlexVar
128−
122+ m1 <- mkFlexVar
129− router msg selfMsg =
123+ m2 <- mkFlexVar
130− AppN ModuleName.platform N.router [ VarN msg, VarN selfMsg ]
124+ sm1 <- mkFlexVar
131−
125+ sm2 <- mkFlexVar
132− equal region var tipe =
126+
133− CEqual region Effects (VarN var) (NoExpectation tipe)
127+ let state0 = VarN s0
134− in
128+ let state1 = VarN s1
135− do vars@[s0,s1,s2,msg1,msg2,selfMsg1,selfMsg2] <- replicateM 7 mkFlexVar
129+ let state2 = VarN s2
136− return $
130+ let msg1 = VarN m1
137− CLet [] vars Map.empty
131+ let msg2 = VarN m2
132+ let self1 = VarN sm1
133+ let self2 = VarN sm2
134+
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
141+
142+ let effectCons =
138− (CAnd
143+ CAnd
139− [ CLocal r0 "init" $ NoExpectation $
144+ [ CLocal r0 "init" (NoExpectation (task state0))
140− task s0
141− , CLocal r1 "onEffects" $ NoExpectation $
145+ , CLocal r1 "onEffects" (NoExpectation onEffects)
142− router msg1 selfMsg1 ==> toFinalArgs msg1 (VarN s1 ==> task s1)
146+ , CLocal r2 "onSelfMsg" (NoExpectation onSelfMsg)
147+ , CEqual r1 Effects state0 (NoExpectation state1)
143− , CLocal r2 "onSelfMsg" $ NoExpectation $
148+ , CEqual r2 Effects state0 (NoExpectation state2)
144− router msg2 selfMsg2 ==> VarN selfMsg2 ==> VarN s2 ==> task s2
149+ , CEqual r2 Effects self1 (NoExpectation self2)
145− , equal r1 s0 (VarN s1)
150+ ]
146− , equal r2 s0 (VarN s2)
151+
147− , equal r2 selfMsg1 (VarN selfMsg2)
152+ CLet [] [s0,s1,s2,m1,m2,sm1,sm2] Map.empty effectCons <$>
148− ]
153+ case manager of
149− )
154+ Can.Cmd cmd ->
155+ checkMap "cmdMap" home cmd CSaveTheEnvironment
156+
157+ Can.Sub sub ->
158+ checkMap "subMap" home sub CSaveTheEnvironment
159+
160+ Can.Fx cmd sub ->
161+ checkMap "cmdMap" home cmd =<<
150− CSaveTheEnvironment
162+ checkMap "subMap" home sub CSaveTheEnvironment
151−
163+
152−
164+
153−effectList :: ModuleName.Canonical -> N.Name -> Variable -> Type
165+effectList :: ModuleName.Canonical -> N.Name -> Type -> Type
154effectList home name msg =
166effectList home name msg =
155− AppN ModuleName.list N.list [AppN home name [VarN msg]]
167+ AppN ModuleName.list N.list [AppN home name [msg]]
168+
169+
170+task :: Type -> Type
171+task answer =
172+ AppN ModuleName.platform N.task [ never, answer ]
173+
174+
175+router :: Type -> Type -> Type
176+router msg self =
177+ AppN ModuleName.platform N.router [ msg, self ]
178+
179+
180+checkMap :: N.Name -> ModuleName.Canonical -> N.Name -> Constraint -> IO Constraint
181+checkMap 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 "cmdMap" (NoExpectation mapType)
186+ return $ CLet [a,b] [] Map.empty mapCon constraint
187+
188+
189+toMapType :: ModuleName.Canonical -> N.Name -> Type -> Type -> Type
190+toMapType home tipe a b =
191+ (a ==> b) ==> AppN home tipe [a] ==> AppN home tipe [b]