git.iko.soy/elk
on ea77dcf help sign in
elk/src/Canonicalize/Module.hs
312 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.Canonical as Can
13import qualified AST.Source as Src
14import qualified AST.Valid as Valid
15import qualified AST.Module.Name as ModuleName
16import qualified Canonicalize.Effects as Effects
17import qualified Canonicalize.Environment as Env
18import qualified Canonicalize.Environment.Dups as Dups
19import qualified Canonicalize.Environment.Foreign as Foreign
20import qualified Canonicalize.Environment.Local as Local
21import qualified Canonicalize.Expression as Expr
22import qualified Canonicalize.Pattern as Pattern
23import qualified Canonicalize.Type as Type
24import qualified Elm.Interface as I
25import qualified Elm.Name as N
26import qualified Elm.Package as Pkg
27import qualified Reporting.Annotation as A
28import qualified Reporting.Error.Canonicalize as Error
29import qualified Reporting.Region as R
30import qualified Reporting.Result as Result
31import qualified Reporting.Warning as Warning
35-- RESULT
38type Result a =
39 Result.Result () Warning.Warning Error.Error a
43-- MODULES
46canonicalize
47 :: Pkg.Name
48 -> Map.Map N.Name ModuleName.Canonical
49 -> I.Interfaces
50 -> Valid.Module
51 -> Result Can.Module
52canonicalize pkg importDict interfaces module_@(Valid.Module name _ _ exports imports decls unions aliases binops effects) =
53 do let home = ModuleName.Canonical pkg name
55 startEnv <- Local.addVarsAndTypes module_ =<<
56 Foreign.createInitialEnv home importDict interfaces imports
58 (cunions, caliases) <-
59 (,)
60 <$> (Map.fromList <$> traverse (canonicalizeUnion startEnv) unions)
61 <*> (Map.fromList <$> traverse (canonicalizeAlias startEnv) aliases)
63 let finalEnv = Local.addPatterns cunions startEnv
64 let cbinops = Map.fromList (map canonicalizeBinop binops)
66 (cdecls, ceffects) <-
67 (,)
68 <$> canonicalizeDecls finalEnv decls
69 <*> Effects.canonicalize finalEnv decls cunions effects
71 cexports <- canonicalizeExports decls cunions caliases cbinops ceffects exports
73 let docs = toDocs module_
74 return $ Can.Module home docs cexports cdecls cunions caliases cbinops ceffects
78-- DOCUMENTATION
81toDocs :: Valid.Module -> A.Located (Maybe Can.Docs)
82toDocs (Valid.Module _ (A.A region maybeOverview) comments _ _ _ _ _ _ _) =
83 case maybeOverview of
84 Nothing ->
85 A.A region Nothing
87 Just overview ->
88 A.A region (Just (Can.Docs overview comments))
92-- CANONICALIZE ALIAS
95canonicalizeAlias :: Env.Env -> Valid.Alias -> Result ( N.Name, Can.Alias )
96canonicalizeAlias env (Valid.Alias (A.A _ name) args tipe) =
97 do ctipe <- Type.canonicalize env tipe
98 return (name, Can.Alias (map A.drop args) ctipe (toRecordCtorInfo tipe))
101toRecordCtorInfo :: Src.Type -> Maybe [N.Name]
102toRecordCtorInfo (A.A _ tipe) =
103 case tipe of
104 Src.TRecord fields Nothing ->
105 Just (map (A.drop . fst) fields)
107 _ ->
108 Nothing
112-- CANONICALIZE UNION
115canonicalizeUnion :: Env.Env -> Valid.Union -> Result ( N.Name, Can.Union )
116canonicalizeUnion env (Valid.Union (A.A _ name) args ctors) =
117 let
118 canonicalizeCtor (A.A _ ctor, tipes) =
119 do ctipes <- traverse (Type.canonicalize env) tipes
120 return (ctor, ctipes)
121 in
122 do cctors <- traverse canonicalizeCtor ctors
123 return ( name, Can.Union (map A.drop args) cctors )
127-- CANONICALIZE BINOP
130canonicalizeBinop :: Valid.Binop -> ( N.Name, Can.Binop )
131canonicalizeBinop (Valid.Binop (A.A _ op) associativity precedence func) =
132 ( op, Can.Binop_ associativity precedence func )
136-- CANONICALIZE DECLARATIONS
139canonicalizeDecls :: Env.Env -> [A.Located Valid.Decl] -> Result Can.Decls
140canonicalizeDecls env decls =
141 do nodes <- traverse (toNode env) decls
142 detectCycles (Graph.stronglyConnComp nodes)
145detectCycles :: [Graph.SCC Decl] -> Result Can.Decls
146detectCycles sccs =
147 case sccs of
148 [] ->
149 Result.ok Can.SaveTheEnvironment
151 scc : otherSccs ->
152 case scc of
153 Graph.AcyclicSCC decl ->
154 Can.Declare (toCanDecl decl)
155 <$> detectCycles otherSccs
157 Graph.CyclicSCC [] ->
158 detectCycles otherSccs
160 Graph.CyclicSCC (decl:decls) ->
161 do detectBadCycles decl decls
162 Can.DeclareRec (toCanDecl decl) (map toCanDecl decls)
163 <$> detectCycles otherSccs
166toNode :: Env.Env -> A.Located Valid.Decl -> Result (Decl, N.Name, [N.Name])
167toNode env (A.A region (Valid.Decl name@(A.A _ key) args body tipe)) =
168 case args of
169 [] ->
170 do ctipe <- traverse (Type.canonicalize env) tipe
171 (cbody, freeLocals) <- Expr.removeLocals Warning.Pattern Map.empty $
172 Expr.canonicalize env body
173 return (Value region name cbody ctipe, key, Set.toList freeLocals)
175 _ ->
176 do ctipe <- traverse (Type.canonicalize env) tipe
177 cargs@(Can.Args _ destructors) <- Pattern.canonicalizeArgs env args
178 newEnv <- Env.addLocals destructors env
179 (cbody, freeLocals) <- Expr.removeLocals Warning.Pattern destructors $
180 Expr.canonicalize newEnv body
181 return (Function key cargs cbody ctipe, key, Set.toList freeLocals)
184data Decl
185 = Value R.Region (A.Located N.Name) Can.Expr (Maybe Can.Type)
186 | Function N.Name Can.Args Can.Expr (Maybe Can.Type)
189toCanDecl :: Decl -> Can.Decl
190toCanDecl decl =
191 case decl of
192 Value _ (A.A _ name) body tipe ->
193 Can.Value name body tipe
195 Function name args body tipe ->
196 Can.Function name args body tipe
199detectBadCycles :: Decl -> [Decl] -> Result ()
200detectBadCycles decl decls =
201 case traverse detectBadCyclesHelp (decl:decls) of
202 Nothing ->
203 Result.ok ()
205 Just valueCycle ->
206 case valueCycle of
207 [] ->
208 Result.ok ()
210 (declRegion, A.A region name) : otherInfo ->
211 let otherNames = map (A.drop . snd) otherInfo in
212 Result.throw declRegion (Error.RecursiveDecl region name otherNames)
215detectBadCyclesHelp :: Decl -> Maybe (R.Region, A.Located N.Name)
216detectBadCyclesHelp decl =
217 case decl of
218 Value region name _ _ ->
219 Just (region, name)
221 Function _ _ _ _ ->
222 Nothing
226-- CANONICALIZE EXPORTS
229canonicalizeExports
230 :: [A.Located Valid.Decl]
231 -> Map.Map N.Name union
232 -> Map.Map N.Name alias
233 -> Map.Map N.Name binop
234 -> Can.Effects
235 -> Src.Exposing
236 -> Result Can.Exports
237canonicalizeExports decls unions aliases binops effects exposing =
238 case exposing of
239 Src.Open ->
240 Result.ok Can.ExportEverything
242 Src.Explicit exposeds ->
243 do let names = Map.fromList (map declToName decls)
244 infos <- traverse (checkExposed names unions aliases binops effects) exposeds
245 let toError name () () = Error.ExportDuplicate name
246 Can.Export <$> Dups.detect toError infos
249declToName :: A.Located Valid.Decl -> ( N.Name, () )
250declToName (A.A _ (Valid.Decl (A.A _ name) _ _ _)) =
251 ( name, () )
254checkExposed
255 :: Map.Map N.Name decl
256 -> Map.Map N.Name union
257 -> Map.Map N.Name alias
258 -> Map.Map N.Name binop
259 -> Can.Effects
260 -> A.Located Src.Exposed
261 -> Result (N.Name, [Dups.Info () Can.Export])
262checkExposed decls unions aliases binops effects (A.A region exposed) =
263 case exposed of
264 Src.Lower name ->
265 if Map.member name decls then
266 Result.ok (Dups.info name region () Can.ExportValue)
267 else
268 case checkPorts effects name of
269 Nothing ->
270 Result.ok (Dups.info name region () Can.ExportPort)
272 Just ports ->
273 Result.throw region $ Error.ExportNotFound Error.BadVar name $
274 ports ++ Map.keys decls
276 Src.Operator name ->
277 if Map.member name binops then
278 Result.ok (Dups.info name region () Can.ExportBinop)
279 else
280 Result.throw region $ Error.ExportNotFound Error.BadOp name $
281 Map.keys binops
283 Src.Upper name Src.Public ->
284 if Map.member name unions then
285 Result.ok (Dups.info name region () Can.ExportUnionOpen)
286 else if Map.member name aliases then
287 Result.throw region $ Error.ExportOpenAlias name
288 else
289 Result.throw region $ Error.ExportNotFound Error.BadType name $
290 Map.keys unions ++ Map.keys aliases
292 Src.Upper name Src.Private ->
293 if Map.member name unions then
294 Result.ok (Dups.info name region () Can.ExportUnionClosed)
295 else if Map.member name aliases then
296 Result.ok (Dups.info name region () Can.ExportAlias)
297 else
298 Result.throw region $ Error.ExportNotFound Error.BadType name $
299 Map.keys unions ++ Map.keys aliases
302checkPorts :: Can.Effects -> N.Name -> Maybe [N.Name]
303checkPorts effects name =
304 case effects of
305 Can.NoEffects ->
306 Just []
308 Can.Ports ports ->
309 if Map.member name ports then Nothing else Just (Map.keys ports)
311 Can.Manager _ _ _ _ ->
312 Just []