{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeFamilies #-}
module RnUtils (
checkDupRdrNames, checkShadowedRdrNames,
checkDupNames, checkDupAndShadowedNames, dupNamesErr,
checkTupSize,
addFvRn, mapFvRn, mapMaybeFvRn,
warnUnusedMatches, warnUnusedTypePatterns,
warnUnusedTopBinds, warnUnusedLocalBinds,
checkUnusedRecordWildcard,
mkFieldEnv,
unknownSubordinateErr, badQualBndrErr, typeAppErr,
HsDocContext(..), pprHsDocContext,
inHsDocContext, withHsDocContext,
newLocalBndrRn, newLocalBndrsRn,
bindLocalNames, bindLocalNamesFV,
addNameClashErrRn, extendTyVarEnvFVRn
)
where
import GhcPrelude
import GHC.Hs
import RdrName
import HscTypes
import TcEnv
import TcRnMonad
import Name
import NameSet
import NameEnv
import DataCon
import SrcLoc
import Outputable
import Util
import BasicTypes ( TopLevelFlag(..) )
import ListSetOps ( removeDups )
import DynFlags
import FastString
import Control.Monad
import Data.List
import Constants ( mAX_TUPLE_SIZE )
import qualified Data.List.NonEmpty as NE
import qualified GHC.LanguageExtensions as LangExt
newLocalBndrRn :: Located RdrName -> RnM Name
newLocalBndrRn :: Located RdrName -> RnM Name
newLocalBndrRn (Located RdrName -> Located (SrcSpanLess (Located RdrName))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess (Located RdrName)
rdr_name)
| Just Name
name <- RdrName -> Maybe Name
isExact_maybe SrcSpanLess (Located RdrName)
RdrName
rdr_name
= Name -> RnM Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
name
| Bool
otherwise
= do { Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (RdrName -> Bool
isUnqual SrcSpanLess (Located RdrName)
RdrName
rdr_name)
(SrcSpan -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErrAt SrcSpan
loc (RdrName -> MsgDoc
badQualBndrErr SrcSpanLess (Located RdrName)
RdrName
rdr_name))
; Unique
uniq <- TcRnIf TcGblEnv TcLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
; Name -> RnM Name
forall (m :: * -> *) a. Monad m => a -> m a
return (Unique -> OccName -> SrcSpan -> Name
mkInternalName Unique
uniq (RdrName -> OccName
rdrNameOcc SrcSpanLess (Located RdrName)
RdrName
rdr_name) SrcSpan
loc) }
newLocalBndrsRn :: [Located RdrName] -> RnM [Name]
newLocalBndrsRn :: [Located RdrName] -> RnM [Name]
newLocalBndrsRn = (Located RdrName -> RnM Name) -> [Located RdrName] -> RnM [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Located RdrName -> RnM Name
newLocalBndrRn
bindLocalNames :: [Name] -> RnM a -> RnM a
bindLocalNames :: [Name] -> RnM a -> RnM a
bindLocalNames [Name]
names RnM a
enclosed_scope
= do { TcLclEnv
lcl_env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
; let th_level :: ThLevel
th_level = ThStage -> ThLevel
thLevel (TcLclEnv -> ThStage
tcl_th_ctxt TcLclEnv
lcl_env)
th_bndrs' :: NameEnv (TopLevelFlag, ThLevel)
th_bndrs' = NameEnv (TopLevelFlag, ThLevel)
-> [(Name, (TopLevelFlag, ThLevel))]
-> NameEnv (TopLevelFlag, ThLevel)
forall a. NameEnv a -> [(Name, a)] -> NameEnv a
extendNameEnvList (TcLclEnv -> NameEnv (TopLevelFlag, ThLevel)
tcl_th_bndrs TcLclEnv
lcl_env)
[ (Name
n, (TopLevelFlag
NotTopLevel, ThLevel
th_level)) | Name
n <- [Name]
names ]
rdr_env' :: LocalRdrEnv
rdr_env' = LocalRdrEnv -> [Name] -> LocalRdrEnv
extendLocalRdrEnvList (TcLclEnv -> LocalRdrEnv
tcl_rdr TcLclEnv
lcl_env) [Name]
names
; TcLclEnv -> RnM a -> RnM a
forall lcl' gbl a lcl.
lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
setLclEnv (TcLclEnv
lcl_env { tcl_th_bndrs :: NameEnv (TopLevelFlag, ThLevel)
tcl_th_bndrs = NameEnv (TopLevelFlag, ThLevel)
th_bndrs'
, tcl_rdr :: LocalRdrEnv
tcl_rdr = LocalRdrEnv
rdr_env' })
RnM a
enclosed_scope }
bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindLocalNamesFV [Name]
names RnM (a, FreeVars)
enclosed_scope
= do { (a
result, FreeVars
fvs) <- [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
forall a. [Name] -> RnM a -> RnM a
bindLocalNames [Name]
names RnM (a, FreeVars)
enclosed_scope
; (a, FreeVars) -> RnM (a, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, [Name] -> FreeVars -> FreeVars
delFVs [Name]
names FreeVars
fvs) }
extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
extendTyVarEnvFVRn [Name]
tyvars RnM (a, FreeVars)
thing_inside = [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
forall a. [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindLocalNamesFV [Name]
tyvars RnM (a, FreeVars)
thing_inside
checkDupRdrNames :: [Located RdrName] -> RnM ()
checkDupRdrNames :: [Located RdrName] -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkDupRdrNames [Located RdrName]
rdr_names_w_loc
= (NonEmpty (Located RdrName) -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> [NonEmpty (Located RdrName)] -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Located RdrName -> SrcSpan)
-> NonEmpty (Located RdrName) -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall n.
Outputable n =>
(n -> SrcSpan) -> NonEmpty n -> IOEnv (Env TcGblEnv TcLclEnv) ()
dupNamesErr Located RdrName -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc) [NonEmpty (Located RdrName)]
dups
where
([Located RdrName]
_, [NonEmpty (Located RdrName)]
dups) = (Located RdrName -> Located RdrName -> Ordering)
-> [Located RdrName]
-> ([Located RdrName], [NonEmpty (Located RdrName)])
forall a. (a -> a -> Ordering) -> [a] -> ([a], [NonEmpty a])
removeDups (\Located RdrName
n1 Located RdrName
n2 -> Located RdrName -> SrcSpanLess (Located RdrName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located RdrName
n1 RdrName -> RdrName -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Located RdrName -> SrcSpanLess (Located RdrName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located RdrName
n2) [Located RdrName]
rdr_names_w_loc
checkDupNames :: [Name] -> RnM ()
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)
check_dup_names :: [Name] -> RnM ()
check_dup_names :: [Name] -> IOEnv (Env TcGblEnv TcLclEnv) ()
check_dup_names [Name]
names
= (NonEmpty Name -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> [NonEmpty Name] -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Name -> SrcSpan)
-> NonEmpty Name -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall n.
Outputable n =>
(n -> SrcSpan) -> NonEmpty n -> IOEnv (Env TcGblEnv TcLclEnv) ()
dupNamesErr Name -> SrcSpan
nameSrcSpan) [NonEmpty Name]
dups
where
([Name]
_, [NonEmpty Name]
dups) = (Name -> Name -> Ordering) -> [Name] -> ([Name], [NonEmpty Name])
forall a. (a -> a -> Ordering) -> [a] -> ([a], [NonEmpty a])
removeDups (\Name
n1 Name
n2 -> Name -> OccName
nameOccName Name
n1 OccName -> OccName -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Name -> OccName
nameOccName Name
n2) [Name]
names
checkShadowedRdrNames :: [Located RdrName] -> RnM ()
checkShadowedRdrNames :: [Located RdrName] -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkShadowedRdrNames [Located RdrName]
loc_rdr_names
= do { (GlobalRdrEnv, LocalRdrEnv)
envs <- TcRn (GlobalRdrEnv, LocalRdrEnv)
getRdrEnvs
; (GlobalRdrEnv, LocalRdrEnv)
-> (Located RdrName -> (SrcSpan, OccName))
-> [Located RdrName]
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a.
(GlobalRdrEnv, LocalRdrEnv)
-> (a -> (SrcSpan, OccName))
-> [a]
-> IOEnv (Env TcGblEnv TcLclEnv) ()
checkShadowedOccs (GlobalRdrEnv, LocalRdrEnv)
envs Located RdrName -> (SrcSpan, OccName)
forall a.
(HasSrcSpan a, SrcSpanLess a ~ RdrName) =>
a -> (SrcSpan, OccName)
get_loc_occ [Located RdrName]
filtered_rdrs }
where
filtered_rdrs :: [Located RdrName]
filtered_rdrs = (Located RdrName -> Bool) -> [Located RdrName] -> [Located RdrName]
forall a. (a -> Bool) -> [a] -> [a]
filterOut (RdrName -> Bool
isExact (RdrName -> Bool)
-> (Located RdrName -> RdrName) -> Located RdrName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located RdrName -> RdrName
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) [Located RdrName]
loc_rdr_names
get_loc_occ :: a -> (SrcSpan, OccName)
get_loc_occ (a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess a
rdr) = (SrcSpan
loc,RdrName -> OccName
rdrNameOcc SrcSpanLess a
RdrName
rdr)
checkDupAndShadowedNames :: (GlobalRdrEnv, LocalRdrEnv) -> [Name] -> RnM ()
checkDupAndShadowedNames :: (GlobalRdrEnv, LocalRdrEnv)
-> [Name] -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkDupAndShadowedNames (GlobalRdrEnv, LocalRdrEnv)
envs [Name]
names
= do { [Name] -> IOEnv (Env TcGblEnv TcLclEnv) ()
check_dup_names [Name]
filtered_names
; (GlobalRdrEnv, LocalRdrEnv)
-> (Name -> (SrcSpan, OccName))
-> [Name]
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a.
(GlobalRdrEnv, LocalRdrEnv)
-> (a -> (SrcSpan, OccName))
-> [a]
-> IOEnv (Env TcGblEnv TcLclEnv) ()
checkShadowedOccs (GlobalRdrEnv, LocalRdrEnv)
envs Name -> (SrcSpan, OccName)
get_loc_occ [Name]
filtered_names }
where
filtered_names :: [Name]
filtered_names = (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filterOut Name -> Bool
isSystemName [Name]
names
get_loc_occ :: Name -> (SrcSpan, OccName)
get_loc_occ Name
name = (Name -> SrcSpan
nameSrcSpan Name
name, Name -> OccName
nameOccName Name
name)
checkShadowedOccs :: (GlobalRdrEnv, LocalRdrEnv)
-> (a -> (SrcSpan, OccName))
-> [a] -> RnM ()
checkShadowedOccs :: (GlobalRdrEnv, LocalRdrEnv)
-> (a -> (SrcSpan, OccName))
-> [a]
-> IOEnv (Env TcGblEnv TcLclEnv) ()
checkShadowedOccs (GlobalRdrEnv
global_env,LocalRdrEnv
local_env) a -> (SrcSpan, OccName)
get_loc_occ [a]
ns
= WarningFlag
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall gbl lcl.
WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM WarningFlag
Opt_WarnNameShadowing (IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
do { String -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"checkShadowedOccs:shadow" ([(SrcSpan, OccName)] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr ((a -> (SrcSpan, OccName)) -> [a] -> [(SrcSpan, OccName)]
forall a b. (a -> b) -> [a] -> [b]
map a -> (SrcSpan, OccName)
get_loc_occ [a]
ns))
; (a -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> [a] -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ a -> IOEnv (Env TcGblEnv TcLclEnv) ()
check_shadow [a]
ns }
where
check_shadow :: a -> IOEnv (Env TcGblEnv TcLclEnv) ()
check_shadow a
n
| OccName -> Bool
startsWithUnderscore OccName
occ = () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Just Name
n <- Maybe Name
mb_local = [MsgDoc] -> IOEnv (Env TcGblEnv TcLclEnv) ()
complain [String -> MsgDoc
text String
"bound at" MsgDoc -> MsgDoc -> MsgDoc
<+> SrcLoc -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (Name -> SrcLoc
nameSrcLoc Name
n)]
| Bool
otherwise = do { [GlobalRdrElt]
gres' <- (GlobalRdrElt -> IOEnv (Env TcGblEnv TcLclEnv) Bool)
-> [GlobalRdrElt] -> IOEnv (Env TcGblEnv TcLclEnv) [GlobalRdrElt]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM GlobalRdrElt -> IOEnv (Env TcGblEnv TcLclEnv) Bool
is_shadowed_gre [GlobalRdrElt]
gres
; [MsgDoc] -> IOEnv (Env TcGblEnv TcLclEnv) ()
complain ((GlobalRdrElt -> MsgDoc) -> [GlobalRdrElt] -> [MsgDoc]
forall a b. (a -> b) -> [a] -> [b]
map GlobalRdrElt -> MsgDoc
pprNameProvenance [GlobalRdrElt]
gres') }
where
(SrcSpan
loc,OccName
occ) = a -> (SrcSpan, OccName)
get_loc_occ a
n
mb_local :: Maybe Name
mb_local = LocalRdrEnv -> OccName -> Maybe Name
lookupLocalRdrOcc LocalRdrEnv
local_env OccName
occ
gres :: [GlobalRdrElt]
gres = RdrName -> GlobalRdrEnv -> [GlobalRdrElt]
lookupGRE_RdrName (OccName -> RdrName
mkRdrUnqual OccName
occ) GlobalRdrEnv
global_env
complain :: [MsgDoc] -> IOEnv (Env TcGblEnv TcLclEnv) ()
complain [] = () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
complain [MsgDoc]
pp_locs = WarnReason -> SrcSpan -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addWarnAt (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnNameShadowing)
SrcSpan
loc
(OccName -> [MsgDoc] -> MsgDoc
shadowedNameWarn OccName
occ [MsgDoc]
pp_locs)
is_shadowed_gre :: GlobalRdrElt -> RnM Bool
is_shadowed_gre :: GlobalRdrElt -> IOEnv (Env TcGblEnv TcLclEnv) Bool
is_shadowed_gre GlobalRdrElt
gre | GlobalRdrElt -> Bool
isRecFldGRE GlobalRdrElt
gre
= do { DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; Bool -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IOEnv (Env TcGblEnv TcLclEnv) Bool)
-> Bool -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Extension -> DynFlags -> Bool
xopt Extension
LangExt.RecordPuns DynFlags
dflags
Bool -> Bool -> Bool
|| Extension -> DynFlags -> Bool
xopt Extension
LangExt.RecordWildCards DynFlags
dflags) }
is_shadowed_gre GlobalRdrElt
_other = Bool -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
addFvRn :: FreeVars -> RnM (thing, FreeVars) -> RnM (thing, FreeVars)
addFvRn :: FreeVars -> RnM (thing, FreeVars) -> RnM (thing, FreeVars)
addFvRn FreeVars
fvs1 RnM (thing, FreeVars)
thing_inside = do { (thing
res, FreeVars
fvs2) <- RnM (thing, FreeVars)
thing_inside
; (thing, FreeVars) -> RnM (thing, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (thing
res, FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2) }
mapFvRn :: (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn :: (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn a -> RnM (b, FreeVars)
f [a]
xs = do [(b, FreeVars)]
stuff <- (a -> RnM (b, FreeVars))
-> [a] -> IOEnv (Env TcGblEnv TcLclEnv) [(b, FreeVars)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> RnM (b, FreeVars)
f [a]
xs
case [(b, FreeVars)] -> ([b], [FreeVars])
forall a b. [(a, b)] -> ([a], [b])
unzip [(b, FreeVars)]
stuff of
([b]
ys, [FreeVars]
fvs_s) -> ([b], FreeVars) -> RnM ([b], FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return ([b]
ys, [FreeVars] -> FreeVars
plusFVs [FreeVars]
fvs_s)
mapMaybeFvRn :: (a -> RnM (b, FreeVars)) -> Maybe a -> RnM (Maybe b, FreeVars)
mapMaybeFvRn :: (a -> RnM (b, FreeVars)) -> Maybe a -> RnM (Maybe b, FreeVars)
mapMaybeFvRn a -> RnM (b, FreeVars)
_ Maybe a
Nothing = (Maybe b, FreeVars) -> RnM (Maybe b, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe b
forall a. Maybe a
Nothing, FreeVars
emptyFVs)
mapMaybeFvRn a -> RnM (b, FreeVars)
f (Just a
x) = do { (b
y, FreeVars
fvs) <- a -> RnM (b, FreeVars)
f a
x; (Maybe b, FreeVars) -> RnM (Maybe b, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> Maybe b
forall a. a -> Maybe a
Just b
y, FreeVars
fvs) }
warnUnusedTopBinds :: [GlobalRdrElt] -> RnM ()
warnUnusedTopBinds :: [GlobalRdrElt] -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnUnusedTopBinds [GlobalRdrElt]
gres
= WarningFlag
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall gbl lcl.
WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM WarningFlag
Opt_WarnUnusedTopBinds
(IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ do TcGblEnv
env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
let isBoot :: Bool
isBoot = TcGblEnv -> HscSource
tcg_src TcGblEnv
env HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== HscSource
HsBootFile
let noParent :: GlobalRdrElt -> Bool
noParent GlobalRdrElt
gre = case GlobalRdrElt -> Parent
gre_par GlobalRdrElt
gre of
Parent
NoParent -> Bool
True
Parent
_ -> Bool
False
gres' :: [GlobalRdrElt]
gres' = if Bool
isBoot then (GlobalRdrElt -> Bool) -> [GlobalRdrElt] -> [GlobalRdrElt]
forall a. (a -> Bool) -> [a] -> [a]
filter GlobalRdrElt -> Bool
noParent [GlobalRdrElt]
gres
else [GlobalRdrElt]
gres
[GlobalRdrElt] -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnUnusedGREs [GlobalRdrElt]
gres'
checkUnusedRecordWildcard :: SrcSpan
-> FreeVars
-> Maybe [Name]
-> RnM ()
checkUnusedRecordWildcard :: SrcSpan
-> FreeVars -> Maybe [Name] -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkUnusedRecordWildcard SrcSpan
_ FreeVars
_ Maybe [Name]
Nothing = () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkUnusedRecordWildcard SrcSpan
loc FreeVars
_ (Just []) = do
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
warnRedundantRecordWildcard :: RnM ()
warnRedundantRecordWildcard :: IOEnv (Env TcGblEnv TcLclEnv) ()
warnRedundantRecordWildcard =
WarningFlag
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall gbl lcl.
WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM WarningFlag
Opt_WarnRedundantRecordWildcards
(WarnReason -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addWarn (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnRedundantRecordWildcards)
MsgDoc
redundantWildcardWarning)
warnUnusedRecordWildcard :: [Name] -> FreeVars -> RnM ()
warnUnusedRecordWildcard :: [Name] -> FreeVars -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnUnusedRecordWildcard [Name]
ns FreeVars
used_names = do
let used :: [Name]
used = (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (Name -> FreeVars -> Bool
`elemNameSet` FreeVars
used_names) [Name]
ns
String -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"warnUnused" ([Name] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [Name]
ns MsgDoc -> MsgDoc -> MsgDoc
$$ FreeVars -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr FreeVars
used_names MsgDoc -> MsgDoc -> MsgDoc
$$ [Name] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [Name]
used)
WarningFlag -> Bool -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnIfFlag WarningFlag
Opt_WarnUnusedRecordWildcards ([Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
used)
MsgDoc
unusedRecordWildcardWarning
warnUnusedLocalBinds, warnUnusedMatches, warnUnusedTypePatterns
:: [Name] -> FreeVars -> RnM ()
warnUnusedLocalBinds :: [Name] -> FreeVars -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnUnusedLocalBinds = WarningFlag
-> [Name] -> FreeVars -> IOEnv (Env TcGblEnv TcLclEnv) ()
check_unused WarningFlag
Opt_WarnUnusedLocalBinds
warnUnusedMatches :: [Name] -> FreeVars -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnUnusedMatches = WarningFlag
-> [Name] -> FreeVars -> IOEnv (Env TcGblEnv TcLclEnv) ()
check_unused WarningFlag
Opt_WarnUnusedMatches
warnUnusedTypePatterns :: [Name] -> FreeVars -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnUnusedTypePatterns = WarningFlag
-> [Name] -> FreeVars -> IOEnv (Env TcGblEnv TcLclEnv) ()
check_unused WarningFlag
Opt_WarnUnusedTypePatterns
check_unused :: WarningFlag -> [Name] -> FreeVars -> RnM ()
check_unused :: WarningFlag
-> [Name] -> FreeVars -> IOEnv (Env TcGblEnv TcLclEnv) ()
check_unused WarningFlag
flag [Name]
bound_names FreeVars
used_names
= WarningFlag
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall gbl lcl.
WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM WarningFlag
flag (WarningFlag -> [Name] -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnUnused WarningFlag
flag ((Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filterOut (Name -> FreeVars -> Bool
`elemNameSet` FreeVars
used_names)
[Name]
bound_names))
warnUnusedGREs :: [GlobalRdrElt] -> RnM ()
warnUnusedGREs :: [GlobalRdrElt] -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnUnusedGREs [GlobalRdrElt]
gres = (GlobalRdrElt -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> [GlobalRdrElt] -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ GlobalRdrElt -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnUnusedGRE [GlobalRdrElt]
gres
warnUnused :: WarningFlag -> [Name] -> RnM ()
warnUnused :: WarningFlag -> [Name] -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnUnused WarningFlag
flag [Name]
names = do
NameEnv (FieldLabelString, Name)
fld_env <- GlobalRdrEnv -> NameEnv (FieldLabelString, Name)
mkFieldEnv (GlobalRdrEnv -> NameEnv (FieldLabelString, Name))
-> IOEnv (Env TcGblEnv TcLclEnv) GlobalRdrEnv
-> IOEnv (Env TcGblEnv TcLclEnv) (NameEnv (FieldLabelString, Name))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env TcGblEnv TcLclEnv) GlobalRdrEnv
getGlobalRdrEnv
(Name -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> [Name] -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (WarningFlag
-> NameEnv (FieldLabelString, Name)
-> Name
-> IOEnv (Env TcGblEnv TcLclEnv) ()
warnUnused1 WarningFlag
flag NameEnv (FieldLabelString, Name)
fld_env) [Name]
names
warnUnused1 :: WarningFlag -> NameEnv (FieldLabelString, Name) -> Name -> RnM ()
warnUnused1 :: WarningFlag
-> NameEnv (FieldLabelString, Name)
-> Name
-> IOEnv (Env TcGblEnv TcLclEnv) ()
warnUnused1 WarningFlag
flag NameEnv (FieldLabelString, Name)
fld_env Name
name
= Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name -> OccName -> Bool
reportable Name
name OccName
occ) (IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
WarningFlag
-> OccName -> SrcSpan -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addUnusedWarning WarningFlag
flag
OccName
occ (Name -> SrcSpan
nameSrcSpan Name
name)
(String -> MsgDoc
text (String -> MsgDoc) -> String -> MsgDoc
forall a b. (a -> b) -> a -> b
$ String
"Defined but not used" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
opt_str)
where
occ :: OccName
occ = case NameEnv (FieldLabelString, Name)
-> Name -> Maybe (FieldLabelString, Name)
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv (FieldLabelString, Name)
fld_env Name
name of
Just (FieldLabelString
fl, Name
_) -> FieldLabelString -> OccName
mkVarOccFS FieldLabelString
fl
Maybe (FieldLabelString, Name)
Nothing -> Name -> OccName
nameOccName Name
name
opt_str :: String
opt_str = case WarningFlag
flag of
WarningFlag
Opt_WarnUnusedTypePatterns -> String
" on the right hand side"
WarningFlag
_ -> String
""
warnUnusedGRE :: GlobalRdrElt -> RnM ()
warnUnusedGRE :: GlobalRdrElt -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnUnusedGRE gre :: GlobalRdrElt
gre@(GRE { gre_name :: GlobalRdrElt -> Name
gre_name = Name
name, gre_lcl :: GlobalRdrElt -> Bool
gre_lcl = Bool
lcl, gre_imp :: GlobalRdrElt -> [ImportSpec]
gre_imp = [ImportSpec]
is })
| Bool
lcl = do NameEnv (FieldLabelString, Name)
fld_env <- GlobalRdrEnv -> NameEnv (FieldLabelString, Name)
mkFieldEnv (GlobalRdrEnv -> NameEnv (FieldLabelString, Name))
-> IOEnv (Env TcGblEnv TcLclEnv) GlobalRdrEnv
-> IOEnv (Env TcGblEnv TcLclEnv) (NameEnv (FieldLabelString, Name))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env TcGblEnv TcLclEnv) GlobalRdrEnv
getGlobalRdrEnv
WarningFlag
-> NameEnv (FieldLabelString, Name)
-> Name
-> IOEnv (Env TcGblEnv TcLclEnv) ()
warnUnused1 WarningFlag
Opt_WarnUnusedTopBinds NameEnv (FieldLabelString, Name)
fld_env Name
name
| Bool
otherwise = Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name -> OccName -> Bool
reportable Name
name OccName
occ) ((ImportSpec -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> [ImportSpec] -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ImportSpec -> IOEnv (Env TcGblEnv TcLclEnv) ()
warn [ImportSpec]
is)
where
occ :: OccName
occ = GlobalRdrElt -> OccName
greOccName GlobalRdrElt
gre
warn :: ImportSpec -> IOEnv (Env TcGblEnv TcLclEnv) ()
warn ImportSpec
spec = WarningFlag
-> OccName -> SrcSpan -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addUnusedWarning WarningFlag
Opt_WarnUnusedTopBinds OccName
occ SrcSpan
span MsgDoc
msg
where
span :: SrcSpan
span = ImportSpec -> SrcSpan
importSpecLoc ImportSpec
spec
pp_mod :: MsgDoc
pp_mod = MsgDoc -> MsgDoc
quotes (ModuleName -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (ImportSpec -> ModuleName
importSpecModule ImportSpec
spec))
msg :: MsgDoc
msg = String -> MsgDoc
text String
"Imported from" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc
pp_mod MsgDoc -> MsgDoc -> MsgDoc
<+> PtrString -> MsgDoc
ptext (String -> PtrString
sLit String
"but not used")
mkFieldEnv :: GlobalRdrEnv -> NameEnv (FieldLabelString, Name)
mkFieldEnv :: GlobalRdrEnv -> NameEnv (FieldLabelString, Name)
mkFieldEnv GlobalRdrEnv
rdr_env = [(Name, (FieldLabelString, Name))]
-> NameEnv (FieldLabelString, Name)
forall a. [(Name, a)] -> NameEnv a
mkNameEnv [ (GlobalRdrElt -> Name
gre_name GlobalRdrElt
gre, (FieldLabelString
lbl, Parent -> Name
par_is (GlobalRdrElt -> Parent
gre_par GlobalRdrElt
gre)))
| [GlobalRdrElt]
gres <- GlobalRdrEnv -> [[GlobalRdrElt]]
forall a. OccEnv a -> [a]
occEnvElts GlobalRdrEnv
rdr_env
, GlobalRdrElt
gre <- [GlobalRdrElt]
gres
, Just FieldLabelString
lbl <- [GlobalRdrElt -> Maybe FieldLabelString
greLabel GlobalRdrElt
gre]
]
reportable :: Name -> OccName -> Bool
reportable :: Name -> OccName -> Bool
reportable Name
name OccName
occ
| Name -> Bool
isWiredInName Name
name = Bool
False
| Bool
otherwise = Bool -> Bool
not (OccName -> Bool
startsWithUnderscore OccName
occ)
addUnusedWarning :: WarningFlag -> OccName -> SrcSpan -> SDoc -> RnM ()
addUnusedWarning :: WarningFlag
-> OccName -> SrcSpan -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addUnusedWarning WarningFlag
flag OccName
occ SrcSpan
span MsgDoc
msg
= WarnReason -> SrcSpan -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addWarnAt (WarningFlag -> WarnReason
Reason WarningFlag
flag) SrcSpan
span (MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
[MsgDoc] -> MsgDoc
sep [MsgDoc
msg MsgDoc -> MsgDoc -> MsgDoc
<> MsgDoc
colon,
ThLevel -> MsgDoc -> MsgDoc
nest ThLevel
2 (MsgDoc -> MsgDoc) -> MsgDoc -> MsgDoc
forall a b. (a -> b) -> a -> b
$ NameSpace -> MsgDoc
pprNonVarNameSpace (OccName -> NameSpace
occNameSpace OccName
occ)
MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (OccName -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr OccName
occ)]
unusedRecordWildcardWarning :: SDoc
unusedRecordWildcardWarning :: MsgDoc
unusedRecordWildcardWarning =
MsgDoc -> MsgDoc
wildcardDoc (MsgDoc -> MsgDoc) -> MsgDoc -> MsgDoc
forall a b. (a -> b) -> a -> b
$ String -> MsgDoc
text String
"No variables bound in the record wildcard match are used"
redundantWildcardWarning :: SDoc
redundantWildcardWarning :: MsgDoc
redundantWildcardWarning =
MsgDoc -> MsgDoc
wildcardDoc (MsgDoc -> MsgDoc) -> MsgDoc -> MsgDoc
forall a b. (a -> b) -> a -> b
$ String -> MsgDoc
text String
"Record wildcard does not bind any new variables"
wildcardDoc :: SDoc -> SDoc
wildcardDoc :: MsgDoc -> MsgDoc
wildcardDoc MsgDoc
herald =
MsgDoc
herald
MsgDoc -> MsgDoc -> MsgDoc
$$ ThLevel -> MsgDoc -> MsgDoc
nest ThLevel
2 (String -> MsgDoc
text String
"Possible fix" MsgDoc -> MsgDoc -> MsgDoc
<> MsgDoc
colon MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
"omit the"
MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (String -> MsgDoc
text String
".."))
addNameClashErrRn :: RdrName -> [GlobalRdrElt] -> RnM ()
addNameClashErrRn :: RdrName -> [GlobalRdrElt] -> IOEnv (Env TcGblEnv TcLclEnv) ()
addNameClashErrRn RdrName
rdr_name [GlobalRdrElt]
gres
| (GlobalRdrElt -> Bool) -> [GlobalRdrElt] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all GlobalRdrElt -> Bool
isLocalGRE [GlobalRdrElt]
gres Bool -> Bool -> Bool
&& Bool -> Bool
not ((GlobalRdrElt -> Bool) -> [GlobalRdrElt] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all GlobalRdrElt -> Bool
isRecFldGRE [GlobalRdrElt]
gres)
= () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise
= MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr ([MsgDoc] -> MsgDoc
vcat [ String -> MsgDoc
text String
"Ambiguous occurrence" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (RdrName -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr RdrName
rdr_name)
, String -> MsgDoc
text String
"It could refer to"
, ThLevel -> MsgDoc -> MsgDoc
nest ThLevel
3 ([MsgDoc] -> MsgDoc
vcat (MsgDoc
msg1 MsgDoc -> [MsgDoc] -> [MsgDoc]
forall a. a -> [a] -> [a]
: [MsgDoc]
msgs)) ])
where
(GlobalRdrElt
np1:[GlobalRdrElt]
nps) = [GlobalRdrElt]
gres
msg1 :: MsgDoc
msg1 = String -> MsgDoc
text String
"either" MsgDoc -> MsgDoc -> MsgDoc
<+> GlobalRdrElt -> MsgDoc
ppr_gre GlobalRdrElt
np1
msgs :: [MsgDoc]
msgs = [String -> MsgDoc
text String
" or" MsgDoc -> MsgDoc -> MsgDoc
<+> GlobalRdrElt -> MsgDoc
ppr_gre GlobalRdrElt
np | GlobalRdrElt
np <- [GlobalRdrElt]
nps]
ppr_gre :: GlobalRdrElt -> MsgDoc
ppr_gre GlobalRdrElt
gre = [MsgDoc] -> MsgDoc
sep [ GlobalRdrElt -> MsgDoc
pp_gre_name GlobalRdrElt
gre MsgDoc -> MsgDoc -> MsgDoc
<> MsgDoc
comma
, GlobalRdrElt -> MsgDoc
pprNameProvenance GlobalRdrElt
gre]
pp_gre_name :: GlobalRdrElt -> MsgDoc
pp_gre_name gre :: GlobalRdrElt
gre@(GRE { gre_name :: GlobalRdrElt -> Name
gre_name = Name
name, gre_par :: GlobalRdrElt -> Parent
gre_par = Parent
parent
, gre_lcl :: GlobalRdrElt -> Bool
gre_lcl = Bool
lcl, gre_imp :: GlobalRdrElt -> [ImportSpec]
gre_imp = [ImportSpec]
iss })
| FldParent { par_lbl :: Parent -> Maybe FieldLabelString
par_lbl = Just FieldLabelString
lbl } <- Parent
parent
= String -> MsgDoc
text String
"the field" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (FieldLabelString -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr FieldLabelString
lbl)
| Bool
otherwise
= MsgDoc -> MsgDoc
quotes (MsgDoc
pp_qual MsgDoc -> MsgDoc -> MsgDoc
<> MsgDoc
dot MsgDoc -> MsgDoc -> MsgDoc
<> OccName -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (Name -> OccName
nameOccName Name
name))
where
pp_qual :: MsgDoc
pp_qual | Bool
lcl
= Module -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
name)
| ImportSpec
imp : [ImportSpec]
_ <- [ImportSpec]
iss
, ImpDeclSpec { is_as :: ImpDeclSpec -> ModuleName
is_as = ModuleName
mod } <- ImportSpec -> ImpDeclSpec
is_decl ImportSpec
imp
= ModuleName -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr ModuleName
mod
| Bool
otherwise
= String -> MsgDoc -> MsgDoc
forall a. HasCallStack => String -> MsgDoc -> a
pprPanic String
"addNameClassErrRn" (GlobalRdrElt -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr GlobalRdrElt
gre MsgDoc -> MsgDoc -> MsgDoc
$$ [ImportSpec] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [ImportSpec]
iss)
shadowedNameWarn :: OccName -> [SDoc] -> SDoc
shadowedNameWarn :: OccName -> [MsgDoc] -> MsgDoc
shadowedNameWarn OccName
occ [MsgDoc]
shadowed_locs
= [MsgDoc] -> MsgDoc
sep [String -> MsgDoc
text String
"This binding for" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (OccName -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr OccName
occ)
MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
"shadows the existing binding" MsgDoc -> MsgDoc -> MsgDoc
<> [MsgDoc] -> MsgDoc
forall a. [a] -> MsgDoc
plural [MsgDoc]
shadowed_locs,
ThLevel -> MsgDoc -> MsgDoc
nest ThLevel
2 ([MsgDoc] -> MsgDoc
vcat [MsgDoc]
shadowed_locs)]
unknownSubordinateErr :: SDoc -> RdrName -> SDoc
unknownSubordinateErr :: MsgDoc -> RdrName -> MsgDoc
unknownSubordinateErr MsgDoc
doc RdrName
op
= MsgDoc -> MsgDoc
quotes (RdrName -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr RdrName
op) MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
"is not a (visible)" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc
doc
dupNamesErr :: Outputable n => (n -> SrcSpan) -> NE.NonEmpty n -> RnM ()
dupNamesErr :: (n -> SrcSpan) -> NonEmpty n -> IOEnv (Env TcGblEnv TcLclEnv) ()
dupNamesErr n -> SrcSpan
get_loc NonEmpty n
names
= SrcSpan -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErrAt SrcSpan
big_loc (MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
[MsgDoc] -> MsgDoc
vcat [String -> MsgDoc
text String
"Conflicting definitions for" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (n -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (NonEmpty n -> n
forall a. NonEmpty a -> a
NE.head NonEmpty n
names)),
MsgDoc
locations]
where
locs :: [SrcSpan]
locs = (n -> SrcSpan) -> [n] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map n -> SrcSpan
get_loc (NonEmpty n -> [n]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty n
names)
big_loc :: SrcSpan
big_loc = (SrcSpan -> SrcSpan -> SrcSpan) -> [SrcSpan] -> SrcSpan
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans [SrcSpan]
locs
locations :: MsgDoc
locations = String -> MsgDoc
text String
"Bound at:" MsgDoc -> MsgDoc -> MsgDoc
<+> [MsgDoc] -> MsgDoc
vcat ((SrcSpan -> MsgDoc) -> [SrcSpan] -> [MsgDoc]
forall a b. (a -> b) -> [a] -> [b]
map SrcSpan -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr ([SrcSpan] -> [SrcSpan]
forall a. Ord a => [a] -> [a]
sort [SrcSpan]
locs))
badQualBndrErr :: RdrName -> SDoc
badQualBndrErr :: RdrName -> MsgDoc
badQualBndrErr RdrName
rdr_name
= String -> MsgDoc
text String
"Qualified name in binding position:" MsgDoc -> MsgDoc -> MsgDoc
<+> RdrName -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr RdrName
rdr_name
typeAppErr :: String -> LHsType GhcPs -> SDoc
typeAppErr :: String -> LHsType GhcPs -> MsgDoc
typeAppErr String
what (L SrcSpan
_ HsType GhcPs
k)
= MsgDoc -> ThLevel -> MsgDoc -> MsgDoc
hang (String -> MsgDoc
text String
"Illegal visible" MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
what MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
"application"
MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (Char -> MsgDoc
char Char
'@' MsgDoc -> MsgDoc -> MsgDoc
<> HsType GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsType GhcPs
k))
ThLevel
2 (String -> MsgDoc
text String
"Perhaps you intended to use TypeApplications")
checkTupSize :: Int -> RnM ()
checkTupSize :: ThLevel -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkTupSize ThLevel
tup_size
| ThLevel
tup_size ThLevel -> ThLevel -> Bool
forall a. Ord a => a -> a -> Bool
<= ThLevel
mAX_TUPLE_SIZE
= () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise
= MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr ([MsgDoc] -> MsgDoc
sep [String -> MsgDoc
text String
"A" MsgDoc -> MsgDoc -> MsgDoc
<+> ThLevel -> MsgDoc
int ThLevel
tup_size MsgDoc -> MsgDoc -> MsgDoc
<> PtrString -> MsgDoc
ptext (String -> PtrString
sLit String
"-tuple is too large for GHC"),
ThLevel -> MsgDoc -> MsgDoc
nest ThLevel
2 (MsgDoc -> MsgDoc
parens (String -> MsgDoc
text String
"max size is" MsgDoc -> MsgDoc -> MsgDoc
<+> ThLevel -> MsgDoc
int ThLevel
mAX_TUPLE_SIZE)),
ThLevel -> MsgDoc -> MsgDoc
nest ThLevel
2 (String -> MsgDoc
text String
"Workaround: use nested tuples or define a data type")])
data HsDocContext
= TypeSigCtx SDoc
| StandaloneKindSigCtx SDoc
| PatCtx
| SpecInstSigCtx
| DefaultDeclCtx
| ForeignDeclCtx (Located RdrName)
| DerivDeclCtx
| RuleCtx FastString
| TyDataCtx (Located RdrName)
| TySynCtx (Located RdrName)
| TyFamilyCtx (Located RdrName)
| FamPatCtx (Located RdrName)
| ConDeclCtx [Located Name]
| ClassDeclCtx (Located RdrName)
| ExprWithTySigCtx
| TypBrCtx
| HsTypeCtx
| GHCiCtx
| SpliceTypeCtx (LHsType GhcPs)
| ClassInstanceCtx
| GenericCtx SDoc
withHsDocContext :: HsDocContext -> SDoc -> SDoc
withHsDocContext :: HsDocContext -> MsgDoc -> MsgDoc
withHsDocContext HsDocContext
ctxt MsgDoc
doc = MsgDoc
doc MsgDoc -> MsgDoc -> MsgDoc
$$ HsDocContext -> MsgDoc
inHsDocContext HsDocContext
ctxt
inHsDocContext :: HsDocContext -> SDoc
inHsDocContext :: HsDocContext -> MsgDoc
inHsDocContext HsDocContext
ctxt = String -> MsgDoc
text String
"In" MsgDoc -> MsgDoc -> MsgDoc
<+> HsDocContext -> MsgDoc
pprHsDocContext HsDocContext
ctxt
pprHsDocContext :: HsDocContext -> SDoc
pprHsDocContext :: HsDocContext -> MsgDoc
pprHsDocContext (GenericCtx MsgDoc
doc) = MsgDoc
doc
pprHsDocContext (TypeSigCtx MsgDoc
doc) = String -> MsgDoc
text String
"the type signature for" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc
doc
pprHsDocContext (StandaloneKindSigCtx MsgDoc
doc) = String -> MsgDoc
text String
"the standalone kind signature for" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc
doc
pprHsDocContext HsDocContext
PatCtx = String -> MsgDoc
text String
"a pattern type-signature"
pprHsDocContext HsDocContext
SpecInstSigCtx = String -> MsgDoc
text String
"a SPECIALISE instance pragma"
pprHsDocContext HsDocContext
DefaultDeclCtx = String -> MsgDoc
text String
"a `default' declaration"
pprHsDocContext HsDocContext
DerivDeclCtx = String -> MsgDoc
text String
"a deriving declaration"
pprHsDocContext (RuleCtx FieldLabelString
name) = String -> MsgDoc
text String
"the transformation rule" MsgDoc -> MsgDoc -> MsgDoc
<+> FieldLabelString -> MsgDoc
ftext FieldLabelString
name
pprHsDocContext (TyDataCtx Located RdrName
tycon) = String -> MsgDoc
text String
"the data type declaration for" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (Located RdrName -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Located RdrName
tycon)
pprHsDocContext (FamPatCtx Located RdrName
tycon) = String -> MsgDoc
text String
"a type pattern of family instance for" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (Located RdrName -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Located RdrName
tycon)
pprHsDocContext (TySynCtx Located RdrName
name) = String -> MsgDoc
text String
"the declaration for type synonym" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (Located RdrName -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Located RdrName
name)
pprHsDocContext (TyFamilyCtx Located RdrName
name) = String -> MsgDoc
text String
"the declaration for type family" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (Located RdrName -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Located RdrName
name)
pprHsDocContext (ClassDeclCtx Located RdrName
name) = String -> MsgDoc
text String
"the declaration for class" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (Located RdrName -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Located RdrName
name)
pprHsDocContext HsDocContext
ExprWithTySigCtx = String -> MsgDoc
text String
"an expression type signature"
pprHsDocContext HsDocContext
TypBrCtx = String -> MsgDoc
text String
"a Template-Haskell quoted type"
pprHsDocContext HsDocContext
HsTypeCtx = String -> MsgDoc
text String
"a type argument"
pprHsDocContext HsDocContext
GHCiCtx = String -> MsgDoc
text String
"GHCi input"
pprHsDocContext (SpliceTypeCtx LHsType GhcPs
hs_ty) = String -> MsgDoc
text String
"the spliced type" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (LHsType GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr LHsType GhcPs
hs_ty)
pprHsDocContext HsDocContext
ClassInstanceCtx = String -> MsgDoc
text String
"TcSplice.reifyInstances"
pprHsDocContext (ForeignDeclCtx Located RdrName
name)
= String -> MsgDoc
text String
"the foreign declaration for" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (Located RdrName -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Located RdrName
name)
pprHsDocContext (ConDeclCtx [Located Name
name])
= String -> MsgDoc
text String
"the definition of data constructor" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (Located Name -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Located Name
name)
pprHsDocContext (ConDeclCtx [Located Name]
names)
= String -> MsgDoc
text String
"the definition of data constructors" MsgDoc -> MsgDoc -> MsgDoc
<+> [Located Name] -> MsgDoc
forall a. Outputable a => [a] -> MsgDoc
interpp'SP [Located Name]
names