Stagger dazedly towards getting the renamer to compile.
Module, moduleName
-- abstract, instance of Eq, Ord, Outputable
, ModuleName
- , isModuleInThisPackage
+ , isModuleInThisPackage, mkModuleInThisPackage
, moduleNameString -- :: ModuleName -> EncodedString
, moduleNameUserString -- :: ModuleName -> UserString
-- used to be called mkSysModuleFS
mkSysModuleNameFS :: EncodedFS -> ModuleName
mkSysModuleNameFS s = ModuleName s
+
+-- Make a module in this package
+mkModuleInThisPackage :: ModuleName -> Module
+mkModuleInThisPackage nm = Module nm ThisPackage
\end{code}
\begin{code}
wiredInNames, -- Names of wired in things
wiredInThings,
-
+ maybeWiredInTyConName,
+ maybeWiredInIdName,
-- Primop RdrNames
eqH_Char_RDR, ltH_Char_RDR, eqH_Word_RDR, ltH_Word_RDR,
import TysPrim ( primTyCons )
import TysWiredIn ( wiredInTyCons )
import HscTypes ( TyThing(..) )
+import Id ( Id, idName )
-- others:
import RdrName ( RdrName )
import Name ( Name, getName )
-import TyCon ( tyConDataConsIfAvailable, TyCon )
+import TyCon ( tyConDataConsIfAvailable, TyCon, tyConName )
import Class ( Class, classKey )
import Type ( funTyCon )
import Bag
= getName tc : [ getName n | dc <- tyConDataConsIfAvailable tc,
n <- [dataConId dc, dataConWrapId dc] ]
-- Synonyms return empty list of constructors
+
+maybeWiredInIdName :: Name -> Maybe Id
+maybeWiredInIdName nm
+ = case filter ((== nm).idName) wiredInIds of
+ [] -> Nothing
+ (i:is) -> Just i
+
+maybeWiredInTyConName :: Name -> Maybe TyCon
+maybeWiredInTyConName nm
+ = case filter ((== nm).tyConName) wiredInTyCons of
+ [] -> Nothing
+ (tc:tcs) -> Just tc
\end{code}
We let a lot of "non-standard" values be visible, so that we can make
code, which is passed through the renamer anyway.
\begin{code}
-and_RDR = varQual_RDR pREL_BASE_Name SLIT("&&")
-not_RDR = varQual_RDR pREL_BASE_Name SLIT("not")
-compose_RDR = varQual_RDR pREL_BASE_Name SLIT(".")
-ne_RDR = varQual_RDR pREL_BASE_Name SLIT("/=")
-le_RDR = varQual_RDR pREL_BASE_Name SLIT("<=")
-lt_RDR = varQual_RDR pREL_BASE_Name SLIT("<")
-gt_RDR = varQual_RDR pREL_BASE_Name SLIT(">")
-ltTag_RDR = dataQual_RDR pREL_BASE_Name SLIT("LT")
-eqTag_RDR = dataQual_RDR pREL_BASE_Name SLIT("EQ")
-gtTag_RDR = dataQual_RDR pREL_BASE_Name SLIT("GT")
-max_RDR = varQual_RDR pREL_BASE_Name SLIT("max")
-min_RDR = varQual_RDR pREL_BASE_Name SLIT("min")
-compare_RDR = varQual_RDR pREL_BASE_Name SLIT("compare")
-showList_RDR = varQual_RDR pREL_SHOW_Name SLIT("showList")
-showList___RDR = varQual_RDR pREL_SHOW_Name SLIT("showList__")
-showsPrec_RDR = varQual_RDR pREL_SHOW_Name SLIT("showsPrec")
-showSpace_RDR = varQual_RDR pREL_SHOW_Name SLIT("showSpace")
-showString_RDR = varQual_RDR pREL_SHOW_Name SLIT("showString")
-showParen_RDR = varQual_RDR pREL_SHOW_Name SLIT("showParen")
-readsPrec_RDR = varQual_RDR pREL_READ_Name SLIT("readsPrec")
-readList_RDR = varQual_RDR pREL_READ_Name SLIT("readList")
-readParen_RDR = varQual_RDR pREL_READ_Name SLIT("readParen")
-lex_RDR = varQual_RDR pREL_READ_Name SLIT("lex")
-readList___RDR = varQual_RDR pREL_READ_Name SLIT("readList__")
-times_RDR = varQual_RDR pREL_NUM_Name SLIT("*")
-plus_RDR = varQual_RDR pREL_NUM_Name SLIT("+")
-negate_RDR = varQual_RDR pREL_NUM_Name SLIT("negate")
-range_RDR = varQual_RDR pREL_ARR_Name SLIT("range")
-index_RDR = varQual_RDR pREL_ARR_Name SLIT("index")
-inRange_RDR = varQual_RDR pREL_ARR_Name SLIT("inRange")
-succ_RDR = varQual_RDR pREL_ENUM_Name SLIT("succ")
-pred_RDR = varQual_RDR pREL_ENUM_Name SLIT("pred")
-minBound_RDR = varQual_RDR pREL_ENUM_Name SLIT("minBound")
-maxBound_RDR = varQual_RDR pREL_ENUM_Name SLIT("maxBound")
-assertErr_RDR = varQual_RDR pREL_ERR_Name SLIT("assertError")
+unpackCString_RDR = varQual_RDR pREL_BASE_Name SLIT("unpackCString#")
+unpackCStringFoldr_RDR = varQual_RDR pREL_BASE_Name SLIT("unpackFoldrCString#")
+unpackCStringUtf8_RDR = varQual_RDR pREL_BASE_Name SLIT("unpackCStringUtf8#")
+deRefStablePtr_RDR = varQual_RDR pREL_STABLE_Name SLIT("deRefStablePtr")
+makeStablePtr_RDR = varQual_RDR pREL_STABLE_Name SLIT("makeStablePtr")
+bindIO_RDR = varQual_RDR pREL_IO_BASE_Name SLIT("bindIO")
+returnIO_RDR = varQual_RDR pREL_IO_BASE_Name SLIT("returnIO")
+
+main_RDR = varQual_RDR mAIN_Name SLIT("main")
+and_RDR = varQual_RDR pREL_BASE_Name SLIT("&&")
+not_RDR = varQual_RDR pREL_BASE_Name SLIT("not")
+compose_RDR = varQual_RDR pREL_BASE_Name SLIT(".")
+ne_RDR = varQual_RDR pREL_BASE_Name SLIT("/=")
+le_RDR = varQual_RDR pREL_BASE_Name SLIT("<=")
+lt_RDR = varQual_RDR pREL_BASE_Name SLIT("<")
+gt_RDR = varQual_RDR pREL_BASE_Name SLIT(">")
+ltTag_RDR = dataQual_RDR pREL_BASE_Name SLIT("LT")
+eqTag_RDR = dataQual_RDR pREL_BASE_Name SLIT("EQ")
+gtTag_RDR = dataQual_RDR pREL_BASE_Name SLIT("GT")
+max_RDR = varQual_RDR pREL_BASE_Name SLIT("max")
+min_RDR = varQual_RDR pREL_BASE_Name SLIT("min")
+compare_RDR = varQual_RDR pREL_BASE_Name SLIT("compare")
+showList_RDR = varQual_RDR pREL_SHOW_Name SLIT("showList")
+showList___RDR = varQual_RDR pREL_SHOW_Name SLIT("showList__")
+showsPrec_RDR = varQual_RDR pREL_SHOW_Name SLIT("showsPrec")
+showSpace_RDR = varQual_RDR pREL_SHOW_Name SLIT("showSpace")
+showString_RDR = varQual_RDR pREL_SHOW_Name SLIT("showString")
+showParen_RDR = varQual_RDR pREL_SHOW_Name SLIT("showParen")
+readsPrec_RDR = varQual_RDR pREL_READ_Name SLIT("readsPrec")
+readList_RDR = varQual_RDR pREL_READ_Name SLIT("readList")
+readParen_RDR = varQual_RDR pREL_READ_Name SLIT("readParen")
+lex_RDR = varQual_RDR pREL_READ_Name SLIT("lex")
+readList___RDR = varQual_RDR pREL_READ_Name SLIT("readList__")
+times_RDR = varQual_RDR pREL_NUM_Name SLIT("*")
+plus_RDR = varQual_RDR pREL_NUM_Name SLIT("+")
+negate_RDR = varQual_RDR pREL_NUM_Name SLIT("negate")
+range_RDR = varQual_RDR pREL_ARR_Name SLIT("range")
+index_RDR = varQual_RDR pREL_ARR_Name SLIT("index")
+inRange_RDR = varQual_RDR pREL_ARR_Name SLIT("inRange")
+succ_RDR = varQual_RDR pREL_ENUM_Name SLIT("succ")
+pred_RDR = varQual_RDR pREL_ENUM_Name SLIT("pred")
+minBound_RDR = varQual_RDR pREL_ENUM_Name SLIT("minBound")
+maxBound_RDR = varQual_RDR pREL_ENUM_Name SLIT("maxBound")
+assertErr_RDR = varQual_RDR pREL_ERR_Name SLIT("assertError")
\end{code}
%************************************************************************
-- these RDR names also have known keys, so we need to get back the RDR names to
-- populate the occurrence list above.
+ioTyCon_RDR = nameRdrName ioTyConName
intTyCon_RDR = nameRdrName intTyConName
eq_RDR = nameRdrName eqName
ge_RDR = nameRdrName geName
extractHsTyNames, extractHsCtxtTyNames
)
-import CmdLineOpts ( dopt_D_dump_rn_trace, dopt_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,
+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
)
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 ( 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 = ( PersistentCompilerState,
+type RenameResult = ( PersistentCompilerState
, Module -- This module
, RenamedHsModule -- Renamed module
, Maybe ParsedIface -- The existing interface file, if any
, ParsedIface -- The new interface
, [Module]) -- Imported modules
-renameModule :: PersistentCompilerState -> HomeSymbolTable
+renameModule :: DynFlags -> Finder
+ -> PersistentCompilerState -> HomeSymbolTable
-> RdrNameHsModule -> IO (Maybe RenameResult)
-renameModule old_pcs hst this_mod@(HsModule mod_name vers exports imports local_decls _ loc)
+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), msgs, new_pcs)
+ ((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 msgs ;
+ printErrorsAndWarnings (rn_warns_bag, rn_errs_bag) ;
-- Dump any debugging output
dump_action ;
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
\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 ;
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,
+ bad_imp_names = [(n,p) | (n,p@(UserImport mod _ True)) <- defined_but_not_used,
not (module_unused mod)]
deprec_used deprec_env = [ (n,txt)
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}
\section[RnIfaces]{Cacheing and Renaming of Interfaces}
\begin{code}
-module RnIfaces (
-#if 1
- lookupFixityRn
-#else
+module RnIfaces
+#if 0
+ (
findAndReadIface,
getInterfaceExports, getDeferredDecls,
getDeclBinders, getDeclSysBinders,
removeContext -- removeContext probably belongs somewhere else
+ )
#endif
- ) where
+where
#include "HsVersions.h"
#if 1
import Panic ( panic )
-lookupFixityRn = panic "lookupFixityRn"
+lookupFixityRn = panic "lookupFixityRn"
+findAndReadIface = panic "findAndReadIface"
+getInterfaceExports = panic "getInterfaceExports"
+getDeclBinders = panic "getDeclBinders"
+recordLocalSlurps = panic "recordLocalSlurps"
+checkModUsage = panic "checkModUsage"
+outOfDate = panic "outOfDate"
+getSlurped = panic "getSlurped"
+removeContext = panic "removeContext"
+loadBuiltinRules = panic "loadBuiltinRules"
+getDeferredDecls = panic "getDeferredDecls"
+data ImportDeclResult
+ = AlreadySlurped
+ | WiredIn
+ | Deferred
+ | HereItIs (Module, RdrNameHsDecl)
+getImportedInstDecls = panic "getImportedInstDecls"
+importDecl = panic "importDecl"
+mkImportExportInfo = panic "mkImportExportInfo"
+getImportedRules = panic "getImportedRules"
#else
\end{code}
doptRn :: DynFlag -> RnM d Bool
doptRn dflag (RnDown { rn_dflags = dflags}) l_down
= return (dopt dflag dflags)
+
+getDOptsRn :: RnM d DynFlags
+getDOptsRn (RnDown { rn_dflags = dflags}) l_down
+ = return dflags
\end{code}
#include "HsVersions.h"
-import CmdLineOpts ( opt_NoImplicitPrelude, opt_WarnDuplicateExports )
-
-import HsSyn ( HsModule(..), HsDecl(..), IE(..), ieName, ImportDecl(..),
- collectTopBinders
- )
-import RdrHsSyn ( RdrNameIE, RdrNameImportDecl,
- RdrNameHsModule, RdrNameHsDecl
- )
-import RnIfaces ( getInterfaceExports, getDeclBinders,
- recordLocalSlurps, checkModUsage, findAndReadIface, outOfDate
- )
+import CmdLineOpts ( DynFlags, DynFlag(..), dopt, opt_NoImplicitPrelude )
+
+import HsSyn ( HsModule(..), HsDecl(..), IE(..), ieName, ImportDecl(..),
+ collectTopBinders
+ )
+import RdrHsSyn ( RdrNameIE, RdrNameImportDecl,
+ RdrNameHsModule, RdrNameHsDecl
+ )
+import RnIfaces ( getInterfaceExports, getDeclBinders,
+ recordLocalSlurps, checkModUsage,
+ outOfDate, findAndReadIface )
import RnEnv
import RnMonad
import FiniteMap
-import PrelNames ( pRELUDE_Name, mAIN_Name, main_RDR )
-import UniqFM ( lookupUFM )
-import Bag ( bagToList )
-import Module ( ModuleName, mkThisModule, pprModuleName, WhereFrom(..) )
+import PrelNames ( pRELUDE_Name, mAIN_Name, main_RDR )
+import UniqFM ( lookupUFM )
+import Bag ( bagToList )
+import Module ( ModuleName, mkModuleInThisPackage, WhereFrom(..) )
import NameSet
-import Name ( Name, ImportReason(..), Provenance(..),
- setLocalNameSort, nameOccName, nameEnvElts
- )
-import RdrName ( RdrName, rdrNameOcc, setRdrNameOcc, mkRdrQual, mkRdrUnqual, isQual, isUnqual )
-import OccName ( setOccNameSpace, dataName )
-import NameSet ( elemNameSet, emptyNameSet )
+import Name ( Name, nameSrcLoc,
+ setLocalNameSort, nameOccName, nameEnvElts )
+import HscTypes ( Provenance(..), ImportReason(..), GlobalRdrEnv,
+ GenAvailInfo(..), AvailInfo, Avails, AvailEnv )
+import RdrName ( RdrName, rdrNameOcc, setRdrNameOcc, mkRdrQual, mkRdrUnqual,
+ isQual, isUnqual )
+import OccName ( setOccNameSpace, dataName )
+import NameSet ( elemNameSet, emptyNameSet )
import Outputable
-import Maybes ( maybeToBool, catMaybes, mapMaybe )
-import UniqFM ( emptyUFM, listToUFM )
-import ListSetOps ( removeDups )
-import Util ( sortLt )
-import List ( partition )
+import Maybes ( maybeToBool, catMaybes, mapMaybe )
+import UniqFM ( emptyUFM, listToUFM )
+import ListSetOps ( removeDups )
+import Util ( sortLt )
+import List ( partition )
\end{code}
-- CHECK WHETHER WE HAVE IT ALREADY
case maybe_iface of
Left err -> -- Old interface file not found, so we'd better bail out
- traceRn (vcat [ptext SLIT("No old interface file for") <+> pprModuleName mod_name,
+ traceRn (vcat [ptext SLIT("No old interface file for") <+> ppr mod_name,
err]) `thenRn_`
returnRn (outOfDate, Nothing)
returnRn (up_to_date, Just iface)
where
-- Only look in current directory, with suffix .hi
- doc_str = sep [ptext SLIT("need usage info from"), pprModuleName mod_name]
+ doc_str = sep [ptext SLIT("need usage info from"), ppr mod_name]
\end{code}
\begin{code}
let
mk_provenance name = NonLocalDef (UserImport imp_mod iloc (name `elemNameSet` explicits))
- (is_unqual name))
+ (is_unqual name)
in
qualifyImports imp_mod_name
(\n -> LocalDef) -- Provenance is local
avails
where
- mod = mkThisModule mod_name
+ mod = mkModuleInThisPackage mod_name
getLocalDeclBinders :: Module
-> (Name -> Bool) -- Is-exported predicate
exportsFromAvail this_mod (Just export_items)
(mod_avail_env, entity_avail_env)
global_name_env
- = foldlRn exports_from_item
- ([], emptyFM, emptyAvailEnv) export_items `thenRn` \ (_, _, export_avail_map) ->
+ = doptRn Opt_WarnDuplicateExports `thenRn` \ warn_dup_exports ->
+ foldlRn (exports_from_item warn_dup_exports)
+ ([], emptyFM, emptyAvailEnv) export_items
+ `thenRn` \ (_, _, export_avail_map) ->
let
export_avails :: [AvailInfo]
export_avails = nameEnvElts export_avail_map
returnRn export_avails
where
- exports_from_item :: ExportAccum -> RdrNameIE -> RnMG ExportAccum
+ exports_from_item :: Bool -> ExportAccum -> RdrNameIE -> RnMG ExportAccum
- exports_from_item acc@(mods, occs, avails) ie@(IEModuleContents mod)
+ exports_from_item warn_dups acc@(mods, occs, avails) ie@(IEModuleContents mod)
| mod `elem` mods -- Duplicate export of M
- = warnCheckRn opt_WarnDuplicateExports
- (dupModuleExport mod) `thenRn_`
+ = warnCheckRn warn_dups (dupModuleExport mod) `thenRn_`
returnRn acc
| otherwise
in
returnRn (mod:mods, occs', avails')
- exports_from_item acc@(mods, occs, avails) ie
+ exports_from_item warn_dups acc@(mods, occs, avails) ie
| not (maybeToBool maybe_in_scope)
= failWithRn acc (unknownNameErr (ieName ie))
| not (null dup_names)
- = addNameClashErrRn rdr_name (name:dup_names) `thenRn_`
+ = addNameClashErrRn rdr_name ((name,prov):dup_names) `thenRn_`
returnRn acc
#ifdef DEBUG
where
rdr_name = ieName ie
maybe_in_scope = lookupFM global_name_env rdr_name
- Just ((name,_):dup_names) = maybe_in_scope
+ Just ((name,prov):dup_names) = maybe_in_scope
maybe_avail = lookupUFM entity_avail_env name
Just avail = maybe_avail
maybe_export_avail = filterAvail ie avail
check_occs :: RdrNameIE -> ExportOccMap -> AvailInfo -> RnMG ExportOccMap
check_occs ie occs avail
- = foldlRn check occs (availNames avail)
+ = doptRn Opt_WarnDuplicateExports `thenRn` \ warn_dup_exports ->
+ foldlRn (check warn_dup_exports) occs (availNames avail)
where
- check occs name
+ check warn_dup occs name
= case lookupFM occs name_occ of
Nothing -> returnRn (addToFM occs name_occ (name, ie))
Just (name', ie')
| name == name' -> -- Duplicate export
- warnCheckRn opt_WarnDuplicateExports
+ warnCheckRn warn_dup
(dupExportWarn name_occ ie ie')
`thenRn_` returnRn occs
\begin{code}
badImportItemErr mod ie
- = sep [ptext SLIT("Module"), quotes (pprModuleName mod),
+ = sep [ptext SLIT("Module"), quotes (ppr mod),
ptext SLIT("does not export"), quotes (ppr ie)]
dodgyImportWarn mod item = dodgyMsg (ptext SLIT("import")) item
ptext SLIT("but it has none; it is a type synonym or abstract type or class") ]
modExportErr mod
- = hsep [ ptext SLIT("Unknown module in export list: module"), quotes (pprModuleName mod)]
+ = hsep [ ptext SLIT("Unknown module in export list: module"), quotes (ppr mod)]
exportItemErr export_item
= sep [ ptext SLIT("The export item") <+> quotes (ppr export_item),
dupModuleExport mod
= hsep [ptext SLIT("Duplicate"),
- quotes (ptext SLIT("Module") <+> pprModuleName mod),
+ quotes (ptext SLIT("Module") <+> ppr mod),
ptext SLIT("in export list")]
\end{code}
import OccName ( mkDefaultMethodOcc, isTvOcc )
import FiniteMap ( elemFM )
import PrelInfo ( derivableClassKeys, cCallishClassKeys )
-import PrelNames ( deRefStablePtr_RDR, makeStablePtr_RDR,
+import PrelNames ( deRefStablePtr_RDR, makeStablePtr_RDR,
bindIO_RDR, returnIO_RDR
)
import Bag ( bagToList )
import List ( partition, nub )
import Outputable
import SrcLoc ( SrcLoc )
-import CmdLineOpts ( opt_WarnUnusedMatches, dopt_GlasgowExts ) -- Warn of unused for-all'd tyvars
+import CmdLineOpts ( DynFlags, DynFlag(..) )
+ -- Warn of unused for-all'd tyvars
import Unique ( Uniquable(..) )
import ErrUtils ( Message )
import CStrings ( isCLabelString )
rnDecl (TyClD (TySynonym name tyvars ty src_loc))
= pushSrcLocRn src_loc $
- doptsRn dopt_GlasgowExts `thenRn` \ glaExts ->
+ doptRn Opt_GlasgowExts `thenRn` \ glaExts ->
lookupTopBndrRn name `thenRn` \ name' ->
bindTyVarsFVRn syn_doc tyvars $ \ tyvars' ->
rnHsType syn_doc (unquantify glaExts ty) `thenRn` \ (ty', ty_fvs) ->
-- Explicitly quantified but not mentioned in ctxt or tau
warn_guys = filter (`notElem` mentioned) forall_tyvar_names
in
- mapRn_ (forAllWarn doc tau) warn_guys `thenRn_`
+ mapRn_ (forAllWarn doc tau) warn_guys `thenRn_`
rnForAll doc forall_tyvars ctxt tau
rnHsType doc (HsTyVar tyvar)
= hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
forAllWarn doc ty tyvar
- | not opt_WarnUnusedMatches = returnRn ()
- | otherwise
- = getModeRn `thenRn` \ mode ->
- case mode of {
+ = doptRn Opt_WarnUnusedMatches `thenRn` \ warn_unused -> case () of
+ () | not warn_unused -> returnRn ()
+ | otherwise
+ -> getModeRn `thenRn` \ mode ->
+ case mode of {
#ifndef DEBUG
- InterfaceMode -> returnRn () ; -- Don't warn of unused tyvars in interface files
- -- unless DEBUG is on, in which case it is slightly
- -- informative. They can arise from mkRhsTyLam,
-#endif -- leading to (say) f :: forall a b. [b] -> [b]
- other ->
-
- addWarnRn (
- sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
- nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
- $$
- (ptext SLIT("In") <+> doc))
- }
+ InterfaceMode -> returnRn () ; -- Don't warn of unused tyvars in interface files
+ -- unless DEBUG is on, in which case it is slightly
+ -- informative. They can arise from mkRhsTyLam,
+#endif -- leading to (say) f :: forall a b. [b] -> [b]
+ other ->
+ addWarnRn (
+ sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
+ nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
+ $$
+ (ptext SLIT("In") <+> doc)
+ )
+ }
badRuleLhsErr name lhs
= sep [ptext SLIT("Rule") <+> ptext name <> colon,
import Bag ( isEmptyBag )
import ErrUtils ( printErrorsAndWarnings, dumpIfSet_dyn )
import Id ( idType, idName, idUnfolding )
-import Module ( Module, moduleName, {-mkThisModule,-} plusModuleEnv )
+import Module ( Module, moduleName, plusModuleEnv )
import Name ( nameOccName, isLocallyDefined, isGlobalName,
toRdrName, nameEnvElts, emptyNameEnv
)
---------------
typecheckModule
:: DynFlags
+ -> Module
-> PersistentCompilerState
-> HomeSymbolTable
-> RenamedHsModule
-> IO (Maybe (TcEnv, TcResults))
-typecheckModule dflags pcs hst (HsModule mod_name _ _ _ decls _ src_loc)
+typecheckModule dflags this_mod pcs hst (HsModule mod_name _ _ _ decls _ src_loc)
= do env <- initTcEnv global_symbol_table
(maybe_result, (errs,warns)) <- initTc dflags env src_loc tc_module
printErrorsAndWarnings (errs,warns)
else
return maybe_result
where
- this_mod = panic "mkThisModule: unimp" -- WAS: mkThisModule
global_symbol_table = pcs_PST pcs `plusModuleEnv` hst
tc_module = fixTc (\ ~(unf_env ,_) -> tcModule pcs hst this_mod decls unf_env)
projects / ghc-hetmet.git / commitdiff