git.iko.soy/elk
on 7dfbc30 help sign in
elk/src/Canonicalize/Module.hs
350 lines 9.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
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 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 -> Maybe (A.Located Can.Docs)
82toDocs (Valid.Module _ docs comments _ _ _ _ _ _ _) =
83 case docs of
84 Nothing ->
85 Nothing
87 Just (A.At region overview) ->
88 Just (A.At region (Can.Docs overview comments))
92-- CANONICALIZE ALIAS
95canonicalizeAlias :: Env.Env -> Valid.Alias -> Result i w ( N.Name, Can.Alias )
96canonicalizeAlias env (Valid.Alias (A.At _ name) args tipe) =
97 do ctipe <- Type.canonicalize env tipe
98 return (name, Can.Alias (map A.toValue args) ctipe (toRecordCtorInfo tipe))
101toRecordCtorInfo :: Src.Type -> Maybe [N.Name]
102toRecordCtorInfo (A.At _ tipe) =
103 case tipe of
104 Src.TRecord fields Nothing ->
105 Just (map (A.toValue . fst) fields)
107 _ ->
108 Nothing
112-- CANONICALIZE UNION
115canonicalizeUnion :: Env.Env -> Valid.Union -> Result i w ( N.Name, Can.Union )
116canonicalizeUnion env (Valid.Union (A.At _ name) args ctors) =
117 let
118 canonicalizeCtor (A.At _ 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.toValue args) cctors )
127-- CANONICALIZE BINOP
130canonicalizeBinop :: Valid.Binop -> ( N.Name, Can.Binop )
131canonicalizeBinop (Valid.Binop op associativity precedence func) =
132 ( op, Can.Binop_ associativity precedence func )
136-- DECLARATIONS / CYCLE DETECTION
137--
138-- There are two phases of cycle detection:
139--
140-- 1. Detect cycles using ALL dependencies => needed for type inference
141-- 2. Detect cycles using DIRECT dependencies => nonterminating recursion
142--
145canonicalizeDecls :: Env.Env -> [A.Located Valid.Decl] -> Result i [W.Warning] Can.Decls
146canonicalizeDecls env decls =
147 do nodes <- traverse (toNodeOne env) decls
148 detectCycles (Graph.stronglyConnComp nodes)
151detectCycles :: [Graph.SCC NodeTwo] -> Result i w Can.Decls
152detectCycles sccs =
153 case sccs of
154 [] ->
155 Result.ok Can.SaveTheEnvironment
157 scc : otherSccs ->
158 case scc of
159 Graph.AcyclicSCC (def, _, _) ->
160 Can.Declare def <$> detectCycles otherSccs
162 Graph.CyclicSCC [] ->
163 detectCycles otherSccs
165 Graph.CyclicSCC subNodes ->
166 Can.DeclareRec
167 <$> traverse detectBadCycles (Graph.stronglyConnComp subNodes)
168 <*> detectCycles otherSccs
171detectBadCycles :: Graph.SCC Can.Def -> Result i w Can.Def
172detectBadCycles scc =
173 case scc of
174 Graph.AcyclicSCC def ->
175 Result.ok def
177 Graph.CyclicSCC cyclicValueDefs ->
178 Result.throw (Error.RecursiveDecl cyclicValueDefs)
182-- DECLARATIONS / CYCLE DETECTION SETUP
183--
184-- toNodeOne and toNodeTwo set up nodes for the two cycle detection phases.
185--
187-- Phase one nodes track ALL dependencies.
188-- This allows us to find cyclic values for type inference.
189type NodeOne =
190 (NodeTwo, N.Name, [N.Name])
193-- Phase two nodes track DIRECT dependencies.
194-- This allows us to detect cycles that definitely do not terminate.
195type NodeTwo =
196 (Can.Def, N.Name, [N.Name])
199toNodeOne :: Env.Env -> A.Located Valid.Decl -> Result i [W.Warning] NodeOne
200toNodeOne env (A.At _ (Valid.Decl aname@(A.At _ name) srcArgs body maybeType)) =
201 case maybeType of
202 Nothing ->
203 do (args, argBindings) <-
204 Pattern.verify (Error.DPFuncArgs name) $
205 traverse (Pattern.canonicalize env) srcArgs
207 newEnv <-
208 Env.addLocals argBindings env
210 (cbody, freeLocals) <-
211 Expr.verifyBindings W.Pattern argBindings (Expr.canonicalize newEnv body)
213 let def = Can.Def aname args cbody
214 return
215 ( toNodeTwo name srcArgs def freeLocals
216 , name
217 , Map.keys freeLocals
218 )
220 Just srcType ->
221 do (Can.Forall freeVars tipe) <- Type.toAnnotation env srcType
223 ((args,resultType), argBindings) <-
224 Pattern.verify (Error.DPFuncArgs name) $
225 Expr.gatherTypedArgs env name srcArgs tipe Index.first []
227 newEnv <-
228 Env.addLocals argBindings env
230 (cbody, freeLocals) <-
231 Expr.verifyBindings W.Pattern argBindings (Expr.canonicalize newEnv body)
233 let def = Can.TypedDef aname freeVars args cbody resultType
234 return
235 ( toNodeTwo name srcArgs def freeLocals
236 , name
237 , Map.keys freeLocals
238 )
241toNodeTwo :: N.Name -> [arg] -> Can.Def -> Expr.FreeLocals -> NodeTwo
242toNodeTwo name args def freeLocals =
243 case args of
244 [] ->
245 (def, name, Map.foldrWithKey addDirects [] freeLocals)
247 _ ->
248 (def, name, [])
251addDirects :: N.Name -> Expr.Uses -> [N.Name] -> [N.Name]
252addDirects name (Expr.Uses directUses _) directDeps =
253 if directUses > 0 then
254 name:directDeps
255 else
256 directDeps
260-- CANONICALIZE EXPORTS
263canonicalizeExports
264 :: [A.Located Valid.Decl]
265 -> Map.Map N.Name union
266 -> Map.Map N.Name alias
267 -> Map.Map N.Name binop
268 -> Can.Effects
269 -> Src.Exposing
270 -> Result i w Can.Exports
271canonicalizeExports decls unions aliases binops effects exposing =
272 case exposing of
273 Src.Open ->
274 Result.ok Can.ExportEverything
276 Src.Explicit exposeds ->
277 do let names = Map.fromList (map declToName decls)
278 infos <- traverse (checkExposed names unions aliases binops effects) exposeds
279 Can.Export <$> Dups.detect Error.ExportDuplicate (Dups.unions infos)
282declToName :: A.Located Valid.Decl -> ( N.Name, () )
283declToName (A.At _ (Valid.Decl (A.At _ name) _ _ _)) =
284 ( name, () )
287checkExposed
288 :: Map.Map N.Name decl
289 -> Map.Map N.Name union
290 -> Map.Map N.Name alias
291 -> Map.Map N.Name binop
292 -> Can.Effects
293 -> A.Located Src.Exposed
294 -> Result i w (Dups.Dict (A.Located Can.Export))
295checkExposed decls unions aliases binops effects (A.At region exposed) =
296 case exposed of
297 Src.Lower name ->
298 if Map.member name decls then
299 ok name region Can.ExportValue
300 else
301 case checkPorts effects name of
302 Nothing ->
303 ok name region Can.ExportPort
305 Just ports ->
306 Result.throw $ Error.ExportNotFound region Error.BadVar name $
307 ports ++ Map.keys decls
309 Src.Operator name ->
310 if Map.member name binops then
311 ok name region Can.ExportBinop
312 else
313 Result.throw $ Error.ExportNotFound region Error.BadOp name $
314 Map.keys binops
316 Src.Upper name Src.Public ->
317 if Map.member name unions then
318 ok name region Can.ExportUnionOpen
319 else if Map.member name aliases then
320 Result.throw $ Error.ExportOpenAlias region name
321 else
322 Result.throw $ Error.ExportNotFound region Error.BadType name $
323 Map.keys unions ++ Map.keys aliases
325 Src.Upper name Src.Private ->
326 if Map.member name unions then
327 ok name region Can.ExportUnionClosed
328 else if Map.member name aliases then
329 ok name region Can.ExportAlias
330 else
331 Result.throw $ Error.ExportNotFound region Error.BadType name $
332 Map.keys unions ++ Map.keys aliases
335checkPorts :: Can.Effects -> N.Name -> Maybe [N.Name]
336checkPorts effects name =
337 case effects of
338 Can.NoEffects ->
339 Just []
341 Can.Ports ports ->
342 if Map.member name ports then Nothing else Just (Map.keys ports)
344 Can.Manager _ _ _ _ ->
345 Just []
348ok :: N.Name -> R.Region -> Can.Export -> Result i w (Dups.Dict (A.Located Can.Export))
349ok name region export =
350 Result.ok $ Dups.one name region (A.At region export)