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 (L loc rdr_name)
| Just name <- isExact_maybe rdr_name
= return name
| otherwise
= do { unless (isUnqual rdr_name)
(addErrAt (locA loc) (badQualBndrErr rdr_name))
; uniq <- newUnique
; return (mkInternalName uniq (rdrNameOcc rdr_name) (locA loc)) }
newLocalBndrsRn :: [LocatedN RdrName] -> RnM [Name]
newLocalBndrsRn = mapM newLocalBndrRn
bindLocalNames :: [Name] -> RnM a -> RnM a
bindLocalNames names
= updLclEnv $ \ lcl_env ->
let th_level = thLevel (tcl_th_ctxt lcl_env)
th_bndrs' = extendNameEnvList (tcl_th_bndrs lcl_env)
[ (n, (NotTopLevel, th_level)) | n <- names ]
rdr_env' = extendLocalRdrEnvList (tcl_rdr lcl_env) names
in lcl_env { tcl_th_bndrs = th_bndrs'
, tcl_rdr = rdr_env' }
bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindLocalNamesFV names enclosed_scope
= do { (result, fvs) <- bindLocalNames names enclosed_scope
; return (result, delFVs names fvs) }
checkDupRdrNames :: [LocatedN RdrName] -> RnM ()
checkDupRdrNames rdr_names_w_loc
= mapM_ (dupNamesErr getLocA) dups
where
(_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc
checkDupRdrNamesN :: [LocatedN RdrName] -> RnM ()
checkDupRdrNamesN rdr_names_w_loc
= mapM_ (dupNamesErr getLocA) dups
where
(_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc
checkDupNames :: [Name] -> RnM ()
checkDupNames names = check_dup_names (filterOut isSystemName names)
check_dup_names :: [Name] -> RnM ()
check_dup_names names
= mapM_ (dupNamesErr nameSrcSpan) dups
where
(_, dups) = removeDups (\n1 n2 -> nameOccName n1 `compare` nameOccName n2) names
checkShadowedRdrNames :: [LocatedN RdrName] -> RnM ()
checkShadowedRdrNames loc_rdr_names
= do { envs <- getRdrEnvs
; checkShadowedOccs envs get_loc_occ filtered_rdrs }
where
filtered_rdrs = filterOut (isExact . unLoc) loc_rdr_names
get_loc_occ (L loc rdr) = (locA loc,rdrNameOcc rdr)
checkDupAndShadowedNames :: (GlobalRdrEnv, LocalRdrEnv) -> [Name] -> RnM ()
checkDupAndShadowedNames envs names
= do { check_dup_names filtered_names
; checkShadowedOccs envs get_loc_occ filtered_names }
where
filtered_names = filterOut isSystemName names
get_loc_occ name = (nameSrcSpan name, nameOccName name)
checkShadowedOccs :: (GlobalRdrEnv, LocalRdrEnv)
-> (a -> (SrcSpan, OccName))
-> [a] -> RnM ()
checkShadowedOccs (global_env,local_env) get_loc_occ ns
= whenWOptM Opt_WarnNameShadowing $
do { traceRn "checkShadowedOccs:shadow" (ppr (map get_loc_occ ns))
; mapM_ check_shadow ns }
where
check_shadow n
| startsWithUnderscore occ = return ()
| Just n <- mb_local = complain (ShadowedNameProvenanceLocal (nameSrcLoc n))
| otherwise = do { gres' <- filterM is_shadowed_gre gres
; when (not . null $ gres') $ complain (ShadowedNameProvenanceGlobal gres') }
where
(loc,occ) = get_loc_occ n
mb_local = lookupLocalRdrOcc local_env occ
gres = lookupGRE_RdrName (mkRdrUnqual occ) global_env
complain provenance = addDiagnosticAt loc (TcRnShadowedName occ provenance)
is_shadowed_gre :: GlobalRdrElt -> RnM Bool
is_shadowed_gre gre | isRecFldGRE gre
= do { dflags <- getDynFlags
; return $ not (xopt LangExt.NamedFieldPuns dflags
|| xopt LangExt.RecordWildCards dflags) }
is_shadowed_gre _other = return True
checkInferredVars :: HsDocContext
-> Maybe SDoc
-> LHsSigType GhcPs
-> RnM ()
checkInferredVars _ Nothing _ = return ()
checkInferredVars ctxt (Just msg) ty =
let bndrs = sig_ty_bndrs ty
in case find ((==) InferredSpec . hsTyVarBndrFlag) bndrs of
Nothing -> return ()
Just _ -> addErr $ TcRnUnknownMessage $ mkPlainError noHints (withHsDocContext ctxt msg)
where
sig_ty_bndrs :: LHsSigType GhcPs -> [HsTyVarBndr Specificity GhcPs]
sig_ty_bndrs (L _ (HsSig{sig_bndrs = outer_bndrs}))
= map unLoc (hsOuterExplicitBndrs outer_bndrs)
noNestedForallsContextsErr :: SDoc -> LHsType GhcRn -> Maybe (SrcSpan, SDoc)
noNestedForallsContextsErr what lty =
case ignoreParens lty of
L l (HsForAllTy { hst_tele = tele })
| HsForAllVis{} <- tele
-> Just (locA l, vcat [ text "Illegal visible, dependent quantification" <+>
text "in the type of a term"
, text "(GHC does not yet support this)" ])
| HsForAllInvis{} <- tele
-> Just (locA l, nested_foralls_contexts_err)
L l (HsQualTy {})
-> Just (locA l, nested_foralls_contexts_err)
_ -> Nothing
where
nested_foralls_contexts_err =
what <+> text "cannot contain nested"
<+> quotes forAllLit <> text "s or contexts"
addNoNestedForallsContextsErr :: HsDocContext -> SDoc -> LHsType GhcRn -> RnM ()
addNoNestedForallsContextsErr ctxt what lty =
whenIsJust (noNestedForallsContextsErr what lty) $ \(l, err_msg) ->
addErrAt l $ TcRnUnknownMessage $ mkPlainError noHints (withHsDocContext ctxt err_msg)
addFvRn :: FreeVars -> RnM (thing, FreeVars) -> RnM (thing, FreeVars)
addFvRn fvs1 thing_inside = do { (res, fvs2) <- thing_inside
; return (res, fvs1 `plusFV` fvs2) }
mapFvRn :: (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn f xs = do stuff <- mapM f xs
case unzip stuff of
(ys, fvs_s) -> return (ys, plusFVs fvs_s)
mapMaybeFvRn :: (a -> RnM (b, FreeVars)) -> Maybe a -> RnM (Maybe b, FreeVars)
mapMaybeFvRn _ Nothing = return (Nothing, emptyFVs)
mapMaybeFvRn f (Just x) = do { (y, fvs) <- f x; return (Just y, fvs) }
warnUnusedTopBinds :: [GlobalRdrElt] -> RnM ()
warnUnusedTopBinds gres
= whenWOptM Opt_WarnUnusedTopBinds
$ do env <- getGblEnv
let isBoot = tcg_src env == HsBootFile
let noParent gre = case gre_par gre of
NoParent -> True
_ -> False
gres' = if isBoot then filter noParent gres
else gres
warnUnusedGREs gres'
checkUnusedRecordWildcard :: SrcSpan
-> FreeVars
-> Maybe [Name]
-> RnM ()
checkUnusedRecordWildcard _ _ Nothing = return ()
checkUnusedRecordWildcard loc _ (Just []) =
setSrcSpan loc $ warnRedundantRecordWildcard
checkUnusedRecordWildcard loc fvs (Just dotdot_names) =
setSrcSpan loc $ warnUnusedRecordWildcard dotdot_names fvs
warnRedundantRecordWildcard :: RnM ()
warnRedundantRecordWildcard =
whenWOptM Opt_WarnRedundantRecordWildcards $
let msg = TcRnUnknownMessage $
mkPlainDiagnostic (WarningWithFlag Opt_WarnRedundantRecordWildcards)
noHints
redundantWildcardWarning
in addDiagnostic msg
warnUnusedRecordWildcard :: [Name] -> FreeVars -> RnM ()
warnUnusedRecordWildcard ns used_names = do
let used = filter (`elemNameSet` used_names) ns
traceRn "warnUnused" (ppr ns $$ ppr used_names $$ ppr used)
warnIf (null used)
unusedRecordWildcardWarning
warnUnusedLocalBinds, warnUnusedMatches, warnUnusedTypePatterns
:: [Name] -> FreeVars -> RnM ()
warnUnusedLocalBinds = check_unused Opt_WarnUnusedLocalBinds
warnUnusedMatches = check_unused Opt_WarnUnusedMatches
warnUnusedTypePatterns = check_unused Opt_WarnUnusedTypePatterns
check_unused :: WarningFlag -> [Name] -> FreeVars -> RnM ()
check_unused flag bound_names used_names
= whenWOptM flag (warnUnused flag (filterOut (`elemNameSet` used_names)
bound_names))
warnForallIdentifier :: LocatedN RdrName -> RnM ()
warnForallIdentifier (L l rdr_name@(Unqual occ))
| isKw (fsLit "forall") || isKw (fsLit "∀")
= addDiagnosticAt (locA l) (TcRnForallIdentifier rdr_name)
where isKw = (occNameFS occ ==)
warnForallIdentifier _ = return ()
warnUnusedGREs :: [GlobalRdrElt] -> RnM ()
warnUnusedGREs gres = mapM_ warnUnusedGRE gres
warnUnused :: WarningFlag -> [Name] -> RnM ()
warnUnused flag names =
mapM_ (warnUnused1 flag . NormalGreName) names
warnUnused1 :: WarningFlag -> GreName -> RnM ()
warnUnused1 flag child
= when (reportable child) $
addUnusedWarning flag
(occName child) (greNameSrcSpan child)
(text $ "Defined but not used" ++ opt_str)
where
opt_str = case flag of
Opt_WarnUnusedTypePatterns -> " on the right hand side"
_ -> ""
warnUnusedGRE :: GlobalRdrElt -> RnM ()
warnUnusedGRE gre@(GRE { gre_lcl = lcl, gre_imp = is })
| lcl = warnUnused1 Opt_WarnUnusedTopBinds (gre_name gre)
| otherwise = when (reportable (gre_name gre)) (mapM_ warn is)
where
occ = greOccName gre
warn spec = addUnusedWarning Opt_WarnUnusedTopBinds occ span msg
where
span = importSpecLoc spec
pp_mod = quotes (ppr (importSpecModule spec))
msg = text "Imported from" <+> pp_mod <+> text "but not used"
mkFieldEnv :: GlobalRdrEnv -> NameEnv (FieldLabelString, Parent)
mkFieldEnv rdr_env = mkNameEnv [ (greMangledName gre, (flLabel fl, gre_par gre))
| gres <- nonDetOccEnvElts rdr_env
, gre <- gres
, Just fl <- [greFieldLabel gre]
]
reportable :: GreName -> Bool
reportable child
| NormalGreName name <- child
, isWiredInName name = False
| otherwise = not (startsWithUnderscore (occName child))
addUnusedWarning :: WarningFlag -> OccName -> SrcSpan -> SDoc -> RnM ()
addUnusedWarning flag occ span msg = do
let diag = TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag flag) noHints $
sep [msg <> colon,
nest 2 $ pprNonVarNameSpace (occNameSpace occ)
<+> quotes (ppr occ)]
addDiagnosticAt span diag
unusedRecordWildcardWarning :: TcRnMessage
unusedRecordWildcardWarning =
TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnUnusedRecordWildcards) noHints $
wildcardDoc $ text "No variables bound in the record wildcard match are used"
redundantWildcardWarning :: SDoc
redundantWildcardWarning =
wildcardDoc $ text "Record wildcard does not bind any new variables"
wildcardDoc :: SDoc -> SDoc
wildcardDoc herald =
herald
$$ nest 2 (text "Possible fix" <> colon <+> text "omit the"
<+> quotes (text ".."))
addNameClashErrRn :: RdrName -> NE.NonEmpty GlobalRdrElt -> RnM ()
addNameClashErrRn rdr_name gres
| all isLocalGRE gres && can_skip
= return ()
| otherwise
= addErr $ TcRnUnknownMessage $ mkPlainError noHints $
(vcat [ text "Ambiguous occurrence" <+> quotes (ppr rdr_name)
, text "It could refer to"
, nest 3 (vcat (msg1 : msgs)) ])
where
np1 NE.:| nps = gres
msg1 = text "either" <+> ppr_gre np1
msgs = [text " or" <+> ppr_gre np | np <- nps]
ppr_gre gre = sep [ pp_greMangledName gre <> comma
, pprNameProvenance gre]
pp_greMangledName gre@(GRE { gre_name = child, gre_par = par
, gre_lcl = lcl, gre_imp = iss }) =
case child of
FieldGreName fl -> text "the field" <+> quotes (ppr fl) <+> parent_info
NormalGreName name -> quotes (pp_qual name <> dot <> ppr (nameOccName name))
where
parent_info = case par of
NoParent -> empty
ParentIs { par_is = par_name } -> text "of record" <+> quotes (ppr par_name)
pp_qual name
| lcl
= ppr (nameModule name)
| Just imp <- headMaybe iss
, ImpDeclSpec { is_as = mod } <- is_decl imp
= ppr mod
| otherwise
= pprPanic "addNameClassErrRn" (ppr gre $$ ppr iss)
can_skip = num_non_flds >= 2
|| (num_flds >= 2 && not (isDuplicateRecFldGRE (head flds)))
|| (num_non_flds >= 1 && num_flds >= 1
&& not (isNoFieldSelectorGRE (head flds)))
(flds, non_flds) = NE.partition isRecFldGRE gres
num_flds = length flds
num_non_flds = length non_flds
dupNamesErr :: Outputable n => (n -> SrcSpan) -> NE.NonEmpty n -> RnM ()
dupNamesErr get_loc names
= addErrAt big_loc $ TcRnUnknownMessage $ mkPlainError noHints $
vcat [text "Conflicting definitions for" <+> quotes (ppr (NE.head names)),
locations]
where
locs = map get_loc (NE.toList names)
big_loc = foldr1 combineSrcSpans locs
locations = text "Bound at:" <+> vcat (map ppr (sortBy SrcLoc.leftmost_smallest locs))
badQualBndrErr :: RdrName -> TcRnMessage
badQualBndrErr rdr_name
= TcRnUnknownMessage $ mkPlainError noHints $
text "Qualified name in binding position:" <+> ppr rdr_name
typeAppErr :: String -> LHsType GhcPs -> TcRnMessage
typeAppErr what (L _ k)
= TcRnUnknownMessage $ mkPlainError noHints $
hang (text "Illegal visible" <+> text what <+> text "application"
<+> quotes (char '@' <> ppr k))
2 (text "Perhaps you intended to use TypeApplications")
badFieldConErr :: Name -> FieldLabelString -> TcRnMessage
badFieldConErr con field
= TcRnUnknownMessage $ mkPlainError noHints $
hsep [text "Constructor" <+> quotes (ppr con),
text "does not have field", quotes (ppr field)]
checkTupSize :: Int -> TcM ()
checkTupSize tup_size
| tup_size <= mAX_TUPLE_SIZE
= return ()
| otherwise
= addErr $ TcRnUnknownMessage $ mkPlainError noHints $
sep [text "A" <+> int tup_size <> text "-tuple is too large for GHC",
nest 2 (parens (text "max size is" <+> int mAX_TUPLE_SIZE)),
nest 2 (text "Workaround: use nested tuples or define a data type")]
checkCTupSize :: Int -> TcM ()
checkCTupSize tup_size
| tup_size <= mAX_CTUPLE_SIZE
= return ()
| otherwise
= addErr $ TcRnUnknownMessage $ mkPlainError noHints $
hang (text "Constraint tuple arity too large:" <+> int tup_size
<+> parens (text "max arity =" <+> int mAX_CTUPLE_SIZE))
2 (text "Instead, use a nested tuple")
wrapGenSpan :: a -> LocatedAn an a
wrapGenSpan x = L (noAnnSrcSpan generatedSrcSpan) x
genHsApps :: Name -> [LHsExpr GhcRn] -> HsExpr GhcRn
genHsApps fun args = foldl genHsApp (genHsVar fun) args
genHsApp :: HsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
genHsApp fun arg = HsApp noAnn (wrapGenSpan fun) arg
genLHsVar :: Name -> LHsExpr GhcRn
genLHsVar nm = wrapGenSpan $ genHsVar nm
genHsVar :: Name -> HsExpr GhcRn
genHsVar nm = HsVar noExtField $ wrapGenSpan nm
genAppType :: HsExpr GhcRn -> HsType (NoGhcTc GhcRn) -> HsExpr GhcRn
genAppType expr = HsAppType noExtField (wrapGenSpan expr) . mkEmptyWildCardBndrs . wrapGenSpan
genHsIntegralLit :: IntegralLit -> LocatedAn an (HsExpr GhcRn)
genHsIntegralLit lit = wrapGenSpan $ HsLit noAnn (HsInt noExtField lit)
genHsTyLit :: FastString -> HsType GhcRn
genHsTyLit = HsTyLit noExtField . HsStrTy NoSourceText