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

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

This module contains miscellaneous functions related to renaming.

-}

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

        newLocalBndrRn, newLocalBndrsRn,

        bindLocalNames, bindLocalNamesFV,

        addNameClashErrRn,

        checkInferredVars,
        noNestedForallsContextsErr, addNoNestedForallsContextsErr
)

where


import GHC.Prelude

import GHC.Core.Type
import GHC.Hs
import GHC.Types.Name.Reader
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.Types.SourceFile
import GHC.Utils.Outputable
import GHC.Utils.Panic
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 (find, sortBy)
import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE )
import qualified Data.List.NonEmpty as NE
import qualified GHC.LanguageExtensions as LangExt

{-
*********************************************************
*                                                      *
\subsection{Binding}
*                                                      *
*********************************************************
-}

newLocalBndrRn :: LocatedN RdrName -> RnM Name
-- Used for non-top-level binders.  These should
-- never be qualified.
newLocalBndrRn :: LocatedN RdrName -> RnM Name
newLocalBndrRn (L SrcSpanAnnN
loc RdrName
rdr_name)
  | Just Name
name <- RdrName -> Maybe Name
isExact_maybe RdrName
rdr_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 { forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (RdrName -> Bool
isUnqual RdrName
rdr_name)
                (SrcSpan -> SDoc -> TcRn ()
addErrAt (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnN
loc) (RdrName -> SDoc
badQualBndrErr RdrName
rdr_name))
       ; Unique
uniq <- forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (Unique -> OccName -> SrcSpan -> Name
mkInternalName Unique
uniq (RdrName -> OccName
rdrNameOcc RdrName
rdr_name) (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnN
loc)) }

newLocalBndrsRn :: [LocatedN RdrName] -> RnM [Name]
newLocalBndrsRn :: [LocatedN RdrName] -> RnM [Name]
newLocalBndrsRn = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LocatedN 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 <- 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' = 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
       ; 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) <- forall a. [Name] -> RnM a -> RnM a
bindLocalNames [Name]
names RnM (a, FreeVars)
enclosed_scope
        ; forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, [Name] -> FreeVars -> FreeVars
delFVs [Name]
names FreeVars
fvs) }

-------------------------------------
checkDupRdrNames :: [LocatedN RdrName] -> RnM ()
-- Check for duplicated names in a binding group
checkDupRdrNames :: [LocatedN RdrName] -> TcRn ()
checkDupRdrNames [LocatedN RdrName]
rdr_names_w_loc
  = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall n. Outputable n => (n -> SrcSpan) -> NonEmpty n -> TcRn ()
dupNamesErr forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA) [NonEmpty (LocatedN RdrName)]
dups
  where
    ([LocatedN RdrName]
_, [NonEmpty (LocatedN RdrName)]
dups) = forall a. (a -> a -> Ordering) -> [a] -> ([a], [NonEmpty a])
removeDups (\LocatedN RdrName
n1 LocatedN RdrName
n2 -> forall l e. GenLocated l e -> e
unLoc LocatedN RdrName
n1 forall a. Ord a => a -> a -> Ordering
`compare` forall l e. GenLocated l e -> e
unLoc LocatedN RdrName
n2) [LocatedN RdrName]
rdr_names_w_loc

checkDupRdrNamesN :: [LocatedN RdrName] -> RnM ()
-- Check for duplicated names in a binding group
checkDupRdrNamesN :: [LocatedN RdrName] -> TcRn ()
checkDupRdrNamesN [LocatedN RdrName]
rdr_names_w_loc
  = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall n. Outputable n => (n -> SrcSpan) -> NonEmpty n -> TcRn ()
