git.iko.soy/elk
on c19392f help sign in
elk/src/Type/Constrain/Effects.hs
112 lines 3.1 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Type.Constrain.Effects (constrain) where
5import qualified Data.Map.Strict as Map
7import qualified AST.Effects as Effects
8import qualified AST.Module.Name as ModuleName
9import qualified AST.Variable as Var
10import qualified Reporting.Annotation as A
11import qualified Reporting.Error.Type as Error
12import Type.Constraint (Constraint(..), Scheme(Scheme))
13import Type.Type (Variable, Type(AppN,VarN), (==>), mkFlexVar)
17-- CONSTRAIN EFFECTS
20constrain :: ModuleName.Canonical -> Effects.Canonical -> IO Constraint
21constrain moduleName effects =
22 case effects of
23 Effects.None ->
24 return CSaveEnv
26 Effects.Port _ ->
27 return CSaveEnv
29 Effects.Manager _ info ->
30 constrainHelp moduleName info
33never :: Type
34never =
35 AppN Var.never []
38constrainHelp :: ModuleName.Canonical -> Effects.Info -> IO Constraint
39constrainHelp moduleName (Effects.Info tagRegion r0 r1 r2 managerType) =
40 let
41 task t =
42 AppN Var.task [ never, VarN t ]
44 router msg selfMsg =
45 AppN Var.router [ VarN msg, VarN selfMsg ]
46 in
47 do v0 <- mkFlexVar
48 v1 <- mkFlexVar
49 v2 <- mkFlexVar
51 state0 <- mkFlexVar
52 state1 <- mkFlexVar
53 state2 <- mkFlexVar
55 msg1 <- mkFlexVar
56 msg2 <- mkFlexVar
58 selfMsg1 <- mkFlexVar
59 selfMsg2 <- mkFlexVar
61 let
62 vars =
63 [v0, v1, v2, state0, state1, state2, msg1, msg2, selfMsg1, selfMsg2]
65 onEffectsType =
66 router msg1 selfMsg1
67 ==> addEffectArgs 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 :: ModuleName.Canonical
91 -> Effects.RawManagerType
92 -> Variable
93 -> Type
94 -> Type
95addEffectArgs moduleName managerType msg result =
96 let
97 toVar (A.A _ name) =
98 Var.fromModule moduleName name
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
107 Effects.SubManager sub ->
108 effectList sub ==> result
110 Effects.FxManager cmd sub ->
111 effectList cmd ==> effectList sub ==> result