X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnNames.lhs;h=53d04e1d0808c7ba50704aca292685be829a31bc;hb=68afb16743cafd5b7495771d359891c6dfc5a186;hp=2d1329b08668aa6f9664673817c8161d670ae1d9;hpb=1ffb620ae1457b2e3eb5e415a999a4f6f15fec45;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 2d1329b..53d04e1 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -22,30 +22,31 @@ import RnHsSyn import RnMonad import RnIfaces ( IfaceCache(..), cachedIface, cachedDecl ) import RnUtils ( RnEnv(..), emptyRnEnv, extendGlobalRnEnv, - lubExportFlag, qualNameErr, dupNamesErr ) + lubExportFlag, qualNameErr, dupNamesErr, negateNameWarn ) import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst ) -import Bag ( emptyBag, unitBag, consBag, unionBags, unionManyBags, - mapBag, listToBag, bagToList ) +import Bag ( emptyBag, unitBag, consBag, snocBag, unionBags, + unionManyBags, mapBag, filterBag, listToBag, bagToList ) import CmdLineOpts ( opt_NoImplicitPrelude ) -import ErrUtils ( Error(..), Warning(..), addShortErrLocLine ) +import ErrUtils ( Error(..), Warning(..), addErrLoc, addShortErrLocLine ) import FiniteMap ( emptyFM, addListToFM, lookupFM, fmToList, eltsFM, delListFromFM ) import Id ( GenId ) import Maybes ( maybeToBool, catMaybes, MaybeErr(..) ) -import Name ( RdrName(..), Name, isQual, mkTopLevName, +import Name ( RdrName(..), Name, isQual, mkTopLevName, origName, mkImportedName, nameExportFlag, nameImportFlag, - getLocalName, getSrcLoc, pprNonSym, moduleNamePair, - isLexCon, isRdrLexCon, ExportFlag(..) + getLocalName, getSrcLoc, getImpLocs, moduleNamePair, + pprNonSym, isLexCon, isRdrLexCon, ExportFlag(..) ) import PrelInfo ( BuiltinNames(..), BuiltinKeys(..) ) import PrelMods ( fromPrelude, pRELUDE ) import Pretty -import SrcLoc ( SrcLoc, mkIfaceSrcLoc ) +import SrcLoc ( SrcLoc, mkBuiltinSrcLoc ) import TyCon ( tyConDataCons ) import UniqFM ( emptyUFM, addListToUFM_C, lookupUFM ) import UniqSupply ( splitUniqSupply ) -import Util ( isIn, cmpPString, sortLt, removeDups, equivClasses, panic, assertPanic ) +import Util ( isIn, assoc, cmpPString, sortLt, removeDups, + equivClasses, panic, assertPanic ) \end{code} @@ -80,17 +81,20 @@ getGlobalNames iface_cache info us \ (imp_vals, imp_tcs, imp_mods, unqual_imps, imp_fixes, imp_errs, imp_warns) -> let - unqual_vals = mapBag (\rn -> (Unqual (getLocalName rn), rn)) src_vals - unqual_tcs = mapBag (\rn -> (Unqual (getLocalName rn), rn)) src_tcs + unqual_vals = map (\rn -> (Unqual (getLocalName rn), rn)) (bagToList src_vals) + unqual_tcs = map (\rn -> (Unqual (getLocalName rn), rn)) (bagToList src_tcs) - all_vals = bagToList (unqual_vals `unionBags` imp_vals) - all_tcs = bagToList (unqual_tcs `unionBags` imp_tcs) + (src_env, src_dups) = extendGlobalRnEnv emptyRnEnv unqual_vals unqual_tcs + (all_env, imp_dups) = extendGlobalRnEnv src_env (bagToList imp_vals) (bagToList imp_tcs) - (all_env, dups) = extendGlobalRnEnv emptyRnEnv all_vals all_tcs + -- remove dups of the same imported thing + diff_imp_dups = filterBag diff_orig imp_dups + diff_orig (_,rn1,rn2) = origName rn1 /= origName rn2 - dup_errs = map dup_err (equivClasses cmp_rdr (bagToList dups)) + all_dups = bagToList (src_dups `unionBags` diff_imp_dups) + dup_errs = map dup_err (equivClasses cmp_rdr all_dups) cmp_rdr (rdr1,_,_) (rdr2,_,_) = cmp rdr1 rdr2 - dup_err ((rdr,rn,rn'):rest) = globalDupNamesErr rdr (rn:rn': [rn|(_,_,rn)<-rest]) + dup_err ((rdr,rn1,rn2):rest) = globalDupNamesErr rdr (rn1:rn2: [rn|(_,_,rn)<-rest]) all_errs = src_errs `unionBags` imp_errs `unionBags` listToBag dup_errs all_warns = src_warns `unionBags` imp_warns @@ -116,45 +120,66 @@ getSourceNames :: Bag RnName) -- tycons/classes getSourceNames ty_decls cls_decls binds - = mapAndUnzipRn getTyDeclNames ty_decls `thenRn` \ (tycon_s, constrs_s) -> - mapAndUnzipRn getClassNames cls_decls `thenRn` \ (cls_s, cls_ops_s) -> - getTopBindsNames binds `thenRn` \ bind_names -> + = mapAndUnzip3Rn getTyDeclNames ty_decls `thenRn` \ (tycon_s, constrs_s, fields_s) -> + mapAndUnzipRn getClassNames cls_decls `thenRn` \ (cls_s, cls_ops_s) -> + getTopBindsNames binds `thenRn` \ bind_names -> returnRn (unionManyBags constrs_s `unionBags` + unionManyBags fields_s `unionBags` unionManyBags cls_ops_s `unionBags` bind_names, listToBag tycon_s `unionBags` listToBag cls_s) getTyDeclNames :: RdrNameTyDecl - -> RnM_Info s (RnName, Bag RnName) -- tycon and constrs + -> RnM_Info s (RnName, Bag RnName, Bag RnName) -- tycon, constrs and fields getTyDeclNames (TyData _ tycon _ condecls _ _ src_loc) = newGlobalName src_loc Nothing tycon `thenRn` \ tycon_name -> - mapRn (getConDeclName (Just (nameExportFlag tycon_name))) - condecls `thenRn` \ con_names -> - returnRn (RnData tycon_name con_names, - listToBag (map (\ n -> RnConstr n tycon_name) con_names)) + getConFieldNames (Just (nameExportFlag tycon_name)) emptyBag emptyBag emptyFM + condecls `thenRn` \ (con_names, field_names) -> + let + rn_tycon = RnData tycon_name con_names field_names + rn_constrs = [ RnConstr name tycon_name | name <- con_names] + rn_fields = [ RnField name tycon_name | name <- field_names] + in + returnRn (rn_tycon, listToBag rn_constrs, listToBag rn_fields) -getTyDeclNames (TyNew _ tycon _ condecls _ _ src_loc) +getTyDeclNames (TyNew _ tycon _ [NewConDecl con _ con_loc] _ _ src_loc) = newGlobalName src_loc Nothing tycon `thenRn` \ tycon_name -> - mapRn (getConDeclName (Just (nameExportFlag tycon_name))) - condecls `thenRn` \ con_names -> - returnRn (RnData tycon_name con_names, - listToBag (map (\ n -> RnConstr n tycon_name) con_names)) + newGlobalName con_loc (Just (nameExportFlag tycon_name)) con + `thenRn` \ con_name -> + returnRn (RnData tycon_name [con_name] [], + unitBag (RnConstr con_name tycon_name), + emptyBag) getTyDeclNames (TySynonym tycon _ _ src_loc) = newGlobalName src_loc Nothing tycon `thenRn` \ tycon_name -> - returnRn (RnSyn tycon_name, emptyBag) + returnRn (RnSyn tycon_name, emptyBag, emptyBag) + -getConDeclName exp (ConDecl con _ src_loc) - = newGlobalName src_loc exp con -getConDeclName exp (ConOpDecl _ op _ src_loc) - = newGlobalName src_loc exp op -getConDeclName exp (NewConDecl con _ src_loc) - = newGlobalName src_loc exp con -getConDeclName exp (RecConDecl con fields src_loc) - = panic "getConDeclName:RecConDecl" - newGlobalName src_loc exp con +getConFieldNames exp constrs fields have [] + = returnRn (bagToList constrs, bagToList fields) +getConFieldNames exp constrs fields have (ConDecl con _ src_loc : rest) + = newGlobalName src_loc exp con `thenRn` \ con_name -> + getConFieldNames exp (constrs `snocBag` con_name) fields have rest + +getConFieldNames exp constrs fields have (ConOpDecl _ con _ src_loc : rest) + = newGlobalName src_loc exp con `thenRn` \ con_name -> + getConFieldNames exp (constrs `snocBag` con_name) fields have rest + +getConFieldNames exp constrs fields have (RecConDecl con fielddecls src_loc : rest) + = mapRn (addErrRn . dupFieldErr con src_loc) dups `thenRn_` + newGlobalName src_loc exp con `thenRn` \ con_name -> + mapRn (newGlobalName src_loc exp) new_fields `thenRn` \ field_names -> + let + all_constrs = constrs `snocBag` con_name + all_fields = fields `unionBags` listToBag field_names + in + getConFieldNames exp all_constrs all_fields new_have rest + where + (uniq_fields, dups) = removeDups cmp (concat (map fst fielddecls)) + new_fields = filter (not . maybeToBool . lookupFM have) uniq_fields + new_have = addListToFM have (zip new_fields (repeat ())) getClassNames :: RdrNameClassDecl -> RnM_Info s (RnName, Bag RnName) -- class and class ops @@ -264,8 +289,9 @@ newGlobalName locn maybe_exp rdr Just exp -> exp Nothing -> exp_fn n - n = mkTopLevName uniq orig locn exp (occ_fn n) + n = mkTopLevName uniq orig locn exp (occ_fn n) -- NB: two "n"s in + addWarnIfRn (rdr == Unqual SLIT("negate")) (negateNameWarn (rdr, locn)) `thenRn_` addErrIfRn (isQual rdr) (qualNameErr "name in definition" (rdr, locn)) `thenRn_` returnRn n \end{code} @@ -280,7 +306,7 @@ newGlobalName locn maybe_exp rdr type ImportNameInfo = (GlobalNameInfo, FiniteMap (Module,FAST_STRING) RnName, -- values imported so far FiniteMap (Module,FAST_STRING) RnName, -- tycons/classes imported so far - Name -> ExportFlag) -- import flag + Name -> (ExportFlag, [SrcLoc])) -- import flag and src locns type RnM_IInfo s r = RnMonad ImportNameInfo s r @@ -298,45 +324,60 @@ doImportDecls :: Bag Warning) doImportDecls iface_cache g_info us src_imps - = fixIO ( \ ~(_, _, _, _, _, _, rec_imp_flags) -> + = fixIO ( \ ~(_, _, _, _, _, _, rec_imp_stuff) -> let - rec_imp_fm = addListToUFM_C lubExportFlag emptyUFM (bagToList rec_imp_flags) + rec_imp_fm = addListToUFM_C add_stuff emptyUFM (bagToList rec_imp_stuff) + add_stuff (imp1,locns1) (imp2,locns2) = (lubExportFlag imp1 imp2, locns1 `unionBags` locns2) - rec_imp_fn :: Name -> ExportFlag + rec_imp_fn :: Name -> (ExportFlag, [SrcLoc]) rec_imp_fn n = case lookupUFM rec_imp_fm n of - Nothing -> panic "RnNames:rec_imp_fn" - Just flag -> flag + Nothing -> panic "RnNames:rec_imp_fn" + Just (flag, locns) -> (flag, bagToList locns) i_info = (g_info, emptyFM, emptyFM, rec_imp_fn) in - doImports iface_cache i_info us (qprel_imp ++ prel_imp ++ src_imps) + -- cache the imported modules + -- this ensures that all directly imported modules + -- will have their original name iface in scope + accumulate (map (cachedIface False iface_cache) imp_mods) >> + + -- process the imports + doImports iface_cache i_info us all_imps + ) >>= \ (vals, tcs, unquals, fixes, errs, warns, _) -> - let - imp_mods = [ mod | ImportDecl mod _ _ _ _ <- src_imps ] - imp_warns = listToBag (map dupImportWarn imp_dups) - prel_warns = listToBag (map qualPreludeImportWarn qual_prels) - - (_, imp_dups) = removeDups cmp_mod src_imps - cmp_mod (ImportDecl m1 _ _ _ _) (ImportDecl m2 _ _ _ _) = cmpPString m1 m2 - qual_prels = [imp | imp@(ImportDecl mod qual _ _ _) <- src_imps, - fromPrelude mod && qual] - in - return (vals, tcs, imp_mods, unquals, fixes, errs, - prel_warns `unionBags` imp_warns `unionBags` warns) + + return (vals, tcs, imp_mods, unquals, fixes, + errs, imp_warns `unionBags` warns) where - explicit_prelude_import - = null [() | (ImportDecl mod qual _ _ _) <- src_imps, - fromPrelude mod && not qual] + the_imps = implicit_prel ++ src_imps + all_imps = implicit_qprel ++ the_imps + + implicit_qprel = if opt_NoImplicitPrelude + then [{- no "import qualified Prelude" -}] + else [ImportDecl pRELUDE True Nothing Nothing prel_loc] + + explicit_prelude_imp = not (null [ () | (ImportDecl mod qual _ _ _) <- src_imps, + mod == pRELUDE ]) + + implicit_prel = if explicit_prelude_imp || opt_NoImplicitPrelude + then [{- no "import Prelude" -}] + else [ImportDecl pRELUDE False Nothing Nothing prel_loc] + + prel_imps -- WDP: Just guessing on this defn... ToDo + = [ imp | imp@(ImportDecl mod _ _ _ _) <- the_imps, fromPrelude mod ] + + prel_loc = mkBuiltinSrcLoc - qprel_imp = if opt_NoImplicitPrelude - then [{-the flag really means it: *NO* implicit "import Prelude" -}] - else [ImportDecl pRELUDE True Nothing Nothing mkIfaceSrcLoc] + (uniq_imps, imp_dups) = removeDups cmp_mod the_imps + cmp_mod (ImportDecl m1 _ _ _ _) (ImportDecl m2 _ _ _ _) = cmpPString m1 m2 + + qprel_imps = [ imp | imp@(ImportDecl mod True Nothing _ _) <- prel_imps ] + + imp_mods = [ mod | ImportDecl mod _ _ _ _ <- uniq_imps ] + imp_warns = listToBag (map dupImportWarn imp_dups) + `unionBags` + listToBag (map qualPreludeImportWarn qprel_imps) - prel_imp = if not explicit_prelude_import || opt_NoImplicitPrelude - then - [ {-prelude imported explicitly => no import Prelude-} ] - else - [ImportDecl pRELUDE False Nothing Nothing mkIfaceSrcLoc] doImports iface_cache i_info us [] = return (emptyBag, emptyBag, emptyBag, emptyBag, emptyBag, emptyBag, emptyBag) @@ -370,16 +411,16 @@ doImport :: IfaceCache -> ImportNameInfo -> UniqSupply -> RdrNameImportDecl - -> IO (Bag (RdrName,RnName), -- values - Bag (RdrName,RnName), -- tycons/classes - Bag (Module,RnName), -- unqual imports + -> IO (Bag (RdrName,RnName), -- values + Bag (RdrName,RnName), -- tycons/classes + Bag (Module,RnName), -- unqual imports Bag RenamedFixityDecl, Bag Error, Bag Warning, - Bag (RnName,ExportFlag)) -- import flags + Bag (RnName,(ExportFlag,Bag SrcLoc))) -- import flags and src locs doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc) - = cachedIface iface_cache mod >>= \ maybe_iface -> + = cachedIface False iface_cache mod >>= \ maybe_iface -> case maybe_iface of Failed err -> return (emptyBag, emptyBag, emptyBag, emptyBag, @@ -393,15 +434,16 @@ doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc) >>= \ (ie_vals, ie_tcs, imp_flags, errs, warns) -> accumulate (map (checkOrigIE iface_cache) chk_ies) >>= \ chk_errs_warns -> - accumulate (map (getFixityDecl iface_cache) (bagToList ie_vals)) + let + final_vals = mapBag fst_occ b_vals `unionBags` mapBag pair_occ ie_vals + final_tcs = mapBag fst_occ b_tcs `unionBags` mapBag pair_occ ie_tcs + in + accumulate (map (getFixityDecl iface_cache) (bagToList final_vals)) >>= \ fix_maybes_errs -> let (chk_errs, chk_warns) = unzip chk_errs_warns (fix_maybes, fix_errs) = unzip fix_maybes_errs - final_vals = mapBag fst_occ b_vals `unionBags` mapBag pair_occ ie_vals - final_tcs = mapBag fst_occ b_tcs `unionBags` mapBag pair_occ ie_tcs - unquals = if qual then emptyBag else mapBag pair_as (ie_vals `unionBags` ie_tcs) @@ -411,9 +453,10 @@ doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc) `unionBags` errs `unionBags` unionManyBags fix_errs final_warns = mapBag (\ warn -> warn mod src_loc) (unionManyBags chk_warns) `unionBags` warns + imp_stuff = mapBag (\ (n,imp) -> (n,(imp,unitBag src_loc))) imp_flags in return (final_vals, final_tcs, unquals, final_fixes, - final_errs, final_warns, imp_flags) + final_errs, final_warns, imp_stuff) where as_mod = case maybe_as of {Nothing -> mod; Just as_this -> as_this} mk_occ str = if qual then Qual as_mod str else Unqual str @@ -423,7 +466,7 @@ doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc) pair_as rn = (as_mod, rn) -getBuiltins info mod maybe_spec +getBuiltins _ mod maybe_spec | not (fromPrelude mod) = (emptyBag, emptyBag, maybe_spec) @@ -472,16 +515,16 @@ getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) mod maybe_spec (vals, tcs, ies_left) = do_builtin ies -getOrigIEs (ParsedIface _ _ _ _ exps _ _ _ _ _ _) Nothing -- import all +getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) Nothing -- import all = (map mkAllIE (eltsFM exps), [], emptyBag) -getOrigIEs (ParsedIface _ _ _ _ exps _ _ _ _ _ _) (Just (True, ies)) -- import hiding +getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) (Just (True, ies)) -- import hiding = (map mkAllIE (eltsFM exps_left), found_ies, errs) where (found_ies, errs) = lookupIEs exps ies exps_left = delListFromFM exps (map (getLocalName.ie_name.fst) found_ies) -getOrigNames (ParsedIface _ _ _ _ exps _ _ _ _ _ _) (Just (False, ies)) +getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) (Just (False, ies)) -- import these = (map fst found_ies, found_ies, errs) where (found_ies, errs) = lookupIEs exps ies @@ -522,14 +565,14 @@ doOrigIEs iface_cache info mod src_loc us [] doOrigIEs iface_cache info mod src_loc us (ie:ies) = doOrigIE iface_cache info mod src_loc us1 ie - >>= \ (vals1, tcs1, errs1, warns1, imps1) -> + >>= \ (vals1, tcs1, imps1, errs1, warns1) -> doOrigIEs iface_cache info mod src_loc us2 ies - >>= \ (vals2, tcs2, errs2, warns2, imps2) -> + >>= \ (vals2, tcs2, imps2, errs2, warns2) -> return (vals1 `unionBags` vals2, tcs1 `unionBags` tcs2, + imps1 `unionBags` imps2, errs1 `unionBags` errs2, - warns1 `unionBags` warns2, - imps1 `unionBags` imps2) + warns1 `unionBags` warns2) where (us1, us2) = splitUniqSupply us @@ -557,9 +600,9 @@ checkOrigIE iface_cache (IEThingWith n ns, ExportAll) = with_decl iface_cache n (\ err -> (unitBag (\ mod locn -> err), emptyBag)) (\ decl -> case decl of - NewTypeSig _ con _ _ -> (check_with "constructrs" [con] ns, emptyBag) - DataSig _ cons _ _ -> (check_with "constructrs" cons ns, emptyBag) - ClassSig _ ops _ _ -> (check_with "class ops" ops ns, emptyBag)) + NewTypeSig _ con _ _ -> (check_with "constructrs" [con] ns, emptyBag) + DataSig _ cons fields _ _ -> (check_with "constructrs (and fields)" (cons++fields) ns, emptyBag) + ClassSig _ ops _ _ -> (check_with "class ops" ops ns, emptyBag)) where check_with str has rdrs | sortLt (<) (map getLocalName has) == sortLt (<) (map unqual_str rdrs) @@ -578,15 +621,15 @@ with_decl iface_cache n do_err do_decl Succeeded decl -> return (do_decl decl) -getFixityDecl iface_cache rn +getFixityDecl iface_cache (_,rn) = let (mod, str) = moduleNamePair rn in - cachedIface iface_cache mod >>= \ maybe_iface -> + cachedIface True iface_cache mod >>= \ maybe_iface -> case maybe_iface of Failed err -> return (Nothing, unitBag err) - Succeeded (ParsedIface _ _ _ _ _ _ fixes _ _ _ _) -> + Succeeded (ParsedIface _ _ _ _ _ _ _ _ fixes _ _ _ _) -> case lookupFM fixes str of Nothing -> return (Nothing, emptyBag) Just (InfixL _ i) -> return (Just (InfixL rn i), emptyBag) @@ -618,40 +661,48 @@ getIfaceDeclNames :: RdrNameIE -> RdrIfaceDecl Bag (RnName,ExportFlag)) -- import flags getIfaceDeclNames ie (ValSig val src_loc _) - = newImportedName False src_loc Nothing Nothing val `thenRn` \ val_name -> + = newImportedName False src_loc Nothing Nothing val `thenRn` \ val_name -> returnRn (unitBag (RnName val_name), emptyBag, unitBag (RnName val_name, ExportAll)) getIfaceDeclNames ie (TypeSig tycon src_loc _) - = newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name -> + = newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name -> returnRn (emptyBag, unitBag (RnSyn tycon_name), unitBag (RnSyn tycon_name, ExportAll)) getIfaceDeclNames ie (NewTypeSig tycon con src_loc _) - = newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name -> - mapRn (newImportedName False src_loc (Just (nameExportFlag tycon_name)) - (Just (nameImportFlag tycon_name))) - [con] `thenRn` \ con_names -> + = newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name -> + newImportedName False src_loc (Just (nameExportFlag tycon_name)) + (Just (nameImportFlag tycon_name)) + con `thenRn` \ con_name -> returnRn (if imp_all (imp_flag ie) then - listToBag (map (\ n -> RnConstr n tycon_name) con_names) + unitBag (RnConstr con_name tycon_name) else emptyBag, - unitBag (RnData tycon_name con_names), - unitBag (RnData tycon_name con_names, imp_flag ie)) + unitBag (RnData tycon_name [con_name] []), + unitBag (RnData tycon_name [con_name] [], imp_flag ie)) -getIfaceDeclNames ie (DataSig tycon cons src_loc _) +getIfaceDeclNames ie (DataSig tycon cons fields src_loc _) = newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name -> mapRn (newImportedName False src_loc (Just (nameExportFlag tycon_name)) (Just (nameImportFlag tycon_name))) cons `thenRn` \ con_names -> + mapRn (newImportedName False src_loc (Just (nameExportFlag tycon_name)) + (Just (nameImportFlag tycon_name))) + fields `thenRn` \ field_names -> + let + rn_tycon = RnData tycon_name con_names field_names + rn_constrs = [ RnConstr name tycon_name | name <- con_names ] + rn_fields = [ RnField name tycon_name | name <- field_names ] + in returnRn (if imp_all (imp_flag ie) then - listToBag (map (\ n -> RnConstr n tycon_name) con_names) + listToBag rn_constrs `unionBags` listToBag rn_fields else emptyBag, - unitBag (RnData tycon_name con_names), - unitBag (RnData tycon_name con_names, imp_flag ie)) + unitBag rn_tycon, + unitBag (rn_tycon, imp_flag ie)) getIfaceDeclNames ie (ClassSig cls ops src_loc _) = newImportedName True src_loc Nothing Nothing cls `thenRn` \ cls_name -> @@ -710,41 +761,78 @@ newImportedName tycon_or_class locn maybe_exp maybe_imp rdr imp = case maybe_imp of Just imp -> imp - Nothing -> imp_fn n + Nothing -> imp_flag + + (imp_flag, imp_locs) = imp_fn n - n = mkImportedName uniq rdr imp locn exp (occ_fn n) + n = mkImportedName uniq rdr imp locn imp_locs exp (occ_fn n) -- NB: two "n"s in returnRn n \end{code} \begin{code} globalDupNamesErr rdr rns sty - = ppHang (ppBesides [pprNonSym sty rdr, ppStr " multiply defined:"]) - 4 (ppAboves (map pp_def rns)) + = ppAboves (message : map pp_dup rns) where - pp_def rn = addShortErrLocLine (getSrcLoc rn) (\ sty -> ppr sty rn) sty - -dupImportWarn dup_imps sty - = ppStr "dupImportWarn" - -qualPreludeImportWarn imp sty - = ppStr "qualPreludeImportWarn" - -unknownImpSpecErr ie imp_mod locn sty - = ppStr "unknownImpSpecErr" - -duplicateImpSpecErr ie imp_mod locn sty - = ppStr "duplicateImpSpecErr" - -allWhenSynImpSpecWarn n imp_mod locn sty - = ppStr "allWhenSynImpSpecWarn" - -allWhenAbsImpSpecErr n imp_mod locn sty - = ppStr "allWhenAbsImpSpecErr" - -withWhenAbsImpSpecErr n imp_mod locn sty - = ppStr "withWhenAbsImpSpecErr" - -withImpSpecErr str n has ns imp_mod locn sty - = ppStr "withImpSpecErr" + message = ppBesides [ppStr "multiple declarations of `", pprNonSym sty rdr, ppStr "'"] + + pp_dup rn = addShortErrLocLine (get_loc rn) (\ sty -> + ppBesides [pp_descrip rn, pprNonSym sty rn]) sty + + get_loc rn = case getImpLocs rn of + [] -> getSrcLoc rn + locs -> head locs + + pp_descrip (RnName _) = ppStr "a value" + pp_descrip (RnSyn _) = ppStr "a type synonym" + pp_descrip (RnData _ _ _) = ppStr "a data type" + pp_descrip (RnConstr _ _) = ppStr "a data constructor" + pp_descrip (RnField _ _) = ppStr "a record field" + pp_descrip (RnClass _ _) = ppStr "a class" + pp_descrip (RnClassOp _ _) = ppStr "a class method" + pp_descrip _ = ppNil + +dupImportWarn (ImportDecl m1 _ _ _ locn1 : dup_imps) sty + = ppAboves (item1 : map dup_item dup_imps) + where + item1 = addShortErrLocLine locn1 (\ sty -> + ppCat [ppStr "multiple imports from module", ppPStr m1]) sty + + dup_item (ImportDecl m _ _ _ locn) + = addShortErrLocLine locn (\ sty -> + ppCat [ppStr "here was another import from module", ppPStr m]) sty + +qualPreludeImportWarn (ImportDecl m _ _ _ locn) + = addShortErrLocLine locn (\ sty -> + ppCat [ppStr "qualified import of prelude module", ppPStr m]) + +unknownImpSpecErr ie imp_mod locn + = addShortErrLocLine locn (\ sty -> + ppBesides [ppStr "module ", ppPStr imp_mod, ppStr " does not export `", ppr sty (ie_name ie), ppStr "'"]) + +duplicateImpSpecErr ie imp_mod locn + = addShortErrLocLine locn (\ sty -> + ppBesides [ppStr "`", ppr sty (ie_name ie), ppStr "' already seen in import list"]) + +allWhenSynImpSpecWarn n imp_mod locn + = addShortErrLocLine locn (\ sty -> + ppBesides [ppStr "type synonym `", ppr sty n, ppStr "' should not be imported with (..)"]) + +allWhenAbsImpSpecErr n imp_mod locn + = addShortErrLocLine locn (\ sty -> + ppBesides [ppStr "module ", ppPStr imp_mod, ppStr " only exports `", ppr sty n, ppStr "' abstractly"]) + +withWhenAbsImpSpecErr n imp_mod locn + = addShortErrLocLine locn (\ sty -> + ppBesides [ppStr "module ", ppPStr imp_mod, ppStr " only exports `", ppr sty n, ppStr "' abstractly"]) + +withImpSpecErr str n has ns imp_mod locn + = addErrLoc locn "" (\ sty -> + ppAboves [ ppBesides [ppStr "inconsistent list of", ppStr str, ppStr "in import list for `", ppr sty n, ppStr "'"], + ppCat [ppStr " expected:", ppInterleave ppComma (map (ppr sty) has)], + ppCat [ppStr " found: ", ppInterleave ppComma (map (ppr sty) ns)] ]) + +dupFieldErr con locn (dup:rest) + = addShortErrLocLine locn (\ sty -> + ppBesides [ppStr "record field `", ppr sty dup, ppStr "declared multiple times in `", ppr sty con, ppStr "'"]) \end{code}