dupNamesErr forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA) [NonEmpty (LocatedN RdrName)]
dups
  where
    ([LocatedN RdrName]
_, [NonEmpty (LocatedN RdrName)]
dups) = forall a. (a -> a -> Ordering) -> [a] -> ([a], [NonEmpty a])
removeDups (\LocatedN RdrName
n1 LocatedN RdrName
n2 -> forall l e. GenLocated l e -> e
unLoc LocatedN RdrName
n1 forall a. Ord a => a -> a -> Ordering
`compare` forall l e. GenLocated l e -> e
unLoc LocatedN RdrName
n2) [LocatedN RdrName]
rdr_names_w_loc

checkDupNames :: [Name] -> RnM ()
-- Check for duplicated names in a binding group
checkDupNames :: [Name] -> TcRn ()
checkDupNames [Name]
names = [Name] -> TcRn ()
check_dup_names (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] -> TcRn ()
check_dup_names [Name]
names
  = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall n. Outputable n => (n -> SrcSpan) -> NonEmpty n -> TcRn ()
dupNamesErr Name -> SrcSpan
nameSrcSpan) [NonEmpty Name]
dups
  where
    ([Name]
_, [NonEmpty Name]
dups) = forall a. (a -> a -> Ordering) -> [a] -> ([a], [NonEmpty a])
removeDups (\Name
n1 Name
n2 -> Name -> OccName
nameOccName Name
n1 forall a. Ord a => a -> a -> Ordering
`compare` Name -> OccName
nameOccName Name
n2) [Name]
names

