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 -> panic "RnNames:rec_imp_fn"
393 Just (flag, locns) -> (flag, bagToList locns)
395 i_info = (g_info, emptyFM, emptyFM, rec_imp_fn)
397 -- cache the imported modules
398 -- this ensures that all directly imported modules
399 -- will have their original name iface in scope
400 -- pprTrace "doImportDecls:" (ppCat (map ppPStr imp_mods)) $
401 accumulate (map (cachedIface iface_cache False SLIT("doImportDecls")) imp_mods) >>
403 -- process the imports
404 doImports iface_cache i_info us all_imps
406 ) >>= \ (vals, tcs, unquals, fixes, errs, warns, _) ->
408 return (vals, tcs, imp_mods, unquals, fixes,
409 imp_errs `unionBags` errs,
410 imp_warns `unionBags` warns)
412 all_imps = implicit_prel ++ src_imps
413 -- all_imps = implicit_qprel ++ the_imps
416 = not (null [ () | (ImportDecl mod qual _ _ _) <- src_imps, mod == pRELUDE ])
418 implicit_prel | opt_NoImplicitPrelude = []
419 | explicit_prelude_imp = [ImportDecl pRELUDE True Nothing Nothing prel_loc]
420 | otherwise = [ImportDecl pRELUDE False Nothing Nothing prel_loc]
422 prel_loc = mkBuiltinSrcLoc
424 (uniq_imps, imp_dups) = removeDups cmp_mod all_imps
425 cmp_mod (ImportDecl m1 _ _ _ _) (ImportDecl m2 _ _ _ _) = cmpPString m1 m2
427 qprel_imps = [ imp | imp@(ImportDecl mod True Nothing _ _) <- src_imps,
430 qual_mods = [ (qual_name mod as_mod, imp) | imp@(ImportDecl mod True as_mod _ _) <- src_imps ]
431 qual_name mod (Just as_mod) = as_mod
432 qual_name mod Nothing = mod
434 (_, qual_dups) = removeDups cmp_qual qual_mods
435 bad_qual_dups = filter (not . all_same_mod) qual_dups
437 cmp_qual (q1,_) (q2,_) = cmpPString q1 q2
438 all_same_mod ((q,ImportDecl mod _ _ _ _):rest)
439 = all has_same_mod rest
441 has_same_mod (_,ImportDecl mod2 _ _ _ _) = mod == mod2
443 imp_mods = [ mod | ImportDecl mod _ _ _ _ <- uniq_imps ]
445 imp_warns = listToBag (map dupImportWarn imp_dups)
447 listToBag (map qualPreludeImportWarn qprel_imps)
449 imp_errs = listToBag (map dupQualImportErr bad_qual_dups)
451 -----------------------
452 doImports :: IfaceCache
455 -> [RdrNameImportDecl] -- import declarations
456 -> IO (Bag (RdrName,RnName), -- imported values in scope
457 Bag (RdrName,RnName), -- imported tycons/classes in scope
458 Bag (Module, RnName), -- unqualified import from module
459 Bag RenamedFixityDecl, -- fixity info for imported names
462 Bag (RnName,(ExportFlag,Bag SrcLoc))) -- import flags and src locs
464 doImports iface_cache i_info us []
465 = return (emptyBag, emptyBag, emptyBag, emptyBag, emptyBag, emptyBag, emptyBag)
467 doImports iface_cache i_info@(g_info,done_vals,done_tcs,rec_imp_fn) us (imp:imps)
469 (us1, us2) = splitUniqSupply us
471 doImport iface_cache i_info us1 imp
472 >>= \ (vals1, tcs1, unquals1, fixes1, errs1, warns1, imps1) ->
474 ext_vals = foldl add_new_one done_vals (bagToList vals1)
475 ext_tcs = foldl add_new_one done_tcs (bagToList tcs1)
477 doImports iface_cache (g_info,ext_vals,ext_tcs,rec_imp_fn) us2 imps
478 >>= \ (vals2, tcs2, unquals2, fixes2, errs2, warns2, imps2) ->
479 return (vals1 `unionBags` vals2,
480 tcs1 `unionBags` tcs2,
481 unquals1 `unionBags` unquals2,
482 fixes1 `unionBags` fixes2,
483 errs1 `unionBags` errs2,
484 warns1 `unionBags` warns2,
485 imps1 `unionBags` imps2)
487 add_new_one :: FiniteMap OrigName RnName -- ones done so far
488 -> (dont_care, RnName)
489 -> FiniteMap OrigName RnName -- extended
491 add_new_one fm (_, rn)
493 orig = origName "add_new_one" rn
495 case (lookupFM fm orig) of
496 Just _ -> fm -- already there: no change
497 Nothing -> addToFM fm orig rn
499 ----------------------
500 doImport :: IfaceCache
504 -> IO (Bag (RdrName,RnName), -- values
505 Bag (RdrName,RnName), -- tycons/classes
506 Bag (Module,RnName), -- unqual imports
507 Bag RenamedFixityDecl,
510 Bag (RnName,(ExportFlag,Bag SrcLoc))) -- import flags and src locs
512 doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc)
514 -- (b_vals, b_tcs, maybe_spec')
515 -- = (emptyBag, emptyBag, maybe_spec)
517 --pprTrace "doImport:" (ppPStr mod) $
518 cachedIface iface_cache False SLIT("doImport") mod >>= \ maybe_iface ->
519 return (maybe_iface, \ iface -> getOrigIEs iface maybe_spec)
520 >>= \ (maybe_iface, do_ies) ->
524 return (emptyBag, emptyBag, emptyBag, emptyBag,
525 unitBag err, emptyBag, emptyBag)
528 (ies, chk_ies, get_errs) = do_ies iface
530 doOrigIEs iface_cache info mod src_loc us ies
531 >>= \ (ie_vals, ie_tcs, imp_flags, errs, warns) ->
532 accumulate (map (checkOrigIE iface_cache) chk_ies)
533 >>= \ chk_errs_warns ->
535 fold_ies = foldBag unionBags pair_occ emptyBag
537 final_vals = {-OLD:mapBag fst_occ b_vals `unionBags`-} fold_ies ie_vals
538 final_tcs = {-OLD:mapBag fst_occ b_tcs `unionBags`-} fold_ies ie_tcs
539 final_vals_list = bagToList final_vals
541 accumulate (map (getFixityDecl iface_cache . snd) final_vals_list)
542 >>= \ fix_maybes_errs ->
544 (chk_errs, chk_warns) = unzip chk_errs_warns
545 (fix_maybes, fix_errs) = unzip fix_maybes_errs
547 unquals = if qual{-ified import-}
549 else mapBag pair_as (ie_vals `unionBags` ie_tcs)
551 final_fixes = listToBag (catMaybes fix_maybes)
553 final_errs = mapBag (\ err -> err mod src_loc) (unionManyBags (get_errs:chk_errs))
554 `unionBags` errs `unionBags` unionManyBags fix_errs
555 final_warns = mapBag (\ warn -> warn mod src_loc) (unionManyBags chk_warns)
557 imp_stuff = mapBag (\ (n,imp) -> (n,(imp,unitBag src_loc))) imp_flags
559 return (final_vals, final_tcs, unquals, final_fixes,
560 final_errs, final_warns, imp_stuff)
563 as_mod = case maybe_as of {Nothing -> mod; Just as_this -> as_this}
565 mk_occ :: FAST_STRING -> RdrName
566 mk_occ str = if qual then Qual as_mod str else Unqual str
568 fst_occ :: (FAST_STRING, RnName) -> (RdrName, RnName)
569 fst_occ (str, rn) = (mk_occ str, rn)
571 pair_occ :: RnName -> Bag (RdrName, RnName)
574 str = getLocalName rn
575 qual_bag = unitBag (Qual as_mod str, rn)
579 else qual_bag -- the qualified name is *also* visible
580 `snocBag` (Unqual str, rn)
583 pair_as :: RnName -> (Module, RnName)
584 pair_as rn = (as_mod, rn)
586 -----------------------------
588 getBuiltins :: ImportNameInfo
590 -> Maybe (Bool, [RdrNameIE])
591 -> (Bag (FAST_STRING, RnName),
592 Bag (FAST_STRING, RnName),
593 Maybe (Bool, [RdrNameIE]) -- return IEs that had no effect
596 getBuiltins _ modname maybe_spec
597 -- | modname `notElem` modulesWithBuiltins
598 = (emptyBag, emptyBag, maybe_spec)
600 getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) modname maybe_spec
602 Nothing -> (all_vals, all_tcs, Nothing)
604 Just (True, ies) -> -- hiding does not work for builtin names
605 trace "NOTE: `import Prelude hiding ...' does not hide built-in names" $
606 (all_vals, all_tcs, maybe_spec)
608 Just (False, ies) -> let
609 (vals,tcs,ies_left) = do_builtin ies
611 (vals, tcs, Just (False, ies_left))
613 all_vals = do_all_builtin (fmToList b_val_names)
614 all_tcs = do_all_builtin (fmToList b_tc_names)
616 do_all_builtin [] = emptyBag
617 do_all_builtin (((OrigName mod str),rn):rest)
618 = --pprTrace "do_all_builtin:" (ppCat [ppPStr modname, ppPStr mod, ppPStr str]) $
619 (if mod == modname then consBag (str, rn) else id) (do_all_builtin rest)
621 do_builtin [] = (emptyBag,emptyBag,[])
625 = case (ie_name ie) of
626 Unqual s -> (s, OrigName modname s)
627 Qual m s -> --pprTrace "do_builtin:surprising qual!" (ppCat [ppPStr m, ppPStr s]) $
628 (s, OrigName modname s)
630 case (lookupFM b_tc_names orig) of -- NB: we favour the tycon/class FM...
631 Just rn -> case (ie,rn) of
632 (IEThingAbs _, WiredInTyCon tc)
633 -> (vals, (str, rn) `consBag` tcs, ies_left)
634 (IEThingAll _, WiredInTyCon tc)
635 -> (listToBag (map (\ id -> (getLocalName id, WiredInId id))
638 (str,rn) `consBag` tcs, ies_left)
639 (IEThingWith _ _, WiredInTyCon tc) -- No checking of With...
640 -> (listToBag (map (\ id -> (nameOf (origName "IEThingWith" id), WiredInId id))
643 (str,rn) `consBag` tcs, ies_left)
644 _ -> panic "importing builtin names (1)"
647 case (lookupFM b_val_names orig) of
648 Nothing -> (vals, tcs, ie:ies_left)
649 Just rn -> case (ie,rn) of
650 (IEVar _, WiredInId _)
651 -> ((str, rn) `consBag` vals, tcs, ies_left)
652 _ -> panic "importing builtin names (2)"
654 (vals, tcs, ies_left) = do_builtin ies
657 -------------------------
658 getOrigIEs :: ParsedIface
659 -> Maybe (Bool, [RdrNameIE]) -- "hiding" or not, blah, blah, blah
661 [(IE OrigName, ExportFlag)],
662 Bag (Module -> SrcLoc -> Error))
664 getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) Nothing -- import all
665 = (map mkAllIE (eltsFM exps), [], emptyBag)
667 getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) (Just (True, ies)) -- import hiding
668 = (map mkAllIE (eltsFM exps_left), found_ies, errs)
670 (found_ies, errs) = lookupIEs exps ies
671 exps_left = delListFromFM exps (map (getLocalName.ie_name.fst) found_ies)
673 getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) (Just (False, ies)) -- import these
674 = (map fst found_ies, found_ies, errs)
676 (found_ies, errs) = lookupIEs exps ies
678 ------------------------------------------------
679 mkAllIE :: (OrigName, ExportFlag) -> IE OrigName
681 mkAllIE (orig,ExportAbs)
682 = --ASSERT(isLexCon (nameOf orig))
683 -- the ASSERT is correct, but it is too easy to
684 -- trigger when writing .hi files by hand (e.g.
685 -- when hackily breaking a module loop)
687 mkAllIE (orig, ExportAll)
688 | isLexCon name_orig || isLexSpecialSym name_orig
693 name_orig = nameOf orig
696 lookupIEs :: ExportsMap
698 -> ([(IE OrigName, ExportFlag)], -- IEs we found, orig-ified
699 Bag (Module -> SrcLoc -> Error))
702 = foldr go ([], emptyBag) ies
704 go ie (already, errs)
706 str = case (ie_name ie) of
710 case (lookupFM exps str) of
712 (already, unknownImpSpecErr ie `consBag` errs)
714 ((orig_ie orig ie, flag) : already,
715 adderr_if (seen_ie orig already) (duplicateImpSpecErr ie) errs)
717 orig_ie orig (IEVar n) = IEVar orig
718 orig_ie orig (IEThingAbs n) = IEThingAbs orig
719 orig_ie orig (IEThingAll n) = IEThingAll orig
720 orig_ie orig (IEThingWith n ns) = IEThingWith orig (map re_orig ns)
722 (OrigName mod _) = orig
723 re_orig (Unqual s) = OrigName mod s
725 seen_ie orig seen_ies = any (\ (ie,_) -> orig == ie_name ie) seen_ies
727 --------------------------------------------
728 doOrigIEs iface_cache info mod src_loc us []
729 = return (emptyBag,emptyBag,emptyBag,emptyBag,emptyBag)
731 doOrigIEs iface_cache info mod src_loc us (ie:ies)
733 (us1, us2) = splitUniqSupply us
735 doOrigIE iface_cache info mod src_loc us1 ie
736 >>= \ (vals1, tcs1, imps1, errs1, warns1) ->
737 doOrigIEs iface_cache info mod src_loc us2 ies
738 >>= \ (vals2, tcs2, imps2, errs2, warns2) ->
739 return (vals1 `unionBags` vals2,
740 tcs1 `unionBags` tcs2,
741 imps1 `unionBags` imps2,
742 errs1 `unionBags` errs2,
743 warns1 `unionBags` warns2)
745 ----------------------
746 doOrigIE :: IfaceCache
752 -> IO (Bag RnName, -- values
753 Bag RnName, -- tycons/classes
754 Bag (RnName,ExportFlag), -- import flags
758 doOrigIE iface_cache info mod src_loc us ie
759 = with_decl iface_cache (ie_name ie)
761 (\ err -> (emptyBag, emptyBag, emptyBag, unitBag err, emptyBag))
762 (\ decl -> case initRn True mod emptyRnEnv us
764 pushSrcLocRn src_loc $
765 getIfaceDeclNames ie decl)
767 ((vals, tcs, imps), errs, warns) -> (vals, tcs, imps, errs, warns))
769 avoided_fn Nothing -- the thing should be in the source
770 = (emptyBag, emptyBag, emptyBag, emptyBag, emptyBag)
771 avoided_fn (Just (Left rn@(WiredInId _))) -- a builtin value brought into scope
772 = (unitBag rn, emptyBag, emptyBag, emptyBag, emptyBag)
773 avoided_fn (Just (Right rn@(WiredInTyCon tc)))
774 -- a builtin tc brought into scope; we also must bring its
775 -- data constructors into scope
776 = --pprTrace "avoided:Right:" (ppr PprDebug rn) $
777 (listToBag [WiredInId dc | dc <- tyConDataCons tc], unitBag rn, emptyBag, emptyBag, emptyBag)
779 -------------------------
780 checkOrigIE :: IfaceCache
781 -> (IE OrigName, ExportFlag)
782 -> IO (Bag (Module -> SrcLoc -> Error), Bag (Module -> SrcLoc -> Warning))
784 checkOrigIE iface_cache (IEThingAll n, ExportAbs)
785 = with_decl iface_cache n
786 (\ _ -> (emptyBag, emptyBag))
787 (\ err -> (unitBag (\ mod locn -> err), emptyBag))
788 (\ decl -> case decl of
789 TypeSig _ _ _ -> (emptyBag, unitBag (allWhenSynImpSpecWarn n))
790 other -> (unitBag (allWhenAbsImpSpecErr n), emptyBag))
792 checkOrigIE iface_cache (IEThingWith n ns, ExportAbs)
793 = return (unitBag (withWhenAbsImpSpecErr n), emptyBag)
795 checkOrigIE iface_cache (IEThingWith n ns, ExportAll)
796 = with_decl iface_cache n
797 (\ _ -> (emptyBag, emptyBag))
798 (\ err -> (unitBag (\ mod locn -> err), emptyBag))
799 (\ decl -> case decl of
800 NewTypeSig _ con _ _ -> (check_with "constructors" [con] ns, emptyBag)
801 DataSig _ cons fields _ _ -> (check_with "constructors (and fields)" (cons++fields) ns, emptyBag)
802 ClassSig _ ops _ _ -> (check_with "class ops" ops ns, emptyBag))
804 check_with str has origs
805 | sortLt (<) (map getLocalName has) == sortLt (<) (map nameOf origs)
808 = unitBag (withImpSpecErr str n has origs)
810 checkOrigIE iface_cache other
811 = return (emptyBag, emptyBag)
813 -----------------------
814 with_decl :: IfaceCache
816 -> (Maybe (Either RnName RnName) -> something) -- if avoided..
817 -> (Error -> something) -- if an error...
818 -> (RdrIfaceDecl -> something) -- if OK...
821 with_decl iface_cache n do_avoid do_err do_decl
822 = cachedDecl iface_cache (isLexCon n_name || isLexSpecialSym n_name) n >>= \ maybe_decl ->
824 CachingAvoided info -> return (do_avoid info)
825 CachingFail err -> return (do_err err)
826 CachingHit decl -> return (do_decl decl)
831 getFixityDecl :: IfaceCache
833 -> IO (Maybe RenamedFixityDecl, Bag Error)
835 getFixityDecl iface_cache rn
837 (OrigName mod str) = origName "getFixityDecl" rn
839 succeeded infx i = return (Just (infx rn i), emptyBag)
841 cachedIface iface_cache True str mod >>= \ maybe_iface ->
844 return (Nothing, unitBag err)
845 Succeeded (ParsedIface _ _ _ _ _ _ _ _ fixes _ _ _ _) ->
846 case lookupFM fixes str of
847 Nothing -> return (Nothing, emptyBag)
848 Just (InfixL _ i) -> succeeded InfixL i
849 Just (InfixR _ i) -> succeeded InfixR i
850 Just (InfixN _ i) -> succeeded InfixN i
852 ie_name (IEVar n) = n
853 ie_name (IEThingAbs n) = n
854 ie_name (IEThingAll n) = n
855 ie_name (IEThingWith n _) = n
857 adderr_if True err errs = err `consBag` errs
858 adderr_if False err errs = errs
861 *********************************************************
863 \subsection{Actually creating the imported names}
865 *********************************************************
868 getIfaceDeclNames :: IE OrigName -> RdrIfaceDecl
869 -> RnM_IInfo s (Bag RnName, -- values
870 Bag RnName, -- tycons/classes
871 Bag (RnName,ExportFlag)) -- import flags
873 getIfaceDeclNames ie (ValSig val src_loc _)
874 = newImportedName False src_loc Nothing Nothing val `thenRn` \ val_name ->
875 returnRn (unitBag (RnName val_name),
877 unitBag (RnName val_name, ExportAll))
879 getIfaceDeclNames ie (TypeSig tycon src_loc _)
880 = newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name ->
882 unitBag (RnSyn tycon_name),
883 unitBag (RnSyn tycon_name, ExportAll))
885 getIfaceDeclNames ie (NewTypeSig tycon con src_loc _)
886 = newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name ->
887 newImportedName False src_loc (Just (nameExportFlag tycon_name))
888 (Just (nameImportFlag tycon_name))
889 con `thenRn` \ con_name ->
890 returnRn (if imp_all (imp_flag ie) then
891 unitBag (RnConstr con_name tycon_name)
894 unitBag (RnData tycon_name [con_name] []),
895 unitBag (RnData tycon_name [con_name] [], imp_flag ie))
897 getIfaceDeclNames ie (DataSig tycon cons fields src_loc _)
898 = newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name ->
900 map_me = mapRn (newImportedName False src_loc
901 (Just (nameExportFlag tycon_name))
902 (Just (nameImportFlag tycon_name)))
904 map_me cons `thenRn` \ con_names ->
905 map_me fields `thenRn` \ field_names ->
907 rn_tycon = RnData tycon_name con_names field_names
908 rn_constrs = [ RnConstr name tycon_name | name <- con_names ]
909 rn_fields = [ RnField name tycon_name | name <- field_names ]
911 returnRn (if imp_all (imp_flag ie) then
912 listToBag rn_constrs `unionBags` listToBag rn_fields
916 unitBag (rn_tycon, imp_flag ie))
918 getIfaceDeclNames ie (ClassSig cls ops src_loc _)
919 = newImportedName True src_loc Nothing Nothing cls `thenRn` \ cls_name ->
920 mapRn (newImportedName False src_loc (Just (nameExportFlag cls_name))
921 (Just (nameImportFlag cls_name)))
922 ops `thenRn` \ op_names ->
923 returnRn (if imp_all (imp_flag ie) then
924 listToBag (map (\ n -> RnClassOp n cls_name) op_names)
927 unitBag (RnClass cls_name op_names),
928 unitBag (RnClass cls_name op_names, imp_flag ie))
931 imp_all ExportAll = True
934 imp_flag (IEThingAbs _) = ExportAbs
935 imp_flag (IEThingAll _) = ExportAll
936 imp_flag (IEThingWith _ _) = ExportAll
939 *********************************************************
941 \subsection{Creating a new imported name}
943 *********************************************************
946 newImportedName :: Bool -- True => tycon or class
948 -> Maybe ExportFlag -- maybe export flag
949 -> Maybe ExportFlag -- maybe import flag
950 -> RdrName -- orig name
953 newImportedName tycon_or_class locn maybe_exp maybe_imp rdr
955 orig = qualToOrigName rdr
957 getExtraRn `thenRn` \ ((_,b_keys,rec_exp_fn,rec_occ_fn),done_vals,done_tcs,rec_imp_fn) ->
958 case ((if tycon_or_class
959 then lookupFM done_tcs
960 else lookupFM done_vals) orig) of
962 Just rn -> returnRn (getName rn)
964 rnGetUnique `thenRn` \ u ->
966 uniq = case lookupFM b_keys orig of
970 exp = case maybe_exp of
972 Nothing -> rec_exp_fn n
974 imp = case maybe_imp of
978 (imp_flag, imp_locs) = rec_imp_fn n
980 n = mkImportedName uniq orig imp locn imp_locs exp (rec_occ_fn n) -- NB: two "n"s
986 globalDupNamesErr rdr rns sty
987 = ppAboves (message : map pp_dup rns)
989 message = ppBesides [ppStr "multiple declarations of `", pprNonSym sty rdr, ppStr "'"]
991 pp_dup rn = addShortErrLocLine (get_loc rn) (\ sty ->
992 ppCat [pp_descrip rn, pprNonSym sty rn]) sty
994 get_loc rn = case getImpLocs rn of
998 pp_descrip (RnName _) = ppStr "as a value:"
999 pp_descrip (RnSyn _) = ppStr "as a type synonym:"
1000 pp_descrip (RnData _ _ _) = ppStr "as a data type:"
1001 pp_descrip (RnConstr _ _) = ppStr "as a data constructor:"
1002 pp_descrip (RnField _ _) = ppStr "as a record field:"
1003 pp_descrip (RnClass _ _) = ppStr "as a class:"
1004 pp_descrip (RnClassOp _ _) = ppStr "as a class method:"
1005 pp_descrip _ = ppNil
1007 dupImportWarn (ImportDecl m1 _ _ _ locn1 : dup_imps) sty
1008 = ppAboves (item1 : map dup_item dup_imps)
1010 item1 = addShortWarnLocLine locn1 (\ sty ->
1011 ppCat [ppStr "multiple imports from module", ppPStr m1]) sty
1013 dup_item (ImportDecl m _ _ _ locn)
1014 = addShortWarnLocLine locn (\ sty ->
1015 ppCat [ppStr "here was another import from module", ppPStr m]) sty
1017 qualPreludeImportWarn (ImportDecl m _ _ _ locn)
1018 = addShortWarnLocLine locn (\ sty ->
1019 ppCat [ppStr "qualified import of prelude module", ppPStr m])
1021 dupQualImportErr ((q1,ImportDecl _ _ _ _ locn1):dup_quals) sty
1022 = ppAboves (item1 : map dup_item dup_quals)
1024 item1 = addShortErrLocLine locn1 (\ sty ->
1025 ppCat [ppStr "multiple imports (from different modules) with same qualified name", ppPStr q1]) sty
1027 dup_item (q,ImportDecl _ _ _ _ locn)
1028 = addShortErrLocLine locn (\ sty ->
1029 ppCat [ppStr "here was another import with qualified name", ppPStr q]) sty
1031 unknownImpSpecErr ie imp_mod locn
1032 = addShortErrLocLine locn (\ sty ->
1033 ppBesides [ppStr "module ", ppPStr imp_mod, ppStr " does not export `", ppr sty (ie_name ie), ppStr "'"])
1035 duplicateImpSpecErr ie imp_mod locn
1036 = addShortErrLocLine locn (\ sty ->
1037 ppBesides [ppStr "`", ppr sty (ie_name ie), ppStr "' already seen in import list"])
1039 allWhenSynImpSpecWarn n imp_mod locn
1040 = addShortWarnLocLine locn (\ sty ->
1041 ppBesides [ppStr "type synonym `", ppr sty n, ppStr "' should not be imported with (..)"])
1043 allWhenAbsImpSpecErr n imp_mod locn
1044 = addShortErrLocLine locn (\ sty ->
1045 ppBesides [ppStr "module ", ppPStr imp_mod, ppStr " only exports `", ppr sty n, ppStr "' abstractly"])
1047 withWhenAbsImpSpecErr n imp_mod locn
1048 = addShortErrLocLine locn (\ sty ->
1049 ppBesides [ppStr "module ", ppPStr imp_mod, ppStr " only exports `", ppr sty n, ppStr "' abstractly"])
1051 withImpSpecErr str n has ns imp_mod locn
1052 = addErrLoc locn "" (\ sty ->
1053 ppAboves [ ppBesides [ppStr "inconsistent list of", ppStr str, ppStr "in import list for `", ppr sty n, ppStr "'"],
1054 ppCat [ppStr " expected:", ppInterleave ppComma (map (ppr sty) has)],
1055 ppCat [ppStr " found: ", ppInterleave ppComma (map (ppr sty) ns)] ])
1057 dupFieldErr con locn (dup:rest)
1058 = addShortErrLocLine locn (\ sty ->
1059 ppBesides [ppStr "record field `", ppr sty dup, ppStr "declared multiple times in `", ppr sty con, ppStr "'"])