X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnNames.lhs;h=55aeb1bec8214196c6bbd03c2eedb0702e2f317d;hb=26741ec416bae2c502ef00a2ba0e79050a32cb67;hp=2d1329b08668aa6f9664673817c8161d670ae1d9;hpb=1ffb620ae1457b2e3eb5e415a999a4f6f15fec45;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 2d1329b..55aeb1b 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -13,47 +13,54 @@ module RnNames ( import PreludeGlaST ( MutableVar(..) ) -import Ubiq +IMP_Ubiq() import HsSyn import RdrHsSyn import RnHsSyn import RnMonad -import RnIfaces ( IfaceCache(..), cachedIface, cachedDecl ) -import RnUtils ( RnEnv(..), emptyRnEnv, extendGlobalRnEnv, - lubExportFlag, qualNameErr, dupNamesErr ) -import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst ) +import RnIfaces ( IfaceCache, cachedIface, cachedDecl, CachingResult(..) ) +import RnUtils ( SYN_IE(RnEnv), emptyRnEnv, extendGlobalRnEnv, + lubExportFlag, qualNameErr, dupNamesErr + ) +import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), ExportsMap(..), RdrIfaceInst ) -import Bag ( emptyBag, unitBag, consBag, unionBags, unionManyBags, - mapBag, listToBag, bagToList ) -import CmdLineOpts ( opt_NoImplicitPrelude ) -import ErrUtils ( Error(..), Warning(..), addShortErrLocLine ) -import FiniteMap ( emptyFM, addListToFM, lookupFM, fmToList, eltsFM, delListFromFM ) +import Bag ( emptyBag, unitBag, consBag, snocBag, unionBags, + unionManyBags, mapBag, filterBag, listToBag, bagToList ) +import CmdLineOpts ( opt_NoImplicitPrelude, opt_CompilingGhcInternals ) +import ErrUtils ( SYN_IE(Error), SYN_IE(Warning), addErrLoc, addShortErrLocLine, addShortWarnLocLine ) +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, - mkImportedName, nameExportFlag, nameImportFlag, - getLocalName, getSrcLoc, pprNonSym, moduleNamePair, - 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 PrelInfo ( SYN_IE(BuiltinNames), SYN_IE(BuiltinKeys) ) +import PrelMods ( pRELUDE, gHC_BUILTINS, modulesWithBuiltins ) 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, 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 @@ -71,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) -> @@ -80,25 +90,25 @@ 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 "diff_orig" rn1 /= origName "diff_orig" 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 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} ********************************************************* @@ -116,60 +126,97 @@ 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)) - -getTyDeclNames (TyNew _ 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)) + = --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]) $ -getTyDeclNames (TySynonym tycon _ _ src_loc) - = newGlobalName src_loc Nothing tycon `thenRn` \ tycon_name -> - returnRn (RnSyn tycon_name, emptyBag) + 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 + 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) -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 +getTyDeclNames (TyNew _ tycon _ [NewConDecl con _ con_loc] _ _ src_loc) + = 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 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 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 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 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 + 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 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) @@ -228,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} @@ -239,35 +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_CompilingGhcInternals 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 exp + 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_CompilingGhcInternals + -- 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) + n = if is_toplev + then mkTopLevName uniq orig locn exp (rec_occ_fn n) -- NB: two "n"s + else mkWiredInName uniq orig exp in - 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} ********************************************************* @@ -277,83 +354,130 @@ 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) -- import flag - +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) 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 + -- pprTrace "doImportDecls:" (ppCat (map ppPStr imp_mods)) $ + accumulate (map (cachedIface iface_cache False SLIT("doImportDecls")) 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, + imp_errs `unionBags` 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 = ImportDecl gHC_BUILTINS True Nothing Nothing prel_loc + : (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 = 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_loc = mkBuiltinSrcLoc + + (uniq_imps, imp_dups) = removeDups cmp_mod the_imps + cmp_mod (ImportDecl m1 _ _ _ _) (ImportDecl m2 _ _ _ _) = cmpPString m1 m2 - qprel_imp = if opt_NoImplicitPrelude - then [{-the flag really means it: *NO* implicit "import Prelude" -}] - else [ImportDecl pRELUDE True Nothing Nothing mkIfaceSrcLoc] + qprel_imps = [ imp | imp@(ImportDecl mod True Nothing _ _) <- src_imps, + mod == pRELUDE ] - prel_imp = if not explicit_prelude_import || opt_NoImplicitPrelude - then - [ {-prelude imported explicitly => no import Prelude-} ] - else - [ImportDecl pRELUDE False Nothing Nothing mkIfaceSrcLoc] + 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_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, @@ -363,46 +487,72 @@ 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 -> 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 -> + = 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 iface_cache False SLIT("doImport") 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) -> accumulate (map (checkOrigIE iface_cache) chk_ies) >>= \ chk_errs_warns -> - accumulate (map (getFixityDecl iface_cache) (bagToList ie_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 + final_vals_list = bagToList final_vals + in + (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) @@ -411,27 +561,45 @@ 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 :: 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 :: ImportNameInfo + -> Module + -> Maybe (Bool, [RdrNameIE]) + -> (Bag (FAST_STRING, RnName), + Bag (FAST_STRING, RnName), + Maybe (Bool, [RdrNameIE]) -- return IEs that had no effect + ) -getBuiltins info mod maybe_spec - | not (fromPrelude mod) +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 @@ -443,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) @@ -459,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 _) @@ -471,70 +650,105 @@ 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 +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 +------------------------------------------------ +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 - >>= \ (vals1, tcs1, errs1, warns1, imps1) -> + = 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, 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) - where - (us1, us2) = splitUniqSupply us + warns1 `unionBags` warns2) + +---------------------- +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) + avoided_fn (\ err -> (emptyBag, emptyBag, emptyBag, unitBag err, emptyBag)) (\ decl -> case initRn True mod emptyRnEnv us (setExtraRn info $ @@ -542,9 +756,23 @@ doOrigIE iface_cache info mod src_loc us ie getIfaceDeclNames ie decl) of ((vals, tcs, imps), errs, warns) -> (vals, tcs, imps, errs, warns)) + where + avoided_fn Nothing -- the thing should be in the source + = (emptyBag, emptyBag, emptyBag, emptyBag, emptyBag) + avoided_fn (Just (Left rn)) -- a builtin value brought into scope + = (unitBag rn, emptyBag, emptyBag, emptyBag, emptyBag) + avoided_fn (Just (Right rn)) -- a builtin tc/class brought into scope + = --pprTrace "avoided:Right:" (ppr PprShowAll rn) $ + (emptyBag, unitBag rn, emptyBag, emptyBag, emptyBag) + +------------------------- +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 + (\ _ -> (emptyBag, emptyBag)) (\ err -> (unitBag (\ mod locn -> err), emptyBag)) (\ decl -> case decl of TypeSig _ _ _ -> (emptyBag, unitBag (allWhenSynImpSpecWarn n)) @@ -555,53 +783,65 @@ checkOrigIE iface_cache (IEThingWith n ns, ExportAbs) checkOrigIE iface_cache (IEThingWith n ns, ExportAll) = with_decl iface_cache n + (\ _ -> (emptyBag, emptyBag)) (\ 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 "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 + -> (Maybe (Either RnName RnName) -> something) -- if avoided.. + -> (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 -> +with_decl iface_cache n do_avoid do_err do_decl + = cachedDecl iface_cache (isLexCon (nameOf n)) n >>= \ maybe_decl -> case maybe_decl of - Failed err -> return (do_err err) - Succeeded decl -> return (do_decl decl) + CachingAvoided info -> return (do_avoid info) + CachingFail err -> return (do_err err) + CachingHit decl -> return (do_decl decl) +------------- +getFixityDecl :: IfaceCache + -> RnName + -> IO (Maybe RenamedFixityDecl, Bag Error) 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 iface_cache mod >>= \ maybe_iface -> + cachedIface iface_cache True str 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) - 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} @@ -612,46 +852,55 @@ 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 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 -> + 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 ] + 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 -> @@ -689,62 +938,110 @@ 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_fn n + Just xx -> xx + Nothing -> imp_flag + + (imp_flag, imp_locs) = rec_imp_fn n - n = mkImportedName uniq rdr imp locn exp (occ_fn n) + n = mkImportedName uniq orig imp locn imp_locs exp (rec_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" + message = ppBesides [ppStr "multiple declarations of `", pprNonSym sty rdr, ppStr "'"] + + pp_dup rn = addShortErrLocLine (get_loc 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 "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 = addShortWarnLocLine locn1 (\ sty -> + ppCat [ppStr "multiple imports from module", ppPStr m1]) sty -allWhenAbsImpSpecErr n imp_mod locn sty - = ppStr "allWhenAbsImpSpecErr" + dup_item (ImportDecl m _ _ _ locn) + = addShortWarnLocLine locn (\ sty -> + ppCat [ppStr "here was another import from module", ppPStr m]) sty -withWhenAbsImpSpecErr n imp_mod locn sty - = ppStr "withWhenAbsImpSpecErr" +qualPreludeImportWarn (ImportDecl m _ _ _ locn) + = addShortWarnLocLine locn (\ sty -> + ppCat [ppStr "qualified import of prelude module", ppPStr m]) -withImpSpecErr str n has ns imp_mod locn sty - = ppStr "withImpSpecErr" +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 "'"]) + +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 + = addShortWarnLocLine 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}