---------------------
checkShadowedRdrNames :: [LocatedN RdrName] -> RnM ()
checkShadowedRdrNames :: [LocatedN RdrName] -> TcRn ()
checkShadowedRdrNames [LocatedN RdrName]
loc_rdr_names
  = do { (GlobalRdrEnv, LocalRdrEnv)
envs <- TcRn (GlobalRdrEnv, LocalRdrEnv)
getRdrEnvs
       ; forall a.
(GlobalRdrEnv, LocalRdrEnv)
-> (a -> (SrcSpan, OccName)) -> [a] -> TcRn ()
checkShadowedOccs (GlobalRdrEnv, LocalRdrEnv)
envs forall {a}.
GenLocated (SrcSpanAnn' a) RdrName -> (SrcSpan, OccName)
get_loc_occ [LocatedN RdrName]
filtered_rdrs }
  where
    filtered_rdrs :: [LocatedN RdrName]
filtered_rdrs = forall a. (a -> Bool) -> [a] -> [a]
filterOut (RdrName -> Bool
isExact forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LocatedN RdrName]
loc_rdr_names
                -- See Note [Binders in Template Haskell] in "GHC.ThToHs"
    get_loc_occ :: GenLocated (SrcSpanAnn' a) RdrName -> (SrcSpan, OccName)
get_loc_occ (L SrcSpanAnn' a
loc RdrName
rdr) = (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' a
loc,RdrName -> OccName
rdrNameOcc RdrName
rdr)

checkDupAndShadowedNames :: (GlobalRdrEnv, LocalRdrEnv) -> [Name] -> RnM ()
checkDupAndShadowedNames :: (GlobalRdrEnv, LocalRdrEnv) -> [Name] -> TcRn ()
checkDupAndShadowedNames (GlobalRdrEnv, LocalRdrEnv)
envs [Name]
names
  = do { [Name] -> TcRn ()
check_dup_names [Name]
filtered_names
       ; forall a.
(GlobalRdrEnv, LocalRdrEnv)
-> (a -> (SrcSpan, OccName)) -> [a] -> TcRn ()
checkShadowedOccs (GlobalRdrEnv, LocalRdrEnv)
envs Name -> (SrcSpan, OccName)
get_loc_occ [Name]
filtered_names }
  where
    filtered_names :: [Name]
filtered_names = 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] -> TcRn ()
checkShadowedOccs (GlobalRdrEnv
global_env,LocalRdrEnv
local_env) a -> (SrcSpan, OccName)
get_loc_occ [a]
ns
  = forall gbl lcl.
WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM WarningFlag
Opt_WarnNameShadowing forall a b. (a -> b) -> a -> b
$
    do  { String -> SDoc -> TcRn ()
traceRn String
"checkShadowedOccs:shadow" (forall a. Outputable a => a -> SDoc
ppr (forall a b. (a -> b) -> [a] -> [b]
map a -> (SrcSpan, OccName)
get_loc_occ [a]
ns))
        ; forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ a -> TcRn ()
check_shadow [a]
ns }
  where
    check_shadow :: a -> TcRn ()
check_shadow a
n
        | OccName -> Bool
startsWithUnderscore OccName
occ = forall (m :: * -> *) a. Monad m => a -> m a
return ()  -- Do not report shadowing for "_x"
                                                -- See #3262
        | Just Name
n <- Maybe Name
mb_local = [SDoc] -> TcRn ()
complain [String -> SDoc
text String
"bound at" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (Name -> SrcLoc
nameSrcLoc Name
n)]
        | Bool
otherwise = do { [GlobalRdrElt]
gres' <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM GlobalRdrElt -> RnM Bool
is_shadowed_gre [GlobalRdrElt]
gres
                         ; [SDoc] -> TcRn ()
complain (forall a b. (a -> b) -> [a] -> [b]
map GlobalRdrElt -> SDoc
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 :: [SDoc] -> TcRn ()
complain []      = forall (m :: * -> *) a. Monad m => a -> m a
return ()
          complain [SDoc]
pp_locs = WarnReason -> SrcSpan -> SDoc -> TcRn ()
addWarnAt (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnNameShadowing)
                                       SrcSpan
loc
                                       (OccName -> [SDoc] -> SDoc
shadowedNameWarn OccName
occ [SDoc]
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 -> RnM Bool
is_shadowed_gre GlobalRdrElt
gre | GlobalRdrElt -> Bool
isRecFldGRE GlobalRdrElt
gre
        = do { DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
             ; forall (m :: * -> *) a. Monad m => a -> m a
return 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 = 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 SDoc -> LHsSigType GhcPs -> TcRn ()
checkInferredVars HsDocContext
_    Maybe SDoc
Nothing    LHsSigType GhcPs
_  = forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkInferredVars HsDocContext
ctxt (Just SDoc
msg) LHsSigType GhcPs
ty =
  let bndrs :: [HsTyVarBndr Specificity GhcPs]
bndrs = LHsSigType GhcPs -> [HsTyVarBndr Specificity GhcPs]
sig_ty_bndrs LHsSigType GhcPs
ty
  in case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (forall a. Eq a => a -> a -> Bool
(==) Specificity
InferredSpec forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall flag (pass :: Pass). HsTyVarBndr flag (GhcPass pass) -> flag
hsTyVarBndrFlag) [HsTyVarBndr Specificity GhcPs]
bndrs of
    Maybe (HsTyVarBndr Specificity GhcPs)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just HsTyVarBndr Specificity GhcPs
_  -> SDoc -> TcRn ()
addErr forall a b. (a -> b) -> a -> b
$ HsDocContext -> SDoc -> SDoc
withHsDocContext HsDocContext
ctxt SDoc
msg
  where
    sig_ty_bndrs :: LHsSigType GhcPs -> [HsTyVarBndr Specificity GhcPs]
    sig_ty_bndrs :: LHsSigType GhcPs -> [HsTyVarBndr Specificity GhcPs]
sig_ty_bndrs (L SrcSpanAnnA
_ (HsSig{sig_bndrs :: forall pass. HsSigType pass -> HsOuterSigTyVarBndrs pass
sig_bndrs = HsOuterSigTyVarBndrs GhcPs
outer_bndrs}))
      = forall a b. (a -> b) -> [a] -> [b]
map forall l e. GenLocated l e -> e
unLoc (forall flag (p :: Pass).
HsOuterTyVarBndrs flag (GhcPass p)
-> [LHsTyVarBndr flag (NoGhcTc (GhcPass p))]
hsOuterExplicitBndrs HsOuterSigTyVarBndrs GhcPs
outer_bndrs)

{-
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 :: SDoc -> LHsType GhcRn -> Maybe (SrcSpan, SDoc)
noNestedForallsContextsErr SDoc
what LHsType GhcRn
lty =
  case forall (p :: Pass). LHsType (GhcPass p) -> LHsType (GhcPass p)
ignoreParens LHsType GhcRn
lty of
    L SrcSpanAnnA
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).
      -> forall a. a -> Maybe a
Just (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
l, [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Illegal visible, dependent quantification" SDoc -> SDoc -> SDoc
<+>
                              String -> SDoc
text String
"in the type of a term"
                            , String -> SDoc
text String
"(GHC does not yet support this)" ])
      |  HsForAllInvis{} <- HsForAllTelescope GhcRn
tele
      -> forall a. a -> Maybe a
Just (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
l, SDoc
nested_foralls_contexts_err)
    L SrcSpanAnnA
l (HsQualTy {})
      -> forall a. a -> Maybe a
Just (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
l, SDoc
nested_foralls_contexts_err)
    LHsType GhcRn
_ -> forall a. Maybe a
Nothing
  where
    nested_foralls_contexts_err :: SDoc
nested_foralls_contexts_err =
      SDoc
what SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"cannot contain nested"
      SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes SDoc
forAllLit SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"s or contexts"

-- | A common way to invoke 'noNestedForallsContextsErr'.
addNoNestedForallsContextsErr :: HsDocContext -> SDoc -> LHsType GhcRn -> RnM ()
addNoNestedForallsContextsErr :: HsDocContext -> SDoc -> LHsType GhcRn -> TcRn ()
addNoNestedForallsContextsErr HsDocContext
ctxt SDoc
what LHsType GhcRn
lty =
  forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust (SDoc -> LHsType GhcRn -> Maybe (SrcSpan, SDoc)
noNestedForallsContextsErr SDoc
what LHsType GhcRn
lty) forall a b. (a -> b) -> a -> b
$ \(SrcSpan
l, SDoc
err_msg) ->
    SrcSpan -> SDoc -> TcRn ()
addErrAt SrcSpan
l forall a b. (a -> b) -> a -> b
$ HsDocContext -> SDoc -> SDoc
withHsDocContext HsDocContext
ctxt SDoc
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
                               ; 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 <- 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 forall a b. [(a, b)] -> ([a], [b])
unzip [(b, FreeVars)]
stuff of
                      ([b]
ys, [FreeVars]
fvs_s) -> 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 = forall (m :: * -> *) a. Monad m => a -> m a
return (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; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just b
y, FreeVars
fvs) }

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

warnUnusedTopBinds :: [GlobalRdrElt] -> RnM ()
warnUnusedTopBinds :: [GlobalRdrElt] -> TcRn ()
warnUnusedTopBinds [GlobalRdrElt]
gres
    = forall gbl lcl.
WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM WarningFlag
Opt_WarnUnusedTopBinds
    forall a b. (a -> b) -> a -> b
$ do TcGblEnv
env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
         let isBoot :: Bool
isBoot = TcGblEnv -> HscSource
tcg_src TcGblEnv
env 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 forall a. (a -> Bool) -> [a] -> [a]
filter GlobalRdrElt -> Bool
noParent [GlobalRdrElt]
gres
                               else                 [GlobalRdrElt]
gres
         [GlobalRdrElt] -> TcRn ()
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] -> TcRn ()
checkUnusedRecordWildcard SrcSpan
_ FreeVars
_ Maybe [Name]
Nothing     = forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkUnusedRecordWildcard SrcSpan
loc FreeVars
_ (Just []) =
  -- Add a new warning if the .. pattern binds no variables
  forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc forall a b. (a -> b) -> a -> b
$ TcRn ()
warnRedundantRecordWildcard
checkUnusedRecordWildcard SrcSpan
loc FreeVars
fvs (Just [Name]
dotdot_names) =
  forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc forall a b. (a -> b) -> a -> b
$ [Name] -> FreeVars -> TcRn ()
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 :: TcRn ()
warnRedundantRecordWildcard =
  forall gbl lcl.
WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM WarningFlag
Opt_WarnRedundantRecordWildcards
            (WarnReason -> SDoc -> TcRn ()
addWarn (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnRedundantRecordWildcards)
                     SDoc
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 -> TcRn ()
warnUnusedRecordWildcard [Name]
ns FreeVars
used_names = do
  let used :: [Name]
used = forall a. (a -> Bool) -> [a] -> [a]
filter (Name -> FreeVars -> Bool
`elemNameSet` FreeVars
used_names) [Name]
ns
  String -> SDoc -> TcRn ()
traceRn String
"warnUnused" (forall a. Outputable a => a -> SDoc
ppr [Name]
ns SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr FreeVars
used_names SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr [Name]
used)
  WarningFlag -> Bool -> SDoc -> TcRn ()
warnIfFlag WarningFlag
Opt_WarnUnusedRecordWildcards (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
used)
    SDoc
unusedRecordWildcardWarning



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

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

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

-- NB the Names must not be the names of record fields!
warnUnused :: WarningFlag -> [Name] -> RnM ()
warnUnused :: WarningFlag -> [Name] -> TcRn ()
warnUnused WarningFlag
flag [Name]
names =
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (WarningFlag -> GreName -> TcRn ()
warnUnused1 WarningFlag
flag forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> GreName
NormalGreName) [Name]
names

warnUnused1 :: WarningFlag -> GreName -> RnM ()
warnUnused1 :: WarningFlag -> GreName -> TcRn ()
warnUnused1 WarningFlag
flag GreName
child
  = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GreName -> Bool
reportable GreName
child) forall a b. (a -> b) -> a -> b
$
    WarningFlag -> OccName -> SrcSpan -> SDoc -> TcRn ()
addUnusedWarning WarningFlag
flag
                     (forall name. HasOccName name => name -> OccName
occName GreName
child) (GreName -> SrcSpan
greNameSrcSpan GreName
child)
                     (String -> SDoc
text forall a b. (a -> b) -> a -> b
$ String
"Defined but not used" forall a. [a] -> [a] -> [a]
++ String
opt_str)
  where
    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 -> TcRn ()
warnUnusedGRE gre :: GlobalRdrElt
gre@(GRE { gre_lcl :: GlobalRdrElt -> Bool
gre_lcl = Bool
lcl, gre_imp :: GlobalRdrElt -> [ImportSpec]
gre_imp = [ImportSpec]
is })
  | Bool
lcl       = WarningFlag -> GreName -> TcRn ()
warnUnused1 WarningFlag
Opt_WarnUnusedTopBinds (GlobalRdrElt -> GreName
gre_name GlobalRdrElt
gre)
  | Bool
otherwise = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GreName -> Bool
reportable (GlobalRdrElt -> GreName
gre_name GlobalRdrElt
gre)) (forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ImportSpec -> TcRn ()
warn [ImportSpec]
is)
  where
    occ :: OccName
occ = GlobalRdrElt -> OccName
greOccName GlobalRdrElt
gre
    warn :: ImportSpec -> TcRn ()
warn ImportSpec
spec = WarningFlag -> OccName -> SrcSpan -> SDoc -> TcRn ()
addUnusedWarning WarningFlag
Opt_WarnUnusedTopBinds OccName
occ SrcSpan
span SDoc
msg
        where
           span :: SrcSpan
span = ImportSpec -> SrcSpan
importSpecLoc ImportSpec
spec
           pp_mod :: SDoc
pp_mod = SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr (ImportSpec -> ModuleName
importSpecModule ImportSpec
spec))
           msg :: SDoc
msg = String -> SDoc
text String
"Imported from" SDoc -> SDoc -> SDoc
<+> SDoc
pp_mod SDoc -> SDoc -> SDoc
<+> PtrString -> SDoc
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, Parent)
mkFieldEnv :: GlobalRdrEnv -> NameEnv (FieldLabelString, Parent)
mkFieldEnv GlobalRdrEnv
rdr_env = forall a. [(Name, a)] -> NameEnv a
mkNameEnv [ (GlobalRdrElt -> Name
greMangledName GlobalRdrElt
gre, (FieldLabel -> FieldLabelString
flLabel FieldLabel
fl, GlobalRdrElt -> Parent
gre_par GlobalRdrElt
gre))
                               | [GlobalRdrElt]
gres <- forall a. OccEnv a -> [a]
occEnvElts GlobalRdrEnv
rdr_env
                               , GlobalRdrElt
gre <- [GlobalRdrElt]
gres
                               , Just FieldLabel
fl <- [GlobalRdrElt -> Maybe FieldLabel
greFieldLabel GlobalRdrElt
gre]
                               ]

