git.iko.soy/elk
on e92c826 help sign in
elk/src/Canonicalize/Module.hs
346 lines 9.8 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Canonicalize.Module
3 ( canonicalize
4 )
5 where
8import qualified Data.Graph as Graph
9import qualified Data.Map as Map
10import qualified Data.Set as Set
12import qualified AST.Expression.Canonical as Can
13import qualified AST.Expression.Source as Src
14import qualified AST.Expression.Valid as Valid
15import qualified AST.Module.Name as ModuleName
16import qualified AST.Type as Type
17import qualified Canonicalize.Environment as Env
18import qualified Canonicalize.Environment.Dups as Dups
19import qualified Canonicalize.Expression as Expr
20import qualified Canonicalize.Pattern as Pattern
21import qualified Canonicalize.Type as Type
22import qualified Elm.Interface as I
23import qualified Elm.Name as N
24import qualified Elm.Package as Pkg
25import qualified Reporting.Annotation as A
26import qualified Reporting.Error.Canonicalize as Error
27import qualified Reporting.Region as R
28import qualified Reporting.Result as Result
29import qualified Reporting.Warning as Warning
33-- RESULT
36type Result a =
37 Result.Result () Warning.Warning Error.Error a
41-- MODULES
44canonicalize
45 :: Pkg.Name
46 -> Map.Map ModuleName.Raw ModuleName.Canonical
47 -> I.Interfaces
48 -> Valid.Module
49 -> Result Can.Module
50canonicalize pkg importDict interfaces module_ =
51 do env <- Env.create pkg importDict interfaces module_
52 let (Valid.Module name _ _ exports _ decls unions aliases binops effects) = module_
53 (cdecls, cunions, caliases) <-
54 (,,)
55 <$> canonicalizeDecls env decls
56 <*> (Map.fromList <$> traverse (canonicalizeUnion env) unions)
57 <*> (Map.fromList <$> traverse (canonicalizeAlias env) aliases)
59 let cbinops = Map.fromList (map canonicalizeBinop binops)
60 ceffects <- canonicalizeEffects env cunions effects
61 cexports <- canonicalizeExports decls cunions caliases cbinops ceffects exports
63 let home = ModuleName.Canonical pkg name
64 let docs = toDocs module_
65 return $ Can.Module home docs cexports cdecls cunions caliases cbinops ceffects
69-- DOCUMENTATION
72toDocs :: Valid.Module -> A.Located (Maybe Can.Docs)
73toDocs (Valid.Module _ (A.A region maybeOverview) comments _ _ _ _ _ _ _) =
74 case maybeOverview of
75 Nothing ->
76 A.A region Nothing
78 Just overview ->
79 A.A region (Just (Can.Docs overview comments))
83-- CANONICALIZE ALIAS
86canonicalizeAlias :: Env.Env -> Valid.Alias -> Result ( N.Name, Can.Alias )
87canonicalizeAlias env (Valid.Alias (A.A _ name) args tipe) =
88 do ctipe <- Type.canonicalize env tipe
89 return (name, Can.Alias (map A.drop args) ctipe (toRecordCtorInfo tipe))
92toRecordCtorInfo :: Type.Raw -> Maybe [N.Name]
93toRecordCtorInfo (A.A _ tipe) =
94 case tipe of
95 Type.RRecord fields Nothing ->
96 Just (map (A.drop . fst) fields)
98 _ ->
99 Nothing
103-- CANONICALIZE UNION
106canonicalizeUnion :: Env.Env -> Valid.Union -> Result ( N.Name, Can.Union )
107canonicalizeUnion env (Valid.Union (A.A _ name) args ctors) =
108 let
109 canonicalizeCtor (A.A _ ctor, tipes) =
110 do ctipes <- traverse (Type.canonicalize env) tipes
111 return (ctor, ctipes)
112 in
113 do cctors <- traverse canonicalizeCtor ctors
114 return ( name, Can.Union (map A.drop args) cctors )
118-- CANONICALIZE BINOP
121canonicalizeBinop :: Valid.Binop -> ( N.Name, Can.Binop )
122canonicalizeBinop (Valid.Binop (A.A _ op) associativity precedence func) =
123 ( op, Can.Binop_ associativity precedence func )
127-- CANONICALIZE DECLARATIONS
130canonicalizeDecls :: Env.Env -> [A.Located Valid.Decl] -> Result Can.Decls
131canonicalizeDecls env decls =
132 do nodes <- traverse (toNode env) decls
133 detectCycles (Graph.stronglyConnComp nodes)
136detectCycles :: [Graph.SCC Decl] -> Result Can.Decls
137detectCycles sccs =
138 case sccs of
139 [] ->
140 Result.ok Can.SaveTheEnvironment
142 scc : otherSccs ->
143 case scc of
144 Graph.AcyclicSCC decl ->
145 Can.Declare (toCanDecl decl)
146 <$> detectCycles otherSccs
148 Graph.CyclicSCC [] ->
149 detectCycles otherSccs
151 Graph.CyclicSCC (decl:decls) ->
152 do detectBadCycles decl decls
153 Can.DeclareRec (toCanDecl decl) (map toCanDecl decls)
154 <$> detectCycles otherSccs
157toNode :: Env.Env -> A.Located Valid.Decl -> Result (Decl, N.Name, [N.Name])
158toNode env (A.A region (Valid.Decl name@(A.A _ key) args body tipe)) =
159 case args of
160 [] ->
161 do ctipe <- traverse (Type.canonicalize env) tipe
162 (cbody, freeLocals) <- Expr.removeLocals Map.empty $ Expr.canonicalize env body
163 return (Value region name cbody ctipe, key, Set.toList freeLocals)
165 _ ->
166 do ctipe <- traverse (Type.canonicalize env) tipe
167 cargs@(Can.Args _ destructors) <- Pattern.canonicalizeArgs env args
168 newEnv <- Env.addLocals destructors env
169 (cbody, freeLocals) <- Expr.removeLocals destructors $ Expr.canonicalize newEnv body
170 return (Function key cargs cbody ctipe, key, Set.toList freeLocals)
173data Decl
174 = Value R.Region (A.Located N.Name) Can.Expr (Maybe Type.Canonical)
175 | Function N.Name Can.Args Can.Expr (Maybe Type.Canonical)
178toCanDecl :: Decl -> Can.Decl
179toCanDecl decl =
180 case decl of
181 Value _ (A.A _ name) body tipe ->
182 Can.Value name body tipe
184 Function name args body tipe ->
185 Can.Function name args body tipe
188detectBadCycles :: Decl -> [Decl] -> Result ()
189detectBadCycles decl decls =
190 case traverse detectBadCyclesHelp (decl:decls) of
191 Nothing ->
192 Result.ok ()
194 Just valueCycle ->
195 case valueCycle of
196 [] ->
197 Result.ok ()
199 (declRegion, A.A region name) : otherInfo ->
200 let otherNames = map (A.drop . snd) otherInfo in
201 Result.throw declRegion (Error.RecursiveDecl region name otherNames)
204detectBadCyclesHelp :: Decl -> Maybe (R.Region, A.Located N.Name)
205detectBadCyclesHelp decl =
206 case decl of
207 Value region name _ _ ->
208 Just (region, name)
210 Function _ _ _ _ ->
211 Nothing
215-- CANONICALIZE EFFECTS
218canonicalizeEffects :: Env.Env -> Map.Map N.Name a -> Valid.Effects -> Result Can.Effects
219canonicalizeEffects env unions effects =
220 case effects of
221 Valid.NoEffects ->
222 Result.ok Can.NoEffects
224 Valid.Ports ports ->
225 do pairs <- traverse (canonicalizePort env) ports
226 return $ Can.Ports (Map.fromList pairs)
228 Valid.Cmd cmdType ->
229 Can.Cmd <$> verifyEffectType cmdType unions
231 Valid.Sub subType ->
232 Can.Sub <$> verifyEffectType subType unions
234 Valid.Fx cmdType subType ->
235 Can.Fx
236 <$> verifyEffectType cmdType unions
237 <*> verifyEffectType subType unions
240canonicalizePort :: Env.Env -> Valid.Port -> Result (N.Name, Type.Canonical)
241canonicalizePort env (Valid.Port (A.A _ name) tipe) =
242 (,) name <$> Type.canonicalize env tipe
245verifyEffectType :: A.Located N.Name -> Map.Map N.Name a -> Result N.Name
246verifyEffectType (A.A region name) unions =
247 if Map.member name unions then
248 Result.ok name
249 else
250 Result.throw region (Error.EffectNotFound name)
254-- CANONICALIZE EXPORTS
257canonicalizeExports
258 :: [A.Located Valid.Decl]
259 -> Map.Map N.Name union
260 -> Map.Map N.Name alias
261 -> Map.Map N.Name binop
262 -> Can.Effects
263 -> Src.Exposing
264 -> Result Can.Exports
265canonicalizeExports decls unions aliases binops effects exposing =
266 case exposing of
267 Src.Open ->
268 Result.ok Can.ExportEverything
270 Src.Explicit exposeds ->
271 do let names = Map.fromList (map declToName decls)
272 infos <- traverse (checkExposed names unions aliases binops effects) exposeds
273 let toError name () () = Error.ExportDuplicate name
274 Can.Export <$> Dups.detect toError infos
277declToName :: A.Located Valid.Decl -> (N.Name, Can.Export)
278declToName (A.A _ (Valid.Decl (A.A _ name) _ _ _)) =
279 (name, Can.ExportValue)
282checkExposed
283 :: Map.Map N.Name decl
284 -> Map.Map N.Name union
285 -> Map.Map N.Name alias
286 -> Map.Map N.Name binop
287 -> Can.Effects
288 -> A.Located Src.Exposed
289 -> Result (N.Name, [Dups.Info () Can.Export])
290checkExposed decls unions aliases binops effects (A.A region exposed) =
291 case exposed of
292 Src.Lower name ->
293 if Map.member name decls then
294 Result.ok (Dups.info name region () Can.ExportValue)
295 else
296 case checkPorts effects name of
297 Nothing ->
298 Result.ok (Dups.info name region () Can.ExportPort)
300 Just ports ->
301 Result.throw region $ Error.ExportNotFound Error.BadVar name $
302 ports ++ Map.keys decls
304 Src.Operator name ->
305 if Map.member name binops then
306 Result.ok (Dups.info name region () Can.ExportBinop)
307 else
308 Result.throw region $ Error.ExportNotFound Error.BadOp name $
309 Map.keys binops
311 Src.Upper name Src.Public ->
312 if Map.member name unions then
313 Result.ok (Dups.info name region () Can.ExportUnionOpen)
314 else if Map.member name aliases then
315 Result.throw region $ Error.ExportOpenAlias name
316 else
317 Result.throw region $ Error.ExportNotFound Error.BadType name $
318 Map.keys unions ++ Map.keys aliases
320 Src.Upper name Src.Private ->
321 if Map.member name unions then
322 Result.ok (Dups.info name region () Can.ExportUnionClosed)
323 else if Map.member name aliases then
324 Result.ok (Dups.info name region () Can.ExportAlias)
325 else
326 Result.throw region $ Error.ExportNotFound Error.BadType name $
327 Map.keys unions ++ Map.keys aliases
330checkPorts :: Can.Effects -> N.Name -> Maybe [N.Name]
331checkPorts effects name =
332 case effects of
333 Can.NoEffects ->
334 Just []
336 Can.Ports ports ->
337 if Map.member name ports then Nothing else Just (Map.keys ports)
339 Can.Cmd _ ->
340 Just []
342 Can.Sub _ ->
343 Just []
345 Can.Fx _ _ ->
346 Just []