@@ -30,11 +30,18 @@ import qualified Transform.Interface as Interface
3030
3131environment :: Module.Interfaces -> Module.ValidModule -> Canonicalizer [Doc] Environment
3232environment interfaces modul@(Module.Module _ _ _ imports decls) =
33− do () <- allImportsAvailable
34− let moduleName = Module.names modul
35− nonLocalEnv <- foldM (addImports moduleName interfaces) (builtIns moduleName) imports
36− let (aliases, env) = List.foldl' (addDecl moduleName) ([], nonLocalEnv) decls
37− addTypeAliases moduleName aliases env
33+ do () <- allImportsAvailable
34+ let moduleName =
35+ Module.names modul
36+
37+ nonLocalEnv <-
38+ foldM (addImports moduleName interfaces) (builtIns moduleName) imports
39+
40+ let (aliases, env) =
41+ List.foldl' (addDecl moduleName) ([], nonLocalEnv) decls
42+
43+ addTypeAliases moduleName aliases env
44+
3845 where
3946 allImportsAvailable :: Canonicalizer [Doc] ()
4047 allImportsAvailable =
@@ -42,53 +49,80 @@ environment interfaces modul@(Module.Module _ _ _ imports decls) =
4249 [] -> return ()
4350 missings -> throwError [ P.text (missingModuleError missings) ]
4451 where
45− modules = map fst imports
52+ modules =
53+ map fst imports
4654
47− found m = Map.member m interfaces || Module.nameIsNative m
55+ found m =
56+ Map.member m interfaces || Module.nameIsNative m
4857
4958 missingModuleError missings =
50− concat [ "The following imports were not found:\n "
51− , List.intercalate ", " (map Module.nameToString missings)
52− ]
59+ concat
60+ [ "The following imports were not found:\n "
61+ , List.intercalate ", " (map Module.nameToString missings)
62+ ]
5363
5464
55−addImports :: Module.Name -> Module.Interfaces -> Environment -> (Module.Name, Module.ImportMethod)
56− -> Canonicalizer [Doc] Environment
65+addImports
66+ :: Module.Name
67+ -> Module.Interfaces
68+ -> Environment
69+ -> (Module.Name, Module.ImportMethod)
70+ -> Canonicalizer [Doc] Environment
5771addImports moduleName interfaces environ (name, method)
58− | Module.nameIsNative name = return environ
72+ | Module.nameIsNative name =
73+ return environ
74+
5975 | otherwise =
60− case method of
61− Module.As name' ->
62− return (updateEnviron (name' ++ "."))
76+ let (Module.ImportMethod maybeAlias listing) = method
6377
64− Module.Open (Var.Listing vs open)
65− | open -> return (updateEnviron "")
66− | otherwise -> foldM (addValue name interface) environ vs
67− where
68− interface = Interface.filterExports ((Map.!) interfaces name)
69−
70− updateEnviron prefix =
71− let dict' = dict . map (first (prefix++)) in
72− merge environ $
73− Env { _home = moduleName
74− , _values = dict' $ map pair (Map.keys (iTypes interface)) ++ ctors
75− , _adts = dict' $ map pair (Map.keys (iAdts interface))
76− , _aliases = dict' $ map alias (Map.toList (iAliases interface))
77− , _patterns = dict' $ ctors
78− }
78+ (Var.Listing exposedVars open) = listing
79+
80+ qualifier =
81+ maybe (Module.nameToString name) id maybeAlias
82+
83+ env =
84+ updateEnviron (qualifier ++ ".") environ
85+ in
86+ if open
87+ then return (updateEnviron "" env)
88+ else foldM (addValue name interface) env exposedVars
89+ where
90+ interface =
91+ Interface.filterExports ((Map.!) interfaces name)
92+
93+ updateEnviron prefix env =
94+ let dict' = dict . map (first (prefix++)) in
95+ merge env $
96+ Env { _home = moduleName
97+ , _values = dict' $ map pair (Map.keys (iTypes interface)) ++ ctors
98+ , _adts = dict' $ map pair (Map.keys (iAdts interface))
99+ , _aliases = dict' $ map alias (Map.toList (iAliases interface))
100+ , _patterns = dict' $ ctors
101+ }
79102
80− canonical :: String -> Var.Canonical
81− canonical = Var.Canonical (Var.Module name)
103+ canonical :: String -> Var.Canonical
104+ canonical =
105+ Var.Canonical (Var.Module name)
82106
83− pair :: String -> (String, Var.Canonical)
84− pair key = (key, canonical key)
107+ pair :: String -> (String, Var.Canonical)
108+ pair key =
109+ (key, canonical key)
85110
86− alias (x,(tvars,tipe)) = (x, (canonical x, tvars, tipe))
111+ alias (x,(tvars,tipe)) =
112+ (x, (canonical x, tvars, tipe))
87113
88− ctors = concatMap (map (pair . fst) . snd . snd) (Map.toList (iAdts interface))
114+ ctors =
115+ concatMap
116+ (map (pair . fst) . snd . snd)
117+ (Map.toList (iAdts interface))
89118
90−addValue :: Module.Name -> Module.Interface -> Environment -> Var.Value
91− -> Canonicalizer [Doc] Environment
119+
120+addValue
121+ :: Module.Name
122+ -> Module.Interface
123+ -> Environment
124+ -> Var.Value
125+ -> Canonicalizer [Doc] Environment
92126addValue moduleName interface env value =
93127 let name = Module.nameToString moduleName
94128 insert' x = insert x (Var.Canonical (Var.Module moduleName) x)
@@ -98,7 +132,9 @@ addValue moduleName interface env value =
98132 in
99133 case value of
100134 Var.Value x
101− | Map.notMember x (iTypes interface) -> notFound x
135+ | Map.notMember x (iTypes interface) ->
136+ notFound x
137+
102138 | otherwise ->
103139 return $ env { _values = insert' x (_values env) }
104140
@@ -126,11 +162,12 @@ addValue moduleName interface env value =
126162 case Map.lookup x (iAdts interface) of
127163 Nothing -> notFound x
128164 Just (_tvars, ctors) ->
129− do ctors' <- filterNames (map fst ctors)
130− return $ env { _adts = insert' x (_adts env)
131− , _values = foldr insert' (_values env) ctors'
132− , _patterns = foldr insert' (_patterns env) ctors'
133− }
165+ do ctors' <- filterNames (map fst ctors)
166+ return $ env
167+ { _adts = insert' x (_adts env)
168+ , _values = foldr insert' (_values env) ctors'
169+ , _patterns = foldr insert' (_patterns env) ctors'
170+ }
134171 where
135172 filterNames names
136173 | open = return names
@@ -139,19 +176,22 @@ addValue moduleName interface env value =
139176 [] -> return names
140177 c:_ -> notFound c
141178
179+
142180type Node = ((String, [String], Type.RawType), String, [String])
143181
182+
144183node :: String -> [String] -> Type.RawType -> Node
145−node name tvars alias = ((name, tvars, alias), name, edges alias)
146− where
147− edges tipe =
148− case tipe of
149− Type.Lambda t1 t2 -> edges t1 ++ edges t2
150− Type.Var _ -> []
151− Type.Type (Var.Raw x) -> [x]
152− Type.App t ts -> edges t ++ concatMap edges ts
153− Type.Record fs ext -> maybe [] edges ext ++ concatMap (edges . snd) fs
154− Type.Aliased _ t -> edges t
184+node name tvars alias =
185+ ((name, tvars, alias), name, edges alias)
186+ where
187+ edges tipe =
188+ case tipe of
189+ Type.Lambda t1 t2 -> edges t1 ++ edges t2
190+ Type.Var _ -> []
191+ Type.Type (Var.Raw x) -> [x]
192+ Type.App t ts -> edges t ++ concatMap edges ts
193+ Type.Record fs ext -> maybe [] edges ext ++ concatMap (edges . snd) fs
194+ Type.Aliased _ t -> edges t
155195
156196
157197addTypeAliases
@@ -232,7 +272,11 @@ typeAliasErrorExplanation =
232272-- When canonicalizing, all _values should be Local, but all _adts and _patterns
233273-- should be fully namespaced. With _adts, they may appear in types that can
234274-- escape the module.
235−addDecl :: Module.Name -> ([Node], Environment) -> D.ValidDecl -> ([Node], Environment)
275+addDecl
276+ :: Module.Name
277+ -> ([Node], Environment)
278+ -> D.ValidDecl
279+ -> ([Node], Environment)
236280addDecl moduleName info@(nodes,env) decl =
237281 let namespacedVar = Var.Canonical (Var.Module moduleName)
238282 addLocal x e = insert x (Var.local x) e
@@ -241,29 +285,41 @@ addDecl moduleName info@(nodes,env) decl =
241285 case decl of
242286 D.Definition (Valid.Definition pattern _ _) ->
243287 (,) nodes $ env
244− { _values = foldr addLocal (_values env) (P.boundVarList pattern) }
288+ { _values =
289+ foldr addLocal (_values env) (P.boundVarList pattern)
290+ }
245291
246292 D.Datatype name _ ctors ->
247293 (,) nodes $ env
248− { _values = addCtors addLocal (_values env)
249− , _adts = addNamespaced name (_adts env)
250− , _patterns = addCtors addNamespaced (_patterns env)
251− }
294+ { _values =
295+ addCtors addLocal (_values env)
296+ , _adts =
297+ addNamespaced name (_adts env)
298+ , _patterns =
299+ addCtors addNamespaced (_patterns env)
300+ }
252301 where
253302 addCtors how e = foldr how e (map fst ctors)
254303
255304 D.TypeAlias name tvars alias ->
256305 (,) (node name tvars alias : nodes) $ env
257− { _values = case alias of
258− Type.Record _ _ -> addLocal name (_values env)
259− _ -> _values env
260− }
306+ { _values =
307+ case alias of
308+ Type.Record _ _ ->
309+ addLocal name (_values env)
310+ _ ->
311+ _values env
312+ }
261313
262314 D.Port port ->
263− let portName = case port of
264− D.Out name _ _ -> name
265− D.In name _ -> name
315+ let portName =
316+ case port of
317+ D.Out name _ _ -> name
318+ D.In name _ -> name
266319 in
267− (,) nodes $ env { _values = addLocal portName (_values env) }
320+ (,) nodes $ env
321+ { _values =
322+ addLocal portName (_values env)
323+ }
268324
269325 D.Fixity _ _ _ -> info