module RnNames (
rnImports, getLocalNonValBinders,
rnExports, extendGlobalRdrEnvRn,
gresFromAvails,
calculateAvails,
reportUnusedNames,
checkConName
) where
#include "HsVersions.h"
import DynFlags
import HsSyn
import TcEnv ( isBrackStage )
import RnEnv
import RnHsDoc ( rnHsDoc )
import LoadIface ( loadSrcInterface )
import TcRnMonad
import PrelNames
import Module
import Name
import NameEnv
import NameSet
import Avail
import HscTypes
import RdrName
import Outputable
import Maybes
import SrcLoc
import BasicTypes ( TopLevelFlag(..) )
import ErrUtils
import Util
import FastString
import ListSetOps
import Control.Monad
import Data.Map ( Map )
import qualified Data.Map as Map
import Data.List ( partition, (\\), find )
import qualified Data.Set as Set
import System.FilePath ((</>))
import System.IO
rnImports :: [LImportDecl RdrName]
-> RnM ([LImportDecl Name], GlobalRdrEnv, ImportAvails, AnyHpcUsage)
rnImports imports = do
this_mod <- getModule
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 Opt_PackageImports
when (not pkg_imports) $ addErr packageImportErr
let imp_mod_name = unLoc loc_imp_mod_name
doc = ppr imp_mod_name <+> ptext (sLit "is directly imported")
when (not want_boot &&
imp_mod_name == moduleName this_mod &&
(case mb_pkg of
Nothing -> True
Just pkg_fs -> pkg_fs == fsLit "this" ||
fsToPackageKey pkg_fs == modulePackageKey this_mod))
(addErr (ptext (sLit "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 (missingImportListWarn imp_mod_name)
ifaces <- loadSrcInterface doc imp_mod_name want_boot mb_pkg
WARN( not want_boot && any mi_boot ifaces, ppr imp_mod_name ) do
WARN( want_boot && length ifaces /= 1, ppr imp_mod_name ) do
dflags <- getDynFlags
warnIf (want_boot && any (not.mi_boot) ifaces && isOneShot (ghcMode dflags))
(warnRedundantSourceImport imp_mod_name)
when (mod_safe && not (safeImportsOn dflags)) $
addErr (ptext (sLit "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 = 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 ifaces imp_spec imp_details
let gbl_env = mkGlobalRdrEnv (filterOut from_this_mod gres)
from_this_mod gre = nameModule (gre_name gre) == this_mod
import_all = case imp_details of
Just (is_hiding, L _ ls) -> not is_hiding && null ls
_ -> False
mod_safe' = mod_safe
|| (not implicit && safeDirectImpsReq dflags)
|| (implicit && safeImplicitImpsReq dflags)
let imports
= foldr plusImportAvails emptyImportAvails (map
(\iface ->
(calculateAvails dflags iface mod_safe' want_boot) {
imp_mods = unitModuleEnv (mi_module iface)
[(qual_mod_name, import_all, loc, mod_safe')] })
ifaces)
whenWOptM Opt_WarnWarningsDeprecations (
forM_ ifaces $ \iface ->
case mi_warns iface of
WarnAll txt -> addWarn $ 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, any mi_hpc ifaces)
calculateAvails :: DynFlags
-> ModIface
-> IsSafeImport
-> IsBootInterface
-> ImportAvails
calculateAvails dflags iface mod_safe' want_boot =
let imp_mod = mi_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 = ASSERT( not (imp_mod `elem` dep_orphs deps) )
imp_mod : dep_orphs deps
| otherwise = dep_orphs deps
finsts | has_finsts = ASSERT( not (imp_mod `elem` dep_finsts deps) )
imp_mod : dep_finsts deps
| otherwise = dep_finsts deps
pkg = modulePackageKey (mi_module iface)
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 (pkg `elem` (map fst $ dep_pkgs deps))
, ppr pkg <+> ppr (dep_pkgs deps) )
([], (pkg, False) : dep_pkgs deps, False)
in ImportAvails {
imp_mods = emptyModuleEnv,
imp_orphs = orphans,
imp_finsts = finsts,
imp_dep_mods = mkModDeps dependent_mods,
imp_dep_pkgs = map fst $ dependent_pkgs,
imp_trust_pkgs = if mod_safe'
then map fst $ filter snd dependent_pkgs
else [],
imp_trust_own_pkg = pkg_trust_req
}
warnRedundantSourceImport :: ModuleName -> SDoc
warnRedundantSourceImport mod_name
= ptext (sLit "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
rdr_env2 = extendGlobalRdrEnv (isGHCi && not inBracket) rdr_env avails
lcl_env3 = lcl_env2 { tcl_th_bndrs = extendNameEnvList th_bndrs
[ (n, (TopLevel, th_lvl))
| n <- new_names ] }
fix_env' = foldl extend_fix_env fix_env new_names
dups = findLocalDupsRdrEnv rdr_env2 new_names
gbl_env' = gbl_env { tcg_rdr_env = rdr_env2, tcg_fix_env = fix_env' }
; traceRn (text "extendGlobalRdrEnvRn 1" <+> (ppr avails $$ (ppr dups)))
; mapM_ (addDupDeclErr . map gre_name) dups
; traceRn (text "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 name
| Just (L _ fi) <- lookupFsEnv new_fixities (occNameFS occ)
= extendNameEnv fix_env name (FixItem occ fi)
| otherwise
= fix_env
where
occ = nameOccName name
getLocalNonValBinders :: MiniFixityEnv -> HsGroup RdrName
-> RnM ((TcGblEnv, TcLclEnv), NameSet)
getLocalNonValBinders fixity_env
(HsGroup { hs_valds = binds,
hs_tyclds = tycl_decls,
hs_instds = inst_decls,
hs_fords = foreign_decls })
= do {
; tc_avails <- mapM new_tc (tyClGroupConcat tycl_decls)
; traceRn (text "getLocalNonValBinders 1" <+> ppr tc_avails)
; envs <- extendGlobalRdrEnvRn tc_avails fixity_env
; setEnvs envs $ do {
; nti_avails <- concatMapM new_assoc inst_decls
; is_boot <- tcIsHsBootOrSig
; let val_bndrs | is_boot = hs_boot_sig_bndrs
| otherwise = for_hs_bndrs ++ patsyn_hs_bndrs
; val_avails <- mapM new_simple val_bndrs
; let avails = nti_avails ++ val_avails
new_bndrs = availsToNameSet avails `unionNameSet`
availsToNameSet tc_avails
; traceRn (text "getLocalNonValBinders 2" <+> ppr avails)
; envs <- extendGlobalRdrEnvRn avails fixity_env
; return (envs, new_bndrs) } }
where
ValBindsIn val_binds val_sigs = binds
for_hs_bndrs :: [Located RdrName]
for_hs_bndrs = hsForeignDeclsBinders foreign_decls
patsyn_hs_bndrs :: [Located RdrName]
patsyn_hs_bndrs = hsPatSynBinders val_binds
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 tc_decl
= do { let bndrs = hsLTyClDeclBinders tc_decl
; names@(main_name : _) <- mapM newTopSrcBinder bndrs
; return (AvailTC main_name names) }
new_assoc :: LInstDecl RdrName -> RnM [AvailInfo]
new_assoc (L _ (TyFamInstD {})) = return []
new_assoc (L _ (DataFamInstD { dfid_inst = d }))
= do { avail <- new_di Nothing d
; return [avail] }
new_assoc (L _ (ClsInstD { cid_inst = ClsInstDecl
{ cid_poly_ty = inst_ty
, cid_datafam_insts = adts } }))
| Just (_, _, L loc cls_rdr, _) <-
splitLHsInstDeclTy_maybe (flattenTopLevelLHsForAllTy inst_ty)
= do { cls_nm <- setSrcSpan loc $ lookupGlobalOccRn cls_rdr
; mapM (new_di (Just cls_nm) . unLoc) adts }
| otherwise
= return []
new_di :: Maybe Name -> DataFamInstDecl RdrName -> RnM AvailInfo
new_di mb_cls ti_decl
= do { main_name <- lookupFamInstName mb_cls (dfid_tycon ti_decl)
; sub_names <- mapM newTopSrcBinder (hsDataFamInstBinders ti_decl)
; return (AvailTC (unLoc main_name) sub_names) }
filterImports
:: [ModIface]
-> ImpDeclSpec
-> Maybe (Bool, Located [LIE RdrName])
-> RnM (Maybe (Bool, Located [LIE Name]),
[GlobalRdrElt])
filterImports iface decl_spec Nothing
= return (Nothing, gresFromAvails prov (concatMap mi_exports iface))
where
prov = Imported [ImpSpec { is_decl = decl_spec, is_item = ImpAll }]
filterImports ifaces 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_prov = Imported [ImpSpec { is_decl = decl_spec, is_item = ImpAll }]
gres | want_hiding = gresFromAvails hiding_prov pruned_avails
| otherwise = concatMap (gresFromIE decl_spec) items2
return (Just (want_hiding, L l (map fst items2)), gres)
where
all_avails = concatMap mi_exports ifaces
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)
= ASSERT( name1 == name2 && isNothing mp1 && isNothing 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 (dodgyImportWarn n)
emit_warning MissingImportList = whenWOptM Opt_WarnMissingImportList $
addWarn (missingImportListItem ieRdr)
emit_warning BadImportW = whenWOptM Opt_WarnDodgyImports $
addWarn (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 (any mi_boot ifaces) 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 n
return ([(IEVar (L l name), trimAvail avail name)], [])
IEThingAll (L l tc) -> do
(name, avail@(AvailTC name2 subs), mb_parent) <- lookup_name tc
let warns | null (drop 1 subs) = [DodgyImport tc]
| not (is_qual decl_spec) = [MissingImportList]
| otherwise = []
case mb_parent of
Nothing -> return ([(IEThingAll (L l name), avail)], warns)
Just parent -> return ([(IEThingAll (L l name),
AvailTC name2 (subs \\ [name])),
(IEThingAll (L l name),
AvailTC parent [name])],
warns)
IEThingAbs (L l tc)
| want_hiding
-> let 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 l name | name <- names], [])
| otherwise
-> do nameAvail <- lookup_name tc
return ([mkIEThingAbs l nameAvail], [])
IEThingWith (L l rdr_tc) rdr_ns -> do
(name, AvailTC _ ns, mb_parent) <- lookup_name rdr_tc
let subnames = case ns of
[] -> []
(n1:ns1) | n1 == name -> ns1
| otherwise -> ns
mb_children = lookupChildren subnames rdr_ns
children <- if any isNothing mb_children
then failLookupWith BadImport
else return (catMaybes mb_children)
case mb_parent of
Nothing -> return ([(IEThingWith (L l name) children,
AvailTC name (name:map unLoc children))],
[])
Just parent -> return ([(IEThingWith (L l name) children,
AvailTC name (map unLoc children)),
(IEThingWith (L l name) children,
AvailTC parent [name])],
[])
_other -> failLookupWith IllegalImport
where
mkIEThingAbs l (n, av, Nothing ) = (IEThingAbs (L l n),
trimAvail av n)
mkIEThingAbs l (n, _, Just parent) = (IEThingAbs (L l 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 ]
greExportAvail :: GlobalRdrElt -> AvailInfo
greExportAvail gre
= case gre_par gre of
ParentIs p -> AvailTC p [me]
NoParent | isTyConName me -> AvailTC me [me]
| otherwise -> Avail me
where
me = gre_name gre
plusAvail :: AvailInfo -> AvailInfo -> AvailInfo
plusAvail a1 a2
| debugIsOn && availName a1 /= availName a2
= pprPanic "RnEnv.plusAvail names differ" (hsep [ppr a1,ppr a2])
plusAvail a1@(Avail {}) (Avail {}) = a1
plusAvail (AvailTC _ []) a2@(AvailTC {}) = a2
plusAvail a1@(AvailTC {}) (AvailTC _ []) = a1
plusAvail (AvailTC n1 (s1:ss1)) (AvailTC n2 (s2:ss2))
= case (n1==s1, n2==s2) of
(True,True) -> AvailTC n1 (s1 : (ss1 `unionLists` ss2))
(True,False) -> AvailTC n1 (s1 : (ss1 `unionLists` (s2:ss2)))
(False,True) -> AvailTC n1 (s2 : ((s1:ss1) `unionLists` ss2))
(False,False) -> AvailTC n1 ((s1:ss1) `unionLists` (s2:ss2))
plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2])
trimAvail :: AvailInfo -> Name -> AvailInfo
trimAvail (Avail n) _ = Avail n
trimAvail (AvailTC n ns) m = ASSERT( m `elem` ns) AvailTC n [m]
filterAvails :: (Name -> Bool) -> [AvailInfo] -> [AvailInfo]
filterAvails keep avails = foldr (filterAvail keep) [] avails
filterAvail :: (Name -> Bool) -> AvailInfo -> [AvailInfo] -> [AvailInfo]
filterAvail keep ie rest =
case ie of
Avail n | keep n -> ie : rest
| otherwise -> rest
AvailTC tc ns ->
let left = filter keep ns in
if null left then rest else AvailTC tc left : rest
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 == name
_ -> \_ -> True
prov_fn name = Imported [imp_spec]
where
imp_spec = ImpSpec { is_decl = decl_spec, is_item = item_spec }
item_spec = ImpSome { is_explicit = is_explicit name, is_iloc = loc }
mkChildEnv :: [GlobalRdrElt] -> NameEnv [Name]
mkChildEnv gres = foldr add emptyNameEnv gres
where
add (GRE { gre_name = n, gre_par = ParentIs p }) env = extendNameEnv_Acc (:) singleton env p n
add _ env = env
findChildren :: NameEnv [Name] -> Name -> [Name]
findChildren env n = lookupNameEnv env n `orElse` []
lookupChildren :: [Name] -> [Located RdrName] -> [Maybe (Located Name)]
lookupChildren all_kids rdr_items
= map doOne rdr_items
where
doOne (L l r) = case (lookupFsEnv kid_env . occNameFS . rdrNameOcc) r of
Just n -> Just (L l n)
Nothing -> Nothing
kid_env = mkFsEnv [(occNameFS (nameOccName n), n) | n <- all_kids]
nubAvails :: [AvailInfo] -> [AvailInfo]
nubAvails avails = nameEnvElts (foldl add emptyNameEnv avails)
where
add env avail = extendNameEnv_C plusAvail env (availName avail) avail
type ExportAccum
= ([LIE Name],
ExportOccMap,
[AvailInfo])
emptyExportAccum :: ExportAccum
emptyExportAccum = ([], emptyOccEnv, [])
type ExportOccMap = OccEnv (Name, IE RdrName)
rnExports :: Bool
-> Maybe (Located [LIE RdrName])
-> TcGblEnv
-> RnM TcGblEnv
rnExports explicit_mod exports
tcg_env@(TcGblEnv { tcg_mod = this_mod,
tcg_rdr_env = rdr_env,
tcg_imports = imports })
= unsetWOptM Opt_WarnWarningsDeprecations $
do {
; dflags <- getDynFlags
; let real_exports
| explicit_mod = exports
| ghcLink dflags == LinkInMemory = Nothing
| otherwise
= Just (noLoc [noLoc (IEVar (noLoc main_RDR_Unqual))])
; (rn_exports, avails) <- exports_from_avail real_exports rdr_env imports this_mod
; let final_avails = nubAvails avails
; traceRn (text "rnExports: Exports:" <+> ppr final_avails)
; return (tcg_env { tcg_exports = final_avails,
tcg_rn_exports = case tcg_rn_exports tcg_env of
Nothing -> Nothing
Just _ -> rn_exports,
tcg_dus = tcg_dus tcg_env `plusDU`
usesOnly (availsToNameSet final_avails) }) }
exports_from_avail :: Maybe (Located [LIE RdrName])
-> GlobalRdrEnv
-> ImportAvails
-> Module
-> RnM (Maybe [LIE Name], [AvailInfo])
exports_from_avail Nothing rdr_env _imports _this_mod
=
let
avails = [ greExportAvail gre
| gre <- globalRdrEnvElts rdr_env
, isLocalGRE gre ]
in
return (Nothing, avails)
exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
= do (ie_names, _, exports) <- foldlM do_litem emptyExportAccum rdr_items
return (Just ie_names, exports)
where
do_litem :: ExportAccum -> LIE RdrName -> RnM ExportAccum
do_litem acc lie = setSrcSpan (getLoc lie) (exports_from_item acc lie)
kids_env :: NameEnv [Name]
kids_env = mkChildEnv (globalRdrEnvElts rdr_env)
imported_modules = [ qual_name
| xs <- moduleEnvElts $ imp_mods imports,
(qual_name, _, _, _) <- xs ]
exports_from_item :: ExportAccum -> LIE RdrName -> RnM ExportAccum
exports_from_item acc@(ie_names, occs, exports)
(L loc (IEModuleContents (L lm mod)))
| let earlier_mods = [ mod
| (L _ (IEModuleContents (L _ mod))) <- ie_names ]
, mod `elem` earlier_mods
= do { warn_dup_exports <- woptM Opt_WarnDuplicateExports ;
warnIf warn_dup_exports (dupModuleExport mod) ;
return acc }
| otherwise
= do { implicit_prelude <- xoptM Opt_ImplicitPrelude
; warnDodgyExports <- woptM Opt_WarnDodgyExports
; let { exportValid = (mod `elem` imported_modules)
|| (moduleName this_mod == mod)
; gres = filter (isModuleExported implicit_prelude mod)
(globalRdrEnvElts rdr_env)
; new_exports = map greExportAvail gres
; names = map gre_name gres }
; checkErr exportValid (moduleNotImported mod)
; warnIf (warnDodgyExports && exportValid && null names)
(nullModuleExport mod)
; addUsedRdrNames (concat [ [mkRdrQual mod occ, mkRdrUnqual occ]
| occ <- map nameOccName names ])
; occs' <- check_occs (IEModuleContents (noLoc mod)) occs names
; traceRn (vcat [ text "export mod" <+> ppr mod
, ppr new_exports ])
; return (L loc (IEModuleContents (L lm mod)) : ie_names,
occs', new_exports ++ exports) }
exports_from_item acc@(lie_names, occs, exports) (L loc ie)
| isDoc ie
= do new_ie <- lookup_doc_ie ie
return (L loc new_ie : lie_names, occs, exports)
| otherwise
= do (new_ie, avail) <- lookup_ie ie
if isUnboundName (ieName new_ie)
then return acc
else do
occs' <- check_occs ie occs (availNames avail)
return (L loc new_ie : lie_names, occs', avail : exports)
lookup_ie :: IE RdrName -> RnM (IE Name, AvailInfo)
lookup_ie (IEVar (L l rdr))
= do gre <- lookupGreRn rdr
return (IEVar (L l (gre_name gre)), greExportAvail gre)
lookup_ie (IEThingAbs (L l rdr))
= do gre <- lookupGreRn rdr
let name = gre_name gre
avail = greExportAvail gre
return (IEThingAbs (L l name), avail)
lookup_ie ie@(IEThingAll (L l rdr))
= do name <- lookupGlobalOccRn rdr
let kids = findChildren kids_env name
addUsedKids rdr kids
warnDodgyExports <- woptM Opt_WarnDodgyExports
when (null kids) $
if isTyConName name
then when warnDodgyExports $ addWarn (dodgyExportWarn name)
else
addErr (exportItemErr ie)
return (IEThingAll (L l name), AvailTC name (name:kids))
lookup_ie ie@(IEThingWith (L l rdr) sub_rdrs)
= do name <- lookupGlobalOccRn rdr
if isUnboundName name
then return (IEThingWith (L l name) [], AvailTC name [name])
else do
let mb_names = lookupChildren (findChildren kids_env name) sub_rdrs
if any isNothing mb_names
then do addErr (exportItemErr ie)
return (IEThingWith (L l name) [], AvailTC name [name])
else do let names = catMaybes mb_names
addUsedKids rdr (map unLoc names)
return (IEThingWith (L l name) names
, AvailTC name (name:map unLoc names))
lookup_ie _ = panic "lookup_ie"
lookup_doc_ie :: IE RdrName -> RnM (IE Name)
lookup_doc_ie (IEGroup lev doc) = do rn_doc <- rnHsDoc doc
return (IEGroup lev rn_doc)
lookup_doc_ie (IEDoc doc) = do rn_doc <- rnHsDoc doc
return (IEDoc rn_doc)
lookup_doc_ie (IEDocNamed str) = return (IEDocNamed str)
lookup_doc_ie _ = panic "lookup_doc_ie"
addUsedKids parent_rdr kid_names
= addUsedRdrNames $ map (mk_kid_rdr . nameOccName) kid_names
where
mk_kid_rdr = case isQual_maybe parent_rdr of
Nothing -> mkRdrUnqual
Just (modName, _) -> mkRdrQual modName
isDoc :: IE RdrName -> Bool
isDoc (IEDoc _) = True
isDoc (IEDocNamed _) = True
isDoc (IEGroup _ _) = True
isDoc _ = False
isModuleExported :: Bool -> ModuleName -> GlobalRdrElt -> Bool
isModuleExported implicit_prelude mod (GRE { gre_name = name, gre_prov = prov })
| implicit_prelude && isBuiltInSyntax name = False
| otherwise
= case prov of
LocalDef | Just name_mod <- nameModule_maybe name
-> moduleName name_mod == mod
| otherwise -> False
Imported is -> any unQualSpecOK is && any (qualSpecOK mod) is
check_occs :: IE RdrName -> ExportOccMap -> [Name] -> RnM ExportOccMap
check_occs ie occs names
= foldlM check occs names
where
check occs name
= case lookupOccEnv occs name_occ of
Nothing -> return (extendOccEnv occs name_occ (name, ie))
Just (name', ie')
| name == name'
-> do unless (dupExport_ok name ie ie') $ do
warn_dup_exports <- woptM Opt_WarnDuplicateExports
warnIf warn_dup_exports (dupExportWarn name_occ ie ie')
return occs
| otherwise
-> do { global_env <- getGlobalRdrEnv ;
addErr (exportClashErr global_env name' name ie' ie) ;
return occs }
where
name_occ = nameOccName name
dupExport_ok :: Name -> IE RdrName -> IE RdrName -> Bool
dupExport_ok n ie1 ie2
= not ( single ie1 || single ie2
|| (explicit_in ie1 && explicit_in ie2) )
where
explicit_in (IEModuleContents _) = False
explicit_in (IEThingAll r) = nameOccName n == rdrNameOcc (unLoc r)
explicit_in _ = True
single (IEVar {}) = True
single (IEThingAbs {}) = True
single _ = False
reportUnusedNames :: Maybe (Located [LIE RdrName])
-> TcGblEnv -> RnM ()
reportUnusedNames _export_decls gbl_env
= do { traceRn ((text "RUN") <+> (ppr (tcg_dus gbl_env)))
; warnUnusedImportDecls gbl_env
; warnUnusedTopBinds unused_locals }
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 (`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_rdrnames gbl_env)
; let user_imports = filterOut (ideclImplicit . unLoc) (tcg_rn_imports gbl_env)
rdr_env = tcg_rdr_env gbl_env
; let usage :: [ImportDeclUsage]
usage = findImportUsage user_imports rdr_env (Set.elems uses)
; traceRn (vcat [ ptext (sLit "Uses:") <+> ppr (Set.elems uses)
, ptext (sLit "Import usage") <+> ppr usage])
; whenWOptM Opt_WarnUnusedImports $
mapM_ warnUnusedImport usage
; whenGOptM Opt_D_dump_minimal_imports $
printMinimalImports usage }
type ImportMap = Map SrcLoc [AvailInfo]
findImportUsage :: [LImportDecl Name]
-> GlobalRdrEnv
-> [RdrName]
-> [ImportDeclUsage]
findImportUsage imports rdr_env rdrs
= map unused_decl imports
where
import_usage :: ImportMap
import_usage = foldr (extendImportMap rdr_env) Map.empty rdrs
unused_decl decl@(L loc (ImportDecl { ideclHiding = imps }))
= (decl, nubAvails used_avails, nameSetElems unused_imps)
where
used_avails = Map.lookup (srcSpanEnd loc) import_usage `orElse` []
used_names = availsToNameSet 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 n acc
add_unused (IEThingAbs (L _ n)) acc = add_unused_name n acc
add_unused (IEThingAll (L _ n)) acc = add_unused_all n acc
add_unused (IEThingWith (L _ p) ns) acc
= add_unused_with p (map unLoc ns) acc
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 :: GlobalRdrEnv -> RdrName -> ImportMap -> ImportMap
extendImportMap rdr_env rdr imp_map
| [gre] <- lookupGRE_RdrName rdr rdr_env
, Imported imps <- gre_prov gre
= add_imp gre (bestImport imps) imp_map
| otherwise
= 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 = greExportAvail gre
bestImport :: [ImportSpec] -> ImportSpec
bestImport iss
= case partition isImpAll iss of
([], imp_somes) -> textuallyFirst imp_somes
(imp_alls, _) -> textuallyFirst imp_alls
textuallyFirst :: [ImportSpec] -> ImportSpec
textuallyFirst iss = case sortWith (is_dloc . is_decl) iss of
[] -> pprPanic "textuallyFirst" (ppr iss)
(is:_) -> is
isImpAll :: ImportSpec -> Bool
isImpAll (ImpSpec { is_item = ImpAll }) = True
isImpAll _other = False
warnUnusedImport :: ImportDeclUsage -> RnM ()
warnUnusedImport (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 loc msg1
| null unused = return ()
| otherwise = addWarnAt loc msg2
where
msg1 = vcat [pp_herald <+> quotes pp_mod <+> pp_not_used,
nest 2 (ptext (sLit "except perhaps to import instances from")
<+> quotes pp_mod),
ptext (sLit "To import instances alone, use:")
<+> ptext (sLit "import") <+> pp_mod <> parens Outputable.empty ]
msg2 = sep [pp_herald <+> quotes (pprWithCommas ppr 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"
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
; ifaces <- loadSrcInterface doc mod_name is_boot mb_pkg
; let lies = map (L l) (concatMap (to_ie ifaces) 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 (noLoc n)]
to_ie _ (AvailTC n [m])
| n==m = [IEThingAbs (noLoc n)]
to_ie ifaces (AvailTC n ns)
= case [xs | iface <- ifaces
, AvailTC x xs <- mi_exports iface
, x == n
, x `elem` xs
] of
[xs] | all_used xs -> [IEThingAll (noLoc n)]
| otherwise -> [IEThingWith (noLoc n)
(map noLoc (filter (/= n) ns))]
_other -> map (IEVar . noLoc) ns
where
all_used avail_occs = all (`elem` ns) avail_occs
qualImportItemErr :: RdrName -> SDoc
qualImportItemErr rdr
= hang (ptext (sLit "Illegal qualified name in import item:"))
2 (ppr rdr)
badImportItemErrStd :: IsBootInterface -> ImpDeclSpec -> IE RdrName -> SDoc
badImportItemErrStd is_boot decl_spec ie
= sep [ptext (sLit "Module"), quotes (ppr (is_mod decl_spec)), source_import,
ptext (sLit "does not export"), quotes (ppr ie)]
where
source_import | is_boot = ptext (sLit "(hi-boot interface)")
| otherwise = Outputable.empty
badImportItemErrDataCon :: OccName
-> IsBootInterface
-> ImpDeclSpec
-> IE RdrName
-> SDoc
badImportItemErrDataCon dataType_occ is_boot decl_spec ie
= vcat [ ptext (sLit "In module")
<+> quotes (ppr (is_mod decl_spec))
<+> source_import <> colon
, nest 2 $ quotes datacon
<+> ptext (sLit "is a data constructor of")
<+> quotes dataType
, ptext (sLit "To import it use")
, nest 2 $ quotes (ptext (sLit "import"))
<+> ppr (is_mod decl_spec)
<> parens_sp (dataType <> parens_sp datacon)
, ptext (sLit "or")
, nest 2 $ quotes (ptext (sLit "import"))
<+> ppr (is_mod decl_spec)
<> parens_sp (dataType <> ptext (sLit "(..)"))
]
where
datacon_occ = rdrNameOcc $ ieName ie
datacon = parenSymOcc datacon_occ (ppr datacon_occ)
dataType = parenSymOcc dataType_occ (ppr dataType_occ)
source_import | is_boot = ptext (sLit "(hi-boot interface)")
| otherwise = Outputable.empty
parens_sp d = parens (space <> d <> space)
badImportItemErr :: IsBootInterface
-> ImpDeclSpec
-> IE RdrName
-> [AvailInfo]
-> SDoc
badImportItemErr is_boot decl_spec ie avails
= case find checkIfDataCon avails of
Just con -> badImportItemErrDataCon (availOccName con) is_boot decl_spec ie
Nothing -> badImportItemErrStd is_boot 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 = ptext (sLit "Illegal import item")
dodgyImportWarn :: RdrName -> SDoc
dodgyImportWarn item = dodgyMsg (ptext (sLit "import")) item
dodgyExportWarn :: Name -> SDoc
dodgyExportWarn item = dodgyMsg (ptext (sLit "export")) item
dodgyMsg :: (OutputableBndr n, HasOccName n) => SDoc -> n -> SDoc
dodgyMsg kind tc
= sep [ ptext (sLit "The") <+> kind <+> ptext (sLit "item")
<+> quotes (ppr (IEThingAll (noLoc tc)))
<+> ptext (sLit "suggests that"),
quotes (ppr tc) <+> ptext (sLit "has (in-scope) constructors or class methods,"),
ptext (sLit "but it has none") ]
exportItemErr :: IE RdrName -> SDoc
exportItemErr export_item
= sep [ ptext (sLit "The export item") <+> quotes (ppr export_item),
ptext (sLit "attempts to export constructors or class methods that are not visible here") ]
exportClashErr :: GlobalRdrEnv -> Name -> Name -> IE RdrName -> IE RdrName
-> MsgDoc
exportClashErr global_env name1 name2 ie1 ie2
= vcat [ ptext (sLit "Conflicting exports for") <+> quotes (ppr occ) <> colon
, ppr_export ie1' name1'
, ppr_export ie2' name2' ]
where
occ = nameOccName name1
ppr_export ie name = nest 3 (hang (quotes (ppr ie) <+> ptext (sLit "exports") <+>
quotes (ppr name))
2 (pprNameProvenance (get_gre name)))
get_gre name
= case lookupGRE_Name global_env name of
(gre:_) -> gre
[] -> pprPanic "exportClashErr" (ppr name)
get_loc name = greSrcSpan (get_gre name)
(name1', ie1', name2', ie2') = if get_loc name1 < get_loc name2
then (name1, ie1, name2, ie2)
else (name2, ie2, name1, ie1)
greSrcSpan :: GlobalRdrElt -> SrcSpan
greSrcSpan gre
| Imported (is:_) <- gre_prov gre = is_dloc (is_decl is)
| otherwise = name_span
where
name_span = nameSrcSpan (gre_name gre)
addDupDeclErr :: [Name] -> TcRn ()
addDupDeclErr []
= panic "addDupDeclErr: empty list"
addDupDeclErr names@(name : _)
= addErrAt (getSrcSpan (last sorted_names)) $
vcat [ptext (sLit "Multiple declarations of") <+>
quotes (ppr (nameOccName name)),
ptext (sLit "Declared at:") <+>
vcat (map (ppr . nameSrcLoc) sorted_names)]
where
sorted_names = sortWith nameSrcLoc names
dupExportWarn :: OccName -> IE RdrName -> IE RdrName -> SDoc
dupExportWarn occ_name ie1 ie2
= hsep [quotes (ppr occ_name),
ptext (sLit "is exported by"), quotes (ppr ie1),
ptext (sLit "and"), quotes (ppr ie2)]
dupModuleExport :: ModuleName -> SDoc
dupModuleExport mod
= hsep [ptext (sLit "Duplicate"),
quotes (ptext (sLit "Module") <+> ppr mod),
ptext (sLit "in export list")]
moduleNotImported :: ModuleName -> SDoc
moduleNotImported mod
= ptext (sLit "The export item `module") <+> ppr mod <>
ptext (sLit "' is not imported")
nullModuleExport :: ModuleName -> SDoc
nullModuleExport mod
= ptext (sLit "The export item `module") <+> ppr mod <> ptext (sLit "' exports nothing")
missingImportListWarn :: ModuleName -> SDoc
missingImportListWarn mod
= ptext (sLit "The module") <+> quotes (ppr mod) <+> ptext (sLit "does not have an explicit import list")
missingImportListItem :: IE RdrName -> SDoc
missingImportListItem ie
= ptext (sLit "The import item") <+> quotes (ppr ie) <+> ptext (sLit "does not have an explicit import list")
moduleWarn :: ModuleName -> WarningTxt -> SDoc
moduleWarn mod (WarningTxt _ txt)
= sep [ ptext (sLit "Module") <+> quotes (ppr mod) <> ptext (sLit ":"),
nest 2 (vcat (map ppr txt)) ]
moduleWarn mod (DeprecatedTxt _ txt)
= sep [ ptext (sLit "Module") <+> quotes (ppr mod)
<+> ptext (sLit "is deprecated:"),
nest 2 (vcat (map ppr txt)) ]
packageImportErr :: SDoc
packageImportErr
= ptext (sLit "Package-qualified imports are not enabled; use PackageImports")
checkConName :: RdrName -> TcRn ()
checkConName name = checkErr (isRdrDataCon name) (badDataCon name)
badDataCon :: RdrName -> SDoc
badDataCon name
= hsep [ptext (sLit "Illegal data constructor name"), quotes (ppr name)]