@@ -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,20 +49,29 @@ 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 =
6076 case method of
6177 Module.As name' ->
@@ -64,31 +80,41 @@ addImports moduleName interfaces environ (name, method)
6480 Module.Open (Var.Listing vs open)
6581 | open -> return (updateEnviron "")
6682 | 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− }
83+ where
84+ interface =
85+ Interface.filterExports ((Map.!) interfaces name)
86+
87+ updateEnviron prefix =
88+ let dict' = dict . map (first (prefix++)) in
89+ merge environ $
90+ Env { _home = moduleName
91+ , _values = dict' $ map pair (Map.keys (iTypes interface)) ++ ctors
92+ , _adts = dict' $ map pair (Map.keys (iAdts interface))
93+ , _aliases = dict' $ map alias (Map.toList (iAliases interface))
94+ , _patterns = dict' $ ctors
95+ }
96+
97+ canonical :: String -> Var.Canonical
98+ canonical =
99+ Var.Canonical (Var.Module name)
79100
80− canonical :: String -> Var.Canonical
81− canonical = Var.Canonical (Var.Module name)
101+ pair :: String -> (String, Var.Canonical)
102+ pair key =
103+ (key, canonical key)
82104
83− pair :: String -> (String, Var.Canonical)
84− pair key = (key, canonical key)
105+ alias (x,(tvars,tipe)) =
106+ (x, (canonical x, tvars, tipe))
85107
86− alias (x,(tvars,tipe)) = (x, (canonical x, tvars, tipe))
108+ ctors =
109+ concatMap (map (pair . fst) . snd . snd) (Map.toList (iAdts interface))
87110
88− ctors = concatMap (map (pair . fst) . snd . snd) (Map.toList (iAdts interface))
89111
90−addValue :: Module.Name -> Module.Interface -> Environment -> Var.Value
91− -> Canonicalizer [Doc] Environment
112+addValue
113+ :: Module.Name
114+ -> Module.Interface
115+ -> Environment
116+ -> Var.Value
117+ -> Canonicalizer [Doc] Environment
92118addValue moduleName interface env value =
93119 let name = Module.nameToString moduleName
94120 insert' x = insert x (Var.Canonical (Var.Module moduleName) x)
@@ -98,7 +124,9 @@ addValue moduleName interface env value =
98124 in
99125 case value of
100126 Var.Value x
101− | Map.notMember x (iTypes interface) -> notFound x
127+ | Map.notMember x (iTypes interface) ->
128+ notFound x
129+
102130 | otherwise ->
103131 return $ env { _values = insert' x (_values env) }
104132
@@ -126,11 +154,12 @@ addValue moduleName interface env value =
126154 case Map.lookup x (iAdts interface) of
127155 Nothing -> notFound x
128156 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− }
157+ do ctors' <- filterNames (map fst ctors)
158+ return $ env
159+ { _adts = insert' x (_adts env)
160+ , _values = foldr insert' (_values env) ctors'
161+ , _patterns = foldr insert' (_patterns env) ctors'
162+ }
134163 where
135164 filterNames names
136165 | open = return names
@@ -139,19 +168,22 @@ addValue moduleName interface env value =
139168 [] -> return names
140169 c:_ -> notFound c
141170
171+
142172type Node = ((String, [String], Type.RawType), String, [String])
143173
174+
144175node :: 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
176+node name tvars alias =
177+ ((name, tvars, alias), name, edges alias)
178+ where
179+ edges tipe =
180+ case tipe of
181+ Type.Lambda t1 t2 -> edges t1 ++ edges t2
182+ Type.Var _ -> []
183+ Type.Type (Var.Raw x) -> [x]
184+ Type.App t ts -> edges t ++ concatMap edges ts
185+ Type.Record fs ext -> maybe [] edges ext ++ concatMap (edges . snd) fs
186+ Type.Aliased _ t -> edges t
155187
156188
157189addTypeAliases
@@ -232,7 +264,11 @@ typeAliasErrorExplanation =
232264-- When canonicalizing, all _values should be Local, but all _adts and _patterns
233265-- should be fully namespaced. With _adts, they may appear in types that can
234266-- escape the module.
235−addDecl :: Module.Name -> ([Node], Environment) -> D.ValidDecl -> ([Node], Environment)
267+addDecl
268+ :: Module.Name
269+ -> ([Node], Environment)
270+ -> D.ValidDecl
271+ -> ([Node], Environment)
236272addDecl moduleName info@(nodes,env) decl =
237273 let namespacedVar = Var.Canonical (Var.Module moduleName)
238274 addLocal x e = insert x (Var.local x) e
@@ -241,29 +277,41 @@ addDecl moduleName info@(nodes,env) decl =
241277 case decl of
242278 D.Definition (Valid.Definition pattern _ _) ->
243279 (,) nodes $ env
244− { _values = foldr addLocal (_values env) (P.boundVarList pattern) }
280+ { _values =
281+ foldr addLocal (_values env) (P.boundVarList pattern)
282+ }
245283
246284 D.Datatype name _ ctors ->
247285 (,) nodes $ env
248− { _values = addCtors addLocal (_values env)
249− , _adts = addNamespaced name (_adts env)
250− , _patterns = addCtors addNamespaced (_patterns env)
251− }
286+ { _values =
287+ addCtors addLocal (_values env)
288+ , _adts =
289+ addNamespaced name (_adts env)
290+ , _patterns =
291+ addCtors addNamespaced (_patterns env)
292+ }
252293 where
253294 addCtors how e = foldr how e (map fst ctors)
254295
255296 D.TypeAlias name tvars alias ->
256297 (,) (node name tvars alias : nodes) $ env
257− { _values = case alias of
258− Type.Record _ _ -> addLocal name (_values env)
259− _ -> _values env
260− }
298+ { _values =
299+ case alias of
300+ Type.Record _ _ ->
301+ addLocal name (_values env)
302+ _ ->
303+ _values env
304+ }
261305
262306 D.Port port ->
263− let portName = case port of
264− D.Out name _ _ -> name
265− D.In name _ -> name
307+ let portName =
308+ case port of
309+ D.Out name _ _ -> name
310+ D.In name _ -> name
266311 in
267− (,) nodes $ env { _values = addLocal portName (_values env) }
312+ (,) nodes $ env
313+ { _values =
314+ addLocal portName (_values env)
315+ }
268316
269317 D.Fixity _ _ _ -> info