git.iko.soy/elk
on e00a3f3 help sign in
elk/src/Type/Constrain/Effects.hs
112 lines 3.2 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Type.Constrain.Effects (constrain) where
5import qualified Data.Map as Map
6import Data.Monoid ((<>))
8import qualified AST.Effects as Effects
9import qualified AST.Module.Name as ModuleName
10import qualified Reporting.Annotation as A
11import qualified Reporting.Error.Type as Error
12import qualified Type.Environment as Env
13import Type.Type
14 ( Variable, Type(VarN), Constraint(..), Scheme(Scheme)
15 , (==>), (<|), mkVar
16 )
20-- CONSTRAIN EFFECTS
23constrain :: Env.Env -> ModuleName.Canonical -> Effects.Canonical -> IO Constraint
24constrain env moduleName effects =
25 case effects of
26 Effects.None ->
27 return CSaveEnv
29 Effects.Port _ ->
30 return CSaveEnv
32 Effects.Manager _ info ->
33 constrainHelp env moduleName info
36constrainHelp :: Env.Env -> ModuleName.Canonical -> Effects.Info -> IO Constraint
37constrainHelp env moduleName (Effects.Info tagRegion r0 r1 r2 managerType) =
38 let
39 task t =
40 Env.getType env "Platform.Task" <| Env.getType env "Basics.Never" <| VarN t
42 router msg selfMsg =
43 Env.getType env "Platform.Router" <| VarN msg <| VarN selfMsg
44 in
45 do v0 <- mkVar Nothing
46 v1 <- mkVar Nothing
47 v2 <- mkVar Nothing
49 state0 <- mkVar Nothing
50 state1 <- mkVar Nothing
51 state2 <- mkVar Nothing
53 msg1 <- mkVar Nothing
54 msg2 <- mkVar Nothing
56 selfMsg1 <- mkVar Nothing
57 selfMsg2 <- mkVar Nothing
59 let
60 vars =
61 [v0, v1, v2, state0, state1, state2, msg1, msg2, selfMsg1, selfMsg2]
63 onEffectsType =
64 router msg1 selfMsg1
65 ==> addEffectArgs env moduleName managerType msg1
66 (VarN state1 ==> task state1)
68 onSelfMsgType =
69 router msg2 selfMsg2 ==> VarN selfMsg2 ==> VarN state2 ==> task state2
71 constrains =
72 [ CInstance tagRegion "init" (VarN v0)
73 , CInstance tagRegion "onEffects" (VarN v1)
74 , CInstance tagRegion "onSelfMsg" (VarN v2)
75 , CEqual (Error.Manager "init") r0 (VarN v0) (task state0)
76 , CEqual (Error.Manager "onEffects") r1 (VarN v1) onEffectsType
77 , CEqual (Error.Manager "onSelfMsg") r2 (VarN v2) onSelfMsgType
78 , CEqual (Error.State "onEffects") r1 (VarN state0) (VarN state1)
79 , CEqual (Error.State "onSelfMsg") r2 (VarN state0) (VarN state2)
80 , CEqual Error.SelfMsg r2 (VarN selfMsg1) (VarN selfMsg2)
81 ]
83 return $
84 CLet [Scheme [] vars (CAnd constrains) Map.empty] CSaveEnv
87addEffectArgs
88 :: Env.Env
89 -> ModuleName.Canonical
90 -> Effects.RawManagerType
91 -> Variable
92 -> Type
93 -> Type
94addEffectArgs env moduleName managerType msg result =
95 let
96 toTypeName (A.A _ name) =
97 ModuleName.canonicalToText moduleName <> "." <> name
99 effectList fxName =
100 Env.getType env "List" <|
101 (Env.getType env (toTypeName fxName) <| VarN msg)
102 in
103 case managerType of
104 Effects.CmdManager cmd ->
105 effectList cmd ==> result
107 Effects.SubManager sub ->
108 effectList sub ==> result
110 Effects.FxManager cmd sub ->
111 effectList cmd ==> effectList sub ==> result