X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnNames.lhs;h=921cf614f4b6799b71a0e8ae381e2337af5c86b7;hb=30cf375e0bc79a6b71074a5e0fd2ec393241a751;hp=b3a142b02037162ec0564b0d19c7ffa165b018be;hpb=cc051dd76d01b61caae6f4e1fc177c9815716961;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index b3a142b..921cf61 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -22,14 +22,15 @@ import RnHsSyn import RnMonad import RnIfaces ( IfaceCache(..), cachedIface, cachedDecl ) import RnUtils ( RnEnv(..), emptyRnEnv, extendGlobalRnEnv, - lubExportFlag, qualNameErr, dupNamesErr, negateNameWarn ) + lubExportFlag, qualNameErr, dupNamesErr + ) import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst ) import Bag ( emptyBag, unitBag, consBag, snocBag, unionBags, unionManyBags, mapBag, filterBag, listToBag, bagToList ) import CmdLineOpts ( opt_NoImplicitPrelude ) -import ErrUtils ( Error(..), Warning(..), addErrLoc, addShortErrLocLine ) +import ErrUtils ( Error(..), Warning(..), addErrLoc, addShortErrLocLine, addShortWarnLocLine ) import FiniteMap ( emptyFM, addListToFM, lookupFM, fmToList, eltsFM, delListFromFM ) import Id ( GenId ) import Maybes ( maybeToBool, catMaybes, MaybeErr(..) ) @@ -39,7 +40,7 @@ import Name ( RdrName(..), Name, isQual, mkTopLevName, origName, pprNonSym, isLexCon, isRdrLexCon, ExportFlag(..) ) import PrelInfo ( BuiltinNames(..), BuiltinKeys(..) ) -import PrelMods ( fromPrelude, pRELUDE ) +import PrelMods ( fromPrelude, pRELUDE, rATIO, iX ) import Pretty import SrcLoc ( SrcLoc, mkBuiltinSrcLoc ) import TyCon ( tyConDataCons ) @@ -289,9 +290,8 @@ 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} @@ -336,42 +336,63 @@ doImportDecls iface_cache g_info us src_imps i_info = (g_info, emptyFM, emptyFM, rec_imp_fn) in + -- 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, _) -> return (vals, tcs, imp_mods, unquals, fixes, - errs, imp_warns `unionBags` warns) + imp_errs `unionBags` errs, + imp_warns `unionBags` warns) where - (src_qprels, ok_imps) = partition qual_prel src_imps - the_imps = ok_imps ++ prel_imp - all_imps = the_imps ++ qprel_imp + the_imps = implicit_prel ++ src_imps + all_imps = implicit_qprel ++ the_imps - qual_prel (ImportDecl mod qual imp_as _ _) - = fromPrelude mod && qual && not (maybeToBool imp_as) + implicit_qprel = if opt_NoImplicitPrelude + then [{- no "import qualified Prelude" -}] + else [ImportDecl pRELUDE True Nothing Nothing prel_loc] - explicit_prelude_import - = null [() | (ImportDecl mod qual _ _ _) <- ok_imps, fromPrelude mod] + explicit_prelude_imp = not (null [ () | (ImportDecl mod qual _ _ _) <- src_imps, + mod == pRELUDE ]) - qprel_imp = if opt_NoImplicitPrelude - then [{-the flag really means it: *NO* implicit "import Prelude" -}] - else [ImportDecl pRELUDE True Nothing Nothing prel_loc] - - prel_imp = if not explicit_prelude_import || opt_NoImplicitPrelude - then - [{- no "import Prelude" -}] - else - [ImportDecl pRELUDE False Nothing Nothing prel_loc] + implicit_prel = if explicit_prelude_imp || opt_NoImplicitPrelude + then [{- no "import Prelude" -}] + else [ImportDecl pRELUDE False Nothing Nothing prel_loc] prel_loc = mkBuiltinSrcLoc (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 _ _) <- src_imps, + fromPrelude mod ] + + qual_mods = [ (qual_name mod as_mod, imp) | imp@(ImportDecl mod True as_mod _ _) <- src_imps ] + qual_name mod (Just as_mod) = as_mod + qual_name mod Nothing = mod + + (_, qual_dups) = removeDups cmp_qual qual_mods + bad_qual_dups = filter (not . all_same_mod) qual_dups + + cmp_qual (q1,_) (q2,_) = cmpPString q1 q2 + all_same_mod ((q,ImportDecl mod _ _ _ _):rest) + = all has_same_mod rest + where + has_same_mod (q,ImportDecl mod2 _ _ _ _) = mod == mod2 + + imp_mods = [ mod | ImportDecl mod _ _ _ _ <- uniq_imps ] + imp_warns = listToBag (map dupImportWarn imp_dups) `unionBags` - listToBag (map qualPreludeImportWarn src_qprels) + listToBag (map qualPreludeImportWarn qprel_imps) + imp_errs = listToBag (map dupQualImportErr bad_qual_dups) doImports iface_cache i_info us [] = return (emptyBag, emptyBag, emptyBag, emptyBag, emptyBag, emptyBag, emptyBag) @@ -414,7 +435,7 @@ doImport :: IfaceCache 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, @@ -428,15 +449,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) @@ -460,7 +482,7 @@ doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc) getBuiltins _ mod maybe_spec - | not (fromPrelude mod) + | not ((fromPrelude mod) || mod == iX || mod == rATIO ) = (emptyBag, emptyBag, maybe_spec) getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) mod maybe_spec @@ -468,6 +490,7 @@ getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) mod maybe_spec Nothing -> (all_vals, all_tcs, Nothing) Just (True, ies) -> -- hiding does not work for builtin names + trace "getBuiltins: import Prelude hiding ( ... )" $ (all_vals, all_tcs, maybe_spec) Just (False, ies) -> let @@ -478,15 +501,20 @@ getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) mod maybe_spec all_vals = do_all_builtin (fmToList b_val_names) all_tcs = do_all_builtin (fmToList b_tc_names) + filter_mod = if fromPrelude mod then pRELUDE else mod + do_all_builtin [] = emptyBag - do_all_builtin ((str,rn):rest) + do_all_builtin (((str,mod),rn):rest) + | mod == filter_mod = (str, rn) `consBag` do_all_builtin rest + | otherwise + = do_all_builtin rest do_builtin [] = (emptyBag,emptyBag,[]) do_builtin (ie:ies) = let str = unqual_str (ie_name ie) in - case (lookupFM b_tc_names str) of -- NB: we favour the tycon/class FM... + case (lookupFM b_tc_names (str,mod)) of -- NB: we favour the tycon/class FM... Just rn -> case (ie,rn) of (IEThingAbs _, WiredInTyCon tc) -> (vals, (str, rn) `consBag` tcs, ies_left) @@ -495,10 +523,15 @@ getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) mod maybe_spec (tyConDataCons tc)) `unionBags` vals, (str,rn) `consBag` tcs, ies_left) + (IEThingWith _ _, WiredInTyCon tc) -- No checking of With... + -> (listToBag (map (\ id -> (getLocalName id, WiredInId id)) + (tyConDataCons tc)) + `unionBags` vals, + (str,rn) `consBag` tcs, ies_left) _ -> panic "importing builtin names (1)" Nothing -> - case (lookupFM b_val_names str) of + case (lookupFM b_val_names (str,mod)) of Nothing -> (vals, tcs, ie:ies_left) Just rn -> case (ie,rn) of (IEVar _, WiredInId _) @@ -508,16 +541,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) -getOrigIEs (ParsedIface _ _ _ _ exps _ _ _ _ _ _) (Just (False, ies)) -- import these +getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) (Just (False, ies)) -- import these = (map fst found_ies, found_ies, errs) where (found_ies, errs) = lookupIEs exps ies @@ -614,15 +647,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) @@ -758,7 +791,7 @@ newImportedName tycon_or_class locn maybe_exp maybe_imp rdr (imp_flag, imp_locs) = imp_fn n - n = mkImportedName uniq rdr imp locn imp_locs 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} @@ -770,35 +803,45 @@ globalDupNamesErr rdr rns sty 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 + ppCat [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 (RnName _) = ppStr "as a value:" + pp_descrip (RnSyn _) = ppStr "as a type synonym:" + pp_descrip (RnData _ _ _) = ppStr "as a data type:" + pp_descrip (RnConstr _ _) = ppStr "as a data constructor:" + pp_descrip (RnField _ _) = ppStr "as a record field:" + pp_descrip (RnClass _ _) = ppStr "as a class:" + pp_descrip (RnClassOp _ _) = ppStr "as 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 -> + item1 = addShortWarnLocLine locn1 (\ sty -> ppCat [ppStr "multiple imports from module", ppPStr m1]) sty dup_item (ImportDecl m _ _ _ locn) - = addShortErrLocLine locn (\ sty -> + = addShortWarnLocLine locn (\ sty -> ppCat [ppStr "here was another import from module", ppPStr m]) sty qualPreludeImportWarn (ImportDecl m _ _ _ locn) - = addShortErrLocLine locn (\ sty -> + = addShortWarnLocLine locn (\ sty -> ppCat [ppStr "qualified import of prelude module", ppPStr m]) +dupQualImportErr ((q1,ImportDecl _ _ _ _ locn1):dup_quals) sty + = ppAboves (item1 : map dup_item dup_quals) + where + item1 = addShortErrLocLine locn1 (\ sty -> + ppCat [ppStr "multiple imports (from different modules) with same qualified name", ppPStr q1]) sty + + dup_item (q,ImportDecl _ _ _ _ locn) + = addShortErrLocLine locn (\ sty -> + ppCat [ppStr "here was another import with qualified name", ppPStr q]) sty + unknownImpSpecErr ie imp_mod locn = addShortErrLocLine locn (\ sty -> ppBesides [ppStr "module ", ppPStr imp_mod, ppStr " does not export `", ppr sty (ie_name ie), ppStr "'"]) @@ -808,7 +851,7 @@ duplicateImpSpecErr ie imp_mod locn ppBesides [ppStr "`", ppr sty (ie_name ie), ppStr "' already seen in import list"]) allWhenSynImpSpecWarn n imp_mod locn - = addShortErrLocLine locn (\ sty -> + = addShortWarnLocLine locn (\ sty -> ppBesides [ppStr "type synonym `", ppr sty n, ppStr "' should not be imported with (..)"]) allWhenAbsImpSpecErr n imp_mod locn