git.iko.soy/elk
on 577fc17 help sign in
elk/compiler/Transform/Canonicalize/Setup.hs
219 lines 9.0 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
25environment :: Module.Interfaces -> Module.ValidModule -> Canonicalizer [Doc] Environment
26environment 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 :: Canonicalizer [Doc] ()
34 allImportsAvailable =
35 case filter (not . found) modules of
36 [] -> return ()
37 missings -> throwError [ P.text (missingModuleError missings) ]
38 where
39 modules = map fst imports
41 found m = Map.member m interfaces || List.isPrefixOf "Native." m
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." ]
49addImports :: Module.Interfaces -> Environment -> (String, Module.ImportMethod)
50 -> Canonicalizer [Doc] Environment
51addImports 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' ++ "."))
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
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 }
73 canonical :: String -> Var.Canonical
74 canonical = Var.Canonical (Var.Module name)
76 pair :: String -> (String, Var.Canonical)
77 pair key = (key, canonical key)
79 alias (x,(tvars,tipe)) = (x, (canonical x, tvars, tipe))
81 ctors = concatMap (map (pair . fst) . snd . snd) (Map.toList (iAdts interface))
83addValue :: String -> Module.Interface -> Environment -> Var.Value
84 -> Canonicalizer [Doc] Environment
85addValue 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 = throwError [ 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) }
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) }
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
125type Node = ((String, [String], Type.RawType), String, [String])
127node :: String -> [String] -> Type.RawType -> Node
128node 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
139addTypeAliases :: String -> [Node] -> Environment -> Canonicalizer [Doc] Environment
140addTypeAliases moduleName nodes environ =
141 foldM addTypeAlias environ (Graph.stronglyConnComp nodes)
142 where
143 addTypeAlias :: Environment -> Graph.SCC (String, [String], Type.RawType)
144 -> Canonicalizer [Doc] Environment
145 addTypeAlias env scc =
146 case Graph.flattenSCC scc of
147 [(name, tvars, alias)] ->
148 do alias' <- Env.onError throw (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 P.vcat [ P.text msg, P.text err ]
156 aliases ->
157 throwError [ 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 ]
165 typeAlias (n,ts,t) = D.TypeAlias n ts t
166 datatype (n,ts,t) = D.Datatype n ts [(n,[t])]
168 indented :: [D.ValidDecl] -> Doc
169 indented decls = P.vcat (map prty decls) <> P.text "\n"
170 where
171 prty decl = P.text "\n " <> pretty decl
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."
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.
185addDecl :: String -> ([Node], Environment) -> D.ValidDecl -> ([Node], Environment)
186addDecl 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) }
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)
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 }
212 D.Port port ->
213 let portName = case port of
214 D.Out name _ _ -> name
215 D.In name _ -> name
216 in
217 (,) nodes $ env { _values = addLocal portName (_values env) }
219 D.Fixity _ _ _ -> info