git.iko.soy/elk
on aeb02cd help sign in
elk/src/Transform/Canonicalize/Setup.hs
320 lines 10 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Transform.Canonicalize.Setup
3 ( environment
4 , typeAliasErrorSegue
5 , typeAliasErrorExplanation
6 ) where
8import Control.Arrow (first)
9import Control.Monad (foldM)
10import Control.Monad.Error (throwError)
11import qualified Data.Graph as Graph
12import qualified Data.List as List
13import qualified Data.Map as Map
15import qualified AST.Expression.Valid as Valid
17import AST.Module (Interface(iAdts, iTypes, iAliases))
18import qualified AST.Module as Module
19import qualified AST.Type as Type
20import qualified AST.Variable as Var
21import qualified AST.Declaration as D
22import AST.PrettyPrint (pretty, eightyCharLines)
23import qualified AST.Pattern as P
24import Text.PrettyPrint as P
26import Transform.Canonicalize.Environment as Env
27import qualified Transform.Canonicalize.Type as Canonicalize
28import qualified Transform.Interface as Interface
31environment :: Module.Interfaces -> Module.ValidModule -> Canonicalizer [Doc] Environment
32environment interfaces modul@(Module.Module _ _ _ imports decls) =
33 do () <- allImportsAvailable
34 let moduleName =
35 Module.names modul
37 nonLocalEnv <-
38 foldM (addImports moduleName interfaces) (builtIns moduleName) imports
40 let (aliases, env) =
41 List.foldl' (addDecl moduleName) ([], nonLocalEnv) decls
43 addTypeAliases moduleName aliases env
45 where
46 allImportsAvailable :: Canonicalizer [Doc] ()
47 allImportsAvailable =
48 case filter (not . found) modules of
49 [] -> return ()
50 missings -> throwError [ P.text (missingModuleError missings) ]
51 where
52 modules =
53 map fst imports
55 found m =
56 Map.member m interfaces || Module.nameIsNative m
58 missingModuleError missings =
59 concat
60 [ "The following imports were not found:\n "
61 , List.intercalate ", " (map Module.nameToString missings)
62 ]
65addImports
66 :: Module.Name
67 -> Module.Interfaces
68 -> Environment
69 -> (Module.Name, Module.ImportMethod)
70 -> Canonicalizer [Doc] Environment
71addImports moduleName interfaces environ (name, method)
72 | Module.nameIsNative name =
73 return environ
75 | otherwise =
76 let (Module.ImportMethod maybeAlias listing) = method
78 (Var.Listing exposedVars open) = listing
80 qualifier =
81 maybe (Module.nameToString name) id maybeAlias
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)
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 }
103 canonical :: String -> Var.Canonical
104 canonical =
105 Var.Canonical (Var.Module name)
107 pair :: String -> (String, Var.Canonical)
108 pair key =
109 (key, canonical key)
111 alias (x,(tvars,tipe)) =
112 (x, (canonical x, tvars, tipe))
114 ctors =
115 concatMap
116 (map (pair . fst) . snd . snd)
117 (Map.toList (iAdts interface))
120addValue
121 :: Module.Name
122 -> Module.Interface
123 -> Environment
124 -> Var.Value
125 -> Canonicalizer [Doc] Environment
126addValue moduleName interface env value =
127 let name = Module.nameToString moduleName
128 insert' x = insert x (Var.Canonical (Var.Module moduleName) x)
129 msg x = "Import Error: Could not import value '" ++ name ++ "." ++ x ++
130 "'.\n It is not exported by module " ++ name ++ "."
131 notFound x = throwError [ P.text (msg x) ]
132 in
133 case value of
134 Var.Value x
135 | Map.notMember x (iTypes interface) ->
136 notFound x
138 | otherwise ->
139 return $ env { _values = insert' x (_values env) }
141 Var.Alias x ->
142 case Map.lookup x (iAliases interface) of
143 Just (tvars, t) ->
144 return $ env
145 { _aliases = insert x v (_aliases env)
146 , _values = updatedValues
147 }
148 where
149 v = (Var.Canonical (Var.Module moduleName) x, tvars, t)
150 updatedValues =
151 if Map.member x (iTypes interface)
152 then insert' x (_values env)
153 else _values env
155 Nothing ->
156 case Map.lookup x (iAdts interface) of
157 Nothing -> notFound x
158 Just (_,_) ->
159 return $ env { _adts = insert' x (_adts env) }
161 Var.Union x (Var.Listing xs open) ->
162 case Map.lookup x (iAdts interface) of
163 Nothing -> notFound x
164 Just (_tvars, ctors) ->
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 }
171 where
172 filterNames names
173 | open = return names
174 | otherwise =
175 case filter (`notElem` names) xs of
176 [] -> return names
177 c:_ -> notFound c
180type Node = ((String, [String], Type.RawType), String, [String])
183node :: String -> [String] -> Type.RawType -> Node
184node 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
197addTypeAliases
198 :: Module.Name
199 -> [Node]
200 -> Environment
201 -> Canonicalizer [Doc] Environment
202addTypeAliases moduleName nodes environ =
203 foldM (addTypeAlias moduleName) environ (Graph.stronglyConnComp nodes)
206addTypeAlias
207 :: Module.Name
208 -> Environment
209 -> Graph.SCC (String, [String], Type.RawType)
210 -> Canonicalizer [Doc] Environment
211addTypeAlias moduleName env scc =
212 case Graph.flattenSCC scc of
213 [(name, tvars, alias)] ->
214 do alias' <- Env.onError throw (Canonicalize.tipe env alias)
215 let value = (Var.Canonical (Var.Module moduleName) name, tvars, alias')
216 return $ env { _aliases = insert name value (_aliases env) }
217 where
218 throw err =
219 let msg = "Problem with type alias '" ++ name ++ "':"
220 in P.vcat [ P.text msg, P.text err ]
222 aliases ->
223 throwError
224 [ P.vcat
225 [ P.text (eightyCharLines 0 mutuallyRecursiveMessage)
226 , indented (map typeAlias aliases)
227 , P.text (eightyCharLines 0 typeAliasErrorSegue)
228 , indented (map datatype aliases)
229 , P.text (eightyCharLines 0 typeAliasErrorExplanation)
230 ]
231 ]
234typeAlias
235 :: (String, [String], Type.Type var)
236 -> D.Declaration' port def var
237typeAlias (n,ts,t) =
238 D.TypeAlias n ts t
241datatype
242 :: (String, [String], Type.Type var)
243 -> D.Declaration' port def var
244datatype (n,ts,t) =
245 D.Datatype n ts [(n,[t])]
248indented :: [D.ValidDecl] -> Doc
249indented decls = P.vcat (map prty decls) <> P.text "\n"
250 where
251 prty decl = P.text "\n " <> pretty decl
254mutuallyRecursiveMessage :: String
255mutuallyRecursiveMessage =
256 "The following type aliases are mutually recursive, forming an \
257 \infinite type. When you expand them, they just keep getting bigger:"
260typeAliasErrorSegue :: String
261typeAliasErrorSegue =
262 "Try this instead:"
265typeAliasErrorExplanation :: String
266typeAliasErrorExplanation =
267 "It looks very similar, but the 'type' keyword creates a brand new type, \
268 \not just an alias for an existing one. This lets us avoid infinitely \
269 \expanding it during type inference."
272-- When canonicalizing, all _values should be Local, but all _adts and _patterns
273-- should be fully namespaced. With _adts, they may appear in types that can
274-- escape the module.
275addDecl
276 :: Module.Name
277 -> ([Node], Environment)
278 -> D.ValidDecl
279 -> ([Node], Environment)
280addDecl moduleName info@(nodes,env) decl =
281 let namespacedVar = Var.Canonical (Var.Module moduleName)
282 addLocal x e = insert x (Var.local x) e
283 addNamespaced x e = insert x (namespacedVar x) e
284 in
285 case decl of
286 D.Definition (Valid.Definition pattern _ _) ->
287 (,) nodes $ env
288 { _values =
289 foldr addLocal (_values env) (P.boundVarList pattern)
290 }
292 D.Datatype name _ ctors ->
293 (,) nodes $ env
294 { _values =
295 addCtors addLocal (_values env)
296 , _adts =
297 addNamespaced name (_adts env)
298 , _patterns =
299 addCtors addNamespaced (_patterns env)
300 }
301 where
302 addCtors how e = foldr how e (map fst ctors)
304 D.TypeAlias name tvars alias ->
305 (,) (node name tvars alias : nodes) $ env
306 { _values =
307 case alias of
308 Type.Record _ _ ->
309 addLocal name (_values env)
310 _ ->
311 _values env
312 }
314 D.Wire wire ->
315 (,) nodes $ env
316 { _values =
317 addLocal (D.wireName wire) (_values env)
318 }
320 D.Fixity _ _ _ -> info