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 ( MutableVar(..) )
23 import RnIfaces ( IfaceCache(..), cachedIface, cachedDecl )
24 import RnUtils ( RnEnv(..), emptyRnEnv, extendGlobalRnEnv,
25 lubExportFlag, qualNameErr, dupNamesErr
27 import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), ExportsMap(..), RdrIfaceInst )
30 import Bag ( emptyBag, unitBag, consBag, snocBag, unionBags,
31 unionManyBags, mapBag, filterBag, listToBag, bagToList )
32 import CmdLineOpts ( opt_NoImplicitPrelude, opt_CompilingPrelude )
33 import ErrUtils ( Error(..), Warning(..), addErrLoc, addShortErrLocLine, addShortWarnLocLine )
34 import FiniteMap ( emptyFM, addToFM, addListToFM, lookupFM, fmToList, eltsFM, delListFromFM, keysFM{-ToDo:rm-} )
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, ExportFlag(..), OrigName(..)
44 import PrelInfo ( BuiltinNames(..), 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, pprPanic{-ToDo:rm-}, pprTrace{-ToDo:rm-}
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 emptyRnEnv 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 return (all_env, imp_mods, unqual_imps, imp_fixes, all_errs, all_warns) }
114 *********************************************************
116 \subsection{Top-level source names}
118 *********************************************************
123 -> [RdrNameClassDecl]
125 -> RnM_Info s (Bag RnName, -- values
126 Bag RnName) -- tycons/classes
128 getSourceNames ty_decls cls_decls binds
129 = mapAndUnzip3Rn getTyDeclNames ty_decls `thenRn` \ (tycon_s, constrs_s, fields_s) ->
130 mapAndUnzipRn getClassNames cls_decls `thenRn` \ (cls_s, cls_ops_s) ->
131 getTopBindsNames binds `thenRn` \ bind_names ->
132 returnRn (unionManyBags constrs_s `unionBags`
133 unionManyBags fields_s `unionBags`
134 unionManyBags cls_ops_s `unionBags` bind_names,
135 listToBag tycon_s `unionBags` listToBag cls_s)
138 getTyDeclNames :: RdrNameTyDecl
139 -> RnM_Info s (RnName, Bag RnName, Bag RnName) -- tycon, constrs and fields
141 getTyDeclNames (TyData _ tycon _ condecls _ _ src_loc)
142 = --getExtraRn `thenRn` \ ((b_val_names,b_tc_names),b_keys,rec_exp_fn,rec_occ_fn) ->
143 --pprTrace "getTyDeclNames:" (ppr PprDebug tycon) $
144 --pprTrace "getTDN1:" (ppAboves [ ppCat [ppPStr m, ppPStr n] | ((OrigName m n), _) <- fmToList b_tc_names]) $
146 newGlobalName src_loc Nothing False{-not val-} tycon `thenRn` \ tycon_name ->
147 getConFieldNames (Just (nameExportFlag tycon_name)) emptyBag emptyBag emptyFM
148 condecls `thenRn` \ (con_names, field_names) ->
150 rn_tycon = RnData tycon_name con_names field_names
151 rn_constrs = [ RnConstr name tycon_name | name <- con_names]
152 rn_fields = [ RnField name tycon_name | name <- field_names]
154 returnRn (rn_tycon, listToBag rn_constrs, listToBag rn_fields)
156 getTyDeclNames (TyNew _ tycon _ [NewConDecl con _ con_loc] _ _ src_loc)
157 = newGlobalName src_loc Nothing False{-not val-} tycon `thenRn` \ tycon_name ->
158 newGlobalName con_loc (Just (nameExportFlag tycon_name)) True{-val-} con
159 `thenRn` \ con_name ->
160 returnRn (RnData tycon_name [con_name] [],
161 unitBag (RnConstr con_name tycon_name),
164 getTyDeclNames (TySynonym tycon _ _ src_loc)
165 = newGlobalName src_loc Nothing False{-not val-} tycon `thenRn` \ tycon_name ->
166 returnRn (RnSyn tycon_name, emptyBag, emptyBag)
169 getConFieldNames :: Maybe ExportFlag
170 -> Bag Name -> Bag Name
171 -> FiniteMap RdrName ()
173 -> RnM_Info s ([Name], [Name])
175 getConFieldNames exp constrs fields have []
176 = returnRn (bagToList constrs, bagToList fields)
178 getConFieldNames exp constrs fields have (ConDecl con _ src_loc : rest)
179 = newGlobalName src_loc exp True{-val-} con `thenRn` \ con_name ->
180 getConFieldNames exp (constrs `snocBag` con_name) fields have rest
182 getConFieldNames exp constrs fields have (ConOpDecl _ con _ src_loc : rest)
183 = newGlobalName src_loc exp True{-val-} con `thenRn` \ con_name ->
184 getConFieldNames exp (constrs `snocBag` con_name) fields have rest
186 getConFieldNames exp constrs fields have (RecConDecl con fielddecls src_loc : rest)
187 = mapRn (addErrRn . dupFieldErr con src_loc) dups `thenRn_`
188 newGlobalName src_loc exp True{-val-} con `thenRn` \ con_name ->
189 mapRn (newGlobalName src_loc exp True{-val-}) new_fields `thenRn` \ field_names ->
191 all_constrs = constrs `snocBag` con_name
192 all_fields = fields `unionBags` listToBag field_names
194 getConFieldNames exp all_constrs all_fields new_have rest
196 (uniq_fields, dups) = removeDups cmp (concat (map fst fielddecls))
197 new_fields = filter (not . maybeToBool . lookupFM have) uniq_fields
198 new_have = addListToFM have (zip new_fields (repeat ()))
201 getClassNames :: RdrNameClassDecl
202 -> RnM_Info s (RnName, Bag RnName) -- class and class ops
204 getClassNames (ClassDecl _ cname _ sigs _ _ src_loc)
205 = newGlobalName src_loc Nothing False{-notval-} cname `thenRn` \ class_name ->
206 getClassOpNames (Just (nameExportFlag class_name))
207 sigs `thenRn` \ op_names ->
208 returnRn (RnClass class_name op_names,
209 listToBag (map (\ n -> RnClassOp n class_name) op_names))
212 getClassOpNames :: Maybe ExportFlag
216 getClassOpNames exp [] = returnRn []
218 getClassOpNames exp (ClassOpSig op _ _ src_loc : sigs)
219 = newGlobalName src_loc exp True{-val-} op `thenRn` \ op_name ->
220 getClassOpNames exp sigs `thenRn` \ op_names ->
221 returnRn (op_name : op_names)
222 getClassOpNames exp (_ : sigs)
223 = getClassOpNames exp sigs
226 *********************************************************
228 \subsection{Bindings}
230 *********************************************************
233 getTopBindsNames :: RdrNameHsBinds
234 -> RnM_Info s (Bag RnName)
236 getTopBindsNames binds = doBinds binds
238 doBinds EmptyBinds = returnRn emptyBag
239 doBinds (SingleBind bind) = doBind bind
240 doBinds (BindWith bind sigs) = doBind bind
241 doBinds (ThenBinds binds1 binds2)
242 = andRn unionBags (doBinds binds1) (doBinds binds2)
244 doBind EmptyBind = returnRn emptyBag
245 doBind (NonRecBind mbind) = doMBinds mbind
246 doBind (RecBind mbind) = doMBinds mbind
248 doMBinds EmptyMonoBinds = returnRn emptyBag
249 doMBinds (PatMonoBind pat grhss_and_binds locn) = doPat locn pat
250 doMBinds (FunMonoBind p_name _ _ locn) = doName locn p_name
251 doMBinds (AndMonoBinds mbinds1 mbinds2)
252 = andRn unionBags (doMBinds mbinds1) (doMBinds mbinds2)
255 = mapRn (doPat locn) pats `thenRn` \ pats_s ->
256 returnRn (unionManyBags pats_s)
258 doPat locn WildPatIn = returnRn emptyBag
259 doPat locn (LitPatIn _) = returnRn emptyBag
260 doPat locn (LazyPatIn pat) = doPat locn pat
261 doPat locn (VarPatIn var) = doName locn var
262 doPat locn (NegPatIn pat) = doPat locn pat
263 doPat locn (ParPatIn pat) = doPat locn pat
264 doPat locn (ListPatIn pats) = doPats locn pats
265 doPat locn (TuplePatIn pats) = doPats locn pats
266 doPat locn (ConPatIn name pats) = doPats locn pats
267 doPat locn (ConOpPatIn p1 op p2)
268 = andRn unionBags (doPat locn p1) (doPat locn p2)
269 doPat locn (AsPatIn as_name pat)
270 = andRn unionBags (doName locn as_name) (doPat locn pat)
271 doPat locn (RecPatIn name fields)
272 = mapRn (doField locn) fields `thenRn` \ fields_s ->
273 returnRn (unionManyBags fields_s)
275 doField locn (_, pat, _) = doPat locn pat
278 = newGlobalName locn Nothing True{-val-} rdr `thenRn` \ name ->
279 returnRn (unitBag (RnName name))
282 *********************************************************
284 \subsection{Creating a new global name}
286 *********************************************************
289 newGlobalName :: SrcLoc
291 -> Bool{-True<=>value name,False<=>tycon/class-}
295 newGlobalName locn maybe_exp is_val_name (Unqual name)
296 = getExtraRn `thenRn` \ ((b_val_names,b_tc_names),b_keys,rec_exp_fn,rec_occ_fn) ->
297 getModuleRn `thenRn` \ mod ->
298 rnGetUnique `thenRn` \ u ->
300 orig = OrigName mod name
303 = case (lookupFM b_keys orig) of
304 Just (key,_) -> (key, True)
305 Nothing -> if not opt_CompilingPrelude then (u,True) else -- really here just to save gratuitous lookup
306 case (lookupFM (if is_val_name then b_val_names else b_tc_names) orig) of
308 Just xx -> (uniqueOf xx, False{-builtin!-})
310 exp = case maybe_exp of
312 Nothing -> rec_exp_fn n
315 then mkTopLevName uniq orig locn exp (rec_occ_fn n) -- NB: two "n"s
316 else mkWiredInName uniq orig
320 newGlobalName locn maybe_exp is_val_name rdr@(Qual mod name)
321 | opt_CompilingPrelude
322 -- we are actually defining something that compiler knows about (e.g., Bool)
324 = getExtraRn `thenRn` \ ((b_val_names,b_tc_names),b_keys,rec_exp_fn,rec_occ_fn) ->
326 orig = OrigName mod name
329 = case (lookupFM b_keys orig) of
330 Just (key,_) -> (key, True)
331 Nothing -> case (lookupFM (if is_val_name then b_val_names else b_tc_names) orig) of
332 Nothing -> (pprPanic "newGlobalName:Qual:uniq:" (ppr PprDebug rdr), True)
333 Just xx -> (uniqueOf xx, False{-builtin!-})
335 exp = case maybe_exp of
337 Nothing -> rec_exp_fn n
340 then mkTopLevName uniq orig locn exp (rec_occ_fn n) -- NB: two "n"s
341 else mkWiredInName uniq orig
346 = addErrRn (qualNameErr "name in definition" (rdr, locn)) `thenRn_`
347 returnRn (pprPanic "newGlobalName:Qual:" (ppr PprDebug rdr))
350 *********************************************************
352 \subsection{Imported names}
354 *********************************************************
359 FiniteMap OrigName RnName, -- values imported so far
360 FiniteMap OrigName RnName, -- tycons/classes imported so far
361 Name -> (ExportFlag, [SrcLoc])) -- import flag and src locns;
362 -- NB: this last field is in a knot
363 -- and mustn't be tugged on!
365 type RnM_IInfo s r = RnMonad ImportNameInfo s r
367 ------------------------------------------------------------------
370 -> GlobalNameInfo -- builtin and knot name info
372 -> [RdrNameImportDecl] -- import declarations
373 -> IO (Bag (RdrName,RnName), -- imported values in scope
374 Bag (RdrName,RnName), -- imported tycons/classes in scope
375 [Module], -- directly imported modules
376 Bag (Module,RnName), -- unqualified import from module
377 Bag RenamedFixityDecl, -- fixity info for imported names
381 doImportDecls iface_cache g_info us src_imps
382 = fixIO ( \ ~(_, _, _, _, _, _, rec_imp_stuff) ->
384 rec_imp_fm = addListToUFM_C add_stuff emptyUFM (bagToList rec_imp_stuff)
385 add_stuff (imp1,locns1) (imp2,locns2) = (lubExportFlag imp1 imp2, locns1 `unionBags` locns2)
387 rec_imp_fn :: Name -> (ExportFlag, [SrcLoc])
388 rec_imp_fn n = case lookupUFM rec_imp_fm n of
389 Nothing -> panic "RnNames:rec_imp_fn"
390 Just (flag, locns) -> (flag, bagToList locns)
392 i_info = (g_info, emptyFM, emptyFM, rec_imp_fn)
394 -- cache the imported modules
395 -- this ensures that all directly imported modules
396 -- will have their original name iface in scope
397 -- pprTrace "doImportDecls:" (ppCat (map ppPStr imp_mods)) $
398 accumulate (map (cachedIface False iface_cache) imp_mods) >>
400 -- process the imports
401 doImports iface_cache i_info us all_imps
403 ) >>= \ (vals, tcs, unquals, fixes, errs, warns, _) ->
405 return (vals, tcs, imp_mods, unquals, fixes,
406 imp_errs `unionBags` errs,
407 imp_warns `unionBags` warns)
409 the_imps = implicit_prel ++ src_imps
410 all_imps = implicit_qprel ++ the_imps
412 implicit_qprel = ImportDecl gHC_BUILTINS True Nothing Nothing prel_loc
413 : (if opt_NoImplicitPrelude
414 then [{- no "import qualified Prelude" -}]
415 else [ImportDecl pRELUDE True Nothing Nothing prel_loc])
417 explicit_prelude_imp = not (null [ () | (ImportDecl mod qual _ _ _) <- src_imps,
420 implicit_prel = ImportDecl gHC_BUILTINS False Nothing Nothing prel_loc
421 : (if explicit_prelude_imp || opt_NoImplicitPrelude
422 then [{- no "import Prelude" -}]
423 else [ImportDecl pRELUDE False Nothing Nothing prel_loc])
425 prel_loc = mkBuiltinSrcLoc
427 (uniq_imps, imp_dups) = removeDups cmp_mod the_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, mod /= gHC_BUILTINS ]
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') = getBuiltins info mod maybe_spec
519 (if mod == gHC_BUILTINS then
520 return (Succeeded (panic "doImport:GHC fake import!"),
521 \ iface -> ([], [], emptyBag))
523 --pprTrace "doImport:" (ppPStr mod) $
524 cachedIface False iface_cache mod >>= \ maybe_iface ->
525 return (maybe_iface, \ iface -> getOrigIEs iface maybe_spec')
526 ) >>= \ (maybe_iface, do_ies) ->
530 return (emptyBag, emptyBag, emptyBag, emptyBag,
531 unitBag err, emptyBag, emptyBag)
534 (ies, chk_ies, get_errs) = do_ies iface
536 doOrigIEs iface_cache info mod src_loc us ies
537 >>= \ (ie_vals, ie_tcs, imp_flags, errs, warns) ->
538 accumulate (map (checkOrigIE iface_cache) chk_ies)
539 >>= \ chk_errs_warns ->
541 final_vals = mapBag fst_occ b_vals `unionBags` mapBag pair_occ ie_vals
542 final_tcs = mapBag fst_occ b_tcs `unionBags` mapBag pair_occ ie_tcs
543 final_vals_list = bagToList final_vals
545 (if mod == gHC_BUILTINS then
546 return [ (Nothing, emptyBag) | _ <- final_vals_list ]
548 accumulate (map (getFixityDecl iface_cache . snd) final_vals_list)
549 ) >>= \ fix_maybes_errs ->
551 (chk_errs, chk_warns) = unzip chk_errs_warns
552 (fix_maybes, fix_errs) = unzip fix_maybes_errs
554 unquals = if qual{-ified import-}
556 else mapBag pair_as (ie_vals `unionBags` ie_tcs)
558 final_fixes = listToBag (catMaybes fix_maybes)
560 final_errs = mapBag (\ err -> err mod src_loc) (unionManyBags (get_errs:chk_errs))
561 `unionBags` errs `unionBags` unionManyBags fix_errs
562 final_warns = mapBag (\ warn -> warn mod src_loc) (unionManyBags chk_warns)
564 imp_stuff = mapBag (\ (n,imp) -> (n,(imp,unitBag src_loc))) imp_flags
566 return (final_vals, final_tcs, unquals, final_fixes,
567 final_errs, final_warns, imp_stuff)
570 as_mod = case maybe_as of {Nothing -> mod; Just as_this -> as_this}
572 mk_occ :: FAST_STRING -> RdrName
573 mk_occ str = if qual then Qual as_mod str else Unqual str
575 fst_occ :: (FAST_STRING, RnName) -> (RdrName, RnName)
576 fst_occ (str, rn) = (mk_occ str, rn)
578 pair_occ :: RnName -> (RdrName, RnName)
579 pair_occ rn = (mk_occ (getLocalName rn), rn)
581 pair_as :: RnName -> (Module, RnName)
582 pair_as rn = (as_mod, rn)
584 -----------------------------
585 getBuiltins :: ImportNameInfo
587 -> Maybe (Bool, [RdrNameIE])
588 -> (Bag (FAST_STRING, RnName),
589 Bag (FAST_STRING, RnName),
590 Maybe (Bool, [RdrNameIE]) -- return IEs that had no effect
593 getBuiltins _ modname maybe_spec
594 | modname `notElem` modulesWithBuiltins
595 = (emptyBag, emptyBag, maybe_spec)
597 getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) modname maybe_spec
599 Nothing -> (all_vals, all_tcs, Nothing)
601 Just (True, ies) -> -- hiding does not work for builtin names
602 trace "NOTE: `import Prelude hiding ...' does not hide built-in names" $
603 (all_vals, all_tcs, maybe_spec)
605 Just (False, ies) -> let
606 (vals,tcs,ies_left) = do_builtin ies
608 (vals, tcs, Just (False, ies_left))
610 all_vals = do_all_builtin (fmToList b_val_names)
611 all_tcs = do_all_builtin (fmToList b_tc_names)
613 do_all_builtin [] = emptyBag
614 do_all_builtin (((OrigName mod str),rn):rest)
615 = --pprTrace "do_all_builtin:" (ppCat [ppPStr modname, ppPStr mod, ppPStr str]) $
616 (if mod == modname then consBag (str, rn) else id) (do_all_builtin rest)
618 do_builtin [] = (emptyBag,emptyBag,[])
622 = case (ie_name ie) of
623 Unqual s -> (s, OrigName modname s)
624 Qual m s -> pprTrace "do_builtin:surprising qual!" (ppCat [ppPStr m, ppPStr s]) $
625 (s, OrigName modname s)
627 case (lookupFM b_tc_names orig) of -- NB: we favour the tycon/class FM...
628 Just rn -> case (ie,rn) of
629 (IEThingAbs _, WiredInTyCon tc)
630 -> (vals, (str, rn) `consBag` tcs, ies_left)
631 (IEThingAll _, WiredInTyCon tc)
632 -> (listToBag (map (\ id -> (getLocalName id, WiredInId id))
635 (str,rn) `consBag` tcs, ies_left)
636 (IEThingWith _ _, WiredInTyCon tc) -- No checking of With...
637 -> (listToBag (map (\ id -> (nameOf (origName "IEThingWith" id), WiredInId id))
640 (str,rn) `consBag` tcs, ies_left)
641 _ -> panic "importing builtin names (1)"
644 case (lookupFM b_val_names orig) of
645 Nothing -> (vals, tcs, ie:ies_left)
646 Just rn -> case (ie,rn) of
647 (IEVar _, WiredInId _)
648 -> ((str, rn) `consBag` vals, tcs, ies_left)
649 _ -> panic "importing builtin names (2)"
651 (vals, tcs, ies_left) = do_builtin ies
653 -------------------------
654 getOrigIEs :: ParsedIface
655 -> Maybe (Bool, [RdrNameIE]) -- "hiding" or not, blah, blah, blah
657 [(IE OrigName, ExportFlag)],
658 Bag (Module -> SrcLoc -> Error))
660 getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) Nothing -- import all
661 = (map mkAllIE (eltsFM exps), [], emptyBag)
663 getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) (Just (True, ies)) -- import hiding
664 = (map mkAllIE (eltsFM exps_left), found_ies, errs)
666 (found_ies, errs) = lookupIEs exps ies
667 exps_left = delListFromFM exps (map (getLocalName.ie_name.fst) found_ies)
669 getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) (Just (False, ies)) -- import these
670 = (map fst found_ies, found_ies, errs)
672 (found_ies, errs) = lookupIEs exps ies
674 ------------------------------------------------
675 mkAllIE :: (OrigName, ExportFlag) -> IE OrigName
677 mkAllIE (orig,ExportAbs)
678 = ASSERT(isLexCon (nameOf orig))
680 mkAllIE (orig, ExportAll)
681 | isLexCon (nameOf orig)
687 lookupIEs :: ExportsMap
689 -> ([(IE OrigName, ExportFlag)], -- IEs we found, orig-ified
690 Bag (Module -> SrcLoc -> Error))
693 = foldr go ([], emptyBag) ies
695 go ie (already, errs)
697 str = case (ie_name ie) of
701 case (lookupFM exps str) of
703 (already, unknownImpSpecErr ie `consBag` errs)
705 ((orig_ie orig ie, flag) : already,
706 adderr_if (seen_ie orig already) (duplicateImpSpecErr ie) errs)
708 orig_ie orig (IEVar n) = IEVar orig
709 orig_ie orig (IEThingAbs n) = IEThingAbs orig
710 orig_ie orig (IEThingAll n) = IEThingAll orig
711 orig_ie orig (IEThingWith n ns) = IEThingWith orig (map re_orig ns)
713 (OrigName mod _) = orig
714 re_orig (Unqual s) = OrigName mod s
716 seen_ie orig seen_ies = any (\ (ie,_) -> orig == ie_name ie) seen_ies
718 --------------------------------------------
719 doOrigIEs iface_cache info mod src_loc us []
720 = return (emptyBag,emptyBag,emptyBag,emptyBag,emptyBag)
722 doOrigIEs iface_cache info mod src_loc us (ie:ies)
724 (us1, us2) = splitUniqSupply us
726 doOrigIE iface_cache info mod src_loc us1 ie
727 >>= \ (vals1, tcs1, imps1, errs1, warns1) ->
728 doOrigIEs iface_cache info mod src_loc us2 ies
729 >>= \ (vals2, tcs2, imps2, errs2, warns2) ->
730 return (vals1 `unionBags` vals2,
731 tcs1 `unionBags` tcs2,
732 imps1 `unionBags` imps2,
733 errs1 `unionBags` errs2,
734 warns1 `unionBags` warns2)
736 ----------------------
737 doOrigIE :: IfaceCache
743 -> IO (Bag RnName, -- values
744 Bag RnName, -- tycons/classes
745 Bag (RnName,ExportFlag), -- import flags
749 doOrigIE iface_cache info mod src_loc us ie
750 = with_decl iface_cache (ie_name ie)
751 (\ err -> (emptyBag, emptyBag, emptyBag, unitBag err, emptyBag))
752 (\ decl -> case initRn True mod emptyRnEnv us
754 pushSrcLocRn src_loc $
755 getIfaceDeclNames ie decl)
757 ((vals, tcs, imps), errs, warns) -> (vals, tcs, imps, errs, warns))
759 -------------------------
760 checkOrigIE :: IfaceCache
761 -> (IE OrigName, ExportFlag)
762 -> IO (Bag (Module -> SrcLoc -> Error), Bag (Module -> SrcLoc -> Warning))
764 checkOrigIE iface_cache (IEThingAll n, ExportAbs)
765 = with_decl iface_cache n
766 (\ err -> (unitBag (\ mod locn -> err), emptyBag))
767 (\ decl -> case decl of
768 TypeSig _ _ _ -> (emptyBag, unitBag (allWhenSynImpSpecWarn n))
769 other -> (unitBag (allWhenAbsImpSpecErr n), emptyBag))
771 checkOrigIE iface_cache (IEThingWith n ns, ExportAbs)
772 = return (unitBag (withWhenAbsImpSpecErr n), emptyBag)
774 checkOrigIE iface_cache (IEThingWith n ns, ExportAll)
775 = with_decl iface_cache n
776 (\ err -> (unitBag (\ mod locn -> err), emptyBag))
777 (\ decl -> case decl of
778 NewTypeSig _ con _ _ -> (check_with "constructors" [con] ns, emptyBag)
779 DataSig _ cons fields _ _ -> (check_with "constructors (and fields)" (cons++fields) ns, emptyBag)
780 ClassSig _ ops _ _ -> (check_with "class ops" ops ns, emptyBag))
782 check_with str has origs
783 | sortLt (<) (map getLocalName has) == sortLt (<) (map nameOf origs)
786 = unitBag (withImpSpecErr str n has origs)
788 checkOrigIE iface_cache other
789 = return (emptyBag, emptyBag)
791 -----------------------
792 with_decl :: IfaceCache
794 -> (Error -> something) -- if an error...
795 -> (RdrIfaceDecl -> something) -- if OK...
798 with_decl iface_cache n do_err do_decl
799 = cachedDecl iface_cache (isLexCon (nameOf n)) n >>= \ maybe_decl ->
801 Failed err -> return (do_err err)
802 Succeeded decl -> return (do_decl decl)
805 getFixityDecl :: IfaceCache
807 -> IO (Maybe RenamedFixityDecl, Bag Error)
809 getFixityDecl iface_cache rn
811 (OrigName mod str) = origName "getFixityDecl" rn
813 succeeded infx i = return (Just (infx rn i), emptyBag)
815 cachedIface True iface_cache mod >>= \ maybe_iface ->
818 return (Nothing, unitBag err)
819 Succeeded (ParsedIface _ _ _ _ _ _ _ _ fixes _ _ _ _) ->
820 case lookupFM fixes str of
821 Nothing -> return (Nothing, emptyBag)
822 Just (InfixL _ i) -> succeeded InfixL i
823 Just (InfixR _ i) -> succeeded InfixR i
824 Just (InfixN _ i) -> succeeded InfixN i
826 ie_name (IEVar n) = n
827 ie_name (IEThingAbs n) = n
828 ie_name (IEThingAll n) = n
829 ie_name (IEThingWith n _) = n
831 adderr_if True err errs = err `consBag` errs
832 adderr_if False err errs = errs
835 *********************************************************
837 \subsection{Actually creating the imported names}
839 *********************************************************
842 getIfaceDeclNames :: IE OrigName -> RdrIfaceDecl
843 -> RnM_IInfo s (Bag RnName, -- values
844 Bag RnName, -- tycons/classes
845 Bag (RnName,ExportFlag)) -- import flags
847 getIfaceDeclNames ie (ValSig val src_loc _)
848 = newImportedName False src_loc Nothing Nothing val `thenRn` \ val_name ->
849 returnRn (unitBag (RnName val_name),
851 unitBag (RnName val_name, ExportAll))
853 getIfaceDeclNames ie (TypeSig tycon src_loc _)
854 = newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name ->
856 unitBag (RnSyn tycon_name),
857 unitBag (RnSyn tycon_name, ExportAll))
859 getIfaceDeclNames ie (NewTypeSig tycon con src_loc _)
860 = newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name ->
861 newImportedName False src_loc (Just (nameExportFlag tycon_name))
862 (Just (nameImportFlag tycon_name))
863 con `thenRn` \ con_name ->
864 returnRn (if imp_all (imp_flag ie) then
865 unitBag (RnConstr con_name tycon_name)
868 unitBag (RnData tycon_name [con_name] []),
869 unitBag (RnData tycon_name [con_name] [], imp_flag ie))
871 getIfaceDeclNames ie (DataSig tycon cons fields src_loc _)
872 = newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name ->
874 map_me = mapRn (newImportedName False src_loc
875 (Just (nameExportFlag tycon_name))
876 (Just (nameImportFlag tycon_name)))
878 map_me cons `thenRn` \ con_names ->
879 map_me fields `thenRn` \ field_names ->
881 rn_tycon = RnData tycon_name con_names field_names
882 rn_constrs = [ RnConstr name tycon_name | name <- con_names ]
883 rn_fields = [ RnField name tycon_name | name <- field_names ]
885 returnRn (if imp_all (imp_flag ie) then
886 listToBag rn_constrs `unionBags` listToBag rn_fields
890 unitBag (rn_tycon, imp_flag ie))
892 getIfaceDeclNames ie (ClassSig cls ops src_loc _)
893 = newImportedName True src_loc Nothing Nothing cls `thenRn` \ cls_name ->
894 mapRn (newImportedName False src_loc (Just (nameExportFlag cls_name))
895 (Just (nameImportFlag cls_name)))
896 ops `thenRn` \ op_names ->
897 returnRn (if imp_all (imp_flag ie) then
898 listToBag (map (\ n -> RnClassOp n cls_name) op_names)
901 unitBag (RnClass cls_name op_names),
902 unitBag (RnClass cls_name op_names, imp_flag ie))
905 imp_all ExportAll = True
908 imp_flag (IEThingAbs _) = ExportAbs
909 imp_flag (IEThingAll _) = ExportAll
910 imp_flag (IEThingWith _ _) = ExportAll
913 *********************************************************
915 \subsection{Creating a new imported name}
917 *********************************************************
920 newImportedName :: Bool -- True => tycon or class
922 -> Maybe ExportFlag -- maybe export flag
923 -> Maybe ExportFlag -- maybe import flag
924 -> RdrName -- orig name
927 newImportedName tycon_or_class locn maybe_exp maybe_imp rdr
929 orig = qualToOrigName rdr
931 getExtraRn `thenRn` \ ((_,b_keys,rec_exp_fn,rec_occ_fn),done_vals,done_tcs,rec_imp_fn) ->
932 case ((if tycon_or_class
933 then lookupFM done_tcs
934 else lookupFM done_vals) orig) of
936 Just rn -> returnRn (getName rn)
938 rnGetUnique `thenRn` \ u ->
940 uniq = case lookupFM b_keys orig of
944 exp = case maybe_exp of
946 Nothing -> rec_exp_fn n
948 imp = case maybe_imp of
952 (imp_flag, imp_locs) = rec_imp_fn n
954 n = mkImportedName uniq orig imp locn imp_locs exp (rec_occ_fn n) -- NB: two "n"s
960 globalDupNamesErr rdr rns sty
961 = ppAboves (message : map pp_dup rns)
963 message = ppBesides [ppStr "multiple declarations of `", pprNonSym sty rdr, ppStr "'"]
965 pp_dup rn = addShortErrLocLine (get_loc rn) (\ sty ->
966 ppCat [pp_descrip rn, pprNonSym sty rn]) sty
968 get_loc rn = case getImpLocs rn of
972 pp_descrip (RnName _) = ppStr "as a value:"
973 pp_descrip (RnSyn _) = ppStr "as a type synonym:"
974 pp_descrip (RnData _ _ _) = ppStr "as a data type:"
975 pp_descrip (RnConstr _ _) = ppStr "as a data constructor:"
976 pp_descrip (RnField _ _) = ppStr "as a record field:"
977 pp_descrip (RnClass _ _) = ppStr "as a class:"
978 pp_descrip (RnClassOp _ _) = ppStr "as a class method:"
981 dupImportWarn (ImportDecl m1 _ _ _ locn1 : dup_imps) sty
982 = ppAboves (item1 : map dup_item dup_imps)
984 item1 = addShortWarnLocLine locn1 (\ sty ->
985 ppCat [ppStr "multiple imports from module", ppPStr m1]) sty
987 dup_item (ImportDecl m _ _ _ locn)
988 = addShortWarnLocLine locn (\ sty ->
989 ppCat [ppStr "here was another import from module", ppPStr m]) sty
991 qualPreludeImportWarn (ImportDecl m _ _ _ locn)
992 = addShortWarnLocLine locn (\ sty ->
993 ppCat [ppStr "qualified import of prelude module", ppPStr m])
995 dupQualImportErr ((q1,ImportDecl _ _ _ _ locn1):dup_quals) sty
996 = ppAboves (item1 : map dup_item dup_quals)
998 item1 = addShortErrLocLine locn1 (\ sty ->
999 ppCat [ppStr "multiple imports (from different modules) with same qualified name", ppPStr q1]) sty
1001 dup_item (q,ImportDecl _ _ _ _ locn)
1002 = addShortErrLocLine locn (\ sty ->
1003 ppCat [ppStr "here was another import with qualified name", ppPStr q]) sty
1005 unknownImpSpecErr ie imp_mod locn
1006 = addShortErrLocLine locn (\ sty ->
1007 ppBesides [ppStr "module ", ppPStr imp_mod, ppStr " does not export `", ppr sty (ie_name ie), ppStr "'"])
1009 duplicateImpSpecErr ie imp_mod locn
1010 = addShortErrLocLine locn (\ sty ->
1011 ppBesides [ppStr "`", ppr sty (ie_name ie), ppStr "' already seen in import list"])
1013 allWhenSynImpSpecWarn n imp_mod locn
1014 = addShortWarnLocLine locn (\ sty ->
1015 ppBesides [ppStr "type synonym `", ppr sty n, ppStr "' should not be imported with (..)"])
1017 allWhenAbsImpSpecErr n imp_mod locn
1018 = addShortErrLocLine locn (\ sty ->
1019 ppBesides [ppStr "module ", ppPStr imp_mod, ppStr " only exports `", ppr sty n, ppStr "' abstractly"])
1021 withWhenAbsImpSpecErr n imp_mod locn
1022 = addShortErrLocLine locn (\ sty ->
1023 ppBesides [ppStr "module ", ppPStr imp_mod, ppStr " only exports `", ppr sty n, ppStr "' abstractly"])
1025 withImpSpecErr str n has ns imp_mod locn
1026 = addErrLoc locn "" (\ sty ->
1027 ppAboves [ ppBesides [ppStr "inconsistent list of", ppStr str, ppStr "in import list for `", ppr sty n, ppStr "'"],
1028 ppCat [ppStr " expected:", ppInterleave ppComma (map (ppr sty) has)],
1029 ppCat [ppStr " found: ", ppInterleave ppComma (map (ppr sty) ns)] ])
1031 dupFieldErr con locn (dup:rest)
1032 = addShortErrLocLine locn (\ sty ->
1033 ppBesides [ppStr "record field `", ppr sty dup, ppStr "declared multiple times in `", ppr sty con, ppStr "'"])