git.iko.soy/elk
on 9b0c310 help sign in
elk/src/Canonicalize/Setup.hs
389 lines 11 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Canonicalize.Setup (environment) where
4import Control.Applicative ((<$>))
5import Control.Arrow (second)
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.Expression.Valid as Valid
13import qualified AST.Module as Module
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.Region as R
21import qualified Canonicalize.Environment as Env
22import qualified Canonicalize.Result as Result
23import qualified Canonicalize.Type as Canonicalize
26environment
27 :: Module.Interfaces
28 -> Module.ValidModule
29 -> Result.ResultErr Env.Environment
30environment interfaces modul@(Module.Module _ _ _ (defaults, imports) decls) =
31 let moduleName =
32 Module.names modul
34 allImports =
35 imports ++ map (A.A (error "default import not found")) defaults
37 importPatchesResult =
38 concat <$> Trav.traverse (importPatches interfaces) allImports
40 (typeAliasNodes, declPatches) =
41 declarationsToPatches moduleName decls
43 patches =
44 (++) (Env.builtinPatches ++ declPatches) <$> importPatchesResult
45 in
46 (Env.fromPatches moduleName <$> patches)
47 `Result.andThen` addTypeAliases moduleName typeAliasNodes
50-- PATCHES FOR IMPORTS
52importPatches
53 :: Module.Interfaces
54 -> A.Located (Module.Name, Module.ImportMethod)
55 -> Result.ResultErr [Env.Patch]
56importPatches allInterfaces (A.A region (importName, method)) =
57 case restrictToPublicApi <$> Map.lookup importName allInterfaces of
58 Nothing
59 | Module.nameIsNative importName ->
60 Result.ok []
62 | otherwise ->
63 allInterfaces
64 |> Map.keys
65 |> Error.nearbyNames Module.nameToString importName
66 |> Error.moduleNotFound importName
67 |> A.A region
68 |> Result.err
70 Just interface ->
71 let (Module.ImportMethod maybeAlias listing) =
72 method
74 (Var.Listing exposedValues open) =
75 listing
77 qualifier =
78 maybe (Module.nameToString importName) id maybeAlias
80 qualifiedPatches =
81 interfacePatches importName (qualifier ++ ".") interface
83 unqualifiedPatches =
84 if open
85 then Result.ok (interfacePatches importName "" interface)
86 else concat <$> Trav.traverse (valueToPatches region importName interface) exposedValues
87 in
88 (++) qualifiedPatches <$> unqualifiedPatches
91interfacePatches :: Module.Name -> String -> Module.Interface -> [Env.Patch]
92interfacePatches moduleName prefix interface =
93 let genericPatch mkPatch name value =
94 mkPatch (prefix ++ name) value
96 patch mkPatch name =
97 genericPatch mkPatch name (Var.fromModule moduleName name)
99 aliasPatch (name, (tvars, tipe)) =
100 genericPatch Env.Alias name
101 (Var.fromModule moduleName name, tvars, tipe)
103 patternPatch (name, args) =
104 genericPatch Env.Pattern name
105 (Var.fromModule moduleName name, length args)
107 ctors =
108 concatMap snd (Map.elems (Module.iAdts interface))
110 ctorNames =
111 map fst ctors
112 in
113 concat
114 [ map (patch Env.Value) (Map.keys (Module.iTypes interface))
115 , map (patch Env.Value) ctorNames
116 , map (patch Env.Union) (Map.keys (Module.iAdts interface))
117 , map aliasPatch (Map.toList (Module.iAliases interface))
118 , map patternPatch ctors
119 ]
122-- PATCHES FOR INDIVIDUAL VALUES
124valueToPatches
125 :: R.Region
126 -> Module.Name
127 -> Module.Interface
128 -> Var.Value
129 -> Result.ResultErr [Env.Patch]
130valueToPatches region moduleName interface value =
131 let patch mkPatch x =
132 mkPatch x (Var.fromModule moduleName x)
134 patternPatch (x, numArgs) =
135 Env.Pattern x (Var.fromModule moduleName x, numArgs)
137 notFound getNames x =
138 Module.iExports interface
139 |> getNames
140 |> Error.nearbyNames id x
141 |> Error.valueNotFound moduleName x
142 |> A.A region
143 |> Result.err
144 in
145 case value of
146 Var.Value x
147 | Map.notMember x (Module.iTypes interface) ->
148 notFound Var.getValues x
150 | otherwise ->
151 Result.ok [patch Env.Value x]
153 Var.Alias x ->
154 case Map.lookup x (Module.iAliases interface) of
155 Just (tvars, t) ->
156 let alias =
157 Env.Alias x (Var.fromModule moduleName x, tvars, t)
158 in
159 Result.ok $
160 if Map.member x (Module.iTypes interface)
161 then [alias, patch Env.Value x]
162 else [alias]
164 Nothing ->
165 case Map.lookup x (Module.iAdts interface) of
166 Just (_,_) ->
167 Result.ok [patch Env.Union x]
169 Nothing ->
170 let getNames values =
171 Var.getAliases values
172 ++ map fst (Var.getUnions values)
173 in
174 notFound getNames x
176 Var.Union givenName (Var.Listing givenCtorNames open) ->
177 case Map.lookup givenName (Module.iAdts interface) of
178 Nothing ->
179 notFound (map fst . Var.getUnions) givenName
181 Just (_tvars, realCtors) ->
182 patches <$>
183 if open
184 then Result.ok realCtorList
185 else Trav.traverse ctorExists givenCtorNames
186 where
187 realCtorList =
188 map (second length) realCtors
190 realCtorDict =
191 Map.fromList realCtorList
193 ctorExists givenCtorName =
194 case Map.lookup givenCtorName realCtorDict of
195 Just numArgs ->
196 Result.ok (givenCtorName, numArgs)
197 Nothing ->
198 notFound (const (map fst realCtors)) givenCtorName
200 patches ctors =
201 patch Env.Union givenName
202 : map (patch Env.Value . fst) ctors
203 ++ map patternPatch ctors
206-- PATCHES FOR TYPE ALIASES
208type Node = ((R.Region, String, [String], Type.Raw), String, [String])
211node :: R.Region -> String -> [String] -> Type.Raw -> Node
212node region name tvars alias =
213 ((region, name, tvars, alias), name, edges alias)
214 where
215 edges (A.A _ tipe) =
216 case tipe of
217 Type.RLambda t1 t2 ->
218 edges t1 ++ edges t2
220 Type.RVar _ ->
221 []
223 Type.RType (Var.Raw x) ->
224 [x]
226 Type.RApp t ts ->
227 edges t ++ concatMap edges ts
229 Type.RRecord fs ext ->
230 maybe [] edges ext ++ concatMap (edges . snd) fs
233addTypeAliases
234 :: Module.Name
235 -> [Node]
236 -> Env.Environment
237 -> Result.ResultErr Env.Environment
238addTypeAliases moduleName typeAliasNodes initialEnv =
239 Result.foldl
240 (addTypeAlias moduleName)
241 initialEnv
242 (Graph.stronglyConnComp typeAliasNodes)
245addTypeAlias
246 :: Module.Name
247 -> Graph.SCC (R.Region, String, [String], Type.Raw)
248 -> Env.Environment
249 -> Result.ResultErr Env.Environment
250addTypeAlias moduleName scc env =
251 case scc of
252 Graph.AcyclicSCC (_, name, tvars, alias) ->
253 addToEnv <$> Canonicalize.tipe env alias
254 where
255 addToEnv alias' =
256 let value =
257 (Var.fromModule moduleName name, tvars, alias')
258 in
259 env { Env._aliases = Env.insert name value (Env._aliases env) }
261 Graph.CyclicSCC [] ->
262 Result.ok env
264 Graph.CyclicSCC [(region, name, tvars, alias)] ->
265 Result.err (A.A region (Error.Alias (Error.SelfRecursive name tvars alias)))
267 Graph.CyclicSCC aliases@((region, _, _, _) : _) ->
268 Result.err (A.A region (Error.Alias (Error.MutuallyRecursive aliases)))
271-- DECLARATIONS TO PATCHES
273declarationsToPatches
274 :: Module.Name
275 -> [D.ValidDecl]
276 -> ([Node], [Env.Patch])
277declarationsToPatches moduleName decls =
278 let (maybeNodes, patchLists) =
279 unzip (map (declToPatches moduleName) decls)
280 in
281 (Maybe.catMaybes maybeNodes, concat patchLists)
284-- When canonicalizing, all _values should be Local, but all _adts and _patterns
285-- should be fully namespaced. With _adts, they may appear in types that can
286-- escape the module.
287declToPatches
288 :: Module.Name
289 -> D.ValidDecl
290 -> (Maybe Node, [Env.Patch])
291declToPatches moduleName (A.A region decl) =
292 let local mkPatch x =
293 mkPatch x (Var.local x)
295 namespaced mkPatch x =
296 mkPatch x (Var.fromModule moduleName x)
298 patternPatch (name, args) =
299 Env.Pattern name (Var.fromModule moduleName name, length args)
300 in
301 case decl of
302 D.Definition (Valid.Definition pattern _ _) ->
303 ( Nothing
304 , map (local Env.Value) (P.boundVarList pattern)
305 )
307 D.Datatype name _ ctors ->
308 let ctorNames = map fst ctors
309 in
310 ( Nothing
311 , namespaced Env.Union name
312 : map (local Env.Value) ctorNames
313 ++ map patternPatch ctors
314 )
316 D.TypeAlias name tvars alias ->
317 ( Just (node region name tvars alias)
318 , case alias of
319 A.A _ (Type.RRecord _ _) ->
320 [local Env.Value name]
321 _ ->
322 []
323 )
325 D.Port port ->
326 ( Nothing
327 , [local Env.Value (D.validPortName port)]
328 )
330 D.Fixity _ _ _ ->
331 ( Nothing
332 , []
333 )
336-- RESTRICT VISIBLE API OF INTERFACES
338restrictToPublicApi :: Module.Interface -> Module.Interface
339restrictToPublicApi interface =
340 interface
341 { Module.iTypes =
342 Map.fromList $
343 Maybe.mapMaybe
344 (get (Module.iTypes interface))
345 (Var.getValues exports ++ ctors)
347 , Module.iAliases =
348 Map.fromList $
349 Maybe.mapMaybe
350 (get (Module.iAliases interface))
351 (Var.getAliases exports)
353 , Module.iAdts =
354 Map.fromList
355 (Maybe.mapMaybe (trimUnions interface) unions)
356 }
357 where
358 exports :: [Var.Value]
359 exports =
360 Module.iExports interface
362 unions :: [(String, Var.Listing String)]
363 unions =
364 Var.getUnions exports
366 ctors :: [String]
367 ctors =
368 concatMap (\(_, Var.Listing ctorList _) -> ctorList) unions
371get :: Map.Map String a -> String -> Maybe (String, a)
372get dict key =
373 case Map.lookup key dict of
374 Nothing -> Nothing
375 Just value -> Just (key, value)
378trimUnions
379 :: Module.Interface
380 -> (String, Var.Listing String)
381 -> Maybe (String, Module.AdtInfo String)
382trimUnions interface (name, Var.Listing exportedCtors _) =
383 case Map.lookup name (Module.iAdts interface) of
384 Nothing -> Nothing
385 Just (tvars, ctors) ->
386 let isExported (ctor, _) =
387 ctor `elem` exportedCtors
388 in
389 Just (name, (tvars, filter isExported ctors))