git.iko.soy/elk
on dfaef18 help sign in
elk/src/Canonicalize/Module.hs
310 lines 8.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.Effects as Effects
18import qualified Canonicalize.Environment as Env
19import qualified Canonicalize.Environment.Dups as Dups
20import qualified Canonicalize.Expression as Expr
21import qualified Canonicalize.Pattern as Pattern
22import qualified Canonicalize.Type as Type
23import qualified Elm.Interface as I
24import qualified Elm.Name as N
25import qualified Elm.Package as Pkg
26import qualified Reporting.Annotation as A
27import qualified Reporting.Error.Canonicalize as Error
28import qualified Reporting.Region as R
29import qualified Reporting.Result as Result
30import qualified Reporting.Warning as Warning
34-- RESULT
37type Result a =
38 Result.Result () Warning.Warning Error.Error a
42-- MODULES
45canonicalize
46 :: Pkg.Name
47 -> Map.Map N.Name ModuleName.Canonical
48 -> I.Interfaces
49 -> Valid.Module
50 -> Result Can.Module
51canonicalize pkg importDict interfaces module_ =
52 do env <- Env.create pkg importDict interfaces module_
53 let (Valid.Module name _ _ exports _ decls unions aliases binops effects) = module_
54 (cdecls, cunions, caliases) <-
55 (,,)
56 <$> canonicalizeDecls env decls
57 <*> (Map.fromList <$> traverse (canonicalizeUnion env) unions)
58 <*> (Map.fromList <$> traverse (canonicalizeAlias env) aliases)
60 let cbinops = Map.fromList (map canonicalizeBinop binops)
61 ceffects <- Effects.canonicalize env cunions effects
62 cexports <- canonicalizeExports decls cunions caliases cbinops ceffects exports
64 let home = ModuleName.Canonical pkg name
65 let docs = toDocs module_
66 return $ Can.Module home docs cexports cdecls cunions caliases cbinops ceffects
70-- DOCUMENTATION
73toDocs :: Valid.Module -> A.Located (Maybe Can.Docs)
74toDocs (Valid.Module _ (A.A region maybeOverview) comments _ _ _ _ _ _ _) =
75 case maybeOverview of
76 Nothing ->
77 A.A region Nothing
79 Just overview ->
80 A.A region (Just (Can.Docs overview comments))
84-- CANONICALIZE ALIAS
87canonicalizeAlias :: Env.Env -> Valid.Alias -> Result ( N.Name, Can.Alias )
88canonicalizeAlias env (Valid.Alias (A.A _ name) args tipe) =
89 do ctipe <- Type.canonicalize env tipe
90 return (name, Can.Alias (map A.drop args) ctipe (toRecordCtorInfo tipe))
93toRecordCtorInfo :: Type.Raw -> Maybe [N.Name]
94toRecordCtorInfo (A.A _ tipe) =
95 case tipe of
96 Type.RRecord fields Nothing ->
97 Just (map (A.drop . fst) fields)
99 _ ->
100 Nothing
104-- CANONICALIZE UNION
107canonicalizeUnion :: Env.Env -> Valid.Union -> Result ( N.Name, Can.Union )
108canonicalizeUnion env (Valid.Union (A.A _ name) args ctors) =
109 let
110 canonicalizeCtor (A.A _ ctor, tipes) =
111 do ctipes <- traverse (Type.canonicalize env) tipes
112 return (ctor, ctipes)
113 in
114 do cctors <- traverse canonicalizeCtor ctors
115 return ( name, Can.Union (map A.drop args) cctors )
119-- CANONICALIZE BINOP
122canonicalizeBinop :: Valid.Binop -> ( N.Name, Can.Binop )
123canonicalizeBinop (Valid.Binop (A.A _ op) associativity precedence func) =
124 ( op, Can.Binop_ associativity precedence func )
128-- CANONICALIZE DECLARATIONS
131canonicalizeDecls :: Env.Env -> [A.Located Valid.Decl] -> Result Can.Decls
132canonicalizeDecls env decls =
133 do nodes <- traverse (toNode env) decls
134 detectCycles (Graph.stronglyConnComp nodes)
137detectCycles :: [Graph.SCC Decl] -> Result Can.Decls
138detectCycles sccs =
139 case sccs of
140 [] ->
141 Result.ok Can.SaveTheEnvironment
143 scc : otherSccs ->
144 case scc of
145 Graph.AcyclicSCC decl ->
146 Can.Declare (toCanDecl decl)
147 <$> detectCycles otherSccs
149 Graph.CyclicSCC [] ->
150 detectCycles otherSccs
152 Graph.CyclicSCC (decl:decls) ->
153 do detectBadCycles decl decls
154 Can.DeclareRec (toCanDecl decl) (map toCanDecl decls)
155 <$> detectCycles otherSccs
158toNode :: Env.Env -> A.Located Valid.Decl -> Result (Decl, N.Name, [N.Name])
159toNode env (A.A region (Valid.Decl name@(A.A _ key) args body tipe)) =
160 case args of
161 [] ->
162 do ctipe <- traverse (Type.canonicalize env) tipe
163 (cbody, freeLocals) <- Expr.removeLocals Warning.Pattern Map.empty $
164 Expr.canonicalize env body
165 return (Value region name cbody ctipe, key, Set.toList freeLocals)
167 _ ->
168 do ctipe <- traverse (Type.canonicalize env) tipe
169 cargs@(Can.Args _ destructors) <- Pattern.canonicalizeArgs env args
170 newEnv <- Env.addLocals destructors env
171 (cbody, freeLocals) <- Expr.removeLocals Warning.Pattern destructors $
172 Expr.canonicalize newEnv body
173 return (Function key cargs cbody ctipe, key, Set.toList freeLocals)
176data Decl
177 = Value R.Region (A.Located N.Name) Can.Expr (Maybe Type.Canonical)
178 | Function N.Name Can.Args Can.Expr (Maybe Type.Canonical)
181toCanDecl :: Decl -> Can.Decl
182toCanDecl decl =
183 case decl of
184 Value _ (A.A _ name) body tipe ->
185 Can.Value name body tipe
187 Function name args body tipe ->
188 Can.Function name args body tipe
191detectBadCycles :: Decl -> [Decl] -> Result ()
192detectBadCycles decl decls =
193 case traverse detectBadCyclesHelp (decl:decls) of
194 Nothing ->
195 Result.ok ()
197 Just valueCycle ->
198 case valueCycle of
199 [] ->
200 Result.ok ()
202 (declRegion, A.A region name) : otherInfo ->
203 let otherNames = map (A.drop . snd) otherInfo in
204 Result.throw declRegion (Error.RecursiveDecl region name otherNames)
207detectBadCyclesHelp :: Decl -> Maybe (R.Region, A.Located N.Name)
208detectBadCyclesHelp decl =
209 case decl of
210 Value region name _ _ ->
211 Just (region, name)
213 Function _ _ _ _ ->
214 Nothing
218-- CANONICALIZE EXPORTS
221canonicalizeExports
222 :: [A.Located Valid.Decl]
223 -> Map.Map N.Name union
224 -> Map.Map N.Name alias
225 -> Map.Map N.Name binop
226 -> Can.Effects
227 -> Src.Exposing
228 -> Result Can.Exports
229canonicalizeExports decls unions aliases binops effects exposing =
230 case exposing of
231 Src.Open ->
232 Result.ok Can.ExportEverything
234 Src.Explicit exposeds ->
235 do let names = Map.fromList (map declToName decls)
236 infos <- traverse (checkExposed names unions aliases binops effects) exposeds
237 let toError name () () = Error.ExportDuplicate name
238 Can.Export <$> Dups.detect toError infos
241declToName :: A.Located Valid.Decl -> (N.Name, Can.Export)
242declToName (A.A _ (Valid.Decl (A.A _ name) _ _ _)) =
243 (name, Can.ExportValue)
246checkExposed
247 :: Map.Map N.Name decl
248 -> Map.Map N.Name union
249 -> Map.Map N.Name alias
250 -> Map.Map N.Name binop
251 -> Can.Effects
252 -> A.Located Src.Exposed
253 -> Result (N.Name, [Dups.Info () Can.Export])
254checkExposed decls unions aliases binops effects (A.A region exposed) =
255 case exposed of
256 Src.Lower name ->
257 if Map.member name decls then
258 Result.ok (Dups.info name region () Can.ExportValue)
259 else
260 case checkPorts effects name of
261 Nothing ->
262 Result.ok (Dups.info name region () Can.ExportPort)
264 Just ports ->
265 Result.throw region $ Error.ExportNotFound Error.BadVar name $
266 ports ++ Map.keys decls
268 Src.Operator name ->
269 if Map.member name binops then
270 Result.ok (Dups.info name region () Can.ExportBinop)
271 else
272 Result.throw region $ Error.ExportNotFound Error.BadOp name $
273 Map.keys binops
275 Src.Upper name Src.Public ->
276 if Map.member name unions then
277 Result.ok (Dups.info name region () Can.ExportUnionOpen)
278 else if Map.member name aliases then
279 Result.throw region $ Error.ExportOpenAlias name
280 else
281 Result.throw region $ Error.ExportNotFound Error.BadType name $
282 Map.keys unions ++ Map.keys aliases
284 Src.Upper name Src.Private ->
285 if Map.member name unions then
286 Result.ok (Dups.info name region () Can.ExportUnionClosed)
287 else if Map.member name aliases then
288 Result.ok (Dups.info name region () Can.ExportAlias)
289 else
290 Result.throw region $ Error.ExportNotFound Error.BadType name $
291 Map.keys unions ++ Map.keys aliases
294checkPorts :: Can.Effects -> N.Name -> Maybe [N.Name]
295checkPorts effects name =
296 case effects of
297 Can.NoEffects ->
298 Just []
300 Can.Ports ports ->
301 if Map.member name ports then Nothing else Just (Map.keys ports)
303 Can.Cmd _ ->
304 Just []
306 Can.Sub _ ->
307 Just []
309 Can.Fx _ _ ->
310 Just []