git.iko.soy/elk
on e00a3f3 help sign in
elk/src/Canonicalize/Setup.hs
446 lines 12 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Canonicalize.Setup (environment) where
5import Control.Arrow (second)
6import Control.Monad (foldM)
7import qualified Data.Graph as Graph
8import qualified Data.Map as Map
9import qualified Data.Maybe as Maybe
10import Data.Monoid ((<>))
11import Data.Text (Text)
13import qualified AST.Declaration as D
14import qualified AST.Effects as Effects
15import qualified AST.Exposing as Exposing
16import qualified AST.Expression.Source as Src
17import qualified AST.Module as Module
18import qualified AST.Module.Name as ModuleName
19import qualified AST.Pattern as P
20import qualified AST.Type as Type
21import qualified AST.Variable as Var
22import Elm.Utils ((|>))
23import qualified Reporting.Annotation as A
24import qualified Reporting.Error.Canonicalize as Error
25import qualified Reporting.Helpers as Help (nearbyNames)
26import qualified Reporting.Region as R
27import qualified Reporting.Result as Result
28import qualified Canonicalize.Environment as Env
29import qualified Canonicalize.Type as Canonicalize
30import Canonicalize.Variable (Result)
34environment
35 :: Map.Map ModuleName.Raw ModuleName.Canonical
36 -> Module.Interfaces
37 -> Module.Valid
38 -> Result Env.Env
39environment importDict interfaces (Module.Module name info) =
40 let
41 (Module.Valid _ _ (defaults, imports) decls effects) =
42 info
44 allImports =
45 imports ++ map (A.A (error "default import not found")) defaults
47 getImportPatches =
48 traverse (importToPatches importDict interfaces) allImports
50 (typeAliasNodes, declPatches) =
51 declsToPatches name decls
53 effectPatches =
54 effectsToPatches name effects
56 createEnv importPatches =
57 Env.fromPatches
58 name
59 (concat (Env.builtinPatches : declPatches : effectPatches : importPatches))
60 in
61 do env <- createEnv <$> getImportPatches
62 addTypeAliases name typeAliasNodes env
66-- PATCHES FOR IMPORTS
69importToPatches
70 :: Map.Map ModuleName.Raw ModuleName.Canonical
71 -> Module.Interfaces
72 -> A.Located (ModuleName.Raw, Module.ImportMethod)
73 -> Result [Env.Patch]
74importToPatches importDict allInterfaces (A.A region (rawImportName, method)) =
75 let
76 maybeInterface =
77 do canonicalName <- Map.lookup rawImportName importDict
78 interface <- Map.lookup canonicalName allInterfaces
79 return (canonicalName, restrictToPublicApi interface)
80 in
81 case maybeInterface of
82 Nothing ->
83 if ModuleName.isKernel rawImportName then
84 Result.ok []
86 else
87 allInterfaces
88 |> Map.keys
89 |> map ModuleName._module
90 |> Help.nearbyNames ModuleName.toText rawImportName
91 |> Error.moduleNotFound rawImportName
92 |> Result.throw region
94 Just (importName, interface) ->
95 let
96 (Module.ImportMethod maybeAlias listing) =
97 method
99 qualifier =
100 maybe (ModuleName.toText rawImportName) id maybeAlias
102 infixPatches =
103 map (infixToPatch (Var.fromModule importName)) (Module.iFixities interface)
105 qualifiedPatches =
106 interfaceToPatches importName (qualifier <> ".") interface
108 unqualifiedPatches =
109 case listing of
110 Exposing.Open ->
111 Result.ok (interfaceToPatches importName "" interface)
113 Exposing.Explicit xs ->
114 concat <$> traverse (entryToPatches importName interface) xs
115 in
116 (++) (infixPatches ++ qualifiedPatches) <$> unqualifiedPatches
119interfaceToPatches :: ModuleName.Canonical -> Text -> Module.Interface -> [Env.Patch]
120interfaceToPatches moduleName prefix interface =
121 let
122 genericPatch mkPatch name value =
123 mkPatch (prefix <> name) value
125 patch mkPatch name =
126 genericPatch mkPatch name (Var.fromModule moduleName name)
128 aliasPatch (name, (tvars, tipe)) =
129 genericPatch
130 Env.Alias
131 name
132 (Var.fromModule moduleName name, tvars, tipe)
134 patternPatch (name, args) =
135 genericPatch
136 Env.Pattern
137 name
138 (Var.fromModule moduleName name, length args)
140 ctors =
141 concatMap snd (Map.elems (Module.iUnions interface))
143 ctorNames =
144 map fst ctors
145 in
146 concat
147 [ map (patch Env.Value) (Map.keys (Module.iTypes interface))
148 , map (patch Env.Value) ctorNames
149 , map (patch Env.Union) (Map.keys (Module.iUnions interface))
150 , map aliasPatch (Map.toList (Module.iAliases interface))
151 , map patternPatch ctors
152 ]
156-- PATCHES FOR INDIVIDUAL ENTRIES
159entryToPatches
160 :: ModuleName.Canonical
161 -> Module.Interface
162 -> A.Located Exposing.Entry
163 -> Result [Env.Patch]
164entryToPatches moduleName interface (A.A region entry) =
165 let
166 patch mkPatch name =
167 mkPatch name (Var.fromModule moduleName name)
169 patternPatch (name, numArgs) =
170 Env.Pattern name (Var.fromModule moduleName name, numArgs)
172 notFound subRegion getNames name =
173 Module.iExports interface
174 |> getNames
175 |> Help.nearbyNames id name
176 |> Error.valueNotFound (ModuleName._module moduleName) name
177 |> Result.throw subRegion
178 in
179 case entry of
180 Exposing.Lower name ->
181 if Map.notMember name (Module.iTypes interface) then
182 notFound region Exposing._values name
184 else
185 Result.ok [patch Env.Value name]
187 Exposing.Upper x Nothing ->
188 case Map.lookup x (Module.iAliases interface) of
189 Just (tvars, t) ->
190 let
191 alias =
192 Env.Alias x (Var.fromModule moduleName x, tvars, t)
193 in
194 Result.ok $
195 if Map.member x (Module.iTypes interface) then
196 [alias, patch Env.Value x]
198 else
199 [alias]
201 Nothing ->
202 case Map.lookup x (Module.iUnions interface) of
203 Just (_,_) ->
204 Result.ok [patch Env.Union x]
206 Nothing ->
207 let getNames values =
208 Exposing._aliases values
209 ++ map fst (Exposing._unions values)
210 in
211 notFound region getNames x
213 Exposing.Upper givenName (Just exposing) ->
214 case Map.lookup givenName (Module.iUnions interface) of
215 Nothing ->
216 notFound region (map fst . Exposing._unions) givenName
218 Just (_tvars, realCtors) ->
219 patches <$>
220 case exposing of
221 Exposing.Open ->
222 Result.ok realCtorList
224 Exposing.Explicit xs ->
225 traverse ctorExists xs
226 where
227 realCtorList =
228 map (second length) realCtors
230 realCtorDict =
231 Map.fromList realCtorList
233 ctorExists (A.A ctorRegion givenCtorName) =
234 case Map.lookup givenCtorName realCtorDict of
235 Just numArgs ->
236 Result.ok (givenCtorName, numArgs)
238 Nothing ->
239 notFound ctorRegion (const (map fst realCtors)) givenCtorName
241 patches ctors =
242 patch Env.Union givenName
243 : map (patch Env.Value . fst) ctors
244 ++ map patternPatch ctors
248-- PATCHES FOR TYPE ALIASES
251type Node =
252 ( (R.Region, Text, [Text], Type.Raw), Text, [Text] )
255node :: R.Region -> Text -> [Text] -> Type.Raw -> Node
256node region name tvars alias =
257 ((region, name, tvars, alias), name, edges alias)
258 where
259 edges (A.A _ tipe) =
260 case tipe of
261 Type.RLambda t1 t2 ->
262 edges t1 ++ edges t2
264 Type.RVar _ ->
265 []
267 Type.RType (Var.Raw x) ->
268 [x]
270 Type.RApp t ts ->
271 edges t ++ concatMap edges ts
273 Type.RRecord fs ext ->
274 maybe [] edges ext ++ concatMap (edges . snd) fs
277addTypeAliases :: ModuleName.Canonical -> [Node] -> Env.Env -> Result Env.Env
278addTypeAliases moduleName typeAliasNodes initialEnv =
279 foldM (addTypeAlias moduleName) initialEnv (Graph.stronglyConnComp typeAliasNodes)
282addTypeAlias
283 :: ModuleName.Canonical
284 -> Env.Env
285 -> Graph.SCC (R.Region, Text, [Text], Type.Raw)
286 -> Result Env.Env
287addTypeAlias moduleName env scc =
288 case scc of
289 Graph.AcyclicSCC (_, name, tvars, alias) ->
290 addToEnv <$> Canonicalize.tipe env alias
291 where
292 addToEnv alias' =
293 let value =
294 (Var.fromModule moduleName name, tvars, alias')
295 in
296 env { Env._aliases = Env.insert name value (Env._aliases env) }
298 Graph.CyclicSCC [] ->
299 Result.ok env
301 Graph.CyclicSCC [(region, name, tvars, alias)] ->
302 Result.throw region (Error.Alias (Error.SelfRecursive name tvars alias))
304 Graph.CyclicSCC aliases@((region, _, _, _) : _) ->
305 Result.throw region (Error.Alias (Error.MutuallyRecursive aliases))
309-- DECLARATIONS TO PATCHES
312{- When canonicalizing, it is important that:
314 _adts are fully namespaced (Var.Module ...)
315 _patterns are fully namespaced (Var.Module ...)
316 _values that are defined as top-level declarations are (Var.TopLevel ...)
317 all other _values are local (Var.Local)
319-}
320declsToPatches :: ModuleName.Canonical -> D.Valid -> ([Node], [Env.Patch])
321declsToPatches moduleName (D.Decls defs unions aliases infixes) =
322 let
324 -- HELPERS
326 topLevelValue x =
327 Env.Value x (Var.topLevel moduleName x)
329 patternPatch (name, args) =
330 Env.Pattern name (Var.fromModule moduleName name, length args)
332 -- TO PATCHES
334 defToPatches (A.A _ (Src.Def _ pattern _ _)) =
335 map topLevelValue (P.boundVarList pattern)
337 unionToPatches (A.A _ (D.Type name _ ctors)) =
338 Env.Union name (Var.fromModule moduleName name)
339 : map topLevelValue (map fst ctors)
340 ++ map patternPatch ctors
342 aliasToPatches (A.A _ (D.Type name _ alias)) =
343 case A.drop alias of
344 Type.RRecord _ Nothing ->
345 Just (topLevelValue name)
347 _ ->
348 Nothing
350 -- TO NODES
352 aliasToNode (A.A (region, _) (D.Type name tvars alias)) =
353 node region name tvars alias
354 in
355 (
356 map aliasToNode aliases
357 ,
358 concat
359 [ map (infixToPatch (Var.topLevel moduleName)) infixes
360 , Maybe.mapMaybe aliasToPatches aliases
361 , concatMap unionToPatches unions
362 , concatMap defToPatches defs
363 ]
364 )
367infixToPatch :: (Text -> Var.Canonical) -> D.Infix -> Env.Patch
368infixToPatch toVar (D.Infix name assoc prec) =
369 Env.Infix (toVar name) assoc prec
373-- EFFECTS TO PATCHES
376effectsToPatches :: ModuleName.Canonical -> Effects.Raw -> [Env.Patch]
377effectsToPatches moduleName effects =
378 case effects of
379 Effects.None ->
380 []
382 Effects.Port ports ->
383 let
384 toPatch (A.A _ (Effects.PortRaw name _)) =
385 Env.Value name (Var.topLevel moduleName name)
386 in
387 map toPatch ports
389 Effects.Manager _ info ->
390 map (\name -> Env.Value name (Var.topLevel moduleName name)) $
391 case Effects._managerType info of
392 Effects.CmdManager _ ->
393 [ "command" ]
395 Effects.SubManager _ ->
396 [ "subscription" ]
398 Effects.FxManager _ _ ->
399 [ "command", "subscription" ]
403-- RESTRICT VISIBLE API OF INTERFACES
406restrictToPublicApi :: Module.Interface -> Module.Interface
407restrictToPublicApi interface =
408 let
409 (Exposing.Canonical values aliases unions) =
410 Module.iExports interface
411 in
412 interface
413 { Module.iTypes = Map.fromList $
414 Maybe.mapMaybe (get (Module.iTypes interface)) (values ++ concatMap snd unions)
416 , Module.iAliases = Map.fromList $
417 Maybe.mapMaybe (get (Module.iAliases interface)) aliases
419 , Module.iUnions = Map.fromList $
420 Maybe.mapMaybe (trimUnions interface) unions
421 }
425get :: Map.Map Text a -> Text -> Maybe (Text, a)
426get dict key =
427 case Map.lookup key dict of
428 Nothing ->
429 Nothing
431 Just value ->
432 Just (key, value)
435trimUnions :: Module.Interface -> (Text, [Text]) -> Maybe (Text, Module.UnionInfo Text)
436trimUnions interface (name, exposedCtors) =
437 case Map.lookup name (Module.iUnions interface) of
438 Nothing ->
439 Nothing
441 Just (tvars, ctors) ->
442 let
443 isExposed (ctor, _) =
444 ctor `elem` exposedCtors
445 in
446 Just (name, (tvars, filter isExposed ctors))