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

{-

This module contains miscellaneous functions related to renaming.

-}

module GHC.Rename.Utils (
        checkDupRdrNames, checkShadowedRdrNames,
        checkDupNames, checkDupAndShadowedNames, dupNamesErr,
        checkTupSize, checkCTupSize,
        addFvRn, mapFvRn, mapMaybeFvRn,
        warnUnusedMatches, warnUnusedTypePatterns,
        warnUnusedTopBinds, warnUnusedLocalBinds,
        warnForallIdentifier,
        checkUnusedRecordWildcard,
        badQualBndrErr, typeAppErr, badFieldConErr,
        wrapGenSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genLHsApp,
        genAppType,
        genLHsLit, genHsIntegralLit, genHsTyLit, genSimpleConPat,
        genVarPat, genWildPat,
        genSimpleFunBind, genFunBind,

        newLocalBndrRn, newLocalBndrsRn,

        bindLocalNames, bindLocalNamesFV, delLocalNames,

        addNameClashErrRn, mkNameClashErr,

        checkInferredVars,
        noNestedForallsContextsErr, addNoNestedForallsContextsErr,

        isIrrefutableHsPatRn
)

where


import GHC.Prelude hiding (unzip)

import GHC.Core.Type
import GHC.Hs
import GHC.Types.Name.Reader
import GHC.Tc.Errors.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.Types.SourceFile
import GHC.Types.SourceText ( SourceText(..), IntegralLit )
import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Types.Basic
import GHC.Data.List.SetOps ( removeDupsOn )
import GHC.Data.Maybe ( whenIsJust )
import GHC.Driver.DynFlags
import GHC.Data.FastString
import Control.Monad
import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE )
import qualified GHC.LanguageExtensions as LangExt

import qualified Data.List as List
import qualified Data.List.NonEmpty as NE


{-
*********************************************************
*                                                      *
\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
  = Name -> RnM Name
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 -> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErrAt (SrcSpanAnnN -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnN
loc) (RdrName -> TcRnMessage
badQualBndrErr RdrName
rdr_name))
       ; Unique
uniq <- TcRnIf TcGblEnv TcLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
       ; Name -> RnM Name
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Unique -> OccName -> SrcSpan -> Name
mkInternalName Unique
uniq (RdrName -> OccName
rdrNameOcc RdrName
rdr_name) (SrcSpanAnnN -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnN
loc)) }

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

bindLocalNames :: [Name] -> RnM a -> RnM a
bindLocalNames :: forall a. [Name] -> RnM a -> RnM a
bindLocalNames [Name]
names
  = (TcLclCtxt -> TcLclCtxt)
-> TcRnIf TcGblEnv TcLclEnv a -> TcRnIf TcGblEnv TcLclEnv a
forall gbl a.
(TcLclCtxt -> TcLclCtxt)
-> TcRnIf gbl TcLclEnv a -> TcRnIf gbl TcLclEnv a
updLclCtxt ((TcLclCtxt -> TcLclCtxt)
 -> TcRnIf TcGblEnv TcLclEnv a -> TcRnIf TcGblEnv TcLclEnv a)
-> (TcLclCtxt -> TcLclCtxt)
-> TcRnIf TcGblEnv TcLclEnv a
-> TcRnIf TcGblEnv TcLclEnv a
forall a b. (a -> b) -> a -> b
$ \ TcLclCtxt
lcl_env ->
    let th_level :: Int
th_level  = ThStage -> Int
thLevel (TcLclCtxt -> ThStage
tcl_th_ctxt TcLclCtxt
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 (TcLclCtxt -> NameEnv (TopLevelFlag, Int)
tcl_th_bndrs TcLclCtxt
lcl_env)
                    [ (Name
n, (TopLevelFlag
NotTopLevel, Int
th_level)) | Name
n <- [Name]
names ]
        rdr_env' :: LocalRdrEnv
rdr_env'  = LocalRdrEnv -> [Name] -> LocalRdrEnv
extendLocalRdrEnvList (TcLclCtxt -> LocalRdrEnv
tcl_rdr TcLclCtxt
lcl_env) [Name]
names
    in TcLclCtxt
lcl_env { tcl_th_bndrs = th_bndrs'
               , tcl_rdr      = rdr_env' }

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 a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, [Name] -> FreeVars -> FreeVars
delFVs [Name]
names FreeVars
fvs) }

delLocalNames :: [Name] -> RnM a -> RnM a
delLocalNames :: forall a. [Name] -> RnM a -> RnM a
delLocalNames [Name]
names
  = (TcLclCtxt -> TcLclCtxt)
-> TcRnIf TcGblEnv TcLclEnv a -> TcRnIf TcGblEnv TcLclEnv a
forall gbl a.
(TcLclCtxt -> TcLclCtxt)
-> TcRnIf gbl TcLclEnv a -> TcRnIf gbl TcLclEnv a
updLclCtxt ((TcLclCtxt -> TcLclCtxt)
 -> TcRnIf TcGblEnv TcLclEnv a -> TcRnIf TcGblEnv TcLclEnv a)
-> (TcLclCtxt -> TcLclCtxt)
-> TcRnIf TcGblEnv TcLclEnv a
-> TcRnIf TcGblEnv TcLclEnv a
forall a b. (a -> b) -> a -> b
$ \ TcLclCtxt
lcl_env ->
    let th_bndrs' :: NameEnv (TopLevelFlag, Int)
th_bndrs' = NameEnv (TopLevelFlag, Int)
-> [Name] -> NameEnv (TopLevelFlag, Int)
forall a. NameEnv a -> [Name] -> NameEnv a
delListFromNameEnv (TcLclCtxt -> NameEnv (TopLevelFlag, Int)
tcl_th_bndrs TcLclCtxt
lcl_env) [Name]
names
        rdr_env' :: LocalRdrEnv
