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