{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Rename.Utils (
checkDupRdrNames, checkDupRdrNamesN, checkShadowedRdrNames,
checkDupNames, checkDupAndShadowedNames, dupNamesErr,
checkTupSize, checkCTupSize,
addFvRn, mapFvRn, mapMaybeFvRn,
warnUnusedMatches, warnUnusedTypePatterns,
warnUnusedTopBinds, warnUnusedLocalBinds,
warnForallIdentifier,
checkUnusedRecordWildcard,
mkFieldEnv,
badQualBndrErr, typeAppErr, badFieldConErr,
wrapGenSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genAppType,
genHsIntegralLit, genHsTyLit,
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.Errors.Types
import GHC.Tc.Errors.Ppr (withHsDocContext)
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.Monad
import GHC.Types.Error
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.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
import GHC.Data.Bag
newLocalBndrRn :: LocatedN RdrName -> RnM Name
newLocalBndrRn :: GenLocated (SrcSpanAnn' (EpAnn NameAnn)) RdrName -> RnM Name
newLocalBndrRn (L SrcSpanAnn' (EpAnn NameAnn)
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
| Bool
otherwise
= do { forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (RdrName -> Bool
isUnqual RdrName
rdr_name)
(SrcSpan -> TcRnMessage -> TcRn ()
addErrAt (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' (EpAnn NameAnn)
loc) (RdrName -> TcRnMessage
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 SrcSpanAnn' (EpAnn NameAnn)
loc)) }
newLocalBndrsRn :: [LocatedN RdrName] -> RnM [Name]
newLocalBndrsRn :: [GenLocated (SrcSpanAnn' (EpAnn NameAnn)) RdrName] -> RnM [Name]
newLocalBndrsRn = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated (SrcSpanAnn' (EpAnn NameAnn)) RdrName -> RnM Name
newLocalBndrRn
bindLocalNames :: [Name] -> RnM a -> RnM a
bindLocalNames :: forall a. [Name] -> RnM a -> RnM a
bindLocalNames [Name]
names
= forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv forall a b. (a -> b) -> a -> b
$ \ TcLclEnv
lcl_env ->
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
in 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' }
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 ()
checkDupRdrNames :: [GenLocated (SrcSpanAnn' (EpAnn NameAnn)) RdrName] -> TcRn ()
checkDupRdrNames [GenLocated (SrcSpanAnn' (EpAnn NameAnn)) 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 (GenLocated (SrcSpanAnn' (EpAnn NameAnn)) RdrName)]
dups
where
([GenLocated (SrcSpanAnn' (EpAnn NameAnn)) RdrName]
_, [NonEmpty (GenLocated (SrcSpanAnn' (EpAnn NameAnn)) RdrName)]
dups) = forall a. (a -> a -> Ordering) -> [a] -> ([a], [NonEmpty a])
removeDups (\GenLocated (SrcSpanAnn' (EpAnn NameAnn)) RdrName
n1 GenLocated (SrcSpanAnn' (EpAnn NameAnn)) RdrName
n2 -> forall l e. GenLocated l e -> e
unLoc GenLocated (SrcSpanAnn' (EpAnn NameAnn)) RdrName
n1 forall a. Ord a => a -> a -> Ordering
`compare` forall l e. GenLocated l e -> e
unLoc GenLocated (SrcSpanAnn' (EpAnn NameAnn)) RdrName
n2) [GenLocated (SrcSpanAnn' (EpAnn NameAnn)) RdrName]
rdr_names_w_loc
checkDupRdrNamesN :: [LocatedN RdrName] -> RnM ()
checkDupRdrNamesN :: [GenLocated (SrcSpanAnn' (EpAnn NameAnn)) RdrName] -> TcRn ()
checkDupRdrNamesN [GenLocated (SrcSpanAnn' (EpAnn NameAnn)) 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 (GenLocated (SrcSpanAnn' (EpAnn NameAnn)) RdrName)]
dups
where
([GenLocated (SrcSpanAnn' (EpAnn NameAnn)) RdrName]
_, [NonEmpty (GenLocated (SrcSpanAnn' (EpAnn NameAnn)) RdrName)]
dups) = forall a. (a -> a -> Ordering) -> [a] -> ([a], [NonEmpty a])
removeDups (\GenLocated (SrcSpanAnn' (EpAnn NameAnn)) RdrName
n1 GenLocated (SrcSpanAnn' (EpAnn NameAnn)) RdrName
n2 -> forall l e. GenLocated l e -> e
unLoc GenLocated (SrcSpanAnn' (EpAnn NameAnn)) RdrName
n1 forall a. Ord a => a -> a -> Ordering
`compare` forall l e. GenLocated l e -> e
unLoc GenLocated (SrcSpanAnn' (EpAnn NameAnn)) RdrName
n2) [GenLocated (SrcSpanAnn' (EpAnn NameAnn)) RdrName]
rdr_names_w_loc
checkDupNames :: [Name] -> RnM ()
checkDupNames :: [Name] -> TcRn ()
checkDupNames [Name]
names = [Name] -> TcRn ()
check_dup_names (forall a. (a -> Bool) -> [a] -> [a]
filterOut Name -> Bool
isSystemName [Name]
names)
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 :: [GenLocated (SrcSpanAnn' (EpAnn NameAnn)) RdrName] -> TcRn ()
checkShadowedRdrNames [GenLocated (SrcSpanAnn' (EpAnn NameAnn)) 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 [GenLocated (SrcSpanAnn' (EpAnn NameAnn)) RdrName]
filtered_rdrs }
where
filtered_rdrs :: [GenLocated (SrcSpanAnn' (EpAnn NameAnn)) 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) [GenLocated (SrcSpanAnn' (EpAnn NameAnn)) RdrName]
loc_rdr_names
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
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 ()
| Just Name
n <- Maybe Name
mb_local = ShadowedNameProvenance -> TcRn ()
complain (SrcLoc -> ShadowedNameProvenance
ShadowedNameProvenanceLocal (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
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ [GlobalRdrElt]
gres') forall a b. (a -> b) -> a -> b
$ ShadowedNameProvenance -> TcRn ()
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 = RdrName -> GlobalRdrEnv -> [GlobalRdrElt]
lookupGRE_RdrName (OccName -> RdrName
mkRdrUnqual OccName
occ) GlobalRdrEnv
global_env
complain :: ShadowedNameProvenance -> TcRn ()
complain ShadowedNameProvenance
provenance = SrcSpan -> TcRnMessage -> TcRn ()
addDiagnosticAt SrcSpan
loc (OccName -> ShadowedNameProvenance -> TcRnMessage
TcRnShadowedName OccName
occ ShadowedNameProvenance
provenance)
is_shadowed_gre :: GlobalRdrElt -> RnM Bool
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.NamedFieldPuns 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
checkInferredVars :: HsDocContext
-> Maybe SDoc
-> 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
_ -> TcRnMessage -> TcRn ()
addErr forall a b. (a -> b) -> a -> b
$ forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (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)
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
-> 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"
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 -> TcRnMessage -> TcRn ()
addErrAt SrcSpan
l forall a b. (a -> b) -> a -> b
$ forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (HsDocContext -> SDoc -> SDoc
withHsDocContext HsDocContext
ctxt SDoc
err_msg)
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) }
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
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'
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 []) =
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
warnRedundantRecordWildcard :: RnM ()
warnRedundantRecordWildcard :: TcRn ()
warnRedundantRecordWildcard =
forall gbl lcl.
WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM WarningFlag
Opt_WarnRedundantRecordWildcards forall a b. (a -> b) -> a -> b
$
let msg :: TcRnMessage
msg = forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage forall a b. (a -> b) -> a -> b
$
DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainDiagnostic (WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnRedundantRecordWildcards)
[GhcHint]
noHints
SDoc
redundantWildcardWarning
in TcRnMessage -> TcRn ()
addDiagnostic TcRnMessage
msg
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)
Bool -> TcRnMessage -> TcRn ()
warnIf (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
used)
TcRnMessage
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))
warnForallIdentifier :: LocatedN RdrName -> RnM ()
warnForallIdentifier :: GenLocated (SrcSpanAnn' (EpAnn NameAnn)) RdrName -> TcRn ()
warnForallIdentifier (L SrcSpanAnn' (EpAnn NameAnn)
l rdr_name :: RdrName
rdr_name@(Unqual OccName
occ))
| FieldLabelString -> Bool
isKw (String -> FieldLabelString
fsLit String
"forall") Bool -> Bool -> Bool
|| FieldLabelString -> Bool
isKw (String -> FieldLabelString
fsLit String
"∀")
= SrcSpan -> TcRnMessage -> TcRn ()
addDiagnosticAt (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' (EpAnn NameAnn)
l) (RdrName -> TcRnMessage
TcRnForallIdentifier RdrName
rdr_name)
where isKw :: FieldLabelString -> Bool
isKw = (OccName -> FieldLabelString
occNameFS OccName
occ forall a. Eq a => a -> a -> Bool
==)
warnForallIdentifier GenLocated (SrcSpanAnn' (EpAnn NameAnn)) RdrName
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
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
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 -> Bag ImportSpec
gre_imp = Bag 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 Bag 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
<+> String -> SDoc
text String
"but not used"
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]
nonDetOccEnvElts GlobalRdrEnv
rdr_env
, GlobalRdrElt
gre <- [GlobalRdrElt]
gres
, Just FieldLabel
fl <- [GlobalRdrElt -> Maybe FieldLabel
greFieldLabel GlobalRdrElt
gre]
]
reportable :: GreName -> Bool
reportable :: GreName -> Bool
reportable GreName
child
| NormalGreName Name
name <- GreName
child
, Name -> Bool
isWiredInName Name
name = Bool
False
| 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 = do
let diag :: TcRnMessage
diag = forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage forall a b. (a -> b) -> a -> b
$ DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainDiagnostic (WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
flag) [GhcHint]
noHints 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)]
SrcSpan -> TcRnMessage -> TcRn ()
addDiagnosticAt SrcSpan
span TcRnMessage
diag
unusedRecordWildcardWarning :: TcRnMessage
unusedRecordWildcardWarning :: TcRnMessage
unusedRecordWildcardWarning =
forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage forall a b. (a -> b) -> a -> b
$ DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainDiagnostic (WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnUnusedRecordWildcards) [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
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
".."))
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
= forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise
= TcRnMessage -> TcRn ()
addErr forall a b. (a -> b) -> a -> b
$ forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
([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]
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 -> Bag ImportSpec
gre_imp = Bag 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)
| Just ImportSpec
imp <- forall a. Bag a -> Maybe a
headMaybe Bag ImportSpec
iss
, 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 Bag ImportSpec
iss)
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
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 -> TcRnMessage -> TcRn ()
addErrAt SrcSpan
big_loc forall a b. (a -> b) -> a -> b
$ forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints 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 -> TcRnMessage
badQualBndrErr :: RdrName -> TcRnMessage
badQualBndrErr RdrName
rdr_name
= forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
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 -> TcRnMessage
typeAppErr :: String -> LHsType GhcPs -> TcRnMessage
typeAppErr String
what (L SrcSpanAnnA
_ HsType GhcPs
k)
= forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
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")
badFieldConErr :: Name -> FieldLabelString -> TcRnMessage
badFieldConErr :: Name -> FieldLabelString -> TcRnMessage
badFieldConErr Name
con FieldLabelString
field
= forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
hsep [String -> SDoc
text String
"Constructor" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
con),
String -> SDoc
text String
"does not have field", SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr FieldLabelString
field)]
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
= TcRnMessage -> TcRn ()
addErr forall a b. (a -> b) -> a -> b
$ forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
sep [String -> SDoc
text String
"A" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
tup_size SDoc -> SDoc -> SDoc
<> String -> SDoc
text 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")]
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
= TcRnMessage -> TcRn ()
addErr forall a b. (a -> b) -> a -> b
$ forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
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")
wrapGenSpan :: a -> LocatedAn an a
wrapGenSpan :: forall a an. a -> LocatedAn an a
wrapGenSpan a
x = forall l e. l -> e -> GenLocated l e
L (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 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl HsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
genHsApp (Name -> HsExpr GhcRn
genHsVar Name
fun) [LHsExpr GhcRn]
args
genHsApp :: HsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
genHsApp :: HsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
genHsApp HsExpr GhcRn
fun LHsExpr GhcRn
arg = forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp forall a. EpAnn a
noAnn (forall a an. a -> LocatedAn an a
wrapGenSpan HsExpr GhcRn
fun) LHsExpr GhcRn
arg
genLHsVar :: Name -> LHsExpr GhcRn
genLHsVar :: Name -> LHsExpr GhcRn
genLHsVar Name
nm = forall a an. a -> LocatedAn an a
wrapGenSpan forall a b. (a -> b) -> a -> b
$ Name -> HsExpr GhcRn
genHsVar Name
nm
genHsVar :: Name -> HsExpr GhcRn
genHsVar :: Name -> HsExpr GhcRn
genHsVar Name
nm = forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
noExtField forall a b. (a -> b) -> a -> b
$ 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 = forall p.
XAppTypeE p -> LHsExpr p -> LHsWcType (NoGhcTc p) -> HsExpr p
HsAppType NoExtField
noExtField (forall a an. a -> LocatedAn an a
wrapGenSpan HsExpr GhcRn
expr) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall thing. thing -> HsWildCardBndrs GhcRn thing
mkEmptyWildCardBndrs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a an. a -> LocatedAn an a
wrapGenSpan
genHsIntegralLit :: IntegralLit -> LocatedAn an (HsExpr GhcRn)
genHsIntegralLit :: forall an. IntegralLit -> LocatedAn an (HsExpr GhcRn)
genHsIntegralLit IntegralLit
lit = forall a an. a -> LocatedAn an a
wrapGenSpan forall a b. (a -> b) -> a -> b
$ forall p. XLitE p -> HsLit p -> HsExpr p
HsLit forall a. EpAnn a
noAnn (forall x. XHsInt x -> IntegralLit -> HsLit x
HsInt NoExtField
noExtField IntegralLit
lit)
genHsTyLit :: FastString -> HsType GhcRn
genHsTyLit :: FieldLabelString -> HsType GhcRn
genHsTyLit = forall pass. XTyLit pass -> HsTyLit -> HsType pass
HsTyLit NoExtField
noExtField forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceText -> FieldLabelString -> HsTyLit
HsStrTy SourceText
NoSourceText