diff options
Diffstat (limited to 'compiler/rename/RnEnv.hs')
| -rw-r--r-- | compiler/rename/RnEnv.hs | 937 |
1 files changed, 21 insertions, 916 deletions
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.(,) |