X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnEnv.lhs;h=2be3bfd5c0b464e30c0a1ca339365b931f612b09;hb=9d7da331989abcd1844e9d03b8d1e4163796fa85;hp=708f509e57328adce9f2097c23027ede43170161;hpb=98688c6e8fd33f31c51218cf93cbf03fe3a5e73d;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 708f509..2be3bfd 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -6,56 +6,64 @@ \begin{code} module RnEnv ( newTopSrcBinder, - lookupBndrRn,lookupTopBndrRn, - lookupOccRn, lookupGlobalOccRn, - lookupTopFixSigNames, lookupSrcOcc_maybe, - lookupFixityRn, lookupSigOccRn, lookupInstDeclBndr, - lookupSyntaxName, lookupSyntaxNames, lookupImportedName, + lookupLocatedBndrRn, lookupBndrRn, + lookupLocatedTopBndrRn, lookupTopBndrRn, + lookupLocatedOccRn, lookupOccRn, + lookupLocatedGlobalOccRn, lookupGlobalOccRn, + lookupLocalDataTcNames, lookupSrcOcc_maybe, + lookupFixityRn, lookupTyFixityRn, lookupLocatedSigOccRn, + lookupLocatedInstDeclBndr, + lookupSyntaxName, lookupSyntaxTable, lookupImportedName, newLocalsRn, newIPNameRn, bindLocalNames, bindLocalNamesFV, - bindLocalsRn, bindLocalsFV, bindLocatedLocalsRn, - bindPatSigTyVars, bindPatSigTyVarsFV, + bindLocatedLocalsFV, bindLocatedLocalsRn, + bindSigTyVarsFV, bindPatSigTyVars, bindPatSigTyVarsFV, bindTyVarsRn, extendTyVarEnvFVRn, bindLocalFixities, checkDupNames, mapFvRn, warnUnusedMatches, warnUnusedModules, warnUnusedImports, warnUnusedTopBinds, warnUnusedLocalBinds, - dataTcOccs, unknownNameErr + dataTcOccs, unknownNameErr, ) where #include "HsVersions.h" -import LoadIface ( loadSrcInterface ) +import LoadIface ( loadHomeInterface, loadSrcInterface ) import IfaceEnv ( lookupOrig, newGlobalBinder, newIPName ) -import HsSyn -import RdrHsSyn ( RdrNameHsType, RdrNameFixitySig, extractHsTyRdrTyVars ) -import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig, +import HsSyn ( FixitySig(..), HsExpr(..), SyntaxExpr, SyntaxTable, + LHsTyVarBndr, LHsType, + Fixity, hsLTyVarLocNames, replaceTyVarName ) +import RdrHsSyn ( extractHsTyRdrTyVars ) +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, - nameSrcLoc, nameOccName, nameModuleName, nameParent ) +import Name ( Name, nameIsLocalOrFrom, mkInternalName, isWiredInName, + nameSrcLoc, nameOccName, nameModule, nameParent, isExternalName ) import NameSet -import OccName ( tcName, isDataOcc, occNameFlavour, reportIfUnused ) -import Module ( Module, ModuleName, moduleName, mkHomeModule ) -import PrelNames ( mkUnboundName, rOOT_MAIN_Name, iNTERACTIVE ) +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 ( SrcLoc ) +import SrcLoc ( SrcSpan, srcSpanStart, Located(..), eqLocated, unLoc, + srcLocSpan, getLoc, combineSrcSpans, srcSpanStartLine, srcSpanEndLine ) import Outputable -import ListSetOps ( removeDups, equivClasses ) -import List ( nub ) -import CmdLineOpts -import FastString ( FastString ) +import Util ( sortLe ) +import ListSetOps ( removeDups ) +import List ( nubBy ) +import Monad ( when ) +import DynFlags \end{code} %********************************************************* @@ -65,29 +73,51 @@ import FastString ( FastString ) %********************************************************* \begin{code} -newTopSrcBinder :: Module -> Maybe Name -> (RdrName, SrcLoc) -> RnM Name -newTopSrcBinder mod mb_parent (rdr_name, loc) +newTopSrcBinder :: Module -> Maybe Name -> Located RdrName -> RnM Name +newTopSrcBinder this_mod mb_parent (L loc rdr_name) | Just name <- isExact_maybe rdr_name - = returnM name + = -- 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 + -- the current module is the correct one; otherwise GHC can get + -- very confused indeed. This test rejects code like + -- 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 + | isOrig rdr_name - = ASSERT( rdr_mod == moduleName mod || rdr_mod == 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 -- - -- Except for the ":Main.main = ..." definition inserted into - -- the Main module + -- We can get built-in syntax showing up here too, sadly. If you type + -- data T = (,,,) + -- the constructor is parsed as a type, and then RdrHsSyn.tyConToDataCon + -- uses setRdrNameSpace to make it into a data constructors. At that point + -- the nice Exact name for the TyCon gets swizzled to an Orig name. + -- Hence the badOrigBinding error message. -- - -- Because of this latter case, we take the module from 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, + -- Except for the ":Main.main = ..." definition inserted into + -- the Main module; ugh! + + -- Because of this latter case, we call newGlobalBinder with a module from + -- 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) (rdrNameOcc rdr_name) mb_parent loc + newGlobalBinder rdr_mod (rdrNameOcc rdr_name) mb_parent + (srcSpanStart loc) --TODO, should pass the whole span | otherwise - = newGlobalBinder mod (rdrNameOcc rdr_name) mb_parent loc + = newGlobalBinder this_mod (rdrNameOcc rdr_name) mb_parent (srcSpanStart loc) where - rdr_mod = rdrNameModule rdr_name + rdr_mod = rdrNameModule rdr_name \end{code} %********************************************************* @@ -99,12 +129,20 @@ newTopSrcBinder mod mb_parent (rdr_name, loc) Looking up a name in the RnEnv. \begin{code} +lookupLocatedBndrRn :: Located RdrName -> RnM (Located Name) +lookupLocatedBndrRn = wrapLocM lookupBndrRn + +lookupBndrRn :: RdrName -> RnM Name +-- 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 Just name -> returnM name Nothing -> lookupTopBndrRn rdr_name +lookupLocatedTopBndrRn :: Located RdrName -> RnM (Located Name) +lookupLocatedTopBndrRn = wrapLocM lookupTopBndrRn + lookupTopBndrRn :: RdrName -> RnM Name -- Look up a top-level source-code binder. We may be looking up an unqualified 'f', -- and there may be several imported 'f's too, which must not confuse us. @@ -124,28 +162,15 @@ lookupTopBndrRn :: RdrName -> RnM Name lookupTopBndrRn rdr_name | Just name <- isExact_maybe rdr_name - -- This is here just to catch the PrelBase defn of (say) [] and similar - -- The parser reads the special syntax and returns an Exact RdrName - -- But the global_env contains only Qual RdrNames, so we won't - -- find it there; instead just get the name via the Orig route - -- - -- 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 - -- data T = (,) Int Int - -- unless we are in GHC.Tup - = getModule `thenM` \ mod -> - checkErr (moduleName mod == nameModuleName name) - (badOrigBinding rdr_name) `thenM_` - returnM name + = returnM name | isOrig 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 - = getSrcLocM `thenM` \ loc -> - newGlobalBinder (mkHomeModule (rdrNameModule rdr_name)) - (rdrNameOcc rdr_name) Nothing loc + = do { loc <- getSrcSpanM + ; newGlobalBinder (rdrNameModule rdr_name) + (rdrNameOcc rdr_name) Nothing (srcSpanStart loc) } | otherwise = do { mb_gre <- lookupGreLocalRn rdr_name @@ -153,7 +178,7 @@ lookupTopBndrRn rdr_name Nothing -> unboundName rdr_name Just gre -> returnM (gre_name gre) } --- lookupSigOccRn is used for type signatures and pragmas +-- lookupLocatedSigOccRn is used for type signatures and pragmas -- Is this valid? -- module A -- import M( f ) @@ -163,13 +188,16 @@ lookupTopBndrRn rdr_name -- The Haskell98 report does not stipulate this, but it will! -- So we must treat the 'f' in the signature in the same way -- as the binding occurrence of 'f', using lookupBndrRn -lookupSigOccRn :: RdrName -> RnM Name -lookupSigOccRn = lookupBndrRn +lookupLocatedSigOccRn :: Located RdrName -> RnM (Located Name) +lookupLocatedSigOccRn = lookupLocatedBndrRn -- lookupInstDeclBndr is used for the binders in an -- instance declaration. Here we use the class name to -- disambiguate. +lookupLocatedInstDeclBndr :: Name -> Located RdrName -> RnM (Located Name) +lookupLocatedInstDeclBndr cls = wrapLocM (lookupInstDeclBndr cls) + lookupInstDeclBndr :: Name -> RdrName -> RnM Name lookupInstDeclBndr cls_name rdr_name | isUnqual rdr_name -- Find all the things the rdr-name maps to @@ -196,6 +224,9 @@ newIPNameRn ip_rdr = newIPName (mapIPName rdrNameOcc ip_rdr) -- Occurrences -------------------------------------------------- +lookupLocatedOccRn :: Located RdrName -> RnM (Located Name) +lookupLocatedOccRn = wrapLocM lookupOccRn + -- lookupOccRn looks up an occurrence of a RdrName lookupOccRn :: RdrName -> RnM Name lookupOccRn rdr_name @@ -204,6 +235,9 @@ lookupOccRn rdr_name Just name -> returnM name Nothing -> lookupGlobalOccRn rdr_name +lookupLocatedGlobalOccRn :: Located RdrName -> RnM (Located Name) +lookupLocatedGlobalOccRn = wrapLocM lookupGlobalOccRn + lookupGlobalOccRn :: RdrName -> RnM Name -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global -- environment. It's used only for @@ -222,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 -> @@ -282,7 +316,7 @@ lookupGreLocalRn rdr_name where lookup_fn env = filter isLocalGRE (lookupGRE_RdrName rdr_name env) -lookupGreRn_help :: RdrName -- Only used in error message +lookupGreRn_help :: RdrName -- Only used in error message -> (GlobalRdrEnv -> [GlobalRdrElt]) -- Lookup function -> RnM (Maybe GlobalRdrElt) -- Checks for exactly one match; reports deprecations @@ -291,10 +325,7 @@ lookupGreRn_help rdr_name lookup = do { env <- getGlobalRdrEnv ; case lookup env of [] -> returnM Nothing - [gre] -> case gre_deprec gre of - Nothing -> returnM (Just gre) - Just _ -> do { warnDeprec gre - ; returnM (Just gre) } + [gre] -> returnM (Just gre) gres -> do { addNameClashErrRn rdr_name gres ; returnM (Just (head gres)) } } @@ -310,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) | @@ -331,19 +364,24 @@ 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 :: [RdrNameFixitySig] -> RnM a -> RnM a +bindLocalFixities :: [FixitySig RdrName] -> RnM a -> RnM a -- Used for nested fixity decls -- No need to worry about type constructors here, -- Should check for duplicates but we don't @@ -352,10 +390,9 @@ bindLocalFixities fixes thing_inside | otherwise = mappM rn_sig fixes `thenM` \ new_bit -> extendFixityEnv new_bit thing_inside where - rn_sig (FixitySig v fix src_loc) - = addSrcLoc src_loc $ - lookupSigOccRn v `thenM` \ new_v -> - returnM (new_v, (FixItem (rdrNameOcc v) fix src_loc)) + rn_sig (FixitySig lv@(L loc v) fix) + = addLocM lookupBndrRn lv `thenM` \ new_v -> + returnM (new_v, (FixItem (rdrNameOcc v) fix loc)) \end{code} -------------------------------- @@ -396,26 +433,43 @@ 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 -- looking at. --- --- ToDo: If the user typed "[]" or "(,,)", we'll generate an Exact RdrName, --- and we don't have a systematic way to find the TyCon's Name from --- the DataCon's name. Sigh dataTcOccs rdr_name - | isDataOcc occ = [rdr_name_tc, rdr_name] - | otherwise = [rdr_name] + | Just n <- isExact_maybe rdr_name -- Ghastly special case + , n `hasKey` consDataConKey = [rdr_name] -- see note below + | isDataOcc occ = [rdr_name_tc, rdr_name] + | otherwise = [rdr_name] where occ = rdrNameOcc rdr_name rdr_name_tc = setRdrNameSpace rdr_name tcName + +-- If the user typed "[]" or "(,,)", we'll generate an Exact RdrName, +-- and setRdrNameSpace generates an Orig, which is fine +-- But it's not fine for (:), because there *is* no corresponding type +-- constructor. If we generate an Orig tycon for GHC.Base.(:), it'll +-- appear to be in scope (because Orig's simply allocate a new name-cache +-- entry) and then we get an error when we use dataTcOccs in +-- TcRnDriver.tcRnGetInfo. Large sigh. \end{code} %************************************************************************ @@ -448,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 @@ -458,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 -> @@ -492,29 +546,25 @@ lookupSyntaxNames std_names %********************************************************* \begin{code} -newLocalsRn :: [(RdrName,SrcLoc)] - -> RnM [Name] +newLocalsRn :: [Located RdrName] -> RnM [Name] newLocalsRn rdr_names_w_loc - = newUniqueSupply `thenM` \ us -> - let - uniqs = uniqsFromSupply us - names = [ mkInternalName uniq (rdrNameOcc rdr_name) loc - | ((rdr_name,loc), uniq) <- rdr_names_w_loc `zip` uniqs - ] - in - returnM names - + = newUniqueSupply `thenM` \ us -> + returnM (zipWith mk rdr_names_w_loc (uniqsFromSupply us)) + where + mk (L loc rdr_name) uniq + | Just name <- isExact_maybe rdr_name = name + -- This happens in code generated by Template Haskell + | otherwise = ASSERT2( isUnqual rdr_name, ppr rdr_name ) + -- We only bind unqualified names here + -- lookupRdrEnv doesn't even attempt to look up a qualified RdrName + mkInternalName uniq (rdrNameOcc rdr_name) (srcSpanStart loc) bindLocatedLocalsRn :: SDoc -- Documentation string for error message - -> [(RdrName,SrcLoc)] + -> [Located RdrName] -> ([Name] -> RnM a) -> RnM a bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope - = ASSERT2( all (isUnqual . fst) rdr_names_w_loc, ppr rdr_names_w_loc ) - -- We only bind unqualified names here - -- lookupRdrEnv doesn't even attempt to look up a qualified RdrName - - -- Check for duplicate names + = -- Check for duplicate names checkDupNames doc_str rdr_names_w_loc `thenM_` -- Warn about shadowing, but only in source modules @@ -528,71 +578,64 @@ 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) } ------------------------------------- -bindLocalsRn doc rdr_names enclosed_scope - = getSrcLocM `thenM` \ loc -> - bindLocatedLocalsRn doc - (rdr_names `zip` repeat loc) - enclosed_scope - -- binLocalsFVRn is the same as bindLocalsRn -- except that it deals with free vars -bindLocalsFV doc rdr_names enclosed_scope - = bindLocalsRn doc rdr_names $ \ names -> +bindLocatedLocalsFV :: SDoc -> [Located RdrName] -> ([Name] -> RnM (a,FreeVars)) + -> RnM (a, FreeVars) +bindLocatedLocalsFV doc rdr_names enclosed_scope + = bindLocatedLocalsRn doc rdr_names $ \ names -> enclosed_scope names `thenM` \ (thing, fvs) -> 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 -> [HsTyVarBndr RdrName] - -> ([HsTyVarBndr Name] -> RnM a) +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 - = getSrcLocM `thenM` \ loc -> - let - located_tyvars = [(hsTyVarName tv, loc) | tv <- tyvar_names] + = let + located_tyvars = hsLTyVarLocNames tyvar_names in bindLocatedLocalsRn doc_str located_tyvars $ \ names -> - enclosed_scope (zipWith replaceTyVarName tyvar_names names) + enclosed_scope (zipWith replace tyvar_names names) + where + replace (L loc n1) n2 = L loc (replaceTyVarName n1 n2) -bindPatSigTyVars :: [RdrNameHsType] -> ([Name] -> RnM a) -> RnM a +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 -> - getSrcLocM `thenM` \ loc -> - let - forall_tyvars = nub [ tv | ty <- tys, - tv <- extractHsTyRdrTyVars ty, - not (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! - located_tyvars = [(tv, loc) | tv <- forall_tyvars] - 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 :: [RdrNameHsType] +bindPatSigTyVarsFV :: [LHsType RdrName] -> RnM (a, FreeVars) -> RnM (a, FreeVars) bindPatSigTyVarsFV tys thing_inside @@ -600,28 +643,42 @@ 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 - -> [(RdrName, SrcLoc)] + -> [Located RdrName] -> RnM () checkDupNames doc_str rdr_names_w_loc = -- Check for duplicated names in a binding group mappM_ (dupNamesErr doc_str) dups where - (_, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `compare` n2) rdr_names_w_loc + (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc ------------------------------------- -checkShadowing doc_str rdr_names_w_loc +checkShadowing doc_str loc_rdr_names = getLocalRdrEnv `thenM` \ local_env -> getGlobalRdrEnv `thenM` \ global_env -> let - check_shadow (rdr_name,loc) + check_shadow (L loc rdr_name) | rdr_name `elemLocalRdrEnv` local_env || not (null (lookupGRE_RdrName rdr_name global_env )) - = addSrcLoc loc $ addWarn (shadowedNameWarn doc_str rdr_name) + = setSrcSpan loc $ addWarn (shadowedNameWarn doc_str rdr_name) | otherwise = returnM () in - mappM_ check_shadow rdr_names_w_loc + mappM_ check_shadow loc_rdr_names \end{code} @@ -648,14 +705,18 @@ mapFvRn f xs = mappM f xs `thenM` \ stuff -> %************************************************************************ \begin{code} -warnUnusedModules :: [ModuleName] -> RnM () +warnUnusedModules :: [(Module,SrcSpan)] -> RnM () warnUnusedModules mods - = ifOptM Opt_WarnUnusedImports (mappM_ (addWarn . unused_mod) mods) + = ifOptM Opt_WarnUnusedImports (mappM_ bleat mods) where - unused_mod 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) @@ -667,35 +728,36 @@ warnUnusedMatches names = ifOptM Opt_WarnUnusedMatches (warnUnusedLocals name ------------------------- -- Helpers -warnUnusedGREs gres = warnUnusedBinds [(n,Just p) | GRE {gre_name = n, gre_prov = p} <- gres] -warnUnusedLocals names = warnUnusedBinds [(n,Nothing) | n<-names] +warnUnusedGREs gres + = warnUnusedBinds [(n,Just p) | GRE {gre_name = n, gre_prov = p} <- gres] -warnUnusedBinds :: [(Name,Maybe Provenance)] -> RnM () -warnUnusedBinds names - = mappM_ warnUnusedGroup groups - where - -- Group by provenance - groups = equivClasses cmp (filter reportable names) - (_,prov1) `cmp` (_,prov2) = prov1 `compare` prov2 - - reportable (name,_) = reportIfUnused (nameOccName name) +warnUnusedLocals names + = warnUnusedBinds [(n,Nothing) | n<-names] +warnUnusedBinds :: [(Name,Maybe Provenance)] -> RnM () +warnUnusedBinds names = mappM_ warnUnusedName (filter reportable names) + 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) ------------------------- -warnUnusedGroup :: [(Name,Maybe Provenance)] -> RnM () -warnUnusedGroup names - = addSrcLoc def_loc $ - addWarn $ - sep [msg <> colon, nest 4 (fsep (punctuate comma (map (ppr.fst) names)))] +warnUnusedName :: (Name, Maybe Provenance) -> RnM () +warnUnusedName (name, prov) + = addWarnAt loc $ + sep [msg <> colon, + nest 2 $ pprNonVarNameSpace (occNameSpace (nameOccName name)) + <+> quotes (ppr name)] + -- TODO should be a proper span where - (name1, prov1) = head names - loc1 = nameSrcLoc name1 - (def_loc, msg) = case prov1 of - Just (Imported is _) -> (is_loc imp_spec, imp_from (is_mod imp_spec)) - where - imp_spec = head is - other -> (loc1, unused_msg) + (loc,msg) = case prov of + 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" @@ -716,10 +778,10 @@ shadowedNameWarn doc shadow ptext SLIT("shadows an existing binding")] $$ doc -unknownNameErr name - = sep [text flavour <+> ptext SLIT("not in scope:"), quotes (ppr name)] - where - flavour = occNameFlavour (rdrNameOcc name) +unknownNameErr rdr_name + = sep [ptext SLIT("Not in scope:"), + 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) @@ -728,15 +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 ((name,loc) : dup_things) - = addSrcLoc loc $ - addErr ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name)) - $$ - descriptor) -warnDeprec :: GlobalRdrElt -> RnM () -warnDeprec (GRE {gre_name = name, gre_deprec = Just txt}) - = ifOptM Opt_WarnDeprecations $ - addWarn (sep [ text (occNameFlavour (nameOccName name)) <+> - quotes (ppr name) <+> text "is deprecated:", - nest 4 (ppr txt) ]) +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}