{-

This module contains miscellaneous functions related to renaming.

-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeFamilies #-}

module RnUtils (
        checkDupRdrNames, checkShadowedRdrNames,
        checkDupNames, checkDupAndShadowedNames, dupNamesErr,
        checkTupSize,
        addFvRn, mapFvRn, mapMaybeFvRn,
        warnUnusedMatches, warnUnusedTypePatterns,
        warnUnusedTopBinds, warnUnusedLocalBinds,
        checkUnusedRecordWildcard,
        mkFieldEnv,
        unknownSubordinateErr, badQualBndrErr, typeAppErr,
        HsDocContext(..), pprHsDocContext,
        inHsDocContext, withHsDocContext,

        newLocalBndrRn, newLocalBndrsRn,

        bindLocalNames, bindLocalNamesFV,

        addNameClashErrRn, extendTyVarEnvFVRn

)

where


import GhcPrelude

import GHC.Hs
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 Data.List.NonEmpty as NE
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 :: Located RdrName -> RnM Name
newLocalBndrRn (Located RdrName -> Located (SrcSpanLess (Located RdrName))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess (Located RdrName)
rdr_name)
  | Just Name
name <- RdrName -> Maybe Name
isExact_maybe SrcSpanLess (Located RdrName)
RdrName
rdr_name
  = Name -> RnM Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
name -- This happens in code generated by Template Haskell
                -- See Note [Binders in Template Haskell] in Convert.hs
  | Bool
otherwise
  = do { Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (RdrName -> Bool
isUnqual SrcSpanLess (Located RdrName)
RdrName
rdr_name)
                (SrcSpan -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErrAt SrcSpan
loc (RdrName -> MsgDoc
badQualBndrErr SrcSpanLess (Located RdrName)
RdrName
rdr_name))
       ; Unique
uniq <- TcRnIf TcGblEnv TcLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
       ; Name -> RnM Name
forall (m :: * -> *) a. Monad m => a -> m a
return (Unique -> OccName -> SrcSpan -> Name
mkInternalName Unique
uniq (RdrName -> OccName
rdrNameOcc SrcSpanLess (Located RdrName)
RdrName
rdr_name) SrcSpan
loc) }

newLocalBndrsRn :: [Located RdrName] -> RnM [Name]
newLocalBndrsRn :: [Located RdrName] -> RnM [Name]
newLocalBndrsRn = (Located RdrName -> RnM Name) -> [Located RdrName] -> RnM [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Located RdrName -> RnM Name
newLocalBndrRn

bindLocalNames :: [Name] -> RnM a -> RnM a
bindLocalNames :: [Name] -> RnM a -> RnM a
bindLocalNames [Name]
names RnM a
enclosed_scope
  = do { TcLclEnv
lcl_env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
       ; let th_level :: ThLevel
th_level  = ThStage -> ThLevel
thLevel (TcLclEnv -> ThStage
tcl_th_ctxt TcLclEnv
lcl_env)
             th_bndrs' :: NameEnv (TopLevelFlag, ThLevel)
th_bndrs' = NameEnv (TopLevelFlag, ThLevel)
-> [(Name, (TopLevelFlag, ThLevel))]
-> NameEnv (TopLevelFlag, ThLevel)
forall a. NameEnv a -> [(Name, a)] -> NameEnv a
extendNameEnvList (TcLclEnv -> NameEnv (TopLevelFlag, ThLevel)
tcl_th_bndrs TcLclEnv
lcl_env)
                           [ (Name
n, (TopLevelFlag
NotTopLevel, ThLevel
th_level)) | Name
n <- [Name]
names ]
             rdr_env' :: LocalRdrEnv
rdr_env'  = LocalRdrEnv -> [Name] -> LocalRdrEnv
extendLocalRdrEnvList (TcLclEnv -> LocalRdrEnv
tcl_rdr TcLclEnv
lcl_env) [Name]
names
       ; TcLclEnv -> RnM a -> RnM a
forall lcl' gbl a lcl.
lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
setLclEnv (TcLclEnv
lcl_env { tcl_th_bndrs :: NameEnv (TopLevelFlag, ThLevel)
tcl_th_bndrs = NameEnv (TopLevelFlag, ThLevel)
th_bndrs'
                            , tcl_rdr :: LocalRdrEnv
tcl_rdr      = LocalRdrEnv
rdr_env' })
                    RnM a
enclosed_scope }

bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindLocalNamesFV [Name]
names RnM (a, FreeVars)
enclosed_scope
  = do  { (a
result, FreeVars
fvs) <- [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
forall a. [Name] -> RnM a -> RnM a
bindLocalNames [Name]
names RnM (a, FreeVars)
enclosed_scope
        ; (a, FreeVars) -> RnM (a, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, [Name] -> FreeVars -> FreeVars
delFVs [Name]
names FreeVars
fvs) }

-------------------------------------

extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
extendTyVarEnvFVRn [Name]
tyvars RnM (a, FreeVars)
thing_inside = [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
forall a. [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindLocalNamesFV [Name]
tyvars RnM (a, FreeVars)
thing_inside

-------------------------------------
checkDupRdrNames :: [Located RdrName] -> RnM ()
-- Check for duplicated names in a binding group
checkDupRdrNames :: [Located RdrName] -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkDupRdrNames [Located RdrName]
rdr_names_w_loc
  = (NonEmpty (Located RdrName) -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> [NonEmpty (Located RdrName)] -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Located RdrName -> SrcSpan)
-> NonEmpty (Located RdrName) -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall n.
Outputable n =>
(n -> SrcSpan) -> NonEmpty n -> IOEnv (Env TcGblEnv TcLclEnv) ()
dupNamesErr Located RdrName -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc) [NonEmpty (Located RdrName)]
dups
  where
    ([Located RdrName]
_, [NonEmpty (Located RdrName)]
dups) = (Located RdrName -> Located RdrName -> Ordering)
-> [Located RdrName]
-> ([Located RdrName], [NonEmpty (Located RdrName)])
forall a. (a -> a -> Ordering) -> [a] -> ([a], [NonEmpty a])
removeDups (\Located RdrName
n1 Located RdrName
n2 -> Located RdrName -> SrcSpanLess (Located RdrName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located RdrName
n1 RdrName -> RdrName -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Located RdrName -> SrcSpanLess (Located RdrName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located RdrName
n2) [Located RdrName]
rdr_names_w_loc

checkDupNames :: [Name] -> RnM ()
-- Check for duplicated names in a binding group
checkDupNames :: [Name] -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkDupNames [Name]
names = [Name] -> IOEnv (Env TcGblEnv TcLclEnv) ()
check_dup_names ((Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filterOut Name -> Bool
isSystemName [Name]
names)
                -- See Note [Binders in Template Haskell] in Convert

check_dup_names :: [Name] -> RnM ()
check_dup_names :: [Name] -> IOEnv (Env TcGblEnv TcLclEnv) ()
check_dup_names [Name]
names
  = (NonEmpty Name -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> [NonEmpty Name] -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Name -> SrcSpan)
-> NonEmpty Name -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall n.
Outputable n =>
(n -> SrcSpan) -> NonEmpty n -> IOEnv (Env TcGblEnv TcLclEnv) ()
dupNamesErr Name -> SrcSpan
nameSrcSpan) [NonEmpty Name]
dups
  where
    ([Name]
_, [NonEmpty Name]
dups) = (Name -> Name -> Ordering) -> [Name] -> ([Name], [NonEmpty Name])
forall a. (a -> a -> Ordering) -> [a] -> ([a], [NonEmpty a])
removeDups (\Name
n1 Name
n2 -> Name -> OccName
nameOccName Name
n1 OccName -> OccName -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Name -> OccName
nameOccName Name
n2) [Name]
names

---------------------
checkShadowedRdrNames :: [Located RdrName] -> RnM ()
checkShadowedRdrNames :: [Located RdrName] -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkShadowedRdrNames [Located RdrName]
loc_rdr_names
  = do { (GlobalRdrEnv, LocalRdrEnv)
envs <- TcRn (GlobalRdrEnv, LocalRdrEnv)
getRdrEnvs
       ; (GlobalRdrEnv, LocalRdrEnv)
-> (Located RdrName -> (SrcSpan, OccName))
-> [Located RdrName]
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a.
(GlobalRdrEnv, LocalRdrEnv)
-> (a -> (SrcSpan, OccName))
-> [a]
-> IOEnv (Env TcGblEnv TcLclEnv) ()
checkShadowedOccs (GlobalRdrEnv, LocalRdrEnv)
envs Located RdrName -> (SrcSpan, OccName)
forall a.
(HasSrcSpan a, SrcSpanLess a ~ RdrName) =>
a -> (SrcSpan, OccName)
get_loc_occ [Located RdrName]
filtered_rdrs }
  where
    filtered_rdrs :: [Located RdrName]
filtered_rdrs = (Located RdrName -> Bool) -> [Located RdrName] -> [Located RdrName]
forall a. (a -> Bool) -> [a] -> [a]
filterOut (RdrName -> Bool
isExact (RdrName -> Bool)
-> (Located RdrName -> RdrName) -> Located RdrName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located RdrName -> RdrName
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) [Located RdrName]
loc_rdr_names
                -- See Note [Binders in Template Haskell] in Convert
    get_loc_occ :: a -> (SrcSpan, OccName)
get_loc_occ (a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess a
rdr) = (SrcSpan
loc,RdrName -> OccName
rdrNameOcc SrcSpanLess a
RdrName
rdr)

checkDupAndShadowedNames :: (GlobalRdrEnv, LocalRdrEnv) -> [Name] -> RnM ()
checkDupAndShadowedNames :: (GlobalRdrEnv, LocalRdrEnv)
-> [Name] -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkDupAndShadowedNames (GlobalRdrEnv, LocalRdrEnv)
envs [Name]
names
  = do { [Name] -> IOEnv (Env TcGblEnv TcLclEnv) ()
check_dup_names [Name]
filtered_names
       ; (GlobalRdrEnv, LocalRdrEnv)
-> (Name -> (SrcSpan, OccName))
-> [Name]
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a.
(GlobalRdrEnv, LocalRdrEnv)
-> (a -> (SrcSpan, OccName))
-> [a]
-> IOEnv (Env TcGblEnv TcLclEnv) ()
checkShadowedOccs (GlobalRdrEnv, LocalRdrEnv)
envs Name -> (SrcSpan, OccName)
get_loc_occ [Name]
filtered_names }
  where
    filtered_names :: [Name]
filtered_names = (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filterOut Name -> Bool
isSystemName [Name]
names
                -- See Note [Binders in Template Haskell] in Convert
    get_loc_occ :: Name -> (SrcSpan, OccName)
get_loc_occ Name
name = (Name -> SrcSpan
nameSrcSpan Name
name, Name -> OccName
nameOccName Name
name)

-------------------------------------
checkShadowedOccs :: (GlobalRdrEnv, LocalRdrEnv)
                  -> (a -> (SrcSpan, OccName))
                  -> [a] -> RnM ()
checkShadowedOccs :: (GlobalRdrEnv, LocalRdrEnv)
-> (a -> (SrcSpan, OccName))
-> [a]
-> IOEnv (Env TcGblEnv TcLclEnv) ()
checkShadowedOccs (GlobalRdrEnv
global_env,LocalRdrEnv
local_env) a -> (SrcSpan, OccName)
get_loc_occ [a]
ns
  = WarningFlag
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall gbl lcl.
WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM WarningFlag
Opt_WarnNameShadowing (IOEnv (Env TcGblEnv TcLclEnv) ()
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
    do  { String -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"checkShadowedOccs:shadow" ([(SrcSpan, OccName)] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr ((a -> (SrcSpan, OccName)) -> [a] -> [(SrcSpan, OccName)]
forall a b. (a -> b) -> [a] -> [b]
map a -> (SrcSpan, OccName)
get_loc_occ [a]
ns))
        ; (a -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> [a] -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ a -> IOEnv (Env TcGblEnv TcLclEnv) ()
check_shadow [a]
ns }
  where
    check_shadow :: a -> IOEnv (Env TcGblEnv TcLclEnv) ()
check_shadow a
n
        | OccName -> Bool
startsWithUnderscore OccName
occ = () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()  -- Do not report shadowing for "_x"
                                                -- See #3262
        | Just Name
n <- Maybe Name
mb_local = [MsgDoc] -> IOEnv (Env TcGblEnv TcLclEnv) ()
complain [String -> MsgDoc
text String
"bound at" MsgDoc -> MsgDoc -> MsgDoc
<+> SrcLoc -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (Name -> SrcLoc
nameSrcLoc Name
n)]
        | Bool
otherwise = do { [GlobalRdrElt]
gres' <- (GlobalRdrElt -> IOEnv (Env TcGblEnv TcLclEnv) Bool)
-> [GlobalRdrElt] -> IOEnv (Env TcGblEnv TcLclEnv) [GlobalRdrElt]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM GlobalRdrElt -> IOEnv (Env TcGblEnv TcLclEnv) Bool
is_shadowed_gre [GlobalRdrElt]
gres
                         ; [MsgDoc] -> IOEnv (Env TcGblEnv TcLclEnv) ()
complain ((GlobalRdrElt -> MsgDoc) -> [GlobalRdrElt] -> [MsgDoc]
forall a b. (a -> b) -> [a] -> [b]
map GlobalRdrElt -> MsgDoc
pprNameProvenance [GlobalRdrElt]
gres') }
        where
          (SrcSpan
loc,OccName
occ) = a -> (SrcSpan, OccName)
get_loc_occ a
n
          mb_local :: Maybe Name
mb_local  = LocalRdrEnv -> OccName -> Maybe Name
lookupLocalRdrOcc LocalRdrEnv
local_env OccName
occ
          gres :: [GlobalRdrElt]
gres      = RdrName -> GlobalRdrEnv -> [GlobalRdrElt]
lookupGRE_RdrName (OccName -> RdrName
mkRdrUnqual OccName
occ) GlobalRdrEnv
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 :: [MsgDoc] -> IOEnv (Env TcGblEnv TcLclEnv) ()
complain []      = () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          complain [MsgDoc]
pp_locs = WarnReason -> SrcSpan -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addWarnAt (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnNameShadowing)
                                       SrcSpan
loc
                                       (OccName -> [MsgDoc] -> MsgDoc
shadowedNameWarn OccName
occ [MsgDoc]
pp_locs)

    is_shadowed_gre :: GlobalRdrElt -> RnM Bool
        -- Returns False for record selectors that are shadowed, when
        -- punning or wild-cards are on (cf #2723)
    is_shadowed_gre :: GlobalRdrElt -> IOEnv (Env TcGblEnv TcLclEnv) Bool
is_shadowed_gre GlobalRdrElt
gre | GlobalRdrElt -> Bool
isRecFldGRE GlobalRdrElt
gre
        = do { DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
             ; Bool -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IOEnv (Env TcGblEnv TcLclEnv) Bool)
-> Bool -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Extension -> DynFlags -> Bool
xopt Extension
LangExt.RecordPuns DynFlags
dflags
                             Bool -> Bool -> Bool
|| Extension -> DynFlags -> Bool
xopt Extension
LangExt.RecordWildCards DynFlags
dflags) }
    is_shadowed_gre GlobalRdrElt
_other = Bool -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True


{-
************************************************************************
*                                                                      *
\subsection{Free variable manipulation}
*                                                                      *
************************************************************************
-}

-- A useful utility
addFvRn :: FreeVars -> RnM (thing, FreeVars) -> RnM (thing, FreeVars)
addFvRn :: FreeVars -> RnM (thing, FreeVars) -> RnM (thing, FreeVars)
addFvRn FreeVars
fvs1 RnM (thing, FreeVars)
thing_inside = do { (thing
res, FreeVars
fvs2) <- RnM (thing, FreeVars)
thing_inside
                               ; (thing, FreeVars) -> RnM (thing, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (thing
res, FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2) }

mapFvRn :: (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn :: (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn a -> RnM (b, FreeVars)
f [a]
xs = do [(b, FreeVars)]
stuff <- (a -> RnM (b, FreeVars))
-> [a] -> IOEnv (Env TcGblEnv TcLclEnv) [(b, FreeVars)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> RnM (b, FreeVars)
f [a]
xs
                  case [(b, FreeVars)] -> ([b], [FreeVars])
forall a b. [(a, b)] -> ([a], [b])
unzip [(b, FreeVars)]
stuff of
                      ([b]
ys, [FreeVars]
fvs_s) -> ([b], FreeVars) -> RnM ([b], FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return ([b]
ys, [FreeVars] -> FreeVars
plusFVs [FreeVars]
fvs_s)

mapMaybeFvRn :: (a -> RnM (b, FreeVars)) -> Maybe a -> RnM (Maybe b, FreeVars)
mapMaybeFvRn :: (a -> RnM (b, FreeVars)) -> Maybe a -> RnM (Maybe b, FreeVars)
mapMaybeFvRn a -> RnM (b, FreeVars)
_ Maybe a
Nothing = (Maybe b, FreeVars) -> RnM (Maybe b, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe b
forall a. Maybe a
Nothing, FreeVars
emptyFVs)
mapMaybeFvRn a -> RnM (b, FreeVars)
f (Just a
x) = do { (b
y, FreeVars
fvs) <- a -> RnM (b, FreeVars)
f a
x; (Maybe b, FreeVars) -> RnM (Maybe b, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> Maybe b
forall a. a -> Maybe a
Just b
y, FreeVars
fvs) }

{-
************************************************************************
*                                                                      *
\subsection{Envt utility functions}
*                                                                      *
************************************************************************
-}

warnUnusedTopBinds :: [GlobalRdrElt] -> RnM ()
warnUnusedTopBinds :: [GlobalRdrElt] -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnUnusedTopBinds [GlobalRdrElt]
gres
    = WarningFlag
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall gbl lcl.
WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM WarningFlag
Opt_WarnUnusedTopBinds
    (IOEnv (Env TcGblEnv TcLclEnv) ()
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ do TcGblEnv
env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
         let isBoot :: Bool
isBoot = TcGblEnv -> HscSource
tcg_src TcGblEnv
env HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== HscSource
HsBootFile
         let noParent :: GlobalRdrElt -> Bool
noParent GlobalRdrElt
gre = case GlobalRdrElt -> Parent
gre_par GlobalRdrElt
gre of
                            Parent
NoParent -> Bool
True
                            Parent
_        -> Bool
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' :: [GlobalRdrElt]
gres' = if Bool
isBoot then (GlobalRdrElt -> Bool) -> [GlobalRdrElt] -> [GlobalRdrElt]
forall a. (a -> Bool) -> [a] -> [a]
filter GlobalRdrElt -> Bool
noParent [GlobalRdrElt]
gres
                               else                 [GlobalRdrElt]
gres
         [GlobalRdrElt] -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnUnusedGREs [GlobalRdrElt]
gres'


-- | Checks to see if we need to warn for -Wunused-record-wildcards or
-- -Wredundant-record-wildcards
checkUnusedRecordWildcard :: SrcSpan
                          -> FreeVars
                          -> Maybe [Name]
                          -> RnM ()
checkUnusedRecordWildcard :: SrcSpan
-> FreeVars -> Maybe [Name] -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkUnusedRecordWildcard SrcSpan
_ FreeVars
_ Maybe [Name]
Nothing    = () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkUnusedRecordWildcard SrcSpan
loc FreeVars
_ (Just [])  = do
  -- Add a new warning if the .. pattern binds no variables
  SrcSpan
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (IOEnv (Env TcGblEnv TcLclEnv) ()
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ IOEnv (Env TcGblEnv TcLclEnv) ()
warnRedundantRecordWildcard
checkUnusedRecordWildcard SrcSpan
loc FreeVars
fvs (Just [Name]
dotdot_names) =
  SrcSpan
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (IOEnv (Env TcGblEnv TcLclEnv) ()
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ [Name] -> FreeVars -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnUnusedRecordWildcard [Name]
dotdot_names FreeVars
fvs


-- | Produce a warning when the `..` pattern binds no new
-- variables.
--
-- @
--   data P = P { x :: Int }
--
--   foo (P{x, ..}) = x
-- @
--
-- The `..` here doesn't bind any variables as `x` is already bound.
warnRedundantRecordWildcard :: RnM ()
warnRedundantRecordWildcard :: IOEnv (Env TcGblEnv TcLclEnv) ()
warnRedundantRecordWildcard =
  WarningFlag
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall gbl lcl.
WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM WarningFlag
Opt_WarnRedundantRecordWildcards
            (WarnReason -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addWarn (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnRedundantRecordWildcards)
                     MsgDoc
redundantWildcardWarning)


-- | Produce a warning when no variables bound by a `..` pattern are used.
--
-- @
--   data P = P { x :: Int }
--
--   foo (P{..}) = ()
-- @
--
-- The `..` pattern binds `x` but it is not used in the RHS so we issue
-- a warning.
warnUnusedRecordWildcard :: [Name] -> FreeVars -> RnM ()
warnUnusedRecordWildcard :: [Name] -> FreeVars -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnUnusedRecordWildcard [Name]
ns FreeVars
used_names = do
  let used :: [Name]
used = (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (Name -> FreeVars -> Bool
`elemNameSet` FreeVars
used_names) [Name]
ns
  String -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"warnUnused" ([Name] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [Name]
ns MsgDoc -> MsgDoc -> MsgDoc
$$ FreeVars -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr FreeVars
used_names MsgDoc -> MsgDoc -> MsgDoc
$$ [Name] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [Name]
used)
  WarningFlag -> Bool -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnIfFlag WarningFlag
Opt_WarnUnusedRecordWildcards ([Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
used)
    MsgDoc
unusedRecordWildcardWarning



warnUnusedLocalBinds, warnUnusedMatches, warnUnusedTypePatterns
  :: [Name] -> FreeVars -> RnM ()
warnUnusedLocalBinds :: [Name] -> FreeVars -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnUnusedLocalBinds   = WarningFlag
-> [Name] -> FreeVars -> IOEnv (Env TcGblEnv TcLclEnv) ()
check_unused WarningFlag
Opt_WarnUnusedLocalBinds
warnUnusedMatches :: [Name] -> FreeVars -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnUnusedMatches      = WarningFlag
-> [Name] -> FreeVars -> IOEnv (Env TcGblEnv TcLclEnv) ()
check_unused WarningFlag
Opt_WarnUnusedMatches
warnUnusedTypePatterns :: [Name] -> FreeVars -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnUnusedTypePatterns = WarningFlag
-> [Name] -> FreeVars -> IOEnv (Env TcGblEnv TcLclEnv) ()
check_unused WarningFlag
Opt_WarnUnusedTypePatterns

check_unused :: WarningFlag -> [Name] -> FreeVars -> RnM ()
check_unused :: WarningFlag
-> [Name] -> FreeVars -> IOEnv (Env TcGblEnv TcLclEnv) ()
check_unused WarningFlag
flag [Name]
bound_names FreeVars
used_names
  = WarningFlag
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall gbl lcl.
WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM WarningFlag
flag (WarningFlag -> [Name] -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnUnused WarningFlag
flag ((Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filterOut (Name -> FreeVars -> Bool
`elemNameSet` FreeVars
used_names)
                                               [Name]
bound_names))

-------------------------
--      Helpers
warnUnusedGREs :: [GlobalRdrElt] -> RnM ()
warnUnusedGREs :: [GlobalRdrElt] -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnUnusedGREs [GlobalRdrElt]
gres = (GlobalRdrElt -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> [GlobalRdrElt] -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ GlobalRdrElt -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnUnusedGRE [GlobalRdrElt]
gres

warnUnused :: WarningFlag -> [Name] -> RnM ()
warnUnused :: WarningFlag -> [Name] -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnUnused WarningFlag
flag [Name]
names = do
    NameEnv (FieldLabelString, Name)
fld_env <- GlobalRdrEnv -> NameEnv (FieldLabelString, Name)
mkFieldEnv (GlobalRdrEnv -> NameEnv (FieldLabelString, Name))
-> IOEnv (Env TcGblEnv TcLclEnv) GlobalRdrEnv
-> IOEnv (Env TcGblEnv TcLclEnv) (NameEnv (FieldLabelString, Name))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env TcGblEnv TcLclEnv) GlobalRdrEnv
getGlobalRdrEnv
    (Name -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> [Name] -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (WarningFlag
-> NameEnv (FieldLabelString, Name)
-> Name
-> IOEnv (Env TcGblEnv TcLclEnv) ()
warnUnused1 WarningFlag
flag NameEnv (FieldLabelString, Name)
fld_env) [Name]
names

warnUnused1 :: WarningFlag -> NameEnv (FieldLabelString, Name) -> Name -> RnM ()
warnUnused1 :: WarningFlag
-> NameEnv (FieldLabelString, Name)
-> Name
-> IOEnv (Env TcGblEnv TcLclEnv) ()
warnUnused1 WarningFlag
flag NameEnv (FieldLabelString, Name)
fld_env Name
name
  = Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name -> OccName -> Bool
reportable Name
name OccName
occ) (IOEnv (Env TcGblEnv TcLclEnv) ()
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
    WarningFlag
-> OccName -> SrcSpan -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addUnusedWarning WarningFlag
flag
                     OccName
occ (Name -> SrcSpan
nameSrcSpan Name
name)
                     (String -> MsgDoc
text (String -> MsgDoc) -> String -> MsgDoc
forall a b. (a -> b) -> a -> b
$ String
"Defined but not used" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
opt_str)
  where
    occ :: OccName
occ = case NameEnv (FieldLabelString, Name)
-> Name -> Maybe (FieldLabelString, Name)
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv (FieldLabelString, Name)
fld_env Name
name of
              Just (FieldLabelString
fl, Name
_) -> FieldLabelString -> OccName
mkVarOccFS FieldLabelString
fl
              Maybe (FieldLabelString, Name)
Nothing      -> Name -> OccName
nameOccName Name
name
    opt_str :: String
opt_str = case WarningFlag
flag of
                WarningFlag
Opt_WarnUnusedTypePatterns -> String
" on the right hand side"
                WarningFlag
_ -> String
""

warnUnusedGRE :: GlobalRdrElt -> RnM ()
warnUnusedGRE :: GlobalRdrElt -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnUnusedGRE gre :: GlobalRdrElt
gre@(GRE { gre_name :: GlobalRdrElt -> Name
gre_name = Name
name, gre_lcl :: GlobalRdrElt -> Bool
gre_lcl = Bool
lcl, gre_imp :: GlobalRdrElt -> [ImportSpec]
gre_imp = [ImportSpec]
is })
  | Bool
lcl       = do NameEnv (FieldLabelString, Name)
fld_env <- GlobalRdrEnv -> NameEnv (FieldLabelString, Name)
mkFieldEnv (GlobalRdrEnv -> NameEnv (FieldLabelString, Name))
-> IOEnv (Env TcGblEnv TcLclEnv) GlobalRdrEnv
-> IOEnv (Env TcGblEnv TcLclEnv) (NameEnv (FieldLabelString, Name))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env TcGblEnv TcLclEnv) GlobalRdrEnv
getGlobalRdrEnv
                   WarningFlag
-> NameEnv (FieldLabelString, Name)
-> Name
-> IOEnv (Env TcGblEnv TcLclEnv) ()
warnUnused1 WarningFlag
Opt_WarnUnusedTopBinds NameEnv (FieldLabelString, Name)
fld_env Name
name
  | Bool
otherwise = Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name -> OccName -> Bool
reportable Name
name OccName
occ) ((ImportSpec -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> [ImportSpec] -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ImportSpec -> IOEnv (Env TcGblEnv TcLclEnv) ()
warn [ImportSpec]
is)
  where
    occ :: OccName
occ = GlobalRdrElt -> OccName
greOccName GlobalRdrElt
gre
    warn :: ImportSpec -> IOEnv (Env TcGblEnv TcLclEnv) ()
warn ImportSpec
spec = WarningFlag
-> OccName -> SrcSpan -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addUnusedWarning WarningFlag
Opt_WarnUnusedTopBinds OccName
occ SrcSpan
span MsgDoc
msg
        where
           span :: SrcSpan
span = ImportSpec -> SrcSpan
importSpecLoc ImportSpec
spec
           pp_mod :: MsgDoc
pp_mod = MsgDoc -> MsgDoc
quotes (ModuleName -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (ImportSpec -> ModuleName
importSpecModule ImportSpec
spec))
           msg :: MsgDoc
msg = String -> MsgDoc
text String
"Imported from" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc
pp_mod MsgDoc -> MsgDoc -> MsgDoc
<+> PtrString -> MsgDoc
ptext (String -> PtrString
sLit String
"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 :: GlobalRdrEnv -> NameEnv (FieldLabelString, Name)
mkFieldEnv GlobalRdrEnv
rdr_env = [(Name, (FieldLabelString, Name))]
-> NameEnv (FieldLabelString, Name)
forall a. [(Name, a)] -> NameEnv a
mkNameEnv [ (GlobalRdrElt -> Name
gre_name GlobalRdrElt
gre, (FieldLabelString
lbl, Parent -> Name
par_is (GlobalRdrElt -> Parent
gre_par GlobalRdrElt
gre)))
                               | [GlobalRdrElt]
gres <- GlobalRdrEnv -> [[GlobalRdrElt]]
forall a. OccEnv a -> [a]
occEnvElts GlobalRdrEnv
rdr_env
                               , GlobalRdrElt
gre <- [GlobalRdrElt]
gres
                               , Just FieldLabelString
lbl <- [GlobalRdrElt -> Maybe FieldLabelString
greLabel GlobalRdrElt
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 -> OccName -> Bool
reportable Name
name OccName
occ
  | Name -> Bool
isWiredInName Name
name = Bool
False    -- Don't report unused wired-in names
                                  -- Otherwise we get a zillion warnings
                                  -- from Data.Tuple
  | Bool
otherwise = Bool -> Bool
not (OccName -> Bool
startsWithUnderscore OccName
occ)

addUnusedWarning :: WarningFlag -> OccName -> SrcSpan -> SDoc -> RnM ()
addUnusedWarning :: WarningFlag
-> OccName -> SrcSpan -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addUnusedWarning WarningFlag
flag OccName
occ SrcSpan
span MsgDoc
msg
  = WarnReason -> SrcSpan -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addWarnAt (WarningFlag -> WarnReason
Reason WarningFlag
flag) SrcSpan
span (MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
    [MsgDoc] -> MsgDoc
sep [MsgDoc
msg MsgDoc -> MsgDoc -> MsgDoc
<> MsgDoc
colon,
         ThLevel -> MsgDoc -> MsgDoc
nest ThLevel
2 (MsgDoc -> MsgDoc) -> MsgDoc -> MsgDoc
forall a b. (a -> b) -> a -> b
$ NameSpace -> MsgDoc
pprNonVarNameSpace (OccName -> NameSpace
occNameSpace OccName
occ)
                        MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (OccName -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr OccName
occ)]

unusedRecordWildcardWarning :: SDoc
unusedRecordWildcardWarning :: MsgDoc
unusedRecordWildcardWarning =
  MsgDoc -> MsgDoc
wildcardDoc (MsgDoc -> MsgDoc) -> MsgDoc -> MsgDoc
forall a b. (a -> b) -> a -> b
$ String -> MsgDoc
text String
"No variables bound in the record wildcard match are used"

redundantWildcardWarning :: SDoc
redundantWildcardWarning :: MsgDoc
redundantWildcardWarning =
  MsgDoc -> MsgDoc
wildcardDoc (MsgDoc -> MsgDoc) -> MsgDoc -> MsgDoc
forall a b. (a -> b) -> a -> b
$ String -> MsgDoc
text String
"Record wildcard does not bind any new variables"

wildcardDoc :: SDoc -> SDoc
wildcardDoc :: MsgDoc -> MsgDoc
wildcardDoc MsgDoc
herald =
  MsgDoc
herald
    MsgDoc -> MsgDoc -> MsgDoc
$$ ThLevel -> MsgDoc -> MsgDoc
nest ThLevel
2 (String -> MsgDoc
text String
"Possible fix" MsgDoc -> MsgDoc -> MsgDoc
<> MsgDoc
colon MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
"omit the"
                                            MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (String -> MsgDoc
text String
".."))

addNameClashErrRn :: RdrName -> [GlobalRdrElt] -> RnM ()
addNameClashErrRn :: RdrName -> [GlobalRdrElt] -> IOEnv (Env TcGblEnv TcLclEnv) ()
addNameClashErrRn RdrName
rdr_name [GlobalRdrElt]
gres
  | (GlobalRdrElt -> Bool) -> [GlobalRdrElt] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all GlobalRdrElt -> Bool
isLocalGRE [GlobalRdrElt]
gres Bool -> Bool -> Bool
&& Bool -> Bool
not ((GlobalRdrElt -> Bool) -> [GlobalRdrElt] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all GlobalRdrElt -> Bool
isRecFldGRE [GlobalRdrElt]
gres)
               -- If there are two or more *local* defns, we'll have reported
  = () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()  -- that already, and we don't want an error cascade
  | Bool
otherwise
  = MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr ([MsgDoc] -> MsgDoc
vcat [ String -> MsgDoc
text String
"Ambiguous occurrence" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (RdrName -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr RdrName
rdr_name)
                 , String -> MsgDoc
text String
"It could refer to"
                 , ThLevel -> MsgDoc -> MsgDoc
nest ThLevel
3 ([MsgDoc] -> MsgDoc
vcat (MsgDoc
msg1 MsgDoc -> [MsgDoc] -> [MsgDoc]
forall a. a -> [a] -> [a]
: [MsgDoc]
msgs)) ])
  where
    (GlobalRdrElt
np1:[GlobalRdrElt]
nps) = [GlobalRdrElt]
gres
    msg1 :: MsgDoc
msg1 =  String -> MsgDoc
text String
"either" MsgDoc -> MsgDoc -> MsgDoc
<+> GlobalRdrElt -> MsgDoc
ppr_gre GlobalRdrElt
np1
    msgs :: [MsgDoc]
msgs = [String -> MsgDoc
text String
"    or" MsgDoc -> MsgDoc -> MsgDoc
<+> GlobalRdrElt -> MsgDoc
ppr_gre GlobalRdrElt
np | GlobalRdrElt
np <- [GlobalRdrElt]
nps]
    ppr_gre :: GlobalRdrElt -> MsgDoc
ppr_gre GlobalRdrElt
gre = [MsgDoc] -> MsgDoc
sep [ GlobalRdrElt -> MsgDoc
pp_gre_name GlobalRdrElt
gre MsgDoc -> MsgDoc -> MsgDoc
<> MsgDoc
comma
                      , GlobalRdrElt -> MsgDoc
pprNameProvenance GlobalRdrElt
gre]

    -- When printing the name, take care to qualify it in the same
    -- way as the provenance reported by pprNameProvenance, namely
    -- the head of 'gre_imp'.  Otherwise we get confusing reports like
    --   Ambiguous occurrence ‘null’
    --   It could refer to either ‘T15487a.null’,
    --                            imported from ‘Prelude’ at T15487.hs:1:8-13
    --                     or ...
    -- See #15487
    pp_gre_name :: GlobalRdrElt -> MsgDoc
pp_gre_name gre :: GlobalRdrElt
gre@(GRE { gre_name :: GlobalRdrElt -> Name
gre_name = Name
name, gre_par :: GlobalRdrElt -> Parent
gre_par = Parent
parent
                         , gre_lcl :: GlobalRdrElt -> Bool
gre_lcl = Bool
lcl, gre_imp :: GlobalRdrElt -> [ImportSpec]
gre_imp = [ImportSpec]
iss })
      | FldParent { par_lbl :: Parent -> Maybe FieldLabelString
par_lbl = Just FieldLabelString
lbl } <- Parent
parent
      = String -> MsgDoc
text String
"the field" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (FieldLabelString -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr FieldLabelString
lbl)
      | Bool
otherwise
      = MsgDoc -> MsgDoc
quotes (MsgDoc
pp_qual MsgDoc -> MsgDoc -> MsgDoc
<> MsgDoc
dot MsgDoc -> MsgDoc -> MsgDoc
<> OccName -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (Name -> OccName
nameOccName Name
name))
      where
        pp_qual :: MsgDoc
pp_qual | Bool
lcl
                = Module -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
name)
                | ImportSpec
imp : [ImportSpec]
_ <- [ImportSpec]
iss  -- This 'imp' is the one that
                                  -- pprNameProvenance chooses
                , ImpDeclSpec { is_as :: ImpDeclSpec -> ModuleName
is_as = ModuleName
mod } <- ImportSpec -> ImpDeclSpec
is_decl ImportSpec
imp
                = ModuleName -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr ModuleName
mod
                | Bool
otherwise
                = String -> MsgDoc -> MsgDoc
forall a. HasCallStack => String -> MsgDoc -> a
pprPanic String
"addNameClassErrRn" (GlobalRdrElt -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr GlobalRdrElt
gre MsgDoc -> MsgDoc -> MsgDoc
$$ [ImportSpec] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [ImportSpec]
iss)
                  -- Invariant: either 'lcl' is True or 'iss' is non-empty

shadowedNameWarn :: OccName -> [SDoc] -> SDoc
shadowedNameWarn :: OccName -> [MsgDoc] -> MsgDoc
shadowedNameWarn OccName
occ [MsgDoc]
shadowed_locs
  = [MsgDoc] -> MsgDoc
sep [String -> MsgDoc
text String
"This binding for" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (OccName -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr OccName
occ)
            MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
"shadows the existing binding" MsgDoc -> MsgDoc -> MsgDoc
<> [MsgDoc] -> MsgDoc
forall a. [a] -> MsgDoc
plural [MsgDoc]
shadowed_locs,
         ThLevel -> MsgDoc -> MsgDoc
nest ThLevel
2 ([MsgDoc] -> MsgDoc
vcat [MsgDoc]
shadowed_locs)]


unknownSubordinateErr :: SDoc -> RdrName -> SDoc
unknownSubordinateErr :: MsgDoc -> RdrName -> MsgDoc
unknownSubordinateErr MsgDoc
doc RdrName
op    -- Doc is "method of class" or
                                -- "field of constructor"
  = MsgDoc -> MsgDoc
quotes (RdrName -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr RdrName
op) MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
"is not a (visible)" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc
doc


dupNamesErr :: Outputable n => (n -> SrcSpan) -> NE.NonEmpty n -> RnM ()
dupNamesErr :: (n -> SrcSpan) -> NonEmpty n -> IOEnv (Env TcGblEnv TcLclEnv) ()
dupNamesErr n -> SrcSpan
get_loc NonEmpty n
names
  = SrcSpan -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErrAt SrcSpan
big_loc (MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
    [MsgDoc] -> MsgDoc
vcat [String -> MsgDoc
text String
"Conflicting definitions for" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (n -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (NonEmpty n -> n
forall a. NonEmpty a -> a
NE.head NonEmpty n
names)),
          MsgDoc
locations]
  where
    locs :: [SrcSpan]
locs      = (n -> SrcSpan) -> [n] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map n -> SrcSpan
get_loc (NonEmpty n -> [n]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty n
names)
    big_loc :: SrcSpan
big_loc   = (SrcSpan -> SrcSpan -> SrcSpan) -> [SrcSpan] -> SrcSpan
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans [SrcSpan]
locs
    locations :: MsgDoc
locations = String -> MsgDoc
text String
"Bound at:" MsgDoc -> MsgDoc -> MsgDoc
<+> [MsgDoc] -> MsgDoc
vcat ((SrcSpan -> MsgDoc) -> [SrcSpan] -> [MsgDoc]
forall a b. (a -> b) -> [a] -> [b]
map SrcSpan -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr ([SrcSpan] -> [SrcSpan]
forall a. Ord a => [a] -> [a]
sort [SrcSpan]
locs))

badQualBndrErr :: RdrName -> SDoc
badQualBndrErr :: RdrName -> MsgDoc
badQualBndrErr RdrName
rdr_name
  = String -> MsgDoc
text String
"Qualified name in binding position:" MsgDoc -> MsgDoc -> MsgDoc
<+> RdrName -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr RdrName
rdr_name

typeAppErr :: String -> LHsType GhcPs -> SDoc
typeAppErr :: String -> LHsType GhcPs -> MsgDoc
typeAppErr String
what (L SrcSpan
_ HsType GhcPs
k)
  = MsgDoc -> ThLevel -> MsgDoc -> MsgDoc
hang (String -> MsgDoc
text String
"Illegal visible" MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
what MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
"application"
            MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (Char -> MsgDoc
char Char
'@' MsgDoc -> MsgDoc -> MsgDoc
<> HsType GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsType GhcPs
k))
       ThLevel
2 (String -> MsgDoc
text String
"Perhaps you intended to use TypeApplications")

checkTupSize :: Int -> RnM ()
checkTupSize :: ThLevel -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkTupSize ThLevel
tup_size
  | ThLevel
tup_size ThLevel -> ThLevel -> Bool
forall a. Ord a => a -> a -> Bool
<= ThLevel
mAX_TUPLE_SIZE
  = () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise
  = MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr ([MsgDoc] -> MsgDoc
sep [String -> MsgDoc
text String
"A" MsgDoc -> MsgDoc -> MsgDoc
<+> ThLevel -> MsgDoc
int ThLevel
tup_size MsgDoc -> MsgDoc -> MsgDoc
<> PtrString -> MsgDoc
ptext (String -> PtrString
sLit String
"-tuple is too large for GHC"),
                 ThLevel -> MsgDoc -> MsgDoc
nest ThLevel
2 (MsgDoc -> MsgDoc
parens (String -> MsgDoc
text String
"max size is" MsgDoc -> MsgDoc -> MsgDoc
<+> ThLevel -> MsgDoc
int ThLevel
mAX_TUPLE_SIZE)),
                 ThLevel -> MsgDoc -> MsgDoc
nest ThLevel
2 (String -> MsgDoc
text String
"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
  | StandaloneKindSigCtx 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 GhcPs)
  | ClassInstanceCtx
  | GenericCtx SDoc   -- Maybe we want to use this more!

withHsDocContext :: HsDocContext -> SDoc -> SDoc
withHsDocContext :: HsDocContext -> MsgDoc -> MsgDoc
withHsDocContext HsDocContext
ctxt MsgDoc
doc = MsgDoc
doc MsgDoc -> MsgDoc -> MsgDoc
$$ HsDocContext -> MsgDoc
inHsDocContext HsDocContext
ctxt

inHsDocContext :: HsDocContext -> SDoc
inHsDocContext :: HsDocContext -> MsgDoc
inHsDocContext HsDocContext
ctxt = String -> MsgDoc
text String
"In" MsgDoc -> MsgDoc -> MsgDoc
<+> HsDocContext -> MsgDoc
pprHsDocContext HsDocContext
ctxt

pprHsDocContext :: HsDocContext -> SDoc
pprHsDocContext :: HsDocContext -> MsgDoc
pprHsDocContext (GenericCtx MsgDoc
doc)      = MsgDoc
doc
pprHsDocContext (TypeSigCtx MsgDoc
doc)      = String -> MsgDoc
text String
"the type signature for" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc
doc
pprHsDocContext (StandaloneKindSigCtx MsgDoc
doc) = String -> MsgDoc
text String
"the standalone kind signature for" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc
doc
pprHsDocContext HsDocContext
PatCtx                = String -> MsgDoc
text String
"a pattern type-signature"
pprHsDocContext HsDocContext
SpecInstSigCtx        = String -> MsgDoc
text String
"a SPECIALISE instance pragma"
pprHsDocContext HsDocContext
DefaultDeclCtx        = String -> MsgDoc
text String
"a `default' declaration"
pprHsDocContext HsDocContext
DerivDeclCtx          = String -> MsgDoc
text String
"a deriving declaration"
pprHsDocContext (RuleCtx FieldLabelString
name)        = String -> MsgDoc
text String
"the transformation rule" MsgDoc -> MsgDoc -> MsgDoc
<+> FieldLabelString -> MsgDoc
ftext FieldLabelString
name
pprHsDocContext (TyDataCtx Located RdrName
tycon)     = String -> MsgDoc
text String
"the data type declaration for" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (Located RdrName -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Located RdrName
tycon)
pprHsDocContext (FamPatCtx Located RdrName
tycon)     = String -> MsgDoc
text String
"a type pattern of family instance for" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (Located RdrName -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Located RdrName
tycon)
pprHsDocContext (TySynCtx Located RdrName
name)       = String -> MsgDoc
text String
"the declaration for type synonym" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (Located RdrName -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Located RdrName
name)
pprHsDocContext (TyFamilyCtx Located RdrName
name)    = String -> MsgDoc
text String
"the declaration for type family" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (Located RdrName -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Located RdrName
name)
pprHsDocContext (ClassDeclCtx Located RdrName
name)   = String -> MsgDoc
text String
"the declaration for class" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (Located RdrName -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Located RdrName
name)
pprHsDocContext HsDocContext
ExprWithTySigCtx      = String -> MsgDoc
text String
"an expression type signature"
pprHsDocContext HsDocContext
TypBrCtx              = String -> MsgDoc
text String
"a Template-Haskell quoted type"
pprHsDocContext HsDocContext
HsTypeCtx             = String -> MsgDoc
text String
"a type argument"
pprHsDocContext HsDocContext
GHCiCtx               = String -> MsgDoc
text String
"GHCi input"
pprHsDocContext (SpliceTypeCtx LHsType GhcPs
hs_ty) = String -> MsgDoc
text String
"the spliced type" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (LHsType GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr LHsType GhcPs
hs_ty)
pprHsDocContext HsDocContext
ClassInstanceCtx      = String -> MsgDoc
text String
"TcSplice.reifyInstances"

pprHsDocContext (ForeignDeclCtx Located RdrName
name)
   = String -> MsgDoc
text String
"the foreign declaration for" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (Located RdrName -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Located RdrName
name)
pprHsDocContext (ConDeclCtx [Located Name
name])
   = String -> MsgDoc
text String
"the definition of data constructor" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (Located Name -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Located Name
name)
pprHsDocContext (ConDeclCtx [Located Name]
names)
   = String -> MsgDoc
text String
"the definition of data constructors" MsgDoc -> MsgDoc -> MsgDoc
<+> [Located Name] -> MsgDoc
forall a. Outputable a => [a] -> MsgDoc
interpp'SP [Located Name]
names