diff options
Diffstat (limited to 'compiler/rename')
| -rw-r--r-- | compiler/rename/RnBinds.hs | 4 | ||||
| -rw-r--r-- | compiler/rename/RnEnv.hs | 937 | ||||
| -rw-r--r-- | compiler/rename/RnExpr.hs | 6 | ||||
| -rw-r--r-- | compiler/rename/RnFixity.hs | 209 | ||||
| -rw-r--r-- | compiler/rename/RnNames.hs | 2 | ||||
| -rw-r--r-- | compiler/rename/RnPat.hs | 5 | ||||
| -rw-r--r-- | compiler/rename/RnSource.hs | 5 | ||||
| -rw-r--r-- | compiler/rename/RnSplice.hs | 2 | ||||
| -rw-r--r-- | compiler/rename/RnTypes.hs | 6 | ||||
| -rw-r--r-- | compiler/rename/RnUnbound.hs | 340 | ||||
| -rw-r--r-- | compiler/rename/RnUtils.hs | 410 |
11 files changed, 1010 insertions, 916 deletions
diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs index 21d6095c27..9abeee207e 100644 --- a/compiler/rename/RnBinds.hs +++ b/compiler/rename/RnBinds.hs @@ -34,6 +34,10 @@ import RnTypes import RnPat import RnNames import RnEnv +import RnFixity +import RnUtils ( HsDocContext(..), mapFvRn, extendTyVarEnvFVRn + , checkDupRdrNames, warnUnusedLocalBinds + , checkDupAndShadowedNames, bindLocalNamesFV ) import DynFlags import Module import Name diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs index a324ce42a8..3aa9472fe6 100644 --- a/compiler/rename/RnEnv.hs +++ b/compiler/rename/RnEnv.hs @@ -1,7 +1,8 @@ {- (c) The GRASP/AQUA Project, Glasgow University, 1992-2006 -\section[RnEnv]{Environment manipulation for the renamer monad} +RnEnv contains functions which convert RdrNames into Names. + -} {-# LANGUAGE CPP, MultiWayIf #-} @@ -15,42 +16,26 @@ module RnEnv ( lookupTypeOccRn, lookupKindOccRn, lookupGlobalOccRn, lookupGlobalOccRn_maybe, lookupOccRn_overloaded, lookupGlobalOccRn_overloaded, lookupExactOcc, - reportUnboundName, unknownNameSuggestions, - addNameClashErrRn, HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn, lookupSigCtxtOccRn, - lookupFixityRn, lookupFixityRn_help, - lookupFieldFixityRn, lookupTyFixityRn, lookupInstDeclBndr, lookupRecFieldOcc, lookupFamInstName, lookupConstructorFields, + + lookupGreAvailRn, + + -- Rebindable Syntax lookupSyntaxName, lookupSyntaxName', lookupSyntaxNames, lookupIfThenElse, - lookupGreAvailRn, - mkUnboundName, mkUnboundNameRdr, isUnboundName, + + -- Constructing usage information addUsedGRE, addUsedGREs, addUsedDataCons, - newLocalBndrRn, newLocalBndrsRn, - bindLocalNames, bindLocalNamesFV, - MiniFixityEnv, - addLocalFixities, - extendTyVarEnvFVRn, - - -- Role annotations - RoleAnnotEnv, emptyRoleAnnotEnv, mkRoleAnnotEnv, - lookupRoleAnnot, getRoleAnnots, - - checkDupRdrNames, checkShadowedRdrNames, - checkDupNames, checkDupAndShadowedNames, dupNamesErr, - checkTupSize, - addFvRn, mapFvRn, mapMaybeFvRn, - warnUnusedMatches, warnUnusedTypePatterns, - warnUnusedTopBinds, warnUnusedLocalBinds, - mkFieldEnv, - dataTcOccs, kindSigErr, perhapsForallMsg, unknownSubordinateErr, - HsDocContext(..), pprHsDocContext, - inHsDocContext, withHsDocContext + + + dataTcOccs, --TODO: Move this somewhere, into utils? + ) where #include "HsVersions.h" @@ -72,24 +57,21 @@ import Module import ConLike import DataCon import TyCon -import PrelNames ( mkUnboundName, isUnboundName, rOOT_MAIN, forall_tv_RDR ) +import PrelNames ( rOOT_MAIN ) import ErrUtils ( MsgDoc ) -import BasicTypes ( Fixity(..), FixityDirection(..), minPrecedence, - defaultFixity, pprWarningTxtForMsg, SourceText(..) ) +import BasicTypes ( pprWarningTxtForMsg ) import SrcLoc import Outputable import Util import Maybes import BasicTypes ( TopLevelFlag(..) ) -import ListSetOps ( removeDups ) import DynFlags import FastString import Control.Monad -import Data.List -import Data.Function ( on ) import ListSetOps ( minusList ) -import Constants ( mAX_TUPLE_SIZE ) import qualified GHC.LanguageExtensions as LangExt +import RnUnbound +import RnUtils {- ********************************************************* @@ -659,8 +641,6 @@ we'll miss the fact that the qualified import is redundant. -------------------------------------------------- -} -mkUnboundNameRdr :: RdrName -> Name -mkUnboundNameRdr rdr = mkUnboundName (rdrNameOcc rdr) lookupLocatedOccRn :: Located RdrName -> RnM (Located Name) lookupLocatedOccRn = wrapLocM lookupOccRn @@ -1378,216 +1358,8 @@ the list type constructor. Note that setRdrNameSpace on an Exact name requires the Name to be External, which it always is for built in syntax. - -********************************************************* -* * - Fixities -* * -********************************************************* - -Note [Fixity signature lookup] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A fixity declaration like - - infixr 2 ? - -can refer to a value-level operator, e.g.: - - (?) :: String -> String -> String - -or a type-level operator, like: - - data (?) a b = A a | B b - -so we extend the lookup of the reader name '?' to the TcClsName namespace, as -well as the original namespace. - -The extended lookup is also used in other places, like resolution of -deprecation declarations, and lookup of names in GHCi. --} - --------------------------------- -type MiniFixityEnv = FastStringEnv (Located Fixity) - -- Mini fixity env for the names we're about - -- to bind, in a single binding group - -- - -- It is keyed by the *FastString*, not the *OccName*, because - -- the single fixity decl infix 3 T - -- affects both the data constructor T and the type constrctor T - -- - -- We keep the location so that if we find - -- a duplicate, we can report it sensibly - --------------------------------- --- Used for nested fixity decls to bind names along with their fixities. --- the fixities are given as a UFM from an OccName's FastString to a fixity decl - -addLocalFixities :: MiniFixityEnv -> [Name] -> RnM a -> RnM a -addLocalFixities mini_fix_env names thing_inside - = extendFixityEnv (mapMaybe find_fixity names) thing_inside - where - find_fixity name - = case lookupFsEnv mini_fix_env (occNameFS occ) of - Just (L _ fix) -> Just (name, FixItem occ fix) - Nothing -> Nothing - where - occ = nameOccName name - -{- --------------------------------- -lookupFixity is a bit strange. - -* Nested local fixity decls are put in the local fixity env, which we - find with getFixtyEnv - -* Imported fixities are found in the PIT - -* Top-level fixity decls in this module may be for Names that are - either Global (constructors, class operations) - or Local/Exported (everything else) - (See notes with RnNames.getLocalDeclBinders for why we have this split.) - We put them all in the local fixity environment -} -lookupFixityRn :: Name -> RnM Fixity -lookupFixityRn name = lookupFixityRn' name (nameOccName name) - -lookupFixityRn' :: Name -> OccName -> RnM Fixity -lookupFixityRn' name = fmap snd . lookupFixityRn_help' name - --- | 'lookupFixityRn_help' returns @(True, fixity)@ if it finds a 'Fixity' --- in a local environment or from an interface file. Otherwise, it returns --- @(False, fixity)@ (e.g., for unbound 'Name's or 'Name's without --- user-supplied fixity declarations). -lookupFixityRn_help :: Name - -> RnM (Bool, Fixity) -lookupFixityRn_help name = - lookupFixityRn_help' name (nameOccName name) - -lookupFixityRn_help' :: Name - -> OccName - -> RnM (Bool, Fixity) -lookupFixityRn_help' name occ - | isUnboundName name - = return (False, Fixity NoSourceText minPrecedence InfixL) - -- Minimise errors from ubound names; eg - -- a>0 `foo` b>0 - -- where 'foo' is not in scope, should not give an error (Trac #7937) - - | otherwise - = do { local_fix_env <- getFixityEnv - ; case lookupNameEnv local_fix_env name of { - Just (FixItem _ fix) -> return (True, fix) ; - Nothing -> - - do { this_mod <- getModule - ; if nameIsLocalOrFrom this_mod name - -- Local (and interactive) names are all in the - -- fixity env, and don't have entries in the HPT - then return (False, defaultFixity) - else lookup_imported } } } - where - lookup_imported - -- For imported names, we have to get their fixities by doing a - -- 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; - -- module CurrentModule where - -- import A( f ) - -- module A( f ) where - -- import B( f ) - -- Then B isn't loaded right away (after all, it's possible that - -- 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. - -- - -- loadInterfaceForName will find B.hi even if B is a hidden module, - -- and that's what we want. - = do { iface <- loadInterfaceForName doc name - ; let mb_fix = mi_fix_fn iface occ - ; let msg = case mb_fix of - Nothing -> - text "looking up name" <+> ppr name - <+> text "in iface, but found no fixity for it." - <+> text "Using default fixity instead." - Just f -> - text "looking up name in iface and found:" - <+> vcat [ppr name, ppr f] - ; traceRn "lookupFixityRn_either:" msg - ; return (maybe (False, defaultFixity) (\f -> (True, f)) mb_fix) } - - doc = text "Checking fixity for" <+> ppr name - ---------------- -lookupTyFixityRn :: Located Name -> RnM Fixity -lookupTyFixityRn (L _ n) = lookupFixityRn n - --- | Look up the fixity of a (possibly ambiguous) occurrence of a record field --- selector. We use 'lookupFixityRn'' so that we can specifiy the 'OccName' as --- the field label, which might be different to the 'OccName' of the selector --- 'Name' if @DuplicateRecordFields@ is in use (Trac #1173). If there are --- multiple possible selectors with different fixities, generate an error. -lookupFieldFixityRn :: AmbiguousFieldOcc Name -> RnM Fixity -lookupFieldFixityRn (Unambiguous (L _ rdr) n) - = lookupFixityRn' n (rdrNameOcc rdr) -lookupFieldFixityRn (Ambiguous (L _ rdr) _) = get_ambiguous_fixity rdr - where - get_ambiguous_fixity :: RdrName -> RnM Fixity - get_ambiguous_fixity rdr_name = do - traceRn "get_ambiguous_fixity" (ppr rdr_name) - rdr_env <- getGlobalRdrEnv - let elts = lookupGRE_RdrName rdr_name rdr_env - - fixities <- groupBy ((==) `on` snd) . zip elts - <$> mapM lookup_gre_fixity elts - - case fixities of - -- There should always be at least one fixity. - -- Something's very wrong if there are no fixity candidates, so panic - [] -> panic "get_ambiguous_fixity: no candidates for a given RdrName" - [ (_, fix):_ ] -> return fix - ambigs -> addErr (ambiguous_fixity_err rdr_name ambigs) - >> return (Fixity NoSourceText minPrecedence InfixL) - - lookup_gre_fixity gre = lookupFixityRn' (gre_name gre) (greOccName gre) - - ambiguous_fixity_err rn ambigs - = vcat [ text "Ambiguous fixity for record field" <+> quotes (ppr rn) - , hang (text "Conflicts: ") 2 . vcat . - map format_ambig $ concat ambigs ] - - format_ambig (elt, fix) = hang (ppr fix) - 2 (pprNameProvenance elt) - - -{- ********************************************************************* -* * - Role annotations -* * -********************************************************************* -} - -type RoleAnnotEnv = NameEnv (LRoleAnnotDecl Name) - -mkRoleAnnotEnv :: [LRoleAnnotDecl Name] -> RoleAnnotEnv -mkRoleAnnotEnv role_annot_decls - = mkNameEnv [ (name, ra_decl) - | ra_decl <- role_annot_decls - , let name = roleAnnotDeclName (unLoc ra_decl) - , not (isUnboundName name) ] - -- Some of the role annots will be unbound; - -- we don't wish to include these - -emptyRoleAnnotEnv :: RoleAnnotEnv -emptyRoleAnnotEnv = emptyNameEnv - -lookupRoleAnnot :: RoleAnnotEnv -> Name -> Maybe (LRoleAnnotDecl Name) -lookupRoleAnnot = lookupNameEnv - -getRoleAnnots :: [Name] -> RoleAnnotEnv -> ([LRoleAnnotDecl Name], RoleAnnotEnv) -getRoleAnnots bndrs role_env - = ( mapMaybe (lookupRoleAnnot role_env) bndrs - , delListFromNameEnv role_env bndrs ) {- @@ -1675,682 +1447,15 @@ lookupSyntaxNames std_names do { usr_names <- mapM (lookupOccRn . mkRdrUnqual . nameOccName) std_names ; return (map (HsVar . noLoc) usr_names, mkFVs usr_names) } } -{- -********************************************************* -* * -\subsection{Binding} -* * -********************************************************* --} - -newLocalBndrRn :: Located RdrName -> RnM Name --- Used for non-top-level binders. These should --- never be qualified. -newLocalBndrRn (L loc rdr_name) - | Just name <- isExact_maybe rdr_name - = return name -- This happens in code generated by Template Haskell - -- See Note [Binders in Template Haskell] in Convert.hs - | otherwise - = do { unless (isUnqual rdr_name) - (addErrAt loc (badQualBndrErr rdr_name)) - ; uniq <- newUnique - ; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) } - -newLocalBndrsRn :: [Located RdrName] -> RnM [Name] -newLocalBndrsRn = mapM newLocalBndrRn +-- Error messages -bindLocalNames :: [Name] -> RnM a -> RnM a -bindLocalNames names enclosed_scope - = do { lcl_env <- getLclEnv - ; let th_level = thLevel (tcl_th_ctxt lcl_env) - th_bndrs' = extendNameEnvList (tcl_th_bndrs lcl_env) - [ (n, (NotTopLevel, th_level)) | n <- names ] - rdr_env' = extendLocalRdrEnvList (tcl_rdr lcl_env) names - ; setLclEnv (lcl_env { tcl_th_bndrs = th_bndrs' - , tcl_rdr = rdr_env' }) - enclosed_scope } - -bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) -bindLocalNamesFV names enclosed_scope - = do { (result, fvs) <- bindLocalNames names enclosed_scope - ; return (result, delFVs names fvs) } - -------------------------------------- - -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 - -------------------------------------- -checkDupRdrNames :: [Located RdrName] -> RnM () --- Check for duplicated names in a binding group -checkDupRdrNames rdr_names_w_loc - = mapM_ (dupNamesErr getLoc) dups - where - (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc - -checkDupNames :: [Name] -> RnM () --- Check for duplicated names in a binding group -checkDupNames names = check_dup_names (filterOut isSystemName names) - -- See Note [Binders in Template Haskell] in Convert - -check_dup_names :: [Name] -> RnM () -check_dup_names names - = mapM_ (dupNamesErr nameSrcSpan) dups - where - (_, dups) = removeDups (\n1 n2 -> nameOccName n1 `compare` nameOccName n2) names - ---------------------- -checkShadowedRdrNames :: [Located RdrName] -> RnM () -checkShadowedRdrNames loc_rdr_names - = do { envs <- getRdrEnvs - ; checkShadowedOccs envs get_loc_occ filtered_rdrs } - where - filtered_rdrs = filterOut (isExact . unLoc) loc_rdr_names - -- See Note [Binders in Template Haskell] in Convert - get_loc_occ (L loc rdr) = (loc,rdrNameOcc rdr) - -checkDupAndShadowedNames :: (GlobalRdrEnv, LocalRdrEnv) -> [Name] -> RnM () -checkDupAndShadowedNames envs names - = do { check_dup_names filtered_names - ; checkShadowedOccs envs get_loc_occ filtered_names } - where - filtered_names = filterOut isSystemName names - -- See Note [Binders in Template Haskell] in Convert - get_loc_occ name = (nameSrcSpan name, nameOccName name) - -------------------------------------- -checkShadowedOccs :: (GlobalRdrEnv, LocalRdrEnv) - -> (a -> (SrcSpan, OccName)) - -> [a] -> RnM () -checkShadowedOccs (global_env,local_env) get_loc_occ ns - = whenWOptM Opt_WarnNameShadowing $ - do { traceRn "checkShadowedOccs:shadow" (ppr (map get_loc_occ ns)) - ; mapM_ check_shadow ns } - where - check_shadow n - | startsWithUnderscore occ = return () -- Do not report shadowing for "_x" - -- See Trac #3262 - | Just n <- mb_local = complain [text "bound at" <+> ppr (nameSrcLoc n)] - | otherwise = do { gres' <- filterM is_shadowed_gre gres - ; complain (map pprNameProvenance gres') } - where - (loc,occ) = get_loc_occ n - mb_local = lookupLocalRdrOcc local_env occ - gres = lookupGRE_RdrName (mkRdrUnqual occ) global_env - -- Make an Unqualified RdrName and look that up, so that - -- we don't find any GREs that are in scope qualified-only - - complain [] = return () - complain pp_locs = addWarnAt (Reason Opt_WarnNameShadowing) - loc - (shadowedNameWarn occ pp_locs) - - is_shadowed_gre :: GlobalRdrElt -> RnM Bool - -- Returns False for record selectors that are shadowed, when - -- punning or wild-cards are on (cf Trac #2723) - is_shadowed_gre gre | isRecFldGRE gre - = do { dflags <- getDynFlags - ; return $ not (xopt LangExt.RecordPuns dflags - || xopt LangExt.RecordWildCards dflags) } - is_shadowed_gre _other = return True - -{- -************************************************************************ -* * - What to do when a lookup fails -* * -************************************************************************ --} - -data WhereLooking = WL_Any -- Any binding - | WL_Global -- Any top-level binding (local or imported) - | WL_LocalTop -- Any top-level binding in this module - | WL_LocalOnly - -- Only local bindings - -- (pattern synonyms declaractions, - -- see Note [Renaming pattern synonym variables]) - -reportUnboundName :: RdrName -> RnM Name -reportUnboundName rdr = unboundName WL_Any rdr - -unboundName :: WhereLooking -> RdrName -> RnM Name -unboundName wl rdr = unboundNameX wl rdr Outputable.empty - -unboundNameX :: WhereLooking -> RdrName -> SDoc -> RnM Name -unboundNameX where_look rdr_name extra - = do { dflags <- getDynFlags - ; let show_helpful_errors = gopt Opt_HelpfulErrors dflags - what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name)) - err = unknownNameErr what rdr_name $$ extra - ; if not show_helpful_errors - then addErr err - else do { local_env <- getLocalRdrEnv - ; global_env <- getGlobalRdrEnv - ; impInfo <- getImports - ; let suggestions = unknownNameSuggestions_ where_look - dflags global_env local_env impInfo rdr_name - ; addErr (err $$ suggestions) } - ; return (mkUnboundNameRdr rdr_name) } - -unknownNameErr :: SDoc -> RdrName -> SDoc -unknownNameErr what rdr_name - = vcat [ hang (text "Not in scope:") - 2 (what <+> quotes (ppr rdr_name)) - , extra ] - where - extra | rdr_name == forall_tv_RDR = perhapsForallMsg - | otherwise = Outputable.empty - -type HowInScope = Either SrcSpan ImpDeclSpec - -- Left loc => locally bound at loc - -- Right ispec => imported as specified by ispec - - --- | Called from the typechecker (TcErrors) when we find an unbound variable -unknownNameSuggestions :: DynFlags - -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails - -> RdrName -> SDoc -unknownNameSuggestions = unknownNameSuggestions_ WL_Any - -unknownNameSuggestions_ :: WhereLooking -> DynFlags - -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails - -> RdrName -> SDoc -unknownNameSuggestions_ where_look dflags global_env local_env imports tried_rdr_name = - similarNameSuggestions where_look dflags global_env local_env tried_rdr_name $$ - importSuggestions where_look imports tried_rdr_name $$ - extensionSuggestions tried_rdr_name - - -similarNameSuggestions :: WhereLooking -> DynFlags - -> GlobalRdrEnv -> LocalRdrEnv - -> RdrName -> SDoc -similarNameSuggestions where_look dflags global_env - local_env tried_rdr_name - = case suggest of - [] -> Outputable.empty - [p] -> perhaps <+> pp_item p - ps -> sep [ perhaps <+> text "one of these:" - , nest 2 (pprWithCommas pp_item ps) ] - where - all_possibilities :: [(String, (RdrName, HowInScope))] - all_possibilities - = [ (showPpr dflags r, (r, Left loc)) - | (r,loc) <- local_possibilities local_env ] - ++ [ (showPpr dflags r, rp) | (r, rp) <- global_possibilities global_env ] - - suggest = fuzzyLookup (showPpr dflags tried_rdr_name) all_possibilities - perhaps = text "Perhaps you meant" - - pp_item :: (RdrName, HowInScope) -> SDoc - pp_item (rdr, Left loc) = pp_ns rdr <+> quotes (ppr rdr) <+> loc' -- Locally defined - where loc' = case loc of - UnhelpfulSpan l -> parens (ppr l) - RealSrcSpan l -> parens (text "line" <+> int (srcSpanStartLine l)) - pp_item (rdr, Right is) = pp_ns rdr <+> quotes (ppr rdr) <+> -- Imported - parens (text "imported from" <+> ppr (is_mod is)) - - pp_ns :: RdrName -> SDoc - pp_ns rdr | ns /= tried_ns = pprNameSpace ns - | otherwise = Outputable.empty - where ns = rdrNameSpace rdr - - tried_occ = rdrNameOcc tried_rdr_name - tried_is_sym = isSymOcc tried_occ - tried_ns = occNameSpace tried_occ - tried_is_qual = isQual tried_rdr_name - - correct_name_space occ = nameSpacesRelated (occNameSpace occ) tried_ns - && isSymOcc occ == tried_is_sym - -- Treat operator and non-operators as non-matching - -- This heuristic avoids things like - -- Not in scope 'f'; perhaps you meant '+' (from Prelude) - - local_ok = case where_look of { WL_Any -> True - ; WL_LocalOnly -> True - ; _ -> False } - local_possibilities :: LocalRdrEnv -> [(RdrName, SrcSpan)] - local_possibilities env - | tried_is_qual = [] - | not local_ok = [] - | otherwise = [ (mkRdrUnqual occ, nameSrcSpan name) - | name <- localRdrEnvElts env - , let occ = nameOccName name - , correct_name_space occ] - - gre_ok :: GlobalRdrElt -> Bool - gre_ok = case where_look of - WL_LocalTop -> isLocalGRE - WL_LocalOnly -> const False - _ -> const True - - global_possibilities :: GlobalRdrEnv -> [(RdrName, (RdrName, HowInScope))] - global_possibilities global_env - | tried_is_qual = [ (rdr_qual, (rdr_qual, how)) - | gre <- globalRdrEnvElts global_env - , gre_ok gre - , let name = gre_name gre - occ = nameOccName name - , correct_name_space occ - , (mod, how) <- quals_in_scope gre - , let rdr_qual = mkRdrQual mod occ ] - - | otherwise = [ (rdr_unqual, pair) - | gre <- globalRdrEnvElts global_env - , gre_ok gre - , let name = gre_name gre - occ = nameOccName name - rdr_unqual = mkRdrUnqual occ - , correct_name_space occ - , pair <- case (unquals_in_scope gre, quals_only gre) of - (how:_, _) -> [ (rdr_unqual, how) ] - ([], pr:_) -> [ pr ] -- See Note [Only-quals] - ([], []) -> [] ] - - -- Note [Only-quals] - -- The second alternative returns those names with the same - -- OccName as the one we tried, but live in *qualified* imports - -- e.g. if you have: - -- - -- > import qualified Data.Map as Map - -- > foo :: Map - -- - -- then we suggest @Map.Map@. - - -------------------- - unquals_in_scope :: GlobalRdrElt -> [HowInScope] - unquals_in_scope (GRE { gre_name = n, gre_lcl = lcl, gre_imp = is }) - | lcl = [ Left (nameSrcSpan n) ] - | otherwise = [ Right ispec - | i <- is, let ispec = is_decl i - , not (is_qual ispec) ] - - -------------------- - quals_in_scope :: GlobalRdrElt -> [(ModuleName, HowInScope)] - -- Ones for which the qualified version is in scope - quals_in_scope (GRE { gre_name = n, gre_lcl = lcl, gre_imp = is }) - | lcl = case nameModule_maybe n of - Nothing -> [] - Just m -> [(moduleName m, Left (nameSrcSpan n))] - | otherwise = [ (is_as ispec, Right ispec) - | i <- is, let ispec = is_decl i ] - - -------------------- - quals_only :: GlobalRdrElt -> [(RdrName, HowInScope)] - -- Ones for which *only* the qualified version is in scope - quals_only (GRE { gre_name = n, gre_imp = is }) - = [ (mkRdrQual (is_as ispec) (nameOccName n), Right ispec) - | i <- is, let ispec = is_decl i, is_qual ispec ] - --- | Generate helpful suggestions if a qualified name Mod.foo is not in scope. -importSuggestions :: WhereLooking -> ImportAvails -> RdrName -> SDoc -importSuggestions where_look imports rdr_name - | WL_LocalOnly <- where_look = Outputable.empty - | not (isQual rdr_name || isUnqual rdr_name) = Outputable.empty - | null interesting_imports - , Just name <- mod_name - = hsep - [ text "No module named" - , quotes (ppr name) - , text "is imported." - ] - | is_qualified - , null helpful_imports - , [(mod,_)] <- interesting_imports - = hsep - [ text "Module" - , quotes (ppr mod) - , text "does not export" - , quotes (ppr occ_name) <> dot - ] - | is_qualified - , null helpful_imports - , mods <- map fst interesting_imports - = hsep - [ text "Neither" - , quotedListWithNor (map ppr mods) - , text "exports" - , quotes (ppr occ_name) <> dot - ] - | [(mod,imv)] <- helpful_imports_non_hiding - = fsep - [ text "Perhaps you want to add" - , quotes (ppr occ_name) - , text "to the import list" - , text "in the import of" - , quotes (ppr mod) - , parens (ppr (imv_span imv)) <> dot - ] - | not (null helpful_imports_non_hiding) - = fsep - [ text "Perhaps you want to add" - , quotes (ppr occ_name) - , text "to one of these import lists:" - ] - $$ - nest 2 (vcat - [ quotes (ppr mod) <+> parens (ppr (imv_span imv)) - | (mod,imv) <- helpful_imports_non_hiding - ]) - | [(mod,imv)] <- helpful_imports_hiding - = fsep - [ text "Perhaps you want to remove" - , quotes (ppr occ_name) - , text "from the explicit hiding list" - , text "in the import of" - , quotes (ppr mod) - , parens (ppr (imv_span imv)) <> dot - ] - | not (null helpful_imports_hiding) - = fsep - [ text "Perhaps you want to remove" - , quotes (ppr occ_name) - , text "from the hiding clauses" - , text "in one of these imports:" - ] - $$ - nest 2 (vcat - [ quotes (ppr mod) <+> parens (ppr (imv_span imv)) - | (mod,imv) <- helpful_imports_hiding - ]) - | otherwise - = Outputable.empty - where - is_qualified = isQual rdr_name - (mod_name, occ_name) = case rdr_name of - Unqual occ_name -> (Nothing, occ_name) - Qual mod_name occ_name -> (Just mod_name, occ_name) - _ -> error "importSuggestions: dead code" - - - -- What import statements provide "Mod" at all - -- or, if this is an unqualified name, are not qualified imports - interesting_imports = [ (mod, imp) - | (mod, mod_imports) <- moduleEnvToList (imp_mods imports) - , Just imp <- return $ pick (importedByUser mod_imports) - ] - - -- We want to keep only one for each original module; preferably one with an - -- explicit import list (for no particularly good reason) - pick :: [ImportedModsVal] -> Maybe ImportedModsVal - pick = listToMaybe . sortBy (compare `on` prefer) . filter select - where select imv = case mod_name of Just name -> imv_name imv == name - Nothing -> not (imv_qualified imv) - prefer imv = (imv_is_hiding imv, imv_span imv) - - -- Which of these would export a 'foo' - -- (all of these are restricted imports, because if they were not, we - -- wouldn't have an out-of-scope error in the first place) - helpful_imports = filter helpful interesting_imports - where helpful (_,imv) - = not . null $ lookupGlobalRdrEnv (imv_all_exports imv) occ_name - - -- Which of these do that because of an explicit hiding list resp. an - -- explicit import list - (helpful_imports_hiding, helpful_imports_non_hiding) - = partition (imv_is_hiding . snd) helpful_imports - -extensionSuggestions :: RdrName -> SDoc -extensionSuggestions rdrName - | rdrName == mkUnqual varName (fsLit "mdo") || - rdrName == mkUnqual varName (fsLit "rec") - = text "Perhaps you meant to use RecursiveDo" - | otherwise = Outputable.empty - -{- -************************************************************************ -* * -\subsection{Free variable manipulation} -* * -************************************************************************ --} - --- A useful utility -addFvRn :: FreeVars -> RnM (thing, FreeVars) -> RnM (thing, FreeVars) -addFvRn fvs1 thing_inside = do { (res, fvs2) <- thing_inside - ; return (res, fvs1 `plusFV` fvs2) } - -mapFvRn :: (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars) -mapFvRn f xs = do stuff <- mapM f xs - case unzip stuff of - (ys, fvs_s) -> return (ys, plusFVs fvs_s) - -mapMaybeFvRn :: (a -> RnM (b, FreeVars)) -> Maybe a -> RnM (Maybe b, FreeVars) -mapMaybeFvRn _ Nothing = return (Nothing, emptyFVs) -mapMaybeFvRn f (Just x) = do { (y, fvs) <- f x; return (Just y, fvs) } - -{- -************************************************************************ -* * -\subsection{Envt utility functions} -* * -************************************************************************ --} - -warnUnusedTopBinds :: [GlobalRdrElt] -> RnM () -warnUnusedTopBinds gres - = whenWOptM Opt_WarnUnusedTopBinds - $ do env <- getGblEnv - let isBoot = tcg_src env == HsBootFile - let noParent gre = case gre_par gre of - NoParent -> True - _ -> False - -- Don't warn about unused bindings with parents in - -- .hs-boot files, as you are sometimes required to give - -- unused bindings (trac #3449). - -- HOWEVER, in a signature file, you are never obligated to put a - -- definition in the main text. Thus, if you define something - -- and forget to export it, we really DO want to warn. - gres' = if isBoot then filter noParent gres - else gres - warnUnusedGREs gres' - -warnUnusedLocalBinds, warnUnusedMatches, warnUnusedTypePatterns - :: [Name] -> FreeVars -> RnM () -warnUnusedLocalBinds = check_unused Opt_WarnUnusedLocalBinds -warnUnusedMatches = check_unused Opt_WarnUnusedMatches -warnUnusedTypePatterns = check_unused Opt_WarnUnusedTypePatterns - -check_unused :: WarningFlag -> [Name] -> FreeVars -> RnM () -check_unused flag bound_names used_names - = whenWOptM flag (warnUnused flag (filterOut (`elemNameSet` used_names) - bound_names)) - -------------------------- --- Helpers -warnUnusedGREs :: [GlobalRdrElt] -> RnM () -warnUnusedGREs gres = mapM_ warnUnusedGRE gres - -warnUnused :: WarningFlag -> [Name] -> RnM () -warnUnused flag names = do - fld_env <- mkFieldEnv <$> getGlobalRdrEnv - mapM_ (warnUnused1 flag fld_env) names - -warnUnused1 :: WarningFlag -> NameEnv (FieldLabelString, Name) -> Name -> RnM () -warnUnused1 flag fld_env name - = when (reportable name occ) $ - addUnusedWarning flag - occ (nameSrcSpan name) - (text "Defined but not used") - where - occ = case lookupNameEnv fld_env name of - Just (fl, _) -> mkVarOccFS fl - Nothing -> nameOccName name - -warnUnusedGRE :: GlobalRdrElt -> RnM () -warnUnusedGRE gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = is }) - | lcl = do fld_env <- mkFieldEnv <$> getGlobalRdrEnv - warnUnused1 Opt_WarnUnusedTopBinds fld_env name - | otherwise = when (reportable name occ) (mapM_ warn is) - where - occ = greOccName gre - warn spec = addUnusedWarning Opt_WarnUnusedTopBinds occ span msg - where - span = importSpecLoc spec - pp_mod = quotes (ppr (importSpecModule spec)) - msg = text "Imported from" <+> pp_mod <+> ptext (sLit "but not used") - --- | Make a map from selector names to field labels and parent tycon --- names, to be used when reporting unused record fields. -mkFieldEnv :: GlobalRdrEnv -> NameEnv (FieldLabelString, Name) -mkFieldEnv rdr_env = mkNameEnv [ (gre_name gre, (lbl, par_is (gre_par gre))) - | gres <- occEnvElts rdr_env - , gre <- gres - , Just lbl <- [greLabel gre] - ] - --- | Should we report the fact that this 'Name' is unused? The --- 'OccName' may differ from 'nameOccName' due to --- DuplicateRecordFields. -reportable :: Name -> OccName -> Bool -reportable name occ - | isWiredInName name = False -- Don't report unused wired-in names - -- Otherwise we get a zillion warnings - -- from Data.Tuple - | otherwise = not (startsWithUnderscore occ) - -addUnusedWarning :: WarningFlag -> OccName -> SrcSpan -> SDoc -> RnM () -addUnusedWarning flag occ span msg - = addWarnAt (Reason flag) span $ - sep [msg <> colon, - nest 2 $ pprNonVarNameSpace (occNameSpace occ) - <+> quotes (ppr occ)] - -addNameClashErrRn :: RdrName -> [GlobalRdrElt] -> RnM () -addNameClashErrRn rdr_name gres - | all isLocalGRE gres && not (all isRecFldGRE gres) - -- If there are two or more *local* defns, we'll have reported - = return () -- that already, and we don't want an error cascade - | otherwise - = addErr (vcat [text "Ambiguous occurrence" <+> quotes (ppr rdr_name), - text "It could refer to" <+> vcat (msg1 : msgs)]) - where - (np1:nps) = gres - msg1 = ptext (sLit "either") <+> mk_ref np1 - msgs = [text " or" <+> mk_ref np | np <- nps] - mk_ref gre = sep [nom <> comma, pprNameProvenance gre] - where nom = case gre_par gre of - FldParent { par_lbl = Just lbl } -> text "the field" <+> quotes (ppr lbl) - _ -> quotes (ppr (gre_name gre)) - -shadowedNameWarn :: OccName -> [SDoc] -> SDoc -shadowedNameWarn occ shadowed_locs - = sep [text "This binding for" <+> quotes (ppr occ) - <+> text "shadows the existing binding" <> plural shadowed_locs, - nest 2 (vcat shadowed_locs)] - -perhapsForallMsg :: SDoc -perhapsForallMsg - = vcat [ text "Perhaps you intended to use ExplicitForAll or similar flag" - , text "to enable explicit-forall syntax: forall <tvs>. <type>"] - -unknownSubordinateErr :: SDoc -> RdrName -> SDoc -unknownSubordinateErr doc op -- Doc is "method of class" or - -- "field of constructor" - = quotes (ppr op) <+> text "is not a (visible)" <+> doc - -badOrigBinding :: RdrName -> SDoc -badOrigBinding name - = text "Illegal binding of built-in syntax:" <+> ppr (rdrNameOcc name) - -- The rdrNameOcc is because we don't want to print Prelude.(,) - -dupNamesErr :: Outputable n => (n -> SrcSpan) -> [n] -> RnM () -dupNamesErr get_loc names - = addErrAt big_loc $ - vcat [text "Conflicting definitions for" <+> quotes (ppr (head names)), - locations] - where - locs = map get_loc names - big_loc = foldr1 combineSrcSpans locs - locations = text "Bound at:" <+> vcat (map ppr (sort locs)) - -kindSigErr :: Outputable a => a -> SDoc -kindSigErr thing - = hang (text "Illegal kind signature for" <+> quotes (ppr thing)) - 2 (text "Perhaps you intended to use KindSignatures") - -badQualBndrErr :: RdrName -> SDoc -badQualBndrErr rdr_name - = text "Qualified name in binding position:" <+> ppr rdr_name opDeclErr :: RdrName -> SDoc opDeclErr n = hang (text "Illegal declaration of a type or class operator" <+> quotes (ppr n)) 2 (text "Use TypeOperators to declare operators in type and declarations") -checkTupSize :: Int -> RnM () -checkTupSize tup_size - | tup_size <= mAX_TUPLE_SIZE - = return () - | otherwise - = addErr (sep [text "A" <+> int tup_size <> ptext (sLit "-tuple is too large for GHC"), - nest 2 (parens (text "max size is" <+> int mAX_TUPLE_SIZE)), - nest 2 (text "Workaround: use nested tuples or define a data type")]) - -{- -************************************************************************ -* * -\subsection{Contexts for renaming errors} -* * -************************************************************************ --} - --- AZ:TODO: Change these all to be Name instead of RdrName. --- Merge TcType.UserTypeContext in to it. -data HsDocContext - = TypeSigCtx SDoc - | PatCtx - | SpecInstSigCtx - | DefaultDeclCtx - | ForeignDeclCtx (Located RdrName) - | DerivDeclCtx - | RuleCtx FastString - | TyDataCtx (Located RdrName) - | TySynCtx (Located RdrName) - | TyFamilyCtx (Located RdrName) - | FamPatCtx (Located RdrName) -- The patterns of a type/data family instance - | ConDeclCtx [Located Name] - | ClassDeclCtx (Located RdrName) - | ExprWithTySigCtx - | TypBrCtx - | HsTypeCtx - | GHCiCtx - | SpliceTypeCtx (LHsType RdrName) - | ClassInstanceCtx - | VectDeclCtx (Located RdrName) - | GenericCtx SDoc -- Maybe we want to use this more! - -withHsDocContext :: HsDocContext -> SDoc -> SDoc -withHsDocContext ctxt doc = doc $$ inHsDocContext ctxt - -inHsDocContext :: HsDocContext -> SDoc -inHsDocContext ctxt = text "In" <+> pprHsDocContext ctxt - -pprHsDocContext :: HsDocContext -> SDoc -pprHsDocContext (GenericCtx doc) = doc -pprHsDocContext (TypeSigCtx doc) = text "the type signature for" <+> doc -pprHsDocContext PatCtx = text "a pattern type-signature" -pprHsDocContext SpecInstSigCtx = text "a SPECIALISE instance pragma" -pprHsDocContext DefaultDeclCtx = text "a `default' declaration" -pprHsDocContext DerivDeclCtx = text "a deriving declaration" -pprHsDocContext (RuleCtx name) = text "the transformation rule" <+> ftext name -pprHsDocContext (TyDataCtx tycon) = text "the data type declaration for" <+> quotes (ppr tycon) -pprHsDocContext (FamPatCtx tycon) = text "a type pattern of family instance for" <+> quotes (ppr tycon) -pprHsDocContext (TySynCtx name) = text "the declaration for type synonym" <+> quotes (ppr name) -pprHsDocContext (TyFamilyCtx name) = text "the declaration for type family" <+> quotes (ppr name) -pprHsDocContext (ClassDeclCtx name) = text "the declaration for class" <+> quotes (ppr name) -pprHsDocContext ExprWithTySigCtx = text "an expression type signature" -pprHsDocContext TypBrCtx = text "a Template-Haskell quoted type" -pprHsDocContext HsTypeCtx = text "a type argument" -pprHsDocContext GHCiCtx = text "GHCi input" -pprHsDocContext (SpliceTypeCtx hs_ty) = text "the spliced type" <+> quotes (ppr hs_ty) -pprHsDocContext ClassInstanceCtx = text "TcSplice.reifyInstances" - -pprHsDocContext (ForeignDeclCtx name) - = text "the foreign declaration for" <+> quotes (ppr name) -pprHsDocContext (ConDeclCtx [name]) - = text "the definition of data constructor" <+> quotes (ppr name) -pprHsDocContext (ConDeclCtx names) - = text "the definition of data constructors" <+> interpp'SP names -pprHsDocContext (VectDeclCtx tycon) - = text "the VECTORISE pragma for type constructor" <+> quotes (ppr tycon) +badOrigBinding :: RdrName -> SDoc +badOrigBinding name + = text "Illegal binding of built-in syntax:" <+> ppr (rdrNameOcc name) + -- The rdrNameOcc is because we don't want to print Prelude.(,) diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs index 4e9192c26e..987b0bec49 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -26,6 +26,12 @@ import HsSyn import TcRnMonad import Module ( getModule ) import RnEnv +import RnFixity +import RnUtils ( HsDocContext(..), bindLocalNamesFV, checkDupNames + , bindLocalNames + , mapMaybeFvRn, mapFvRn + , warnUnusedLocalBinds ) +import RnUnbound ( reportUnboundName ) import RnSplice ( rnBracket, rnSpliceExpr, checkThLocalName ) import RnTypes import RnPat diff --git a/compiler/rename/RnFixity.hs b/compiler/rename/RnFixity.hs new file mode 100644 index 0000000000..61566f0ba5 --- /dev/null +++ b/compiler/rename/RnFixity.hs @@ -0,0 +1,209 @@ +{- + +This module contains code which maintains and manipulates the +fixity environment during renaming. + +-} +module RnFixity ( MiniFixityEnv, + addLocalFixities, + lookupFixityRn, lookupFixityRn_help, + lookupFieldFixityRn, lookupTyFixityRn ) where + +import LoadIface +import HsSyn +import RdrName +import HscTypes +import TcRnMonad +import Name +import NameEnv +import Module +import BasicTypes ( Fixity(..), FixityDirection(..), minPrecedence, + defaultFixity, SourceText(..) ) +import SrcLoc +import Outputable +import Maybes +import Data.List +import Data.Function ( on ) +import RnUnbound + +{- +********************************************************* +* * + Fixities +* * +********************************************************* + +Note [Fixity signature lookup] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A fixity declaration like + + infixr 2 ? + +can refer to a value-level operator, e.g.: + + (?) :: String -> String -> String + +or a type-level operator, like: + + data (?) a b = A a | B b + +so we extend the lookup of the reader name '?' to the TcClsName namespace, as +well as the original namespace. + +The extended lookup is also used in other places, like resolution of +deprecation declarations, and lookup of names in GHCi. +-} + +-------------------------------- +type MiniFixityEnv = FastStringEnv (Located Fixity) + -- Mini fixity env for the names we're about + -- to bind, in a single binding group + -- + -- It is keyed by the *FastString*, not the *OccName*, because + -- the single fixity decl infix 3 T + -- affects both the data constructor T and the type constrctor T + -- + -- We keep the location so that if we find + -- a duplicate, we can report it sensibly + +-------------------------------- +-- Used for nested fixity decls to bind names along with their fixities. +-- the fixities are given as a UFM from an OccName's FastString to a fixity decl + +addLocalFixities :: MiniFixityEnv -> [Name] -> RnM a -> RnM a +addLocalFixities mini_fix_env names thing_inside + = extendFixityEnv (mapMaybe find_fixity names) thing_inside + where + find_fixity name + = case lookupFsEnv mini_fix_env (occNameFS occ) of + Just (L _ fix) -> Just (name, FixItem occ fix) + Nothing -> Nothing + where + occ = nameOccName name + +{- +-------------------------------- +lookupFixity is a bit strange. + +* Nested local fixity decls are put in the local fixity env, which we + find with getFixtyEnv + +* Imported fixities are found in the PIT + +* Top-level fixity decls in this module may be for Names that are + either Global (constructors, class operations) + or Local/Exported (everything else) + (See notes with RnNames.getLocalDeclBinders for why we have this split.) + We put them all in the local fixity environment +-} + +lookupFixityRn :: Name -> RnM Fixity +lookupFixityRn name = lookupFixityRn' name (nameOccName name) + +lookupFixityRn' :: Name -> OccName -> RnM Fixity +lookupFixityRn' name = fmap snd . lookupFixityRn_help' name + +-- | 'lookupFixityRn_help' returns @(True, fixity)@ if it finds a 'Fixity' +-- in a local environment or from an interface file. Otherwise, it returns +-- @(False, fixity)@ (e.g., for unbound 'Name's or 'Name's without +-- user-supplied fixity declarations). +lookupFixityRn_help :: Name + -> RnM (Bool, Fixity) +lookupFixityRn_help name = + lookupFixityRn_help' name (nameOccName name) + +lookupFixityRn_help' :: Name + -> OccName + -> RnM (Bool, Fixity) +lookupFixityRn_help' name occ + | isUnboundName name + = return (False, Fixity NoSourceText minPrecedence InfixL) + -- Minimise errors from ubound names; eg + -- a>0 `foo` b>0 + -- where 'foo' is not in scope, should not give an error (Trac #7937) + + | otherwise + = do { local_fix_env <- getFixityEnv + ; case lookupNameEnv local_fix_env name of { + Just (FixItem _ fix) -> return (True, fix) ; + Nothing -> + + do { this_mod <- getModule + ; if nameIsLocalOrFrom this_mod name + -- Local (and interactive) names are all in the + -- fixity env, and don't have entries in the HPT + then return (False, defaultFixity) + else lookup_imported } } } + where + lookup_imported + -- For imported names, we have to get their fixities by doing a + -- 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; + -- module CurrentModule where + -- import A( f ) + -- module A( f ) where + -- import B( f ) + -- Then B isn't loaded right away (after all, it's possible that + -- 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. + -- + -- loadInterfaceForName will find B.hi even if B is a hidden module, + -- and that's what we want. + = do { iface <- loadInterfaceForName doc name + ; let mb_fix = mi_fix_fn iface occ + ; let msg = case mb_fix of + Nothing -> + text "looking up name" <+> ppr name + <+> text "in iface, but found no fixity for it." + <+> text "Using default fixity instead." + Just f -> + text "looking up name in iface and found:" + <+> vcat [ppr name, ppr f] + ; traceRn "lookupFixityRn_either:" msg + ; return (maybe (False, defaultFixity) (\f -> (True, f)) mb_fix) } + + doc = text "Checking fixity for" <+> ppr name + +--------------- +lookupTyFixityRn :: Located Name -> RnM Fixity +lookupTyFixityRn (L _ n) = lookupFixityRn n + +-- | Look up the fixity of a (possibly ambiguous) occurrence of a record field +-- selector. We use 'lookupFixityRn'' so that we can specifiy the 'OccName' as +-- the field label, which might be different to the 'OccName' of the selector +-- 'Name' if @DuplicateRecordFields@ is in use (Trac #1173). If there are +-- multiple possible selectors with different fixities, generate an error. +lookupFieldFixityRn :: AmbiguousFieldOcc Name -> RnM Fixity +lookupFieldFixityRn (Unambiguous (L _ rdr) n) + = lookupFixityRn' n (rdrNameOcc rdr) +lookupFieldFixityRn (Ambiguous (L _ rdr) _) = get_ambiguous_fixity rdr + where + get_ambiguous_fixity :: RdrName -> RnM Fixity + get_ambiguous_fixity rdr_name = do + traceRn "get_ambiguous_fixity" (ppr rdr_name) + rdr_env <- getGlobalRdrEnv + let elts = lookupGRE_RdrName rdr_name rdr_env + + fixities <- groupBy ((==) `on` snd) . zip elts + <$> mapM lookup_gre_fixity elts + + case fixities of + -- There should always be at least one fixity. + -- Something's very wrong if there are no fixity candidates, so panic + [] -> panic "get_ambiguous_fixity: no candidates for a given RdrName" + [ (_, fix):_ ] -> return fix + ambigs -> addErr (ambiguous_fixity_err rdr_name ambigs) + >> return (Fixity NoSourceText minPrecedence InfixL) + + lookup_gre_fixity gre = lookupFixityRn' (gre_name gre) (greOccName gre) + + ambiguous_fixity_err rn ambigs + = vcat [ text "Ambiguous fixity for record field" <+> quotes (ppr rn) + , hang (text "Conflicts: ") 2 . vcat . + map format_ambig $ concat ambigs ] + + format_ambig (elt, fix) = hang (ppr fix) + 2 (pprNameProvenance elt) diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs index eccd728db4..fa5f24fb46 100644 --- a/compiler/rename/RnNames.hs +++ b/compiler/rename/RnNames.hs @@ -24,6 +24,8 @@ import DynFlags import HsSyn import TcEnv import RnEnv +import RnFixity +import RnUtils ( warnUnusedTopBinds, mkFieldEnv ) import LoadIface ( loadSrcInterface ) import TcRnMonad import PrelNames diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs index 4590fc71fd..df13cedf59 100644 --- a/compiler/rename/RnPat.hs +++ b/compiler/rename/RnPat.hs @@ -44,6 +44,11 @@ import HsSyn import TcRnMonad import TcHsSyn ( hsOverLitName ) import RnEnv +import RnFixity +import RnUtils ( HsDocContext(..), newLocalBndrRn, bindLocalNames + , warnUnusedMatches, newLocalBndrRn + , checkDupAndShadowedNames, checkTupSize + , unknownSubordinateErr ) import RnTypes import PrelNames import TyCon ( tyConName ) diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs index af145e815f..572ed82814 100644 --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -21,6 +21,11 @@ import RdrName import RnTypes import RnBinds import RnEnv +import RnUtils ( HsDocContext(..), mapFvRn, bindLocalNames + , checkDupRdrNames, inHsDocContext, bindLocalNamesFV + , checkShadowedRdrNames, warnUnusedTypePatterns + , extendTyVarEnvFVRn, newLocalBndrsRn ) +import RnUnbound ( mkUnboundName ) import RnNames import RnHsDoc ( rnHsDoc, rnMbLHsDoc ) import TcAnnotations ( annCtxt ) diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs index 2eeecd1f5f..e0f9493291 100644 --- a/compiler/rename/RnSplice.hs +++ b/compiler/rename/RnSplice.hs @@ -18,6 +18,8 @@ import TcRnMonad import Kind import RnEnv +import RnUtils ( HsDocContext(..), newLocalBndrRn ) +import RnUnbound ( isUnboundName ) import RnSource ( rnSrcDecls, findSplice ) import RnPat ( rnPat ) import BasicTypes ( TopLevelFlag, isTopLevel, SourceText(..) ) diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index 74e6b528e5..492862bc33 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -38,6 +38,12 @@ import DynFlags import HsSyn import RnHsDoc ( rnLHsDoc, rnMbLHsDoc ) import RnEnv +import RnUnbound ( perhapsForallMsg ) +import RnUtils ( HsDocContext(..), withHsDocContext, mapFvRn + , pprHsDocContext, bindLocalNamesFV, dupNamesErr + , newLocalBndrRn, checkShadowedRdrNames ) +import RnFixity ( lookupFieldFixityRn, lookupFixityRn + , lookupTyFixityRn ) import TcRnMonad import RdrName import PrelNames diff --git a/compiler/rename/RnUnbound.hs b/compiler/rename/RnUnbound.hs new file mode 100644 index 0000000000..cf5dab5d37 --- /dev/null +++ b/compiler/rename/RnUnbound.hs @@ -0,0 +1,340 @@ +{- + +This module contains helper functions for reporting and creating +unbound variables. + +-} +module RnUnbound ( mkUnboundName + , mkUnboundNameRdr + , isUnboundName + , reportUnboundName + , unknownNameSuggestions + , WhereLooking(..) + , unboundName + , unboundNameX + , perhapsForallMsg ) where + +import RdrName +import HscTypes +import TcRnMonad +import Name +import Module +import SrcLoc +import Outputable +import PrelNames ( mkUnboundName, forall_tv_RDR, isUnboundName ) +import Util +import Maybes +import DynFlags +import FastString +import Data.List +import Data.Function ( on ) + +{- +************************************************************************ +* * + What to do when a lookup fails +* * +************************************************************************ +-} + +data WhereLooking = WL_Any -- Any binding + | WL_Global -- Any top-level binding (local or imported) + | WL_LocalTop -- Any top-level binding in this module + | WL_LocalOnly + -- Only local bindings + -- (pattern synonyms declaractions, + -- see Note [Renaming pattern synonym variables]) + +mkUnboundNameRdr :: RdrName -> Name +mkUnboundNameRdr rdr = mkUnboundName (rdrNameOcc rdr) + +reportUnboundName :: RdrName -> RnM Name +reportUnboundName rdr = unboundName WL_Any rdr + +unboundName :: WhereLooking -> RdrName -> RnM Name +unboundName wl rdr = unboundNameX wl rdr Outputable.empty + +unboundNameX :: WhereLooking -> RdrName -> SDoc -> RnM Name +unboundNameX where_look rdr_name extra + = do { dflags <- getDynFlags + ; let show_helpful_errors = gopt Opt_HelpfulErrors dflags + what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name)) + err = unknownNameErr what rdr_name $$ extra + ; if not show_helpful_errors + then addErr err + else do { local_env <- getLocalRdrEnv + ; global_env <- getGlobalRdrEnv + ; impInfo <- getImports + ; let suggestions = unknownNameSuggestions_ where_look + dflags global_env local_env impInfo rdr_name + ; addErr (err $$ suggestions) } + ; return (mkUnboundNameRdr rdr_name) } + +unknownNameErr :: SDoc -> RdrName -> SDoc +unknownNameErr what rdr_name + = vcat [ hang (text "Not in scope:") + 2 (what <+> quotes (ppr rdr_name)) + , extra ] + where + extra | rdr_name == forall_tv_RDR = perhapsForallMsg + | otherwise = Outputable.empty + +type HowInScope = Either SrcSpan ImpDeclSpec + -- Left loc => locally bound at loc + -- Right ispec => imported as specified by ispec + + +-- | Called from the typechecker (TcErrors) when we find an unbound variable +unknownNameSuggestions :: DynFlags + -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails + -> RdrName -> SDoc +unknownNameSuggestions = unknownNameSuggestions_ WL_Any + +unknownNameSuggestions_ :: WhereLooking -> DynFlags + -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails + -> RdrName -> SDoc +unknownNameSuggestions_ where_look dflags global_env local_env imports tried_rdr_name = + similarNameSuggestions where_look dflags global_env local_env tried_rdr_name $$ + importSuggestions where_look imports tried_rdr_name $$ + extensionSuggestions tried_rdr_name + + +similarNameSuggestions :: WhereLooking -> DynFlags + -> GlobalRdrEnv -> LocalRdrEnv + -> RdrName -> SDoc +similarNameSuggestions where_look dflags global_env + local_env tried_rdr_name + = case suggest of + [] -> Outputable.empty + [p] -> perhaps <+> pp_item p + ps -> sep [ perhaps <+> text "one of these:" + , nest 2 (pprWithCommas pp_item ps) ] + where + all_possibilities :: [(String, (RdrName, HowInScope))] + all_possibilities + = [ (showPpr dflags r, (r, Left loc)) + | (r,loc) <- local_possibilities local_env ] + ++ [ (showPpr dflags r, rp) | (r, rp) <- global_possibilities global_env ] + + suggest = fuzzyLookup (showPpr dflags tried_rdr_name) all_possibilities + perhaps = text "Perhaps you meant" + + pp_item :: (RdrName, HowInScope) -> SDoc + pp_item (rdr, Left loc) = pp_ns rdr <+> quotes (ppr rdr) <+> loc' -- Locally defined + where loc' = case loc of + UnhelpfulSpan l -> parens (ppr l) + RealSrcSpan l -> parens (text "line" <+> int (srcSpanStartLine l)) + pp_item (rdr, Right is) = pp_ns rdr <+> quotes (ppr rdr) <+> -- Imported + parens (text "imported from" <+> ppr (is_mod is)) + + pp_ns :: RdrName -> SDoc + pp_ns rdr | ns /= tried_ns = pprNameSpace ns + | otherwise = Outputable.empty + where ns = rdrNameSpace rdr + + tried_occ = rdrNameOcc tried_rdr_name + tried_is_sym = isSymOcc tried_occ + tried_ns = occNameSpace tried_occ + tried_is_qual = isQual tried_rdr_name + + correct_name_space occ = nameSpacesRelated (occNameSpace occ) tried_ns + && isSymOcc occ == tried_is_sym + -- Treat operator and non-operators as non-matching + -- This heuristic avoids things like + -- Not in scope 'f'; perhaps you meant '+' (from Prelude) + + local_ok = case where_look of { WL_Any -> True + ; WL_LocalOnly -> True + ; _ -> False } + local_possibilities :: LocalRdrEnv -> [(RdrName, SrcSpan)] + local_possibilities env + | tried_is_qual = [] + | not local_ok = [] + | otherwise = [ (mkRdrUnqual occ, nameSrcSpan name) + | name <- localRdrEnvElts env + , let occ = nameOccName name + , correct_name_space occ] + + gre_ok :: GlobalRdrElt -> Bool + gre_ok = case where_look of + WL_LocalTop -> isLocalGRE + WL_LocalOnly -> const False + _ -> const True + + global_possibilities :: GlobalRdrEnv -> [(RdrName, (RdrName, HowInScope))] + global_possibilities global_env + | tried_is_qual = [ (rdr_qual, (rdr_qual, how)) + | gre <- globalRdrEnvElts global_env + , gre_ok gre + , let name = gre_name gre + occ = nameOccName name + , correct_name_space occ + , (mod, how) <- quals_in_scope gre + , let rdr_qual = mkRdrQual mod occ ] + + | otherwise = [ (rdr_unqual, pair) + | gre <- globalRdrEnvElts global_env + , gre_ok gre + , let name = gre_name gre + occ = nameOccName name + rdr_unqual = mkRdrUnqual occ + , correct_name_space occ + , pair <- case (unquals_in_scope gre, quals_only gre) of + (how:_, _) -> [ (rdr_unqual, how) ] + ([], pr:_) -> [ pr ] -- See Note [Only-quals] + ([], []) -> [] ] + + -- Note [Only-quals] + -- The second alternative returns those names with the same + -- OccName as the one we tried, but live in *qualified* imports + -- e.g. if you have: + -- + -- > import qualified Data.Map as Map + -- > foo :: Map + -- + -- then we suggest @Map.Map@. + + -------------------- + unquals_in_scope :: GlobalRdrElt -> [HowInScope] + unquals_in_scope (GRE { gre_name = n, gre_lcl = lcl, gre_imp = is }) + | lcl = [ Left (nameSrcSpan n) ] + | otherwise = [ Right ispec + | i <- is, let ispec = is_decl i + , not (is_qual ispec) ] + + -------------------- + quals_in_scope :: GlobalRdrElt -> [(ModuleName, HowInScope)] + -- Ones for which the qualified version is in scope + quals_in_scope (GRE { gre_name = n, gre_lcl = lcl, gre_imp = is }) + | lcl = case nameModule_maybe n of + Nothing -> [] + Just m -> [(moduleName m, Left (nameSrcSpan n))] + | otherwise = [ (is_as ispec, Right ispec) + | i <- is, let ispec = is_decl i ] + + -------------------- + quals_only :: GlobalRdrElt -> [(RdrName, HowInScope)] + -- Ones for which *only* the qualified version is in scope + quals_only (GRE { gre_name = n, gre_imp = is }) + = [ (mkRdrQual (is_as ispec) (nameOccName n), Right ispec) + | i <- is, let ispec = is_decl i, is_qual ispec ] + +-- | Generate helpful suggestions if a qualified name Mod.foo is not in scope. +importSuggestions :: WhereLooking -> ImportAvails -> RdrName -> SDoc +importSuggestions where_look imports rdr_name + | WL_LocalOnly <- where_look = Outputable.empty + | not (isQual rdr_name || isUnqual rdr_name) = Outputable.empty + | null interesting_imports + , Just name <- mod_name + = hsep + [ text "No module named" + , quotes (ppr name) + , text "is imported." + ] + | is_qualified + , null helpful_imports + , [(mod,_)] <- interesting_imports + = hsep + [ text "Module" + , quotes (ppr mod) + , text "does not export" + , quotes (ppr occ_name) <> dot + ] + | is_qualified + , null helpful_imports + , mods <- map fst interesting_imports + = hsep + [ text "Neither" + , quotedListWithNor (map ppr mods) + , text "exports" + , quotes (ppr occ_name) <> dot + ] + | [(mod,imv)] <- helpful_imports_non_hiding + = fsep + [ text "Perhaps you want to add" + , quotes (ppr occ_name) + , text "to the import list" + , text "in the import of" + , quotes (ppr mod) + , parens (ppr (imv_span imv)) <> dot + ] + | not (null helpful_imports_non_hiding) + = fsep + [ text "Perhaps you want to add" + , quotes (ppr occ_name) + , text "to one of these import lists:" + ] + $$ + nest 2 (vcat + [ quotes (ppr mod) <+> parens (ppr (imv_span imv)) + | (mod,imv) <- helpful_imports_non_hiding + ]) + | [(mod,imv)] <- helpful_imports_hiding + = fsep + [ text "Perhaps you want to remove" + , quotes (ppr occ_name) + , text "from the explicit hiding list" + , text "in the import of" + , quotes (ppr mod) + , parens (ppr (imv_span imv)) <> dot + ] + | not (null helpful_imports_hiding) + = fsep + [ text "Perhaps you want to remove" + , quotes (ppr occ_name) + , text "from the hiding clauses" + , text "in one of these imports:" + ] + $$ + nest 2 (vcat + [ quotes (ppr mod) <+> parens (ppr (imv_span imv)) + | (mod,imv) <- helpful_imports_hiding + ]) + | otherwise + = Outputable.empty + where + is_qualified = isQual rdr_name + (mod_name, occ_name) = case rdr_name of + Unqual occ_name -> (Nothing, occ_name) + Qual mod_name occ_name -> (Just mod_name, occ_name) + _ -> error "importSuggestions: dead code" + + + -- What import statements provide "Mod" at all + -- or, if this is an unqualified name, are not qualified imports + interesting_imports = [ (mod, imp) + | (mod, mod_imports) <- moduleEnvToList (imp_mods imports) + , Just imp <- return $ pick (importedByUser mod_imports) + ] + + -- We want to keep only one for each original module; preferably one with an + -- explicit import list (for no particularly good reason) + pick :: [ImportedModsVal] -> Maybe ImportedModsVal + pick = listToMaybe . sortBy (compare `on` prefer) . filter select + where select imv = case mod_name of Just name -> imv_name imv == name + Nothing -> not (imv_qualified imv) + prefer imv = (imv_is_hiding imv, imv_span imv) + + -- Which of these would export a 'foo' + -- (all of these are restricted imports, because if they were not, we + -- wouldn't have an out-of-scope error in the first place) + helpful_imports = filter helpful interesting_imports + where helpful (_,imv) + = not . null $ lookupGlobalRdrEnv (imv_all_exports imv) occ_name + + -- Which of these do that because of an explicit hiding list resp. an + -- explicit import list + (helpful_imports_hiding, helpful_imports_non_hiding) + = partition (imv_is_hiding . snd) helpful_imports + +extensionSuggestions :: RdrName -> SDoc +extensionSuggestions rdrName + | rdrName == mkUnqual varName (fsLit "mdo") || + rdrName == mkUnqual varName (fsLit "rec") + = text "Perhaps you meant to use RecursiveDo" + | otherwise = Outputable.empty + +perhapsForallMsg :: SDoc +perhapsForallMsg + = vcat [ text "Perhaps you intended to use ExplicitForAll or similar flag" + , text "to enable explicit-forall syntax: forall <tvs>. <type>"] diff --git a/compiler/rename/RnUtils.hs b/compiler/rename/RnUtils.hs new file mode 100644 index 0000000000..cdeb84883b --- /dev/null +++ b/compiler/rename/RnUtils.hs @@ -0,0 +1,410 @@ +{- + +This module contains miscellaneous functions related to renaming. + +-} +module RnUtils ( + checkDupRdrNames, checkShadowedRdrNames, + checkDupNames, checkDupAndShadowedNames, dupNamesErr, + checkTupSize, + addFvRn, mapFvRn, mapMaybeFvRn, + warnUnusedMatches, warnUnusedTypePatterns, + warnUnusedTopBinds, warnUnusedLocalBinds, + mkFieldEnv, + unknownSubordinateErr, badQualBndrErr, + HsDocContext(..), pprHsDocContext, + inHsDocContext, withHsDocContext, + + newLocalBndrRn, newLocalBndrsRn, + + bindLocalNames, bindLocalNamesFV, + + addNameClashErrRn, extendTyVarEnvFVRn + +) + +where + + +import HsSyn +import RdrName +import HscTypes +import TcEnv +import TcRnMonad +import Name +import NameSet +import NameEnv +import DataCon +import SrcLoc +import Outputable +import Util +import BasicTypes ( TopLevelFlag(..) ) +import ListSetOps ( removeDups ) +import DynFlags +import FastString +import Control.Monad +import Data.List +import Constants ( mAX_TUPLE_SIZE ) +import qualified GHC.LanguageExtensions as LangExt + +{- +********************************************************* +* * +\subsection{Binding} +* * +********************************************************* +-} + +newLocalBndrRn :: Located RdrName -> RnM Name +-- Used for non-top-level binders. These should +-- never be qualified. +newLocalBndrRn (L loc rdr_name) + | Just name <- isExact_maybe rdr_name + = return name -- This happens in code generated by Template Haskell + -- See Note [Binders in Template Haskell] in Convert.hs + | otherwise + = do { unless (isUnqual rdr_name) + (addErrAt loc (badQualBndrErr rdr_name)) + ; uniq <- newUnique + ; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) } + +newLocalBndrsRn :: [Located RdrName] -> RnM [Name] +newLocalBndrsRn = mapM newLocalBndrRn + +bindLocalNames :: [Name] -> RnM a -> RnM a +bindLocalNames names enclosed_scope + = do { lcl_env <- getLclEnv + ; let th_level = thLevel (tcl_th_ctxt lcl_env) + th_bndrs' = extendNameEnvList (tcl_th_bndrs lcl_env) + [ (n, (NotTopLevel, th_level)) | n <- names ] + rdr_env' = extendLocalRdrEnvList (tcl_rdr lcl_env) names + ; setLclEnv (lcl_env { tcl_th_bndrs = th_bndrs' + , tcl_rdr = rdr_env' }) + enclosed_scope } + +bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) +bindLocalNamesFV names enclosed_scope + = do { (result, fvs) <- bindLocalNames names enclosed_scope + ; return (result, delFVs names fvs) } + +------------------------------------- + +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 + +------------------------------------- +checkDupRdrNames :: [Located RdrName] -> RnM () +-- Check for duplicated names in a binding group +checkDupRdrNames rdr_names_w_loc + = mapM_ (dupNamesErr getLoc) dups + where + (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc + +checkDupNames :: [Name] -> RnM () +-- Check for duplicated names in a binding group +checkDupNames names = check_dup_names (filterOut isSystemName names) + -- See Note [Binders in Template Haskell] in Convert + +check_dup_names :: [Name] -> RnM () +check_dup_names names + = mapM_ (dupNamesErr nameSrcSpan) dups + where + (_, dups) = removeDups (\n1 n2 -> nameOccName n1 `compare` nameOccName n2) names + +--------------------- +checkShadowedRdrNames :: [Located RdrName] -> RnM () +checkShadowedRdrNames loc_rdr_names + = do { envs <- getRdrEnvs + ; checkShadowedOccs envs get_loc_occ filtered_rdrs } + where + filtered_rdrs = filterOut (isExact . unLoc) loc_rdr_names + -- See Note [Binders in Template Haskell] in Convert + get_loc_occ (L loc rdr) = (loc,rdrNameOcc rdr) + +checkDupAndShadowedNames :: (GlobalRdrEnv, LocalRdrEnv) -> [Name] -> RnM () +checkDupAndShadowedNames envs names + = do { check_dup_names filtered_names + ; checkShadowedOccs envs get_loc_occ filtered_names } + where + filtered_names = filterOut isSystemName names + -- See Note [Binders in Template Haskell] in Convert + get_loc_occ name = (nameSrcSpan name, nameOccName name) + +------------------------------------- +checkShadowedOccs :: (GlobalRdrEnv, LocalRdrEnv) + -> (a -> (SrcSpan, OccName)) + -> [a] -> RnM () +checkShadowedOccs (global_env,local_env) get_loc_occ ns + = whenWOptM Opt_WarnNameShadowing $ + do { traceRn "checkShadowedOccs:shadow" (ppr (map get_loc_occ ns)) + ; mapM_ check_shadow ns } + where + check_shadow n + | startsWithUnderscore occ = return () -- Do not report shadowing for "_x" + -- See Trac #3262 + | Just n <- mb_local = complain [text "bound at" <+> ppr (nameSrcLoc n)] + | otherwise = do { gres' <- filterM is_shadowed_gre gres + ; complain (map pprNameProvenance gres') } + where + (loc,occ) = get_loc_occ n + mb_local = lookupLocalRdrOcc local_env occ + gres = lookupGRE_RdrName (mkRdrUnqual occ) global_env + -- Make an Unqualified RdrName and look that up, so that + -- we don't find any GREs that are in scope qualified-only + + complain [] = return () + complain pp_locs = addWarnAt (Reason Opt_WarnNameShadowing) + loc + (shadowedNameWarn occ pp_locs) + + is_shadowed_gre :: GlobalRdrElt -> RnM Bool + -- Returns False for record selectors that are shadowed, when + -- punning or wild-cards are on (cf Trac #2723) + is_shadowed_gre gre | isRecFldGRE gre + = do { dflags <- getDynFlags + ; return $ not (xopt LangExt.RecordPuns dflags + || xopt LangExt.RecordWildCards dflags) } + is_shadowed_gre _other = return True + + +{- +************************************************************************ +* * +\subsection{Free variable manipulation} +* * +************************************************************************ +-} + +-- A useful utility +addFvRn :: FreeVars -> RnM (thing, FreeVars) -> RnM (thing, FreeVars) +addFvRn fvs1 thing_inside = do { (res, fvs2) <- thing_inside + ; return (res, fvs1 `plusFV` fvs2) } + +mapFvRn :: (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars) +mapFvRn f xs = do stuff <- mapM f xs + case unzip stuff of + (ys, fvs_s) -> return (ys, plusFVs fvs_s) + +mapMaybeFvRn :: (a -> RnM (b, FreeVars)) -> Maybe a -> RnM (Maybe b, FreeVars) +mapMaybeFvRn _ Nothing = return (Nothing, emptyFVs) +mapMaybeFvRn f (Just x) = do { (y, fvs) <- f x; return (Just y, fvs) } + +{- +************************************************************************ +* * +\subsection{Envt utility functions} +* * +************************************************************************ +-} + +warnUnusedTopBinds :: [GlobalRdrElt] -> RnM () +warnUnusedTopBinds gres + = whenWOptM Opt_WarnUnusedTopBinds + $ do env <- getGblEnv + let isBoot = tcg_src env == HsBootFile + let noParent gre = case gre_par gre of + NoParent -> True + _ -> False + -- Don't warn about unused bindings with parents in + -- .hs-boot files, as you are sometimes required to give + -- unused bindings (trac #3449). + -- HOWEVER, in a signature file, you are never obligated to put a + -- definition in the main text. Thus, if you define something + -- and forget to export it, we really DO want to warn. + gres' = if isBoot then filter noParent gres + else gres + warnUnusedGREs gres' + +warnUnusedLocalBinds, warnUnusedMatches, warnUnusedTypePatterns + :: [Name] -> FreeVars -> RnM () +warnUnusedLocalBinds = check_unused Opt_WarnUnusedLocalBinds +warnUnusedMatches = check_unused Opt_WarnUnusedMatches +warnUnusedTypePatterns = check_unused Opt_WarnUnusedTypePatterns + +check_unused :: WarningFlag -> [Name] -> FreeVars -> RnM () +check_unused flag bound_names used_names + = whenWOptM flag (warnUnused flag (filterOut (`elemNameSet` used_names) + bound_names)) + +------------------------- +-- Helpers +warnUnusedGREs :: [GlobalRdrElt] -> RnM () +warnUnusedGREs gres = mapM_ warnUnusedGRE gres + +warnUnused :: WarningFlag -> [Name] -> RnM () +warnUnused flag names = do + fld_env <- mkFieldEnv <$> getGlobalRdrEnv + mapM_ (warnUnused1 flag fld_env) names + +warnUnused1 :: WarningFlag -> NameEnv (FieldLabelString, Name) -> Name -> RnM () +warnUnused1 flag fld_env name + = when (reportable name occ) $ + addUnusedWarning flag + occ (nameSrcSpan name) + (text "Defined but not used") + where + occ = case lookupNameEnv fld_env name of + Just (fl, _) -> mkVarOccFS fl + Nothing -> nameOccName name + +warnUnusedGRE :: GlobalRdrElt -> RnM () +warnUnusedGRE gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = is }) + | lcl = do fld_env <- mkFieldEnv <$> getGlobalRdrEnv + warnUnused1 Opt_WarnUnusedTopBinds fld_env name + | otherwise = when (reportable name occ) (mapM_ warn is) + where + occ = greOccName gre + warn spec = addUnusedWarning Opt_WarnUnusedTopBinds occ span msg + where + span = importSpecLoc spec + pp_mod = quotes (ppr (importSpecModule spec)) + msg = text "Imported from" <+> pp_mod <+> ptext (sLit "but not used") + +-- | Make a map from selector names to field labels and parent tycon +-- names, to be used when reporting unused record fields. +mkFieldEnv :: GlobalRdrEnv -> NameEnv (FieldLabelString, Name) +mkFieldEnv rdr_env = mkNameEnv [ (gre_name gre, (lbl, par_is (gre_par gre))) + | gres <- occEnvElts rdr_env + , gre <- gres + , Just lbl <- [greLabel gre] + ] + +-- | Should we report the fact that this 'Name' is unused? The +-- 'OccName' may differ from 'nameOccName' due to +-- DuplicateRecordFields. +reportable :: Name -> OccName -> Bool +reportable name occ + | isWiredInName name = False -- Don't report unused wired-in names + -- Otherwise we get a zillion warnings + -- from Data.Tuple + | otherwise = not (startsWithUnderscore occ) + +addUnusedWarning :: WarningFlag -> OccName -> SrcSpan -> SDoc -> RnM () +addUnusedWarning flag occ span msg + = addWarnAt (Reason flag) span $ + sep [msg <> colon, + nest 2 $ pprNonVarNameSpace (occNameSpace occ) + <+> quotes (ppr occ)] + +addNameClashErrRn :: RdrName -> [GlobalRdrElt] -> RnM () +addNameClashErrRn rdr_name gres + | all isLocalGRE gres && not (all isRecFldGRE gres) + -- If there are two or more *local* defns, we'll have reported + = return () -- that already, and we don't want an error cascade + | otherwise + = addErr (vcat [text "Ambiguous occurrence" <+> quotes (ppr rdr_name), + text "It could refer to" <+> vcat (msg1 : msgs)]) + where + (np1:nps) = gres + msg1 = ptext (sLit "either") <+> mk_ref np1 + msgs = [text " or" <+> mk_ref np | np <- nps] + mk_ref gre = sep [nom <> comma, pprNameProvenance gre] + where nom = case gre_par gre of + FldParent { par_lbl = Just lbl } -> text "the field" <+> quotes (ppr lbl) + _ -> quotes (ppr (gre_name gre)) + +shadowedNameWarn :: OccName -> [SDoc] -> SDoc +shadowedNameWarn occ shadowed_locs + = sep [text "This binding for" <+> quotes (ppr occ) + <+> text "shadows the existing binding" <> plural shadowed_locs, + nest 2 (vcat shadowed_locs)] + + +unknownSubordinateErr :: SDoc -> RdrName -> SDoc +unknownSubordinateErr doc op -- Doc is "method of class" or + -- "field of constructor" + = quotes (ppr op) <+> text "is not a (visible)" <+> doc + + +dupNamesErr :: Outputable n => (n -> SrcSpan) -> [n] -> RnM () +dupNamesErr get_loc names + = addErrAt big_loc $ + vcat [text "Conflicting definitions for" <+> quotes (ppr (head names)), + locations] + where + locs = map get_loc names + big_loc = foldr1 combineSrcSpans locs + locations = text "Bound at:" <+> vcat (map ppr (sort locs)) + +badQualBndrErr :: RdrName -> SDoc +badQualBndrErr rdr_name + = text "Qualified name in binding position:" <+> ppr rdr_name + + +checkTupSize :: Int -> RnM () +checkTupSize tup_size + | tup_size <= mAX_TUPLE_SIZE + = return () + | otherwise + = addErr (sep [text "A" <+> int tup_size <> ptext (sLit "-tuple is too large for GHC"), + nest 2 (parens (text "max size is" <+> int mAX_TUPLE_SIZE)), + nest 2 (text "Workaround: use nested tuples or define a data type")]) + +{- +************************************************************************ +* * +\subsection{Contexts for renaming errors} +* * +************************************************************************ +-} + +-- AZ:TODO: Change these all to be Name instead of RdrName. +-- Merge TcType.UserTypeContext in to it. +data HsDocContext + = TypeSigCtx SDoc + | PatCtx + | SpecInstSigCtx + | DefaultDeclCtx + | ForeignDeclCtx (Located RdrName) + | DerivDeclCtx + | RuleCtx FastString + | TyDataCtx (Located RdrName) + | TySynCtx (Located RdrName) + | TyFamilyCtx (Located RdrName) + | FamPatCtx (Located RdrName) -- The patterns of a type/data family instance + | ConDeclCtx [Located Name] + | ClassDeclCtx (Located RdrName) + | ExprWithTySigCtx + | TypBrCtx + | HsTypeCtx + | GHCiCtx + | SpliceTypeCtx (LHsType RdrName) + | ClassInstanceCtx + | VectDeclCtx (Located RdrName) + | GenericCtx SDoc -- Maybe we want to use this more! + +withHsDocContext :: HsDocContext -> SDoc -> SDoc +withHsDocContext ctxt doc = doc $$ inHsDocContext ctxt + +inHsDocContext :: HsDocContext -> SDoc +inHsDocContext ctxt = text "In" <+> pprHsDocContext ctxt + +pprHsDocContext :: HsDocContext -> SDoc +pprHsDocContext (GenericCtx doc) = doc +pprHsDocContext (TypeSigCtx doc) = text "the type signature for" <+> doc +pprHsDocContext PatCtx = text "a pattern type-signature" +pprHsDocContext SpecInstSigCtx = text "a SPECIALISE instance pragma" +pprHsDocContext DefaultDeclCtx = text "a `default' declaration" +pprHsDocContext DerivDeclCtx = text "a deriving declaration" +pprHsDocContext (RuleCtx name) = text "the transformation rule" <+> ftext name +pprHsDocContext (TyDataCtx tycon) = text "the data type declaration for" <+> quotes (ppr tycon) +pprHsDocContext (FamPatCtx tycon) = text "a type pattern of family instance for" <+> quotes (ppr tycon) +pprHsDocContext (TySynCtx name) = text "the declaration for type synonym" <+> quotes (ppr name) +pprHsDocContext (TyFamilyCtx name) = text "the declaration for type family" <+> quotes (ppr name) +pprHsDocContext (ClassDeclCtx name) = text "the declaration for class" <+> quotes (ppr name) +pprHsDocContext ExprWithTySigCtx = text "an expression type signature" +pprHsDocContext TypBrCtx = text "a Template-Haskell quoted type" +pprHsDocContext HsTypeCtx = text "a type argument" +pprHsDocContext GHCiCtx = text "GHCi input" +pprHsDocContext (SpliceTypeCtx hs_ty) = text "the spliced type" <+> quotes (ppr hs_ty) +pprHsDocContext ClassInstanceCtx = text "TcSplice.reifyInstances" + +pprHsDocContext (ForeignDeclCtx name) + = text "the foreign declaration for" <+> quotes (ppr name) +pprHsDocContext (ConDeclCtx [name]) + = text "the definition of data constructor" <+> quotes (ppr name) +pprHsDocContext (ConDeclCtx names) + = text "the definition of data constructors" <+> interpp'SP names +pprHsDocContext (VectDeclCtx tycon) + = text "the VECTORISE pragma for type constructor" <+> quotes (ppr tycon) |