-- | Should we report the fact that this 'Name' is unused? The
-- 'OccName' may differ from 'nameOccName' due to
-- DuplicateRecordFields.
reportable :: GreName -> Bool
reportable :: GreName -> Bool
reportable GreName
child
  | NormalGreName Name
name <- GreName
child
  , 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 (forall name. HasOccName name => name -> OccName
occName GreName
child))

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

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

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

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

{-
Note [Skipping ambiguity errors at use sites of local declarations]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In general, we do not report ambiguous occurrences at use sites where all the
clashing names are defined locally, because the error will have been reported at
the definition site, and we want to avoid an error cascade.

However, when DuplicateRecordFields is enabled, it is possible to define the
same field name multiple times, so we *do* need to report an error at the use
site when there is ambiguity between multiple fields. Moreover, when
NoFieldSelectors is enabled, it is possible to define a field with the same name
as a non-field, so again we need to report ambiguity at the use site.

We can skip reporting an ambiguity error whenever defining the GREs must have
yielded a duplicate declarations error.  More precisely, we can skip if:

 * there are at least two non-fields amongst the GREs; or

 * there are at least two fields amongst the GREs, and DuplicateRecordFields is
   *disabled*; or

 * there is at least one non-field, at least one field, and NoFieldSelectors is
   *disabled*.

These conditions ensure that a duplicate local declaration will have been
reported.  See also Note [Reporting duplicate local declarations] in
GHC.Rename.Names).

