git.iko.soy/elk
on master help sign in
Update to more modern indentation style
1cf108fEvan Czaplicki
src/Transform/Canonicalize/Setup.hs+111−63
compare with master
unifiedsplit
@@ -30,11 +30,18 @@ import qualified Transform.Interface as Interface
30
30
31environment :: Module.Interfaces -> Module.ValidModule -> Canonicalizer [Doc] Environment
31environment :: Module.Interfaces -> Module.ValidModule -> Canonicalizer [Doc] Environment
32environment interfaces modul@(Module.Module _ _ _ imports decls) =
32environment interfaces modul@(Module.Module _ _ _ imports decls) =
33− do () <- allImportsAvailable
33+ do () <- allImportsAvailable
34+ let moduleName =
34− let moduleName = Module.names modul
35+ Module.names modul
36+
37+ nonLocalEnv <-
35− nonLocalEnv <- foldM (addImports moduleName interfaces) (builtIns moduleName) imports
38+ foldM (addImports moduleName interfaces) (builtIns moduleName) imports
39+
40+ let (aliases, env) =
36− let (aliases, env) = List.foldl' (addDecl moduleName) ([], nonLocalEnv) decls
41+ List.foldl' (addDecl moduleName) ([], nonLocalEnv) decls
42+
37− addTypeAliases moduleName aliases env
43+ addTypeAliases moduleName aliases env
44+
38 where
45 where
39 allImportsAvailable :: Canonicalizer [Doc] ()
46 allImportsAvailable :: Canonicalizer [Doc] ()
40 allImportsAvailable =
47 allImportsAvailable =
@@ -42,20 +49,29 @@ environment interfaces modul@(Module.Module _ _ _ imports decls) =
42 [] -> return ()
49 [] -> return ()
43 missings -> throwError [ P.text (missingModuleError missings) ]
50 missings -> throwError [ P.text (missingModuleError missings) ]
44 where
51 where
52+ modules =
45− modules = map fst imports
53+ map fst imports
46
54
55+ found m =
47− found m = Map.member m interfaces || Module.nameIsNative m
56+ Map.member m interfaces || Module.nameIsNative m
48
57
49 missingModuleError missings =
58 missingModuleError missings =
59+ concat
50− concat [ "The following imports were not found:\n "
60+ [ "The following imports were not found:\n "
51− , List.intercalate ", " (map Module.nameToString missings)
61+ , List.intercalate ", " (map Module.nameToString missings)
52− ]
62+ ]
53
63
54
64
65+addImports
66+ :: Module.Name
67+ -> Module.Interfaces
68+ -> Environment
55−addImports :: Module.Name -> Module.Interfaces -> Environment -> (Module.Name, Module.ImportMethod)
69+ -> (Module.Name, Module.ImportMethod)
56− -> Canonicalizer [Doc] Environment
70+ -> Canonicalizer [Doc] Environment
57addImports moduleName interfaces environ (name, method)
71addImports moduleName interfaces environ (name, method)
58− | Module.nameIsNative name = return environ
72+ | Module.nameIsNative name =
73+ return environ
74+
59 | otherwise =
75 | otherwise =
60 case method of
76 case method of
61 Module.As name' ->
77 Module.As name' ->
@@ -64,31 +80,41 @@ addImports moduleName interfaces environ (name, method)
64 Module.Open (Var.Listing vs open)
80 Module.Open (Var.Listing vs open)
65 | open -> return (updateEnviron "")
81 | open -> return (updateEnviron "")
66 | otherwise -> foldM (addValue name interface) environ vs
82 | otherwise -> foldM (addValue name interface) environ vs
67− where
83+ where
84+ interface =
68− interface = Interface.filterExports ((Map.!) interfaces name)
85+ Interface.filterExports ((Map.!) interfaces name)
69−
86+
70− updateEnviron prefix =
87+ updateEnviron prefix =
71− let dict' = dict . map (first (prefix++)) in
88+ let dict' = dict . map (first (prefix++)) in
72− merge environ $
89+ merge environ $
73− Env { _home = moduleName
90+ Env { _home = moduleName
74− , _values = dict' $ map pair (Map.keys (iTypes interface)) ++ ctors
91+ , _values = dict' $ map pair (Map.keys (iTypes interface)) ++ ctors
75− , _adts = dict' $ map pair (Map.keys (iAdts interface))
92+ , _adts = dict' $ map pair (Map.keys (iAdts interface))
76− , _aliases = dict' $ map alias (Map.toList (iAliases interface))
93+ , _aliases = dict' $ map alias (Map.toList (iAliases interface))
77− , _patterns = dict' $ ctors
94+ , _patterns = dict' $ ctors
78− }
95+ }
96+
97+ canonical :: String -> Var.Canonical
98+ canonical =
99+ Var.Canonical (Var.Module name)
79
100
80− canonical :: String -> Var.Canonical
101+ pair :: String -> (String, Var.Canonical)
81− canonical = Var.Canonical (Var.Module name)
102+ pair key =
103+ (key, canonical key)
82
104
83− pair :: String -> (String, Var.Canonical)
105+ alias (x,(tvars,tipe)) =
84− pair key = (key, canonical key)
106+ (x, (canonical x, tvars, tipe))
85
107
86− alias (x,(tvars,tipe)) = (x, (canonical x, tvars, tipe))
108+ ctors =
109+ concatMap (map (pair . fst) . snd . snd) (Map.toList (iAdts interface))
87
110
88− ctors = concatMap (map (pair . fst) . snd . snd) (Map.toList (iAdts interface))
89
111
112+addValue
113+ :: Module.Name
90−addValue :: Module.Name -> Module.Interface -> Environment -> Var.Value
114+ -> Module.Interface
115+ -> Environment
116+ -> Var.Value
91− -> Canonicalizer [Doc] Environment
117+ -> Canonicalizer [Doc] Environment
92addValue moduleName interface env value =
118addValue moduleName interface env value =
93 let name = Module.nameToString moduleName
119 let name = Module.nameToString moduleName
94 insert' x = insert x (Var.Canonical (Var.Module moduleName) x)
120 insert' x = insert x (Var.Canonical (Var.Module moduleName) x)
@@ -98,7 +124,9 @@ addValue moduleName interface env value =
98 in
124 in
99 case value of
125 case value of
100 Var.Value x
126 Var.Value x
101− | Map.notMember x (iTypes interface) -> notFound x
127+ | Map.notMember x (iTypes interface) ->
128+ notFound x
129+
102 | otherwise ->
130 | otherwise ->
103 return $ env { _values = insert' x (_values env) }
131 return $ env { _values = insert' x (_values env) }
104
132
@@ -126,11 +154,12 @@ addValue moduleName interface env value =
126 case Map.lookup x (iAdts interface) of
154 case Map.lookup x (iAdts interface) of
127 Nothing -> notFound x
155 Nothing -> notFound x
128 Just (_tvars, ctors) ->
156 Just (_tvars, ctors) ->
129− do ctors' <- filterNames (map fst ctors)
157+ do ctors' <- filterNames (map fst ctors)
158+ return $ env
130− return $ env { _adts = insert' x (_adts env)
159+ { _adts = insert' x (_adts env)
131− , _values = foldr insert' (_values env) ctors'
160+ , _values = foldr insert' (_values env) ctors'
132− , _patterns = foldr insert' (_patterns env) ctors'
161+ , _patterns = foldr insert' (_patterns env) ctors'
133− }
162+ }
134 where
163 where
135 filterNames names
164 filterNames names
136 | open = return names
165 | open = return names
@@ -139,19 +168,22 @@ addValue moduleName interface env value =
139 [] -> return names
168 [] -> return names
140 c:_ -> notFound c
169 c:_ -> notFound c
141
170
171+
142type Node = ((String, [String], Type.RawType), String, [String])
172type Node = ((String, [String], Type.RawType), String, [String])
143
173
174+
144node :: String -> [String] -> Type.RawType -> Node
175node :: String -> [String] -> Type.RawType -> Node
176+node name tvars alias =
145−node name tvars alias = ((name, tvars, alias), name, edges alias)
177+ ((name, tvars, alias), name, edges alias)
146− where
178+ where
147− edges tipe =
179+ edges tipe =
148− case tipe of
180+ case tipe of
149− Type.Lambda t1 t2 -> edges t1 ++ edges t2
181+ Type.Lambda t1 t2 -> edges t1 ++ edges t2
150− Type.Var _ -> []
182+ Type.Var _ -> []
151− Type.Type (Var.Raw x) -> [x]
183+ Type.Type (Var.Raw x) -> [x]
152− Type.App t ts -> edges t ++ concatMap edges ts
184+ Type.App t ts -> edges t ++ concatMap edges ts
153− Type.Record fs ext -> maybe [] edges ext ++ concatMap (edges . snd) fs
185+ Type.Record fs ext -> maybe [] edges ext ++ concatMap (edges . snd) fs
154− Type.Aliased _ t -> edges t
186+ Type.Aliased _ t -> edges t
155
187
156
188
157addTypeAliases
189addTypeAliases
@@ -232,7 +264,11 @@ typeAliasErrorExplanation =
232-- When canonicalizing, all _values should be Local, but all _adts and _patterns
264-- When canonicalizing, all _values should be Local, but all _adts and _patterns
233-- should be fully namespaced. With _adts, they may appear in types that can
265-- should be fully namespaced. With _adts, they may appear in types that can
234-- escape the module.
266-- escape the module.
267+addDecl
268+ :: Module.Name
235−addDecl :: Module.Name -> ([Node], Environment) -> D.ValidDecl -> ([Node], Environment)
269+ -> ([Node], Environment)
270+ -> D.ValidDecl
271+ -> ([Node], Environment)
236addDecl moduleName info@(nodes,env) decl =
272addDecl moduleName info@(nodes,env) decl =
237 let namespacedVar = Var.Canonical (Var.Module moduleName)
273 let namespacedVar = Var.Canonical (Var.Module moduleName)
238 addLocal x e = insert x (Var.local x) e
274 addLocal x e = insert x (Var.local x) e
@@ -241,29 +277,41 @@ addDecl moduleName info@(nodes,env) decl =
241 case decl of
277 case decl of
242 D.Definition (Valid.Definition pattern _ _) ->
278 D.Definition (Valid.Definition pattern _ _) ->
243 (,) nodes $ env
279 (,) nodes $ env
280+ { _values =
244− { _values = foldr addLocal (_values env) (P.boundVarList pattern) }
281+ foldr addLocal (_values env) (P.boundVarList pattern)
282+ }
245
283
246 D.Datatype name _ ctors ->
284 D.Datatype name _ ctors ->
247 (,) nodes $ env
285 (,) nodes $ env
286+ { _values =
248− { _values = addCtors addLocal (_values env)
287+ addCtors addLocal (_values env)
288+ , _adts =
249− , _adts = addNamespaced name (_adts env)
289+ addNamespaced name (_adts env)
290+ , _patterns =
250− , _patterns = addCtors addNamespaced (_patterns env)
291+ addCtors addNamespaced (_patterns env)
251− }
292+ }
252 where
293 where
253 addCtors how e = foldr how e (map fst ctors)
294 addCtors how e = foldr how e (map fst ctors)
254
295
255 D.TypeAlias name tvars alias ->
296 D.TypeAlias name tvars alias ->
256 (,) (node name tvars alias : nodes) $ env
297 (,) (node name tvars alias : nodes) $ env
298+ { _values =
257− { _values = case alias of
299+ case alias of
300+ Type.Record _ _ ->
258− Type.Record _ _ -> addLocal name (_values env)
301+ addLocal name (_values env)
302+ _ ->
259− _ -> _values env
303+ _values env
260− }
304+ }
261
305
262 D.Port port ->
306 D.Port port ->
263− let portName = case port of
307+ let portName =
308+ case port of
264− D.Out name _ _ -> name
309+ D.Out name _ _ -> name
265− D.In name _ -> name
310+ D.In name _ -> name
266 in
311 in
312+ (,) nodes $ env
313+ { _values =
267− (,) nodes $ env { _values = addLocal portName (_values env) }
314+ addLocal portName (_values env)
315+ }
268
316
269 D.Fixity _ _ _ -> info
317 D.Fixity _ _ _ -> info