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"
11 SYN_IE(GlobalNameInfo)
14 import PreludeGlaST ( SYN_IE(MutableVar) )
23 import RnIfaces ( IfaceCache, cachedIface, cachedDecl, CachingResult(..) )
24 import RnUtils ( SYN_IE(RnEnv), emptyRnEnv, initRnEnv, extendGlobalRnEnv,
25 lubExportFlag, qualNameErr, dupNamesErr, pprRnEnv
27 import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), ExportsMap(..), RdrIfaceInst )
30 import Bag ( emptyBag, unitBag, consBag, snocBag, unionBags,
31 unionManyBags, mapBag, foldBag, filterBag, listToBag, bagToList )
32 import CmdLineOpts ( opt_NoImplicitPrelude, opt_CompilingGhcInternals )
33 import ErrUtils ( SYN_IE(Error), SYN_IE(Warning), addErrLoc, addShortErrLocLine, addShortWarnLocLine )
34 import FiniteMap ( emptyFM, addToFM, addListToFM, lookupFM, fmToList, eltsFM, delListFromFM, FiniteMap )
36 import Maybes ( maybeToBool, catMaybes, MaybeErr(..) )
37 import Name ( RdrName(..), Name, isQual, mkTopLevName, mkWiredInName, origName,
38 nameOf, qualToOrigName, mkImportedName,
39 nameExportFlag, nameImportFlag,
40 getLocalName, getSrcLoc, getImpLocs,
41 moduleNamePair, pprNonSym,
42 isLexCon, isLexSpecialSym, ExportFlag(..), OrigName(..)
44 import PrelInfo ( SYN_IE(BuiltinNames), SYN_IE(BuiltinKeys) )
45 import PrelMods ( pRELUDE, gHC_BUILTINS, modulesWithBuiltins )
47 import SrcLoc ( SrcLoc, mkBuiltinSrcLoc )
48 import TyCon ( tyConDataCons )
49 import UniqFM ( emptyUFM, addListToUFM_C, lookupUFM )
50 import UniqSupply ( splitUniqSupply )
51 import Util ( isIn, assoc, cmpPString, sortLt, removeDups,
52 equivClasses, panic, assertPanic
54 --import PprStyle --ToDo:rm
58 type GlobalNameInfo = (BuiltinNames,
60 Name -> ExportFlag, -- export flag
61 Name -> [RdrName]) -- occurrence names
62 -- NB: both of the functions are in a *knot* and
63 -- must be tugged on oh-so-gently...
65 type RnM_Info s r = RnMonad GlobalNameInfo s r
73 [Module], -- directly imported modules
74 Bag (Module,RnName), -- unqualified imports from module
75 Bag RenamedFixityDecl, -- imported fixity decls
79 getGlobalNames iface_cache info us
80 (HsModule mod _ _ imports _ ty_decls _ cls_decls _ _ _ binds _ _)
82 (us1, us2) = splitUniqSupply us
84 case initRn True mod emptyRnEnv us1
86 getSourceNames ty_decls cls_decls binds)
87 of { ((src_vals, src_tcs), src_errs, src_warns) ->
89 doImportDecls iface_cache info us2 imports >>=
90 \ (imp_vals, imp_tcs, imp_mods, unqual_imps, imp_fixes, imp_errs, imp_warns) ->
93 unqual_vals = map (\rn -> (Unqual (getLocalName rn), rn)) (bagToList src_vals)
94 unqual_tcs = map (\rn -> (Unqual (getLocalName rn), rn)) (bagToList src_tcs)
96 (src_env, src_dups) = extendGlobalRnEnv initRnEnv unqual_vals unqual_tcs
97 (all_env, imp_dups) = extendGlobalRnEnv src_env (bagToList imp_vals) (bagToList imp_tcs)
99 -- remove dups of the same imported thing
100 diff_imp_dups = filterBag diff_orig imp_dups
101 diff_orig (_,rn1,rn2) = origName "diff_orig" rn1 /= origName "diff_orig" rn2
103 all_dups = bagToList (src_dups `unionBags` diff_imp_dups)
104 dup_errs = map dup_err (equivClasses cmp_rdr all_dups)
105 cmp_rdr (rdr1,_,_) (rdr2,_,_) = cmp rdr1 rdr2
106 dup_err ((rdr,rn1,rn2):rest) = globalDupNamesErr rdr (rn1:rn2: [rn|(_,_,rn)<-rest])
108 all_errs = src_errs `unionBags` imp_errs `unionBags` listToBag dup_errs
109 all_warns = src_warns `unionBags` imp_warns
111 -- pprTrace "initRnEnv:" (pprRnEnv PprDebug initRnEnv) $
112 -- pprTrace "src_env:" (pprRnEnv PprDebug src_env) $
113 -- pprTrace "all_env:" (pprRnEnv PprDebug all_env) $
114 return (all_env, imp_mods, unqual_imps, imp_fixes, all_errs, all_warns) }
117 *********************************************************
119 \subsection{Top-level source names}
121 *********************************************************
124 getSourceNames :: -- Collects global *binders* (not uses)
126 -> [RdrNameClassDecl]
128 -> RnM_Info s (Bag RnName, -- values
129 Bag RnName) -- tycons/classes
131 getSourceNames ty_decls cls_decls binds
132 = mapAndUnzip3Rn getTyDeclNames ty_decls `thenRn` \ (tycon_s, constrs_s, fields_s) ->
133 mapAndUnzipRn getClassNames cls_decls `thenRn` \ (cls_s, cls_ops_s) ->
134 getTopBindsNames binds `thenRn` \ bind_names ->
135 returnRn (unionManyBags constrs_s `unionBags`
136 unionManyBags fields_s `unionBags`
137 unionManyBags cls_ops_s `unionBags` bind_names,
138 listToBag tycon_s `unionBags` listToBag cls_s)
141 getTyDeclNames :: RdrNameTyDecl
142 -> RnM_Info s (RnName, Bag RnName, Bag RnName) -- tycon, constrs and fields
144 getTyDeclNames (TyData _ tycon _ condecls _ _ src_loc)
145 = --getExtraRn `thenRn` \ ((b_val_names,b_tc_names),b_keys,rec_exp_fn,rec_occ_fn) ->
146 --pprTrace "getTyDeclNames:" (ppr PprDebug tycon) $
147 --pprTrace "getTDN1:" (ppAboves [ ppCat [ppPStr m, ppPStr n] | ((OrigName m n), _) <- fmToList b_tc_names]) $
149 newGlobalName src_loc Nothing False{-not val-} tycon `thenRn` \ tycon_name ->
150 getConFieldNames (Just (nameExportFlag tycon_name)) emptyBag emptyBag emptyFM
151 condecls `thenRn` \ (con_names, field_names) ->
153 rn_tycon = RnData tycon_name con_names field_names
154 rn_constrs = [ RnConstr name tycon_name | name <- con_names]
155 rn_fields = [ RnField name tycon_name | name <- field_names]
157 returnRn (rn_tycon, listToBag rn_constrs, listToBag rn_fields)
159 getTyDeclNames (TyNew _ tycon _ [NewConDecl con _ con_loc] _ _ src_loc)
160 = newGlobalName src_loc Nothing False{-not val-} tycon `thenRn` \ tycon_name ->
161 newGlobalName con_loc (Just (nameExportFlag tycon_name)) True{-val-} con
162 `thenRn` \ con_name ->
163 returnRn (RnData tycon_name [con_name] [],
164 unitBag (RnConstr con_name tycon_name),
167 getTyDeclNames (TySynonym tycon _ _ src_loc)
168 = newGlobalName src_loc Nothing False{-not val-} tycon `thenRn` \ tycon_name ->
169 returnRn (RnSyn tycon_name, emptyBag, emptyBag)
172 getConFieldNames :: Maybe ExportFlag
173 -> Bag Name -> Bag Name
174 -> FiniteMap RdrName ()
176 -> RnM_Info s ([Name], [Name])
178 getConFieldNames exp constrs fields have []
179 = returnRn (bagToList constrs, bagToList fields)
181 getConFieldNames exp constrs fields have (ConDecl con _ src_loc : rest)
182 = newGlobalName src_loc exp True{-val-} con `thenRn` \ con_name ->
183 getConFieldNames exp (constrs `snocBag` con_name) fields have rest
185 getConFieldNames exp constrs fields have (ConOpDecl _ con _ src_loc : rest)
186 = newGlobalName src_loc exp True{-val-} con `thenRn` \ con_name ->
187 getConFieldNames exp (constrs `snocBag` con_name) fields have rest
189 getConFieldNames exp constrs fields have (RecConDecl con fielddecls src_loc : rest)
190 = mapRn (addErrRn . dupFieldErr con src_loc) dups `thenRn_`
191 newGlobalName src_loc exp True{-val-} con `thenRn` \ con_name ->
192 mapRn (newGlobalName src_loc exp True{-val-}) new_fields `thenRn` \ field_names ->
194 all_constrs = constrs `snocBag` con_name
195 all_fields = fields `unionBags` listToBag field_names
197 getConFieldNames exp all_constrs all_fields new_have rest
199 (uniq_fields, dups) = removeDups cmp (concat (map fst fielddecls))
200 new_fields = filter (not . maybeToBool . lookupFM have) uniq_fields
201 new_have = addListToFM have (zip new_fields (repeat ()))
204 getClassNames :: RdrNameClassDecl
205 -> RnM_Info s (RnName, Bag RnName) -- class and class ops
207 getClassNames (ClassDecl _ cname _ sigs _ _ src_loc)
208 = newGlobalName src_loc Nothing False{-notval-} cname `thenRn` \ class_name ->
209 getClassOpNames (Just (nameExportFlag class_name))
210 sigs `thenRn` \ op_names ->
211 returnRn (RnClass class_name op_names,
212 listToBag (map (\ n -> RnClassOp n class_name) op_names))
215 getClassOpNames :: Maybe ExportFlag
219 getClassOpNames exp [] = returnRn []
221 getClassOpNames exp (ClassOpSig op _ _ src_loc : sigs)
222 = newGlobalName src_loc exp True{-val-} op `thenRn` \ op_name ->
223 getClassOpNames exp sigs `thenRn` \ op_names ->
224 returnRn (op_name : op_names)
225 getClassOpNames exp (_ : sigs)
226 = getClassOpNames exp sigs
229 *********************************************************
231 \subsection{Bindings}
233 *********************************************************
236 getTopBindsNames :: RdrNameHsBinds
237 -> RnM_Info s (Bag RnName)
239 getTopBindsNames binds = doBinds binds
241 doBinds EmptyBinds = returnRn emptyBag
242 doBinds (SingleBind bind) = doBind bind
243 doBinds (BindWith bind sigs) = doBind bind
244 doBinds (ThenBinds binds1 binds2)
245 = andRn unionBags (doBinds binds1) (doBinds binds2)
247 doBind EmptyBind = returnRn emptyBag
248 doBind (NonRecBind mbind) = doMBinds mbind
249 doBind (RecBind mbind) = doMBinds mbind
251 doMBinds EmptyMonoBinds = returnRn emptyBag
252 doMBinds (PatMonoBind pat grhss_and_binds locn) = doPat locn pat
253 doMBinds (FunMonoBind p_name _ _ locn) = doName locn p_name
254 doMBinds (AndMonoBinds mbinds1 mbinds2)
255 = andRn unionBags (doMBinds mbinds1) (doMBinds mbinds2)
258 = mapRn (doPat locn) pats `thenRn` \ pats_s ->
259 returnRn (unionManyBags pats_s)
261 doPat locn WildPatIn = returnRn emptyBag
262 doPat locn (LitPatIn _) = returnRn emptyBag
263 doPat locn (LazyPatIn pat) = doPat locn pat
264 doPat locn (VarPatIn var) = doName locn var
265 doPat locn (NegPatIn pat) = doPat locn pat
266 doPat locn (ParPatIn pat) = doPat locn pat
267 doPat locn (ListPatIn pats) = doPats locn pats
268 doPat locn (TuplePatIn pats) = doPats locn pats
269 doPat locn (ConPatIn name pats) = doPats locn pats
270 doPat locn (ConOpPatIn p1 op p2)
271 = andRn unionBags (doPat locn p1) (doPat locn p2)
272 doPat locn (AsPatIn as_name pat)
273 = andRn unionBags (doName locn as_name) (doPat locn pat)
274 doPat locn (RecPatIn name fields)
275 = mapRn (doField locn) fields `thenRn` \ fields_s ->
276 returnRn (unionManyBags fields_s)
278 doField locn (_, pat, _) = doPat locn pat
281 = newGlobalName locn Nothing True{-val-} rdr `thenRn` \ name ->
282 returnRn (unitBag (RnName name))
285 *********************************************************
287 \subsection{Creating a new global name}
289 *********************************************************
292 newGlobalName :: SrcLoc
294 -> Bool{-True<=>value name,False<=>tycon/class-}
298 newGlobalName locn maybe_exp is_val_name (Unqual name)
299 = getExtraRn `thenRn` \ ((b_val_names,b_tc_names),b_keys,rec_exp_fn,rec_occ_fn) ->
300 getModuleRn `thenRn` \ mod ->
301 rnGetUnique `thenRn` \ u ->
303 orig = OrigName mod name
306 = case (lookupFM b_keys orig) of
307 Just (key,_) -> (key, True)
308 Nothing -> if not opt_CompilingGhcInternals then (u,True) else -- really here just to save gratuitous lookup
309 case (lookupFM (if is_val_name then b_val_names else b_tc_names) orig) of
311 Just xx -> (uniqueOf xx, False{-builtin!-})
313 exp = case maybe_exp of
315 Nothing -> rec_exp_fn n
318 then mkTopLevName uniq orig locn exp (rec_occ_fn n) -- NB: two "n"s
319 else mkWiredInName uniq orig exp
323 newGlobalName locn maybe_exp is_val_name rdr@(Qual mod name)
324 | opt_CompilingGhcInternals
325 -- we are actually defining something that compiler knows about (e.g., Bool)
327 = getExtraRn `thenRn` \ ((b_val_names,b_tc_names),b_keys,rec_exp_fn,rec_occ_fn) ->
329 orig = OrigName mod name
332 = case (lookupFM b_keys orig) of
333 Just (key,_) -> (key, True)
334 Nothing -> case (lookupFM (if is_val_name then b_val_names else b_tc_names) orig) of
335 Nothing -> (panic "newGlobalName:Qual:uniq", True)
336 Just xx -> (uniqueOf xx, False{-builtin!-})
338 exp = case maybe_exp of
340 Nothing -> rec_exp_fn n
343 then mkTopLevName uniq orig locn exp (rec_occ_fn n) -- NB: two "n"s
344 else mkWiredInName uniq orig exp
349 = addErrRn (qualNameErr "name in definition" (rdr, locn)) `thenRn_`
350 returnRn (panic "newGlobalName:Qual")
353 *********************************************************
355 \subsection{Imported names}
357 *********************************************************
362 FiniteMap OrigName RnName, -- values imported so far
363 FiniteMap OrigName RnName, -- tycons/classes imported so far
364 Name -> (ExportFlag, [SrcLoc])) -- import flag and src locns;
365 -- NB: this last field is in a knot
366 -- and mustn't be tugged on!
368 type RnM_IInfo s r = RnMonad ImportNameInfo s r
370 ------------------------------------------------------------------
373 -> GlobalNameInfo -- builtin and knot name info
375 -> [RdrNameImportDecl] -- import declarations
376 -> IO (Bag (RdrName,RnName), -- imported values in scope
377 Bag (RdrName,RnName), -- imported tycons/classes in scope
378 [Module], -- directly imported modules
379 Bag (Module,RnName), -- unqualified import from module
380 Bag RenamedFixityDecl, -- fixity info for imported names
384 doImportDecls iface_cache g_info us src_imps
385 = fixIO ( \ ~(_, _, _, _, _, _, rec_imp_stuff) ->
387 rec_imp_fm = addListToUFM_C add_stuff emptyUFM (bagToList rec_imp_stuff)
388 add_stuff (imp1,locns1) (imp2,locns2) = (lubExportFlag imp1 imp2, locns1 `unionBags` locns2)
390 rec_imp_fn :: Name -> (ExportFlag, [SrcLoc])
391 rec_imp_fn n = case lookupUFM rec_imp_fm n of
392 Nothing -> (NotExported,[mkBuiltinSrcLoc])
393 -- panic "RnNames:rec_imp_fn"
394 -- but the panic can show up
396 Just (flag, locns) -> (flag, bagToList locns)
398 i_info = (g_info, emptyFM, emptyFM, rec_imp_fn)
400 -- cache the imported modules
401 -- this ensures that all directly imported modules
402 -- will have their original name iface in scope
403 -- pprTrace "doImportDecls:" (ppCat (map ppPStr imp_mods)) $
404 accumulate (map (cachedIface iface_cache False SLIT("doImportDecls")) imp_mods) >>
406 -- process the imports
407 doImports iface_cache i_info us all_imps
409 ) >>= \ (vals, tcs, unquals, fixes, errs, warns, _) ->
411 return (vals, tcs, imp_mods, unquals, fixes,
412 imp_errs `unionBags` errs,
413 imp_warns `unionBags` warns)
415 all_imps = implicit_prel ++ src_imps
416 -- all_imps = implicit_qprel ++ the_imps
419 = not (null [ () | (ImportDecl mod qual _ _ _) <- src_imps, mod == pRELUDE ])
421 implicit_prel | opt_NoImplicitPrelude = []
422 | explicit_prelude_imp = [ImportDecl pRELUDE True Nothing Nothing prel_loc]
423 | otherwise = [ImportDecl pRELUDE False Nothing Nothing prel_loc]
425 prel_loc = mkBuiltinSrcLoc
427 (uniq_imps, imp_dups) = removeDups cmp_mod all_imps
428 cmp_mod (ImportDecl m1 _ _ _ _) (ImportDecl m2 _ _ _ _) = cmpPString m1 m2
430 qprel_imps = [ imp | imp@(ImportDecl mod True Nothing _ _) <- src_imps,
433 qual_mods = [ (qual_name mod as_mod, imp) | imp@(ImportDecl mod True as_mod _ _) <- src_imps ]
434 qual_name mod (Just as_mod) = as_mod
435 qual_name mod Nothing = mod
437 (_, qual_dups) = removeDups cmp_qual qual_mods
438 bad_qual_dups = filter (not . all_same_mod) qual_dups
440 cmp_qual (q1,_) (q2,_) = cmpPString q1 q2
441 all_same_mod ((q,ImportDecl mod _ _ _ _):rest)
442 = all has_same_mod rest
444 has_same_mod (_,ImportDecl mod2 _ _ _ _) = mod == mod2
446 imp_mods = [ mod | ImportDecl mod _ _ _ _ <- uniq_imps ]
448 imp_warns = listToBag (map dupImportWarn imp_dups)
450 listToBag (map qualPreludeImportWarn qprel_imps)
452 imp_errs = listToBag (map dupQualImportErr bad_qual_dups)
454 -----------------------
455 doImports :: IfaceCache
458 -> [RdrNameImportDecl] -- import declarations
459 -> IO (Bag (RdrName,RnName), -- imported values in scope
460 Bag (RdrName,RnName), -- imported tycons/classes in scope
461 Bag (Module, RnName), -- unqualified import from module
462 Bag RenamedFixityDecl, -- fixity info for imported names
465 Bag (RnName,(ExportFlag,Bag SrcLoc))) -- import flags and src locs
467 doImports iface_cache i_info us []
468 = return (emptyBag, emptyBag, emptyBag, emptyBag, emptyBag, emptyBag, emptyBag)
470 doImports iface_cache i_info@(g_info,done_vals,done_tcs,rec_imp_fn) us (imp:imps)
472 (us1, us2) = splitUniqSupply us
474 doImport iface_cache i_info us1 imp
475 >>= \ (vals1, tcs1, unquals1, fixes1, errs1, warns1, imps1) ->
477 ext_vals = foldl add_new_one done_vals (bagToList vals1)
478 ext_tcs = foldl add_new_one done_tcs (bagToList tcs1)
480 doImports iface_cache (g_info,ext_vals,ext_tcs,rec_imp_fn) us2 imps
481 >>= \ (vals2, tcs2, unquals2, fixes2, errs2, warns2, imps2) ->
482 return (vals1 `unionBags` vals2,
483 tcs1 `unionBags` tcs2,
484 unquals1 `unionBags` unquals2,
485 fixes1 `unionBags` fixes2,
486 errs1 `unionBags` errs2,
487 warns1 `unionBags` warns2,
488 imps1 `unionBags` imps2)
490 add_new_one :: FiniteMap OrigName RnName -- ones done so far
491 -> (dont_care, RnName)
492 -> FiniteMap OrigName RnName -- extended
494 add_new_one fm (_, rn)
496 orig = origName "add_new_one" rn
498 case (lookupFM fm orig) of
499 Just _ -> fm -- already there: no change
500 Nothing -> addToFM fm orig rn
502 ----------------------
503 doImport :: IfaceCache
507 -> IO (Bag (RdrName,RnName), -- values
508 Bag (RdrName,RnName), -- tycons/classes
509 Bag (Module,RnName), -- unqual imports
510 Bag RenamedFixityDecl,
513 Bag (RnName,(ExportFlag,Bag SrcLoc))) -- import flags and src locs
515 doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc)
517 -- (b_vals, b_tcs, maybe_spec')
518 -- = (emptyBag, emptyBag, maybe_spec)
520 --pprTrace "doImport:" (ppPStr mod) $
521 cachedIface iface_cache False SLIT("doImport") mod >>= \ maybe_iface ->
522 return (maybe_iface, \ iface -> getOrigIEs iface maybe_spec)
523 >>= \ (maybe_iface, do_ies) ->
527 return (emptyBag, emptyBag, emptyBag, emptyBag,
528 unitBag err, emptyBag, emptyBag)
531 (ies, chk_ies, get_errs) = do_ies iface
533 doOrigIEs iface_cache info mod src_loc us ies
534 >>= \ (ie_vals, ie_tcs, imp_flags, errs, warns) ->
535 accumulate (map (checkOrigIE iface_cache) chk_ies)
536 >>= \ chk_errs_warns ->
538 fold_ies = foldBag unionBags pair_occ emptyBag
540 final_vals = {-OLD:mapBag fst_occ b_vals `unionBags`-} fold_ies ie_vals
541 final_tcs = {-OLD:mapBag fst_occ b_tcs `unionBags`-} fold_ies ie_tcs
542 final_vals_list = bagToList final_vals
544 accumulate (map (getFixityDecl iface_cache . snd) final_vals_list)
545 >>= \ fix_maybes_errs ->
547 (chk_errs, chk_warns) = unzip chk_errs_warns
548 (fix_maybes, fix_errs) = unzip fix_maybes_errs
550 unquals = if qual{-ified import-}
552 else mapBag pair_as (ie_vals `unionBags` ie_tcs)
554 final_fixes = listToBag (catMaybes fix_maybes)
556 final_errs = mapBag (\ err -> err mod src_loc) (unionManyBags (get_errs:chk_errs))
557 `unionBags` errs `unionBags` unionManyBags fix_errs
558 final_warns = mapBag (\ warn -> warn mod src_loc) (unionManyBags chk_warns)
560 imp_stuff = mapBag (\ (n,imp) -> (n,(imp,unitBag src_loc))) imp_flags
562 return (final_vals, final_tcs, unquals, final_fixes,
563 final_errs, final_warns, imp_stuff)
566 as_mod = case maybe_as of {Nothing -> mod; Just as_this -> as_this}
568 mk_occ :: FAST_STRING -> RdrName
569 mk_occ str = if qual then Qual as_mod str else Unqual str
571 fst_occ :: (FAST_STRING, RnName) -> (RdrName, RnName)
572 fst_occ (str, rn) = (mk_occ str, rn)
574 pair_occ :: RnName -> Bag (RdrName, RnName)
577 str = getLocalName rn
578 qual_bag = unitBag (Qual as_mod str, rn)
582 else qual_bag -- the qualified name is *also* visible
583 `snocBag` (Unqual str, rn)
586 pair_as :: RnName -> (Module, RnName)
587 pair_as rn = (as_mod, rn)
589 -----------------------------
591 getBuiltins :: ImportNameInfo
593 -> Maybe (Bool, [RdrNameIE])
594 -> (Bag (FAST_STRING, RnName),
595 Bag (FAST_STRING, RnName),
596 Maybe (Bool, [RdrNameIE]) -- return IEs that had no effect
599 getBuiltins _ modname maybe_spec
600 -- | modname `notElem` modulesWithBuiltins
601 = (emptyBag, emptyBag, maybe_spec)
603 getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) modname maybe_spec
605 Nothing -> (all_vals, all_tcs, Nothing)
607 Just (True, ies) -> -- hiding does not work for builtin names
608 trace "NOTE: `import Prelude hiding ...' does not hide built-in names" $
609 (all_vals, all_tcs, maybe_spec)
611 Just (False, ies) -> let
612 (vals,tcs,ies_left) = do_builtin ies
614 (vals, tcs, Just (False, ies_left))
616 all_vals = do_all_builtin (fmToList b_val_names)
617 all_tcs = do_all_builtin (fmToList b_tc_names)
619 do_all_builtin [] = emptyBag
620 do_all_builtin (((OrigName mod str),rn):rest)
621 = --pprTrace "do_all_builtin:" (ppCat [ppPStr modname, ppPStr mod, ppPStr str]) $
622 (if mod == modname then consBag (str, rn) else id) (do_all_builtin rest)
624 do_builtin [] = (emptyBag,emptyBag,[])
628 = case (ie_name ie) of
629 Unqual s -> (s, OrigName modname s)
630 Qual m s -> --pprTrace "do_builtin:surprising qual!" (ppCat [ppPStr m, ppPStr s]) $
631 (s, OrigName modname s)
633 case (lookupFM b_tc_names orig) of -- NB: we favour the tycon/class FM...
634 Just rn -> case (ie,rn) of
635 (IEThingAbs _, WiredInTyCon tc)
636 -> (vals, (str, rn) `consBag` tcs, ies_left)
637 (IEThingAll _, WiredInTyCon tc)
638 -> (listToBag (map (\ id -> (getLocalName id, WiredInId id))
641 (str,rn) `consBag` tcs, ies_left)
642 (IEThingWith _ _, WiredInTyCon tc) -- No checking of With...
643 -> (listToBag (map (\ id -> (nameOf (origName "IEThingWith" id), WiredInId id))
646 (str,rn) `consBag` tcs, ies_left)
647 _ -> panic "importing builtin names (1)"
650 case (lookupFM b_val_names orig) of
651 Nothing -> (vals, tcs, ie:ies_left)
652 Just rn -> case (ie,rn) of
653 (IEVar _, WiredInId _)
654 -> ((str, rn) `consBag` vals, tcs, ies_left)
655 _ -> panic "importing builtin names (2)"
657 (vals, tcs, ies_left) = do_builtin ies
660 -------------------------
661 getOrigIEs :: ParsedIface
662 -> Maybe (Bool, [RdrNameIE]) -- "hiding" or not, blah, blah, blah
664 [(IE OrigName, ExportFlag)],
665 Bag (Module -> SrcLoc -> Error))
667 getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) Nothing -- import all
668 = (map mkAllIE (eltsFM exps), [], emptyBag)
670 getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) (Just (True, ies)) -- import hiding
671 = (map mkAllIE (eltsFM exps_left), found_ies, errs)
673 (found_ies, errs) = lookupIEs exps ies
674 exps_left = delListFromFM exps (map (getLocalName.ie_name.fst) found_ies)
676 getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) (Just (False, ies)) -- import these
677 = (map fst found_ies, found_ies, errs)
679 (found_ies, errs) = lookupIEs exps ies
681 ------------------------------------------------
682 mkAllIE :: (OrigName, ExportFlag) -> IE OrigName
684 mkAllIE (orig,ExportAbs)
685 = --ASSERT(isLexCon (nameOf orig))
686 -- the ASSERT is correct, but it is too easy to
687 -- trigger when writing .hi files by hand (e.g.
688 -- when hackily breaking a module loop)
690 mkAllIE (orig, ExportAll)
691 | isLexCon name_orig || isLexSpecialSym name_orig
696 name_orig = nameOf orig
699 lookupIEs :: ExportsMap
701 -> ([(IE OrigName, ExportFlag)], -- IEs we found, orig-ified
702 Bag (Module -> SrcLoc -> Error))
705 = foldr go ([], emptyBag) ies
707 go ie (already, errs)
709 str = case (ie_name ie) of
713 case (lookupFM exps str) of
715 (already, unknownImpSpecErr ie `consBag` errs)
717 ((orig_ie orig ie, flag) : already,
718 adderr_if (seen_ie orig already) (duplicateImpSpecErr ie) errs)
720 orig_ie orig (IEVar n) = IEVar orig
721 orig_ie orig (IEThingAbs n) = IEThingAbs orig
722 orig_ie orig (IEThingAll n) = IEThingAll orig
723 orig_ie orig (IEThingWith n ns) = IEThingWith orig (map re_orig ns)
725 (OrigName mod _) = orig
726 re_orig (Unqual s) = OrigName mod s
728 seen_ie orig seen_ies = any (\ (ie,_) -> orig == ie_name ie) seen_ies
730 --------------------------------------------
731 doOrigIEs iface_cache info mod src_loc us []
732 = return (emptyBag,emptyBag,emptyBag,emptyBag,emptyBag)
734 doOrigIEs iface_cache info mod src_loc us (ie:ies)
736 (us1, us2) = splitUniqSupply us
738 doOrigIE iface_cache info mod src_loc us1 ie
739 >>= \ (vals1, tcs1, imps1, errs1, warns1) ->
740 doOrigIEs iface_cache info mod src_loc us2 ies
741 >>= \ (vals2, tcs2, imps2, errs2, warns2) ->
742 return (vals1 `unionBags` vals2,
743 tcs1 `unionBags` tcs2,
744 imps1 `unionBags` imps2,
745 errs1 `unionBags` errs2,
746 warns1 `unionBags` warns2)
748 ----------------------
749 doOrigIE :: IfaceCache
755 -> IO (Bag RnName, -- values
756 Bag RnName, -- tycons/classes
757 Bag (RnName,ExportFlag), -- import flags
761 doOrigIE iface_cache info mod src_loc us ie
762 = with_decl iface_cache (ie_name ie)
764 (\ err -> (emptyBag, emptyBag, emptyBag, unitBag err, emptyBag))
765 (\ decl -> case initRn True mod emptyRnEnv us
767 pushSrcLocRn src_loc $
768 getIfaceDeclNames ie decl)
770 ((vals, tcs, imps), errs, warns) -> (vals, tcs, imps, errs, warns))
772 avoided_fn Nothing -- the thing should be in the source
773 = (emptyBag, emptyBag, emptyBag, emptyBag, emptyBag)
774 avoided_fn (Just (Left rn@(WiredInId _))) -- a builtin value brought into scope
775 = (unitBag rn, emptyBag, emptyBag, emptyBag, emptyBag)
776 avoided_fn (Just (Right rn@(WiredInTyCon tc)))
777 -- a builtin tc brought into scope; we also must bring its
778 -- data constructors into scope
779 = --pprTrace "avoided:Right:" (ppr PprDebug rn) $
780 (listToBag [WiredInId dc | dc <- tyConDataCons tc], unitBag rn, emptyBag, emptyBag, emptyBag)
782 -------------------------
783 checkOrigIE :: IfaceCache
784 -> (IE OrigName, ExportFlag)
785 -> IO (Bag (Module -> SrcLoc -> Error), Bag (Module -> SrcLoc -> Warning))
787 checkOrigIE iface_cache (IEThingAll n, ExportAbs)
788 = with_decl iface_cache n
789 (\ _ -> (emptyBag, emptyBag))
790 (\ err -> (unitBag (\ mod locn -> err), emptyBag))
791 (\ decl -> case decl of
792 TypeSig _ _ _ -> (emptyBag, unitBag (allWhenSynImpSpecWarn n))
793 other -> (unitBag (allWhenAbsImpSpecErr n), emptyBag))
795 checkOrigIE iface_cache (IEThingWith n ns, ExportAbs)
796 = return (unitBag (withWhenAbsImpSpecErr n), emptyBag)
798 checkOrigIE iface_cache (IEThingWith n ns, ExportAll)
799 = with_decl iface_cache n
800 (\ _ -> (emptyBag, emptyBag))
801 (\ err -> (unitBag (\ mod locn -> err), emptyBag))
802 (\ decl -> case decl of
803 NewTypeSig _ con _ _ -> (check_with "constructors" [con] ns, emptyBag)
804 DataSig _ cons fields _ _ -> (check_with "constructors (and fields)" (cons++fields) ns, emptyBag)
805 ClassSig _ ops _ _ -> (check_with "class ops" ops ns, emptyBag))
807 check_with str has origs
808 | sortLt (<) (map getLocalName has) == sortLt (<) (map nameOf origs)
811 = unitBag (withImpSpecErr str n has origs)
813 checkOrigIE iface_cache other
814 = return (emptyBag, emptyBag)
816 -----------------------
817 with_decl :: IfaceCache
819 -> (Maybe (Either RnName RnName) -> something) -- if avoided..
820 -> (Error -> something) -- if an error...
821 -> (RdrIfaceDecl -> something) -- if OK...
824 with_decl iface_cache n do_avoid do_err do_decl
825 = cachedDecl iface_cache (isLexCon n_name || isLexSpecialSym n_name) n >>= \ maybe_decl ->
827 CachingAvoided info -> return (do_avoid info)
828 CachingFail err -> return (do_err err)
829 CachingHit decl -> return (do_decl decl)
834 getFixityDecl :: IfaceCache
836 -> IO (Maybe RenamedFixityDecl, Bag Error)
838 getFixityDecl iface_cache rn
840 (OrigName mod str) = origName "getFixityDecl" rn
842 succeeded infx i = return (Just (infx rn i), emptyBag)
844 cachedIface iface_cache True str mod >>= \ maybe_iface ->
847 return (Nothing, unitBag err)
848 Succeeded (ParsedIface _ _ _ _ _ _ _ _ fixes _ _ _ _) ->
849 case lookupFM fixes str of
850 Nothing -> return (Nothing, emptyBag)
851 Just (InfixL _ i) -> succeeded InfixL i
852 Just (InfixR _ i) -> succeeded InfixR i
853 Just (InfixN _ i) -> succeeded InfixN i
855 ie_name (IEVar n) = n
856 ie_name (IEThingAbs n) = n
857 ie_name (IEThingAll n) = n
858 ie_name (IEThingWith n _) = n
860 adderr_if True err errs = err `consBag` errs
861 adderr_if False err errs = errs
864 *********************************************************
866 \subsection{Actually creating the imported names}
868 *********************************************************
871 getIfaceDeclNames :: IE OrigName -> RdrIfaceDecl
872 -> RnM_IInfo s (Bag RnName, -- values
873 Bag RnName, -- tycons/classes
874 Bag (RnName,ExportFlag)) -- import flags
876 getIfaceDeclNames ie (ValSig val src_loc _)
877 = newImportedName False src_loc Nothing Nothing val `thenRn` \ val_name ->
878 returnRn (unitBag (RnName val_name),
880 unitBag (RnName val_name, ExportAll))
882 getIfaceDeclNames ie (TypeSig tycon src_loc _)
883 = newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name ->
885 unitBag (RnSyn tycon_name),
886 unitBag (RnSyn tycon_name, ExportAll))
888 getIfaceDeclNames ie (NewTypeSig tycon con src_loc _)
889 = newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name ->
890 newImportedName False src_loc (Just (nameExportFlag tycon_name))
891 (Just (nameImportFlag tycon_name))
892 con `thenRn` \ con_name ->
893 returnRn (if imp_all (imp_flag ie) then
894 unitBag (RnConstr con_name tycon_name)
897 unitBag (RnData tycon_name [con_name] []),
898 unitBag (RnData tycon_name [con_name] [], imp_flag ie))
900 getIfaceDeclNames ie (DataSig tycon cons fields src_loc _)
901 = newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name ->
903 map_me = mapRn (newImportedName False src_loc
904 (Just (nameExportFlag tycon_name))
905 (Just (nameImportFlag tycon_name)))
907 map_me cons `thenRn` \ con_names ->
908 map_me fields `thenRn` \ field_names ->
910 rn_tycon = RnData tycon_name con_names field_names
911 rn_constrs = [ RnConstr name tycon_name | name <- con_names ]
912 rn_fields = [ RnField name tycon_name | name <- field_names ]
914 returnRn (if imp_all (imp_flag ie) then
915 listToBag rn_constrs `unionBags` listToBag rn_fields
919 unitBag (rn_tycon, imp_flag ie))
921 getIfaceDeclNames ie (ClassSig cls ops src_loc _)
922 = newImportedName True src_loc Nothing Nothing cls `thenRn` \ cls_name ->
923 mapRn (newImportedName False src_loc (Just (nameExportFlag cls_name))
924 (Just (nameImportFlag cls_name)))
925 ops `thenRn` \ op_names ->
926 returnRn (if imp_all (imp_flag ie) then
927 listToBag (map (\ n -> RnClassOp n cls_name) op_names)
930 unitBag (RnClass cls_name op_names),
931 unitBag (RnClass cls_name op_names, imp_flag ie))
934 imp_all ExportAll = True
937 imp_flag (IEThingAbs _) = ExportAbs
938 imp_flag (IEThingAll _) = ExportAll
939 imp_flag (IEThingWith _ _) = ExportAll
942 *********************************************************
944 \subsection{Creating a new imported name}
946 *********************************************************
949 newImportedName :: Bool -- True => tycon or class
951 -> Maybe ExportFlag -- maybe export flag
952 -> Maybe ExportFlag -- maybe import flag
953 -> RdrName -- orig name
956 newImportedName tycon_or_class locn maybe_exp maybe_imp rdr
958 orig = qualToOrigName rdr
960 getExtraRn `thenRn` \ ((_,b_keys,rec_exp_fn,rec_occ_fn),done_vals,done_tcs,rec_imp_fn) ->
961 case ((if tycon_or_class
962 then lookupFM done_tcs
963 else lookupFM done_vals) orig) of
965 Just rn -> returnRn (getName rn)
967 rnGetUnique `thenRn` \ u ->
969 uniq = case lookupFM b_keys orig of
973 exp = case maybe_exp of
975 Nothing -> rec_exp_fn n
977 imp = case maybe_imp of
981 (imp_flag, imp_locs) = rec_imp_fn n
983 n = mkImportedName uniq orig imp locn imp_locs exp (rec_occ_fn n) -- NB: two "n"s
989 globalDupNamesErr rdr rns sty
990 = ppAboves (message : map pp_dup rns)
992 message = ppBesides [ppStr "multiple declarations of `", pprNonSym sty rdr, ppStr "'"]
994 pp_dup rn = addShortErrLocLine (get_loc rn) (\ sty ->
995 ppCat [pp_descrip rn, pprNonSym sty rn]) sty
997 get_loc rn = case getImpLocs rn of
1001 pp_descrip (RnName _) = ppStr "as a value:"
1002 pp_descrip (RnSyn _) = ppStr "as a type synonym:"
1003 pp_descrip (RnData _ _ _) = ppStr "as a data type:"
1004 pp_descrip (RnConstr _ _) = ppStr "as a data constructor:"
1005 pp_descrip (RnField _ _) = ppStr "as a record field:"
1006 pp_descrip (RnClass _ _) = ppStr "as a class:"
1007 pp_descrip (RnClassOp _ _) = ppStr "as a class method:"
1008 pp_descrip _ = ppNil
1010 dupImportWarn (ImportDecl m1 _ _ _ locn1 : dup_imps) sty
1011 = ppAboves (item1 : map dup_item dup_imps)
1013 item1 = addShortWarnLocLine locn1 (\ sty ->
1014 ppCat [ppStr "multiple imports from module", ppPStr m1]) sty
1016 dup_item (ImportDecl m _ _ _ locn)
1017 = addShortWarnLocLine locn (\ sty ->
1018 ppCat [ppStr "here was another import from module", ppPStr m]) sty
1020 qualPreludeImportWarn (ImportDecl m _ _ _ locn)
1021 = addShortWarnLocLine locn (\ sty ->
1022 ppCat [ppStr "qualified import of prelude module", ppPStr m])
1024 dupQualImportErr ((q1,ImportDecl _ _ _ _ locn1):dup_quals) sty
1025 = ppAboves (item1 : map dup_item dup_quals)
1027 item1 = addShortErrLocLine locn1 (\ sty ->
1028 ppCat [ppStr "multiple imports (from different modules) with same qualified name", ppPStr q1]) sty
1030 dup_item (q,ImportDecl _ _ _ _ locn)
1031 = addShortErrLocLine locn (\ sty ->
1032 ppCat [ppStr "here was another import with qualified name", ppPStr q]) sty
1034 unknownImpSpecErr ie imp_mod locn
1035 = addShortErrLocLine locn (\ sty ->
1036 ppBesides [ppStr "module ", ppPStr imp_mod, ppStr " does not export `", ppr sty (ie_name ie), ppStr "'"])
1038 duplicateImpSpecErr ie imp_mod locn
1039 = addShortErrLocLine locn (\ sty ->
1040 ppBesides [ppStr "`", ppr sty (ie_name ie), ppStr "' already seen in import list"])
1042 allWhenSynImpSpecWarn n imp_mod locn
1043 = addShortWarnLocLine locn (\ sty ->
1044 ppBesides [ppStr "type synonym `", ppr sty n, ppStr "' should not be imported with (..)"])
1046 allWhenAbsImpSpecErr n imp_mod locn
1047 = addShortErrLocLine locn (\ sty ->
1048 ppBesides [ppStr "module ", ppPStr imp_mod, ppStr " only exports `", ppr sty n, ppStr "' abstractly"])
1050 withWhenAbsImpSpecErr n imp_mod locn
1051 = addShortErrLocLine locn (\ sty ->
1052 ppBesides [ppStr "module ", ppPStr imp_mod, ppStr " only exports `", ppr sty n, ppStr "' abstractly"])
1054 withImpSpecErr str n has ns imp_mod locn
1055 = addErrLoc locn "" (\ sty ->
1056 ppAboves [ ppBesides [ppStr "inconsistent list of", ppStr str, ppStr "in import list for `", ppr sty n, ppStr "'"],
1057 ppCat [ppStr " expected:", ppInterleave ppComma (map (ppr sty) has)],
1058 ppCat [ppStr " found: ", ppInterleave ppComma (map (ppr sty) ns)] ])
1060 dupFieldErr con locn (dup:rest)
1061 = addShortErrLocLine locn (\ sty ->
1062 ppBesides [ppStr "record field `", ppr sty dup, ppStr "declared multiple times in `", ppr sty con, ppStr "'"])