git.iko.soy/elk
on 54dfb21 help sign in
elk/src/Canonicalize/Setup.hs
399 lines 12 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Canonicalize.Setup (environment) where
4import Control.Arrow (second)
5import qualified Data.Graph as Graph
6import qualified Data.Map as Map
7import qualified Data.Maybe as Maybe
8import qualified Data.Traversable as Trav
10import qualified AST.Declaration as D
11import qualified AST.Expression.Valid as Valid
12import qualified AST.Module as Module
13import qualified AST.Module.Name as ModuleName
14import qualified AST.Pattern as P
15import qualified AST.Type as Type
16import qualified AST.Variable as Var
17import Elm.Utils ((|>))
18import qualified Reporting.Annotation as A
19import qualified Reporting.Error.Canonicalize as Error
20import qualified Reporting.Error.Helpers as Error
21import qualified Reporting.Region as R
22import qualified Canonicalize.Environment as Env
23import qualified Canonicalize.Result as Result
24import qualified Canonicalize.Type as Canonicalize
27environment
28 :: Map.Map ModuleName.Raw ModuleName.Canonical
29 -> Module.Interfaces
30 -> Module.ValidModule
31 -> Result.ResultErr Env.Environment
32environment importDict interfaces (Module.Module name _ _ _ (defaults, imports) decls) =
33 let
34 allImports =
35 imports ++ map (A.A (error "default import not found")) defaults
37 importPatchesResult =
38 concat <$> Trav.traverse (importPatches importDict interfaces) allImports
40 (typeAliasNodes, declPatches) =
41 declarationsToPatches name decls
43 patches =
44 (++) (Env.builtinPatches ++ declPatches) <$> importPatchesResult
45 in
46 (Env.fromPatches name <$> patches)
47 `Result.andThen` addTypeAliases name typeAliasNodes
50-- PATCHES FOR IMPORTS
52importPatches
53 :: Map.Map ModuleName.Raw ModuleName.Canonical
54 -> Module.Interfaces
55 -> A.Located (ModuleName.Raw, Module.ImportMethod)
56 -> Result.ResultErr [Env.Patch]
57importPatches importDict allInterfaces (A.A region (rawImportName, method)) =
58 let
59 maybeInterface =
60 do canonicalName <- Map.lookup rawImportName importDict
61 interface <- Map.lookup canonicalName allInterfaces
62 return (canonicalName, restrictToPublicApi interface)
63 in
64 case maybeInterface of
65 Nothing ->
66 if ModuleName.isNative rawImportName then
67 Result.ok []
69 else
70 allInterfaces
71 |> Map.keys
72 |> map ModuleName._module
73 |> Error.nearbyNames ModuleName.toString rawImportName
74 |> Error.moduleNotFound rawImportName
75 |> A.A region
76 |> Result.err
78 Just (importName, interface) ->
79 let (Module.ImportMethod maybeAlias listing) =
80 method
82 (Var.Listing exposedValues open) =
83 listing
85 qualifier =
86 maybe (ModuleName.toString rawImportName) id maybeAlias
88 qualifiedPatches =
89 interfacePatches importName (qualifier ++ ".") interface
91 unqualifiedPatches =
92 if open
93 then Result.ok (interfacePatches importName "" interface)
94 else concat <$> Trav.traverse (valueToPatches region importName interface) exposedValues
95 in
96 (++) qualifiedPatches <$> unqualifiedPatches
99interfacePatches :: ModuleName.Canonical -> String -> Module.Interface -> [Env.Patch]
100interfacePatches moduleName prefix interface =
101 let genericPatch mkPatch name value =
102 mkPatch (prefix ++ name) value
104 patch mkPatch name =
105 genericPatch mkPatch name (Var.fromModule moduleName name)
107 aliasPatch (name, (tvars, tipe)) =
108 genericPatch Env.Alias name
109 (Var.fromModule moduleName name, tvars, tipe)
111 patternPatch (name, args) =
112 genericPatch Env.Pattern name
113 (Var.fromModule moduleName name, length args)
115 ctors =
116 concatMap snd (Map.elems (Module.iAdts interface))
118 ctorNames =
119 map fst ctors
120 in
121 concat
122 [ map (patch Env.Value) (Map.keys (Module.iTypes interface))
123 , map (patch Env.Value) ctorNames
124 , map (patch Env.Union) (Map.keys (Module.iAdts interface))
125 , map aliasPatch (Map.toList (Module.iAliases interface))
126 , map patternPatch ctors
127 ]
130-- PATCHES FOR INDIVIDUAL VALUES
132valueToPatches
133 :: R.Region
134 -> ModuleName.Canonical
135 -> Module.Interface
136 -> Var.Value
137 -> Result.ResultErr [Env.Patch]
138valueToPatches region moduleName interface value =
139 let patch mkPatch x =
140 mkPatch x (Var.fromModule moduleName x)
142 patternPatch (x, numArgs) =
143 Env.Pattern x (Var.fromModule moduleName x, numArgs)
145 notFound getNames x =
146 Module.iExports interface
147 |> getNames
148 |> Error.nearbyNames id x
149 |> Error.valueNotFound (ModuleName._module moduleName) x
150 |> A.A region
151 |> Result.err
152 in
153 case value of
154 Var.Value x
155 | Map.notMember x (Module.iTypes interface) ->
156 notFound Var.getValues x
158 | otherwise ->
159 Result.ok [patch Env.Value x]
161 Var.Alias x ->
162 case Map.lookup x (Module.iAliases interface) of
163 Just (tvars, t) ->
164 let alias =
165 Env.Alias x (Var.fromModule moduleName x, tvars, t)
166 in
167 Result.ok $
168 if Map.member x (Module.iTypes interface)
169 then [alias, patch Env.Value x]
170 else [alias]
172 Nothing ->
173 case Map.lookup x (Module.iAdts interface) of
174 Just (_,_) ->
175 Result.ok [patch Env.Union x]
177 Nothing ->
178 let getNames values =
179 Var.getAliases values
180 ++ map fst (Var.getUnions values)
181 in
182 notFound getNames x
184 Var.Union givenName (Var.Listing givenCtorNames open) ->
185 case Map.lookup givenName (Module.iAdts interface) of
186 Nothing ->
187 notFound (map fst . Var.getUnions) givenName
189 Just (_tvars, realCtors) ->
190 patches <$>
191 if open
192 then Result.ok realCtorList
193 else Trav.traverse ctorExists givenCtorNames
194 where
195 realCtorList =
196 map (second length) realCtors
198 realCtorDict =
199 Map.fromList realCtorList
201 ctorExists givenCtorName =
202 case Map.lookup givenCtorName realCtorDict of
203 Just numArgs ->
204 Result.ok (givenCtorName, numArgs)
205 Nothing ->
206 notFound (const (map fst realCtors)) givenCtorName
208 patches ctors =
209 patch Env.Union givenName
210 : map (patch Env.Value . fst) ctors
211 ++ map patternPatch ctors
214-- PATCHES FOR TYPE ALIASES
216type Node = ((R.Region, String, [String], Type.Raw), String, [String])
219node :: R.Region -> String -> [String] -> Type.Raw -> Node
220node region name tvars alias =
221 ((region, name, tvars, alias), name, edges alias)
222 where
223 edges (A.A _ tipe) =
224 case tipe of
225 Type.RLambda t1 t2 ->
226 edges t1 ++ edges t2
228 Type.RVar _ ->
229 []
231 Type.RType (Var.Raw x) ->
232 [x]
234 Type.RApp t ts ->
235 edges t ++ concatMap edges ts
237 Type.RRecord fs ext ->
238 maybe [] edges ext ++ concatMap (edges . snd) fs
241addTypeAliases
242 :: ModuleName.Canonical
243 -> [Node]
244 -> Env.Environment
245 -> Result.ResultErr Env.Environment
246addTypeAliases moduleName typeAliasNodes initialEnv =
247 Result.foldl
248 (addTypeAlias moduleName)
249 initialEnv
250 (Graph.stronglyConnComp typeAliasNodes)
253addTypeAlias
254 :: ModuleName.Canonical
255 -> Graph.SCC (R.Region, String, [String], Type.Raw)
256 -> Env.Environment
257 -> Result.ResultErr Env.Environment
258addTypeAlias moduleName scc env =
259 case scc of
260 Graph.AcyclicSCC (_, name, tvars, alias) ->
261 addToEnv <$> Canonicalize.tipe env alias
262 where
263 addToEnv alias' =
264 let value =
265 (Var.fromModule moduleName name, tvars, alias')
266 in
267 env { Env._aliases = Env.insert name value (Env._aliases env) }
269 Graph.CyclicSCC [] ->
270 Result.ok env
272 Graph.CyclicSCC [(region, name, tvars, alias)] ->
273 Result.err (A.A region (Error.Alias (Error.SelfRecursive name tvars alias)))
275 Graph.CyclicSCC aliases@((region, _, _, _) : _) ->
276 Result.err (A.A region (Error.Alias (Error.MutuallyRecursive aliases)))
279-- DECLARATIONS TO PATCHES
281declarationsToPatches
282 :: ModuleName.Canonical
283 -> [D.ValidDecl]
284 -> ([Node], [Env.Patch])
285declarationsToPatches moduleName decls =
286 let (maybeNodes, patchLists) =
287 unzip (map (declToPatches moduleName) decls)
288 in
289 (Maybe.catMaybes maybeNodes, concat patchLists)
292-- When canonicalizing, it is important that:
293-- _adts are fully namespaced (Var.Module ...)
294-- _patterns are fully namespaced (Var.Module ...)
295-- _values that are defined as top-level declarations are (Var.TopLevel ...)
296-- all other _values are local (Var.Local)
297declToPatches
298 :: ModuleName.Canonical
299 -> D.ValidDecl
300 -> (Maybe Node, [Env.Patch])
301declToPatches moduleName (A.A (region,_) decl) =
302 let topLevel mkPatch x =
303 mkPatch x (Var.topLevel moduleName x )
305 namespaced mkPatch x =
306 mkPatch x (Var.fromModule moduleName x)
308 patternPatch (name, args) =
309 Env.Pattern name (Var.fromModule moduleName name, length args)
310 in
311 case decl of
312 D.Definition (Valid.Definition pattern _ _) ->
313 ( Nothing
314 , map (topLevel Env.Value) (P.boundVarList pattern)
315 )
317 D.Datatype name _ ctors ->
318 let ctorNames = map fst ctors
319 in
320 ( Nothing
321 , namespaced Env.Union name
322 : map (topLevel Env.Value) ctorNames
323 ++ map patternPatch ctors
324 )
326 D.TypeAlias name tvars alias ->
327 ( Just (node region name tvars alias)
328 , case alias of
329 A.A _ (Type.RRecord _ Nothing) ->
330 [topLevel Env.Value name]
331 _ ->
332 []
333 )
335 D.Port port ->
336 ( Nothing
337 , [topLevel Env.Value (D.validPortName port)]
338 )
340 D.Fixity _ _ _ ->
341 ( Nothing
342 , []
343 )
346-- RESTRICT VISIBLE API OF INTERFACES
348restrictToPublicApi :: Module.Interface -> Module.Interface
349restrictToPublicApi interface =
350 interface
351 { Module.iTypes =
352 Map.fromList $
353 Maybe.mapMaybe
354 (get (Module.iTypes interface))
355 (Var.getValues exports ++ ctors)
357 , Module.iAliases =
358 Map.fromList $
359 Maybe.mapMaybe
360 (get (Module.iAliases interface))
361 (Var.getAliases exports)
363 , Module.iAdts =
364 Map.fromList
365 (Maybe.mapMaybe (trimUnions interface) unions)
366 }
367 where
368 exports :: [Var.Value]
369 exports =
370 Module.iExports interface
372 unions :: [(String, Var.Listing String)]
373 unions =
374 Var.getUnions exports
376 ctors :: [String]
377 ctors =
378 concatMap (\(_, Var.Listing ctorList _) -> ctorList) unions
381get :: Map.Map String a -> String -> Maybe (String, a)
382get dict key =
383 case Map.lookup key dict of
384 Nothing -> Nothing
385 Just value -> Just (key, value)
388trimUnions
389 :: Module.Interface
390 -> (String, Var.Listing String)
391 -> Maybe (String, Module.AdtInfo String)
392trimUnions interface (name, Var.Listing exportedCtors _) =
393 case Map.lookup name (Module.iAdts interface) of
394 Nothing -> Nothing
395 Just (tvars, ctors) ->
396 let isExported (ctor, _) =
397 ctor `elem` exportedCtors
398 in
399 Just (name, (tvars, filter isExported ctors))