-}

addNameClashErrRn :: RdrName -> NE.NonEmpty GlobalRdrElt -> RnM ()
addNameClashErrRn :: RdrName -> NonEmpty GlobalRdrElt -> TcRn ()
addNameClashErrRn RdrName
rdr_name NonEmpty GlobalRdrElt
gres
  | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all GlobalRdrElt -> Bool
isLocalGRE NonEmpty GlobalRdrElt
gres Bool -> Bool -> Bool
&& Bool
can_skip
  -- If there are two or more *local* defns, we'll usually have reported that
  -- already, and we don't want an error cascade.
  = forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise
  = SDoc -> TcRn ()
addErr ([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Ambiguous occurrence" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr RdrName
rdr_name)
                 , String -> SDoc
text String
"It could refer to"
                 , Int -> SDoc -> SDoc
nest Int
3 ([SDoc] -> SDoc
vcat (SDoc
msg1 forall a. a -> [a] -> [a]
: [SDoc]
msgs)) ])
  where
    GlobalRdrElt
np1 NE.:| [GlobalRdrElt]
nps = NonEmpty GlobalRdrElt
gres
    msg1 :: SDoc
msg1 =  String -> SDoc
text String
"either" SDoc -> SDoc -> SDoc
<+> GlobalRdrElt -> SDoc
ppr_gre GlobalRdrElt
np1
    msgs :: [SDoc]
