X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Frename%2FRnEnv.lhs;h=91b1269a2456f87ac73ebf6dc7ce36c5c97ccd9c;hb=76ca9b9e7926e0c3f5b7c607116431c07e689813;hp=2be3bfd5c0b464e30c0a1ca339365b931f612b09;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 2be3bfd..91b1269 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -30,13 +30,14 @@ module RnEnv ( #include "HsVersions.h" -import LoadIface ( loadHomeInterface, loadSrcInterface ) +import LoadIface ( loadInterfaceForName, loadSrcInterface ) import IfaceEnv ( lookupOrig, newGlobalBinder, newIPName ) import HsSyn ( FixitySig(..), HsExpr(..), SyntaxExpr, SyntaxTable, LHsTyVarBndr, LHsType, Fixity, hsLTyVarLocNames, replaceTyVarName ) import RdrHsSyn ( extractHsTyRdrTyVars ) -import RdrName ( RdrName, rdrNameModule, isQual, isUnqual, isOrig, +import RdrName ( RdrName, isQual, isUnqual, isOrig_maybe, + isQual_maybe, mkRdrUnqual, setRdrNameSpace, rdrNameOcc, pprGlobalRdrEnv, lookupGRE_RdrName, isExact_maybe, isSrcRdrName, @@ -52,12 +53,12 @@ import Name ( Name, nameIsLocalOrFrom, mkInternalName, isWiredInName, import NameSet import OccName ( tcName, isDataOcc, pprNonVarNameSpace, occNameSpace, reportIfUnused ) -import Module ( Module ) +import Module ( Module, ModuleName ) import PrelNames ( mkUnboundName, rOOT_MAIN, iNTERACTIVE, consDataConKey, hasKey ) import UniqSupply import BasicTypes ( IPName, mapIPName ) import SrcLoc ( SrcSpan, srcSpanStart, Located(..), eqLocated, unLoc, - srcLocSpan, getLoc, combineSrcSpans, srcSpanStartLine, srcSpanEndLine ) + srcLocSpan, getLoc, combineSrcSpans, isOneLineSpan ) import Outputable import Util ( sortLe ) import ListSetOps ( removeDups ) @@ -86,14 +87,14 @@ newTopSrcBinder this_mod mb_parent (L loc rdr_name) -- data T = (,) Int Int -- unless we are in GHC.Tup ASSERT2( isExternalName name, ppr name ) - do checkErr (this_mod == nameModule name) - (badOrigBinding rdr_name) - returnM name + do { checkM (this_mod == nameModule name) + (addErrAt loc (badOrigBinding rdr_name)) + ; return name } - | isOrig rdr_name - = do checkErr (rdr_mod == this_mod || rdr_mod == rOOT_MAIN) - (badOrigBinding rdr_name) + | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name + = do { checkM (rdr_mod == this_mod || rdr_mod == rOOT_MAIN) + (addErrAt loc (badOrigBinding rdr_name)) -- When reading External Core we get Orig names as binders, -- but they should agree with the module gotten from the monad -- @@ -111,13 +112,15 @@ newTopSrcBinder this_mod mb_parent (L loc rdr_name) -- the RdrName, not from the environment. In principle, it'd be fine to -- have an arbitrary mixture of external core definitions in a single module, -- (apart from module-initialisation issues, perhaps). - newGlobalBinder rdr_mod (rdrNameOcc rdr_name) mb_parent - (srcSpanStart loc) --TODO, should pass the whole span + ; newGlobalBinder rdr_mod rdr_occ mb_parent (srcSpanStart loc) } + --TODO, should pass the whole span | otherwise - = newGlobalBinder this_mod (rdrNameOcc rdr_name) mb_parent (srcSpanStart loc) - where - rdr_mod = rdrNameModule rdr_name + = do { checkM (not (isQual rdr_name)) + (addErrAt loc (badQualBndrErr rdr_name)) + -- Binders should not be qualified; if they are, and with a different + -- module name, we we get a confusing "M.T is not in scope" error later + ; newGlobalBinder this_mod (rdrNameOcc rdr_name) mb_parent (srcSpanStart loc) } \end{code} %********************************************************* @@ -164,13 +167,12 @@ lookupTopBndrRn rdr_name | Just name <- isExact_maybe rdr_name = returnM name - | isOrig rdr_name + | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name -- This deals with the case of derived bindings, where -- we don't bother to call newTopSrcBinder first -- We assume there is no "parent" name = do { loc <- getSrcSpanM - ; newGlobalBinder (rdrNameModule rdr_name) - (rdrNameOcc rdr_name) Nothing (srcSpanStart loc) } + ; newGlobalBinder rdr_mod rdr_occ Nothing (srcSpanStart loc) } | otherwise = do { mb_gre <- lookupGreLocalRn rdr_name @@ -278,9 +280,12 @@ lookupImportedName rdr_name -- This happens in derived code = returnM n - | otherwise -- Always Orig, even when reading a .hi-boot file - = ASSERT( not (isUnqual rdr_name) ) - lookupOrig (rdrNameModule rdr_name) (rdrNameOcc rdr_name) + -- Always Orig, even when reading a .hi-boot file + | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name + = lookupOrig rdr_mod rdr_occ + + | otherwise + = pprPanic "RnEnv.lookupImportedName" (ppr rdr_name) unboundName :: RdrName -> RnM Name unboundName rdr_name @@ -337,13 +342,10 @@ lookupGreRn_help rdr_name lookup -- try to load the interface if we don't already have it. lookupQualifiedName :: RdrName -> RnM Name lookupQualifiedName rdr_name - = let - mod = rdrNameModule rdr_name - occ = rdrNameOcc rdr_name - in + | Just (mod,occ) <- isQual_maybe rdr_name -- Note: we want to behave as we would for a source file import here, -- and respect hiddenness of modules/packages, hence loadSrcInterface. - loadSrcInterface doc mod False `thenM` \ iface -> + = loadSrcInterface doc mod False `thenM` \ iface -> case [ (mod,occ) | (mod,avails) <- mi_exports iface, @@ -353,6 +355,9 @@ lookupQualifiedName rdr_name ((mod,occ):ns) -> ASSERT (null ns) lookupOrig mod occ _ -> unboundName rdr_name + + | otherwise + = pprPanic "RnEnv.lookupQualifiedName" (ppr rdr_name) where doc = ptext SLIT("Need to find") <+> ppr rdr_name \end{code} @@ -421,7 +426,7 @@ lookupFixityRn name else -- It's imported -- For imported names, we have to get their fixities by doing a - -- loadHomeInterface, and consulting the Ifaces that comes back + -- loadInterfaceForName, and consulting the Ifaces that comes back -- from that, because the interface file for the Name might not -- have been loaded yet. Why not? Suppose you import module A, -- which exports a function 'f', thus; @@ -434,9 +439,9 @@ lookupFixityRn name -- 'f', we need to know its fixity, and it's then, and only -- then, that we load B.hi. That is what's happening here. -- - -- loadHomeInterface will find B.hi even if B is a hidden module, + -- loadInterfaceForName will find B.hi even if B is a hidden module, -- and that's what we want. - loadHomeInterface doc name `thenM` \ iface -> + loadInterfaceForName doc name `thenM` \ iface -> returnM (mi_fix_fn iface (nameOccName name)) where doc = ptext SLIT("Checking fixity for") <+> ppr name @@ -444,10 +449,9 @@ lookupFixityRn name --------------- lookupTyFixityRn :: Located Name -> RnM Fixity lookupTyFixityRn (L loc n) - = doptM Opt_GlasgowExts `thenM` \ glaExts -> - when (not glaExts) - (setSrcSpan loc $ addWarn (infixTyConWarn n)) `thenM_` - lookupFixityRn n + = do { glaExts <- doptM Opt_GlasgowExts + ; when (not glaExts) (addWarnAt loc (infixTyConWarn n)) + ; lookupFixityRn n } --------------- dataTcOccs :: RdrName -> [RdrName] @@ -675,7 +679,7 @@ checkShadowing doc_str loc_rdr_names check_shadow (L loc rdr_name) | rdr_name `elemLocalRdrEnv` local_env || not (null (lookupGRE_RdrName rdr_name global_env )) - = setSrcSpan loc $ addWarn (shadowedNameWarn doc_str rdr_name) + = addWarnAt loc (shadowedNameWarn doc_str rdr_name) | otherwise = returnM () in mappM_ check_shadow loc_rdr_names @@ -705,11 +709,11 @@ mapFvRn f xs = mappM f xs `thenM` \ stuff -> %************************************************************************ \begin{code} -warnUnusedModules :: [(Module,SrcSpan)] -> RnM () +warnUnusedModules :: [(ModuleName,SrcSpan)] -> RnM () warnUnusedModules mods = ifOptM Opt_WarnUnusedImports (mappM_ bleat mods) where - bleat (mod,loc) = setSrcSpan loc $ addWarn (mk_warn mod) + bleat (mod,loc) = addWarnAt loc (mk_warn mod) mk_warn m = vcat [ptext SLIT("Module") <+> quotes (ppr m) <+> text "is imported, but nothing from it is used,", nest 2 (ptext SLIT("except perhaps instances visible in") @@ -764,10 +768,11 @@ warnUnusedName (name, prov) \end{code} \begin{code} -addNameClashErrRn rdr_name (np1:nps) +addNameClashErrRn rdr_name names = addErr (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name), ptext SLIT("It could refer to") <+> vcat (msg1 : msgs)]) where + (np1:nps) = names msg1 = ptext SLIT("either") <+> mk_ref np1 msgs = [ptext SLIT(" or") <+> mk_ref np | np <- nps] mk_ref gre = quotes (ppr (gre_name gre)) <> comma <+> pprNameProvenance gre @@ -792,19 +797,21 @@ badOrigBinding name dupNamesErr :: SDoc -> [Located RdrName] -> RnM () dupNamesErr descriptor located_names - = setSrcSpan big_loc $ - addErr (vcat [ptext SLIT("Conflicting definitions for") <+> quotes (ppr name1), - locations, - descriptor]) + = addErrAt big_loc $ + vcat [ptext SLIT("Conflicting definitions for") <+> quotes (ppr name1), + locations, descriptor] where L _ name1 = head located_names locs = map getLoc located_names big_loc = foldr1 combineSrcSpans locs - one_line = srcSpanStartLine big_loc == srcSpanEndLine big_loc + one_line = isOneLineSpan big_loc locations | one_line = empty | otherwise = ptext SLIT("Bound at:") <+> vcat (map ppr (sortLe (<=) locs)) +badQualBndrErr rdr_name + = ptext SLIT("Qualified name in binding position:") <+> ppr rdr_name + infixTyConWarn op = vcat [ftext FSLIT("Accepting non-standard infix type constructor") <+> quotes (ppr op), ftext FSLIT("Use -fglasgow-exts to avoid this warning")]