X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnEnv.lhs;h=2be3bfd5c0b464e30c0a1ca339365b931f612b09;hb=9d7da331989abcd1844e9d03b8d1e4163796fa85;hp=116f9de41193e88a59ca42bf32b58466b9ca40b4;hpb=d551dbfef0b710f5ede21ee0c54ee7e80dd53b64;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 116f9de..2be3bfd 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -10,8 +10,8 @@ module RnEnv ( lookupLocatedTopBndrRn, lookupTopBndrRn, lookupLocatedOccRn, lookupOccRn, lookupLocatedGlobalOccRn, lookupGlobalOccRn, - lookupTopFixSigNames, lookupSrcOcc_maybe, - lookupFixityRn, lookupLocatedSigOccRn, + lookupLocalDataTcNames, lookupSrcOcc_maybe, + lookupFixityRn, lookupTyFixityRn, lookupLocatedSigOccRn, lookupLocatedInstDeclBndr, lookupSyntaxName, lookupSyntaxTable, lookupImportedName, @@ -33,8 +33,8 @@ module RnEnv ( import LoadIface ( loadHomeInterface, loadSrcInterface ) import IfaceEnv ( lookupOrig, newGlobalBinder, newIPName ) import HsSyn ( FixitySig(..), HsExpr(..), SyntaxExpr, SyntaxTable, - HsType(..), HsExplicitForAll(..), LHsTyVarBndr, LHsType, - LSig, Sig(..), Fixity, hsLTyVarName, hsLTyVarLocNames, replaceTyVarName ) + LHsTyVarBndr, LHsType, + Fixity, hsLTyVarLocNames, replaceTyVarName ) import RdrHsSyn ( extractHsTyRdrTyVars ) import RdrName ( RdrName, rdrNameModule, isQual, isUnqual, isOrig, mkRdrUnqual, setRdrNameSpace, rdrNameOcc, @@ -42,14 +42,16 @@ import RdrName ( RdrName, rdrNameModule, isQual, isUnqual, isOrig, isExact_maybe, isSrcRdrName, GlobalRdrElt(..), GlobalRdrEnv, lookupGlobalRdrEnv, isLocalGRE, extendLocalRdrEnv, elemLocalRdrEnv, lookupLocalRdrEnv, - Provenance(..), pprNameProvenance, ImportSpec(..) + Provenance(..), pprNameProvenance, + importSpecLoc, importSpecModule ) import HscTypes ( availNames, ModIface(..), FixItem(..), lookupFixity ) import TcRnMonad -import Name ( Name, nameIsLocalOrFrom, mkInternalName, +import Name ( Name, nameIsLocalOrFrom, mkInternalName, isWiredInName, nameSrcLoc, nameOccName, nameModule, nameParent, isExternalName ) import NameSet -import OccName ( tcName, isDataOcc, occNameFlavour, reportIfUnused ) +import OccName ( tcName, isDataOcc, pprNonVarNameSpace, occNameSpace, + reportIfUnused ) import Module ( Module ) import PrelNames ( mkUnboundName, rOOT_MAIN, iNTERACTIVE, consDataConKey, hasKey ) import UniqSupply @@ -60,6 +62,7 @@ import Outputable import Util ( sortLe ) import ListSetOps ( removeDups ) import List ( nubBy ) +import Monad ( when ) import DynFlags \end{code} @@ -361,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 @@ -428,11 +436,20 @@ lookupFixityRn name -- -- loadHomeInterface will find B.hi even if B is a hidden module, -- and that's what we want. - initIfaceTcRn (loadHomeInterface doc name) `thenM` \ iface -> + loadHomeInterface doc name `thenM` \ iface -> returnM (mi_fix_fn iface (nameOccName name)) where - doc = ptext SLIT("Checking fixity for") <+> ppr 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 @@ -626,32 +643,15 @@ bindPatSigTyVarsFV tys thing_inside thing_inside `thenM` \ (result,fvs) -> returnM (result, fvs `delListFromNameSet` tvs) -bindSigTyVarsFV :: [LSig Name] +bindSigTyVarsFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) --- Bind the top-level forall'd type variables in the sigs. --- E.g f :: a -> a --- f = rhs --- The 'a' scopes over the rhs --- --- NB: there'll usually be just one (for a function binding) --- but if there are many, one may shadow the rest; too bad! --- e.g x :: [a] -> [a] --- y :: [(a,a)] -> a --- (x,y) = e --- In e, 'a' will be in scope, and it'll be the one from 'y'! -bindSigTyVarsFV sigs thing_inside +bindSigTyVarsFV tvs thing_inside = do { scoped_tyvars <- doptM Opt_ScopedTypeVariables ; if not scoped_tyvars then thing_inside else bindLocalNamesFV tvs thing_inside } - where - tvs = [ hsLTyVarName ltv - | L _ (Sig _ (L _ (HsForAllTy Explicit ltvs _ _))) <- sigs, ltv <- ltvs ] - -- Note the pattern-match on "Explicit"; we only bind - -- type variables from signatures with an explicit top-level for-all - extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) -- This function is used only in rnSourceDecl on InstDecl @@ -710,10 +710,13 @@ warnUnusedModules mods = ifOptM Opt_WarnUnusedImports (mappM_ bleat mods) where 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", - parens (ptext SLIT("except perhaps instances visible in") <+> - quotes (ppr m))] + 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) @@ -733,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) ------------------------- @@ -741,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" @@ -773,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) @@ -796,4 +804,8 @@ dupNamesErr descriptor located_names 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}