git.iko.soy/elk
on d87affe help sign in
elk/src/Transform/Canonicalize/Setup.hs
232 lines 9.5 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Transform.Canonicalize.Setup (environment) where
4import Control.Arrow (first)
5import Control.Monad (foldM)
6import Control.Monad.Error (throwError)
7import qualified Data.Graph as Graph
8import qualified Data.List as List
9import qualified Data.Map as Map
11import qualified AST.Expression.Valid as Valid
13import AST.Module (Interface(iAdts, iTypes, iAliases))
14import qualified AST.Module as Module
15import qualified AST.Type as Type
16import qualified AST.Variable as Var
17import qualified AST.Declaration as D
18import AST.PrettyPrint (pretty, eightyCharLines)
19import qualified AST.Pattern as P
20import Text.PrettyPrint as P
22import Transform.Canonicalize.Environment as Env
23import qualified Transform.Canonicalize.Type as Canonicalize
24import qualified Transform.Interface as Interface
27environment :: Module.Interfaces -> Module.ValidModule -> Canonicalizer [Doc] Environment
28environment interfaces modul@(Module.Module _ _ _ imports decls) =
29 do () <- allImportsAvailable
30 let moduleName = Module.names modul
31 nonLocalEnv <- foldM (addImports moduleName interfaces) (builtIns moduleName) imports
32 let (aliases, env) = List.foldl' (addDecl moduleName) ([], nonLocalEnv) decls
33 addTypeAliases moduleName aliases env
34 where
35 allImportsAvailable :: Canonicalizer [Doc] ()
36 allImportsAvailable =
37 case filter (not . found) modules of
38 [] -> return ()
39 missings -> throwError [ P.text (missingModuleError missings) ]
40 where
41 modules = map fst imports
43 found m = Map.member m interfaces || Module.nameIsNative m
45 missingModuleError missings =
46 concat [ "The following imports were not found:\n "
47 , List.intercalate ", " (map Module.nameToString missings)
48 ]
51addImports :: Module.Name -> Module.Interfaces -> Environment -> (Module.Name, Module.ImportMethod)
52 -> Canonicalizer [Doc] Environment
53addImports moduleName interfaces environ (name, method)
54 | Module.nameIsNative name = return environ
55 | otherwise =
56 case method of
57 Module.As name' ->
58 return (updateEnviron (name' ++ "."))
60 Module.Open (Var.Listing vs open)
61 | open -> return (updateEnviron "")
62 | otherwise -> foldM (addValue name interface) environ vs
63 where
64 interface = Interface.filterExports ((Map.!) interfaces name)
66 updateEnviron prefix =
67 let dict' = dict . map (first (prefix++)) in
68 merge environ $
69 Env { _home = moduleName
70 , _values = dict' $ map pair (Map.keys (iTypes interface)) ++ ctors
71 , _adts = dict' $ map pair (Map.keys (iAdts interface))
72 , _aliases = dict' $ map alias (Map.toList (iAliases interface))
73 , _patterns = dict' $ ctors
74 }
76 canonical :: String -> Var.Canonical
77 canonical = Var.Canonical (Var.Module name)
79 pair :: String -> (String, Var.Canonical)
80 pair key = (key, canonical key)
82 alias (x,(tvars,tipe)) = (x, (canonical x, tvars, tipe))
84 ctors = concatMap (map (pair . fst) . snd . snd) (Map.toList (iAdts interface))
86addValue :: Module.Name -> Module.Interface -> Environment -> Var.Value
87 -> Canonicalizer [Doc] Environment
88addValue moduleName interface env value =
89 let name = Module.nameToString moduleName
90 insert' x = insert x (Var.Canonical (Var.Module moduleName) x)
91 msg x = "Import Error: Could not import value '" ++ name ++ "." ++ x ++
92 "'.\n It is not exported by module " ++ name ++ "."
93 notFound x = throwError [ P.text (msg x) ]
94 in
95 case value of
96 Var.Value x
97 | Map.notMember x (iTypes interface) -> notFound x
98 | otherwise ->
99 return $ env { _values = insert' x (_values env) }
101 Var.Alias x ->
102 case Map.lookup x (iAliases interface) of
103 Just (tvars, t) ->
104 return $ env
105 { _aliases = insert x v (_aliases env)
106 , _values = updatedValues
107 }
108 where
109 v = (Var.Canonical (Var.Module moduleName) x, tvars, t)
110 updatedValues =
111 if Map.member x (iTypes interface)
112 then insert' x (_values env)
113 else _values env
115 Nothing ->
116 case Map.lookup x (iAdts interface) of
117 Nothing -> notFound x
118 Just (_,_) ->
119 return $ env { _adts = insert' x (_adts env) }
121 Var.ADT x (Var.Listing xs open) ->
122 case Map.lookup x (iAdts interface) of
123 Nothing -> notFound x
124 Just (_tvars, ctors) ->
125 do ctors' <- filterNames (map fst ctors)
126 return $ env { _adts = insert' x (_adts env)
127 , _values = foldr insert' (_values env) ctors'
128 , _patterns = foldr insert' (_patterns env) ctors'
129 }
130 where
131 filterNames names
132 | open = return names
133 | otherwise =
134 case filter (`notElem` names) xs of
135 [] -> return names
136 c:_ -> notFound c
138type Node = ((String, [String], Type.RawType), String, [String])
140node :: String -> [String] -> Type.RawType -> Node
141node name tvars alias = ((name, tvars, alias), name, edges alias)
142 where
143 edges tipe =
144 case tipe of
145 Type.Lambda t1 t2 -> edges t1 ++ edges t2
146 Type.Var _ -> []
147 Type.Type (Var.Raw x) -> [x]
148 Type.App t ts -> edges t ++ concatMap edges ts
149 Type.Record fs ext -> maybe [] edges ext ++ concatMap (edges . snd) fs
150 Type.Aliased _ t -> edges t
152addTypeAliases :: Module.Name -> [Node] -> Environment -> Canonicalizer [Doc] Environment
153addTypeAliases moduleName nodes environ =
154 foldM addTypeAlias environ (Graph.stronglyConnComp nodes)
155 where
156 addTypeAlias :: Environment -> Graph.SCC (String, [String], Type.RawType)
157 -> Canonicalizer [Doc] Environment
158 addTypeAlias env scc =
159 case Graph.flattenSCC scc of
160 [(name, tvars, alias)] ->
161 do alias' <- Env.onError throw (Canonicalize.tipe env alias)
162 let value = (Var.Canonical (Var.Module moduleName) name, tvars, alias')
163 return $ env { _aliases = insert name value (_aliases env) }
164 where
165 throw err =
166 let msg = "Problem with type alias '" ++ name ++ "':"
167 in P.vcat [ P.text msg, P.text err ]
169 aliases ->
170 throwError [ P.vcat [ P.text (eightyCharLines 0 msg1)
171 , indented (map typeAlias aliases)
172 , P.text (eightyCharLines 0 msg2)
173 , indented (map datatype aliases)
174 , P.text (eightyCharLines 0 msg3)
175 ]
176 ]
178 typeAlias (n,ts,t) = D.TypeAlias n ts t
179 datatype (n,ts,t) = D.Datatype n ts [(n,[t])]
181 indented :: [D.ValidDecl] -> Doc
182 indented decls = P.vcat (map prty decls) <> P.text "\n"
183 where
184 prty decl = P.text "\n " <> pretty decl
186 msg1 = "The following type aliases are mutually recursive, forming an \
187 \infinite type. When you expand them, they just keep getting bigger:"
188 msg2 = "Instead, you can try something like this:"
189 msg3 = "It looks very similar, but an algebraic data type (ADT) \
190 \actually creates a new type. Unlike with a type alias, this \
191 \freshly created type is meaningful on its own, so an ADT \
192 \does not need to be expanded."
195-- When canonicalizing, all _values should be Local, but all _adts and _patterns
196-- should be fully namespaced. With _adts, they may appear in types that can
197-- escape the module.
198addDecl :: Module.Name -> ([Node], Environment) -> D.ValidDecl -> ([Node], Environment)
199addDecl moduleName info@(nodes,env) decl =
200 let namespacedVar = Var.Canonical (Var.Module moduleName)
201 addLocal x e = insert x (Var.local x) e
202 addNamespaced x e = insert x (namespacedVar x) e
203 in
204 case decl of
205 D.Definition (Valid.Definition pattern _ _) ->
206 (,) nodes $ env
207 { _values = foldr addLocal (_values env) (P.boundVarList pattern) }
209 D.Datatype name _ ctors ->
210 (,) nodes $ env
211 { _values = addCtors addLocal (_values env)
212 , _adts = addNamespaced name (_adts env)
213 , _patterns = addCtors addNamespaced (_patterns env)
214 }
215 where
216 addCtors how e = foldr how e (map fst ctors)
218 D.TypeAlias name tvars alias ->
219 (,) (node name tvars alias : nodes) $ env
220 { _values = case alias of
221 Type.Record _ _ -> addLocal name (_values env)
222 _ -> _values env
223 }
225 D.Port port ->
226 let portName = case port of
227 D.Out name _ _ -> name
228 D.In name _ -> name
229 in
230 (,) nodes $ env { _values = addLocal portName (_values env) }
232 D.Fixity _ _ _ -> info