git.iko.soy/elk
on feb5ece help sign in
elk/src/Canonicalize/Module.hs
344 lines 9.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
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.Result as Result
30import qualified Reporting.Warning as W
34-- RESULT
37type Result i w a =
38 Result.Result i w Error.Error a
42-- MODULES
45canonicalize
46 :: Pkg.Name
47 -> Map.Map N.Name ModuleName.Canonical
48 -> I.Interfaces
49 -> Valid.Module
50 -> Result i [W.Warning] Can.Module
51canonicalize pkg importDict interfaces module_@(Valid.Module name _ _ exports imports decls unions aliases binops effects) =
52 do let home = ModuleName.Canonical pkg name
54 startEnv <- Local.addVarsAndTypes module_ =<<
55 Foreign.createInitialEnv home importDict interfaces imports
57 (cunions, caliases) <-
58 (,)
59 <$> (Map.fromList <$> traverse (canonicalizeUnion startEnv) unions)
60 <*> (Map.fromList <$> traverse (canonicalizeAlias startEnv) aliases)
62 let finalEnv = Local.addPatterns cunions startEnv
63 let cbinops = Map.fromList (map canonicalizeBinop binops)
65 (cdecls, ceffects) <-
66 (,)
67 <$> canonicalizeDecls finalEnv decls
68 <*> Effects.canonicalize finalEnv decls cunions effects
70 cexports <- canonicalizeExports decls cunions caliases cbinops ceffects exports
72 let docs = toDocs module_
73 return $ Can.Module home docs cexports cdecls cunions caliases cbinops ceffects
77-- DOCUMENTATION
80toDocs :: Valid.Module -> A.Located (Maybe Can.Docs)
81toDocs (Valid.Module _ (A.At region maybeOverview) comments _ _ _ _ _ _ _) =
82 case maybeOverview of
83 Nothing ->
84 A.At region Nothing
86 Just overview ->
87 A.At region (Just (Can.Docs overview comments))
91-- CANONICALIZE ALIAS
94canonicalizeAlias :: Env.Env -> Valid.Alias -> Result i w ( N.Name, Can.Alias )
95canonicalizeAlias env (Valid.Alias (A.At _ name) args tipe) =
96 do ctipe <- Type.canonicalize env tipe
97 return (name, Can.Alias (map A.toValue args) ctipe (toRecordCtorInfo tipe))
100toRecordCtorInfo :: Src.Type -> Maybe [N.Name]
101toRecordCtorInfo (A.At _ tipe) =
102 case tipe of
103 Src.TRecord fields Nothing ->
104 Just (map (A.toValue . fst) fields)
106 _ ->
107 Nothing
111-- CANONICALIZE UNION
114canonicalizeUnion :: Env.Env -> Valid.Union -> Result i w ( N.Name, Can.Union )
115canonicalizeUnion env (Valid.Union (A.At _ name) args ctors) =
116 let
117 canonicalizeCtor (A.At _ ctor, tipes) =
118 do ctipes <- traverse (Type.canonicalize env) tipes
119 return (ctor, ctipes)
120 in
121 do cctors <- traverse canonicalizeCtor ctors
122 return ( name, Can.Union (map A.toValue args) cctors )
126-- CANONICALIZE BINOP
129canonicalizeBinop :: Valid.Binop -> ( N.Name, Can.Binop )
130canonicalizeBinop (Valid.Binop (A.At _ op) associativity precedence func) =
131 ( op, Can.Binop_ associativity precedence func )
135-- DECLARATIONS / CYCLE DETECTION
136--
137-- There are two phases of cycle detection:
138--
139-- 1. Detect cycles using ALL dependencies => needed for type inference
140-- 2. Detect cycles using DIRECT dependencies => nonterminating recursion
141--
144canonicalizeDecls :: Env.Env -> [A.Located Valid.Decl] -> Result i [W.Warning] Can.Decls
145canonicalizeDecls env decls =
146 do nodes <- traverse (toNodeOne env) decls
147 detectCycles (Graph.stronglyConnComp nodes)
150detectCycles :: [Graph.SCC NodeTwo] -> Result i w Can.Decls
151detectCycles sccs =
152 case sccs of
153 [] ->
154 Result.ok Can.SaveTheEnvironment
156 scc : otherSccs ->
157 case scc of
158 Graph.AcyclicSCC (def, _, _) ->
159 Can.Declare def <$> detectCycles otherSccs
161 Graph.CyclicSCC [] ->
162 detectCycles otherSccs
164 Graph.CyclicSCC subNodes ->
165 Can.DeclareRec
166 <$> traverse detectBadCycles (Graph.stronglyConnComp subNodes)
167 <*> detectCycles otherSccs
170detectBadCycles :: Graph.SCC Can.Def -> Result i w Can.Def
171detectBadCycles scc =
172 case scc of
173 Graph.AcyclicSCC def ->
174 Result.ok def
176 Graph.CyclicSCC cyclicValueDefs ->
177 Result.throw (Error.RecursiveDecl cyclicValueDefs)
181-- DECLARATIONS / CYCLE DETECTION SETUP
182--
183-- toNodeOne and toNodeTwo set up nodes for the two cycle detection phases.
184--
186-- Phase one nodes track ALL dependencies.
187-- This allows us to find cyclic values for type inference.
188type NodeOne =
189 (NodeTwo, N.Name, [N.Name])
192-- Phase two nodes track DIRECT dependencies.
193-- This allows us to detect cycles that definitely do not terminate.
194type NodeTwo =
195 (Can.Def, N.Name, [N.Name])
198toNodeOne :: Env.Env -> A.Located Valid.Decl -> Result i [W.Warning] NodeOne
199toNodeOne env (A.At _ (Valid.Decl aname@(A.At _ name) srcArgs body maybeType)) =
200 case maybeType of
201 Nothing ->
202 do (args, argBindings) <-
203 Pattern.verify (Error.DPFuncArgs name) $
204 traverse (Pattern.canonicalize env) srcArgs
206 newEnv <-
207 Env.addLocals argBindings env
209 (cbody, freeLocals) <-
210 Expr.verifyBindings W.Pattern argBindings (Expr.canonicalize newEnv body)
212 let def = Can.Def aname args cbody
213 return
214 ( toNodeTwo name srcArgs def freeLocals
215 , name
216 , Map.keys freeLocals
217 )
219 Just srcType ->
220 do (Can.Forall freeVars tipe) <- Type.toAnnotation env srcType
222 ((args,resultType), argBindings) <-
223 Pattern.verify (Error.DPFuncArgs name) $
224 Expr.gatherTypedArgs env name srcArgs tipe Index.first []
226 newEnv <-
227 Env.addLocals argBindings env
229 (cbody, freeLocals) <-
230 Expr.verifyBindings W.Pattern argBindings (Expr.canonicalize newEnv body)
232 let def = Can.TypedDef aname freeVars args cbody resultType
233 return
234 ( toNodeTwo name srcArgs def freeLocals
235 , name
236 , Map.keys freeLocals
237 )
240toNodeTwo :: N.Name -> [arg] -> Can.Def -> Expr.FreeLocals -> NodeTwo
241toNodeTwo name args def freeLocals =
242 case args of
243 [] ->
244 (def, name, Map.foldrWithKey addDirects [] freeLocals)
246 _ ->
247 (def, name, [])
250addDirects :: N.Name -> Expr.Uses -> [N.Name] -> [N.Name]
251addDirects name (Expr.Uses directUses _) directDeps =
252 if directUses > 0 then
253 name:directDeps
254 else
255 directDeps
259-- CANONICALIZE EXPORTS
262canonicalizeExports
263 :: [A.Located Valid.Decl]
264 -> Map.Map N.Name union
265 -> Map.Map N.Name alias
266 -> Map.Map N.Name binop
267 -> Can.Effects
268 -> Src.Exposing
269 -> Result i w Can.Exports
270canonicalizeExports decls unions aliases binops effects exposing =
271 case exposing of
272 Src.Open ->
273 Result.ok Can.ExportEverything
275 Src.Explicit exposeds ->
276 do let names = Map.fromList (map declToName decls)
277 infos <- traverse (checkExposed names unions aliases binops effects) exposeds
278 Can.Export <$> Dups.detect Error.ExportDuplicate (Dups.unions infos)
281declToName :: A.Located Valid.Decl -> ( N.Name, () )
282declToName (A.At _ (Valid.Decl (A.At _ name) _ _ _)) =
283 ( name, () )
286checkExposed
287 :: Map.Map N.Name decl
288 -> Map.Map N.Name union
289 -> Map.Map N.Name alias
290 -> Map.Map N.Name binop
291 -> Can.Effects
292 -> A.Located Src.Exposed
293 -> Result i w (Dups.Dict () Can.Export)
294checkExposed decls unions aliases binops effects (A.At region exposed) =
295 case exposed of
296 Src.Lower name ->
297 if Map.member name decls then
298 Result.ok (Dups.one name region () Can.ExportValue)
299 else
300 case checkPorts effects name of
301 Nothing ->
302 Result.ok (Dups.one name region () Can.ExportPort)
304 Just ports ->
305 Result.throw $ Error.ExportNotFound region Error.BadVar name $
306 ports ++ Map.keys decls
308 Src.Operator name ->
309 if Map.member name binops then
310 Result.ok (Dups.one name region () Can.ExportBinop)
311 else
312 Result.throw $ Error.ExportNotFound region Error.BadOp name $
313 Map.keys binops
315 Src.Upper name Src.Public ->
316 if Map.member name unions then
317 Result.ok (Dups.one name region () Can.ExportUnionOpen)
318 else if Map.member name aliases then
319 Result.throw $ Error.ExportOpenAlias region name
320 else
321 Result.throw $ Error.ExportNotFound region Error.BadType name $
322 Map.keys unions ++ Map.keys aliases
324 Src.Upper name Src.Private ->
325 if Map.member name unions then
326 Result.ok (Dups.one name region () Can.ExportUnionClosed)
327 else if Map.member name aliases then
328 Result.ok (Dups.one name region () Can.ExportAlias)
329 else
330 Result.throw $ Error.ExportNotFound region Error.BadType name $
331 Map.keys unions ++ Map.keys aliases
334checkPorts :: Can.Effects -> N.Name -> Maybe [N.Name]
335checkPorts effects name =
336 case effects of
337 Can.NoEffects ->
338 Just []
340 Can.Ports ports ->
341 if Map.member name ports then Nothing else Just (Map.keys ports)
343 Can.Manager _ _ _ _ ->
344 Just []