{-# LANGUAGE CPP, NondecreasingIndentation, MultiWayIf, NamedFieldPuns #-}
module RnNames (
rnImports, getLocalNonValBinders, newRecordSelector,
extendGlobalRdrEnvRn,
gresFromAvails,
calculateAvails,
reportUnusedNames,
checkConName,
mkChildEnv,
findChildren,
dodgyMsg
) where
#include "HsVersions.h"
import DynFlags
import HsSyn
import TcEnv
import RnEnv
import LoadIface ( loadSrcInterface )
import TcRnMonad
import PrelNames
import Module
import Name
import NameEnv
import NameSet
import Avail
import FieldLabel
import HscTypes
import RdrName
import RdrHsSyn ( setRdrNameSpace )
import Outputable
import Maybes
import SrcLoc
import BasicTypes ( TopLevelFlag(..), StringLiteral(..) )
import Util
import FastString
import FastStringEnv
import Id
import Type
import PatSyn
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
import Data.Either ( partitionEithers, isRight, rights )
import Data.Map ( Map )
import qualified Data.Map as Map
import Data.Ord ( comparing )
import Data.List ( partition, (\\), find, sortBy )
import qualified Data.Set as S
import System.FilePath ((</>))
import System.IO
rnImports :: [LImportDecl RdrName]
-> RnM ([LImportDecl Name], 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)
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 Name, GlobalRdrEnv, ImportAvails, AnyHpcUsage)]
-> ([LImportDecl Name], GlobalRdrEnv, ImportAvails, AnyHpcUsage)
combine = foldr plus ([], emptyGlobalRdrEnv, emptyImportAvails, False)
plus (decl, gbl_env1, imp_avails1,hpc_usage1)
(decls, gbl_env2, imp_avails2,hpc_usage2)
= ( decl:decls,
gbl_env1 `plusGlobalRdrEnv` gbl_env2,
imp_avails1 `plusImportAvails` imp_avails2,
hpc_usage1 || hpc_usage2 )
rnImportDecl :: Module -> LImportDecl RdrName
-> RnM (LImportDecl Name, 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_only, ideclImplicit = implicit
, ideclAs = as_mod, ideclHiding = imp_details }))
= setSrcSpan loc $ do
when (isJust mb_pkg) $ do
pkg_imports <- xoptM LangExt.PackageImports
when (not pkg_imports) $ addErr packageImportErr
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" ||
fsToUnitId pkg_fs == moduleUnitId 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( not want_boot && mi_boot iface, ppr imp_mod_name ) do
dflags <- getDynFlags
warnIf NoReason
(want_boot && not (mi_boot iface) && 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 = 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)
let imv = ImportedModsVal
{ imv_name = qual_mod_name
, imv_span = loc
, imv_is_safe = mod_safe'
, imv_is_hiding = is_hiding
, imv_all_exports = potential_gres
, imv_qualified = qual_only
}
imports = calculateAvails dflags 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 ()
)
let new_imp_decl = L loc (decl { ideclSafe = mod_safe'
, ideclHiding = new_imp_details })
return (new_imp_decl, gbl_env, imports, mi_hpc iface)
calculateAvails :: DynFlags
-> ModIface
-> IsSafeImport
-> IsBootInterface
-> ImportedBy
-> ImportAvails
calculateAvails dflags iface mod_safe' want_boot imported_by =
let imp_mod = mi_module iface
imp_sem_mod= mi_semantic_module iface
orph_iface = mi_orphan iface
has_finsts = mi_finsts 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 = moduleUnitId (mi_module iface)
ipkg = toInstalledUnitId pkg
ptrust = trust == Sf_Trustworthy || trust_pkg
(dependent_mods, dependent_pkgs, pkg_trust_req)
| pkg == thisPackage dflags =
((moduleName imp_mod,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
}
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
[ (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 availNames avails
new_occs = map nameOccName 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 = gre_name 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
name = gre_name gre
occ = nameOccName name
dups = filter isLocalGRE (lookupGlobalRdrEnv env occ)
getLocalNonValBinders :: MiniFixityEnv -> HsGroup RdrName
-> 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
; overload_ok <- xoptM LangExt.DuplicateRecordFields
; (tc_avails, tc_fldss)
<- fmap unzip $ mapM (new_tc overload_ok)
(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 overload_ok)
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
ValBindsIn _val_binds val_sigs = binds
for_hs_bndrs :: [Located RdrName]
for_hs_bndrs = hsForeignDeclsBinders foreign_decls
hs_boot_sig_bndrs = [ L decl_loc (unLoc n)
| L decl_loc (TypeSig ns _) <- val_sigs, n <- ns]
new_simple :: Located RdrName -> RnM AvailInfo
new_simple rdr_name = do{ nm <- newTopSrcBinder rdr_name
; return (avail nm) }
new_tc :: Bool -> LTyClDecl RdrName
-> RnM (AvailInfo, [(Name, [FieldLabel])])
new_tc overload_ok tc_decl
= do { let (bndrs, flds) = hsLTyClDeclBinders tc_decl
; names@(main_name : sub_names) <- mapM newTopSrcBinder bndrs
; flds' <- mapM (newRecordSelector overload_ok 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 RdrName -> [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_details = RecCon cdflds }))
= [( find_con_name rdr
, concatMap find_con_decl_flds (unLoc cdflds) )]
find_con_flds (L _ (ConDeclGADT
{ con_names = rdrs
, con_type = (HsIB { hsib_body = res_ty})}))
= map (\ (L _ rdr) -> ( find_con_name rdr
, concatMap find_con_decl_flds cdflds))
rdrs
where
(_tvs, _cxt, tau) = splitLHsSigmaTy res_ty
cdflds = case tau of
L _ (HsFunTy
(L _ (HsAppsTy
[L _ (HsAppPrefix (L _ (HsRecTy flds)))])) _) -> flds
L _ (HsFunTy (L _ (HsRecTy flds)) _) -> flds
_ -> []
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 :: Bool -> LInstDecl RdrName
-> RnM ([AvailInfo], [(Name, [FieldLabel])])
new_assoc _ (L _ (TyFamInstD {})) = return ([], [])
new_assoc overload_ok (L _ (DataFamInstD d))
= do { (avail, flds) <- new_di overload_ok Nothing d
; return ([avail], flds) }
new_assoc overload_ok (L _ (ClsInstD (ClsInstDecl { cid_poly_ty = inst_ty
, cid_datafam_insts = adts })))
| Just (L loc cls_rdr) <- getLHsInstDeclClass_maybe inst_ty
= do { cls_nm <- setSrcSpan loc $ lookupGlobalOccRn cls_rdr
; (avails, fldss)
<- mapAndUnzipM (new_loc_di overload_ok (Just cls_nm)) adts
; return (avails, concat fldss) }
| otherwise
= return ([], [])
new_di :: Bool -> Maybe Name -> DataFamInstDecl RdrName
-> RnM (AvailInfo, [(Name, [FieldLabel])])
new_di overload_ok mb_cls ti_decl
= do { main_name <- lookupFamInstName mb_cls (dfid_tycon ti_decl)
; let (bndrs, flds) = hsDataFamInstBinders ti_decl
; sub_names <- mapM newTopSrcBinder bndrs
; flds' <- mapM (newRecordSelector overload_ok sub_names) flds
; let avail = AvailTC (unLoc main_name) sub_names flds'
fld_env = mk_fld_env (dfid_defn ti_decl) sub_names flds'
; return (avail, fld_env) }
new_loc_di :: Bool -> Maybe Name -> LDataFamInstDecl RdrName
-> RnM (AvailInfo, [(Name, [FieldLabel])])
new_loc_di overload_ok mb_cls (L _ d) = new_di overload_ok mb_cls d
newRecordSelector :: Bool -> [Name] -> LFieldOcc RdrName -> RnM FieldLabel
newRecordSelector _ [] _ = error "newRecordSelector: datatype has no constructors!"
newRecordSelector overload_ok (dc:_) (L loc (FieldOcc (L _ fld) _))
= do { selName <- newTopSrcBinder $ L loc $ field
; return $ qualFieldLbl { flSelector = selName } }
where
fieldOccName = occNameFS $ rdrNameOcc fld
qualFieldLbl = mkFieldLabelOccs fieldOccName (nameOccName dc) overload_ok
field | isExact fld = fld
| otherwise = mkRdrUnqual (flSelector qualFieldLbl)
filterImports
:: ModIface
-> ImpDeclSpec
-> Maybe (Bool, Located [LIE RdrName])
-> RnM (Maybe (Bool, Located [LIE Name]),
[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 Name, AvailInfo)]
items2 = concat items1
names = availsToNameSet (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 (Name,
AvailInfo,
Maybe Name)
imp_occ_env = mkOccEnv_C combine [ (nameOccName n, (n, a, Nothing))
| a <- all_avails, n <- availNames a]
where
combine (name1, a1@(AvailTC p1 _ _), mp1)
(name2, a2@(AvailTC p2 _ _), mp2)
= ASSERT2( name1 == name2 && isNothing mp1 && isNothing mp2
, ppr name1 <+> ppr name2 <+> ppr mp1 <+> ppr mp2 )
if p1 == name1 then (name1, a1, Just p2)
else (name1, a2, Just p1)
combine x y = pprPanic "filterImports/combine" (ppr x $$ ppr y)
lookup_name :: RdrName -> IELookupM (Name, AvailInfo, Maybe Name)
lookup_name rdr | isQual rdr = failLookupWith (QualImportError rdr)
| Just succ <- mb_success = return succ
| otherwise = failLookupWith BadImport
where
mb_success = lookupOccEnv imp_occ_env (rdrNameOcc rdr)
lookup_lie :: LIE RdrName -> TcRn [(LIE Name, AvailInfo)]
lookup_lie (L loc ieRdr)
= do (stuff, warns) <- setSrcSpan 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 = whenWOptM Opt_WarnDodgyImports $
addWarn (Reason Opt_WarnDodgyImports) (lookup_err_msg BadImport)
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 -> badImportItemErr iface decl_spec ieRdr all_avails
IllegalImport -> illegalImportItemErr
QualImportError rdr -> qualImportItemErr rdr
lookup_ie :: IE RdrName -> IELookupM ([(IE Name, AvailInfo)], [IELookupWarning])
lookup_ie ie = handle_bad_import $ do
case ie of
IEVar (L l n) -> do
(name, avail, _) <- lookup_name $ ieWrappedName n
return ([(IEVar (L l (replaceWrappedName n name)),
trimAvail avail name)], [])
IEThingAll (L l tc) -> do
(name, avail, mb_parent) <- lookup_name $ ieWrappedName tc
let warns = case avail of
Avail {}
-> [DodgyImport $ ieWrappedName tc]
AvailTC _ subs fs
| null (drop 1 subs) && null fs
-> [DodgyImport $ ieWrappedName tc]
| not (is_qual decl_spec)
-> [MissingImportList]
| otherwise
-> []
renamed_ie = IEThingAll (L l (replaceWrappedName tc name))
sub_avails = case avail of
Avail {} -> []
AvailTC name2 subs fs -> [(renamed_ie, AvailTC name2 (subs \\ [name]) fs)]
case mb_parent of
Nothing -> return ([(renamed_ie, avail)], warns)
Just parent -> return ((renamed_ie, AvailTC parent [name] []) : sub_avails, warns)
IEThingAbs (L l tc')
| want_hiding
-> let tc = ieWrappedName tc'
tc_name = lookup_name tc
dc_name = lookup_name (setRdrNameSpace tc srcDataName)
in
case catIELookupM [ tc_name, dc_name ] of
[] -> failLookupWith BadImport
names -> return ([mkIEThingAbs tc' l name | name <- names], [])
| otherwise
-> do nameAvail <- lookup_name (ieWrappedName tc')
return ([mkIEThingAbs tc' l nameAvail]
, [])
IEThingWith (L l rdr_tc) wc rdr_ns' rdr_fs ->
ASSERT2(null rdr_fs, ppr rdr_fs) do
(name, AvailTC _ ns subflds, mb_parent)
<- lookup_name (ieWrappedName rdr_tc)
let subnames = case ns of
[] -> []
(n1:ns1) | n1 == name -> ns1
| otherwise -> ns
rdr_ns = map ieLWrappedName rdr_ns'
case lookupChildren (map Left subnames ++ map Right subflds) rdr_ns of
Nothing -> failLookupWith BadImport
Just (childnames, childflds) ->
case mb_parent of
Nothing
-> return ([(IEThingWith (L l name') wc childnames'
childflds,
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 (L l name') wc childnames'
childflds,
AvailTC name (map unLoc childnames) (map unLoc childflds)),
(IEThingWith (L l name') wc childnames'
childflds,
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 (L l (replaceWrappedName tc n)), trimAvail av n)
mkIEThingAbs tc l (n, _, Just parent)
= (IEThingAbs (L l (replaceWrappedName tc n)), AvailTC parent [n] [])
handle_bad_import m = catchIELookup m $ \err -> case err of
BadImport | want_hiding -> return ([], [BadImportW])
_ -> failLookupWith err
type IELookupM = MaybeErr IELookupError
data IELookupWarning
= BadImportW
| MissingImportList
| DodgyImport RdrName
data IELookupError
= QualImportError RdrName
| BadImport
| IllegalImport
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 Name, AvailInfo) -> [GlobalRdrElt]
gresFromIE decl_spec (L loc ie, avail)
= gresFromAvail prov_fn avail
where
is_explicit = case ie of
IEThingAll (L _ name) -> \n -> n == ieWrappedName 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 = loc }
mkChildEnv :: [GlobalRdrElt] -> NameEnv [GlobalRdrElt]
mkChildEnv gres = foldr add emptyNameEnv gres
where
add gre env = case gre_par gre of
FldParent p _ -> extendNameEnv_Acc (:) singleton env p gre
ParentIs p -> extendNameEnv_Acc (:) singleton env p gre
NoParent -> env
findChildren :: NameEnv [a] -> Name -> [a]
findChildren env n = lookupNameEnv env n `orElse` []
lookupChildren :: [Either Name FieldLabel] -> [Located RdrName]
-> Maybe ([Located Name], [Located FieldLabel])
lookupChildren all_kids rdr_items
= do xs <- mapM doOne rdr_items
return (fmap concat (partitionEithers xs))
where
doOne (L l r) = case (lookupFsEnv kid_env . occNameFS . rdrNameOcc) r of
Just [Left n] -> Just (Left (L l n))
Just rs | all isRight rs -> Just (Right (map (L l) (rights rs)))
_ -> Nothing
kid_env = extendFsEnvList_C (++) emptyFsEnv
[(either (occNameFS . nameOccName) flLabel x, [x]) | x <- all_kids]
reportUnusedNames :: Maybe (Located [LIE RdrName])
-> TcGblEnv -> RnM ()
reportUnusedNames _export_decls gbl_env
= do { traceRn "RUN" (ppr (tcg_dus gbl_env))
; warnUnusedImportDecls gbl_env
; warnUnusedTopBinds unused_locals
; warnMissingSignatures gbl_env }
where
used_names :: NameSet
used_names = findUses (tcg_dus gbl_env) emptyNameSet
defined_names :: [GlobalRdrElt]
defined_names = globalRdrEnvElts (tcg_rdr_env gbl_env)
_defined_and_used, defined_but_not_used :: [GlobalRdrElt]
(_defined_and_used, defined_but_not_used)
= partition (gre_is_used used_names) defined_names
kids_env = mkChildEnv defined_names
gre_is_used :: NameSet -> GlobalRdrElt -> Bool
gre_is_used used_names (GRE {gre_name = name})
= name `elemNameSet` used_names
|| any (\ gre -> gre_name gre `elemNameSet` used_names) (findChildren kids_env name)
unused_locals :: [GlobalRdrElt]
unused_locals = filter is_unused_local defined_but_not_used
is_unused_local :: GlobalRdrElt -> Bool
is_unused_local gre = isLocalGRE gre && isExternalName (gre_name gre)
type ImportDeclUsage
= ( LImportDecl Name
, [AvailInfo]
, [Name] )
warnUnusedImportDecls :: TcGblEnv -> RnM ()
warnUnusedImportDecls gbl_env
= 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 usage }
warnMissingSignatures :: TcGblEnv -> RnM ()
warnMissingSignatures gbl_env
= do { let exports = availsToNameSet (tcg_exports gbl_env)
sig_ns = tcg_sigs gbl_env
binds = collectHsBindsBinders $ 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_only_exported = add_warns Opt_WarnMissingExportedSignatures
| warn_missing_sigs = add_warns Opt_WarnMissingSignatures
| warn_pat_syns = add_warns Opt_WarnMissingPatternSynonymSignatures
| otherwise = return ()
add_warns flag
= when warn_pat_syns
(mapM_ add_pat_syn_warn pat_syns) >>
when (warn_missing_sigs || warn_only_exported)
(mapM_ add_bind_warn binds)
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
= 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
= not warn_only_exported || name `elemNameSet` exports
; add_sig_warns }
type ImportMap = Map SrcLoc [AvailInfo]
findImportUsage :: [LImportDecl Name]
-> [GlobalRdrElt]
-> [ImportDeclUsage]
findImportUsage imports used_gres
= map unused_decl imports
where
import_usage :: ImportMap
import_usage
= foldr extendImportMap Map.empty used_gres
unused_decl decl@(L loc (ImportDecl { ideclHiding = imps }))
= (decl, nubAvails used_avails, nameSetElemsStable unused_imps)
where
used_avails = Map.lookup (srcSpanEnd loc) import_usage `orElse` []
used_names = availsToNameSetWithSelectors used_avails
used_parents = mkNameSet [n | AvailTC n _ _ <- used_avails]
unused_imps
= case imps of
Just (False, L _ imp_ies) ->
foldr (add_unused . unLoc) emptyNameSet imp_ies
_other -> emptyNameSet
add_unused :: IE Name -> NameSet -> NameSet
add_unused (IEVar (L _ n)) acc
= add_unused_name (ieWrappedName n) acc
add_unused (IEThingAbs (L _ n)) acc
= add_unused_name (ieWrappedName n) acc
add_unused (IEThingAll (L _ n)) acc
= add_unused_all (ieWrappedName n) acc
add_unused (IEThingWith (L _ p) wc ns fs) acc =
add_wc_all (add_unused_with (ieWrappedName p) xs acc)
where xs = map (ieWrappedName . unLoc) ns
++ map (flSelector . unLoc) fs
add_wc_all = case wc of
NoIEWildcard -> id
IEWildcard _ -> add_unused_all (ieWrappedName p)
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
extendImportMap :: GlobalRdrElt -> ImportMap -> ImportMap
extendImportMap gre imp_map
= add_imp gre (bestImport (gre_imp gre)) imp_map
where
add_imp :: GlobalRdrElt -> ImportSpec -> ImportMap -> ImportMap
add_imp gre (ImpSpec { is_decl = imp_decl_spec }) imp_map
= Map.insertWith add decl_loc [avail] imp_map
where
add _ avails = avail : avails
decl_loc = srcSpanEnd (is_dloc imp_decl_spec)
avail = availFromGRE gre
warnUnusedImport :: WarningFlag -> NameEnv (FieldLabelString, Name)
-> 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) loc msg1
| null unused = return ()
| otherwise = addWarnAt (Reason flag) loc msg2
where
msg1 = vcat [pp_herald <+> quotes pp_mod <+> pp_not_used,
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 <+> pp_not_used]
pp_herald = text "The" <+> pp_qual <+> text "import of"
pp_qual
| ideclQualified decl = text "qualified"
| otherwise = Outputable.empty
pp_mod = ppr (unLoc (ideclName decl))
pp_not_used = text "is redundant"
ppr_possible_field n = case lookupNameEnv fld_env n of
Just (fld, p) -> ppr p <> parens (ppr fld)
Nothing -> ppr n
sort_unused = pprWithCommas ppr_possible_field $
sortBy (comparing nameOccName) unused
printMinimalImports :: [ImportDeclUsage] -> RnM ()
printMinimalImports imports_w_usage
= do { imports' <- mapM mk_minimal imports_w_usage
; this_mod <- getModule
; dflags <- getDynFlags
; liftIO $
do { h <- openFile (mkFilename dflags this_mod) WriteMode
; printForUser dflags h neverQualify (vcat (map ppr imports')) }
}
where
mkFilename dflags this_mod
| Just d <- dumpDir dflags = d </> basefn
| otherwise = basefn
where
basefn = moduleNameString (moduleName this_mod) ++ ".imports"
mk_minimal (L l decl, used, 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 lies = map (L l) (concatMap (to_ie iface) used)
; return (L l (decl { ideclHiding = Just (False, L l lies) })) }
where
doc = text "Compute minimal imports for" <+> ppr decl
to_ie :: ModIface -> AvailInfo -> [IE Name]
to_ie _ (Avail n)
= [IEVar (to_ie_post_rn $ noLoc n)]
to_ie _ (AvailTC n [m] [])
| n==m = [IEThingAbs (to_ie_post_rn $ noLoc n)]
to_ie iface (AvailTC n ns fs)
= case [(xs,gs) | AvailTC x xs gs <- mi_exports iface
, x == n
, x `elem` xs
] of
[xs] | all_used xs -> [IEThingAll (to_ie_post_rn $ noLoc n)]
| otherwise ->
[IEThingWith (to_ie_post_rn $ noLoc n) NoIEWildcard
(map (to_ie_post_rn . noLoc) (filter (/= n) ns))
(map noLoc fs)]
_other | all_non_overloaded fs
-> map (IEVar . to_ie_post_rn_var . noLoc) $ ns
++ map flSelector fs
| otherwise ->
[IEThingWith (to_ie_post_rn $ noLoc n) NoIEWildcard
(map (to_ie_post_rn . noLoc) (filter (/= n) ns))
(map noLoc fs)]
where
fld_lbls = map flLabel fs
all_used (avail_occs, avail_flds)
= all (`elem` ns) avail_occs
&& all (`elem` fld_lbls) (map flLabel avail_flds)
all_non_overloaded = all (not . flIsOverloaded)
to_ie_post_rn_var :: (HasOccName name) => Located name -> LIEWrappedName name
to_ie_post_rn_var (L l n)
| isDataOcc $ occName n = L l (IEPattern (L l n))
| otherwise = L l (IEName (L l n))
to_ie_post_rn :: (HasOccName name) => Located name -> LIEWrappedName name
to_ie_post_rn (L l n)
| isTcOcc occ && isSymOcc occ = L l (IEType (L l n))
| otherwise = L l (IEName (L l n))
where occ = occName n
qualImportItemErr :: RdrName -> SDoc
qualImportItemErr rdr
= hang (text "Illegal qualified name in import item:")
2 (ppr rdr)
badImportItemErrStd :: ModIface -> ImpDeclSpec -> IE RdrName -> SDoc
badImportItemErrStd iface decl_spec ie
= sep [text "Module", quotes (ppr (is_mod decl_spec)), source_import,
text "does not export", quotes (ppr ie)]
where
source_import | mi_boot iface = text "(hi-boot interface)"
| otherwise = Outputable.empty
badImportItemErrDataCon :: OccName -> ModIface -> ImpDeclSpec -> IE RdrName -> SDoc
badImportItemErrDataCon dataType_occ iface decl_spec ie
= vcat [ text "In module"
<+> quotes (ppr (is_mod decl_spec))
<+> source_import <> 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)
source_import | mi_boot iface = text "(hi-boot interface)"
| otherwise = Outputable.empty
parens_sp d = parens (space <> d <> space)
badImportItemErr :: ModIface -> ImpDeclSpec -> IE RdrName -> [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 == nameOccNameFS n) ns of
Just n -> isDataConName n
Nothing -> False
checkIfDataCon _ = False
availOccName = nameOccName . availName
nameOccNameFS = occNameFS . nameOccName
importedFS = occNameFS . rdrNameOcc $ ieName ie
illegalImportItemErr :: SDoc
illegalImportItemErr = text "Illegal import item"
dodgyImportWarn :: RdrName -> SDoc
dodgyImportWarn item = dodgyMsg (text "import") item
dodgyMsg :: (OutputableBndr n, HasOccName n) => SDoc -> n -> SDoc
dodgyMsg kind tc
= sep [ text "The" <+> kind <+> ptext (sLit "item")
<+> quotes (ppr (IEThingAll (noLoc (IEName $ noLoc tc))))
<+> text "suggests that",
quotes (ppr tc) <+> text "has (in-scope) constructors or class methods,",
text "but it has none" ]
addDupDeclErr :: [GlobalRdrElt] -> TcRn ()
addDupDeclErr [] = panic "addDupDeclErr: empty list"
addDupDeclErr gres@(gre : _)
= addErrAt (getSrcSpan (last sorted_names)) $
vcat [text "Multiple declarations of" <+>
quotes (ppr (nameOccName name)),
text "Declared at:" <+>
vcat (map (ppr . nameSrcLoc) sorted_names)]
where
name = gre_name gre
sorted_names = sortWith nameSrcLoc (map gre_name gres)
missingImportListWarn :: ModuleName -> SDoc
missingImportListWarn mod
= text "The module" <+> quotes (ppr mod) <+> ptext (sLit "does not have an explicit import list")
missingImportListItem :: IE RdrName -> 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)]