git.iko.soy/elk
on 501c607 help sign in
elk/src/Transform/Canonicalize/Setup.hs
336 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
32 :: Module.Interfaces
33 -> Module.ValidModule
34 -> Canonicalizer [Doc] Environment
35environment interfaces modul@(Module.Module _ _ _ imports decls) =
36 do () <- allImportsAvailable
37 let moduleName =
38 Module.names modul
40 nonLocalEnv <-
41 foldM (addImports moduleName interfaces) (builtIns moduleName) imports
43 let (aliases, env) =
44 List.foldl' (addDecl moduleName) ([], nonLocalEnv) decls
46 addTypeAliases moduleName aliases env
48 where
49 allImportsAvailable :: Canonicalizer [Doc] ()
50 allImportsAvailable =
51 case filter (not . found) modules of
52 [] -> return ()
53 missings -> throwError [ P.text (missingModuleError missings) ]
54 where
55 modules =
56 map fst imports
58 found m =
59 Map.member m interfaces || Module.nameIsNative m
61 missingModuleError missings =
62 concat
63 [ "The following imports were not found:\n "
64 , List.intercalate ", " (map Module.nameToString missings)
65 ]
68addImports
69 :: Module.Name
70 -> Module.Interfaces
71 -> Environment
72 -> (Module.Name, Module.ImportMethod)
73 -> Canonicalizer [Doc] Environment
74addImports moduleName interfaces environ (name, method)
75 | Module.nameIsNative name =
76 return environ
78 | otherwise =
79 let (Module.ImportMethod maybeAlias listing) = method
81 (Var.Listing exposedVars open) = listing
83 qualifier =
84 maybe (Module.nameToString name) id maybeAlias
86 env =
87 updateEnviron (qualifier ++ ".") environ
88 in
89 if open
90 then return (updateEnviron "" env)
91 else foldM (addValue name interface) env exposedVars
92 where
93 interface =
94 Interface.filterExports ((Map.!) interfaces name)
96 updateEnviron prefix env =
97 let dict' = dict . map (first (prefix++)) in
98 merge env $
99 Env { _home = moduleName
100 , _values = dict' $ map pair (Map.keys (iTypes interface)) ++ ctors
101 , _adts = dict' $ map pair (Map.keys (iAdts interface))
102 , _aliases = dict' $ map alias (Map.toList (iAliases interface))
103 , _patterns = dict' $ ctors
104 }
106 canonical :: String -> Var.Canonical
107 canonical =
108 Var.Canonical (Var.Module name)
110 pair :: String -> (String, Var.Canonical)
111 pair key =
112 (key, canonical key)
114 alias (x,(tvars,tipe)) =
115 (x, (canonical x, tvars, tipe))
117 ctors =
118 concatMap
119 (map (pair . fst) . snd . snd)
120 (Map.toList (iAdts interface))
123addValue
124 :: Module.Name
125 -> Module.Interface
126 -> Environment
127 -> Var.Value
128 -> Canonicalizer [Doc] Environment
129addValue moduleName interface env value =
130 let name = Module.nameToString moduleName
131 insert' x = insert x (Var.Canonical (Var.Module moduleName) x)
132 msg x = "Import Error: Could not import value '" ++ name ++ "." ++ x ++
133 "'.\n It is not exported by module " ++ name ++ "."
134 notFound x = throwError [ P.text (msg x) ]
135 in
136 case value of
137 Var.Value x
138 | Map.notMember x (iTypes interface) ->
139 notFound x
141 | otherwise ->
142 return $ env { _values = insert' x (_values env) }
144 Var.Alias x ->
145 case Map.lookup x (iAliases interface) of
146 Just (tvars, t) ->
147 return $ env
148 { _aliases = insert x v (_aliases env)
149 , _values = updatedValues
150 }
151 where
152 v = (Var.Canonical (Var.Module moduleName) x, tvars, t)
153 updatedValues =
154 if Map.member x (iTypes interface)
155 then insert' x (_values env)
156 else _values env
158 Nothing ->
159 case Map.lookup x (iAdts interface) of
160 Nothing -> notFound x
161 Just (_,_) ->
162 return $ env { _adts = insert' x (_adts env) }
164 Var.Union x (Var.Listing xs open) ->
165 case Map.lookup x (iAdts interface) of
166 Nothing -> notFound x
167 Just (_tvars, ctors) ->
168 do ctors' <- filterNames (map fst ctors)
169 return $ env
170 { _adts = insert' x (_adts env)
171 , _values = foldr insert' (_values env) ctors'
172 , _patterns = foldr insert' (_patterns env) ctors'
173 }
174 where
175 filterNames names
176 | open = return names
177 | otherwise =
178 case filter (`notElem` names) xs of
179 [] -> return names
180 c:_ -> notFound c
183type Node = ((String, [String], Type.RawType), String, [String])
186node :: String -> [String] -> Type.RawType -> Node
187node name tvars alias =
188 ((name, tvars, alias), name, edges alias)
189 where
190 edges tipe =
191 case tipe of
192 Type.Lambda t1 t2 ->
193 edges t1 ++ edges t2
195 Type.Var _ ->
196 []
198 Type.Type (Var.Raw x) ->
199 [x]
201 Type.App t ts ->
202 edges t ++ concatMap edges ts
204 Type.Record fs ext ->
205 maybe [] edges ext ++ concatMap (edges . snd) fs
207 Type.Aliased _ args t ->
208 edges t ++ concatMap (edges . snd) args
211addTypeAliases
212 :: Module.Name
213 -> [Node]
214 -> Environment
215 -> Canonicalizer [Doc] Environment
216addTypeAliases moduleName nodes environ =
217 foldM (addTypeAlias moduleName) environ (Graph.stronglyConnComp nodes)
220addTypeAlias
221 :: Module.Name
222 -> Environment
223 -> Graph.SCC (String, [String], Type.RawType)
224 -> Canonicalizer [Doc] Environment
225addTypeAlias moduleName env scc =
226 case Graph.flattenSCC scc of
227 [(name, tvars, alias)] ->
228 do alias' <- Env.onError throw (Canonicalize.tipe env alias)
229 let value = (Var.Canonical (Var.Module moduleName) name, tvars, alias')
230 return $ env { _aliases = insert name value (_aliases env) }
231 where
232 throw err =
233 let msg = "Problem with type alias '" ++ name ++ "':"
234 in P.vcat [ P.text msg, P.text err ]
236 aliases ->
237 throwError
238 [ P.vcat
239 [ P.text (eightyCharLines 0 mutuallyRecursiveMessage)
240 , indented (map typeAlias aliases)
241 , P.text (eightyCharLines 0 typeAliasErrorSegue)
242 , indented (map datatype aliases)
243 , P.text (eightyCharLines 0 typeAliasErrorExplanation)
244 ]
245 ]
248typeAlias
249 :: (String, [String], Type.Type var)
250 -> D.Declaration' wire def var
251typeAlias (n,ts,t) =
252 D.TypeAlias n ts t
255datatype
256 :: (String, [String], Type.Type var)
257 -> D.Declaration' wire def var
258datatype (n,ts,t) =
259 D.Datatype n ts [(n,[t])]
262indented :: [D.ValidDecl] -> Doc
263indented decls =
264 P.vcat (map prty decls) <> P.text "\n"
265 where
266 prty decl = P.text "\n " <> pretty decl
269mutuallyRecursiveMessage :: String
270mutuallyRecursiveMessage =
271 "The following type aliases are mutually recursive, forming an \
272 \infinite type. When you expand them, they just keep getting bigger:"
275typeAliasErrorSegue :: String
276typeAliasErrorSegue =
277 "Try this instead:"
280typeAliasErrorExplanation :: String
281typeAliasErrorExplanation =
282 "It looks very similar, but the 'type' keyword creates a brand new type, \
283 \not just an alias for an existing one. This lets us avoid infinitely \
284 \expanding it during type inference."
287-- When canonicalizing, all _values should be Local, but all _adts and _patterns
288-- should be fully namespaced. With _adts, they may appear in types that can
289-- escape the module.
290addDecl
291 :: Module.Name
292 -> ([Node], Environment)
293 -> D.ValidDecl
294 -> ([Node], Environment)
295addDecl moduleName info@(nodes,env) decl =
296 let namespacedVar = Var.Canonical (Var.Module moduleName)
297 addLocal x e = insert x (Var.local x) e
298 addNamespaced x e = insert x (namespacedVar x) e
299 in
300 case decl of
301 D.Definition (Valid.Definition pattern _ _) ->
302 (,) nodes $ env
303 { _values =
304 foldr addLocal (_values env) (P.boundVarList pattern)
305 }
307 D.Datatype name _ ctors ->
308 (,) nodes $ env
309 { _values =
310 addCtors addLocal (_values env)
311 , _adts =
312 addNamespaced name (_adts env)
313 , _patterns =
314 addCtors addNamespaced (_patterns env)
315 }
316 where
317 addCtors how e = foldr how e (map fst ctors)
319 D.TypeAlias name tvars alias ->
320 (,) (node name tvars alias : nodes) $ env
321 { _values =
322 case alias of
323 Type.Record _ _ ->
324 addLocal name (_values env)
325 _ ->
326 _values env
327 }
329 D.Wire wire ->
330 (,) nodes $ env
331 { _values =
332 addLocal (D.wireName wire) (_values env)
333 }
335 D.Fixity _ _ _ ->
336 info