git.iko.soy/elk
on ca2be8a help sign in
elk/src/Canonicalize/Module.hs
305 lines 8.6 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
11import qualified AST.Canonical as Can
12import qualified AST.Source as Src
13import qualified AST.Valid as Valid
14import qualified AST.Module.Name as ModuleName
15import qualified Canonicalize.Effects as Effects
16import qualified Canonicalize.Environment as Env
17import qualified Canonicalize.Environment.Dups as Dups
18import qualified Canonicalize.Environment.Foreign as Foreign
19import qualified Canonicalize.Environment.Local as Local
20import qualified Canonicalize.Expression as Expr
21import qualified Canonicalize.Pattern as Pattern
22import qualified Canonicalize.Type as Type
23import qualified Data.Index as Index
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 W
35-- RESULT
38type Result i w a =
39 Result.Result i w Error.Error a
43-- MODULES
46canonicalize
47 :: Pkg.Name
48 -> Map.Map N.Name ModuleName.Canonical
49 -> I.Interfaces
50 -> Valid.Module
51 -> Result i [W.Warning] Can.Module
52canonicalize pkg importDict interfaces module_@(Valid.Module name _ _ exports imports decls _ _ binops effects) =
53 do let home = ModuleName.Canonical pkg name
54 let cbinops = Map.fromList (map canonicalizeBinop binops)
56 (env, cunions, caliases) <-
57 Local.add module_ =<<
58 Foreign.createInitialEnv home importDict interfaces imports
60 cdecls <- canonicalizeDecls env decls
61 ceffects <- Effects.canonicalize env decls cunions effects
62 cexports <- canonicalizeExports decls cunions caliases cbinops ceffects exports
64 return $ Can.Module home (toDocs module_) cexports cdecls cunions caliases cbinops ceffects
68-- DOCUMENTATION
71toDocs :: Valid.Module -> Can.Docs
72toDocs (Valid.Module _ docs comments _ _ _ _ _ _ _) =
73 case docs of
74 Src.NoDocs region ->
75 Can.NoDocs region
77 Src.YesDocs region overview ->
78 Can.YesDocs region overview comments
82-- CANONICALIZE BINOP
85canonicalizeBinop :: Valid.Binop -> ( N.Name, Can.Binop )
86canonicalizeBinop (Valid.Binop op associativity precedence func) =
87 ( op, Can.Binop_ associativity precedence func )
91-- DECLARATIONS / CYCLE DETECTION
92--
93-- There are two phases of cycle detection:
94--
95-- 1. Detect cycles using ALL dependencies => needed for type inference
96-- 2. Detect cycles using DIRECT dependencies => nonterminating recursion
97--
100canonicalizeDecls :: Env.Env -> [A.Located Valid.Decl] -> Result i [W.Warning] Can.Decls
101canonicalizeDecls env decls =
102 do nodes <- traverse (toNodeOne env) decls
103 detectCycles (Graph.stronglyConnComp nodes)
106detectCycles :: [Graph.SCC NodeTwo] -> Result i w Can.Decls
107detectCycles sccs =
108 case sccs of
109 [] ->
110 Result.ok Can.SaveTheEnvironment
112 scc : otherSccs ->
113 case scc of
114 Graph.AcyclicSCC (def, _, _) ->
115 Can.Declare def <$> detectCycles otherSccs
117 Graph.CyclicSCC [] ->
118 detectCycles otherSccs
120 Graph.CyclicSCC subNodes ->
121 Can.DeclareRec
122 <$> traverse detectBadCycles (Graph.stronglyConnComp subNodes)
123 <*> detectCycles otherSccs
126detectBadCycles :: Graph.SCC Can.Def -> Result i w Can.Def
127detectBadCycles scc =
128 case scc of
129 Graph.AcyclicSCC def ->
130 Result.ok def
132 Graph.CyclicSCC cyclicValueDefs ->
133 Result.throw (Error.RecursiveDecl cyclicValueDefs)
137-- DECLARATIONS / CYCLE DETECTION SETUP
138--
139-- toNodeOne and toNodeTwo set up nodes for the two cycle detection phases.
140--
142-- Phase one nodes track ALL dependencies.
143-- This allows us to find cyclic values for type inference.
144type NodeOne =
145 (NodeTwo, N.Name, [N.Name])
148-- Phase two nodes track DIRECT dependencies.
149-- This allows us to detect cycles that definitely do not terminate.
150type NodeTwo =
151 (Can.Def, N.Name, [N.Name])
154toNodeOne :: Env.Env -> A.Located Valid.Decl -> Result i [W.Warning] NodeOne
155toNodeOne env (A.At _ (Valid.Decl aname@(A.At _ name) srcArgs body maybeType)) =
156 case maybeType of
157 Nothing ->
158 do (args, argBindings) <-
159 Pattern.verify (Error.DPFuncArgs name) $
160 traverse (Pattern.canonicalize env) srcArgs
162 newEnv <-
163 Env.addLocals argBindings env
165 (cbody, freeLocals) <-
166 Expr.verifyBindings W.Pattern argBindings (Expr.canonicalize newEnv body)
168 let def = Can.Def aname args cbody
169 return
170 ( toNodeTwo name srcArgs def freeLocals
171 , name
172 , Map.keys freeLocals
173 )
175 Just srcType ->
176 do (Can.Forall freeVars tipe) <- Type.toAnnotation env srcType
178 ((args,resultType), argBindings) <-
179 Pattern.verify (Error.DPFuncArgs name) $
180 Expr.gatherTypedArgs env name srcArgs tipe Index.first []
182 newEnv <-
183 Env.addLocals argBindings env
185 (cbody, freeLocals) <-
186 Expr.verifyBindings W.Pattern argBindings (Expr.canonicalize newEnv body)
188 let def = Can.TypedDef aname freeVars args cbody resultType
189 return
190 ( toNodeTwo name srcArgs def freeLocals
191 , name
192 , Map.keys freeLocals
193 )
196toNodeTwo :: N.Name -> [arg] -> Can.Def -> Expr.FreeLocals -> NodeTwo
197toNodeTwo name args def freeLocals =
198 case args of
199 [] ->
200 (def, name, Map.foldrWithKey addDirects [] freeLocals)
202 _ ->
203 (def, name, [])
206addDirects :: N.Name -> Expr.Uses -> [N.Name] -> [N.Name]
207addDirects name (Expr.Uses directUses _) directDeps =
208 if directUses > 0 then
209 name:directDeps
210 else
211 directDeps
215-- CANONICALIZE EXPORTS
218canonicalizeExports
219 :: [A.Located Valid.Decl]
220 -> Map.Map N.Name union
221 -> Map.Map N.Name alias
222 -> Map.Map N.Name binop
223 -> Can.Effects
224 -> A.Located Src.Exposing
225 -> Result i w Can.Exports
226canonicalizeExports decls unions aliases binops effects (A.At region exposing) =
227 case exposing of
228 Src.Open ->
229 Result.ok (Can.ExportEverything region)
231 Src.Explicit exposeds ->
232 do let names = Map.fromList (map declToName decls)
233 infos <- traverse (checkExposed names unions aliases binops effects) exposeds
234 Can.Export <$> Dups.detect Error.ExportDuplicate (Dups.unions infos)
237declToName :: A.Located Valid.Decl -> ( N.Name, () )
238declToName (A.At _ (Valid.Decl (A.At _ name) _ _ _)) =
239 ( name, () )
242checkExposed
243 :: Map.Map N.Name decl
244 -> Map.Map N.Name union
245 -> Map.Map N.Name alias
246 -> Map.Map N.Name binop
247 -> Can.Effects
248 -> A.Located Src.Exposed
249 -> Result i w (Dups.Dict (A.Located Can.Export))
250checkExposed decls unions aliases binops effects (A.At region exposed) =
251 case exposed of
252 Src.Lower name ->
253 if Map.member name decls then
254 ok name region Can.ExportValue
255 else
256 case checkPorts effects name of
257 Nothing ->
258 ok name region Can.ExportPort
260 Just ports ->
261 Result.throw $ Error.ExportNotFound region Error.BadVar name $
262 ports ++ Map.keys decls
264 Src.Operator name ->
265 if Map.member name binops then
266 ok name region Can.ExportBinop
267 else
268 Result.throw $ Error.ExportNotFound region Error.BadOp name $
269 Map.keys binops
271 Src.Upper name Src.Public ->
272 if Map.member name unions then
273 ok name region Can.ExportUnionOpen
274 else if Map.member name aliases then
275 Result.throw $ Error.ExportOpenAlias region name
276 else
277 Result.throw $ Error.ExportNotFound region Error.BadType name $
278 Map.keys unions ++ Map.keys aliases
280 Src.Upper name Src.Private ->
281 if Map.member name unions then
282 ok name region Can.ExportUnionClosed
283 else if Map.member name aliases then
284 ok name region Can.ExportAlias
285 else
286 Result.throw $ Error.ExportNotFound region Error.BadType name $
287 Map.keys unions ++ Map.keys aliases
290checkPorts :: Can.Effects -> N.Name -> Maybe [N.Name]
291checkPorts effects name =
292 case effects of
293 Can.NoEffects ->
294 Just []
296 Can.Ports ports ->
297 if Map.member name ports then Nothing else Just (Map.keys ports)
299 Can.Manager _ _ _ _ ->
300 Just []
303ok :: N.Name -> R.Region -> Can.Export -> Result i w (Dups.Dict (A.Located Can.Export))
304ok name region export =
305 Result.ok $ Dups.one name region (A.At region export)