git.iko.soy/elk
on 00a3069 help sign in
elk/src/Canonicalize/Effects.hs
208 lines 5.5 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Canonicalize.Effects
4 ( canonicalize
5 , checkPayload
6 )
7 where
9import qualified Data.Foldable as F
10import qualified Data.Map as Map
11import qualified Data.Set as Set
12import Data.Text (Text)
14import qualified AST.Canonical as Can
15import qualified AST.Valid as Valid
16import qualified AST.Module.Name as ModuleName
17import qualified AST.Utils.Type as Type
18import qualified Canonicalize.Environment as Env
19import qualified Canonicalize.Type as Type
20import qualified Elm.Name as N
21import qualified Reporting.Annotation as A
22import qualified Reporting.Error.Canonicalize as Error
23import qualified Reporting.Region as R
24import qualified Reporting.Result as Result
28-- RESULT
31type Result i w a =
32 Result.Result i w Error.Error a
36-- CANONICALIZE
39canonicalize
40 :: Env.Env
41 -> [A.Located Valid.Decl]
42 -> Map.Map N.Name union
43 -> Valid.Effects
44 -> Result i w Can.Effects
45canonicalize env decls unions effects =
46 case effects of
47 Valid.NoEffects ->
48 Result.ok Can.NoEffects
50 Valid.Ports ports ->
51 do pairs <- traverse (canonicalizePort env) ports
52 return $ Can.Ports (Map.fromList pairs)
54 Valid.Manager region manager ->
55 let dict = Map.fromList (map toNameRegion decls) in
56 Can.Manager
57 <$> verifyManager region dict "init"
58 <*> verifyManager region dict "onEffects"
59 <*> verifyManager region dict "onSelfMsg"
60 <*>
61 case manager of
62 Valid.Cmd cmdType ->
63 Can.Cmd <$> verifyEffectType cmdType unions
65 Valid.Sub subType ->
66 Can.Sub <$> verifyEffectType subType unions
68 Valid.Fx cmdType subType ->
69 Can.Fx
70 <$> verifyEffectType cmdType unions
71 <*> verifyEffectType subType unions
75-- CANONICALIZE PORT
78canonicalizePort :: Env.Env -> Valid.Port -> Result i w (N.Name, Can.Port)
79canonicalizePort env (Valid.Port (A.At region portName) tipe) =
80 do (Can.Forall freeVars ctipe) <- Type.toAnnotation env tipe
81 case Type.deepDealias ctipe of
82 Can.TLambda outgoingType (Can.TType home name [Can.TVar _])
83 | home == ModuleName.cmd && name == "Cmd" ->
84 case checkPayload outgoingType of
85 Left (badType, err) ->
86 Result.throw (Error.PortPayloadInvalid region portName badType err)
88 Right () ->
89 Result.ok (portName, Can.Outgoing freeVars ctipe)
91 Can.TLambda (Can.TLambda incomingType (Can.TVar msg1)) (Can.TType home name [Can.TVar msg2])
92 | home == ModuleName.sub && name == "Sub" && msg1 == msg2 ->
93 case checkPayload incomingType of
94 Left (badType, err) ->
95 Result.throw (Error.PortPayloadInvalid region portName badType err)
97 Right () ->
98 Result.ok (portName, Can.Incoming freeVars ctipe)
100 _ ->
101 Result.throw (Error.PortTypeInvalid region portName ctipe)
105-- VERIFY MANAGER
108verifyEffectType :: A.Located N.Name -> Map.Map N.Name a -> Result i w N.Name
109verifyEffectType (A.At region name) unions =
110 if Map.member name unions then
111 Result.ok name
112 else
113 Result.throw (Error.EffectNotFound region name)
116toNameRegion :: A.Located Valid.Decl -> (N.Name, R.Region)
117toNameRegion (A.At _ (Valid.Decl (A.At region name) _ _ _)) =
118 (name, region)
121verifyManager :: R.Region -> Map.Map N.Name R.Region -> N.Name -> Result i w R.Region
122verifyManager tagRegion decls name =
123 case Map.lookup name decls of
124 Just region ->
125 Result.ok region
127 Nothing ->
128 Result.throw (Error.EffectFunctionNotFound tagRegion name)
132-- CHECK PAYLOAD TYPES
135checkPayload :: Can.Type -> Either (Can.Type, Error.InvalidPayload) ()
136checkPayload tipe =
137 case tipe of
138 Can.TAlias _ _ args aliasedType ->
139 checkPayload (Type.dealias args aliasedType)
141 Can.TType home name args ->
142 case args of
143 []
144 | isPrim home name -> Right ()
145 | isJson home name -> Right ()
147 [arg]
148 | isList home name -> checkPayload arg
149 | isMaybe home name -> checkPayload arg
150 | isArray home name -> checkPayload arg
152 _ ->
153 Left (tipe, Error.UnsupportedType name)
155 Can.TUnit ->
156 Right ()
158 Can.TTuple a b maybeC ->
159 do checkPayload a
160 checkPayload b
161 case maybeC of
162 Nothing ->
163 Right ()
165 Just c ->
166 checkPayload c
168 Can.TVar name ->
169 Left (tipe, Error.TypeVariable name)
171 Can.TLambda _ _ ->
172 Left (tipe, Error.Function)
174 Can.TRecord _ (Just _) ->
175 Left (tipe, Error.ExtendedRecord)
177 Can.TRecord fields Nothing ->
178 F.traverse_ checkPayload fields
181isPrim :: ModuleName.Canonical -> N.Name -> Bool
182isPrim home name =
183 home == ModuleName.basics && Set.member name primitives
186primitives :: Set.Set Text
187primitives =
188 Set.fromList [ N.int, N.float, N.string, N.bool ]
191isJson :: ModuleName.Canonical -> N.Name -> Bool
192isJson home name =
193 home == ModuleName.jsonEncode && name == N.value
196isList :: ModuleName.Canonical -> N.Name -> Bool
197isList home name =
198 home == ModuleName.list && name == N.list
201isMaybe :: ModuleName.Canonical -> N.Name -> Bool
202isMaybe home name =
203 home == ModuleName.maybe && name == N.maybe
206isArray :: ModuleName.Canonical -> N.Name -> Bool
207isArray home name =
208 home == ModuleName.array && name == N.array