module GHC.Rename.Names (
rnImports, getLocalNonValBinders, newRecordSelector,
extendGlobalRdrEnvRn,
gresFromAvails,
calculateAvails,
reportUnusedNames,
checkConName,
mkChildEnv,
findChildren,
dodgyMsg,
dodgyMsgInsert,
findImportUsage,
getMinimalImports,
printMinimalImports,
ImportDeclUsage
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Driver.Env
import GHC.Driver.Session
import GHC.Driver.Ppr
import GHC.Rename.Env
import GHC.Rename.Fixity
import GHC.Rename.Utils ( warnUnusedTopBinds, mkFieldEnv )
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.Monad
import GHC.Hs
import GHC.Iface.Load ( loadSrcInterface )
import GHC.Builtin.Names
import GHC.Parser.PostProcess ( setRdrNameSpace )
import GHC.Core.Type
import GHC.Core.PatSyn
import GHC.Core.TyCo.Ppr
import GHC.Core.TyCon ( TyCon, tyConName, tyConKind )
import qualified GHC.LanguageExtensions as LangExt
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Misc as Utils
import GHC.Utils.Panic
import GHC.Types.Fixity.Env
import GHC.Types.SafeHaskell
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Name.Set
import GHC.Types.Name.Reader
import GHC.Types.Avail
import GHC.Types.FieldLabel
import GHC.Types.SourceFile
import GHC.Types.SrcLoc as SrcLoc
import GHC.Types.Basic ( TopLevelFlag(..) )
import GHC.Types.SourceText
import GHC.Types.Id
import GHC.Types.HpcInfo
import GHC.Unit
import GHC.Unit.Module.Warnings
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.Imported
import GHC.Unit.Module.Deps
import GHC.Data.Maybe
import GHC.Data.FastString
import GHC.Data.FastString.Env
import Control.Monad
import Data.Either ( partitionEithers )
import Data.Map ( Map )
import qualified Data.Map as Map
import Data.Ord ( comparing )
import Data.List ( partition, (\\), find, sortBy, groupBy, sortOn )
import Data.Function ( on )
import qualified Data.Set as S
import System.FilePath ((</>))
import System.IO
rnImports :: [LImportDecl GhcPs]
-> RnM ([LImportDecl GhcRn], GlobalRdrEnv, ImportAvails, AnyHpcUsage)
rnImports imports = do
tcg_env <- getGblEnv
let this_mod = tcg_mod tcg_env
let (source, ordinary) = partition is_source_import imports
is_source_import d = ideclSource (unLoc d) == IsBoot
stuff1 <- mapAndReportM (rnImportDecl this_mod) ordinary
stuff2 <- mapAndReportM (rnImportDecl this_mod) source
let (decls, rdr_env, imp_avails, hpc_usage) = combine (stuff1 ++ stuff2)
return (decls, rdr_env, imp_avails, hpc_usage)
where
combine :: [(LImportDecl GhcRn, GlobalRdrEnv, ImportAvails, AnyHpcUsage)]
-> ([LImportDecl GhcRn], GlobalRdrEnv, ImportAvails, AnyHpcUsage)
combine ss =
let (decls, rdr_env, imp_avails, hpc_usage, finsts) = foldr
plus
([], emptyGlobalRdrEnv, emptyImportAvails, False, emptyModuleSet)
ss
in (decls, rdr_env, imp_avails { imp_finsts = moduleSetElts finsts },
hpc_usage)
plus (decl, gbl_env1, imp_avails1, hpc_usage1)
(decls, gbl_env2, imp_avails2, hpc_usage2, finsts_set)
= ( decl:decls,
gbl_env1 `plusGlobalRdrEnv` gbl_env2,
imp_avails1' `plusImportAvails` imp_avails2,
hpc_usage1 || hpc_usage2,
extendModuleSetList finsts_set new_finsts )
where
imp_avails1' = imp_avails1 { imp_finsts = [] }
new_finsts = imp_finsts imp_avails1
rnImportDecl :: Module -> LImportDecl GhcPs
-> RnM (LImportDecl GhcRn, GlobalRdrEnv, ImportAvails, AnyHpcUsage)
rnImportDecl this_mod
(L loc decl@(ImportDecl { ideclName = loc_imp_mod_name
, ideclPkgQual = mb_pkg
, ideclSource = want_boot, ideclSafe = mod_safe
, ideclQualified = qual_style, ideclImplicit = implicit
, ideclAs = as_mod, ideclHiding = imp_details }))
= setSrcSpanA loc $ do
when (isJust mb_pkg) $ do
pkg_imports <- xoptM LangExt.PackageImports
when (not pkg_imports) $ addErr packageImportErr
let qual_only = isImportDeclQualified qual_style
let imp_mod_name = unLoc loc_imp_mod_name
doc = ppr imp_mod_name <+> text "is directly imported"
when (imp_mod_name == moduleName this_mod &&
(case mb_pkg of
Nothing -> True
Just (StringLiteral _ pkg_fs _) -> pkg_fs == fsLit "this" ||
fsToUnit pkg_fs == moduleUnit this_mod))
(addErr (text "A module cannot import itself:" <+> ppr imp_mod_name))
case imp_details of
Just (False, _) -> return ()
_ | implicit -> return ()
| qual_only -> return ()
| otherwise -> whenWOptM Opt_WarnMissingImportList $
addWarn (Reason Opt_WarnMissingImportList)
(missingImportListWarn imp_mod_name)
iface <- loadSrcInterface doc imp_mod_name want_boot (fmap sl_fs mb_pkg)
WARN( (want_boot == NotBoot) && (mi_boot iface == IsBoot), ppr imp_mod_name ) do
dflags <- getDynFlags
warnIf ((want_boot == IsBoot) && (mi_boot iface == NotBoot) && isOneShot (ghcMode dflags))
(warnRedundantSourceImport imp_mod_name)
when (mod_safe && not (safeImportsOn dflags)) $
addErr (text "safe import can't be used as Safe Haskell isn't on!"
$+$ ptext (sLit $ "please enable Safe Haskell through either "
++ "Safe, Trustworthy or Unsafe"))
let
qual_mod_name = fmap unLoc as_mod `orElse` imp_mod_name
imp_spec = ImpDeclSpec { is_mod = imp_mod_name, is_qual = qual_only,
is_dloc = locA loc, is_as = qual_mod_name }
(new_imp_details, gres) <- filterImports iface imp_spec imp_details
potential_gres <- mkGlobalRdrEnv . snd <$> filterImports iface imp_spec Nothing
let gbl_env = mkGlobalRdrEnv gres
is_hiding | Just (True,_) <- imp_details = True
| otherwise = False
mod_safe' = mod_safe
|| (not implicit && safeDirectImpsReq dflags)
|| (implicit && safeImplicitImpsReq dflags)
hsc_env <- getTopEnv
let home_unit = hsc_home_unit hsc_env
imv = ImportedModsVal
{ imv_name = qual_mod_name
, imv_span = locA loc
, imv_is_safe = mod_safe'
, imv_is_hiding = is_hiding
, imv_all_exports = potential_gres
, imv_qualified = qual_only
}
imports = calculateAvails home_unit iface mod_safe' want_boot (ImportedByUser imv)
whenWOptM Opt_WarnWarningsDeprecations (
case (mi_warns iface) of
WarnAll txt -> addWarn (Reason Opt_WarnWarningsDeprecations)
(moduleWarn imp_mod_name txt)
_ -> return ()
)
warnUnqualifiedImport decl iface
let new_imp_decl = L loc (decl { ideclExt = noExtField, ideclSafe = mod_safe'
, ideclHiding = new_imp_details
, ideclName = ideclName decl
, ideclAs = ideclAs decl })
return (new_imp_decl, gbl_env, imports, mi_hpc iface)
calculateAvails :: HomeUnit
-> ModIface
-> IsSafeImport
-> IsBootInterface
-> ImportedBy
-> ImportAvails
calculateAvails home_unit iface mod_safe' want_boot imported_by =
let imp_mod = mi_module iface
imp_sem_mod= mi_semantic_module iface
orph_iface = mi_orphan (mi_final_exts iface)
has_finsts = mi_finsts (mi_final_exts iface)
deps = mi_deps iface
trust = getSafeMode $ mi_trust iface
trust_pkg = mi_trust_pkg iface
orphans | orph_iface = ASSERT2( not (imp_sem_mod `elem` dep_orphs deps), ppr imp_sem_mod <+> ppr (dep_orphs deps) )
imp_sem_mod : dep_orphs deps
| otherwise = dep_orphs deps
finsts | has_finsts = ASSERT2( not (imp_sem_mod `elem` dep_finsts deps), ppr imp_sem_mod <+> ppr (dep_orphs deps) )
imp_sem_mod : dep_finsts deps
| otherwise = dep_finsts deps
pkg = moduleUnit (mi_module iface)
ipkg = toUnitId pkg
ptrust = trust == Sf_Trustworthy || trust_pkg
(dependent_mods, dependent_pkgs, pkg_trust_req)
| isHomeUnit home_unit pkg =
( GWIB { gwib_mod = moduleName imp_mod, gwib_isBoot = want_boot } : dep_mods deps
, dep_pkgs deps
, ptrust
)
| otherwise =
ASSERT2( not (ipkg `elem` (map fst $ dep_pkgs deps))
, ppr ipkg <+> ppr (dep_pkgs deps) )
([], (ipkg, False) : dep_pkgs deps, False)
in ImportAvails {
imp_mods = unitModuleEnv (mi_module iface) [imported_by],
imp_orphs = orphans,
imp_finsts = finsts,
imp_dep_mods = mkModDeps dependent_mods,
imp_dep_pkgs = S.fromList . map fst $ dependent_pkgs,
imp_trust_pkgs = if mod_safe'
then S.fromList . map fst $ filter snd dependent_pkgs
else S.empty,
imp_trust_own_pkg = pkg_trust_req
}
warnUnqualifiedImport :: ImportDecl GhcPs -> ModIface -> RnM ()
warnUnqualifiedImport decl iface =
whenWOptM Opt_WarnCompatUnqualifiedImports
$ when bad_import
$ addWarnAt (Reason Opt_WarnCompatUnqualifiedImports) loc warning
where
mod = mi_module iface
loc = getLoc $ ideclName decl
is_qual = isImportDeclQualified (ideclQualified decl)
has_import_list =
case ideclHiding decl of
Just (False, _) -> True
_ -> False
bad_import =
mod `elemModuleSet` qualifiedMods
&& not is_qual
&& not has_import_list
warning = vcat
[ text "To ensure compatibility with future core libraries changes"
, text "imports to" <+> ppr (ideclName decl) <+> text "should be"
, text "either qualified or have an explicit import list."
]
qualifiedMods = mkModuleSet [ dATA_LIST ]
warnRedundantSourceImport :: ModuleName -> SDoc
warnRedundantSourceImport mod_name
= text "Unnecessary {-# SOURCE #-} in the import of module"
<+> quotes (ppr mod_name)
extendGlobalRdrEnvRn :: [AvailInfo]
-> MiniFixityEnv
-> RnM (TcGblEnv, TcLclEnv)
extendGlobalRdrEnvRn avails new_fixities
= do { (gbl_env, lcl_env) <- getEnvs
; stage <- getStage
; isGHCi <- getIsGHCi
; let rdr_env = tcg_rdr_env gbl_env
fix_env = tcg_fix_env gbl_env
th_bndrs = tcl_th_bndrs lcl_env
th_lvl = thLevel stage
inBracket = isBrackStage stage
lcl_env_TH = lcl_env { tcl_rdr = delLocalRdrEnvList (tcl_rdr lcl_env) new_occs }
lcl_env2 | inBracket = lcl_env_TH
| otherwise = lcl_env
want_shadowing = isGHCi || inBracket
rdr_env1 | want_shadowing = shadowNames rdr_env new_names
| otherwise = rdr_env
lcl_env3 = lcl_env2 { tcl_th_bndrs = extendNameEnvList th_bndrs
[ ( greNameMangledName n
, (TopLevel, th_lvl) )
| n <- new_names ] }
; rdr_env2 <- foldlM add_gre rdr_env1 new_gres
; let fix_env' = foldl' extend_fix_env fix_env new_gres
gbl_env' = gbl_env { tcg_rdr_env = rdr_env2, tcg_fix_env = fix_env' }
; traceRn "extendGlobalRdrEnvRn 2" (pprGlobalRdrEnv True rdr_env2)
; return (gbl_env', lcl_env3) }
where
new_names = concatMap availGreNames avails
new_occs = map occName new_names
extend_fix_env fix_env gre
| Just (L _ fi) <- lookupFsEnv new_fixities (occNameFS occ)
= extendNameEnv fix_env name (FixItem occ fi)
| otherwise
= fix_env
where
name = greMangledName gre
occ = greOccName gre
new_gres :: [GlobalRdrElt]
new_gres = concatMap localGREsFromAvail avails
add_gre :: GlobalRdrEnv -> GlobalRdrElt -> RnM GlobalRdrEnv
add_gre env gre
| not (null dups)
= do { addDupDeclErr (gre : dups); return env }
| otherwise
= return (extendGlobalRdrEnv env gre)
where
dups = filter isDupGRE (lookupGlobalRdrEnv env (greOccName gre))
isDupGRE gre' = isLocalGRE gre' && not (isAllowedDup gre')
isAllowedDup gre' =
case (isRecFldGRE gre, isRecFldGRE gre') of
(True, True) -> gre_name gre /= gre_name gre'
&& isDuplicateRecFldGRE gre'
(True, False) -> isNoFieldSelectorGRE gre
(False, True) -> isNoFieldSelectorGRE gre'
(False, False) -> False
getLocalNonValBinders :: MiniFixityEnv -> HsGroup GhcPs
-> RnM ((TcGblEnv, TcLclEnv), NameSet)
getLocalNonValBinders fixity_env
(HsGroup { hs_valds = binds,
hs_tyclds = tycl_decls,
hs_fords = foreign_decls })
= do {
; let inst_decls = tycl_decls >>= group_instds
; dup_fields_ok <- xopt_DuplicateRecordFields <$> getDynFlags
; has_sel <- xopt_FieldSelectors <$> getDynFlags
; (tc_avails, tc_fldss)
<- fmap unzip $ mapM (new_tc dup_fields_ok has_sel)
(tyClGroupTyClDecls tycl_decls)
; traceRn "getLocalNonValBinders 1" (ppr tc_avails)
; envs <- extendGlobalRdrEnvRn tc_avails fixity_env
; setEnvs envs $ do {
; (nti_availss, nti_fldss) <- mapAndUnzipM (new_assoc dup_fields_ok has_sel)
inst_decls
; is_boot <- tcIsHsBootOrSig
; let val_bndrs | is_boot = hs_boot_sig_bndrs
| otherwise = for_hs_bndrs
; val_avails <- mapM new_simple val_bndrs
; let avails = concat nti_availss ++ val_avails
new_bndrs = availsToNameSetWithSelectors avails `unionNameSet`
availsToNameSetWithSelectors tc_avails
flds = concat nti_fldss ++ concat tc_fldss
; traceRn "getLocalNonValBinders 2" (ppr avails)
; (tcg_env, tcl_env) <- extendGlobalRdrEnvRn avails fixity_env
; let field_env = extendNameEnvList (tcg_field_env tcg_env) flds
envs = (tcg_env { tcg_field_env = field_env }, tcl_env)
; traceRn "getLocalNonValBinders 3" (vcat [ppr flds, ppr field_env])
; return (envs, new_bndrs) } }
where
ValBinds _ _val_binds val_sigs = binds
for_hs_bndrs :: [LocatedN RdrName]
for_hs_bndrs = hsForeignDeclsBinders foreign_decls
hs_boot_sig_bndrs = [ L (l2l decl_loc) (unLoc n)
| L decl_loc (TypeSig _ ns _) <- val_sigs, n <- ns]
new_simple :: LocatedN RdrName -> RnM AvailInfo
new_simple rdr_name = do{ nm <- newTopSrcBinder rdr_name
; return (avail nm) }
new_tc :: DuplicateRecordFields -> FieldSelectors -> LTyClDecl GhcPs
-> RnM (AvailInfo, [(Name, [FieldLabel])])
new_tc dup_fields_ok has_sel tc_decl
= do { let (bndrs, flds) = hsLTyClDeclBinders tc_decl
; names@(main_name : sub_names) <- mapM (newTopSrcBinder . l2n) bndrs
; flds' <- mapM (newRecordSelector dup_fields_ok has_sel sub_names) flds
; let fld_env = case unLoc tc_decl of
DataDecl { tcdDataDefn = d } -> mk_fld_env d names flds'
_ -> []
; return (availTC main_name names flds', fld_env) }
mk_fld_env :: HsDataDefn GhcPs -> [Name] -> [FieldLabel]
-> [(Name, [FieldLabel])]
mk_fld_env d names flds = concatMap find_con_flds (dd_cons d)
where
find_con_flds (L _ (ConDeclH98 { con_name = L _ rdr
, con_args = RecCon cdflds }))
= [( find_con_name rdr
, concatMap find_con_decl_flds (unLoc cdflds) )]
find_con_flds (L _ (ConDeclGADT { con_names = rdrs
, con_g_args = RecConGADT flds }))
= [ ( find_con_name rdr
, concatMap find_con_decl_flds (unLoc flds))
| L _ rdr <- rdrs ]
find_con_flds _ = []
find_con_name rdr
= expectJust "getLocalNonValBinders/find_con_name" $
find (\ n -> nameOccName n == rdrNameOcc rdr) names
find_con_decl_flds (L _ x)
= map find_con_decl_fld (cd_fld_names x)
find_con_decl_fld (L _ (FieldOcc _ (L _ rdr)))
= expectJust "getLocalNonValBinders/find_con_decl_fld" $
find (\ fl -> flLabel fl == lbl) flds
where lbl = occNameFS (rdrNameOcc rdr)
new_assoc :: DuplicateRecordFields -> FieldSelectors -> LInstDecl GhcPs
-> RnM ([AvailInfo], [(Name, [FieldLabel])])
new_assoc _ _ (L _ (TyFamInstD {})) = return ([], [])
new_assoc dup_fields_ok has_sel (L _ (DataFamInstD _ d))
= do { (avail, flds) <- new_di dup_fields_ok has_sel Nothing d
; return ([avail], flds) }
new_assoc dup_fields_ok has_sel (L _ (ClsInstD _ (ClsInstDecl { cid_poly_ty = inst_ty
, cid_datafam_insts = adts })))
= do
mb_cls_nm <- runMaybeT $ do
L loc cls_rdr <- MaybeT $ pure $ getLHsInstDeclClass_maybe inst_ty
MaybeT $ setSrcSpan (locA loc) $ lookupGlobalOccRn_maybe cls_rdr
case mb_cls_nm of
Nothing -> pure ([], [])
Just cls_nm -> do
(avails, fldss)
<- mapAndUnzipM (new_loc_di dup_fields_ok has_sel (Just cls_nm)) adts
pure (avails, concat fldss)
new_di :: DuplicateRecordFields -> FieldSelectors -> Maybe Name -> DataFamInstDecl GhcPs
-> RnM (AvailInfo, [(Name, [FieldLabel])])
new_di dup_fields_ok has_sel mb_cls dfid@(DataFamInstDecl { dfid_eqn = ti_decl })
= do { main_name <- lookupFamInstName mb_cls (feqn_tycon ti_decl)
; let (bndrs, flds) = hsDataFamInstBinders dfid
; sub_names <- mapM (newTopSrcBinder .l2n) bndrs
; flds' <- mapM (newRecordSelector dup_fields_ok has_sel sub_names) flds
; let avail = availTC (unLoc main_name) sub_names flds'
fld_env = mk_fld_env (feqn_rhs ti_decl) sub_names flds'
; return (avail, fld_env) }
new_loc_di :: DuplicateRecordFields -> FieldSelectors -> Maybe Name -> LDataFamInstDecl GhcPs
-> RnM (AvailInfo, [(Name, [FieldLabel])])
new_loc_di dup_fields_ok has_sel mb_cls (L _ d) = new_di dup_fields_ok has_sel mb_cls d
newRecordSelector :: DuplicateRecordFields -> FieldSelectors -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel
newRecordSelector _ _ [] _ = error "newRecordSelector: datatype has no constructors!"
newRecordSelector dup_fields_ok has_sel (dc:_) (L loc (FieldOcc _ (L _ fld)))
= do { selName <- newTopSrcBinder $ L (noAnnSrcSpan loc) $ field
; return $ FieldLabel { flLabel = fieldLabelString
, flHasDuplicateRecordFields = dup_fields_ok
, flHasFieldSelector = has_sel
, flSelector = selName } }
where
fieldLabelString = occNameFS $ rdrNameOcc fld
selOccName = fieldSelectorOccName fieldLabelString (nameOccName dc) dup_fields_ok has_sel
field | isExact fld = fld
| otherwise = mkRdrUnqual selOccName
filterImports
:: ModIface
-> ImpDeclSpec
-> Maybe (Bool, LocatedL [LIE GhcPs])
-> RnM (Maybe (Bool, LocatedL [LIE GhcRn]),
[GlobalRdrElt])
filterImports iface decl_spec Nothing
= return (Nothing, gresFromAvails (Just imp_spec) (mi_exports iface))
where
imp_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll }
filterImports iface decl_spec (Just (want_hiding, L l import_items))
= do
items1 <- mapM lookup_lie import_items
let items2 :: [(LIE GhcRn, AvailInfo)]
items2 = concat items1
names = availsToNameSetWithSelectors (map snd items2)
keep n = not (n `elemNameSet` names)
pruned_avails = filterAvails keep all_avails
hiding_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll }
gres | want_hiding = gresFromAvails (Just hiding_spec) pruned_avails
| otherwise = concatMap (gresFromIE decl_spec) items2
return (Just (want_hiding, L l (map fst items2)), gres)
where
all_avails = mi_exports iface
imp_occ_env :: OccEnv (NameEnv (GreName,
AvailInfo,
Maybe Name))
imp_occ_env = mkOccEnv_C (plusNameEnv_C combine)
[ (occName c, mkNameEnv [(greNameMangledName c, (c, a, Nothing))])
| a <- all_avails
, c <- availGreNames a]
combine :: (GreName, AvailInfo, Maybe Name)
-> (GreName, AvailInfo, Maybe Name)
-> (GreName, AvailInfo, Maybe Name)
combine (NormalGreName name1, a1@(AvailTC p1 _), mb1)
(NormalGreName name2, a2@(AvailTC p2 _), mb2)
= ASSERT2( name1 == name2 && isNothing mb1 && isNothing mb2
, ppr name1 <+> ppr name2 <+> ppr mb1 <+> ppr mb2 )
if p1 == name1 then (NormalGreName name1, a1, Just p2)
else (NormalGreName name1, a2, Just p1)
combine (c1, a1, mb1) (c2, a2, mb2)
= ASSERT2( c1 == c2 && isNothing mb1 && isNothing mb2
&& (isAvailTC a1 || isAvailTC a2)
, ppr c1 <+> ppr c2 <+> ppr a1 <+> ppr a2 <+> ppr mb1 <+> ppr mb2 )
if isAvailTC a1 then (c1, a1, Nothing)
else (c1, a2, Nothing)
isAvailTC AvailTC{} = True
isAvailTC _ = False
lookup_name :: IE GhcPs -> RdrName -> IELookupM (Name, AvailInfo, Maybe Name)
lookup_name ie rdr
| isQual rdr = failLookupWith (QualImportError rdr)
| Just succ <- mb_success = case nameEnvElts succ of
[(c,a,x)] -> return (greNameMangledName c, a, x)
xs -> failLookupWith (AmbiguousImport rdr (map sndOf3 xs))
| otherwise = failLookupWith (BadImport ie)
where
mb_success = lookupOccEnv imp_occ_env (rdrNameOcc rdr)
lookup_lie :: LIE GhcPs -> TcRn [(LIE GhcRn, AvailInfo)]
lookup_lie (L loc ieRdr)
= do (stuff, warns) <- setSrcSpanA loc $
liftM (fromMaybe ([],[])) $
run_lookup (lookup_ie ieRdr)
mapM_ emit_warning warns
return [ (L loc ie, avail) | (ie,avail) <- stuff ]
where
emit_warning (DodgyImport n) = whenWOptM Opt_WarnDodgyImports $
addWarn (Reason Opt_WarnDodgyImports) (dodgyImportWarn n)
emit_warning MissingImportList = whenWOptM Opt_WarnMissingImportList $
addWarn (Reason Opt_WarnMissingImportList) (missingImportListItem ieRdr)
emit_warning (BadImportW ie) = whenWOptM Opt_WarnDodgyImports $
addWarn (Reason Opt_WarnDodgyImports) (lookup_err_msg (BadImport ie))
run_lookup :: IELookupM a -> TcRn (Maybe a)
run_lookup m = case m of
Failed err -> addErr (lookup_err_msg err) >> return Nothing
Succeeded a -> return (Just a)
lookup_err_msg err = case err of
BadImport ie -> badImportItemErr iface decl_spec ie all_avails
IllegalImport -> illegalImportItemErr
QualImportError rdr -> qualImportItemErr rdr
AmbiguousImport rdr xs -> ambiguousImportItemErr rdr xs
lookup_ie :: IE GhcPs
-> IELookupM ([(IE GhcRn, AvailInfo)], [IELookupWarning])
lookup_ie ie = handle_bad_import $
case ie of
IEVar _ (L l n) -> do
(name, avail, _) <- lookup_name ie $ ieWrappedName n
return ([(IEVar noExtField (L l (replaceWrappedName n name)),
trimAvail avail name)], [])
IEThingAll _ (L l tc) -> do
(name, avail, mb_parent) <- lookup_name ie $ ieWrappedName tc
let warns = case avail of
Avail {}
-> [DodgyImport $ ieWrappedName tc]
AvailTC _ subs
| null (drop 1 subs)
-> [DodgyImport $ ieWrappedName tc]
| not (is_qual decl_spec)
-> [MissingImportList]
| otherwise
-> []
renamed_ie = IEThingAll noAnn (L l (replaceWrappedName tc name))
sub_avails = case avail of
Avail {} -> []
AvailTC name2 subs -> [(renamed_ie, AvailTC name2 (subs \\ [NormalGreName name]))]
case mb_parent of
Nothing -> return ([(renamed_ie, avail)], warns)
Just parent -> return ((renamed_ie, AvailTC parent [NormalGreName name]) : sub_avails, warns)
IEThingAbs _ (L l tc')
| want_hiding
-> let tc = ieWrappedName tc'
tc_name = lookup_name ie tc
dc_name = lookup_name ie (setRdrNameSpace tc srcDataName)
in
case catIELookupM [ tc_name, dc_name ] of
[] -> failLookupWith (BadImport ie)
names -> return ([mkIEThingAbs tc' l name | name <- names], [])
| otherwise
-> do nameAvail <- lookup_name ie (ieWrappedName tc')
return ([mkIEThingAbs tc' l nameAvail]
, [])
IEThingWith xt ltc@(L l rdr_tc) wc rdr_ns -> do
(name, avail, mb_parent)
<- lookup_name (IEThingAbs noAnn ltc) (ieWrappedName rdr_tc)
let subnames = availSubordinateGreNames avail
case lookupChildren subnames rdr_ns of
Failed rdrs -> failLookupWith (BadImport (IEThingWith xt ltc wc rdrs))
Succeeded (childnames, childflds) ->
case mb_parent of
Nothing
-> return ([(IEThingWith childflds (L l name') wc childnames',
availTC name (name:map unLoc childnames) (map unLoc childflds))],
[])
where name' = replaceWrappedName rdr_tc name
childnames' = map to_ie_post_rn childnames
Just parent
-> return ([(IEThingWith childflds (L l name') wc childnames',
availTC name (map unLoc childnames) (map unLoc childflds)),
(IEThingWith childflds (L l name') wc childnames',
availTC parent [name] [])],
[])
where name' = replaceWrappedName rdr_tc name
childnames' = map to_ie_post_rn childnames
_other -> failLookupWith IllegalImport
where
mkIEThingAbs tc l (n, av, Nothing )
= (IEThingAbs noAnn (L l (replaceWrappedName tc n)), trimAvail av n)
mkIEThingAbs tc l (n, _, Just parent)
= (IEThingAbs noAnn (L l (replaceWrappedName tc n))
, availTC parent [n] [])
handle_bad_import m = catchIELookup m $ \err -> case err of
BadImport ie | want_hiding -> return ([], [BadImportW ie])
_ -> failLookupWith err
type IELookupM = MaybeErr IELookupError
data IELookupWarning
= BadImportW (IE GhcPs)
| MissingImportList
| DodgyImport RdrName
data IELookupError
= QualImportError RdrName
| BadImport (IE GhcPs)
| IllegalImport
| AmbiguousImport RdrName [AvailInfo]
failLookupWith :: IELookupError -> IELookupM a
failLookupWith err = Failed err
catchIELookup :: IELookupM a -> (IELookupError -> IELookupM a) -> IELookupM a
catchIELookup m h = case m of
Succeeded r -> return r
Failed err -> h err
catIELookupM :: [IELookupM a] -> [a]
catIELookupM ms = [ a | Succeeded a <- ms ]
gresFromIE :: ImpDeclSpec -> (LIE GhcRn, AvailInfo) -> [GlobalRdrElt]
gresFromIE decl_spec (L loc ie, avail)
= gresFromAvail prov_fn avail
where
is_explicit = case ie of
IEThingAll _ name -> \n -> n == lieWrappedName name
_ -> \_ -> True
prov_fn name
= Just (ImpSpec { is_decl = decl_spec, is_item = item_spec })
where
item_spec = ImpSome { is_explicit = is_explicit name
, is_iloc = locA loc }
mkChildEnv :: [GlobalRdrElt] -> NameEnv [GlobalRdrElt]
mkChildEnv gres = foldr add emptyNameEnv gres
where
add gre env = case gre_par gre of
ParentIs p -> extendNameEnv_Acc (:) Utils.singleton env p gre
NoParent -> env
findChildren :: NameEnv [a] -> Name -> [a]
findChildren env n = lookupNameEnv env n `orElse` []
lookupChildren :: [GreName] -> [LIEWrappedName RdrName]
-> MaybeErr [LIEWrappedName RdrName]
([LocatedA Name], [Located FieldLabel])
lookupChildren all_kids rdr_items
| null fails
= Succeeded (fmap concat (partitionEithers oks))
| otherwise
= Failed fails
where
mb_xs = map doOne rdr_items
fails = [ bad_rdr | Failed bad_rdr <- mb_xs ]
oks = [ ok | Succeeded ok <- mb_xs ]
oks :: [Either (LocatedA Name) [Located FieldLabel]]
doOne item@(L l r)
= case (lookupFsEnv kid_env . occNameFS . rdrNameOcc . ieWrappedName) r of
Just [NormalGreName n] -> Succeeded (Left (L l n))
Just rs | Just fs <- traverse greNameFieldLabel rs -> Succeeded (Right (map (L (locA l)) fs))
_ -> Failed item
kid_env = extendFsEnvList_C (++) emptyFsEnv
[(occNameFS (occName x), [x]) | x <- all_kids]
reportUnusedNames :: TcGblEnv -> HscSource -> RnM ()
reportUnusedNames gbl_env hsc_src
= do { keep <- readTcRef (tcg_keep gbl_env)
; traceRn "RUN" (ppr (tcg_dus gbl_env))
; warnUnusedImportDecls gbl_env hsc_src
; warnUnusedTopBinds $ unused_locals keep
; warnMissingSignatures gbl_env
; warnMissingKindSignatures gbl_env }
where
used_names :: NameSet -> NameSet
used_names keep = findUses (tcg_dus gbl_env) emptyNameSet `unionNameSet` keep
defined_names :: [GlobalRdrElt]
defined_names = globalRdrEnvElts (tcg_rdr_env gbl_env)
kids_env = mkChildEnv defined_names
gre_is_used :: NameSet -> GlobalRdrElt -> Bool
gre_is_used used_names gre0
= name `elemNameSet` used_names
|| any (\ gre -> greMangledName gre `elemNameSet` used_names) (findChildren kids_env name)
where
name = greMangledName gre0
unused_locals :: NameSet -> [GlobalRdrElt]
unused_locals keep =
let
_defined_and_used, defined_but_not_used :: [GlobalRdrElt]
(_defined_and_used, defined_but_not_used)
= partition (gre_is_used (used_names keep)) defined_names
in filter is_unused_local defined_but_not_used
is_unused_local :: GlobalRdrElt -> Bool
is_unused_local gre = isLocalGRE gre && isExternalName (greMangledName gre)
warnMissingSignatures :: TcGblEnv -> RnM ()
warnMissingSignatures gbl_env
= do { let exports = availsToNameSet (tcg_exports gbl_env)
sig_ns = tcg_sigs gbl_env
binds = collectHsBindsBinders CollNoDictBinders $ tcg_binds gbl_env
pat_syns = tcg_patsyns gbl_env
; warn_missing_sigs <- woptM Opt_WarnMissingSignatures
; warn_only_exported <- woptM Opt_WarnMissingExportedSignatures
; warn_pat_syns <- woptM Opt_WarnMissingPatternSynonymSignatures
; let add_sig_warns
| warn_missing_sigs = add_warns Opt_WarnMissingSignatures
| warn_only_exported = add_warns Opt_WarnMissingExportedSignatures
| warn_pat_syns = add_warns Opt_WarnMissingPatternSynonymSignatures
| otherwise = return ()
add_warns flag
= when (warn_missing_sigs || warn_only_exported)
(mapM_ add_bind_warn binds) >>
when (warn_missing_sigs || warn_pat_syns)
(mapM_ add_pat_syn_warn pat_syns)
where
add_pat_syn_warn p
= add_warn name $
hang (text "Pattern synonym with no type signature:")
2 (text "pattern" <+> pprPrefixName name <+> dcolon <+> pp_ty)
where
name = patSynName p
pp_ty = pprPatSynType p
add_bind_warn :: Id -> IOEnv (Env TcGblEnv TcLclEnv) ()
add_bind_warn id
= do { env <- tcInitTidyEnv
; let name = idName id
(_, ty) = tidyOpenType env (idType id)
ty_msg = pprSigmaType ty
; add_warn name $
hang (text "Top-level binding with no type signature:")
2 (pprPrefixName name <+> dcolon <+> ty_msg) }
add_warn name msg
= when (name `elemNameSet` sig_ns && export_check name)
(addWarnAt (Reason flag) (getSrcSpan name) msg)
export_check name
= warn_missing_sigs || not warn_only_exported || name `elemNameSet` exports
; add_sig_warns }
warnMissingKindSignatures :: TcGblEnv -> RnM ()
warnMissingKindSignatures gbl_env
= do { warn_missing_kind_sigs <- woptM Opt_WarnMissingKindSignatures
; cusks_enabled <- xoptM LangExt.CUSKs
; when (warn_missing_kind_sigs) (mapM_ (add_ty_warn cusks_enabled) tcs)
}
where
tcs = tcg_tcs gbl_env
ksig_ns = tcg_ksigs gbl_env
add_ty_warn :: Bool -> TyCon -> IOEnv (Env TcGblEnv TcLclEnv) ()
add_ty_warn cusks_enabled tyCon = when (name `elemNameSet` ksig_ns) $
addWarnAt (Reason Opt_WarnMissingKindSignatures) (getSrcSpan name) $
hang msg 2 (text "type" <+> pprPrefixName name <+> dcolon <+> ki_msg)
where
msg | cusks_enabled = text "Top-level type constructor with no standalone kind signature or CUSK:"
| otherwise = text "Top-level type constructor with no standalone kind signature:"
name = tyConName tyCon
ki = tyConKind tyCon
ki_msg :: SDoc
ki_msg = pprKind ki
type ImportDeclUsage
= ( LImportDecl GhcRn
, [GlobalRdrElt]
, [Name] )
warnUnusedImportDecls :: TcGblEnv -> HscSource -> RnM ()
warnUnusedImportDecls gbl_env hsc_src
= do { uses <- readMutVar (tcg_used_gres gbl_env)
; let user_imports = filterOut
(ideclImplicit . unLoc)
(tcg_rn_imports gbl_env)
rdr_env = tcg_rdr_env gbl_env
fld_env = mkFieldEnv rdr_env
; let usage :: [ImportDeclUsage]
usage = findImportUsage user_imports uses
; traceRn "warnUnusedImportDecls" $
(vcat [ text "Uses:" <+> ppr uses
, text "Import usage" <+> ppr usage])
; whenWOptM Opt_WarnUnusedImports $
mapM_ (warnUnusedImport Opt_WarnUnusedImports fld_env) usage
; whenGOptM Opt_D_dump_minimal_imports $
printMinimalImports hsc_src usage }
findImportUsage :: [LImportDecl GhcRn]
-> [GlobalRdrElt]
-> [ImportDeclUsage]
findImportUsage imports used_gres
= map unused_decl imports
where
import_usage :: ImportMap
import_usage = mkImportMap used_gres
unused_decl :: LImportDecl GhcRn -> (LImportDecl GhcRn, [GlobalRdrElt], [Name])
unused_decl decl@(L loc (ImportDecl { ideclHiding = imps }))
= (decl, used_gres, nameSetElemsStable unused_imps)
where
used_gres = lookupSrcLoc (srcSpanEnd $ locA loc) import_usage
`orElse` []
used_names = mkNameSet (map greMangledName used_gres)
used_parents = mkNameSet (mapMaybe greParent_maybe used_gres)
unused_imps
= case imps of
Just (False, L _ imp_ies) ->
foldr (add_unused . unLoc) emptyNameSet imp_ies
_other -> emptyNameSet
add_unused :: IE GhcRn -> NameSet -> NameSet
add_unused (IEVar _ n) acc = add_unused_name (lieWrappedName n) acc
add_unused (IEThingAbs _ n) acc = add_unused_name (lieWrappedName n) acc
add_unused (IEThingAll _ n) acc = add_unused_all (lieWrappedName n) acc
add_unused (IEThingWith fs p wc ns) acc =
add_wc_all (add_unused_with pn xs acc)
where pn = lieWrappedName p
xs = map lieWrappedName ns ++ map (flSelector . unLoc) fs
add_wc_all = case wc of
NoIEWildcard -> id
IEWildcard _ -> add_unused_all pn
add_unused _ acc = acc
add_unused_name n acc
| n `elemNameSet` used_names = acc
| otherwise = acc `extendNameSet` n
add_unused_all n acc
| n `elemNameSet` used_names = acc
| n `elemNameSet` used_parents = acc
| otherwise = acc `extendNameSet` n
add_unused_with p ns acc
| all (`elemNameSet` acc1) ns = add_unused_name p acc1
| otherwise = acc1
where
acc1 = foldr add_unused_name acc ns
type ImportMap = Map RealSrcLoc [GlobalRdrElt]
mkImportMap :: [GlobalRdrElt] -> ImportMap
mkImportMap gres
= foldr add_one Map.empty gres
where
add_one gre@(GRE { gre_imp = imp_specs }) imp_map =
case srcSpanEnd (is_dloc (is_decl best_imp_spec)) of
RealSrcLoc decl_loc _ -> Map.insertWith add decl_loc [gre] imp_map
UnhelpfulLoc _ -> imp_map
where
best_imp_spec = bestImport imp_specs
add _ gres = gre : gres
warnUnusedImport :: WarningFlag -> NameEnv (FieldLabelString, Parent)
-> ImportDeclUsage -> RnM ()
warnUnusedImport flag fld_env (L loc decl, used, unused)
| Just (False,L _ []) <- ideclHiding decl
= return ()
| Just (True, L _ hides) <- ideclHiding decl
, not (null hides)
, pRELUDE_NAME == unLoc (ideclName decl)
= return ()
| null used
= addWarnAt (Reason flag) (locA loc) msg1
| null unused
= return ()
| Just (_, L _ imports) <- ideclHiding decl
, length unused == 1
, Just (L loc _) <- find (\(L _ ie) -> ((ieName ie) :: Name) `elem` unused) imports
= addWarnAt (Reason flag) (locA loc) msg2
| otherwise
= addWarnAt (Reason flag) (locA loc) msg2
where
msg1 = vcat [ pp_herald <+> quotes pp_mod <+> is_redundant
, nest 2 (text "except perhaps to import instances from"
<+> quotes pp_mod)
, text "To import instances alone, use:"
<+> text "import" <+> pp_mod <> parens Outputable.empty ]
msg2 = sep [ pp_herald <+> quotes sort_unused
, text "from module" <+> quotes pp_mod <+> is_redundant]
pp_herald = text "The" <+> pp_qual <+> text "import of"
pp_qual
| isImportDeclQualified (ideclQualified decl)= text "qualified"
| otherwise = Outputable.empty
pp_mod = ppr (unLoc (ideclName decl))
is_redundant = text "is redundant"
ppr_possible_field n = case lookupNameEnv fld_env n of
Just (fld, ParentIs p) -> pprNameUnqualified p <> parens (ppr fld)
Just (fld, NoParent) -> ppr fld
Nothing -> pprNameUnqualified n
sort_unused :: SDoc
sort_unused = pprWithCommas ppr_possible_field $
sortBy (comparing nameOccName) unused
getMinimalImports :: [ImportDeclUsage] -> RnM [LImportDecl GhcRn]
getMinimalImports = fmap combine . mapM mk_minimal
where
mk_minimal (L l decl, used_gres, unused)
| null unused
, Just (False, _) <- ideclHiding decl
= return (L l decl)
| otherwise
= do { let ImportDecl { ideclName = L _ mod_name
, ideclSource = is_boot
, ideclPkgQual = mb_pkg } = decl
; iface <- loadSrcInterface doc mod_name is_boot (fmap sl_fs mb_pkg)
; let used_avails = gresToAvailInfo used_gres
lies = map (L l) (concatMap (to_ie iface) used_avails)
; return (L l (decl { ideclHiding = Just (False, L (l2l l) lies) })) }
where
doc = text "Compute minimal imports for" <+> ppr decl
to_ie :: ModIface -> AvailInfo -> [IE GhcRn]
to_ie _ (Avail c)
= [IEVar noExtField (to_ie_post_rn $ noLocA (greNamePrintableName c))]
to_ie _ avail@(AvailTC n [_])
| availExportsDecl avail = [IEThingAbs noAnn (to_ie_post_rn $ noLocA n)]
to_ie iface (AvailTC n cs)
= case [xs | avail@(AvailTC x xs) <- mi_exports iface
, x == n
, availExportsDecl avail
] of
[xs] | all_used xs ->
[IEThingAll noAnn (to_ie_post_rn $ noLocA n)]
| otherwise ->
[IEThingWith (map noLoc fs) (to_ie_post_rn $ noLocA n) NoIEWildcard
(map (to_ie_post_rn . noLocA) (filter (/= n) ns))]
_other | all_non_overloaded fs
-> map (IEVar noExtField . to_ie_post_rn_var . noLocA) $ ns
++ map flSelector fs
| otherwise ->
[IEThingWith (map noLoc fs) (to_ie_post_rn $ noLocA n) NoIEWildcard
(map (to_ie_post_rn . noLocA) (filter (/= n) ns))]
where
(ns, fs) = partitionGreNames cs
all_used avail_cs = all (`elem` cs) avail_cs
all_non_overloaded = all (not . flIsOverloaded)
combine :: [LImportDecl GhcRn] -> [LImportDecl GhcRn]
combine = map merge . groupBy ((==) `on` getKey) . sortOn getKey
getKey :: LImportDecl GhcRn -> (Bool, Maybe ModuleName, ModuleName)
getKey decl =
( isImportDeclQualified . ideclQualified $ idecl
, unLoc <$> ideclAs idecl
, unLoc . ideclName $ idecl
)
where
idecl :: ImportDecl GhcRn
idecl = unLoc decl
merge :: [LImportDecl GhcRn] -> LImportDecl GhcRn
merge [] = error "getMinimalImports: unexpected empty list"
merge decls@((L l decl) : _) = L l (decl { ideclHiding = Just (False, L (noAnnSrcSpan (locA l)) lies) })
where lies = concatMap (unLoc . snd) $ mapMaybe (ideclHiding . unLoc) decls
printMinimalImports :: HscSource -> [ImportDeclUsage] -> RnM ()
printMinimalImports hsc_src imports_w_usage
= do { imports' <- getMinimalImports imports_w_usage
; this_mod <- getModule
; dflags <- getDynFlags
; liftIO $ withFile (mkFilename dflags this_mod) WriteMode $ \h ->
printForUser dflags h neverQualify AllTheWay (vcat (map ppr imports'))
}
where
mkFilename dflags this_mod
| Just d <- dumpDir dflags = d </> basefn
| otherwise = basefn
where
suffix = case hsc_src of
HsBootFile -> ".imports-boot"
HsSrcFile -> ".imports"
HsigFile -> ".imports"
basefn = moduleNameString (moduleName this_mod) ++ suffix
to_ie_post_rn_var :: (HasOccName name) => LocatedA name -> LIEWrappedName name
to_ie_post_rn_var (L l n)
| isDataOcc $ occName n = L l (IEPattern (AR $ la2r l) (L (la2na l) n))
| otherwise = L l (IEName (L (la2na l) n))
to_ie_post_rn :: (HasOccName name) => LocatedA name -> LIEWrappedName name
to_ie_post_rn (L l n)
| isTcOcc occ && isSymOcc occ = L l (IEType (AR $ la2r l) (L (la2na l) n))
| otherwise = L l (IEName (L (la2na l) n))
where occ = occName n
qualImportItemErr :: RdrName -> SDoc
qualImportItemErr rdr
= hang (text "Illegal qualified name in import item:")
2 (ppr rdr)
ambiguousImportItemErr :: RdrName -> [AvailInfo] -> SDoc
ambiguousImportItemErr rdr avails
= hang (text "Ambiguous name" <+> quotes (ppr rdr) <+> text "in import item. It could refer to:")
2 (vcat (map ppr_avail avails))
where
ppr_avail (AvailTC parent _) = ppr parent <> parens (ppr rdr)
ppr_avail (Avail name) = ppr name
pprImpDeclSpec :: ModIface -> ImpDeclSpec -> SDoc
pprImpDeclSpec iface decl_spec =
quotes (ppr (is_mod decl_spec)) <+> case mi_boot iface of
IsBoot -> text "(hi-boot interface)"
NotBoot -> Outputable.empty
badImportItemErrStd :: ModIface -> ImpDeclSpec -> IE GhcPs -> SDoc
badImportItemErrStd iface decl_spec ie
= sep [text "Module", pprImpDeclSpec iface decl_spec,
text "does not export", quotes (ppr ie)]
badImportItemErrDataCon :: OccName -> ModIface -> ImpDeclSpec -> IE GhcPs
-> SDoc
badImportItemErrDataCon dataType_occ iface decl_spec ie
= vcat [ text "In module"
<+> pprImpDeclSpec iface decl_spec
<> colon
, nest 2 $ quotes datacon
<+> text "is a data constructor of"
<+> quotes dataType
, text "To import it use"
, nest 2 $ text "import"
<+> ppr (is_mod decl_spec)
<> parens_sp (dataType <> parens_sp datacon)
, text "or"
, nest 2 $ text "import"
<+> ppr (is_mod decl_spec)
<> parens_sp (dataType <> text "(..)")
]
where
datacon_occ = rdrNameOcc $ ieName ie
datacon = parenSymOcc datacon_occ (ppr datacon_occ)
dataType = parenSymOcc dataType_occ (ppr dataType_occ)
parens_sp d = parens (space <> d <> space)
badImportItemErr :: ModIface -> ImpDeclSpec -> IE GhcPs -> [AvailInfo] -> SDoc
badImportItemErr iface decl_spec ie avails
= case find checkIfDataCon avails of
Just con -> badImportItemErrDataCon (availOccName con) iface decl_spec ie
Nothing -> badImportItemErrStd iface decl_spec ie
where
checkIfDataCon (AvailTC _ ns) =
case find (\n -> importedFS == occNameFS (occName n)) ns of
Just n -> isDataConName (greNameMangledName n)
Nothing -> False
checkIfDataCon _ = False
availOccName = occName . availGreName
importedFS = occNameFS . rdrNameOcc $ ieName ie
illegalImportItemErr :: SDoc
illegalImportItemErr = text "Illegal import item"
dodgyImportWarn :: RdrName -> SDoc
dodgyImportWarn item
= dodgyMsg (text "import") item (dodgyMsgInsert item :: IE GhcPs)
dodgyMsg :: (Outputable a, Outputable b) => SDoc -> a -> b -> SDoc
dodgyMsg kind tc ie
= sep [ text "The" <+> kind <+> ptext (sLit "item")
<+> quotes (ppr ie)
<+> text "suggests that",
quotes (ppr tc) <+> text "has (in-scope) constructors or class methods,",
text "but it has none" ]
dodgyMsgInsert :: forall p . IdP (GhcPass p) -> IE (GhcPass p)
dodgyMsgInsert tc = IEThingAll noAnn ii
where
ii :: LIEWrappedName (IdP (GhcPass p))
ii = noLocA (IEName $ noLocA tc)
addDupDeclErr :: [GlobalRdrElt] -> TcRn ()
addDupDeclErr [] = panic "addDupDeclErr: empty list"
addDupDeclErr gres@(gre : _)
= addErrAt (getSrcSpan (last sorted_names)) $
vcat [text "Multiple declarations of" <+>
quotes (ppr (greOccName gre)),
text "Declared at:" <+>
vcat (map (ppr . nameSrcLoc) sorted_names)]
where
sorted_names =
sortBy (SrcLoc.leftmost_smallest `on` nameSrcSpan)
(map greMangledName gres)
missingImportListWarn :: ModuleName -> SDoc
missingImportListWarn mod
= text "The module" <+> quotes (ppr mod) <+> ptext (sLit "does not have an explicit import list")
missingImportListItem :: IE GhcPs -> SDoc
missingImportListItem ie
= text "The import item" <+> quotes (ppr ie) <+> ptext (sLit "does not have an explicit import list")
moduleWarn :: ModuleName -> WarningTxt -> SDoc
moduleWarn mod (WarningTxt _ txt)
= sep [ text "Module" <+> quotes (ppr mod) <> ptext (sLit ":"),
nest 2 (vcat (map (ppr . sl_fs . unLoc) txt)) ]
moduleWarn mod (DeprecatedTxt _ txt)
= sep [ text "Module" <+> quotes (ppr mod)
<+> text "is deprecated:",
nest 2 (vcat (map (ppr . sl_fs . unLoc) txt)) ]
packageImportErr :: SDoc
packageImportErr
= text "Package-qualified imports are not enabled; use PackageImports"
checkConName :: RdrName -> TcRn ()
checkConName name = checkErr (isRdrDataCon name) (badDataCon name)
badDataCon :: RdrName -> SDoc
badDataCon name
= hsep [text "Illegal data constructor name", quotes (ppr name)]