X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnNames.lhs;h=cd256b9feb7121b639553f07bbe29d4956a9ce30;hb=ae45ff0e9831a0dc862a5d68d03e355d7e323c62;hp=0f7037269dd1c1b7ffd5e050f3ce977ca432e677;hpb=5cf27e8f1731c52fe63a5b9615f927484164c61b;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 0f70372..cd256b9 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -13,7 +13,7 @@ module RnNames ( import PreludeGlaST ( MutableVar(..) ) -import Ubiq +IMP_Ubiq() import HsSyn import RdrHsSyn @@ -22,40 +22,45 @@ 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 ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), ExportsMap(..), RdrIfaceInst ) import Bag ( emptyBag, unitBag, consBag, snocBag, unionBags, unionManyBags, mapBag, filterBag, listToBag, bagToList ) -import CmdLineOpts ( opt_NoImplicitPrelude ) +import CmdLineOpts ( opt_NoImplicitPrelude, opt_CompilingPrelude ) import ErrUtils ( Error(..), Warning(..), addErrLoc, addShortErrLocLine, addShortWarnLocLine ) -import FiniteMap ( emptyFM, addListToFM, lookupFM, fmToList, eltsFM, delListFromFM ) +import FiniteMap ( emptyFM, addToFM, addListToFM, lookupFM, fmToList, eltsFM, delListFromFM, keysFM{-ToDo:rm-} ) import Id ( GenId ) import Maybes ( maybeToBool, catMaybes, MaybeErr(..) ) -import Name ( RdrName(..), Name, isQual, mkTopLevName, origName, - mkImportedName, nameExportFlag, nameImportFlag, - getLocalName, getSrcLoc, getImpLocs, moduleNamePair, - pprNonSym, isLexCon, isRdrLexCon, ExportFlag(..) +import Name ( RdrName(..), Name, isQual, mkTopLevName, mkWiredInName, origName, + nameOf, qualToOrigName, mkImportedName, + nameExportFlag, nameImportFlag, + getLocalName, getSrcLoc, getImpLocs, + moduleNamePair, pprNonSym, + isLexCon, ExportFlag(..), OrigName(..) ) import PrelInfo ( BuiltinNames(..), BuiltinKeys(..) ) -import PrelMods ( fromPrelude, pRELUDE ) +import PrelMods ( pRELUDE, gHC_BUILTINS, modulesWithBuiltins ) import Pretty import SrcLoc ( SrcLoc, mkBuiltinSrcLoc ) import TyCon ( tyConDataCons ) import UniqFM ( emptyUFM, addListToUFM_C, lookupUFM ) import UniqSupply ( splitUniqSupply ) import Util ( isIn, assoc, cmpPString, sortLt, removeDups, - equivClasses, panic, assertPanic ) + equivClasses, panic, assertPanic, pprPanic{-ToDo:rm-}, pprTrace{-ToDo:rm-} + ) +import PprStyle --ToDo:rm \end{code} - \begin{code} type GlobalNameInfo = (BuiltinNames, BuiltinKeys, Name -> ExportFlag, -- export flag - Name -> [RdrName]) -- occurence names + Name -> [RdrName]) -- occurrence names + -- NB: both of the functions are in a *knot* and + -- must be tugged on oh-so-gently... type RnM_Info s r = RnMonad GlobalNameInfo s r @@ -73,7 +78,10 @@ getGlobalNames :: getGlobalNames iface_cache info us (HsModule mod _ _ imports _ ty_decls _ cls_decls _ _ _ binds _ _) - = case initRn True mod emptyRnEnv us1 + = let + (us1, us2) = splitUniqSupply us + in + case initRn True mod emptyRnEnv us1 (setExtraRn info $ getSourceNames ty_decls cls_decls binds) of { ((src_vals, src_tcs), src_errs, src_warns) -> @@ -90,7 +98,7 @@ getGlobalNames iface_cache info us -- remove dups of the same imported thing diff_imp_dups = filterBag diff_orig imp_dups - diff_orig (_,rn1,rn2) = origName rn1 /= origName rn2 + diff_orig (_,rn1,rn2) = origName "diff_orig" rn1 /= origName "diff_orig" rn2 all_dups = bagToList (src_dups `unionBags` diff_imp_dups) dup_errs = map dup_err (equivClasses cmp_rdr all_dups) @@ -100,10 +108,7 @@ getGlobalNames iface_cache info us all_errs = src_errs `unionBags` imp_errs `unionBags` listToBag dup_errs all_warns = src_warns `unionBags` imp_warns in - return (all_env, imp_mods, unqual_imps, imp_fixes, all_errs, all_warns) - } - where - (us1, us2) = splitUniqSupply us + return (all_env, imp_mods, unqual_imps, imp_fixes, all_errs, all_warns) } \end{code} ********************************************************* @@ -129,12 +134,16 @@ getSourceNames ty_decls cls_decls binds unionManyBags cls_ops_s `unionBags` bind_names, listToBag tycon_s `unionBags` listToBag cls_s) - +-------------- getTyDeclNames :: RdrNameTyDecl -> 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 -> + = --getExtraRn `thenRn` \ ((b_val_names,b_tc_names),b_keys,rec_exp_fn,rec_occ_fn) -> + --pprTrace "getTyDeclNames:" (ppr PprDebug tycon) $ + --pprTrace "getTDN1:" (ppAboves [ ppCat [ppPStr m, ppPStr n] | ((OrigName m n), _) <- fmToList b_tc_names]) $ + + newGlobalName src_loc Nothing False{-not val-} tycon `thenRn` \ tycon_name -> getConFieldNames (Just (nameExportFlag tycon_name)) emptyBag emptyBag emptyFM condecls `thenRn` \ (con_names, field_names) -> let @@ -145,33 +154,39 @@ getTyDeclNames (TyData _ tycon _ condecls _ _ src_loc) returnRn (rn_tycon, listToBag rn_constrs, listToBag rn_fields) getTyDeclNames (TyNew _ tycon _ [NewConDecl con _ con_loc] _ _ src_loc) - = newGlobalName src_loc Nothing tycon `thenRn` \ tycon_name -> - newGlobalName con_loc (Just (nameExportFlag tycon_name)) con + = newGlobalName src_loc Nothing False{-not val-} tycon `thenRn` \ tycon_name -> + newGlobalName con_loc (Just (nameExportFlag tycon_name)) True{-val-} 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 -> + = newGlobalName src_loc Nothing False{-not val-} tycon `thenRn` \ tycon_name -> returnRn (RnSyn tycon_name, emptyBag, emptyBag) +---------------- +getConFieldNames :: Maybe ExportFlag + -> Bag Name -> Bag Name + -> FiniteMap RdrName () + -> [RdrNameConDecl] + -> RnM_Info s ([Name], [Name]) 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 -> + = newGlobalName src_loc exp True{-val-} 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 -> + = newGlobalName src_loc exp True{-val-} 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 -> + newGlobalName src_loc exp True{-val-} con `thenRn` \ con_name -> + mapRn (newGlobalName src_loc exp True{-val-}) new_fields `thenRn` \ field_names -> let all_constrs = constrs `snocBag` con_name all_fields = fields `unionBags` listToBag field_names @@ -182,20 +197,26 @@ getConFieldNames exp constrs fields have (RecConDecl con fielddecls src_loc : re 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 getClassNames (ClassDecl _ cname _ sigs _ _ src_loc) - = newGlobalName src_loc Nothing cname `thenRn` \ class_name -> + = newGlobalName src_loc Nothing False{-notval-} cname `thenRn` \ class_name -> getClassOpNames (Just (nameExportFlag class_name)) sigs `thenRn` \ op_names -> returnRn (RnClass class_name op_names, listToBag (map (\ n -> RnClassOp n class_name) op_names)) -getClassOpNames exp [] - = returnRn [] +--------------- +getClassOpNames :: Maybe ExportFlag + -> [RdrNameSig] + -> RnM_Info s [Name] + +getClassOpNames exp [] = returnRn [] + getClassOpNames exp (ClassOpSig op _ _ src_loc : sigs) - = newGlobalName src_loc exp op `thenRn` \ op_name -> + = newGlobalName src_loc exp True{-val-} op `thenRn` \ op_name -> getClassOpNames exp sigs `thenRn` \ op_names -> returnRn (op_name : op_names) getClassOpNames exp (_ : sigs) @@ -254,7 +275,7 @@ doPat locn (RecPatIn name fields) doField locn (_, pat, _) = doPat locn pat doName locn rdr - = newGlobalName locn Nothing rdr `thenRn` \ name -> + = newGlobalName locn Nothing True{-val-} rdr `thenRn` \ name -> returnRn (unitBag (RnName name)) \end{code} @@ -265,36 +286,65 @@ doName locn rdr ********************************************************* \begin{code} -newGlobalName :: SrcLoc -> Maybe ExportFlag - -> RdrName -> RnM_Info s Name +newGlobalName :: SrcLoc + -> Maybe ExportFlag + -> Bool{-True<=>value name,False<=>tycon/class-} + -> RdrName + -> RnM_Info s Name + +newGlobalName locn maybe_exp is_val_name (Unqual name) + = getExtraRn `thenRn` \ ((b_val_names,b_tc_names),b_keys,rec_exp_fn,rec_occ_fn) -> + getModuleRn `thenRn` \ mod -> + rnGetUnique `thenRn` \ u -> + let + orig = OrigName mod name + + (uniq, is_toplev) + = case (lookupFM b_keys orig) of + Just (key,_) -> (key, True) + Nothing -> if not opt_CompilingPrelude then (u,True) else -- really here just to save gratuitous lookup + case (lookupFM (if is_val_name then b_val_names else b_tc_names) orig) of + Nothing -> (u, True) + Just xx -> (uniqueOf xx, False{-builtin!-}) + + exp = case maybe_exp of + Just flag -> flag + Nothing -> rec_exp_fn n + + n = if is_toplev + then mkTopLevName uniq orig locn exp (rec_occ_fn n) -- NB: two "n"s + else mkWiredInName uniq orig + in + returnRn n --- ToDo: b_names and b_keys being defined in this module !!! +newGlobalName locn maybe_exp is_val_name rdr@(Qual mod name) + | opt_CompilingPrelude + -- we are actually defining something that compiler knows about (e.g., Bool) -newGlobalName locn maybe_exp rdr - = getExtraRn `thenRn` \ (_,b_keys,exp_fn,occ_fn) -> - getModuleRn `thenRn` \ mod -> - rnGetUnique `thenRn` \ u -> + = getExtraRn `thenRn` \ ((b_val_names,b_tc_names),b_keys,rec_exp_fn,rec_occ_fn) -> let - (uniq, unqual) - = case rdr of - Qual m n -> (u, n) - Unqual n -> case (lookupFM b_keys n) of - Nothing -> (u, n) - Just (key,_) -> (key, n) + orig = OrigName mod name - orig = if fromPrelude mod - then (Unqual unqual) - else (Qual mod unqual) + (uniq, is_toplev) + = case (lookupFM b_keys orig) of + Just (key,_) -> (key, True) + Nothing -> case (lookupFM (if is_val_name then b_val_names else b_tc_names) orig) of + Nothing -> (pprPanic "newGlobalName:Qual:uniq:" (ppr PprDebug rdr), True) + Just xx -> (uniqueOf xx, False{-builtin!-}) exp = case maybe_exp of - Just exp -> exp - Nothing -> exp_fn n + Just flag -> flag + Nothing -> rec_exp_fn n - n = mkTopLevName uniq orig locn exp (occ_fn n) -- NB: two "n"s + n = if is_toplev + then mkTopLevName uniq orig locn exp (rec_occ_fn n) -- NB: two "n"s + else mkWiredInName uniq orig in - addWarnIfRn (rdr == Unqual SLIT("negate")) (negateNameWarn (rdr, locn)) `thenRn_` - addErrIfRn (isQual rdr) (qualNameErr "name in definition" (rdr, locn)) `thenRn_` returnRn n + + | otherwise + = addErrRn (qualNameErr "name in definition" (rdr, locn)) `thenRn_` + returnRn (pprPanic "newGlobalName:Qual:" (ppr PprDebug rdr)) \end{code} ********************************************************* @@ -304,23 +354,27 @@ newGlobalName locn maybe_exp rdr ********************************************************* \begin{code} -type ImportNameInfo = (GlobalNameInfo, - FiniteMap (Module,FAST_STRING) RnName, -- values imported so far - FiniteMap (Module,FAST_STRING) RnName, -- tycons/classes imported so far - Name -> (ExportFlag, [SrcLoc])) -- import flag and src locns - +type ImportNameInfo + = (GlobalNameInfo, + FiniteMap OrigName RnName, -- values imported so far + FiniteMap OrigName RnName, -- tycons/classes imported so far + Name -> (ExportFlag, [SrcLoc])) -- import flag and src locns; + -- NB: this last field is in a knot + -- and mustn't be tugged on! + type RnM_IInfo s r = RnMonad ImportNameInfo s r +------------------------------------------------------------------ doImportDecls :: IfaceCache - -> GlobalNameInfo -- builtin and knot name info + -> GlobalNameInfo -- builtin and knot name info -> UniqSupply - -> [RdrNameImportDecl] -- import declarations - -> IO (Bag (RdrName,RnName), -- imported values in scope - Bag (RdrName,RnName), -- imported tycons/classes in scope - [Module], -- directly imported modules - Bag (Module,RnName), -- unqualified import from module - Bag RenamedFixityDecl, -- fixity info for imported names + -> [RdrNameImportDecl] -- import declarations + -> IO (Bag (RdrName,RnName), -- imported values in scope + Bag (RdrName,RnName), -- imported tycons/classes in scope + [Module], -- directly imported modules + Bag (Module,RnName), -- unqualified import from module + Bag RenamedFixityDecl, -- fixity info for imported names Bag Error, Bag Warning) @@ -340,6 +394,7 @@ doImportDecls iface_cache g_info us src_imps -- cache the imported modules -- this ensures that all directly imported modules -- will have their original name iface in scope + -- pprTrace "doImportDecls:" (ppCat (map ppPStr imp_mods)) $ accumulate (map (cachedIface False iface_cache) imp_mods) >> -- process the imports @@ -348,54 +403,81 @@ doImportDecls iface_cache g_info us src_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 - the_imps = implicit_prel ++ src_imps + the_imps = implicit_prel ++ src_imps all_imps = implicit_qprel ++ the_imps - implicit_qprel = if opt_NoImplicitPrelude + implicit_qprel = ImportDecl gHC_BUILTINS True Nothing Nothing prel_loc + : (if opt_NoImplicitPrelude then [{- no "import qualified Prelude" -}] - else [ImportDecl pRELUDE True Nothing Nothing prel_loc] + 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 + implicit_prel = ImportDecl gHC_BUILTINS False Nothing Nothing prel_loc + : (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 ] + 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 _ _) <- prel_imps ] + qprel_imps = [ imp | imp@(ImportDecl mod True Nothing _ _) <- src_imps, + mod == pRELUDE ] + + 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 (_,ImportDecl mod2 _ _ _ _) = mod == mod2 + + imp_mods = [ mod | ImportDecl mod _ _ _ _ <- uniq_imps, mod /= gHC_BUILTINS ] - imp_mods = [ mod | ImportDecl mod _ _ _ _ <- uniq_imps ] imp_warns = listToBag (map dupImportWarn imp_dups) `unionBags` listToBag (map qualPreludeImportWarn qprel_imps) + imp_errs = listToBag (map dupQualImportErr bad_qual_dups) + +----------------------- +doImports :: IfaceCache + -> ImportNameInfo + -> UniqSupply + -> [RdrNameImportDecl] -- import declarations + -> IO (Bag (RdrName,RnName), -- imported values in scope + Bag (RdrName,RnName), -- imported tycons/classes in scope + Bag (Module, RnName), -- unqualified import from module + Bag RenamedFixityDecl, -- fixity info for imported names + Bag Error, + Bag Warning, + Bag (RnName,(ExportFlag,Bag SrcLoc))) -- import flags and src locs doImports iface_cache i_info us [] = return (emptyBag, emptyBag, emptyBag, emptyBag, emptyBag, emptyBag, emptyBag) -doImports iface_cache i_info@(g_info,done_vals,done_tcs,imp_fn) us (imp:imps) - = doImport iface_cache i_info us1 imp + +doImports iface_cache i_info@(g_info,done_vals,done_tcs,rec_imp_fn) us (imp:imps) + = let + (us1, us2) = splitUniqSupply us + in + doImport iface_cache i_info us1 imp >>= \ (vals1, tcs1, unquals1, fixes1, errs1, warns1, imps1) -> let - new_vals = [ (moduleNamePair rn, rn) | (_,rn) <- bagToList vals1, - not (maybeToBool (lookupFM done_vals (moduleNamePair rn))) ] - -- moduleNamePair computed twice - ext_vals = addListToFM done_vals new_vals - - new_tcs = [ (moduleNamePair rn, rn) | (_,rn) <- bagToList tcs1, - not (maybeToBool (lookupFM done_tcs (moduleNamePair rn))) ] - ext_tcs = addListToFM done_tcs new_tcs + ext_vals = foldl add_new_one done_vals (bagToList vals1) + ext_tcs = foldl add_new_one done_tcs (bagToList tcs1) in - doImports iface_cache (g_info,ext_vals,ext_tcs,imp_fn) us2 imps + doImports iface_cache (g_info,ext_vals,ext_tcs,rec_imp_fn) us2 imps >>= \ (vals2, tcs2, unquals2, fixes2, errs2, warns2, imps2) -> return (vals1 `unionBags` vals2, tcs1 `unionBags` tcs2, @@ -405,9 +487,19 @@ doImports iface_cache i_info@(g_info,done_vals,done_tcs,imp_fn) us (imp:imps) warns1 `unionBags` warns2, imps1 `unionBags` imps2) where - (us1, us2) = splitUniqSupply us + add_new_one :: FiniteMap OrigName RnName -- ones done so far + -> (dont_care, RnName) + -> FiniteMap OrigName RnName -- extended + add_new_one fm (_, rn) + = let + orig = origName "add_new_one" rn + in + case (lookupFM fm orig) of + Just _ -> fm -- already there: no change + Nothing -> addToFM fm orig rn +---------------------- doImport :: IfaceCache -> ImportNameInfo -> UniqSupply @@ -421,15 +513,25 @@ 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 False iface_cache mod >>= \ maybe_iface -> + = let + (b_vals, b_tcs, maybe_spec') = getBuiltins info mod maybe_spec + in + (if mod == gHC_BUILTINS then + return (Succeeded (panic "doImport:GHC fake import!"), + \ iface -> ([], [], emptyBag)) + else + --pprTrace "doImport:" (ppPStr mod) $ + cachedIface False iface_cache mod >>= \ maybe_iface -> + return (maybe_iface, \ iface -> getOrigIEs iface maybe_spec') + ) >>= \ (maybe_iface, do_ies) -> + case maybe_iface of Failed err -> return (emptyBag, emptyBag, emptyBag, emptyBag, unitBag err, emptyBag, emptyBag) Succeeded iface -> let - (b_vals, b_tcs, maybe_spec') = getBuiltins info mod maybe_spec - (ies, chk_ies, get_errs) = getOrigIEs iface maybe_spec' + (ies, chk_ies, get_errs) = do_ies iface in doOrigIEs iface_cache info mod src_loc us ies >>= \ (ie_vals, ie_tcs, imp_flags, errs, warns) -> @@ -438,14 +540,19 @@ doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc) 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 + final_vals_list = bagToList final_vals in - accumulate (map (getFixityDecl iface_cache) (bagToList final_vals)) - >>= \ fix_maybes_errs -> + (if mod == gHC_BUILTINS then + return [ (Nothing, emptyBag) | _ <- final_vals_list ] + else + accumulate (map (getFixityDecl iface_cache . snd) final_vals_list) + ) >>= \ fix_maybes_errs -> let (chk_errs, chk_warns) = unzip chk_errs_warns (fix_maybes, fix_errs) = unzip fix_maybes_errs - unquals = if qual then emptyBag + unquals = if qual{-ified import-} + then emptyBag else mapBag pair_as (ie_vals `unionBags` ie_tcs) final_fixes = listToBag (catMaybes fix_maybes) @@ -459,23 +566,40 @@ doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc) return (final_vals, final_tcs, unquals, final_fixes, final_errs, final_warns, imp_stuff) where + as_mod :: Module as_mod = case maybe_as of {Nothing -> mod; Just as_this -> as_this} + + mk_occ :: FAST_STRING -> RdrName mk_occ str = if qual then Qual as_mod str else Unqual str + fst_occ :: (FAST_STRING, RnName) -> (RdrName, RnName) fst_occ (str, rn) = (mk_occ str, rn) - pair_occ rn = (mk_occ (getLocalName rn), rn) - pair_as rn = (as_mod, rn) + pair_occ :: RnName -> (RdrName, RnName) + pair_occ rn = (mk_occ (getLocalName rn), rn) + + pair_as :: RnName -> (Module, RnName) + pair_as rn = (as_mod, rn) -getBuiltins _ mod maybe_spec - | not (fromPrelude mod) +----------------------------- +getBuiltins :: ImportNameInfo + -> Module + -> Maybe (Bool, [RdrNameIE]) + -> (Bag (FAST_STRING, RnName), + Bag (FAST_STRING, RnName), + Maybe (Bool, [RdrNameIE]) -- return IEs that had no effect + ) + +getBuiltins _ modname maybe_spec + | modname `notElem` modulesWithBuiltins = (emptyBag, emptyBag, maybe_spec) -getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) mod maybe_spec +getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) modname maybe_spec = case maybe_spec of Nothing -> (all_vals, all_tcs, Nothing) Just (True, ies) -> -- hiding does not work for builtin names + trace "NOTE: `import Prelude hiding ...' does not hide built-in names" $ (all_vals, all_tcs, maybe_spec) Just (False, ies) -> let @@ -487,14 +611,20 @@ getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) mod maybe_spec all_tcs = do_all_builtin (fmToList b_tc_names) do_all_builtin [] = emptyBag - do_all_builtin ((str,rn):rest) - = (str, rn) `consBag` do_all_builtin rest + do_all_builtin (((OrigName mod str),rn):rest) + = --pprTrace "do_all_builtin:" (ppCat [ppPStr modname, ppPStr mod, ppPStr str]) $ + (if mod == modname then consBag (str, rn) else id) (do_all_builtin rest) do_builtin [] = (emptyBag,emptyBag,[]) do_builtin (ie:ies) - = let str = unqual_str (ie_name ie) + = let + (str, orig) + = case (ie_name ie) of + Unqual s -> (s, OrigName modname s) + Qual m s -> pprTrace "do_builtin:surprising qual!" (ppCat [ppPStr m, ppPStr s]) $ + (s, OrigName modname s) in - case (lookupFM b_tc_names str) of -- NB: we favour the tycon/class FM... + case (lookupFM b_tc_names orig) of -- NB: we favour the tycon/class FM... Just rn -> case (ie,rn) of (IEThingAbs _, WiredInTyCon tc) -> (vals, (str, rn) `consBag` tcs, ies_left) @@ -503,10 +633,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 -> (nameOf (origName "IEThingWith" 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 orig) of Nothing -> (vals, tcs, ie:ies_left) Just rn -> case (ie,rn) of (IEVar _, WiredInId _) @@ -515,8 +650,14 @@ getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) mod maybe_spec where (vals, tcs, ies_left) = do_builtin ies +------------------------- +getOrigIEs :: ParsedIface + -> Maybe (Bool, [RdrNameIE]) -- "hiding" or not, blah, blah, blah + -> ([IE OrigName], + [(IE OrigName, ExportFlag)], + Bag (Module -> SrcLoc -> Error)) -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 @@ -530,42 +671,59 @@ getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) (Just (False, ies)) -- imp where (found_ies, errs) = lookupIEs exps ies +------------------------------------------------ +mkAllIE :: (OrigName, ExportFlag) -> IE OrigName mkAllIE (orig,ExportAbs) - = ASSERT(isLexCon (getLocalName orig)) + = ASSERT(isLexCon (nameOf orig)) IEThingAbs orig mkAllIE (orig, ExportAll) - | isLexCon (getLocalName orig) + | isLexCon (nameOf orig) = IEThingAll orig | otherwise = IEVar orig +------------ +lookupIEs :: ExportsMap + -> [RdrNameIE] + -> ([(IE OrigName, ExportFlag)], -- IEs we found, orig-ified + Bag (Module -> SrcLoc -> Error)) -lookupIEs exps [] - = ([], emptyBag) -lookupIEs exps (ie:ies) - = case lookupFM exps (unqual_str (ie_name ie)) of - Nothing -> - (orig_ies, unknownImpSpecErr ie `consBag` errs) - Just (orig,flag) -> - (orig_ie orig flag ie ++ orig_ies, - adderr_if (seen_ie orig orig_ies) (duplicateImpSpecErr ie) errs) +lookupIEs exps ies + = foldr go ([], emptyBag) ies where - (orig_ies, errs) = lookupIEs exps ies - - orig_ie orig flag (IEVar n) = [(IEVar orig, flag)] - orig_ie orig flag (IEThingAbs n) = [(IEThingAbs orig, flag)] - orig_ie orig flag (IEThingAll n) = [(IEThingAll orig, flag)] - orig_ie orig flag (IEThingWith n ns) = [(IEThingWith orig ns, flag)] + go ie (already, errs) + = let + str = case (ie_name ie) of + Unqual s -> s + Qual m s -> s + in + case (lookupFM exps str) of + Nothing -> + (already, unknownImpSpecErr ie `consBag` errs) + Just (orig, flag) -> + ((orig_ie orig ie, flag) : already, + adderr_if (seen_ie orig already) (duplicateImpSpecErr ie) errs) + + orig_ie orig (IEVar n) = IEVar orig + orig_ie orig (IEThingAbs n) = IEThingAbs orig + orig_ie orig (IEThingAll n) = IEThingAll orig + orig_ie orig (IEThingWith n ns) = IEThingWith orig (map re_orig ns) + where + (OrigName mod _) = orig + re_orig (Unqual s) = OrigName mod s seen_ie orig seen_ies = any (\ (ie,_) -> orig == ie_name ie) seen_ies - +-------------------------------------------- doOrigIEs iface_cache info mod src_loc us [] = return (emptyBag,emptyBag,emptyBag,emptyBag,emptyBag) doOrigIEs iface_cache info mod src_loc us (ie:ies) - = doOrigIE iface_cache info mod src_loc us1 ie + = let + (us1, us2) = splitUniqSupply us + in + doOrigIE iface_cache info mod src_loc us1 ie >>= \ (vals1, tcs1, imps1, errs1, warns1) -> doOrigIEs iface_cache info mod src_loc us2 ies >>= \ (vals2, tcs2, imps2, errs2, warns2) -> @@ -574,8 +732,19 @@ doOrigIEs iface_cache info mod src_loc us (ie:ies) imps1 `unionBags` imps2, errs1 `unionBags` errs2, warns1 `unionBags` warns2) - where - (us1, us2) = splitUniqSupply us + +---------------------- +doOrigIE :: IfaceCache + -> ImportNameInfo + -> Module + -> SrcLoc + -> UniqSupply + -> IE OrigName + -> IO (Bag RnName, -- values + Bag RnName, -- tycons/classes + Bag (RnName,ExportFlag), -- import flags + Bag Error, + Bag Warning) doOrigIE iface_cache info mod src_loc us ie = with_decl iface_cache (ie_name ie) @@ -587,6 +756,11 @@ doOrigIE iface_cache info mod src_loc us ie of ((vals, tcs, imps), errs, warns) -> (vals, tcs, imps, errs, warns)) +------------------------- +checkOrigIE :: IfaceCache + -> (IE OrigName, ExportFlag) + -> IO (Bag (Module -> SrcLoc -> Error), Bag (Module -> SrcLoc -> Warning)) + checkOrigIE iface_cache (IEThingAll n, ExportAbs) = with_decl iface_cache n (\ err -> (unitBag (\ mod locn -> err), emptyBag)) @@ -601,30 +775,42 @@ 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 fields _ _ -> (check_with "constructrs (and fields)" (cons++fields) ns, emptyBag) + NewTypeSig _ con _ _ -> (check_with "constructors" [con] ns, emptyBag) + DataSig _ cons fields _ _ -> (check_with "constructors (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) + check_with str has origs + | sortLt (<) (map getLocalName has) == sortLt (<) (map nameOf origs) = emptyBag | otherwise - = unitBag (withImpSpecErr str n has rdrs) + = unitBag (withImpSpecErr str n has origs) checkOrigIE iface_cache other = return (emptyBag, emptyBag) +----------------------- +with_decl :: IfaceCache + -> OrigName + -> (Error -> something) -- if an error... + -> (RdrIfaceDecl -> something) -- if OK... + -> IO something with_decl iface_cache n do_err do_decl - = cachedDecl iface_cache (isRdrLexCon n) n >>= \ maybe_decl -> + = cachedDecl iface_cache (isLexCon (nameOf n)) n >>= \ maybe_decl -> case maybe_decl of - Failed err -> return (do_err err) + Failed err -> return (do_err err) Succeeded decl -> return (do_decl decl) +------------- +getFixityDecl :: IfaceCache + -> RnName + -> IO (Maybe RenamedFixityDecl, Bag Error) -getFixityDecl iface_cache (_,rn) +getFixityDecl iface_cache rn = let - (mod, str) = moduleNamePair rn + (OrigName mod str) = origName "getFixityDecl" rn + + succeeded infx i = return (Just (infx rn i), emptyBag) in cachedIface True iface_cache mod >>= \ maybe_iface -> case maybe_iface of @@ -633,19 +819,16 @@ getFixityDecl iface_cache (_,rn) Succeeded (ParsedIface _ _ _ _ _ _ _ _ fixes _ _ _ _) -> case lookupFM fixes str of Nothing -> return (Nothing, emptyBag) - Just (InfixL _ i) -> return (Just (InfixL rn i), emptyBag) - Just (InfixR _ i) -> return (Just (InfixR rn i), emptyBag) - Just (InfixN _ i) -> return (Just (InfixN rn i), emptyBag) + Just (InfixL _ i) -> succeeded InfixL i + Just (InfixR _ i) -> succeeded InfixR i + Just (InfixN _ i) -> succeeded InfixN i ie_name (IEVar n) = n ie_name (IEThingAbs n) = n ie_name (IEThingAll n) = n ie_name (IEThingWith n _) = n -unqual_str (Unqual str) = str -unqual_str q@(Qual _ _) = panic "unqual_str" - -adderr_if True err errs = err `consBag` errs +adderr_if True err errs = err `consBag` errs adderr_if False err errs = errs \end{code} @@ -656,7 +839,7 @@ adderr_if False err errs = errs ********************************************************* \begin{code} -getIfaceDeclNames :: RdrNameIE -> RdrIfaceDecl +getIfaceDeclNames :: IE OrigName -> RdrIfaceDecl -> RnM_IInfo s (Bag RnName, -- values Bag RnName, -- tycons/classes Bag (RnName,ExportFlag)) -- import flags @@ -687,12 +870,13 @@ getIfaceDeclNames ie (NewTypeSig tycon con 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 + map_me = mapRn (newImportedName False src_loc + (Just (nameExportFlag tycon_name)) + (Just (nameImportFlag tycon_name))) + in + map_me cons `thenRn` \ con_names -> + map_me fields `thenRn` \ field_names -> let rn_tycon = RnData tycon_name con_names field_names rn_constrs = [ RnConstr name tycon_name | name <- con_names ] @@ -741,32 +925,33 @@ newImportedName :: Bool -- True => tycon or class -> RnM_IInfo s Name newImportedName tycon_or_class locn maybe_exp maybe_imp rdr - = getExtraRn `thenRn` \ ((_,b_keys,exp_fn,occ_fn),done_vals,done_tcs,imp_fn) -> - case if tycon_or_class - then lookupFM done_tcs (moduleNamePair rdr) - else lookupFM done_vals (moduleNamePair rdr) - of - Just rn -> returnRn (getName rn) - Nothing -> + = let + orig = qualToOrigName rdr + in + getExtraRn `thenRn` \ ((_,b_keys,rec_exp_fn,rec_occ_fn),done_vals,done_tcs,rec_imp_fn) -> + case ((if tycon_or_class + then lookupFM done_tcs + else lookupFM done_vals) orig) of + + Just rn -> returnRn (getName rn) + Nothing -> rnGetUnique `thenRn` \ u -> let - uniq = case rdr of - Qual m n -> u - Unqual n -> case lookupFM b_keys n of - Nothing -> u - Just (key,_) -> key + uniq = case lookupFM b_keys orig of + Nothing -> u + Just (key,_) -> key exp = case maybe_exp of - Just exp -> exp - Nothing -> exp_fn n + Just xx -> xx + Nothing -> rec_exp_fn n imp = case maybe_imp of - Just imp -> imp - Nothing -> imp_flag + Just xx -> xx + Nothing -> imp_flag - (imp_flag, imp_locs) = imp_fn n + (imp_flag, imp_locs) = rec_imp_fn n - n = mkImportedName uniq rdr imp locn imp_locs exp (occ_fn n) -- NB: two "n"s + n = mkImportedName uniq orig imp locn imp_locs exp (rec_occ_fn n) -- NB: two "n"s in returnRn n \end{code} @@ -807,6 +992,16 @@ qualPreludeImportWarn (ImportDecl m _ _ _ locn) = 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 "'"])