msgs = [String -> SDoc
text String
"    or" SDoc -> SDoc -> SDoc
<+> GlobalRdrElt -> SDoc
ppr_gre GlobalRdrElt
np | GlobalRdrElt
np <- [GlobalRdrElt]
nps]
    ppr_gre :: GlobalRdrElt -> SDoc
ppr_gre GlobalRdrElt
gre = [SDoc] -> SDoc
sep [ GlobalRdrElt -> SDoc
pp_greMangledName GlobalRdrElt
gre SDoc -> SDoc -> SDoc
<> SDoc
comma
                      , GlobalRdrElt -> SDoc
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_greMangledName :: GlobalRdrElt -> SDoc
pp_greMangledName gre :: GlobalRdrElt
gre@(GRE { gre_name :: GlobalRdrElt -> GreName
gre_name = GreName
child, gre_par :: GlobalRdrElt -> Parent
gre_par = Parent
par
                         , gre_lcl :: GlobalRdrElt -> Bool
gre_lcl = Bool
lcl, gre_imp :: GlobalRdrElt -> [ImportSpec]
gre_imp = [ImportSpec]
iss }) =
      case GreName
child of
        FieldGreName FieldLabel
fl  -> String -> SDoc
text String
"the field" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr FieldLabel
fl) SDoc -> SDoc -> SDoc
<+> SDoc
parent_info
        NormalGreName Name
