git.iko.soy/elk
on master help sign in
Split canonicalization setup into new module
25eaad1Evan Czaplicki
compiler/Transform/Canonicalize.hs+3−145
compare with master
unifiedsplit
@@ -2,8 +2,6 @@
2module Transform.Canonicalize (module', filterExports) where
2module Transform.Canonicalize (module', filterExports) where
3
3
4import Control.Applicative ((<$>),(<*>))
4import Control.Applicative ((<$>),(<*>))
5−import Control.Arrow (first)
6−import Control.Monad (foldM)
7import qualified Data.Either as Either
5import qualified Data.Either as Either
8import qualified Data.List as List
6import qualified Data.List as List
9import qualified Data.Map as Map
7import qualified Data.Map as Map
@@ -13,7 +11,7 @@ import AST.Expression.General (Expr'(..), dummyLet)
13import qualified AST.Expression.Valid as Valid
11import qualified AST.Expression.Valid as Valid
14import qualified AST.Expression.Canonical as Canonical
12import qualified AST.Expression.Canonical as Canonical
15
13
16−import AST.Module (Interface(iAdts, iTypes, iAliases), CanonicalBody(..))
14+import AST.Module (CanonicalBody(..))
17import qualified AST.Module as Module
15import qualified AST.Module as Module
18import qualified AST.Type as Type
16import qualified AST.Type as Type
19import qualified AST.Variable as Var
17import qualified AST.Variable as Var
@@ -24,137 +22,15 @@ import qualified AST.Pattern as P
24import Text.PrettyPrint as P
22import Text.PrettyPrint as P
25
23
26import Transform.Canonicalize.Environment as Env
24import Transform.Canonicalize.Environment as Env
25+import qualified Transform.Canonicalize.Setup as Setup
27import qualified Transform.Canonicalize.Type as Canonicalize
26import qualified Transform.Canonicalize.Type as Canonicalize
28import qualified Transform.Canonicalize.Variable as Canonicalize
27import qualified Transform.Canonicalize.Variable as Canonicalize
29import qualified Transform.SortDefinitions as Transform
28import qualified Transform.SortDefinitions as Transform
30import qualified Transform.Declaration as Transform
29import qualified Transform.Declaration as Transform
31
30
32−environment :: Module.Interfaces -> Module.ValidModule -> Either [Doc] Environment
33−environment interfaces m@(Module.Module _ _ _ ims decls) =
34− do () <- allImportsAvailable interfaces ims
35− nonLocalEnv <- foldM (toEnv interfaces) Env.builtIns ims
36− let moduleName = Module.getName m
37− foldM (addDecl moduleName) nonLocalEnv decls
38−
39−toEnv :: Module.Interfaces -> Environment -> (String, Module.ImportMethod)
40− -> Either [Doc] Environment
41−toEnv interfaces environ (name,method)
42− | List.isPrefixOf "Native." name = return environ
43− | otherwise =
44− case method of
45− Module.As name' ->
46− return (updateEnviron (name' ++ "."))
47−
48− Module.Open (Var.Listing vs open)
49− | open -> return (updateEnviron "")
50− | otherwise -> foldM (addValue name interface) environ vs
51− where
52− interface = (Map.!) interfaces name
53−
54− updateEnviron prefix =
55− let dict' = dict . map (first (prefix++)) in
56− merge environ $
57− Env { _values = dict' $ map pair (Map.keys (iTypes interface)) ++ ctors
58− , _adts = dict' $ map pair (Map.keys (iAdts interface))
59− , _aliases = dict' $ map alias (Map.toList (iAliases interface))
60− , _patterns = dict' $ ctors
61− }
62−
63− canonical :: String -> Var.Canonical
64− canonical = Var.Canonical (Var.Module name)
65−
66− pair :: String -> (String, Var.Canonical)
67− pair key = (key, canonical key)
68−
69− alias (x,(tvars,tipe)) = (x, (canonical x, tvars, tipe))
70−
71− ctors = concatMap (map (pair . fst) . snd . snd) (Map.toList (iAdts interface))
72−
73−addValue :: String -> Module.Interface -> Environment -> Var.Value
74− -> Either [Doc] Environment
75−addValue name interface env value =
76− let insert' x = Env.insert x (Var.Canonical (Var.Module name) x)
77− msg x = "Import Error: Could not import value '" ++ name ++ "." ++ x ++
78− "'.\n It is not exported by module " ++ name ++ "."
79− notFound x = Left [ P.text (msg x) ]
80− in
81− case value of
82− Var.Value x
83− | Map.notMember x (iTypes interface) -> notFound x
84− | otherwise ->
85− return $ env { _values = insert' x (_values env) }
86−
87− Var.Alias x ->
88− case Map.lookup x (iAliases interface) of
89− Just (tvars, t) ->
90− let v = (Var.Canonical (Var.Module name) x, tvars, t) in
91− return $ env { _aliases = Env.insert x v (_aliases env) }
92− Nothing ->
93− case Map.lookup x (iAdts interface) of
94− Nothing -> notFound x
95− Just (_,_) ->
96− return $ env { _adts = insert' x (_adts env) }
97−
98− Var.ADT x (Var.Listing xs open) ->
99− case Map.lookup x (iAdts interface) of
100− Nothing -> notFound x
101− Just (_tvars, ctors) ->
102− do ctors <- filterNames (map fst ctors)
103− return $ env { _adts = insert' x (_adts env)
104− , _values = foldr insert' (_values env) ctors
105− , _patterns = foldr insert' (_patterns env) ctors
106− }
107− where
108− filterNames names
109− | open = return names
110− | otherwise =
111− case filter (`notElem` names) xs of
112− [] -> return names
113− c:_ -> notFound c
114−
115−-- When canonicalizing, all _values should be Local, but all _adts and _patterns
116−-- should be fully namespaced. With _adts, they may appear in types that can
117−-- escape the module.
118−addDecl :: String -> Environment -> D.ValidDecl -> Either [Doc] Environment
119−addDecl moduleName env decl =
120− let namespacedVar = Var.Canonical (Var.Module moduleName)
121− addLocal x e = Env.insert x (Var.local x) e
122− addNamespaced x e = Env.insert x (namespacedVar x) e
123− in
124− case decl of
125− D.Definition (Valid.Definition pattern _ _) ->
126− return $ env
127− { _values = foldr addLocal (_values env) (P.boundVarList pattern) }
128−
129− D.Datatype name _ ctors ->
130− return $ env
131− { _values = addCtors addLocal (_values env)
132− , _adts = addNamespaced name (_adts env)
133− , _patterns = addCtors addNamespaced (_patterns env)
134− }
135− where
136− addCtors how e = foldr how e (map fst ctors)
137−
138− D.TypeAlias name tvars alias ->
139− do alias' <- Either.either throw return (Canonicalize.tipe env alias)
140− return $ env
141− { _aliases = Env.insert name (namespacedVar name, tvars, alias') (_aliases env)
142− , _values = case alias of
143− Type.Record _ _ -> addLocal name (_values env)
144− _ -> _values env
145− }
146− where
147− throw err =
148− let msg = "Error in type alias '" ++ name ++ "':"
149− in Left [ P.vcat [ P.text msg, P.text err ] ]
150−
151− D.Port _ -> return env
152−
153− D.Fixity _ _ _ -> return env
154−
155module' :: Module.Interfaces -> Module.ValidModule -> Either [Doc] Module.CanonicalModule
31module' :: Module.Interfaces -> Module.ValidModule -> Either [Doc] Module.CanonicalModule
156module' interfaces modul@(Module.Module _ _ exs _ decls) =
32module' interfaces modul@(Module.Module _ _ exs _ decls) =
157− do env <- environment interfaces modul
33+ do env <- Setup.environment interfaces modul
158 canonicalDecls <- mapM (declaration env) decls
34 canonicalDecls <- mapM (declaration env) decls
159 exports' <- delist locals exs
35 exports' <- delist locals exs
160 return $ modul { Module.exports = exports'
36 return $ modul { Module.exports = exports'
@@ -285,24 +161,6 @@ declaration env decl =
285 D.Fixity assoc prec op -> return $ D.Fixity assoc prec op
161 D.Fixity assoc prec op -> return $ D.Fixity assoc prec op
286
162
287
163
288−allImportsAvailable :: Module.Interfaces
289− -> [(String, Module.ImportMethod)]
290− -> Either [Doc] ()
291−allImportsAvailable interfaces imports =
292− case filter (not . found) modules of
293− [] -> Right ()
294− missings -> Left [ P.text (missingModuleError missings) ]
295− where
296− modules = map fst imports
297−
298− found m = Map.member m interfaces || List.isPrefixOf "Native." m
299−
300− missingModuleError missings =
301− concat [ "The following imports were not found: "
302− , List.intercalate ", " missings
303− , "\n You may need to compile with the --make "
304− , "flag to detect modules you have written." ]
305−
306expression :: Environment -> Valid.Expr -> Either [Doc] Canonical.Expr
164expression :: Environment -> Valid.Expr -> Either [Doc] Canonical.Expr
307expression env (A.A ann expr) =
165expression env (A.A ann expr) =
308 let go = expression env
166 let go = expression env
compiler/Transform/Canonicalize/Setup.hsnew file+214
@@ -0,0 +1,214 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Transform.Canonicalize.Setup (environment) where
3+
4+import Control.Arrow (first)
5+import Control.Monad (foldM)
6+import qualified Data.Either as Either
7+import qualified Data.Graph as Graph
8+import qualified Data.List as List
9+import qualified Data.Map as Map
10+
11+import qualified AST.Expression.Valid as Valid
12+
13+import AST.Module (Interface(iAdts, iTypes, iAliases))
14+import qualified AST.Module as Module
15+import qualified AST.Type as Type
16+import qualified AST.Variable as Var
17+import qualified AST.Declaration as D
18+import AST.PrettyPrint (pretty, eightyCharLines)
19+import qualified AST.Pattern as P
20+import Text.PrettyPrint as P
21+
22+import Transform.Canonicalize.Environment as Env
23+import qualified Transform.Canonicalize.Type as Canonicalize
24+
25+environment :: Module.Interfaces -> Module.ValidModule -> Either [Doc] Environment
26+environment interfaces modul@(Module.Module _ _ _ imports decls) =
27+ do () <- allImportsAvailable
28+ nonLocalEnv <- foldM (addImports interfaces) builtIns imports
29+ let moduleName = Module.getName modul
30+ (aliases, env) = List.foldl' (addDecl moduleName) ([], nonLocalEnv) decls
31+ addTypeAliases moduleName aliases env
32+ where
33+ allImportsAvailable :: Either [Doc] ()
34+ allImportsAvailable =
35+ case filter (not . found) modules of
36+ [] -> Right ()
37+ missings -> Left [ P.text (missingModuleError missings) ]
38+ where
39+ modules = map fst imports
40+
41+ found m = Map.member m interfaces || List.isPrefixOf "Native." m
42+
43+ missingModuleError missings =
44+ concat [ "The following imports were not found: "
45+ , List.intercalate ", " missings
46+ , "\n You may need to compile with the --make "
47+ , "flag to detect modules you have written." ]
48+
49+addImports :: Module.Interfaces -> Environment -> (String, Module.ImportMethod)
50+ -> Either [Doc] Environment
51+addImports interfaces environ (name,method)
52+ | List.isPrefixOf "Native." name = return environ
53+ | otherwise =
54+ case method of
55+ Module.As name' ->
56+ return (updateEnviron (name' ++ "."))
57+
58+ Module.Open (Var.Listing vs open)
59+ | open -> return (updateEnviron "")
60+ | otherwise -> foldM (addValue name interface) environ vs
61+ where
62+ interface = (Map.!) interfaces name
63+
64+ updateEnviron prefix =
65+ let dict' = dict . map (first (prefix++)) in
66+ merge environ $
67+ Env { _values = dict' $ map pair (Map.keys (iTypes interface)) ++ ctors
68+ , _adts = dict' $ map pair (Map.keys (iAdts interface))
69+ , _aliases = dict' $ map alias (Map.toList (iAliases interface))
70+ , _patterns = dict' $ ctors
71+ }
72+
73+ canonical :: String -> Var.Canonical
74+ canonical = Var.Canonical (Var.Module name)
75+
76+ pair :: String -> (String, Var.Canonical)
77+ pair key = (key, canonical key)
78+
79+ alias (x,(tvars,tipe)) = (x, (canonical x, tvars, tipe))
80+
81+ ctors = concatMap (map (pair . fst) . snd . snd) (Map.toList (iAdts interface))
82+
83+addValue :: String -> Module.Interface -> Environment -> Var.Value
84+ -> Either [Doc] Environment
85+addValue name interface env value =
86+ let insert' x = insert x (Var.Canonical (Var.Module name) x)
87+ msg x = "Import Error: Could not import value '" ++ name ++ "." ++ x ++
88+ "'.\n It is not exported by module " ++ name ++ "."
89+ notFound x = Left [ P.text (msg x) ]
90+ in
91+ case value of
92+ Var.Value x
93+ | Map.notMember x (iTypes interface) -> notFound x
94+ | otherwise ->
95+ return $ env { _values = insert' x (_values env) }
96+
97+ Var.Alias x ->
98+ case Map.lookup x (iAliases interface) of
99+ Just (tvars, t) ->
100+ let v = (Var.Canonical (Var.Module name) x, tvars, t) in
101+ return $ env { _aliases = insert x v (_aliases env) }
102+ Nothing ->
103+ case Map.lookup x (iAdts interface) of
104+ Nothing -> notFound x
105+ Just (_,_) ->
106+ return $ env { _adts = insert' x (_adts env) }
107+
108+ Var.ADT x (Var.Listing xs open) ->
109+ case Map.lookup x (iAdts interface) of
110+ Nothing -> notFound x
111+ Just (_tvars, ctors) ->
112+ do ctors' <- filterNames (map fst ctors)
113+ return $ env { _adts = insert' x (_adts env)
114+ , _values = foldr insert' (_values env) ctors'
115+ , _patterns = foldr insert' (_patterns env) ctors'
116+ }
117+ where
118+ filterNames names
119+ | open = return names
120+ | otherwise =
121+ case filter (`notElem` names) xs of
122+ [] -> return names
123+ c:_ -> notFound c
124+
125+type Node = ((String, [String], Type.RawType), String, [String])
126+
127+node :: String -> [String] -> Type.RawType -> Node
128+node name tvars alias = ((name, tvars, alias), name, edges alias)
129+ where
130+ edges tipe =
131+ case tipe of
132+ Type.Lambda t1 t2 -> edges t1 ++ edges t2
133+ Type.Var _ -> []
134+ Type.Type (Var.Raw x) -> [x]
135+ Type.App t ts -> edges t ++ concatMap edges ts
136+ Type.Record fs ext -> maybe [] edges ext ++ concatMap (edges . snd) fs
137+ Type.Aliased _ t -> edges t
138+
139+addTypeAliases :: String -> [Node] -> Environment -> Either [Doc] Environment
140+addTypeAliases moduleName nodes environ =
141+ foldM addTypeAlias environ (Graph.stronglyConnComp nodes)
142+ where
143+ addTypeAlias :: Environment -> Graph.SCC (String, [String], Type.RawType)
144+ -> Either [Doc] Environment
145+ addTypeAlias env scc =
146+ case Graph.flattenSCC scc of
147+ [(name, tvars, alias)] ->
148+ do alias' <- Either.either throw return (Canonicalize.tipe env alias)
149+ let value = (Var.Canonical (Var.Module moduleName) name, tvars, alias')
150+ return $ env { _aliases = insert name value (_aliases env) }
151+ where
152+ throw err =
153+ let msg = "Problem with type alias '" ++ name ++ "':"
154+ in Left [ P.vcat [ P.text msg, P.text err ] ]
155+
156+ aliases ->
157+ Left [ P.vcat [ P.text (eightyCharLines 0 msg1)
158+ , indented (map typeAlias aliases)
159+ , P.text (eightyCharLines 0 msg2)
160+ , indented (map datatype aliases)
161+ , P.text (eightyCharLines 0 msg3)
162+ ]
163+ ]
164+
165+ typeAlias (n,ts,t) = D.TypeAlias n ts t
166+ datatype (n,ts,t) = D.Datatype n ts [(n,[t])]
167+
168+ indented :: [D.ValidDecl] -> Doc
169+ indented decls = P.vcat (map prty decls)
170+ where
171+ prty decl = P.text "\n " <> pretty decl <> P.text "\n"
172+
173+ msg1 = "The following type aliases are mutually recursive, forming an \
174+ \infinite type. When you expand them, they just keep getting bigger:"
175+ msg2 = "Instead, you can try something like this:"
176+ msg3 = "It looks very similar, but an algebraic data type (ADT) \
177+ \actually creates a new type. Unlike with a type alias, this \
178+ \freshly created type is meaningful on its own, so an ADT \
179+ \does not need to be expanded."
180+
181+
182+-- When canonicalizing, all _values should be Local, but all _adts and _patterns
183+-- should be fully namespaced. With _adts, they may appear in types that can
184+-- escape the module.
185+addDecl :: String -> ([Node], Environment) -> D.ValidDecl -> ([Node], Environment)
186+addDecl moduleName info@(nodes,env) decl =
187+ let namespacedVar = Var.Canonical (Var.Module moduleName)
188+ addLocal x e = insert x (Var.local x) e
189+ addNamespaced x e = insert x (namespacedVar x) e
190+ in
191+ case decl of
192+ D.Definition (Valid.Definition pattern _ _) ->
193+ (,) nodes $ env
194+ { _values = foldr addLocal (_values env) (P.boundVarList pattern) }
195+
196+ D.Datatype name _ ctors ->
197+ (,) nodes $ env
198+ { _values = addCtors addLocal (_values env)
199+ , _adts = addNamespaced name (_adts env)
200+ , _patterns = addCtors addNamespaced (_patterns env)
201+ }
202+ where
203+ addCtors how e = foldr how e (map fst ctors)
204+
205+ D.TypeAlias name tvars alias ->
206+ (,) (node name tvars alias : nodes) $ env
207+ { _values = case alias of
208+ Type.Record _ _ -> addLocal name (_values env)
209+ _ -> _values env
210+ }
211+
212+ D.Port _ -> info
213+
214+ D.Fixity _ _ _ -> info