git.iko.soy/elk
on 247359c help sign in
elk/src/Type/Constrain/Module.hs
155 lines 4.6 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Type.Constrain.Module
4 ( constrain
5 )
6 where
9import Control.Monad (replicateM)
10import qualified Data.Map.Strict as Map
12import qualified AST.Canonical as Can
13import qualified AST.Module.Name as ModuleName
14import qualified Elm.Name as N
15import qualified Reporting.Annotation as A
16import qualified Reporting.Region as R
17import Type.Constraint
18import qualified Type.Constrain.Expression as Expr
19import qualified Type.Instantiate as Instantiate
20import Type.Type (Type(..), Variable, (==>), mkFlexVar, never)
24-- CONSTRAIN
27constrain :: Can.Module -> IO Constraint
28constrain (Can.Module home _ _ decls _ _ _ effects) =
29 case effects of
30 Can.NoEffects ->
31 constrainDecls CSaveTheEnvironment decls
33 Can.Ports ports ->
34 do header <- traverse portToHeader ports
35 CLet [] [] header CTrue
36 <$> constrainDecls CSaveTheEnvironment decls
38 Can.Manager r0 r1 r2 manager ->
39 case manager of
40 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
46 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
52 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
60-- CONSTRAIN DECLARATIONS
63constrainDecls :: Constraint -> Can.Decls -> IO Constraint
64constrainDecls finalConstraint decls =
65 case decls of
66 Can.Declare def otherDecls ->
67 Expr.constrainDef Map.empty def
68 =<< constrainDecls finalConstraint otherDecls
70 Can.DeclareRec defs otherDecls ->
71 Expr.constrainRecursiveDefs Map.empty defs
72 =<< constrainDecls finalConstraint otherDecls
74 Can.SaveTheEnvironment ->
75 return finalConstraint
79-- PORT HELPERS
82portToHeader :: Can.Port -> IO (A.Located Type)
83portToHeader port_ =
84 case port_ of
85 Can.Incoming freeVars tipe ->
86 do vars <- traverse (\_ -> VarN <$> mkFlexVar) freeVars
87 A.At zero <$> Instantiate.fromSrcType vars tipe
89 Can.Outgoing freeVars tipe ->
90 do vars <- traverse (\_ -> VarN <$> mkFlexVar) freeVars
91 A.At zero <$> Instantiate.fromSrcType vars tipe
94{-# NOINLINE zero #-}
95zero :: R.Region
96zero =
97 R.Region (R.Position 0 0) (R.Position 0 0)
101-- EFFECT MANAGER HELPERS
104mkCmd :: ModuleName.Canonical -> N.Name -> IO (Map.Map N.Name (A.Located Type))
105mkCmd 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])
111mkSub :: ModuleName.Canonical -> N.Name -> IO (Map.Map N.Name (A.Located Type))
112mkSub 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])
118constrainEffects
119 :: R.Region
120 -> R.Region
121 -> R.Region
122 -> (Variable -> Type -> Type)
123 -> IO Constraint
124constrainEffects r0 r1 r2 toFinalArgs =
125 let
126 task t =
127 AppN ModuleName.platform N.task [ never, VarN t ]
129 router msg selfMsg =
130 AppN ModuleName.platform N.router [ VarN msg, VarN selfMsg ]
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 [ CLookup r0 "init" $ NoExpectation $
140 task s0
141 , CLookup r1 "onEffects" $ NoExpectation $
142 router msg1 selfMsg1 ==> toFinalArgs msg1 (VarN s1 ==> task s1)
143 , CLookup 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
153effectList :: ModuleName.Canonical -> N.Name -> Variable -> Type
154effectList home name msg =
155 AppN ModuleName.list N.list [AppN home name [VarN msg]]