name -> SDoc -> SDoc
quotes (Name -> SDoc
pp_qual Name
name SDoc -> SDoc -> SDoc
<> SDoc
dot SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr (Name -> OccName
nameOccName Name
name))
      where
        parent_info :: SDoc
parent_info = case Parent
par of
          Parent
NoParent -> SDoc
empty
          ParentIs { par_is :: Parent -> Name
par_is = Name
par_name } -> String -> SDoc
text String
"of record" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
par_name)
        pp_qual :: Name -> SDoc
pp_qual Name
name
                | Bool
lcl
                = forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => 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
                = forall a. Outputable a => a -> SDoc
ppr ModuleName
mod
                | Bool
otherwise
                = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"addNameClassErrRn" (forall a. Outputable a => a -> SDoc
ppr GlobalRdrElt
gre SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr [ImportSpec]
iss)
                  -- Invariant: either 'lcl' is True or 'iss' is non-empty

    -- If all the GREs are defined locally, can we skip reporting an ambiguity
    -- error at use sites, because it will have been reported already? See
    -- Note [Skipping ambiguity errors at use sites of local declarations]
    can_skip :: Bool
can_skip = Int
num_non_flds forall a. Ord a => a -> a -> Bool
>= Int
2
            Bool -> Bool -> Bool
|| (Int
num_flds forall a. Ord a => a -> a -> Bool
>= Int
2 Bool -> Bool -> Bool
&& Bool -> Bool
not (GlobalRdrElt -> Bool
isDuplicateRecFldGRE (forall a. [a] -> a
head [GlobalRdrElt]
flds)))
            Bool -> Bool -> Bool
|| (Int
num_non_flds forall a. Ord a => a -> a -> Bool
>= Int
1 Bool -> Bool -> Bool
&& Int
num_flds forall a. Ord a => a -> a -> Bool
>= Int
1
                                  Bool -> Bool -> Bool
&& Bool -> Bool
not (GlobalRdrElt -> Bool
isNoFieldSelectorGRE (forall a. [a] -> a
head [GlobalRdrElt]
flds)))
    ([GlobalRdrElt]
flds, [GlobalRdrElt]
non_flds) = forall a. (a -> Bool) -> NonEmpty a -> ([a], [a])
NE.partition GlobalRdrElt -> Bool
isRecFldGRE NonEmpty GlobalRdrElt
gres
    num_flds :: Int
num_flds     = forall (t :: * -> *) a. Foldable t => t a -> Int
length [GlobalRdrElt]
flds
    num_non_flds :: Int
num_non_flds = forall (t :: * -> *) a. Foldable t => t a -> Int
length [GlobalRdrElt]
non_flds


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


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


