git.iko.soy/elk
on 17618de help sign in
elk/src/Canonicalize/Setup.hs
452 lines 12 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Canonicalize.Setup (environment) where
4import Control.Arrow (second)
5import Control.Monad (foldM)
6import qualified Data.Graph as Graph
7import qualified Data.Map as Map
8import qualified Data.Maybe as Maybe
9import qualified Data.Traversable as Trav
11import qualified AST.Declaration as D
12import qualified AST.Effects as Effects
13import qualified AST.Expression.Valid as Valid
14import qualified AST.Module as Module
15import qualified AST.Module.Name as ModuleName
16import qualified AST.Pattern as P
17import qualified AST.Type as Type
18import qualified AST.Variable as Var
19import Elm.Utils ((|>))
20import qualified Reporting.Annotation as A
21import qualified Reporting.Error.Canonicalize as Error
22import qualified Reporting.Error.Helpers as Error
23import qualified Reporting.Region as R
24import qualified Reporting.Result as Result
25import qualified Canonicalize.Environment as Env
26import qualified Canonicalize.Type as Canonicalize
27import Canonicalize.Variable (Result)
31environment
32 :: Map.Map ModuleName.Raw ModuleName.Canonical
33 -> Module.Interfaces
34 -> Module.Valid
35 -> Result Env.Environment
36environment importDict interfaces (Module.Module name _ info) =
37 let
38 (Module.Valid _ _ (defaults, imports) decls effects) =
39 info
41 allImports =
42 imports ++ map (A.A (error "default import not found")) defaults
44 getImportPatches =
45 Trav.traverse (importToPatches importDict interfaces) allImports
47 (typeAliasNodes, declPatches) =
48 declsToPatches name decls
50 effectPatches =
51 effectsToPatches name effects
53 createEnv importPatches =
54 Env.fromPatches
55 name
56 (concat (Env.builtinPatches : declPatches : effectPatches : importPatches))
57 in
58 do env <- createEnv <$> getImportPatches
59 addTypeAliases name typeAliasNodes env
63-- PATCHES FOR IMPORTS
66importToPatches
67 :: Map.Map ModuleName.Raw ModuleName.Canonical
68 -> Module.Interfaces
69 -> A.Located (ModuleName.Raw, Module.ImportMethod)
70 -> Result [Env.Patch]
71importToPatches importDict allInterfaces (A.A region (rawImportName, method)) =
72 let
73 maybeInterface =
74 do canonicalName <- Map.lookup rawImportName importDict
75 interface <- Map.lookup canonicalName allInterfaces
76 return (canonicalName, restrictToPublicApi interface)
77 in
78 case maybeInterface of
79 Nothing ->
80 if ModuleName.isNative rawImportName then
81 Result.ok []
83 else
84 allInterfaces
85 |> Map.keys
86 |> map ModuleName._module
87 |> Error.nearbyNames ModuleName.toString rawImportName
88 |> Error.moduleNotFound rawImportName
89 |> Result.throw region
91 Just (importName, interface) ->
92 let
93 (Module.ImportMethod maybeAlias listing) =
94 method
96 (Var.Listing exposedValues open) =
97 listing
99 qualifier =
100 maybe (ModuleName.toString rawImportName) id maybeAlias
102 qualifiedPatches =
103 interfaceToPatches importName (qualifier ++ ".") interface
105 unqualifiedPatches =
106 if open then
107 Result.ok (interfaceToPatches importName "" interface)
109 else
110 concat <$> Trav.traverse (valueToPatches region importName interface) exposedValues
111 in
112 (++) qualifiedPatches <$> unqualifiedPatches
115interfaceToPatches :: ModuleName.Canonical -> String -> Module.Interface -> [Env.Patch]
116interfaceToPatches moduleName prefix interface =
117 let
118 genericPatch mkPatch name value =
119 mkPatch (prefix ++ name) value
121 patch mkPatch name =
122 genericPatch mkPatch name (Var.fromModule moduleName name)
124 aliasPatch (name, (tvars, tipe)) =
125 genericPatch
126 Env.Alias
127 name
128 (Var.fromModule moduleName name, tvars, tipe)
130 patternPatch (name, args) =
131 genericPatch
132 Env.Pattern
133 name
134 (Var.fromModule moduleName name, length args)
136 ctors =
137 concatMap snd (Map.elems (Module.iUnions interface))
139 ctorNames =
140 map fst ctors
141 in
142 concat
143 [ map (patch Env.Value) (Map.keys (Module.iTypes interface))
144 , map (patch Env.Value) ctorNames
145 , map (patch Env.Union) (Map.keys (Module.iUnions interface))
146 , map aliasPatch (Map.toList (Module.iAliases interface))
147 , map patternPatch ctors
148 ]
152-- PATCHES FOR INDIVIDUAL VALUES
155valueToPatches
156 :: R.Region
157 -> ModuleName.Canonical
158 -> Module.Interface
159 -> Var.Value
160 -> Result [Env.Patch]
161valueToPatches region moduleName interface value =
162 let
163 patch mkPatch x =
164 mkPatch x (Var.fromModule moduleName x)
166 patternPatch (x, numArgs) =
167 Env.Pattern x (Var.fromModule moduleName x, numArgs)
169 notFound getNames x =
170 Module.iExports interface
171 |> getNames
172 |> Error.nearbyNames id x
173 |> Error.valueNotFound (ModuleName._module moduleName) x
174 |> Result.throw region
175 in
176 case value of
177 Var.Value x ->
178 if Map.notMember x (Module.iTypes interface) then
179 notFound Var.getValues x
181 else
182 Result.ok [patch Env.Value x]
184 Var.Alias x ->
185 case Map.lookup x (Module.iAliases interface) of
186 Just (tvars, t) ->
187 let
188 alias =
189 Env.Alias x (Var.fromModule moduleName x, tvars, t)
190 in
191 Result.ok $
192 if Map.member x (Module.iTypes interface) then
193 [alias, patch Env.Value x]
195 else
196 [alias]
198 Nothing ->
199 case Map.lookup x (Module.iUnions interface) of
200 Just (_,_) ->
201 Result.ok [patch Env.Union x]
203 Nothing ->
204 let getNames values =
205 Var.getAliases values
206 ++ map fst (Var.getUnions values)
207 in
208 notFound getNames x
210 Var.Union givenName (Var.Listing givenCtorNames open) ->
211 case Map.lookup givenName (Module.iUnions interface) of
212 Nothing ->
213 notFound (map fst . Var.getUnions) givenName
215 Just (_tvars, realCtors) ->
216 patches <$>
217 if open then
218 Result.ok realCtorList
220 else
221 Trav.traverse ctorExists givenCtorNames
222 where
223 realCtorList =
224 map (second length) realCtors
226 realCtorDict =
227 Map.fromList realCtorList
229 ctorExists givenCtorName =
230 case Map.lookup givenCtorName realCtorDict of
231 Just numArgs ->
232 Result.ok (givenCtorName, numArgs)
234 Nothing ->
235 notFound (const (map fst realCtors)) givenCtorName
237 patches ctors =
238 patch Env.Union givenName
239 : map (patch Env.Value . fst) ctors
240 ++ map patternPatch ctors
244-- PATCHES FOR TYPE ALIASES
247type Node =
248 ( (R.Region, String, [String], Type.Raw), String, [String] )
251node :: R.Region -> String -> [String] -> Type.Raw -> Node
252node region name tvars alias =
253 ((region, name, tvars, alias), name, edges alias)
254 where
255 edges (A.A _ tipe) =
256 case tipe of
257 Type.RLambda t1 t2 ->
258 edges t1 ++ edges t2
260 Type.RVar _ ->
261 []
263 Type.RType (Var.Raw x) ->
264 [x]
266 Type.RApp t ts ->
267 edges t ++ concatMap edges ts
269 Type.RRecord fs ext ->
270 maybe [] edges ext ++ concatMap (edges . snd) fs
273addTypeAliases :: ModuleName.Canonical -> [Node] -> Env.Environment -> Result Env.Environment
274addTypeAliases moduleName typeAliasNodes initialEnv =
275 foldM (addTypeAlias moduleName) initialEnv (Graph.stronglyConnComp typeAliasNodes)
278addTypeAlias
279 :: ModuleName.Canonical
280 -> Env.Environment
281 -> Graph.SCC (R.Region, String, [String], Type.Raw)
282 -> Result Env.Environment
283addTypeAlias moduleName env scc =
284 case scc of
285 Graph.AcyclicSCC (_, name, tvars, alias) ->
286 addToEnv <$> Canonicalize.tipe env alias
287 where
288 addToEnv alias' =
289 let value =
290 (Var.fromModule moduleName name, tvars, alias')
291 in
292 env { Env._aliases = Env.insert name value (Env._aliases env) }
294 Graph.CyclicSCC [] ->
295 Result.ok env
297 Graph.CyclicSCC [(region, name, tvars, alias)] ->
298 Result.throw region (Error.Alias (Error.SelfRecursive name tvars alias))
300 Graph.CyclicSCC aliases@((region, _, _, _) : _) ->
301 Result.throw region (Error.Alias (Error.MutuallyRecursive aliases))
305-- DECLARATIONS TO PATCHES
308{- When canonicalizing, it is important that:
310 _adts are fully namespaced (Var.Module ...)
311 _patterns are fully namespaced (Var.Module ...)
312 _values that are defined as top-level declarations are (Var.TopLevel ...)
313 all other _values are local (Var.Local)
315-}
316declsToPatches :: ModuleName.Canonical -> D.Valid -> ([Node], [Env.Patch])
317declsToPatches moduleName (D.Decls defs unions aliases _) =
318 let
320 -- HELPERS
322 topLevelValue x =
323 Env.Value x (Var.topLevel moduleName x)
325 patternPatch (name, args) =
326 Env.Pattern name (Var.fromModule moduleName name, length args)
328 -- TO PATCHES
330 defToPatches (A.A _ (Valid.Def pattern _ _)) =
331 map topLevelValue (P.boundVarList pattern)
333 unionToPatches (A.A _ (D.Type name _ ctors)) =
334 Env.Union name (Var.fromModule moduleName name)
335 : map topLevelValue (map fst ctors)
336 ++ map patternPatch ctors
338 aliasToPatches (A.A _ (D.Type name _ alias)) =
339 case A.drop alias of
340 Type.RRecord _ Nothing ->
341 Just (topLevelValue name)
343 _ ->
344 Nothing
346 -- TO NODES
348 aliasToNode (A.A (region, _) (D.Type name tvars alias)) =
349 node region name tvars alias
350 in
351 (
352 map aliasToNode aliases
353 ,
354 concat
355 [ Maybe.mapMaybe aliasToPatches aliases
356 , concatMap unionToPatches unions
357 , concatMap defToPatches defs
358 ]
359 )
362-- EFFECTS TO PATCHES
365effectsToPatches :: ModuleName.Canonical -> Effects.Raw -> [Env.Patch]
366effectsToPatches moduleName effects =
367 case effects of
368 Effects.None ->
369 []
371 Effects.Port ports ->
372 let
373 toPatch (A.A _ (Effects.PortRaw name _)) =
374 Env.Value name (Var.topLevel moduleName name)
375 in
376 map toPatch ports
378 Effects.Manager _ info ->
379 map (\name -> Env.Value name (Var.topLevel moduleName name)) $
380 case Effects._managerType info of
381 Effects.CmdManager _ ->
382 [ "command" ]
384 Effects.SubManager _ ->
385 [ "subscription" ]
387 Effects.FxManager _ _ ->
388 [ "command", "subscription" ]
392-- RESTRICT VISIBLE API OF INTERFACES
395restrictToPublicApi :: Module.Interface -> Module.Interface
396restrictToPublicApi interface =
397 interface
398 { Module.iTypes =
399 Map.fromList $
400 Maybe.mapMaybe
401 (get (Module.iTypes interface))
402 (Var.getValues exports ++ ctors)
404 , Module.iAliases =
405 Map.fromList $
406 Maybe.mapMaybe
407 (get (Module.iAliases interface))
408 (Var.getAliases exports)
410 , Module.iUnions =
411 Map.fromList
412 (Maybe.mapMaybe (trimUnions interface) unions)
413 }
414 where
415 exports :: [Var.Value]
416 exports =
417 Module.iExports interface
419 unions :: [(String, Var.Listing String)]
420 unions =
421 Var.getUnions exports
423 ctors :: [String]
424 ctors =
425 concatMap (\(_, Var.Listing ctorList _) -> ctorList) unions
428get :: Map.Map String a -> String -> Maybe (String, a)
429get dict key =
430 case Map.lookup key dict of
431 Nothing ->
432 Nothing
434 Just value ->
435 Just (key, value)
438trimUnions
439 :: Module.Interface
440 -> (String, Var.Listing String)
441 -> Maybe (String, Module.UnionInfo String)
442trimUnions interface (name, Var.Listing exportedCtors _) =
443 case Map.lookup name (Module.iUnions interface) of
444 Nothing ->
445 Nothing
447 Just (tvars, ctors) ->
448 let
449 isExported (ctor, _) =
450 ctor `elem` exportedCtors
451 in
452 Just (name, (tvars, filter isExported ctors))