git.iko.soy/elk
on 2edbe13 help sign in
elk/compiler/src/Canonicalize/Module.hs
296 lines 8.7 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.Name as Name
12import qualified AST.Canonical as Can
13import qualified AST.Source as Src
14import qualified Canonicalize.Effects as Effects
15import qualified Canonicalize.Environment as Env
16import qualified Canonicalize.Environment.Dups as Dups
17import qualified Canonicalize.Environment.Foreign as Foreign
18import qualified Canonicalize.Environment.Local as Local
19import qualified Canonicalize.Expression as Expr
20import qualified Canonicalize.Pattern as Pattern
21import qualified Canonicalize.Type as Type
22import qualified Data.Index as Index
23import qualified Elm.Interface as I
24import qualified Elm.ModuleName as ModuleName
25import qualified Elm.Package as Pkg
26import qualified Reporting.Annotation as A
27import qualified Reporting.Error.Canonicalize as Error
28import qualified Reporting.Result as Result
29import qualified Reporting.Warning as W
33-- RESULT
36type Result i w a =
37 Result.Result i w Error.Error a
41-- MODULES
44canonicalize :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Result i [W.Warning] Can.Module
45canonicalize pkg ifaces modul@(Src.Module _ exports docs imports values _ _ binops effects) =
46 do let home = ModuleName.Canonical pkg (Src.getName modul)
47 let cbinops = Map.fromList (map canonicalizeBinop binops)
49 (env, cunions, caliases) <-
50 Local.add modul =<<
51 Foreign.createInitialEnv home ifaces imports
53 cvalues <- canonicalizeValues env values
54 ceffects <- Effects.canonicalize env values cunions effects
55 cexports <- canonicalizeExports values cunions caliases cbinops ceffects exports
57 return $ Can.Module home cexports docs cvalues cunions caliases cbinops ceffects
61-- CANONICALIZE BINOP
64canonicalizeBinop :: A.Located Src.Infix -> ( Name.Name, Can.Binop )
65canonicalizeBinop (A.At _ (Src.Infix op associativity precedence func)) =
66 ( op, Can.Binop_ associativity precedence func )
70-- DECLARATIONS / CYCLE DETECTION
71--
72-- There are two phases of cycle detection:
73--
74-- 1. Detect cycles using ALL dependencies => needed for type inference
75-- 2. Detect cycles using DIRECT dependencies => nonterminating recursion
76--
79canonicalizeValues :: Env.Env -> [A.Located Src.Value] -> Result i [W.Warning] Can.Decls
80canonicalizeValues env values =
81 do nodes <- traverse (toNodeOne env) values
82 detectCycles (Graph.stronglyConnComp nodes)
85detectCycles :: [Graph.SCC NodeTwo] -> Result i w Can.Decls
86detectCycles sccs =
87 case sccs of
88 [] ->
89 Result.ok Can.SaveTheEnvironment
91 scc : otherSccs ->
92 case scc of
93 Graph.AcyclicSCC (def, _, _) ->
94 Can.Declare def <$> detectCycles otherSccs
96 Graph.CyclicSCC subNodes ->
97 do defs <- traverse detectBadCycles (Graph.stronglyConnComp subNodes)
98 case defs of
99 [] -> detectCycles otherSccs
100 d:ds -> Can.DeclareRec d ds <$> detectCycles otherSccs
103detectBadCycles :: Graph.SCC Can.Def -> Result i w Can.Def
104detectBadCycles scc =
105 case scc of
106 Graph.AcyclicSCC def ->
107 Result.ok def
109 Graph.CyclicSCC [] ->
110 error "The definition of Data.Graph.SCC should not allow empty CyclicSCC!"
112 Graph.CyclicSCC (def:defs) ->
113 let
114 (A.At region name) = extractDefName def
115 names = map (A.toValue . extractDefName) defs
116 in
117 Result.throw (Error.RecursiveDecl region name names)
120extractDefName :: Can.Def -> A.Located Name.Name
121extractDefName def =
122 case def of
123 Can.Def name _ _ -> name
124 Can.TypedDef name _ _ _ _ -> name
128-- DECLARATIONS / CYCLE DETECTION SETUP
129--
130-- toNodeOne and toNodeTwo set up nodes for the two cycle detection phases.
131--
133-- Phase one nodes track ALL dependencies.
134-- This allows us to find cyclic values for type inference.
135type NodeOne =
136 (NodeTwo, Name.Name, [Name.Name])
139-- Phase two nodes track DIRECT dependencies.
140-- This allows us to detect cycles that definitely do not terminate.
141type NodeTwo =
142 (Can.Def, Name.Name, [Name.Name])
145toNodeOne :: Env.Env -> A.Located Src.Value -> Result i [W.Warning] NodeOne
146toNodeOne env (A.At _ (Src.Value aname@(A.At _ name) srcArgs body maybeType)) =
147 case maybeType of
148 Nothing ->
149 do (args, argBindings) <-
150 Pattern.verify (Error.DPFuncArgs name) $
151 traverse (Pattern.canonicalize env) srcArgs
153 newEnv <-
154 Env.addLocals argBindings env
156 (cbody, freeLocals) <-
157 Expr.verifyBindings W.Pattern argBindings (Expr.canonicalize newEnv body)
159 let def = Can.Def aname args cbody
160 return
161 ( toNodeTwo name srcArgs def freeLocals
162 , name
163 , Map.keys freeLocals
164 )
166 Just srcType ->
167 do (Can.Forall freeVars tipe) <- Type.toAnnotation env srcType
169 ((args,resultType), argBindings) <-
170 Pattern.verify (Error.DPFuncArgs name) $
171 Expr.gatherTypedArgs env name srcArgs tipe Index.first []
173 newEnv <-
174 Env.addLocals argBindings env
176 (cbody, freeLocals) <-
177 Expr.verifyBindings W.Pattern argBindings (Expr.canonicalize newEnv body)
179 let def = Can.TypedDef aname freeVars args cbody resultType
180 return
181 ( toNodeTwo name srcArgs def freeLocals
182 , name
183 , Map.keys freeLocals
184 )
187toNodeTwo :: Name.Name -> [arg] -> Can.Def -> Expr.FreeLocals -> NodeTwo
188toNodeTwo name args def freeLocals =
189 case args of
190 [] ->
191 (def, name, Map.foldrWithKey addDirects [] freeLocals)
193 _ ->
194 (def, name, [])
197addDirects :: Name.Name -> Expr.Uses -> [Name.Name] -> [Name.Name]
198addDirects name (Expr.Uses directUses _) directDeps =
199 if directUses > 0 then
200 name:directDeps
201 else
202 directDeps
206-- CANONICALIZE EXPORTS
209canonicalizeExports
210 :: [A.Located Src.Value]
211 -> Map.Map Name.Name union
212 -> Map.Map Name.Name alias
213 -> Map.Map Name.Name binop
214 -> Can.Effects
215 -> A.Located Src.Exposing
216 -> Result i w Can.Exports
217canonicalizeExports values unions aliases binops effects (A.At region exposing) =
218 case exposing of
219 Src.Open ->
220 Result.ok (Can.ExportEverything region)
222 Src.Explicit exposeds ->
223 do let names = Map.fromList (map valueToName values)
224 infos <- traverse (checkExposed names unions aliases binops effects) exposeds
225 Can.Export <$> Dups.detect Error.ExportDuplicate (Dups.unions infos)
228valueToName :: A.Located Src.Value -> ( Name.Name, () )
229valueToName (A.At _ (Src.Value (A.At _ name) _ _ _)) =
230 ( name, () )
233checkExposed
234 :: Map.Map Name.Name value
235 -> Map.Map Name.Name union
236 -> Map.Map Name.Name alias
237 -> Map.Map Name.Name binop
238 -> Can.Effects
239 -> Src.Exposed
240 -> Result i w (Dups.Dict (A.Located Can.Export))
241checkExposed values unions aliases binops effects exposed =
242 case exposed of
243 Src.Lower (A.At region name) ->
244 if Map.member name values then
245 ok name region Can.ExportValue
246 else
247 case checkPorts effects name of
248 Nothing ->
249 ok name region Can.ExportPort
251 Just ports ->
252 Result.throw $ Error.ExportNotFound region Error.BadVar name $
253 ports ++ Map.keys values
255 Src.Operator region name ->
256 if Map.member name binops then
257 ok name region Can.ExportBinop
258 else
259 Result.throw $ Error.ExportNotFound region Error.BadOp name $
260 Map.keys binops
262 Src.Upper (A.At region name) (Src.Public dotDotRegion) ->
263 if Map.member name unions then
264 ok name region Can.ExportUnionOpen
265 else if Map.member name aliases then
266 Result.throw $ Error.ExportOpenAlias dotDotRegion name
267 else
268 Result.throw $ Error.ExportNotFound region Error.BadType name $
269 Map.keys unions ++ Map.keys aliases
271 Src.Upper (A.At region name) Src.Private ->
272 if Map.member name unions then
273 ok name region Can.ExportUnionClosed
274 else if Map.member name aliases then
275 ok name region Can.ExportAlias
276 else
277 Result.throw $ Error.ExportNotFound region Error.BadType name $
278 Map.keys unions ++ Map.keys aliases
281checkPorts :: Can.Effects -> Name.Name -> Maybe [Name.Name]
282checkPorts effects name =
283 case effects of
284 Can.NoEffects ->
285 Just []
287 Can.Ports ports ->
288 if Map.member name ports then Nothing else Just (Map.keys ports)
290 Can.Manager _ _ _ _ ->
291 Just []
294ok :: Name.Name -> A.Region -> Can.Export -> Result i w (Dups.Dict (A.Located Can.Export))
295ok name region export =
296 Result.ok $ Dups.one name region (A.At region export)