git.iko.soy/elk
on da476ff help sign in
elk/src/Transform/Canonicalize/Setup.hs
269 lines 9.7 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 = Module.names modul
35 nonLocalEnv <- foldM (addImports moduleName interfaces) (builtIns moduleName) imports
36 let (aliases, env) = List.foldl' (addDecl moduleName) ([], nonLocalEnv) decls
37 addTypeAliases moduleName aliases env
38 where
39 allImportsAvailable :: Canonicalizer [Doc] ()
40 allImportsAvailable =
41 case filter (not . found) modules of
42 [] -> return ()
43 missings -> throwError [ P.text (missingModuleError missings) ]
44 where
45 modules = map fst imports
47 found m = Map.member m interfaces || Module.nameIsNative m
49 missingModuleError missings =
50 concat [ "The following imports were not found:\n "
51 , List.intercalate ", " (map Module.nameToString missings)
52 ]
55addImports :: Module.Name -> Module.Interfaces -> Environment -> (Module.Name, Module.ImportMethod)
56 -> Canonicalizer [Doc] Environment
57addImports moduleName interfaces environ (name, method)
58 | Module.nameIsNative name = return environ
59 | otherwise =
60 case method of
61 Module.As name' ->
62 return (updateEnviron (name' ++ "."))
64 Module.Open (Var.Listing vs open)
65 | open -> return (updateEnviron "")
66 | otherwise -> foldM (addValue name interface) environ vs
67 where
68 interface = Interface.filterExports ((Map.!) interfaces name)
70 updateEnviron prefix =
71 let dict' = dict . map (first (prefix++)) in
72 merge environ $
73 Env { _home = moduleName
74 , _values = dict' $ map pair (Map.keys (iTypes interface)) ++ ctors
75 , _adts = dict' $ map pair (Map.keys (iAdts interface))
76 , _aliases = dict' $ map alias (Map.toList (iAliases interface))
77 , _patterns = dict' $ ctors
78 }
80 canonical :: String -> Var.Canonical
81 canonical = Var.Canonical (Var.Module name)
83 pair :: String -> (String, Var.Canonical)
84 pair key = (key, canonical key)
86 alias (x,(tvars,tipe)) = (x, (canonical x, tvars, tipe))
88 ctors = concatMap (map (pair . fst) . snd . snd) (Map.toList (iAdts interface))
90addValue :: Module.Name -> Module.Interface -> Environment -> Var.Value
91 -> Canonicalizer [Doc] Environment
92addValue moduleName interface env value =
93 let name = Module.nameToString moduleName
94 insert' x = insert x (Var.Canonical (Var.Module moduleName) x)
95 msg x = "Import Error: Could not import value '" ++ name ++ "." ++ x ++
96 "'.\n It is not exported by module " ++ name ++ "."
97 notFound x = throwError [ P.text (msg x) ]
98 in
99 case value of
100 Var.Value x
101 | Map.notMember x (iTypes interface) -> notFound x
102 | otherwise ->
103 return $ env { _values = insert' x (_values env) }
105 Var.Alias x ->
106 case Map.lookup x (iAliases interface) of
107 Just (tvars, t) ->
108 return $ env
109 { _aliases = insert x v (_aliases env)
110 , _values = updatedValues
111 }
112 where
113 v = (Var.Canonical (Var.Module moduleName) x, tvars, t)
114 updatedValues =
115 if Map.member x (iTypes interface)
116 then insert' x (_values env)
117 else _values env
119 Nothing ->
120 case Map.lookup x (iAdts interface) of
121 Nothing -> notFound x
122 Just (_,_) ->
123 return $ env { _adts = insert' x (_adts env) }
125 Var.Union x (Var.Listing xs open) ->
126 case Map.lookup x (iAdts interface) of
127 Nothing -> notFound x
128 Just (_tvars, ctors) ->
129 do ctors' <- filterNames (map fst ctors)
130 return $ env { _adts = insert' x (_adts env)
131 , _values = foldr insert' (_values env) ctors'
132 , _patterns = foldr insert' (_patterns env) ctors'
133 }
134 where
135 filterNames names
136 | open = return names
137 | otherwise =
138 case filter (`notElem` names) xs of
139 [] -> return names
140 c:_ -> notFound c
142type Node = ((String, [String], Type.RawType), String, [String])
144node :: String -> [String] -> Type.RawType -> Node
145node name tvars alias = ((name, tvars, alias), name, edges alias)
146 where
147 edges tipe =
148 case tipe of
149 Type.Lambda t1 t2 -> edges t1 ++ edges t2
150 Type.Var _ -> []
151 Type.Type (Var.Raw x) -> [x]
152 Type.App t ts -> edges t ++ concatMap edges ts
153 Type.Record fs ext -> maybe [] edges ext ++ concatMap (edges . snd) fs
154 Type.Aliased _ t -> edges t
157addTypeAliases
158 :: Module.Name
159 -> [Node]
160 -> Environment
161 -> Canonicalizer [Doc] Environment
162addTypeAliases moduleName nodes environ =
163 foldM (addTypeAlias moduleName) environ (Graph.stronglyConnComp nodes)
166addTypeAlias
167 :: Module.Name
168 -> Environment
169 -> Graph.SCC (String, [String], Type.RawType)
170 -> Canonicalizer [Doc] Environment
171addTypeAlias moduleName env scc =
172 case Graph.flattenSCC scc of
173 [(name, tvars, alias)] ->
174 do alias' <- Env.onError throw (Canonicalize.tipe env alias)
175 let value = (Var.Canonical (Var.Module moduleName) name, tvars, alias')
176 return $ env { _aliases = insert name value (_aliases env) }
177 where
178 throw err =
179 let msg = "Problem with type alias '" ++ name ++ "':"
180 in P.vcat [ P.text msg, P.text err ]
182 aliases ->
183 throwError
184 [ P.vcat
185 [ P.text (eightyCharLines 0 mutuallyRecursiveMessage)
186 , indented (map typeAlias aliases)
187 , P.text (eightyCharLines 0 typeAliasErrorSegue)
188 , indented (map datatype aliases)
189 , P.text (eightyCharLines 0 typeAliasErrorExplanation)
190 ]
191 ]
194typeAlias
195 :: (String, [String], Type.Type var)
196 -> D.Declaration' port def var
197typeAlias (n,ts,t) =
198 D.TypeAlias n ts t
201datatype
202 :: (String, [String], Type.Type var)
203 -> D.Declaration' port def var
204datatype (n,ts,t) =
205 D.Datatype n ts [(n,[t])]
208indented :: [D.ValidDecl] -> Doc
209indented decls = P.vcat (map prty decls) <> P.text "\n"
210 where
211 prty decl = P.text "\n " <> pretty decl
214mutuallyRecursiveMessage :: String
215mutuallyRecursiveMessage =
216 "The following type aliases are mutually recursive, forming an \
217 \infinite type. When you expand them, they just keep getting bigger:"
220typeAliasErrorSegue :: String
221typeAliasErrorSegue =
222 "Try this instead:"
225typeAliasErrorExplanation :: String
226typeAliasErrorExplanation =
227 "It looks very similar, but the 'type' keyword creates a brand new type, \
228 \not just an alias for an existing one. This lets us avoid infinitely \
229 \expanding it during type inference."
232-- 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
234-- escape the module.
235addDecl :: Module.Name -> ([Node], Environment) -> D.ValidDecl -> ([Node], Environment)
236addDecl moduleName info@(nodes,env) decl =
237 let namespacedVar = Var.Canonical (Var.Module moduleName)
238 addLocal x e = insert x (Var.local x) e
239 addNamespaced x e = insert x (namespacedVar x) e
240 in
241 case decl of
242 D.Definition (Valid.Definition pattern _ _) ->
243 (,) nodes $ env
244 { _values = foldr addLocal (_values env) (P.boundVarList pattern) }
246 D.Datatype name _ ctors ->
247 (,) nodes $ env
248 { _values = addCtors addLocal (_values env)
249 , _adts = addNamespaced name (_adts env)
250 , _patterns = addCtors addNamespaced (_patterns env)
251 }
252 where
253 addCtors how e = foldr how e (map fst ctors)
255 D.TypeAlias name tvars alias ->
256 (,) (node name tvars alias : nodes) $ env
257 { _values = case alias of
258 Type.Record _ _ -> addLocal name (_values env)
259 _ -> _values env
260 }
262 D.Port port ->
263 let portName = case port of
264 D.Out name _ _ -> name
265 D.In name _ -> name
266 in
267 (,) nodes $ env { _values = addLocal portName (_values env) }
269 D.Fixity _ _ _ -> info