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 RnNames ( getGlobalNames )
import RnSource ( rnSourceDecls, rnDecl )
-import RnIfaces ( getImportedInstDecls, importDecl, mkImportExportInfo, getInterfaceExports,
+import RnIfaces ( getImportedInstDecls, importDecl, mkImportExportInfo,
+ getInterfaceExports,
getImportedRules, getSlurped, removeContext,
loadBuiltinRules, getDeferredDecls, ImportDeclResult(..)
)
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,
+ nameOccName, nameUnique, nameModule,
+-- maybeUserImportedFrom,
+-- isUserImportedExplicitlyName, isUserImportedName,
+-- maybeWiredInTyConName, maybeWiredInIdName,
isUserExportedName, toRdrName,
nameEnvElts, extendNameEnv
)
import TysWiredIn ( unitTyCon, intTyCon, doubleTyCon, boolTyCon )
import PrelRules ( builtinRules )
import PrelNames ( mAIN_Name, pREL_MAIN_Name, pRELUDE_Name,
- ioTyCon_RDR, unpackCString_RDR, unpackCStringFoldr_RDR, unpackCStringUtf8_RDR
+ ioTyCon_RDR,
+ unpackCString_RDR, unpackCStringFoldr_RDR, unpackCStringUtf8_RDR,
+ eqString_RDR
)
-import PrelInfo ( fractionalClassKeys, derivingOccurrences )
+import PrelInfo ( fractionalClassKeys, derivingOccurrences,
+ maybeWiredInTyConName, maybeWiredInIdName )
import Type ( namesOfType, funTyCon )
import ErrUtils ( printErrorsAndWarnings, dumpIfSet, ghcExit )
import BasicTypes ( Version, initialVersion )
import Maybes ( maybeToBool, expectJust )
import Outputable
import IO ( openFile, IOMode(..) )
+import HscTypes ( Finder, 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
- , 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
- , [Module]) -- Imported modules
+type RenameResult = ( PersistentCompilerState
+ , ModIface
+ )
-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 (PersistentCompilerState, Maybe ModIface)
+ -- The mi_decls in the ModIface include
+ -- ones imported from packages too
+
+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 (mkThisModule 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}
\begin{code}
-rename :: RdrNameHsModule -> RnMG (Maybe RenameResult, IO ())
+rename :: RdrNameHsModule -> RnMG (Maybe ModIface, IO ())
rename this_mod@(HsModule mod_name vers exports imports local_decls mod_deprec loc)
= -- FIND THE GLOBAL NAME ENVIRONMENT
getGlobalNames this_mod `thenRn` \ maybe_stuff ->
else
-- GENERATE THE VERSION/USAGE INFO
- mkImportExportInfo mod_name export_avails exports `thenRn` \ (my_exports, my_usages) ->
+ mkImportExportInfo mod_name export_avails imports `thenRn` \ (my_exports, my_usages) ->
-- RETURN THE RENAMED MODULE
getNameSupplyRn `thenRn` \ name_supply ->
user_import ImportByUserSource = True
user_import _ = False
- this_module = mkThisModule mod_name
+ this_module = mkModuleInThisPackage mod_name
-- Export only those fixities that are for names that are
-- (a) defined in this module
-- (b) exported
exported_fixities
- = [ FixitySig (toRdrName name) fixity loc
- | FixitySig name fixity loc <- nameEnvElts local_fixity_env,
- isUserExportedName name
- ]
-
- new_iface = ParsedIface { pi_mod = this_module
- , pi_vers = initialVersion
- , pi_orphan = any isOrphanDecl rn_local_decls
- , pi_exports = my_exports
- , pi_usages = my_usages
- , pi_fixity = (initialVersion, exported_fixities)
- , pi_deprecs = my_deprecs
- -- These ones get filled in later
- , pi_insts = [], pi_decls = []
- , pi_rules = (initialVersion, [])
- }
-
- renamed_module = HsModule mod_name vers
- trashed_exports trashed_imports
- (rn_local_decls ++ rn_imp_decls)
- mod_deprec
- loc
-
- result = (this_module, renamed_module,
- old_iface, new_iface,
- name_supply, local_fixity_env,
- direct_import_mods)
+ = mkNameEnv [ (name, fixity)
+ | FixitySig name fixity loc <- nameEnvElts local_fixity_env,
+ isUserExportedName name
+ ]
+
+ mod_iface = ModIface { mi_module = this_module
+ mi_version = panic "mi_version: not filled in yet",
+ mi_orphan = any isOrphanDecl rn_local_decls,
+ mi_exports = my_exports,
+ mi_usages = my_usages,
+ mi_fixity = exported_fixities)
+ mi_deprecs = my_deprecs
+ mi_decls = rn_local_decls ++ rn_imp_decls
+ }
in
-- REPORT UNUSED NAMES, AND DEBUG DUMP
export_avails source_fvs
rn_imp_decls `thenRn_`
- returnRn (Just result, dump_action) }
+ returnRn (Just mod_iface, dump_action) }
where
trashed_exports = {-trace "rnSource:trashed_exports"-} Nothing
trashed_imports = {-trace "rnSource:trashed_imports"-} []
implicit_occs = string_occs ++ foldr ((++) . get) implicit_main decls
-- Virtually every program has error messages in it somewhere
- string_occs = [unpackCString_RDR, unpackCStringFoldr_RDR, unpackCStringUtf8_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 = []
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)
(hsTyVarNames tvs)
`addOneToNameSet` cls)
(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)
(hsTyVarNames tvs)
`addOneToNameSet` tycon
\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 {
, 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 (maybeToBool (lookupFM minimal_imports m)),
moduleName m /= pRELUDE_Name]
- 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 = expectJust "module_unused" (maybeUserImportedFrom n)
- `elem` unused_imp_mods
- -- module_unused is only called if it's user-imported
+ 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 ->
-> [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}