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