{-

This module contains miscellaneous functions related to renaming.

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

{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

module GHC.Rename.Utils (
        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,

        checkInferredVars,
        noNestedForallsContextsErr, addNoNestedForallsContextsErr
)

where


import GHC.Prelude

import GHC.Core.Type
import GHC.Hs
import GHC.Types.Name.Reader
import GHC.Driver.Types
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.Monad
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Env
import GHC.Core.DataCon
import GHC.Types.SrcLoc as SrcLoc
import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Types.Basic  ( TopLevelFlag(..) )
import GHC.Data.List.SetOps ( removeDups )
import GHC.Data.Maybe ( whenIsJust )
import GHC.Driver.Session
import GHC.Data.FastString
import Control.Monad
import Data.List
import GHC.Settings.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 (L SrcSpan
loc RdrName
rdr_name)
  | Just Name
name <- RdrName -> Maybe Name
isExact_maybe 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 "GHC.ThToHs"
  | Bool
otherwise
  = do { Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (RdrName -> Bool
isUnqual RdrName
rdr_name)
                (SrcSpan -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErrAt SrcSpan
loc (RdrName -> MsgDoc
badQualBndrErr 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 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 :: forall a. [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 :: Int
th_level  = ThStage -> Int
thLevel (TcLclEnv -> ThStage
tcl_th_ctxt TcLclEnv
lcl_env)
             th_bndrs' :: NameEnv (TopLevelFlag, Int)
th_bndrs' = NameEnv (TopLevelFlag, Int)
-> [(Name, (TopLevelFlag, Int))] -> NameEnv (TopLevelFlag, Int)
forall a. NameEnv a -> [(Name, a)] -> NameEnv a
extendNameEnvList (TcLclEnv -> NameEnv (TopLevelFlag, Int)
tcl_th_bndrs TcLclEnv
lcl_env)
                           [ (Name
n, (TopLevelFlag
NotTopLevel, Int
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, Int)
tcl_th_bndrs = NameEnv (TopLevelFlag, Int)
th_bndrs'
                            , tcl_rdr :: LocalRdrEnv
tcl_rdr      = LocalRdrEnv
rdr_env' })
                    RnM a
enclosed_scope }

bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindLocalNamesFV :: forall a. [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 :: forall a. [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 l e. GenLocated l e -> l
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 -> RdrName
forall l e. GenLocated l e -> e
unLoc Located RdrName
n1 RdrName -> RdrName -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Located RdrName -> RdrName
forall l e. GenLocated l e -> e
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 "GHC.ThToHs"

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}. GenLocated a RdrName -> (a, 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 l e. GenLocated l e -> e
unLoc) [Located RdrName]
loc_rdr_names
                -- See Note [Binders in Template Haskell] in "GHC.ThToHs"
    get_loc_occ :: GenLocated a RdrName -> (a, OccName)
get_loc_occ (L a
loc RdrName
rdr) = (a
loc,RdrName -> OccName
rdrNameOcc 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 "GHC.ThToHs"
    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 :: forall a.
(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

-------------------------------------
-- | Throw an error message if a user attempts to quantify an inferred type
-- variable in a place where specificity cannot be observed. For example,
-- @forall {a}. [a] -> [a]@ would be rejected to the inferred type variable
-- @{a}@, but @forall a. [a] -> [a]@ would be accepted.
-- See @Note [Unobservably inferred type variables]@.
checkInferredVars :: HsDocContext
                  -> Maybe SDoc
                  -- ^ The error msg if the signature is not allowed to contain
                  --   manually written inferred variables.
                  -> LHsSigType GhcPs
                  -> RnM ()
checkInferredVars :: HsDocContext
-> Maybe MsgDoc
-> LHsSigType GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) ()
checkInferredVars HsDocContext
_    Maybe MsgDoc
Nothing    LHsSigType GhcPs
_  = () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkInferredVars HsDocContext
ctxt (Just MsgDoc
msg) LHsSigType GhcPs
ty =
  let bndrs :: [HsTyVarBndr Specificity GhcPs]
bndrs = LHsType GhcPs -> [HsTyVarBndr Specificity GhcPs]
forallty_bndrs (LHsSigType GhcPs -> LHsType GhcPs
forall (p :: Pass). LHsSigType (GhcPass p) -> LHsType (GhcPass p)
hsSigType LHsSigType GhcPs
ty)
  in case (HsTyVarBndr Specificity GhcPs -> Bool)
-> [HsTyVarBndr Specificity GhcPs]
-> Maybe (HsTyVarBndr Specificity GhcPs)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Specificity -> Specificity -> Bool
forall a. Eq a => a -> a -> Bool
(==) Specificity
InferredSpec (Specificity -> Bool)
-> (HsTyVarBndr Specificity GhcPs -> Specificity)
-> HsTyVarBndr Specificity GhcPs
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsTyVarBndr Specificity GhcPs -> Specificity
forall flag (pass :: Pass). HsTyVarBndr flag (GhcPass pass) -> flag
hsTyVarBndrFlag) [HsTyVarBndr Specificity GhcPs]
bndrs of
    Maybe (HsTyVarBndr Specificity GhcPs)
Nothing -> () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just HsTyVarBndr Specificity GhcPs
_  -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr (MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ HsDocContext -> MsgDoc -> MsgDoc
withHsDocContext HsDocContext
ctxt MsgDoc
msg
  where
    forallty_bndrs :: LHsType GhcPs -> [HsTyVarBndr Specificity GhcPs]
    forallty_bndrs :: LHsType GhcPs -> [HsTyVarBndr Specificity GhcPs]
forallty_bndrs (L SrcSpan
_ HsType GhcPs
ty) = case HsType GhcPs
ty of
      HsParTy XParTy GhcPs
_ LHsType GhcPs
ty' -> LHsType GhcPs -> [HsTyVarBndr Specificity GhcPs]
forallty_bndrs LHsType GhcPs
ty'
      HsForAllTy { hst_tele :: forall pass. HsType pass -> HsForAllTelescope pass
hst_tele = HsForAllInvis { hsf_invis_bndrs :: forall pass.
HsForAllTelescope pass -> [LHsTyVarBndr Specificity pass]
hsf_invis_bndrs = [LHsTyVarBndr Specificity GhcPs]
tvs }}
                    -> (LHsTyVarBndr Specificity GhcPs -> HsTyVarBndr Specificity GhcPs)
-> [LHsTyVarBndr Specificity GhcPs]
-> [HsTyVarBndr Specificity GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map LHsTyVarBndr Specificity GhcPs -> HsTyVarBndr Specificity GhcPs
forall l e. GenLocated l e -> e
unLoc [LHsTyVarBndr Specificity GhcPs]
tvs
      HsType GhcPs
_             -> []

{-
Note [Unobservably inferred type variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
While GHC's parser allows the use of inferred type variables
(e.g., `forall {a}. <...>`) just about anywhere that type variable binders can
appear, there are some situations where the distinction between inferred and
specified type variables cannot be observed. For example, consider this
instance declaration:

  instance forall {a}. Eq (T a) where ...

Making {a} inferred is pointless, as there is no way for user code to
"apply" an instance declaration in a way where the inferred/specified
distinction would make a difference. (Notably, there is no opportunity
for visible type application of an instance declaration.) Anyone who
writes such code is likely confused, so in an attempt to be helpful,
we emit an error message if a user writes code like this. The
checkInferredVars function is responsible for implementing this
restriction.

It turns out to be somewhat cumbersome to enforce this restriction in
certain cases.  Specifically:

* Quantified constraints. In the type `f :: (forall {a}. C a) => Proxy Int`,
  there is no way to observe that {a} is inferred. Nevertheless, actually
  rejecting this code would be tricky, as we would need to reject
  `forall {a}. <...>` as a constraint but *accept* other uses of
  `forall {a}. <...>` as a type (e.g., `g :: (forall {a}. a -> a) -> b -> b`).
  This is quite tedious to do in practice, so we don't bother.

* Default method type signatures (#18432). These are tricky because inferred
  type variables can appear nested, e.g.,

    class C a where
      m         :: forall b. a -> b -> forall c.   c -> c
      default m :: forall b. a -> b -> forall {c}. c -> c
      m _ _ = id

  Robustly checking for nested, inferred type variables ends up being a pain,
  so we don't try to do this.

For now, we simply allow inferred quantifiers to be specified here,
even though doing so is pointless. All we lose is a warning.

Aside from the places where we already use checkInferredVars, most of
the other places where inferred vars don't make sense are in any case
already prohibited from having foralls /at all/.  For example:

  instance forall a. forall {b}. Eq (Either a b) where ...

Here the nested `forall {b}` is already prohibited. (See
Note [No nested foralls or contexts in instance types] in GHC.Hs.Type).
-}

-- | Examines a non-outermost type for @forall@s or contexts, which are assumed
-- to be nested. For example, in the following declaration:
--
-- @
-- instance forall a. forall b. C (Either a b)
-- @
--
-- The outermost @forall a@ is fine, but the nested @forall b@ is not. We
-- invoke 'noNestedForallsContextsErr' on the type @forall b. C (Either a b)@
-- to catch the nested @forall@ and create a suitable error message.
-- 'noNestedForallsContextsErr' returns @'Just' err_msg@ if such a @forall@ or
-- context is found, and returns @Nothing@ otherwise.
--
-- This is currently used in the following places:
--
-- * In GADT constructor types (in 'rnConDecl').
--   See @Note [GADT abstract syntax] (Wrinkle: No nested foralls or contexts)@
--   in "GHC.Hs.Type".
--
-- * In instance declaration types (in 'rnClsIntDecl' and 'rnSrcDerivDecl' in
--   "GHC.Rename.Module" and 'renameSig' in "GHC.Rename.Bind").
--   See @Note [No nested foralls or contexts in instance types]@ in
--   "GHC.Hs.Type".
noNestedForallsContextsErr :: SDoc -> LHsType GhcRn -> Maybe (SrcSpan, SDoc)
noNestedForallsContextsErr :: MsgDoc -> LHsType GhcRn -> Maybe (SrcSpan, MsgDoc)
noNestedForallsContextsErr MsgDoc
what LHsType GhcRn
lty =
  case LHsType GhcRn -> LHsType GhcRn
forall pass. LHsType pass -> LHsType pass
ignoreParens LHsType GhcRn
lty of
    L SrcSpan
l (HsForAllTy { hst_tele :: forall pass. HsType pass -> HsForAllTelescope pass
hst_tele = HsForAllTelescope GhcRn
tele })
      |  HsForAllVis{} <- HsForAllTelescope GhcRn
tele
         -- The only two places where this function is called correspond to
         -- types of terms, so we give a slightly more descriptive error
         -- message in the event that they contain visible dependent
         -- quantification (currently only allowed in kinds).
      -> (SrcSpan, MsgDoc) -> Maybe (SrcSpan, MsgDoc)
forall a. a -> Maybe a
Just (SrcSpan
l, [MsgDoc] -> MsgDoc
vcat [ String -> MsgDoc
text String
"Illegal visible, dependent quantification" MsgDoc -> MsgDoc -> MsgDoc
<+>
                         String -> MsgDoc
text String
"in the type of a term"
                       , String -> MsgDoc
text String
"(GHC does not yet support this)" ])
      |  HsForAllInvis{} <- HsForAllTelescope GhcRn
tele
      -> (SrcSpan, MsgDoc) -> Maybe (SrcSpan, MsgDoc)
forall a. a -> Maybe a
Just (SrcSpan
l, MsgDoc
nested_foralls_contexts_err)
    L SrcSpan
l (HsQualTy {})
      -> (SrcSpan, MsgDoc) -> Maybe (SrcSpan, MsgDoc)
forall a. a -> Maybe a
Just (SrcSpan
l, MsgDoc
nested_foralls_contexts_err)
    LHsType GhcRn
_ -> Maybe (SrcSpan, MsgDoc)
forall a. Maybe a
Nothing
  where
    nested_foralls_contexts_err :: MsgDoc
nested_foralls_contexts_err =
      MsgDoc
what MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
"cannot contain nested"
      MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes MsgDoc
forAllLit MsgDoc -> MsgDoc -> MsgDoc
<> String -> MsgDoc
text String
"s or contexts"

-- | A common way to invoke 'noNestedForallsContextsErr'.
addNoNestedForallsContextsErr :: HsDocContext -> SDoc -> LHsType GhcRn -> RnM ()
addNoNestedForallsContextsErr :: HsDocContext
-> MsgDoc -> LHsType GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) ()
addNoNestedForallsContextsErr HsDocContext
ctxt MsgDoc
what LHsType GhcRn
lty =
  Maybe (SrcSpan, MsgDoc)
-> ((SrcSpan, MsgDoc) -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust (MsgDoc -> LHsType GhcRn -> Maybe (SrcSpan, MsgDoc)
noNestedForallsContextsErr MsgDoc
what LHsType GhcRn
lty) (((SrcSpan, MsgDoc) -> IOEnv (Env TcGblEnv TcLclEnv) ())
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> ((SrcSpan, MsgDoc) -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ \(SrcSpan
l, MsgDoc
err_msg) ->
    SrcSpan -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErrAt SrcSpan
l (MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ HsDocContext -> MsgDoc -> MsgDoc
withHsDocContext HsDocContext
ctxt MsgDoc
err_msg

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

-- A useful utility
addFvRn :: FreeVars -> RnM (thing, FreeVars) -> RnM (thing, FreeVars)
addFvRn :: forall thing.
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 :: forall a b. (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 :: forall a b.
(a -> RnM (b, FreeVars)) -> Maybe a -> RnM (Maybe b, FreeVars)
mapMaybeFvRn a -> RnM (b, FreeVars)
_ Maybe a
Nothing = (Maybe b, FreeVars)
-> IOEnv (Env TcGblEnv TcLclEnv) (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)
-> IOEnv (Env TcGblEnv TcLclEnv) (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,
         Int -> MsgDoc -> MsgDoc
nest Int
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
$$ Int -> MsgDoc -> MsgDoc
nest Int
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"
                 , Int -> MsgDoc -> MsgDoc
nest Int
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,
         Int -> MsgDoc -> MsgDoc
nest Int
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 :: forall n.
Outputable n =>
(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 -> Ordering) -> [SrcSpan] -> [SrcSpan]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy SrcSpan -> SrcSpan -> Ordering
SrcLoc.leftmost_smallest [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 -> Int -> 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))
       Int
2 (String -> MsgDoc
text String
"Perhaps you intended to use TypeApplications")

checkTupSize :: Int -> RnM ()
checkTupSize :: Int -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkTupSize Int
tup_size
  | Int
tup_size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
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
<+> Int -> MsgDoc
int Int
tup_size MsgDoc -> MsgDoc -> MsgDoc
<> PtrString -> MsgDoc
ptext (String -> PtrString
sLit String
"-tuple is too large for GHC"),
                 Int -> MsgDoc -> MsgDoc
nest Int
2 (MsgDoc -> MsgDoc
parens (String -> MsgDoc
text String
"max size is" MsgDoc -> MsgDoc -> MsgDoc
<+> Int -> MsgDoc
int Int
mAX_TUPLE_SIZE)),
                 Int -> MsgDoc -> MsgDoc
nest Int
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 rewrite rule" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
doubleQuotes (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
"GHC.Tc.Gen.Splice.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