rdr_env'  = LocalRdrEnv -> [OccName] -> LocalRdrEnv
minusLocalRdrEnvList (TcLclCtxt -> LocalRdrEnv
tcl_rdr TcLclCtxt
lcl_env) ((Name -> OccName) -> [Name] -> [OccName]
forall a b. (a -> b) -> [a] -> [b]
map Name -> OccName
forall name. HasOccName name => name -> OccName
occName [Name]
names)
    in TcLclCtxt
lcl_env { tcl_th_bndrs = th_bndrs'
               , tcl_rdr      = rdr_env' }

-------------------------------------
checkDupRdrNames :: [LocatedN RdrName] -> RnM ()
-- Check for duplicated names in a binding group
checkDupRdrNames :: [LocatedN RdrName] -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkDupRdrNames [LocatedN RdrName]
rdr_names_w_loc
  = (NonEmpty (LocatedN RdrName) -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> [NonEmpty (LocatedN RdrName)]
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\ NonEmpty (LocatedN RdrName)
ns -> NonEmpty SrcSpan
-> NonEmpty RdrName -> IOEnv (Env TcGblEnv TcLclEnv) ()
dupNamesErr (LocatedN RdrName -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA (LocatedN RdrName -> SrcSpan)
-> NonEmpty (LocatedN RdrName) -> NonEmpty SrcSpan
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (LocatedN RdrName)
ns) (LocatedN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc (LocatedN RdrName -> RdrName)
-> NonEmpty (LocatedN RdrName) -> NonEmpty RdrName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (LocatedN RdrName)
ns)) [NonEmpty (LocatedN RdrName)]
dups
  where
    ([LocatedN RdrName]
_, [NonEmpty (LocatedN RdrName)]
dups) = (LocatedN RdrName -> RdrName)
-> [LocatedN RdrName]
-> ([LocatedN RdrName], [NonEmpty (LocatedN RdrName)])
forall b a. Ord b => (a -> b) -> [a] -> ([a], [NonEmpty a])
removeDupsOn LocatedN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc [LocatedN 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_ (\ NonEmpty Name
ns -> NonEmpty SrcSpan
-> NonEmpty RdrName -> IOEnv (Env TcGblEnv TcLclEnv) ()
dupNamesErr (Name -> SrcSpan
nameSrcSpan (Name -> SrcSpan) -> NonEmpty Name -> NonEmpty SrcSpan
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty Name
ns) (Name -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName (Name -> RdrName) -> NonEmpty Name -> NonEmpty RdrName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty Name
ns)) [NonEmpty Name]
dups
  where
    ([Name]
_, [NonEmpty Name]
dups) = (Name -> OccName) -> [Name] -> ([Name], [NonEmpty Name])
forall b a. Ord b => (a -> b) -> [a] -> ([a], [NonEmpty a])
removeDupsOn Name -> OccName
nameOccName [Name]
names

---------------------
checkShadowedRdrNames :: [LocatedN RdrName] -> RnM ()
checkShadowedRdrNames :: [LocatedN RdrName] -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkShadowedRdrNames [LocatedN RdrName]
loc_rdr_names
  = do { (GlobalRdrEnv, LocalRdrEnv)
envs <- TcRn (GlobalRdrEnv, LocalRdrEnv)
getRdrEnvs
       ; (GlobalRdrEnv, LocalRdrEnv)
-> (LocatedN RdrName -> (SrcSpan, OccName))
-> [LocatedN RdrName]
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a.
(GlobalRdrEnv, LocalRdrEnv)
-> (a -> (SrcSpan, OccName))
-> [a]
-> IOEnv (Env TcGblEnv TcLclEnv) ()
checkShadowedOccs (GlobalRdrEnv, LocalRdrEnv)
envs LocatedN RdrName -> (SrcSpan, OccName)
forall {a}.
GenLocated (SrcSpanAnn' a) RdrName -> (SrcSpan, OccName)
get_loc_occ [LocatedN RdrName]
filtered_rdrs }
  where
    filtered_rdrs :: [LocatedN RdrName]
filtered_rdrs = (LocatedN RdrName -> Bool)
-> [LocatedN RdrName] -> [LocatedN RdrName]
forall a. (a -> Bool) -> [a] -> [a]
filterOut (RdrName -> Bool
isExact (RdrName -> Bool)
-> (LocatedN RdrName -> RdrName) -> LocatedN RdrName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocatedN RdrName -> RdrName
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) = (SrcSpanAnn' a -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' 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 -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"checkShadowedOccs:shadow" ([(SrcSpan, OccName)] -> SDoc
forall a. Outputable a => a -> SDoc
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 a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()  -- Do not report shadowing for "_x"
                                                -- See #3262
        | Just Name
n <- Maybe Name
mb_local = ShadowedNameProvenance -> IOEnv (Env TcGblEnv TcLclEnv) ()
complain (SrcLoc -> ShadowedNameProvenance
ShadowedNameProvenanceLocal (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
                         ; Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool)
-> ([GlobalRdrElt] -> Bool) -> [GlobalRdrElt] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GlobalRdrElt] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([GlobalRdrElt] -> Bool) -> [GlobalRdrElt] -> Bool
forall a b. (a -> b) -> a -> b
$ [GlobalRdrElt]
gres') (IOEnv (Env TcGblEnv TcLclEnv) ()
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ ShadowedNameProvenance -> IOEnv (Env TcGblEnv TcLclEnv) ()
complain ([GlobalRdrElt] -> ShadowedNameProvenance
ShadowedNameProvenanceGlobal [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      = GlobalRdrEnv -> LookupGRE GREInfo -> [GlobalRdrElt]
forall info.
GlobalRdrEnvX info -> LookupGRE info -> [GlobalRdrEltX info]
lookupGRE GlobalRdrEnv
global_env (RdrName -> WhichGREs GREInfo -> LookupGRE GREInfo
forall info. RdrName -> WhichGREs info -> LookupGRE info
LookupRdrName (OccName -> RdrName
mkRdrUnqual OccName
occ) (FieldsOrSelectors -> WhichGREs GREInfo
RelevantGREsFOS FieldsOrSelectors
WantBoth))
                -- Make an Unqualified RdrName and look that up, so that
                -- we don't find any GREs that are in scope qualified-only

          complain :: ShadowedNameProvenance -> IOEnv (Env TcGblEnv TcLclEnv) ()
complain ShadowedNameProvenance
provenance = SrcSpan -> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addDiagnosticAt SrcSpan
loc (OccName -> ShadowedNameProvenance -> TcRnMessage
TcRnShadowedName OccName
occ ShadowedNameProvenance
provenance)

    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
forall info. GlobalRdrEltX info -> 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 a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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.NamedFieldPuns 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 a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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
                  -> LHsSigType GhcPs
                  -> RnM ()
checkInferredVars :: HsDocContext
-> LHsSigType GhcPs -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkInferredVars HsDocContext
ctxt LHsSigType GhcPs
ty =
  let bndrs :: [HsTyVarBndr Specificity GhcPs]
bndrs = LHsSigType GhcPs -> [HsTyVarBndr Specificity GhcPs]
sig_ty_bndrs LHsSigType GhcPs
ty
  in case (HsTyVarBndr Specificity GhcPs -> Bool)
-> [HsTyVarBndr Specificity GhcPs]
-> [HsTyVarBndr Specificity GhcPs]
forall a. (a -> Bool) -> [a] -> [a]
filter (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
    [] -> () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    HsTyVarBndr Specificity GhcPs
iv : [HsTyVarBndr Specificity GhcPs]
ivs -> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr (TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
      HsDocContext -> TcRnMessage -> TcRnMessage
TcRnWithHsDocContext HsDocContext
ctxt (TcRnMessage -> TcRnMessage) -> TcRnMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$
      NonEmpty (HsTyVarBndr Specificity GhcPs) -> TcRnMessage
TcRnIllegalInferredTyVars (HsTyVarBndr Specificity GhcPs
iv HsTyVarBndr Specificity GhcPs
-> [HsTyVarBndr Specificity GhcPs]
-> NonEmpty (HsTyVarBndr Specificity GhcPs)
forall a. a -> [a] -> NonEmpty a
NE.:| [HsTyVarBndr Specificity GhcPs]
ivs)
  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}))
      = (GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)
 -> HsTyVarBndr Specificity GhcPs)
-> [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
-> [HsTyVarBndr Specificity GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)
-> HsTyVarBndr Specificity GhcPs
forall l e. GenLocated l e -> e
unLoc (HsOuterSigTyVarBndrs GhcPs
-> [LHsTyVarBndr Specificity (NoGhcTc GhcPs)]
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 :: NestedForallsContextsIn
                           -> LHsType GhcRn
                           -> Maybe (SrcSpan, TcRnMessage)
noNestedForallsContextsErr :: NestedForallsContextsIn
-> LHsType GhcRn -> Maybe (SrcSpan, TcRnMessage)
noNestedForallsContextsErr NestedForallsContextsIn
what LHsType GhcRn
lty =
  case LHsType GhcRn -> LHsType GhcRn
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).
      -> (SrcSpan, TcRnMessage) -> Maybe (SrcSpan, TcRnMessage)
forall a. a -> Maybe a
Just (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
l, Maybe Type -> TcRnMessage
TcRnVDQInTermType Maybe Type
forall a. Maybe a
Nothing)
      |  HsForAllInvis{} <- HsForAllTelescope GhcRn
tele
      -> (SrcSpan, TcRnMessage) -> Maybe (SrcSpan, TcRnMessage)
forall a. a -> Maybe a
Just (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
l, TcRnMessage
nested_foralls_contexts_err)
    L SrcSpanAnnA
l (HsQualTy {})
      -> (SrcSpan, TcRnMessage) -> Maybe (SrcSpan, TcRnMessage)
forall a. a -> Maybe a
Just (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
l, TcRnMessage
nested_foralls_contexts_err)
    LHsType GhcRn
_ -> Maybe (SrcSpan, TcRnMessage)
forall a. Maybe a
Nothing
  where
    nested_foralls_contexts_err :: TcRnMessage
nested_foralls_contexts_err =
      NestedForallsContextsIn -> TcRnMessage
TcRnNestedForallsContexts NestedForallsContextsIn
what

-- | A common way to invoke 'noNestedForallsContextsErr'.
addNoNestedForallsContextsErr :: HsDocContext
                              -> NestedForallsContextsIn
                              -> LHsType GhcRn
                              -> RnM ()
addNoNestedForallsContextsErr :: HsDocContext
-> NestedForallsContextsIn
-> LHsType GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) ()
addNoNestedForallsContextsErr HsDocContext
ctxt NestedForallsContextsIn
what LHsType GhcRn
lty =
  Maybe (SrcSpan, TcRnMessage)
-> ((SrcSpan, TcRnMessage) -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust (NestedForallsContextsIn
-> LHsType GhcRn -> Maybe (SrcSpan, TcRnMessage)
noNestedForallsContextsErr NestedForallsContextsIn
what LHsType GhcRn
lty) (((SrcSpan, TcRnMessage) -> IOEnv (Env TcGblEnv TcLclEnv) ())
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> ((SrcSpan, TcRnMessage) -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ \(SrcSpan
l, TcRnMessage
err_msg) ->
    SrcSpan -> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErrAt SrcSpan
l (TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ HsDocContext -> TcRnMessage -> TcRnMessage
TcRnWithHsDocContext HsDocContext
ctxt TcRnMessage
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 a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (thing
res, FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2) }

mapFvRn :: Traversable f => (a -> RnM (b, FreeVars)) -> f a -> RnM (f b, FreeVars)
mapFvRn :: forall (f :: * -> *) a b.
Traversable f =>
(a -> RnM (b, FreeVars)) -> f a -> RnM (f b, FreeVars)
mapFvRn a -> RnM (b, FreeVars)
f f a
xs = do
    f (b, FreeVars)
stuff <- (a -> RnM (b, FreeVars))
-> f a -> IOEnv (Env TcGblEnv TcLclEnv) (f (b, FreeVars))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> f a -> m (f b)
mapM a -> RnM (b, FreeVars)
f f a
xs
    case f (b, FreeVars) -> (f b, f FreeVars)
forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
unzip f (b, FreeVars)
stuff of
        (f b
ys, f FreeVars
fvs_s) -> (f b, FreeVars) -> RnM (f b, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (f b
ys, (FreeVars -> FreeVars -> FreeVars)
-> FreeVars -> f FreeVars -> FreeVars
forall b a. (b -> a -> b) -> b -> f a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((FreeVars -> FreeVars -> FreeVars)
-> FreeVars -> FreeVars -> FreeVars
forall a b c. (a -> b -> c) -> b -> a -> c
flip FreeVars -> FreeVars -> FreeVars
plusFV) FreeVars
emptyFVs f FreeVars
fvs_s)
{-# SPECIALIZE mapFvRn :: (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars) #-}

unzip :: Functor f => f (a, b) -> (f a, f b)
unzip :: forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
unzip = \ f (a, b)
xs -> (((a, b) -> a) -> f (a, b) -> f a
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, b) -> a
forall a b. (a, b) -> a
fst f (a, b)
xs, ((a, b) -> b) -> f (a, b) -> f b
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, b) -> b
forall a b. (a, b) -> b
snd f (a, b)
xs)
{-# NOINLINE [1] unzip #-}
{-# RULES "unzip/List" unzip = List.unzip #-}

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 a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 = HscSource -> Bool
isHsBootFile (HscSource -> Bool) -> HscSource -> Bool
forall a b. (a -> b) -> a -> b
$ TcGblEnv -> HscSource
tcg_src TcGblEnv
env
         let noParent :: GlobalRdrEltX info -> Bool
noParent GlobalRdrEltX info
gre = case GlobalRdrEltX info -> Parent
forall info. GlobalRdrEltX info -> Parent
greParent GlobalRdrEltX info
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
forall info. GlobalRdrEltX info -> 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 a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkUnusedRecordWildcard SrcSpan
loc FreeVars
_ (Just []) =
  -- 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 = TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addDiagnostic TcRnMessage
TcRnRedundantRecordWildcard


-- | 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 -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"warnUnused" ([Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Name]
ns SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ FreeVars -> SDoc
forall a. Outputable a => a -> SDoc
ppr FreeVars
used_names SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Name]
used)
  Bool -> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnIf ([Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
used) ([Name] -> TcRnMessage
TcRnUnusedRecordWildcard [Name]
ns)



warnUnusedLocalBinds, warnUnusedMatches, warnUnusedTypePatterns
  :: [Name] -> FreeVars -> RnM ()
warnUnusedLocalBinds :: [Name] -> FreeVars -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnUnusedLocalBinds   = UnusedNameProv
-> [Name] -> FreeVars -> IOEnv (Env TcGblEnv TcLclEnv) ()
check_unused UnusedNameProv
UnusedNameLocalBind
warnUnusedMatches :: [Name] -> FreeVars -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnUnusedMatches      = UnusedNameProv
-> [Name] -> FreeVars -> IOEnv (Env TcGblEnv TcLclEnv) ()
check_unused UnusedNameProv
UnusedNameMatch
warnUnusedTypePatterns :: [Name] -> FreeVars -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnUnusedTypePatterns = UnusedNameProv
-> [Name] -> FreeVars -> IOEnv (Env TcGblEnv TcLclEnv) ()
check_unused UnusedNameProv
UnusedNameTypePattern

check_unused :: UnusedNameProv -> [Name] -> FreeVars -> RnM ()
check_unused :: UnusedNameProv
-> [Name] -> FreeVars -> IOEnv (Env TcGblEnv TcLclEnv) ()
check_unused UnusedNameProv
prov [Name]
bound_names FreeVars
used_names
  = UnusedNameProv -> [Name] -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnUnused UnusedNameProv
prov ((Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filterOut (Name -> FreeVars -> Bool
`elemNameSet` FreeVars
used_names) [Name]
bound_names)

warnForallIdentifier :: LocatedN RdrName -> RnM ()
warnForallIdentifier :: LocatedN RdrName -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnForallIdentifier (L SrcSpanAnnN
l rdr_name :: RdrName
rdr_name@(Unqual OccName
occ))
  | FastString -> Bool
isKw (String -> FastString
fsLit String
"forall") Bool -> Bool -> Bool
|| FastString -> Bool
isKw (String -> FastString
fsLit String
"∀")
  = SrcSpan -> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addDiagnosticAt (SrcSpanAnnN -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnN
l) (RdrName -> TcRnMessage
TcRnForallIdentifier RdrName
rdr_name)
  where isKw :: FastString -> Bool
isKw = (OccName -> FastString
occNameFS OccName
occ FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
==)
warnForallIdentifier LocatedN RdrName
_ = () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-------------------------
--      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

-- NB the Names must not be the names of record fields!
warnUnused :: UnusedNameProv -> [Name] -> RnM ()
warnUnused :: UnusedNameProv -> [Name] -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnUnused UnusedNameProv
prov [Name]
names =
  (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_ (\ Name
nm -> UnusedNameProv
-> Name -> OccName -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnUnused1 UnusedNameProv
prov Name
nm (Name -> OccName
nameOccName Name
nm)) [Name]
names

warnUnused1 :: UnusedNameProv -> Name -> OccName -> RnM ()
warnUnused1 :: UnusedNameProv
-> Name -> OccName -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnUnused1 UnusedNameProv
prov Name
child OccName
child_occ
  = Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name -> OccName -> Bool
reportable Name
child OccName
child_occ) (IOEnv (Env TcGblEnv TcLclEnv) ()
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
    UnusedNameProv
-> SrcSpan -> OccName -> IOEnv (Env TcGblEnv TcLclEnv) ()
warn_unused_name UnusedNameProv
prov (Name -> SrcSpan
nameSrcSpan Name
child) OccName
child_occ

warn_unused_name :: UnusedNameProv -> SrcSpan -> OccName -> RnM ()
warn_unused_name :: UnusedNameProv
-> SrcSpan -> OccName -> IOEnv (Env TcGblEnv TcLclEnv) ()
warn_unused_name UnusedNameProv
prov SrcSpan
span OccName
child_occ =
  SrcSpan -> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addDiagnosticAt SrcSpan
span (OccName -> UnusedNameProv -> TcRnMessage
TcRnUnusedName OccName
child_occ UnusedNameProv
prov)

warnUnusedGRE :: GlobalRdrElt -> RnM ()
warnUnusedGRE :: GlobalRdrElt -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnUnusedGRE gre :: GlobalRdrElt
gre@(GRE { gre_lcl :: forall info. GlobalRdrEltX info -> Bool
gre_lcl = Bool
lcl, gre_imp :: forall info. GlobalRdrEltX info -> Bag ImportSpec
gre_imp = Bag ImportSpec
is })
  | Bool
lcl       = UnusedNameProv
-> Name -> OccName -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnUnused1 UnusedNameProv
UnusedNameTopDecl Name
nm OccName
occ
  | Bool
otherwise = Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name -> OccName -> Bool
reportable Name
nm OccName
occ) ((ImportSpec -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> Bag 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 Bag ImportSpec
is)
  where
    occ :: OccName
occ = GlobalRdrElt -> OccName
forall info. GlobalRdrEltX info -> OccName
greOccName GlobalRdrElt
gre
    nm :: Name
nm = GlobalRdrElt -> Name
forall info. GlobalRdrEltX info -> Name
greName GlobalRdrElt
gre
    warn :: ImportSpec -> IOEnv (Env TcGblEnv TcLclEnv) ()
warn ImportSpec
spec =
      UnusedNameProv
-> SrcSpan -> OccName -> IOEnv (Env TcGblEnv TcLclEnv) ()
warn_unused_name (ModuleName -> UnusedNameProv
UnusedNameImported (ImportSpec -> ModuleName
importSpecModule ImportSpec
spec)) SrcSpan
span OccName
occ
      where
        span :: SrcSpan
span = ImportSpec -> SrcSpan
importSpecLoc ImportSpec
spec

-- | 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
child OccName
child_occ
  | Name -> Bool
isWiredInName Name
child
  = 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
child_occ)

{-
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 -> IOEnv (Env TcGblEnv TcLclEnv) ()
addNameClashErrRn RdrName
rdr_name NonEmpty GlobalRdrElt
gres
  | (GlobalRdrElt -> Bool) -> NonEmpty GlobalRdrElt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all GlobalRdrElt -> Bool
forall info. GlobalRdrEltX info -> 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.
  = () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise
  = do { GlobalRdrEnv
gre_env <- TcRn GlobalRdrEnv
getGlobalRdrEnv
       ; TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr (TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ GlobalRdrEnv -> RdrName -> NonEmpty GlobalRdrElt -> TcRnMessage
mkNameClashErr GlobalRdrEnv
gre_env RdrName
rdr_name NonEmpty GlobalRdrElt
gres }
  where
    -- 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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2
            Bool -> Bool -> Bool
|| (Int
num_flds Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 Bool -> Bool -> Bool
&& Bool -> Bool
not (GlobalRdrElt -> Bool
isDuplicateRecFldGRE ([GlobalRdrElt] -> GlobalRdrElt
forall a. HasCallStack => [a] -> a
head [GlobalRdrElt]
flds)))
            Bool -> Bool -> Bool
|| (Int
num_non_flds Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1 Bool -> Bool -> Bool
&& Int
num_flds Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1
                                  Bool -> Bool -> Bool
&& Bool -> Bool
not (GlobalRdrElt -> Bool
isNoFieldSelectorGRE ([GlobalRdrElt] -> GlobalRdrElt
forall a. HasCallStack => [a] -> a
head [GlobalRdrElt]
flds)))
    ([GlobalRdrElt]
flds, [GlobalRdrElt]
non_flds) = (GlobalRdrElt -> Bool)
-> NonEmpty GlobalRdrElt -> ([GlobalRdrElt], [GlobalRdrElt])
forall a. (a -> Bool) -> NonEmpty a -> ([a], [a])
NE.partition GlobalRdrElt -> Bool
forall info. GlobalRdrEltX info -> Bool
isRecFldGRE NonEmpty GlobalRdrElt
gres
    num_flds :: Int
num_flds     = [GlobalRdrElt] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [GlobalRdrElt]
flds
    num_non_flds :: Int
num_non_flds = [GlobalRdrElt] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [GlobalRdrElt]
non_flds

mkNameClashErr :: GlobalRdrEnv -> RdrName -> NE.NonEmpty GlobalRdrElt -> TcRnMessage
mkNameClashErr :: GlobalRdrEnv -> RdrName -> NonEmpty GlobalRdrElt -> TcRnMessage
mkNameClashErr GlobalRdrEnv
gre_env RdrName
rdr_name NonEmpty GlobalRdrElt
gres = GlobalRdrEnv -> RdrName -> NonEmpty GlobalRdrElt -> TcRnMessage
TcRnAmbiguousName GlobalRdrEnv
gre_env RdrName
rdr_name NonEmpty GlobalRdrElt
gres

dupNamesErr :: NE.NonEmpty SrcSpan -> NE.NonEmpty RdrName -> RnM ()
dupNamesErr :: NonEmpty SrcSpan
-> NonEmpty RdrName -> IOEnv (Env TcGblEnv TcLclEnv) ()
dupNamesErr NonEmpty SrcSpan
locs NonEmpty RdrName
names
  = SrcSpan -> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErrAt SrcSpan
big_loc (RdrName -> NonEmpty SrcSpan -> TcRnMessage
TcRnBindingNameConflict (NonEmpty RdrName -> RdrName
forall a. NonEmpty a -> a
NE.head NonEmpty RdrName
names) NonEmpty SrcSpan
locs)
  where
    big_loc :: SrcSpan
big_loc = (SrcSpan -> SrcSpan -> SrcSpan) -> NonEmpty SrcSpan -> SrcSpan
forall a. (a -> a -> a) -> NonEmpty a -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans NonEmpty SrcSpan
locs

badQualBndrErr :: RdrName -> TcRnMessage
badQualBndrErr :: RdrName -> TcRnMessage
badQualBndrErr RdrName
rdr_name = RdrName -> TcRnMessage
TcRnQualifiedBinder RdrName
rdr_name

typeAppErr :: TypeOrKind -> LHsType GhcPs -> TcRnMessage
typeAppErr :: TypeOrKind -> LHsType GhcPs -> TcRnMessage
typeAppErr TypeOrKind
what (L SrcSpanAnnA
_ HsType GhcPs
k) = TypeApplication -> TcRnMessage
TcRnTypeApplicationsDisabled (HsType GhcPs -> TypeOrKind -> TypeApplication
TypeApplication HsType GhcPs
k TypeOrKind
what)

badFieldConErr :: Name -> FieldLabelString -> TcRnMessage
badFieldConErr :: Name -> FieldLabelString -> TcRnMessage
badFieldConErr Name
con FieldLabelString
field = Name -> FieldLabelString -> TcRnMessage
TcRnInvalidRecordField Name
con FieldLabelString
field

-- | Ensure that a boxed or unboxed tuple has arity no larger than
-- 'mAX_TUPLE_SIZE'.
checkTupSize :: Int -> TcM ()
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 a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise
  = TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr (Int -> TcRnMessage
TcRnTupleTooLarge Int
tup_size)

-- | Ensure that a constraint tuple has arity no larger than 'mAX_CTUPLE_SIZE'.
checkCTupSize :: Int -> TcM ()
checkCTupSize :: Int -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkCTupSize Int
tup_size
  | Int
tup_size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
mAX_CTUPLE_SIZE
  = () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise
  = TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr (Int -> TcRnMessage
TcRnCTupleTooLarge Int
tup_size)

{- *********************************************************************
*                                                                      *
              Generating code for HsExpanded
      See Note [Handling overloaded and rebindable constructs]
*                                                                      *
********************************************************************* -}

wrapGenSpan :: a -> LocatedAn an a
-- Wrap something in a "generatedSrcSpan"
-- See Note [Rebindable syntax and HsExpansion]
wrapGenSpan :: forall a an. a -> LocatedAn an a
wrapGenSpan a
x = SrcAnn an -> a -> GenLocated (SrcAnn an) a
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcAnn an
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
generatedSrcSpan) a
x

genHsApps :: Name -> [LHsExpr GhcRn] -> HsExpr GhcRn
genHsApps :: Name -> [LHsExpr GhcRn] -> HsExpr GhcRn
genHsApps Name
fun [LHsExpr GhcRn]
args = (HsExpr GhcRn
 -> GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn)
-> HsExpr GhcRn
-> [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
-> HsExpr GhcRn
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl HsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
HsExpr GhcRn
-> GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn
genHsApp (Name -> HsExpr GhcRn
genHsVar Name
fun) [LHsExpr GhcRn]
[GenLocated SrcSpanAnnA (HsExpr GhcRn)]
args

genHsApp :: HsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
genHsApp :: HsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
genHsApp HsExpr GhcRn
fun LHsExpr GhcRn
arg = XApp GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcRn
EpAnn NoEpAnns
forall a. EpAnn a
noAnn (HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall a an. a -> LocatedAn an a
wrapGenSpan HsExpr GhcRn
fun) LHsExpr GhcRn
arg

genLHsApp :: HsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn
genLHsApp :: HsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn
genLHsApp HsExpr GhcRn
fun LHsExpr GhcRn
arg = HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall a an. a -> LocatedAn an a
wrapGenSpan (HsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
genHsApp HsExpr GhcRn
fun LHsExpr GhcRn
arg)

genLHsVar :: Name -> LHsExpr GhcRn
genLHsVar :: Name -> LHsExpr GhcRn
genLHsVar Name
nm = HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall a an. a -> LocatedAn an a
wrapGenSpan (HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ Name -> HsExpr GhcRn
genHsVar Name
nm

genHsVar :: Name -> HsExpr GhcRn
genHsVar :: Name -> HsExpr GhcRn
genHsVar Name
nm = XVar GhcRn -> LIdP GhcRn -> HsExpr GhcRn
forall p. XVar p -> LIdP p -> HsExpr p
HsVar XVar GhcRn
NoExtField
noExtField (LIdP GhcRn -> HsExpr GhcRn) -> LIdP GhcRn -> HsExpr GhcRn
forall a b. (a -> b) -> a -> b
$ Name -> LocatedAn NameAnn Name
forall a an. a -> LocatedAn an a
wrapGenSpan Name
nm

genAppType :: HsExpr GhcRn -> HsType (NoGhcTc GhcRn) -> HsExpr GhcRn
genAppType :: HsExpr GhcRn -> HsType (NoGhcTc GhcRn) -> HsExpr GhcRn
genAppType HsExpr GhcRn
expr HsType (NoGhcTc GhcRn)
ty = XAppTypeE GhcRn
-> LHsExpr GhcRn
-> LHsToken "@" GhcRn
-> LHsWcType (NoGhcTc GhcRn)
-> HsExpr GhcRn
forall p.
XAppTypeE p
-> LHsExpr p -> LHsToken "@" p -> LHsWcType (NoGhcTc p) -> HsExpr p
HsAppType XAppTypeE GhcRn
NoExtField
noExtField (HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall a an. a -> LocatedAn an a
wrapGenSpan HsExpr GhcRn
expr) LHsToken "@" GhcRn
GenLocated TokenLocation (HsToken "@")
forall (tok :: Symbol). GenLocated TokenLocation (HsToken tok)
noHsTok (GenLocated SrcSpanAnnA (HsType GhcRn)
-> HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
forall thing. thing -> HsWildCardBndrs GhcRn thing
mkEmptyWildCardBndrs (HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall a an. a -> LocatedAn an a
wrapGenSpan HsType (NoGhcTc GhcRn)
HsType GhcRn
ty))

genLHsLit :: HsLit GhcRn -> LocatedAn an (HsExpr GhcRn)
genLHsLit :: forall an. HsLit GhcRn -> LocatedAn an (HsExpr GhcRn)
genLHsLit = HsExpr GhcRn -> LocatedAn an (HsExpr GhcRn)
forall a an. a -> LocatedAn an a
wrapGenSpan (HsExpr GhcRn -> LocatedAn an (HsExpr GhcRn))
-> (HsLit GhcRn -> HsExpr GhcRn)
-> HsLit GhcRn
-> LocatedAn an (HsExpr GhcRn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XLitE GhcRn -> HsLit GhcRn -> HsExpr GhcRn
forall p. XLitE p -> HsLit p -> HsExpr p
HsLit XLitE GhcRn
EpAnn NoEpAnns
forall a. EpAnn a
noAnn

genHsIntegralLit :: IntegralLit -> LocatedAn an (HsExpr GhcRn)
genHsIntegralLit :: forall an. IntegralLit -> LocatedAn an (HsExpr GhcRn)
genHsIntegralLit = HsLit GhcRn -> LocatedAn an (HsExpr GhcRn)
forall an. HsLit GhcRn -> LocatedAn an (HsExpr GhcRn)
genLHsLit (HsLit GhcRn -> LocatedAn an (HsExpr GhcRn))
-> (IntegralLit -> HsLit GhcRn)
-> IntegralLit
-> LocatedAn an (HsExpr GhcRn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XHsInt GhcRn -> IntegralLit -> HsLit GhcRn
forall x. XHsInt x -> IntegralLit -> HsLit x
HsInt XHsInt GhcRn
NoExtField
noExtField

genHsTyLit :: FastString -> HsType GhcRn
genHsTyLit :: FastString -> HsType GhcRn
genHsTyLit = XTyLit GhcRn -> HsTyLit GhcRn -> HsType GhcRn
forall pass. XTyLit pass -> HsTyLit pass -> HsType pass
HsTyLit XTyLit GhcRn
NoExtField
noExtField (HsTyLit GhcRn -> HsType GhcRn)
-> (FastString -> HsTyLit GhcRn) -> FastString -> HsType GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XStrTy GhcRn -> FastString -> HsTyLit GhcRn
forall pass. XStrTy pass -> FastString -> HsTyLit pass
HsStrTy XStrTy GhcRn
SourceText
NoSourceText

genSimpleConPat :: Name -> [LPat GhcRn] -> LPat GhcRn
-- The pattern (C p1 .. pn)
genSimpleConPat :: Name -> [LPat GhcRn] -> LPat GhcRn
genSimpleConPat Name
con [LPat GhcRn]
pats
  = Pat GhcRn -> LocatedAn AnnListItem (Pat GhcRn)
forall a an. a -> LocatedAn an a
wrapGenSpan (Pat GhcRn -> LocatedAn AnnListItem (Pat GhcRn))
-> Pat GhcRn -> LocatedAn AnnListItem (Pat GhcRn)
forall a b. (a -> b) -> a -> b
$ ConPat { pat_con_ext :: XConPat GhcRn
pat_con_ext = XConPat GhcRn
NoExtField
noExtField
                         , pat_con :: XRec GhcRn (ConLikeP GhcRn)
pat_con     = Name -> LocatedAn NameAnn Name
forall a an. a -> LocatedAn an a
wrapGenSpan Name
con
                         , pat_args :: HsConPatDetails GhcRn
pat_args    = [HsConPatTyArg GhcRn]
-> [LocatedAn AnnListItem (Pat GhcRn)]
-> HsConDetails
     (HsConPatTyArg GhcRn)
     (LocatedAn AnnListItem (Pat GhcRn))
     (HsRecFields GhcRn (LocatedAn AnnListItem (Pat GhcRn)))
forall tyarg arg rec.
[tyarg] -> [arg] -> HsConDetails tyarg arg rec
PrefixCon [] [LPat GhcRn]
[LocatedAn AnnListItem (Pat GhcRn)]
pats }

genVarPat :: Name -> LPat GhcRn
genVarPat :: Name -> LPat GhcRn
genVarPat Name
n = Pat GhcRn -> LocatedAn AnnListItem (Pat GhcRn)
forall a an. a -> LocatedAn an a
wrapGenSpan (Pat GhcRn -> LocatedAn AnnListItem (Pat GhcRn))
-> Pat GhcRn -> LocatedAn AnnListItem (Pat GhcRn)
forall a b. (a -> b) -> a -> b
$ XVarPat GhcRn -> LIdP GhcRn -> Pat GhcRn
forall p. XVarPat p -> LIdP p -> Pat p
VarPat XVarPat GhcRn
NoExtField
noExtField (Name -> LocatedAn NameAnn Name
forall a an. a -> LocatedAn an a
wrapGenSpan Name
n)

genWildPat :: LPat GhcRn
genWildPat :: LPat GhcRn
genWildPat = Pat GhcRn -> LocatedAn AnnListItem (Pat GhcRn)
forall a an. a -> LocatedAn an a
wrapGenSpan (Pat GhcRn -> LocatedAn AnnListItem (Pat GhcRn))
-> Pat GhcRn -> LocatedAn AnnListItem (Pat GhcRn)
forall a b. (a -> b) -> a -> b
$ XWildPat GhcRn -> Pat GhcRn
forall p. XWildPat p -> Pat p
WildPat XWildPat GhcRn
NoExtField
noExtField

genSimpleFunBind :: Name -> [LPat GhcRn]
                 -> LHsExpr GhcRn -> LHsBind GhcRn
genSimpleFunBind :: Name -> [LPat GhcRn] -> LHsExpr GhcRn -> LHsBind GhcRn
genSimpleFunBind Name
fun [LPat GhcRn]
pats LHsExpr GhcRn
expr
  = SrcSpanAnnA
-> HsBind GhcRn -> GenLocated SrcSpanAnnA (HsBind GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
forall {ann}. SrcAnn ann
gen (HsBind GhcRn -> GenLocated SrcSpanAnnA (HsBind GhcRn))
-> HsBind GhcRn -> GenLocated SrcSpanAnnA (HsBind GhcRn)
forall a b. (a -> b) -> a -> b
$ LocatedAn NameAnn Name
-> [LMatch GhcRn (LHsExpr GhcRn)] -> HsBind GhcRn
genFunBind (SrcSpanAnnN -> Name -> LocatedAn NameAnn Name
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
forall {ann}. SrcAnn ann
gen Name
fun)
        [HsMatchContext GhcRn
-> [LPat GhcRn]
-> LHsExpr GhcRn
-> HsLocalBinds GhcRn
-> LMatch GhcRn (LHsExpr GhcRn)
forall (p :: Pass).
IsPass p =>
HsMatchContext (GhcPass p)
-> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> HsLocalBinds (GhcPass p)
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
mkMatch (LIdP (NoGhcTc GhcRn) -> HsMatchContext GhcRn
forall p. LIdP (NoGhcTc p) -> HsMatchContext p
mkPrefixFunRhs (SrcSpanAnnN -> Name -> LocatedAn NameAnn Name
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
forall {ann}. SrcAnn ann
gen Name
fun)) [LPat GhcRn]
pats LHsExpr GhcRn
expr
                 HsLocalBinds GhcRn
forall (a :: Pass) (b :: Pass).
HsLocalBindsLR (GhcPass a) (GhcPass b)
emptyLocalBinds]
  where
    gen :: SrcAnn ann
gen = SrcSpan -> SrcAnn ann
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
generatedSrcSpan

genFunBind :: LocatedN Name -> [LMatch GhcRn (LHsExpr GhcRn)]
           -> HsBind GhcRn
genFunBind :: LocatedAn NameAnn Name
-> [LMatch GhcRn (LHsExpr GhcRn)] -> HsBind GhcRn
genFunBind LocatedAn NameAnn Name
fn [LMatch GhcRn (LHsExpr GhcRn)]
ms
  = FunBind { fun_id :: LIdP GhcRn
fun_id = LIdP GhcRn
LocatedAn NameAnn Name
fn
            , fun_matches :: MatchGroup GhcRn (LHsExpr GhcRn)
fun_matches = Origin
-> LocatedL
     [LocatedA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
-> MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
forall (p :: Pass) (body :: * -> *).
AnnoBody p body =>
Origin
-> LocatedL
     [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
-> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
mkMatchGroup (DoPmc -> Origin
Generated DoPmc
SkipPmc) ([LocatedA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
-> LocatedL
     [LocatedA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
forall a an. a -> LocatedAn an a
wrapGenSpan [LMatch GhcRn (LHsExpr GhcRn)]
[LocatedA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
ms)
            , fun_ext :: XFunBind GhcRn GhcRn
fun_ext = XFunBind GhcRn GhcRn
FreeVars
emptyNameSet
            }

isIrrefutableHsPatRn :: forall p. (OutputableBndrId p)
                  => DynFlags -> LPat (GhcPass p) -> Bool
isIrrefutableHsPatRn :: forall (p :: Pass).
OutputableBndrId p =>
DynFlags -> LPat (GhcPass p) -> Bool
isIrrefutableHsPatRn DynFlags
dflags =
    Bool -> XRec (GhcPass p) (Pat (GhcPass p)) -> Bool
forall (p :: Pass).
OutputableBndrId p =>
Bool -> LPat (GhcPass p) -> Bool
isIrrefutableHsPat (Extension -> DynFlags -> Bool
xopt Extension
LangExt.Strict DynFlags
dflags)