X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnEnv.lhs;h=2be3bfd5c0b464e30c0a1ca339365b931f612b09;hb=9d7da331989abcd1844e9d03b8d1e4163796fa85;hp=c9e48cbfca90114439d88861eb4602e06691f3fb;hpb=0e2c58247410a9317064bbddbf294644c0300b14;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index c9e48cb..2be3bfd 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -10,15 +10,15 @@ module RnEnv ( lookupLocatedTopBndrRn, lookupTopBndrRn, lookupLocatedOccRn, lookupOccRn, lookupLocatedGlobalOccRn, lookupGlobalOccRn, - lookupTopFixSigNames, lookupSrcOcc_maybe, - lookupFixityRn, lookupLocatedSigOccRn, + lookupLocalDataTcNames, lookupSrcOcc_maybe, + lookupFixityRn, lookupTyFixityRn, lookupLocatedSigOccRn, lookupLocatedInstDeclBndr, - lookupSyntaxName, lookupSyntaxNames, lookupImportedName, + lookupSyntaxName, lookupSyntaxTable, lookupImportedName, newLocalsRn, newIPNameRn, bindLocalNames, bindLocalNamesFV, bindLocatedLocalsFV, bindLocatedLocalsRn, - bindPatSigTyVars, bindPatSigTyVarsFV, + bindSigTyVarsFV, bindPatSigTyVars, bindPatSigTyVarsFV, bindTyVarsRn, extendTyVarEnvFVRn, bindLocalFixities, @@ -30,37 +30,40 @@ module RnEnv ( #include "HsVersions.h" -import LoadIface ( loadSrcInterface ) +import LoadIface ( loadHomeInterface, loadSrcInterface ) import IfaceEnv ( lookupOrig, newGlobalBinder, newIPName ) -import HsSyn +import HsSyn ( FixitySig(..), HsExpr(..), SyntaxExpr, SyntaxTable, + LHsTyVarBndr, LHsType, + Fixity, hsLTyVarLocNames, replaceTyVarName ) import RdrHsSyn ( extractHsTyRdrTyVars ) -import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig, +import RdrName ( RdrName, rdrNameModule, isQual, isUnqual, isOrig, mkRdrUnqual, setRdrNameSpace, rdrNameOcc, pprGlobalRdrEnv, lookupGRE_RdrName, isExact_maybe, isSrcRdrName, GlobalRdrElt(..), GlobalRdrEnv, lookupGlobalRdrEnv, isLocalGRE, extendLocalRdrEnv, elemLocalRdrEnv, lookupLocalRdrEnv, - Provenance(..), pprNameProvenance, ImportSpec(..) + Provenance(..), pprNameProvenance, + importSpecLoc, importSpecModule ) -import HsTypes ( hsTyVarName, replaceTyVarName ) import HscTypes ( availNames, ModIface(..), FixItem(..), lookupFixity ) import TcRnMonad -import Name ( Name, nameIsLocalOrFrom, mkInternalName, isInternalName, - nameSrcLoc, nameOccName, nameModuleName, nameParent ) +import Name ( Name, nameIsLocalOrFrom, mkInternalName, isWiredInName, + nameSrcLoc, nameOccName, nameModule, nameParent, isExternalName ) import NameSet -import OccName ( tcName, isDataOcc, occNameFlavour, reportIfUnused, - isVarOcc ) -import Module ( Module, ModuleName, moduleName, mkHomeModule ) -import PrelNames ( mkUnboundName, rOOT_MAIN_Name, iNTERACTIVE, consDataConKey, hasKey ) +import OccName ( tcName, isDataOcc, pprNonVarNameSpace, occNameSpace, + reportIfUnused ) +import Module ( Module ) +import PrelNames ( mkUnboundName, rOOT_MAIN, iNTERACTIVE, consDataConKey, hasKey ) import UniqSupply import BasicTypes ( IPName, mapIPName ) import SrcLoc ( SrcSpan, srcSpanStart, Located(..), eqLocated, unLoc, - srcLocSpan ) + srcLocSpan, getLoc, combineSrcSpans, srcSpanStartLine, srcSpanEndLine ) import Outputable +import Util ( sortLe ) import ListSetOps ( removeDups ) import List ( nubBy ) -import CmdLineOpts -import FastString ( FastString ) +import Monad ( when ) +import DynFlags \end{code} %********************************************************* @@ -73,22 +76,23 @@ import FastString ( FastString ) newTopSrcBinder :: Module -> Maybe Name -> Located RdrName -> RnM Name newTopSrcBinder this_mod mb_parent (L loc rdr_name) | Just name <- isExact_maybe rdr_name - -- This is here to catch + = -- This is here to catch -- (a) Exact-name binders created by Template Haskell -- (b) The PrelBase defn of (say) [] and similar, for which -- the parser reads the special syntax and returns an Exact RdrName - -- - -- We are at a binding site for the name, so check first that it + -- We are at a binding site for the name, so check first that it -- the current module is the correct one; otherwise GHC can get - -- very confused indeed. This test rejects code like + -- very confused indeed. This test rejects code like -- data T = (,) Int Int -- unless we are in GHC.Tup - = do checkErr (isInternalName name || this_mod_name == nameModuleName name) + ASSERT2( isExternalName name, ppr name ) + do checkErr (this_mod == nameModule name) (badOrigBinding rdr_name) returnM name + | isOrig rdr_name - = do checkErr (rdr_mod_name == this_mod_name || rdr_mod_name == rOOT_MAIN_Name) + = do checkErr (rdr_mod == this_mod || rdr_mod == rOOT_MAIN) (badOrigBinding rdr_name) -- When reading External Core we get Orig names as binders, -- but they should agree with the module gotten from the monad @@ -107,14 +111,13 @@ 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 (mkHomeModule rdr_mod_name) (rdrNameOcc rdr_name) mb_parent + newGlobalBinder rdr_mod (rdrNameOcc rdr_name) mb_parent (srcSpanStart loc) --TODO, should pass the whole span | otherwise = newGlobalBinder this_mod (rdrNameOcc rdr_name) mb_parent (srcSpanStart loc) where - this_mod_name = moduleName this_mod - rdr_mod_name = rdrNameModule rdr_name + rdr_mod = rdrNameModule rdr_name \end{code} %********************************************************* @@ -130,7 +133,7 @@ lookupLocatedBndrRn :: Located RdrName -> RnM (Located Name) lookupLocatedBndrRn = wrapLocM lookupBndrRn lookupBndrRn :: RdrName -> RnM Name --- NOTE: assumes that the SrcSpan of the binder has already been addSrcSpan'd +-- NOTE: assumes that the SrcSpan of the binder has already been setSrcSpan'd lookupBndrRn rdr_name = getLocalRdrEnv `thenM` \ local_env -> case lookupLocalRdrEnv local_env rdr_name of @@ -166,7 +169,7 @@ lookupTopBndrRn rdr_name -- we don't bother to call newTopSrcBinder first -- We assume there is no "parent" name = do { loc <- getSrcSpanM - ; newGlobalBinder (mkHomeModule (rdrNameModule rdr_name)) + ; newGlobalBinder (rdrNameModule rdr_name) (rdrNameOcc rdr_name) Nothing (srcSpanStart loc) } | otherwise @@ -253,7 +256,7 @@ lookupGlobalOccRn rdr_name Nothing -> -- We allow qualified names on the command line to refer to - -- *any* name exported by any module in scope, just as if + -- *any* name exported by any module in scope, just as if -- there was an "import qualified M" declaration for every -- module. getModule `thenM` \ mod -> @@ -338,6 +341,8 @@ lookupQualifiedName rdr_name mod = rdrNameModule rdr_name occ = rdrNameOcc rdr_name in + -- 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 -> case [ (mod,occ) | @@ -359,16 +364,21 @@ lookupQualifiedName rdr_name %********************************************************* \begin{code} -lookupTopFixSigNames :: RdrName -> RnM [Name] +lookupLocalDataTcNames :: RdrName -> RnM [Name] -- GHC extension: look up both the tycon and data con -- for con-like things -lookupTopFixSigNames rdr_name +-- Complain if neither is in scope +lookupLocalDataTcNames rdr_name | Just n <- isExact_maybe rdr_name -- Special case for (:), which doesn't get into the GlobalRdrEnv = return [n] -- For this we don't need to try the tycon too | otherwise = do { mb_gres <- mapM lookupGreLocalRn (dataTcOccs rdr_name) - ; return [gre_name gre | Just gre <- mb_gres] } + ; case [gre_name gre | Just gre <- mb_gres] of + [] -> do { addErr (unknownNameErr rdr_name) + ; return [] } + names -> return names + } -------------------------------- bindLocalFixities :: [FixitySig RdrName] -> RnM a -> RnM a @@ -423,12 +433,23 @@ lookupFixityRn name -- nothing from B will be used). When we come across a use of -- '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. - loadSrcInterface doc name_mod False `thenM` \ iface -> + -- + -- loadHomeInterface will find B.hi even if B is a hidden module, + -- and that's what we want. + loadHomeInterface doc name `thenM` \ iface -> returnM (mi_fix_fn iface (nameOccName name)) where - doc = ptext SLIT("Checking fixity for") <+> ppr name - name_mod = nameModuleName name + doc = ptext SLIT("Checking fixity for") <+> ppr 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 + +--------------- dataTcOccs :: RdrName -> [RdrName] -- If the input is a data constructor, return both it and a type -- constructor. This is useful when we aren't sure which we are @@ -481,7 +502,7 @@ At the moment this just happens for We store the relevant Name in the HsSyn tree, in * HsIntegral/HsFractional * NegApp - * NPlusKPatIn + * NPlusKPat * HsDo respectively. Initially, we just store the "standard" name (PrelNames.fromIntegralName, fromRationalName etc), but the renamer changes this to the appropriate user @@ -491,23 +512,23 @@ We treat the orignal (standard) names as free-vars too, because the type checker checks the type of the user thing against the type of the standard thing. \begin{code} -lookupSyntaxName :: Name -- The standard name - -> RnM (Name, FreeVars) -- Possibly a non-standard name +lookupSyntaxName :: Name -- The standard name + -> RnM (SyntaxExpr Name, FreeVars) -- Possibly a non-standard name lookupSyntaxName std_name - = doptM Opt_NoImplicitPrelude `thenM` \ no_prelude -> - if not no_prelude then normal_case + = doptM Opt_ImplicitPrelude `thenM` \ implicit_prelude -> + if implicit_prelude then normal_case else -- Get the similarly named thing from the local environment lookupOccRn (mkRdrUnqual (nameOccName std_name)) `thenM` \ usr_name -> - returnM (usr_name, unitFV usr_name) + returnM (HsVar usr_name, unitFV usr_name) where - normal_case = returnM (std_name, emptyFVs) + normal_case = returnM (HsVar std_name, emptyFVs) -lookupSyntaxNames :: [Name] -- Standard names - -> RnM (ReboundNames Name, FreeVars) -- See comments with HsExpr.ReboundNames -lookupSyntaxNames std_names - = doptM Opt_NoImplicitPrelude `thenM` \ no_prelude -> - if not no_prelude then normal_case +lookupSyntaxTable :: [Name] -- Standard names + -> RnM (SyntaxTable Name, FreeVars) -- See comments with HsExpr.ReboundNames +lookupSyntaxTable std_names + = doptM Opt_ImplicitPrelude `thenM` \ implicit_prelude -> + if implicit_prelude then normal_case else -- Get the similarly named thing from the local environment mappM (lookupOccRn . mkRdrUnqual . nameOccName) std_names `thenM` \ usr_names -> @@ -557,15 +578,16 @@ bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope (enclosed_scope names) +bindLocalNames :: [Name] -> RnM a -> RnM a bindLocalNames names enclosed_scope = getLocalRdrEnv `thenM` \ name_env -> setLocalRdrEnv (extendLocalRdrEnv name_env names) enclosed_scope +bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) bindLocalNamesFV names enclosed_scope - = bindLocalNames names $ - enclosed_scope `thenM` \ (thing, fvs) -> - returnM (thing, delListFromNameSet fvs names) + = do { (result, fvs) <- bindLocalNames names enclosed_scope + ; returnM (result, delListFromNameSet fvs names) } ------------------------------------- @@ -579,18 +601,13 @@ bindLocatedLocalsFV doc rdr_names enclosed_scope returnM (thing, delListFromNameSet fvs names) ------------------------------------- -extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) - -- This tiresome function is used only in rnSourceDecl on InstDecl -extendTyVarEnvFVRn tyvars enclosed_scope - = bindLocalNames tyvars enclosed_scope `thenM` \ (thing, fvs) -> - returnM (thing, delListFromNameSet fvs tyvars) - bindTyVarsRn :: SDoc -> [LHsTyVarBndr RdrName] -> ([LHsTyVarBndr Name] -> RnM a) -> RnM a +-- Haskell-98 binding of type variables; e.g. within a data type decl bindTyVarsRn doc_str tyvar_names enclosed_scope = let - located_tyvars = [L loc (hsTyVarName tv) | L loc tv <- tyvar_names] + located_tyvars = hsLTyVarLocNames tyvar_names in bindLocatedLocalsRn doc_str located_tyvars $ \ names -> enclosed_scope (zipWith replace tyvar_names names) @@ -601,19 +618,22 @@ bindPatSigTyVars :: [LHsType RdrName] -> ([Name] -> RnM a) -> RnM a -- Find the type variables in the pattern type -- signatures that must be brought into scope bindPatSigTyVars tys thing_inside - = getLocalRdrEnv `thenM` \ name_env -> - let - located_tyvars = nubBy eqLocated [ tv | ty <- tys, - tv <- extractHsTyRdrTyVars ty, - not (unLoc tv `elemLocalRdrEnv` name_env) - ] + = do { scoped_tyvars <- doptM Opt_ScopedTypeVariables + ; if not scoped_tyvars then + thing_inside [] + else + do { name_env <- getLocalRdrEnv + ; let locd_tvs = [ tv | ty <- tys + , tv <- extractHsTyRdrTyVars ty + , not (unLoc tv `elemLocalRdrEnv` name_env) ] + nubbed_tvs = nubBy eqLocated locd_tvs -- The 'nub' is important. For example: -- f (x :: t) (y :: t) = .... -- We don't want to complain about binding t twice! - doc_sig = text "In a pattern type-signature" - in - bindLocatedLocalsRn doc_sig located_tyvars thing_inside + ; bindLocatedLocalsRn doc_sig nubbed_tvs thing_inside }} + where + doc_sig = text "In a pattern type-signature" bindPatSigTyVarsFV :: [LHsType RdrName] -> RnM (a, FreeVars) @@ -623,6 +643,20 @@ bindPatSigTyVarsFV tys thing_inside thing_inside `thenM` \ (result,fvs) -> returnM (result, fvs `delListFromNameSet` tvs) +bindSigTyVarsFV :: [Name] + -> RnM (a, FreeVars) + -> RnM (a, FreeVars) +bindSigTyVarsFV tvs thing_inside + = do { scoped_tyvars <- doptM Opt_ScopedTypeVariables + ; if not scoped_tyvars then + thing_inside + else + bindLocalNamesFV tvs thing_inside } + +extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) + -- This function is used only in rnSourceDecl on InstDecl +extendTyVarEnvFVRn tyvars thing_inside = bindLocalNamesFV tyvars thing_inside + ------------------------------------- checkDupNames :: SDoc -> [Located RdrName] @@ -641,7 +675,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 )) - = addSrcSpan loc $ addWarn (shadowedNameWarn doc_str rdr_name) + = setSrcSpan loc $ addWarn (shadowedNameWarn doc_str rdr_name) | otherwise = returnM () in mappM_ check_shadow loc_rdr_names @@ -671,15 +705,18 @@ mapFvRn f xs = mappM f xs `thenM` \ stuff -> %************************************************************************ \begin{code} -warnUnusedModules :: [(ModuleName,SrcSpan)] -> RnM () +warnUnusedModules :: [(Module,SrcSpan)] -> RnM () warnUnusedModules mods = ifOptM Opt_WarnUnusedImports (mappM_ bleat mods) where - bleat (mod,loc) = addSrcSpan loc $ addWarn (mk_warn mod) - mk_warn m = vcat [ptext SLIT("Module") <+> quotes (ppr m) <+> - text "is imported, but nothing from it is used", - parens (ptext SLIT("except perhaps instances visible in") <+> - quotes (ppr m))] + bleat (mod,loc) = setSrcSpan loc $ addWarn (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") + <+> quotes (ppr m)), + ptext SLIT("To suppress this warning, use:") + <+> ptext SLIT("import") <+> ppr m <> parens empty ] + warnUnusedImports, warnUnusedTopBinds :: [GlobalRdrElt] -> RnM () warnUnusedImports gres = ifOptM Opt_WarnUnusedImports (warnUnusedGREs gres) @@ -699,7 +736,11 @@ warnUnusedLocals names warnUnusedBinds :: [(Name,Maybe Provenance)] -> RnM () warnUnusedBinds names = mappM_ warnUnusedName (filter reportable names) - where reportable (name,_) = reportIfUnused (nameOccName name) + where reportable (name,_) + | isWiredInName name = False -- Don't report unused wired-in names + -- Otherwise we get a zillion warnings + -- from Data.Tuple + | otherwise = reportIfUnused (nameOccName name) ------------------------- @@ -707,16 +748,16 @@ warnUnusedName :: (Name, Maybe Provenance) -> RnM () warnUnusedName (name, prov) = addWarnAt loc $ sep [msg <> colon, - nest 2 $ occNameFlavour (nameOccName name) <+> quotes (ppr name)] + nest 2 $ pprNonVarNameSpace (occNameSpace (nameOccName name)) + <+> quotes (ppr name)] -- TODO should be a proper span where (loc,msg) = case prov of - Just (Imported is _) -> - ( is_loc (head is), imp_from (is_mod imp_spec) ) - where - imp_spec = head is - other -> - ( srcLocSpan (nameSrcLoc name), unused_msg ) + Just (Imported is) + -> (importSpecLoc imp_spec, imp_from (importSpecModule imp_spec)) + where + imp_spec = head is + other -> (srcLocSpan (nameSrcLoc name), unused_msg) unused_msg = text "Defined but not used" imp_from mod = text "Imported from" <+> quotes (ppr mod) <+> text "but not used" @@ -739,7 +780,8 @@ shadowedNameWarn doc shadow unknownNameErr rdr_name = sep [ptext SLIT("Not in scope:"), - nest 2 $ occNameFlavour (rdrNameOcc rdr_name) <+> quotes (ppr rdr_name)] + nest 2 $ pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name)) + <+> quotes (ppr rdr_name)] unknownInstBndrErr cls op = quotes (ppr op) <+> ptext SLIT("is not a (visible) method of class") <+> quotes (ppr cls) @@ -748,9 +790,22 @@ badOrigBinding name = ptext SLIT("Illegal binding of built-in syntax:") <+> ppr (rdrNameOcc name) -- The rdrNameOcc is because we don't want to print Prelude.(,) -dupNamesErr descriptor (L loc name : dup_things) - = addSrcSpan loc $ - addErr ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name)) - $$ - descriptor) +dupNamesErr :: SDoc -> [Located RdrName] -> RnM () +dupNamesErr descriptor located_names + = setSrcSpan big_loc $ + addErr (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 + locations | one_line = empty + | otherwise = ptext SLIT("Bound at:") <+> + vcat (map ppr (sortLe (<=) locs)) + +infixTyConWarn op + = vcat [ftext FSLIT("Accepting non-standard infix type constructor") <+> quotes (ppr op), + ftext FSLIT("Use -fglasgow-exts to avoid this warning")] \end{code}