git.iko.soy/elk
on 267f708 help sign in
elk/src/Type/Constrain/Effects.hs
114 lines 3.2 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Type.Constrain.Effects (constrain) where
4import qualified Data.Map as Map
6import qualified AST.Effects as Effects
7import qualified AST.Module.Name as ModuleName
8import qualified Reporting.Annotation as A
9import qualified Reporting.Error.Type as Error
10import qualified Type.Environment as Env
11import Type.Type
12 ( Variable, Type, TypeConstraint, Constraint(..), Scheme(Scheme)
13 , TermN(VarN), (==>), (<|), mkVar
14 )
17constrain
18 :: Env.Environment
19 -> ModuleName.Canonical
20 -> Effects.Canonical
21 -> IO TypeConstraint
22constrain env moduleName effects =
23 case effects of
24 Effects.None ->
25 return CSaveEnv
27 Effects.Port _ ->
28 return CSaveEnv
30 Effects.Manager _ info ->
31 constrainHelp env moduleName info
34constrainHelp
35 :: Env.Environment
36 -> ModuleName.Canonical
37 -> Effects.Info
38 -> IO TypeConstraint
39constrainHelp env moduleName (Effects.Info tagRegion r0 r1 r2 managerType) =
40 let
41 task t =
42 Env.getType env "Platform.Task" <| Env.getType env "Basics.Never" <| VarN t
44 router msg selfMsg =
45 Env.getType env "Platform.Router" <| VarN msg <| VarN selfMsg
46 in
47 do v0 <- mkVar Nothing
48 v1 <- mkVar Nothing
49 v2 <- mkVar Nothing
51 state0 <- mkVar Nothing
52 state1 <- mkVar Nothing
53 state2 <- mkVar Nothing
55 msg1 <- mkVar Nothing
56 msg2 <- mkVar Nothing
58 selfMsg1 <- mkVar Nothing
59 selfMsg2 <- mkVar Nothing
61 let
62 vars =
63 [v0, v1, v2, state0, state1, state2, msg1, msg2, selfMsg1, selfMsg2]
65 onEffectsType =
66 router msg1 selfMsg1
67 ==> addEffectArgs env moduleName managerType msg1
68 (VarN state1 ==> task state1)
70 onSelfMsgType =
71 router msg2 selfMsg2 ==> VarN selfMsg2 ==> VarN state2 ==> task state2
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 ]
85 return $
86 CLet [Scheme [] vars (CAnd constrains) Map.empty] CSaveEnv
89addEffectArgs
90 :: Env.Environment
91 -> ModuleName.Canonical
92 -> Effects.ManagerType
93 -> Variable
94 -> Type
95 -> Type
96addEffectArgs env moduleName managerType msg result =
97 let
98 toTypeName (A.A _ name) =
99 ModuleName.canonicalToString moduleName ++ "." ++ name
101 effectList fxName =
102 Env.getType env "List" <|
103 (Env.getType env (toTypeName fxName) <| VarN msg)
104 in
105 case managerType of
106 Effects.CmdManager cmd ->
107 effectList cmd ==> result
109 Effects.SubManager sub ->
110 effectList sub ==> result
112 Effects.FxManager cmd sub ->
113 effectList cmd ==> effectList sub ==> result