extractHsTyNames, extractHsCtxtTyNames
)
-import CmdLineOpts ( opt_HiMap, opt_D_dump_rn_trace, opt_D_dump_minimal_imports,
- opt_D_dump_rn, opt_D_dump_rn_stats, opt_WarnDeprecations,
- opt_WarnUnusedBinds
- )
+import CmdLineOpts ( DynFlags, DynFlag(..) )
import RnMonad
+import Finder ( Finder )
import RnNames ( getGlobalNames )
import RnSource ( rnSourceDecls, rnDecl )
-import RnIfaces ( getImportedInstDecls, importDecl, mkImportExportInfo, getInterfaceExports,
- getImportedRules, loadHomeInterface, getSlurped, removeContext,
+import RnIfaces ( getImportedInstDecls, importDecl, mkImportExportInfo,
+ getInterfaceExports,
+ getImportedRules, getSlurped, removeContext,
loadBuiltinRules, getDeferredDecls, ImportDeclResult(..)
)
-import RnEnv ( availName, availsToNameSet, unitAvailEnv, availEnvElts, plusAvailEnv,
+import RnEnv ( availName, availsToNameSet,
+ emptyAvailEnv, unitAvailEnv, availEnvElts, plusAvailEnv,
warnUnusedImports, warnUnusedLocalBinds, warnUnusedModules,
- lookupImplicitOccsRn, pprAvail, unknownNameErr,
+ lookupOrigNames, unknownNameErr,
FreeVars, plusFVs, plusFV, unitFV, emptyFVs, isEmptyFVs, addOneFV
)
import Module ( Module, ModuleName, WhereFrom(..),
- moduleNameUserString, mkSearchPath, moduleName, mkThisModule
+ moduleNameUserString, moduleName, mkModuleInThisPackage
)
import Name ( Name, isLocallyDefined, NamedThing(..), getSrcLoc,
- nameOccName, nameUnique, nameModule, maybeUserImportedFrom,
- isUserImportedExplicitlyName, isUserImportedName,
- maybeWiredInTyConName, maybeWiredInIdName, isWiredInName,
- isUserExportedName, toRdrName
+ nameOccName, nameUnique, nameModule,
+-- maybeUserImportedFrom,
+-- isUserImportedExplicitlyName, isUserImportedName,
+-- maybeWiredInTyConName, maybeWiredInIdName,
+ isUserExportedName, toRdrName,
+ nameEnvElts, extendNameEnv
)
import OccName ( occNameFlavour, isValOcc )
import Id ( idType )
import NameSet
import TysWiredIn ( unitTyCon, intTyCon, doubleTyCon, boolTyCon )
import PrelRules ( builtinRules )
-import PrelInfo ( mAIN_Name, pREL_MAIN_Name, pRELUDE_Name,
- ioTyCon_RDR, unpackCString_RDR, unpackCString2_RDR, unpackCStringFoldr_RDR,
- fractionalClassKeys, derivingOccurrences
+import PrelNames ( mAIN_Name, pREL_MAIN_Name, pRELUDE_Name,
+ ioTyCon_RDR,
+ unpackCString_RDR, unpackCStringFoldr_RDR, unpackCStringUtf8_RDR,
+ eqString_RDR
)
+import PrelInfo ( fractionalClassKeys, derivingOccurrences,
+ maybeWiredInTyConName, maybeWiredInIdName )
import Type ( namesOfType, funTyCon )
import ErrUtils ( printErrorsAndWarnings, dumpIfSet, ghcExit )
import BasicTypes ( Version, initialVersion )
import Bag ( isEmptyBag, bagToList )
-import FiniteMap ( FiniteMap, eltsFM, fmToList, emptyFM, lookupFM, addToFM_C )
+import FiniteMap ( FiniteMap, eltsFM, fmToList, emptyFM, lookupFM,
+ addToFM_C, elemFM, addToFM
+ )
import UniqSupply ( UniqSupply )
import UniqFM ( lookupUFM )
import SrcLoc ( noSrcLoc )
import Maybes ( maybeToBool, expectJust )
import Outputable
import IO ( openFile, IOMode(..) )
+import HscTypes ( PersistentCompilerState, HomeSymbolTable, GlobalRdrEnv,
+ AvailEnv, Avails, GenAvailInfo(..), AvailInfo,
+ Provenance(..), ImportReason(..) )
+
+-- HACKS:
+maybeUserImportedFrom = panic "maybeUserImportedFrom"
+isUserImportedExplicitlyName = panic "isUserImportedExplicitlyName"
+isUserImportedName = panic "isUserImportedName"
+iDeprecs = panic "iDeprecs"
+type FixityEnv = LocalFixityEnv
\end{code}
\begin{code}
-type RenameResult = ( Module -- This module
+type RenameResult = ( PersistentCompilerState
+ , Module -- This module
, RenamedHsModule -- Renamed module
, Maybe ParsedIface -- The existing interface file, if any
, ParsedIface -- The new interface
- , RnNameSupply -- Final env; for renaming derivings
- , FixityEnv -- The fixity environment; for derivings
- , [ModuleName]) -- Imported modules; for profiling
+ , [Module]) -- Imported modules
-renameModule :: UniqSupply -> RdrNameHsModule -> IO (Maybe RenameResult)
-renameModule us this_mod@(HsModule mod_name vers exports imports local_decls _ loc)
+renameModule :: DynFlags -> Finder
+ -> PersistentCompilerState -> HomeSymbolTable
+ -> RdrNameHsModule -> IO (Maybe RenameResult)
+renameModule dflags finder old_pcs hst
+ this_mod@(HsModule mod_name vers exports imports local_decls _ loc)
= -- Initialise the renamer monad
do {
- ((maybe_rn_stuff, dump_action), rn_errs_bag, rn_warns_bag)
- <- initRn mod_name us (mkSearchPath opt_HiMap) loc (rename this_mod) ;
+ ((maybe_rn_stuff, dump_action), (rn_warns_bag, rn_errs_bag), new_pcs)
+ <- initRn dflags finder old_pcs hst loc (rename this_mod) ;
-- Check for warnings
- printErrorsAndWarnings rn_errs_bag rn_warns_bag ;
+ printErrorsAndWarnings (rn_warns_bag, rn_errs_bag) ;
-- Dump any debugging output
dump_action ;
-- Return results
if not (isEmptyBag rn_errs_bag) then
- do { ghcExit 1 ; return Nothing }
+ return (old_pcs, Nothing)
else
- return maybe_rn_stuff
+ return (new_pcs, maybe_rn_stuff)
}
\end{code}
mkImportExportInfo mod_name export_avails exports `thenRn` \ (my_exports, my_usages) ->
-- RETURN THE RENAMED MODULE
- getNameSupplyRn `thenRn` \ name_supply ->
+ getNameSupplyRn `thenRn` \ name_supply ->
+ getIfacesRn `thenRn` \ ifaces ->
let
- this_module = mkThisModule mod_name
- direct_import_mods = [mod | ImportDecl mod _ _ _ _ _ <- imports]
+ direct_import_mods :: [Module]
+ direct_import_mods = [m | (_, _, Just (m, _, _, _, imp, _))
+ <- eltsFM (iImpModInfo ifaces), user_import imp]
+
+ -- *don't* just pick the forward edges. It's entirely possible
+ -- that a module is only reachable via back edges.
+ user_import ImportByUser = True
+ user_import ImportByUserSource = True
+ user_import _ = False
+
+ this_module = mkModuleInThisPackage mod_name
-- Export only those fixities that are for names that are
-- (a) defined in this module
-- REPORT UNUSED NAMES, AND DEBUG DUMP
reportUnusedNames mod_name direct_import_mods
gbl_env global_avail_env
- export_avails source_fvs `thenRn_`
+ export_avails source_fvs
+ rn_imp_decls `thenRn_`
returnRn (Just result, dump_action) }
where
\begin{code}
implicitFVs mod_name decls
- = lookupImplicitOccsRn implicit_occs `thenRn` \ implicit_names ->
+ = lookupOrigNames implicit_occs `thenRn` \ implicit_names ->
returnRn (mkNameSet (map getName default_tycons) `plusFV`
implicit_names)
where
implicit_occs = string_occs ++ foldr ((++) . get) implicit_main decls
-- Virtually every program has error messages in it somewhere
- string_occs = [unpackCString_RDR, unpackCString2_RDR, unpackCStringFoldr_RDR]
+ string_occs = [unpackCString_RDR, unpackCStringFoldr_RDR, unpackCStringUtf8_RDR,
+ eqString_RDR]
- get (TyClD (TyData _ _ _ _ _ _ (Just deriv_classes) _ _))
+ get (TyClD (TyData _ _ _ _ _ _ (Just deriv_classes) _ _ _ _))
= concat (map get_deriv deriv_classes)
get other = []
check (HsVar v) = not (isLocallyDefined v)
check (HsApp f a) = check f && check a
check (HsLit _) = False
+ check (HsOverLit _) = False
check (OpApp l o _ r) = check l && check o && check r
check (NegApp e _) = check e
check (HsPar e) = check e
ASSERT( isEmptyFVs fvs )
returnRn decls1
-stripDecl (mod, TyClD (TyData dt _ tc tvs _ nconstrs _ _ loc))
- = (mod, TyClD (TyData dt [] tc tvs [] nconstrs Nothing NoDataPragmas loc))
+stripDecl (mod, TyClD (TyData dt _ tc tvs _ nconstrs _ _ loc name1 name2))
+ = (mod, TyClD (TyData dt [] tc tvs [] nconstrs Nothing NoDataPragmas loc
+ name1 name2))
-- Nuke the context and constructors
-- But retain the *number* of constructors!
-- Also the tvs will have kinds on them.
getGates source_fvs (SigD (IfaceSig _ ty _ _))
= extractHsTyNames ty
-getGates source_fvs (TyClD (ClassDecl ctxt cls tvs _ sigs _ _ _ _ _ _ _))
+getGates source_fvs (TyClD (ClassDecl ctxt cls tvs _ sigs _ _ _ _ ))
= (delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs)
- (map getTyVarName tvs)
+ (hsTyVarNames tvs)
`addOneToNameSet` cls)
`plusFV` maybe_double
where
- get (ClassOpSig n _ _ ty _)
+ get (ClassOpSig n _ ty _)
| n `elemNameSet` source_fvs = extractHsTyNames ty
| otherwise = emptyFVs
getGates source_fvs (TyClD (TySynonym tycon tvs ty _))
= delListFromNameSet (extractHsTyNames ty)
- (map getTyVarName tvs)
+ (hsTyVarNames tvs)
-- A type synonym type constructor isn't a "gate" for instance decls
-getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _ _))
+getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _ _ _ _))
= delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons)
- (map getTyVarName tvs)
+ (hsTyVarNames tvs)
`addOneToNameSet` tycon
where
get (ConDecl n _ tvs ctxt details _)
-- If the constructor is method, get fvs from all its fields
= delListFromNameSet (get_details details `plusFV`
extractHsCtxtTyNames ctxt)
- (map getTyVarName tvs)
+ (hsTyVarNames tvs)
get (ConDecl n _ tvs ctxt (RecCon fields) _)
-- Even if the constructor isn't mentioned, the fields
-- might be, as selectors. They can't mention existentially
get_details (VanillaCon tys) = plusFVs (map get_bang tys)
get_details (InfixCon t1 t2) = get_bang t1 `plusFV` get_bang t2
get_details (RecCon fields) = plusFVs [get_bang t | (_, t) <- fields]
- get_details (NewCon t _) = extractHsTyNames t
get_field (fs,t) | any (`elemNameSet` source_fvs) fs = get_bang t
| otherwise = emptyFVs
- get_bang (Banged t) = extractHsTyNames t
- get_bang (Unbanged t) = extractHsTyNames t
- get_bang (Unpacked t) = extractHsTyNames t
+ get_bang bty = extractHsTyNames (getBangType bty)
getGates source_fvs other_decl = emptyFVs
\end{code}
\begin{code}
fixitiesFromLocalDecls :: GlobalRdrEnv -> [RdrNameHsDecl] -> RnMG FixityEnv
fixitiesFromLocalDecls gbl_env decls
- = foldlRn getFixities emptyNameEnv decls `thenRn` \ env ->
- traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts env))) `thenRn_`
+ = doptRn Opt_WarnUnusedBinds `thenRn` \ warn_unused ->
+ foldlRn (getFixities warn_unused) emptyNameEnv decls `thenRn` \ env ->
+ traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts env)))
+ `thenRn_`
returnRn env
where
- getFixities :: FixityEnv -> RdrNameHsDecl -> RnMG FixityEnv
- getFixities acc (FixD fix)
- = fix_decl acc fix
+ getFixities :: Bool -> FixityEnv -> RdrNameHsDecl -> RnMG FixityEnv
+ getFixities warn_uu acc (FixD fix)
+ = fix_decl warn_uu acc fix
- getFixities acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ _ _ _ _))
- = foldlRn fix_decl acc [sig | FixSig sig <- sigs]
+ getFixities warn_uu acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ _ ))
+ = foldlRn (fix_decl warn_uu) acc [sig | FixSig sig <- sigs]
-- Get fixities from class decl sigs too.
- getFixities acc other_decl
+ getFixities warn_uu acc other_decl
= returnRn acc
- fix_decl acc sig@(FixitySig rdr_name fixity loc)
+ fix_decl warn_uu acc sig@(FixitySig rdr_name fixity loc)
= -- Check for fixity decl for something not declared
case lookupRdrEnv gbl_env rdr_name of {
- Nothing | opt_WarnUnusedBinds
+ Nothing | warn_uu
-> pushSrcLocRn loc (addWarnRn (unusedFixityDecl rdr_name fixity))
`thenRn_` returnRn acc
| otherwise -> returnRn acc ;
- Just (name:_) ->
+ Just ((name,_):_) ->
-- Check for duplicate fixity decl
case lookupNameEnv acc name of {
Just (FixitySig _ _ loc') -> addErrRn (dupFixityDecl rdr_name loc loc')
`thenRn_` returnRn acc ;
- Nothing -> returnRn (addToNameEnv acc name (FixitySig name fixity loc))
+ Nothing -> returnRn (extendNameEnv acc name (FixitySig name fixity loc))
}}
\end{code}
%*********************************************************
\begin{code}
-reportUnusedNames :: ModuleName -> [ModuleName]
+reportUnusedNames :: ModuleName -> [Module]
-> GlobalRdrEnv -> AvailEnv
- -> Avails -> NameSet -> RnMG ()
+ -> Avails -> NameSet -> [RenamedHsDecl]
+ -> RnMG ()
reportUnusedNames mod_name direct_import_mods
gbl_env avail_env
export_avails mentioned_names
+ imported_decls
= let
used_names = mentioned_names `unionNameSets` availsToNameSet export_avails
= case lookupNameEnv avail_env sub_name of
Just avail -> avail
Nothing -> WARN( isUserImportedName sub_name,
- text "reportUnusedName: not in avail_env" <+> ppr sub_name )
+ text "reportUnusedName: not in avail_env" <+>
+ ppr sub_name )
Avail sub_name
, case parent_avail of { AvailTC _ _ -> True; other -> False }
]
- defined_names = mkNameSet (concat (rdrEnvElts gbl_env))
- defined_but_not_used =
- nameSetToList (defined_names `minusNameSet` really_used_names)
+ defined_names, defined_but_not_used :: [(Name,Provenance)]
+ defined_names = concat (rdrEnvElts gbl_env)
+ defined_but_not_used = filter not_used defined_names
+ not_used name = not (name `elemNameSet` really_used_names)
-- Filter out the ones only defined implicitly
- bad_locals = [n | n <- defined_but_not_used, isLocallyDefined n]
- bad_imp_names = [n | n <- defined_but_not_used, isUserImportedExplicitlyName n,
- not (module_unused n)]
+ bad_locals :: [Name]
+ bad_locals = [n | (n,LocalDef) <- defined_but_not_used]
+
+ bad_imp_names :: [(Name,Provenance)]
+ bad_imp_names = [(n,p) | (n,p@(UserImport mod _ True)) <- defined_but_not_used,
+ not (module_unused mod)]
deprec_used deprec_env = [ (n,txt)
| n <- nameSetToList mentioned_names,
not (isLocallyDefined n),
Just txt <- [lookupNameEnv deprec_env n] ]
- minimal_imports :: FiniteMap ModuleName AvailEnv
- minimal_imports = foldNameSet add emptyFM really_used_names
- add n acc = case maybeUserImportedFrom n of
- Nothing -> acc
- Just m -> addToFM_C plusAvailEnv acc (moduleName m)
- (unitAvailEnv (mk_avail n))
+ -- inst_mods are directly-imported modules that
+ -- contain instance decl(s) that the renamer decided to suck in
+ -- It's not necessarily redundant to import such modules.
+ --
+ -- NOTE: Consider
+ -- module This
+ -- import M ()
+ --
+ -- The import M() is not *necessarily* redundant, even if
+ -- we suck in no instance decls from M (e.g. it contains
+ -- no instance decls, or This contains no code). It may be
+ -- that we import M solely to ensure that M's orphan instance
+ -- decls (or those in its imports) are visible to people who
+ -- import This. Sigh.
+ -- There's really no good way to detect this, so the error message
+ -- in RnEnv.warnUnusedModules is weakened instead
+ inst_mods = [m | InstD (InstDecl _ _ _ (Just dfun) _) <- imported_decls,
+ let m = nameModule dfun,
+ m `elem` direct_import_mods
+ ]
+
+ minimal_imports :: FiniteMap Module AvailEnv
+ minimal_imports0 = emptyFM
+ minimal_imports1 = foldNameSet add_name minimal_imports0 really_used_names
+ minimal_imports = foldr add_inst_mod minimal_imports1 inst_mods
+
+ add_name n acc = case maybeUserImportedFrom n of
+ Nothing -> acc
+ Just m -> addToFM_C plusAvailEnv acc m
+ (unitAvailEnv (mk_avail n))
+ add_inst_mod m acc
+ | m `elemFM` acc = acc -- We import something already
+ | otherwise = addToFM acc m emptyAvailEnv
+ -- Add an empty collection of imports for a module
+ -- from which we have sucked only instance decls
+
mk_avail n = case lookupNameEnv avail_env n of
Just (AvailTC m _) | n==m -> AvailTC n [n]
| otherwise -> AvailTC m [n,m]
-- unused_imp_mods are the directly-imported modules
-- that are not mentioned in minimal_imports
- unused_imp_mods = [m | m <- direct_import_mods,
- not (maybeToBool (lookupFM minimal_imports m))]
-
- module_unused :: Name -> Bool
- -- Name is imported from a module that's completely unused,
- -- so don't report stuff about the name (the module covers it)
- module_unused n = moduleName (expectJust "module_unused" (maybeUserImportedFrom n))
- `elem` unused_imp_mods
- -- module_unused is only called if it's user-imported
+ unused_imp_mods = [m | m <- direct_import_mods,
+ not (maybeToBool (lookupFM minimal_imports m)),
+ moduleName m /= pRELUDE_Name]
+
+ module_unused :: Module -> Bool
+ module_unused mod = mod `elem` unused_imp_mods
+
in
warnUnusedModules unused_imp_mods `thenRn_`
warnUnusedLocalBinds bad_locals `thenRn_`
warnUnusedImports bad_imp_names `thenRn_`
printMinimalImports mod_name minimal_imports `thenRn_`
getIfacesRn `thenRn` \ ifaces ->
- (if opt_WarnDeprecations
+ doptRn Opt_WarnDeprecations `thenRn` \ warn_drs ->
+ (if warn_drs
then mapRn_ warnDeprec (deprec_used (iDeprecs ifaces))
else returnRn ())
-- ToDo: deal with original imports with 'qualified' and 'as M' clauses
printMinimalImports mod_name imps
- | not opt_D_dump_minimal_imports
+ = doptRn Opt_D_dump_minimal_imports `thenRn` \ dump_minimal ->
+ printMinimalImports_wrk dump_minimal mod_name imps
+
+printMinimalImports_wrk dump_minimal mod_name imps
+ | not dump_minimal
= returnRn ()
| otherwise
= mapRn to_ies (fmToList imps) `thenRn` \ mod_ies ->
parens (fsep (punctuate comma (map ppr ies)))
to_ies (mod, avail_env) = mapRn to_ie (availEnvElts avail_env) `thenRn` \ ies ->
- returnRn (mod, ies)
+ returnRn (moduleName mod, ies)
to_ie :: AvailInfo -> RnMG (IE Name)
to_ie (Avail n) = returnRn (IEVar n)
-> [RenamedHsDecl] -- Renamed local decls
-> RnMG (IO ())
rnDump imp_decls local_decls
- | opt_D_dump_rn_trace ||
- opt_D_dump_rn_stats ||
- opt_D_dump_rn
- = getRnStats imp_decls `thenRn` \ stats_msg ->
-
- returnRn (printErrs stats_msg >>
- dumpIfSet opt_D_dump_rn "Renamer:"
- (vcat (map ppr (local_decls ++ imp_decls))))
-
- | otherwise = returnRn (return ())
+ = doptRn Opt_D_dump_rn_trace `thenRn` \ dump_rn_trace ->
+ doptRn Opt_D_dump_rn_stats `thenRn` \ dump_rn_stats ->
+ doptRn Opt_D_dump_rn `thenRn` \ dump_rn ->
+ if dump_rn_trace || dump_rn_stats || dump_rn then
+ getRnStats imp_decls `thenRn` \ stats_msg ->
+ returnRn (printErrs stats_msg >>
+ dumpIfSet dump_rn "Renamer:"
+ (vcat (map ppr (local_decls ++ imp_decls))))
+ else
+ returnRn (return ())
\end{code}
projects / ghc-hetmet.git / blobdiff