@@ -28,48 +28,39 @@ constrain :: Can.Module -> IO Constraint
2828constrain (Can.Module home _ _ decls _ _ _ effects) =
2929 case effects of
3030 Can.NoEffects ->
31− constrainDecls CSaveTheEnvironment decls
31+ constrainDecls decls CSaveTheEnvironment
3232
3333 Can.Ports ports ->
34− do header <- traverse portToHeader ports
35− CLet [] [] header CTrue
36− <$> constrainDecls CSaveTheEnvironment decls
34+ Map.foldrWithKey letPort (constrainDecls decls CSaveTheEnvironment) ports
3735
3836 Can.Manager r0 r1 r2 manager ->
3937 case manager of
4038 Can.Cmd cmdName ->
41− do header <- mkCmd home cmdName
42− fxCon <- constrainEffects r0 r1 r2 $ \msg result ->
43− effectList home cmdName msg ==> result
44− CLet [] [] header CTrue <$> constrainDecls fxCon decls
39+ letCmd home cmdName =<<
40+ constrainDecls decls =<< constrainEffects home r0 r1 r2 manager
4541
4642 Can.Sub subName ->
47− do header <- mkSub home subName
48− fxCon <- constrainEffects r0 r1 r2 $ \msg result ->
49− effectList home subName msg ==> result
50− CLet [] [] header CTrue <$> constrainDecls fxCon decls
43+ letSub home subName =<<
44+ constrainDecls decls =<< constrainEffects home r0 r1 r2 manager
5145
5246 Can.Fx cmdName subName ->
53− do header <- Map.union <$> mkCmd home cmdName <*> mkSub home subName
54− fxCon <- constrainEffects r0 r1 r2 $ \msg result ->
55− effectList home cmdName msg ==> effectList home subName msg ==> result
56− CLet [] [] header CTrue <$> constrainDecls fxCon decls
47+ letCmd home cmdName =<<
48+ letSub home subName =<<
49+ constrainDecls decls =<< constrainEffects home r0 r1 r2 manager
5750
5851
5952
6053-- CONSTRAIN DECLARATIONS
6154
6255
63−constrainDecls :: Constraint -> Can.Decls -> IO Constraint
64−constrainDecls finalConstraint decls =
56+constrainDecls :: Can.Decls -> Constraint -> IO Constraint
57+constrainDecls decls finalConstraint =
6558 case decls of
6659 Can.Declare def otherDecls ->
67− Expr.constrainDef Map.empty def
68− =<< constrainDecls finalConstraint otherDecls
60+ Expr.constrainDef Map.empty def =<< constrainDecls otherDecls finalConstraint
6961
7062 Can.DeclareRec defs otherDecls ->
71− Expr.constrainRecursiveDefs Map.empty defs
72− =<< constrainDecls finalConstraint otherDecls
63+ Expr.constrainRecursiveDefs Map.empty defs =<< constrainDecls otherDecls finalConstraint
7364
7465 Can.SaveTheEnvironment ->
7566 return finalConstraint
@@ -79,16 +70,20 @@ constrainDecls finalConstraint decls =
7970-- PORT HELPERS
8071
8172
82−portToHeader :: Can.Port -> IO (A.Located Type)
83−portToHeader port_ =
73+letPort :: N.Name -> Can.Port -> IO Constraint -> IO Constraint
74+letPort name port_ makeConstraint =
8475 case port_ of
85− Can.Incoming freeVars tipe ->
86− do vars <- traverse (\_ -> VarN <$> mkFlexVar) freeVars
87− A.At zero <$> Instantiate.fromSrcType vars tipe
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
8881
89− Can.Outgoing freeVars tipe ->
90− do vars <- traverse (\_ -> VarN <$> mkFlexVar) freeVars
91− A.At zero <$> Instantiate.fromSrcType vars tipe
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
9287
9388
9489{-# NOINLINE zero #-}
@@ -101,55 +96,96 @@ zero =
10196-- EFFECT MANAGER HELPERS
10297
10398
104−mkCmd :: ModuleName.Canonical -> N.Name -> IO (Map.Map N.Name (A.Located Type))
105−mkCmd home typeName =
106− do msg <- VarN <$> mkFlexVar
107− return $ Map.singleton "command" $ A.At zero $
108− FunN (AppN home typeName [msg]) (AppN ModuleName.cmd N.cmd [msg])
109−
110−
111−mkSub :: ModuleName.Canonical -> N.Name -> IO (Map.Map N.Name (A.Located Type))
112−mkSub home typeName =
113− do msg <- VarN <$> mkFlexVar
114− return $ Map.singleton "subscription" $ A.At zero $
115− FunN (AppN home typeName [msg]) (AppN ModuleName.sub N.sub [msg])
116−
117−
118−constrainEffects
119− :: R.Region
120− -> R.Region
121− -> R.Region
122− -> (Variable -> Type -> Type)
123− -> IO Constraint
124−constrainEffects r0 r1 r2 toFinalArgs =
125− let
126− task t =
127− AppN ModuleName.platform N.task [ never, VarN t ]
128−
129− router msg selfMsg =
130− AppN ModuleName.platform N.router [ VarN msg, VarN selfMsg ]
131−
132− equal region var tipe =
133− CEqual region Effects (VarN var) (NoExpectation tipe)
134− in
135− do vars@[s0,s1,s2,msg1,msg2,selfMsg1,selfMsg2] <- replicateM 7 mkFlexVar
136− return $
137− CLet [] vars Map.empty
138− (CAnd
139− [ CLocal r0 "init" $ NoExpectation $
140− task s0
141− , CLocal r1 "onEffects" $ NoExpectation $
142− router msg1 selfMsg1 ==> toFinalArgs msg1 (VarN s1 ==> task s1)
143− , CLocal r2 "onSelfMsg" $ NoExpectation $
144− router msg2 selfMsg2 ==> VarN selfMsg2 ==> VarN s2 ==> task s2
145− , equal r1 s0 (VarN s1)
146− , equal r2 s0 (VarN s2)
147− , equal r2 selfMsg1 (VarN selfMsg2)
148− ]
149− )
150− CSaveTheEnvironment
151−
152−
153−effectList :: ModuleName.Canonical -> N.Name -> Variable -> Type
99+letCmd :: ModuleName.Canonical -> N.Name -> Constraint -> IO Constraint
100+letCmd 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
106+
107+
108+letSub :: ModuleName.Canonical -> N.Name -> Constraint -> IO Constraint
109+letSub 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
115+
116+
117+constrainEffects :: ModuleName.Canonical -> R.Region -> R.Region -> R.Region -> Can.Manager -> IO Constraint
118+constrainEffects 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
126+
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
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 =
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+ ]
151+
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
156+
157+ Can.Sub sub ->
158+ checkMap "subMap" home sub CSaveTheEnvironment
159+
160+ Can.Fx cmd sub ->
161+ checkMap "cmdMap" home cmd =<<
162+ checkMap "subMap" home sub CSaveTheEnvironment
163+
164+
165+effectList :: ModuleName.Canonical -> N.Name -> Type -> Type
154166effectList 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]