dupNamesErr :: Outputable n => (n -> SrcSpan) -> NE.NonEmpty n -> RnM ()
dupNamesErr :: forall n. Outputable n => (n -> SrcSpan) -> NonEmpty n -> TcRn ()
dupNamesErr n -> SrcSpan
get_loc NonEmpty n
names
  = SrcSpan -> SDoc -> TcRn ()
addErrAt SrcSpan
big_loc forall a b. (a -> b) -> a -> b
$
    [SDoc] -> SDoc
vcat [String -> SDoc
text String
"Conflicting definitions for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr (forall a. NonEmpty a -> a
NE.head NonEmpty n
names)),
          SDoc
locations]
  where
    locs :: [SrcSpan]
locs      = forall a b. (a -> b) -> [a] -> [b]
map n -> SrcSpan
get_loc (forall a. NonEmpty a -> [a]
NE.toList NonEmpty n
names)
    big_loc :: SrcSpan
big_loc   = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans [SrcSpan]
locs
    locations :: SDoc
locations = String -> SDoc
text String
"Bound at:" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
vcat (forall a b. (a -> b) -> [a] -> [b]
map forall a. Outputable a => a -> SDoc
ppr (forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy SrcSpan -> SrcSpan -> Ordering
SrcLoc.leftmost_smallest [SrcSpan]
locs))

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

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

-- | Ensure that a boxed or unboxed tuple has arity no larger than
-- 'mAX_TUPLE_SIZE'.
checkTupSize :: Int -> TcM ()
checkTupSize :: Int -> TcRn ()
checkTupSize Int
tup_size
  | Int
tup_size forall a. Ord a => a -> a -> Bool
<= Int
mAX_TUPLE_SIZE
  = forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise
  = SDoc -> TcRn ()
addErr ([SDoc] -> SDoc
sep [String -> SDoc
text String
"A" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
tup_size SDoc -> SDoc -> SDoc
<> PtrString -> SDoc
ptext (String -> PtrString
sLit String
"-tuple is too large for GHC"),
                 Int -> SDoc -> SDoc
nest Int
2 (SDoc -> SDoc
parens (String -> SDoc
text String
"max size is" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
mAX_TUPLE_SIZE)),
                 Int -> SDoc -> SDoc
nest Int
2 (String -> SDoc
text String
"Workaround: use nested tuples or define a data type")])

-- | Ensure that a constraint tuple has arity no larger than 'mAX_CTUPLE_SIZE'.
checkCTupSize :: Int -> TcM ()
checkCTupSize :: Int -> TcRn ()
checkCTupSize Int
tup_size
  | Int
tup_size forall a. Ord a => a -> a -> Bool
<= Int
mAX_CTUPLE_SIZE
  = forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise
  = SDoc -> TcRn ()
addErr (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Constraint tuple arity too large:" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
tup_size
                  SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens (String -> SDoc
text String
"max arity =" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
mAX_CTUPLE_SIZE))
               Int
2 (String -> SDoc
text String
"Instead, use a nested tuple"))


{-
************************************************************************
*                                                                      *
\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 (LocatedN RdrName)
  | DerivDeclCtx
  | RuleCtx FastString
  | TyDataCtx (LocatedN RdrName)
  | TySynCtx (LocatedN RdrName)
  | TyFamilyCtx (LocatedN RdrName)
  | FamPatCtx (LocatedN RdrName)    -- The patterns of a type/data family instance
  | ConDeclCtx [LocatedN Name]
  | ClassDeclCtx (LocatedN RdrName)
  | ExprWithTySigCtx
  | TypBrCtx
  | HsTypeCtx
  | HsTypePatCtx
  | GHCiCtx
  | SpliceTypeCtx (LHsType GhcPs)
  | ClassInstanceCtx
  | GenericCtx SDoc   -- Maybe we want to use this more!

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

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

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

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