git.iko.soy/elk
on a4e2560 help sign in
elk/src/Canonicalize/Module.hs
313 lines 9.0 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.Effects as Effects
18import qualified Canonicalize.Environment as Env
19import qualified Canonicalize.Environment.Dups as Dups
20import qualified Canonicalize.Environment.Foreign as Foreign
21import qualified Canonicalize.Environment.Local as Local
22import qualified Canonicalize.Expression as Expr
23import qualified Canonicalize.Pattern as Pattern
24import qualified Canonicalize.Type as Type
25import qualified Elm.Interface as I
26import qualified Elm.Name as N
27import qualified Elm.Package as Pkg
28import qualified Reporting.Annotation as A
29import qualified Reporting.Error.Canonicalize as Error
30import qualified Reporting.Region as R
31import qualified Reporting.Result as Result
32import qualified Reporting.Warning as Warning
36-- RESULT
39type Result a =
40 Result.Result () Warning.Warning Error.Error a
44-- MODULES
47canonicalize
48 :: Pkg.Name
49 -> Map.Map N.Name ModuleName.Canonical
50 -> I.Interfaces
51 -> Valid.Module
52 -> Result Can.Module
53canonicalize pkg importDict interfaces module_@(Valid.Module name _ _ exports imports decls unions aliases binops effects) =
54 do let home = ModuleName.Canonical pkg name
56 startEnv <- Local.addVarsAndTypes module_ =<<
57 Foreign.createInitialEnv home importDict interfaces imports
59 (cunions, caliases) <-
60 (,)
61 <$> (Map.fromList <$> traverse (canonicalizeUnion startEnv) unions)
62 <*> (Map.fromList <$> traverse (canonicalizeAlias startEnv) aliases)
64 let finalEnv = Local.addPatterns cunions startEnv
65 let cbinops = Map.fromList (map canonicalizeBinop binops)
67 (cdecls, ceffects) <-
68 (,)
69 <$> canonicalizeDecls finalEnv decls
70 <*> Effects.canonicalize finalEnv decls cunions effects
72 cexports <- canonicalizeExports decls cunions caliases cbinops ceffects exports
74 let docs = toDocs module_
75 return $ Can.Module home docs cexports cdecls cunions caliases cbinops ceffects
79-- DOCUMENTATION
82toDocs :: Valid.Module -> A.Located (Maybe Can.Docs)
83toDocs (Valid.Module _ (A.A region maybeOverview) comments _ _ _ _ _ _ _) =
84 case maybeOverview of
85 Nothing ->
86 A.A region Nothing
88 Just overview ->
89 A.A region (Just (Can.Docs overview comments))
93-- CANONICALIZE ALIAS
96canonicalizeAlias :: Env.Env -> Valid.Alias -> Result ( N.Name, Can.Alias )
97canonicalizeAlias env (Valid.Alias (A.A _ name) args tipe) =
98 do ctipe <- Type.canonicalize env tipe
99 return (name, Can.Alias (map A.drop args) ctipe (toRecordCtorInfo tipe))
102toRecordCtorInfo :: Type.Raw -> Maybe [N.Name]
103toRecordCtorInfo (A.A _ tipe) =
104 case tipe of
105 Type.RRecord fields Nothing ->
106 Just (map (A.drop . fst) fields)
108 _ ->
109 Nothing
113-- CANONICALIZE UNION
116canonicalizeUnion :: Env.Env -> Valid.Union -> Result ( N.Name, Can.Union )
117canonicalizeUnion env (Valid.Union (A.A _ name) args ctors) =
118 let
119 canonicalizeCtor (A.A _ ctor, tipes) =
120 do ctipes <- traverse (Type.canonicalize env) tipes
121 return (ctor, ctipes)
122 in
123 do cctors <- traverse canonicalizeCtor ctors
124 return ( name, Can.Union (map A.drop args) cctors )
128-- CANONICALIZE BINOP
131canonicalizeBinop :: Valid.Binop -> ( N.Name, Can.Binop )
132canonicalizeBinop (Valid.Binop (A.A _ op) associativity precedence func) =
133 ( op, Can.Binop_ associativity precedence func )
137-- CANONICALIZE DECLARATIONS
140canonicalizeDecls :: Env.Env -> [A.Located Valid.Decl] -> Result Can.Decls
141canonicalizeDecls env decls =
142 do nodes <- traverse (toNode env) decls
143 detectCycles (Graph.stronglyConnComp nodes)
146detectCycles :: [Graph.SCC Decl] -> Result Can.Decls
147detectCycles sccs =
148 case sccs of
149 [] ->
150 Result.ok Can.SaveTheEnvironment
152 scc : otherSccs ->
153 case scc of
154 Graph.AcyclicSCC decl ->
155 Can.Declare (toCanDecl decl)
156 <$> detectCycles otherSccs
158 Graph.CyclicSCC [] ->
159 detectCycles otherSccs
161 Graph.CyclicSCC (decl:decls) ->
162 do detectBadCycles decl decls
163 Can.DeclareRec (toCanDecl decl) (map toCanDecl decls)
164 <$> detectCycles otherSccs
167toNode :: Env.Env -> A.Located Valid.Decl -> Result (Decl, N.Name, [N.Name])
168toNode env (A.A region (Valid.Decl name@(A.A _ key) args body tipe)) =
169 case args of
170 [] ->
171 do ctipe <- traverse (Type.canonicalize env) tipe
172 (cbody, freeLocals) <- Expr.removeLocals Warning.Pattern Map.empty $
173 Expr.canonicalize env body
174 return (Value region name cbody ctipe, key, Set.toList freeLocals)
176 _ ->
177 do ctipe <- traverse (Type.canonicalize env) tipe
178 cargs@(Can.Args _ destructors) <- Pattern.canonicalizeArgs env args
179 newEnv <- Env.addLocals destructors env
180 (cbody, freeLocals) <- Expr.removeLocals Warning.Pattern destructors $
181 Expr.canonicalize newEnv body
182 return (Function key cargs cbody ctipe, key, Set.toList freeLocals)
185data Decl
186 = Value R.Region (A.Located N.Name) Can.Expr (Maybe Type.Canonical)
187 | Function N.Name Can.Args Can.Expr (Maybe Type.Canonical)
190toCanDecl :: Decl -> Can.Decl
191toCanDecl decl =
192 case decl of
193 Value _ (A.A _ name) body tipe ->
194 Can.Value name body tipe
196 Function name args body tipe ->
197 Can.Function name args body tipe
200detectBadCycles :: Decl -> [Decl] -> Result ()
201detectBadCycles decl decls =
202 case traverse detectBadCyclesHelp (decl:decls) of
203 Nothing ->
204 Result.ok ()
206 Just valueCycle ->
207 case valueCycle of
208 [] ->
209 Result.ok ()
211 (declRegion, A.A region name) : otherInfo ->
212 let otherNames = map (A.drop . snd) otherInfo in
213 Result.throw declRegion (Error.RecursiveDecl region name otherNames)
216detectBadCyclesHelp :: Decl -> Maybe (R.Region, A.Located N.Name)
217detectBadCyclesHelp decl =
218 case decl of
219 Value region name _ _ ->
220 Just (region, name)
222 Function _ _ _ _ ->
223 Nothing
227-- CANONICALIZE EXPORTS
230canonicalizeExports
231 :: [A.Located Valid.Decl]
232 -> Map.Map N.Name union
233 -> Map.Map N.Name alias
234 -> Map.Map N.Name binop
235 -> Can.Effects
236 -> Src.Exposing
237 -> Result Can.Exports
238canonicalizeExports decls unions aliases binops effects exposing =
239 case exposing of
240 Src.Open ->
241 Result.ok Can.ExportEverything
243 Src.Explicit exposeds ->
244 do let names = Map.fromList (map declToName decls)
245 infos <- traverse (checkExposed names unions aliases binops effects) exposeds
246 let toError name () () = Error.ExportDuplicate name
247 Can.Export <$> Dups.detect toError infos
250declToName :: A.Located Valid.Decl -> ( N.Name, () )
251declToName (A.A _ (Valid.Decl (A.A _ name) _ _ _)) =
252 ( name, () )
255checkExposed
256 :: Map.Map N.Name decl
257 -> Map.Map N.Name union
258 -> Map.Map N.Name alias
259 -> Map.Map N.Name binop
260 -> Can.Effects
261 -> A.Located Src.Exposed
262 -> Result (N.Name, [Dups.Info () Can.Export])
263checkExposed decls unions aliases binops effects (A.A region exposed) =
264 case exposed of
265 Src.Lower name ->
266 if Map.member name decls then
267 Result.ok (Dups.info name region () Can.ExportValue)
268 else
269 case checkPorts effects name of
270 Nothing ->
271 Result.ok (Dups.info name region () Can.ExportPort)
273 Just ports ->
274 Result.throw region $ Error.ExportNotFound Error.BadVar name $
275 ports ++ Map.keys decls
277 Src.Operator name ->
278 if Map.member name binops then
279 Result.ok (Dups.info name region () Can.ExportBinop)
280 else
281 Result.throw region $ Error.ExportNotFound Error.BadOp name $
282 Map.keys binops
284 Src.Upper name Src.Public ->
285 if Map.member name unions then
286 Result.ok (Dups.info name region () Can.ExportUnionOpen)
287 else if Map.member name aliases then
288 Result.throw region $ Error.ExportOpenAlias name
289 else
290 Result.throw region $ Error.ExportNotFound Error.BadType name $
291 Map.keys unions ++ Map.keys aliases
293 Src.Upper name Src.Private ->
294 if Map.member name unions then
295 Result.ok (Dups.info name region () Can.ExportUnionClosed)
296 else if Map.member name aliases then
297 Result.ok (Dups.info name region () Can.ExportAlias)
298 else
299 Result.throw region $ Error.ExportNotFound Error.BadType name $
300 Map.keys unions ++ Map.keys aliases
303checkPorts :: Can.Effects -> N.Name -> Maybe [N.Name]
304checkPorts effects name =
305 case effects of
306 Can.NoEffects ->
307 Just []
309 Can.Ports ports ->
310 if Map.member name ports then Nothing else Just (Map.keys ports)
312 Can.Manager _ _ _ _ ->
313 Just []