@@ -0,0 +1,214 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Transform.Canonicalize.Setup (environment) where
3+
4+import Control.Arrow (first)
5+import Control.Monad (foldM)
6+import qualified Data.Either as Either
7+import qualified Data.Graph as Graph
8+import qualified Data.List as List
9+import qualified Data.Map as Map
10+
11+import qualified AST.Expression.Valid as Valid
12+
13+import AST.Module (Interface(iAdts, iTypes, iAliases))
14+import qualified AST.Module as Module
15+import qualified AST.Type as Type
16+import qualified AST.Variable as Var
17+import qualified AST.Declaration as D
18+import AST.PrettyPrint (pretty, eightyCharLines)
19+import qualified AST.Pattern as P
20+import Text.PrettyPrint as P
21+
22+import Transform.Canonicalize.Environment as Env
23+import qualified Transform.Canonicalize.Type as Canonicalize
24+
25+environment :: Module.Interfaces -> Module.ValidModule -> Either [Doc] Environment
26+environment 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 :: Either [Doc] ()
34+ allImportsAvailable =
35+ case filter (not . found) modules of
36+ [] -> Right ()
37+ missings -> Left [ P.text (missingModuleError missings) ]
38+ where
39+ modules = map fst imports
40+
41+ found m = Map.member m interfaces || List.isPrefixOf "Native." m
42+
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." ]
48+
49+addImports :: Module.Interfaces -> Environment -> (String, Module.ImportMethod)
50+ -> Either [Doc] Environment
51+addImports 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' ++ "."))
57+
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
63+
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+ }
72+
73+ canonical :: String -> Var.Canonical
74+ canonical = Var.Canonical (Var.Module name)
75+
76+ pair :: String -> (String, Var.Canonical)
77+ pair key = (key, canonical key)
78+
79+ alias (x,(tvars,tipe)) = (x, (canonical x, tvars, tipe))
80+
81+ ctors = concatMap (map (pair . fst) . snd . snd) (Map.toList (iAdts interface))
82+
83+addValue :: String -> Module.Interface -> Environment -> Var.Value
84+ -> Either [Doc] Environment
85+addValue 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 = Left [ 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) }
96+
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) }
107+
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
124+
125+type Node = ((String, [String], Type.RawType), String, [String])
126+
127+node :: String -> [String] -> Type.RawType -> Node
128+node 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
138+
139+addTypeAliases :: String -> [Node] -> Environment -> Either [Doc] Environment
140+addTypeAliases moduleName nodes environ =
141+ foldM addTypeAlias environ (Graph.stronglyConnComp nodes)
142+ where
143+ addTypeAlias :: Environment -> Graph.SCC (String, [String], Type.RawType)
144+ -> Either [Doc] Environment
145+ addTypeAlias env scc =
146+ case Graph.flattenSCC scc of
147+ [(name, tvars, alias)] ->
148+ do alias' <- Either.either throw return (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 Left [ P.vcat [ P.text msg, P.text err ] ]
155+
156+ aliases ->
157+ Left [ 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+ ]
164+
165+ typeAlias (n,ts,t) = D.TypeAlias n ts t
166+ datatype (n,ts,t) = D.Datatype n ts [(n,[t])]
167+
168+ indented :: [D.ValidDecl] -> Doc
169+ indented decls = P.vcat (map prty decls)
170+ where
171+ prty decl = P.text "\n " <> pretty decl <> P.text "\n"
172+
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."
180+
181+
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.
185+addDecl :: String -> ([Node], Environment) -> D.ValidDecl -> ([Node], Environment)
186+addDecl 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) }
195+
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)
204+
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+ }
211+
212+ D.Port _ -> info
213+
214+ D.Fixity _ _ _ -> info