2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[RnNames]{Extracting imported and top-level names in scope}
7 #include "HsVersions.h"
14 import PreludeGlaST ( returnPrimIO, thenPrimIO, MutableVar(..) )
23 import RnIfaces ( IfaceCache(..), cacheInterface, ParsedIface )
24 import RnUtils ( RnEnv(..), emptyRnEnv, extendGlobalRnEnv, qualNameErr, dupNamesErr )
26 import Bag ( emptyBag, unitBag, unionBags, unionManyBags, mapBag, listToBag, bagToList )
27 import ErrUtils ( Error(..), Warning(..), addShortErrLocLine )
28 import FiniteMap ( fmToList )
29 import Name ( RdrName(..), Name, isQual, mkTopLevName,
30 mkImportedName, nameExportFlag,
31 getLocalName, getSrcLoc, pprNonOp
33 import PrelInfo ( BuiltinNames(..), BuiltinKeys(..) )
34 import PrelMods ( fromPrelude )
36 import SrcLoc ( SrcLoc )
37 import UniqSupply ( splitUniqSupply )
38 import Util ( equivClasses, panic )
43 type GlobalNameInfo = (BuiltinNames,
48 type RnM_Info s r = RnMonad GlobalNameInfo s r
56 [Module], -- directly imported modules
57 Bag (Module,(RnName,ExportFlag)), -- unqualified imports from module
58 Bag RenamedFixityDecl, -- imported fixity decls
62 getGlobalNames iface_var info us
63 (HsModule mod _ _ imports _ ty_decls _ cls_decls _ _ _ binds _ _)
64 = case initRn True mod emptyRnEnv us1
66 getSourceNames ty_decls cls_decls binds)
67 of { ((src_vals, src_tcs), src_errs, src_warns) ->
69 getImportedNames iface_var info us2 imports `thenPrimIO`
70 \ (imp_vals, imp_tcs, imp_mods, unqual_imps, imp_fixes, imp_errs, imp_warns) ->
73 unqual_vals = mapBag (\rn -> (Unqual (getLocalName rn), rn)) src_vals
74 unqual_tcs = mapBag (\rn -> (Unqual (getLocalName rn), rn)) src_tcs
76 all_vals = bagToList (unqual_vals `unionBags` imp_vals)
77 all_tcs = bagToList (unqual_tcs `unionBags` imp_tcs)
79 (all_env, dups) = extendGlobalRnEnv emptyRnEnv all_vals all_tcs
81 dup_errs = map dup_err (equivClasses cmp_rdr (bagToList dups))
82 cmp_rdr (rdr1,_,_) (rdr2,_,_) = cmp rdr1 rdr2
83 dup_err ((rdr,rn,rn'):rest) = globalDupNamesErr rdr (rn:rn': [rn|(_,_,rn)<-rest])
85 all_errs = src_errs `unionBags` imp_errs `unionBags` listToBag dup_errs
86 all_warns = src_warns `unionBags` imp_warns
88 returnPrimIO (all_env, bagToList imp_mods, unqual_imps, imp_fixes, all_errs, all_warns)
91 (us1, us2) = splitUniqSupply us
94 *********************************************************
96 \subsection{Top-level source names}
98 *********************************************************
103 -> [RdrNameClassDecl]
105 -> RnM_Info s (Bag RnName, -- values
106 Bag RnName) -- tycons/classes
108 getSourceNames ty_decls cls_decls binds
109 = mapAndUnzipRn getTyDeclNames ty_decls `thenRn` \ (tycon_s, constrs_s) ->
110 mapAndUnzipRn getClassNames cls_decls `thenRn` \ (cls_s, cls_ops_s) ->
111 getTopBindsNames binds `thenRn` \ bind_names ->
112 returnRn (unionManyBags constrs_s `unionBags`
113 unionManyBags cls_ops_s `unionBags` bind_names,
114 listToBag tycon_s `unionBags` listToBag cls_s)
117 getTyDeclNames :: RdrNameTyDecl
118 -> RnM_Info s (RnName, Bag RnName) -- tycon and constrs
120 getTyDeclNames (TyData _ tycon _ condecls _ _ src_loc)
121 = newGlobalName src_loc Nothing tycon `thenRn` \ tycon_name ->
122 mapRn (getConDeclName (Just (nameExportFlag tycon_name)))
123 condecls `thenRn` \ con_names ->
124 returnRn (RnData tycon_name con_names,
125 listToBag (map (\ n -> RnConstr n tycon_name) con_names))
127 getTyDeclNames (TyNew _ tycon _ condecls _ _ src_loc)
128 = newGlobalName src_loc Nothing tycon `thenRn` \ tycon_name ->
129 mapRn (getConDeclName (Just (nameExportFlag tycon_name)))
130 condecls `thenRn` \ con_names ->
131 returnRn (RnData tycon_name con_names,
132 listToBag (map (\ n -> RnConstr n tycon_name) con_names))
134 getTyDeclNames (TySynonym tycon _ _ src_loc)
135 = newGlobalName src_loc Nothing tycon `thenRn` \ tycon_name ->
136 returnRn (RnSyn tycon_name, emptyBag)
138 getConDeclName exp (ConDecl con _ src_loc)
139 = newGlobalName src_loc exp con
140 getConDeclName exp (ConOpDecl _ op _ src_loc)
141 = newGlobalName src_loc exp op
142 getConDeclName exp (NewConDecl con _ src_loc)
143 = newGlobalName src_loc exp con
144 getConDeclName exp (RecConDecl con fields src_loc)
145 = panic "getConDeclName:RecConDecl"
146 newGlobalName src_loc exp con
149 getClassNames :: RdrNameClassDecl
150 -> RnM_Info s (RnName, Bag RnName) -- class and class ops
152 getClassNames (ClassDecl _ cname _ sigs _ _ src_loc)
153 = newGlobalName src_loc Nothing cname `thenRn` \ class_name ->
154 getClassOpNames (Just (nameExportFlag class_name))
155 sigs `thenRn` \ op_names ->
156 returnRn (RnClass class_name op_names,
157 listToBag (map (\ n -> RnClassOp n class_name) op_names))
159 getClassOpNames exp []
161 getClassOpNames exp (ClassOpSig op _ _ src_loc : sigs)
162 = newGlobalName src_loc exp op `thenRn` \ op_name ->
163 getClassOpNames exp sigs `thenRn` \ op_names ->
164 returnRn (op_name : op_names)
165 getClassOpNames exp (_ : sigs)
166 = getClassOpNames exp sigs
169 *********************************************************
171 \subsection{Bindings}
173 *********************************************************
176 getTopBindsNames :: RdrNameHsBinds
177 -> RnM_Info s (Bag RnName)
179 getTopBindsNames binds = doBinds binds
181 doBinds EmptyBinds = returnRn emptyBag
182 doBinds (SingleBind bind) = doBind bind
183 doBinds (BindWith bind sigs) = doBind bind
184 doBinds (ThenBinds binds1 binds2)
185 = andRn unionBags (doBinds binds1) (doBinds binds2)
187 doBind EmptyBind = returnRn emptyBag
188 doBind (NonRecBind mbind) = doMBinds mbind
189 doBind (RecBind mbind) = doMBinds mbind
191 doMBinds EmptyMonoBinds = returnRn emptyBag
192 doMBinds (PatMonoBind pat grhss_and_binds locn) = doPat locn pat
193 doMBinds (FunMonoBind p_name _ _ locn) = doName locn p_name
194 doMBinds (AndMonoBinds mbinds1 mbinds2)
195 = andRn unionBags (doMBinds mbinds1) (doMBinds mbinds2)
198 = mapRn (doPat locn) pats `thenRn` \ pats_s ->
199 returnRn (unionManyBags pats_s)
201 doPat locn WildPatIn = returnRn emptyBag
202 doPat locn (LitPatIn _) = returnRn emptyBag
203 doPat locn (LazyPatIn pat) = doPat locn pat
204 doPat locn (VarPatIn var) = doName locn var
205 doPat locn (NegPatIn pat) = doPat locn pat
206 doPat locn (ParPatIn pat) = doPat locn pat
207 doPat locn (ListPatIn pats) = doPats locn pats
208 doPat locn (TuplePatIn pats) = doPats locn pats
209 doPat locn (ConPatIn name pats) = doPats locn pats
210 doPat locn (ConOpPatIn p1 op p2)
211 = andRn unionBags (doPat locn p1) (doPat locn p2)
212 doPat locn (AsPatIn as_name pat)
213 = andRn unionBags (doName locn as_name) (doPat locn pat)
214 doPat locn (RecPatIn name fields)
215 = mapRn (doField locn) fields `thenRn` \ fields_s ->
216 returnRn (unionManyBags fields_s)
218 doField locn (_, pat, _) = doPat locn pat
221 = newGlobalName locn Nothing rdr `thenRn` \ name ->
222 returnRn (unitBag (RnName name))
225 *********************************************************
227 \subsection{Creating a new global name}
229 *********************************************************
232 newGlobalName :: SrcLoc -> Maybe ExportFlag
233 -> RdrName -> RnM_Info s Name
235 newGlobalName locn maybe_exp rdr
236 = getExtraRn `thenRn` \ (_,_,exp_fn,occ_fn) ->
237 getModuleRn `thenRn` \ mod ->
238 getSourceRn `thenRn` \ source ->
239 rnGetUnique `thenRn` \ u ->
241 src_unqual = getLocalName rdr
243 src_orig = if fromPrelude mod
244 then (Unqual src_unqual)
245 else (Qual mod src_unqual)
247 exp = case maybe_exp of
252 mkTopLevName u src_orig locn exp (occ_fn n)
254 mkImportedName u rdr locn exp (occ_fn n)
256 addErrIfRn (source && isQual rdr)
257 (qualNameErr "name in definition" (rdr, locn)) `thenRn_`
261 *********************************************************
263 \subsection{Imported names}
265 *********************************************************
270 -> GlobalNameInfo -- builtin and knot name info
272 -> [RdrNameImportDecl] -- import declarations
273 -> PrimIO (Bag (RdrName,RnName), -- imported values in scope
274 Bag (RdrName,RnName), -- imported tycons/classes in scope
275 Bag Module, -- directly imported modules
276 Bag (Module,(RnName,ExportFlag)), -- unqualified imports from module
277 Bag RenamedFixityDecl, -- fixity info for imported names
281 getImportedNames iface_var info us imports
282 = returnPrimIO (builtin_vals, builtin_tcs, emptyBag, emptyBag, emptyBag, emptyBag, emptyBag)
284 -- For now jsut add the builtin names ...
285 (b_names,_,_,_) = info
286 builtin_vals = listToBag [(Unqual s, rn) | (s,rn) <- fmToList b_names, not (isRnTyCon rn)]
287 builtin_tcs = listToBag [(Unqual s, rn) | (s,rn) <- fmToList b_names, isRnTyCon rn]
292 globalDupNamesErr rdr rns sty
293 = ppHang (ppBesides [pprNonOp sty rdr, ppStr " multiply defined:"])
294 4 (ppAboves (map pp_def rns))
296 pp_def rn = addShortErrLocLine (getSrcLoc rn) (\ sty -> ppr sty rn) sty
298 -- ToDo: print import src locs for imported names