diff options
| -rw-r--r-- | ghc/compiler/basicTypes/Module.lhs | 6 | ||||
| -rw-r--r-- | ghc/compiler/prelude/PrelInfo.lhs | 18 | ||||
| -rw-r--r-- | ghc/compiler/prelude/PrelNames.lhs | 80 | ||||
| -rw-r--r-- | ghc/compiler/rename/Rename.lhs | 98 | ||||
| -rw-r--r-- | ghc/compiler/rename/RnIfaces.lhs | 31 | ||||
| -rw-r--r-- | ghc/compiler/rename/RnMonad.lhs | 4 | ||||
| -rw-r--r-- | ghc/compiler/rename/RnNames.lhs | 94 | ||||
| -rw-r--r-- | ghc/compiler/rename/RnSource.lhs | 42 | ||||
| -rw-r--r-- | ghc/compiler/typecheck/TcModule.lhs | 6 |
9 files changed, 228 insertions, 151 deletions
diff --git a/ghc/compiler/basicTypes/Module.lhs b/ghc/compiler/basicTypes/Module.lhs index c297d2d7c9..44bf44bf17 100644 --- a/ghc/compiler/basicTypes/Module.lhs +++ b/ghc/compiler/basicTypes/Module.lhs @@ -24,7 +24,7 @@ module Module Module, moduleName -- abstract, instance of Eq, Ord, Outputable , ModuleName - , isModuleInThisPackage + , isModuleInThisPackage, mkModuleInThisPackage , moduleNameString -- :: ModuleName -> EncodedString , moduleNameUserString -- :: ModuleName -> UserString @@ -181,6 +181,10 @@ mkModuleNameFS s = ModuleName (encodeFS s) -- 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} diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index 88bf2f35f7..9bbfc6761b 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -10,7 +10,8 @@ module PrelInfo ( wiredInNames, -- Names of wired in things wiredInThings, - + maybeWiredInTyConName, + maybeWiredInIdName, -- Primop RdrNames eqH_Char_RDR, ltH_Char_RDR, eqH_Word_RDR, ltH_Word_RDR, @@ -39,11 +40,12 @@ import MkId -- All of it, for re-export 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 @@ -85,6 +87,18 @@ tyThingNames (ATyCon tc) = 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 diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index f73146a7f7..826786ce57 100644 --- a/ghc/compiler/prelude/PrelNames.lhs +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -418,41 +418,50 @@ pre-assigned keys. Mostly these names are used in generating deriving 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} %************************************************************************ @@ -784,6 +793,7 @@ deriving_occ_info -- 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 diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index cf679691d5..1f7ba61259 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -15,14 +15,13 @@ import RnHsSyn ( RenamedHsModule, RenamedHsDecl, 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(..) ) @@ -33,12 +32,13 @@ import RnEnv ( availName, availsToNameSet, 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 ) @@ -53,7 +53,8 @@ import PrelNames ( mAIN_Name, pREL_MAIN_Name, pRELUDE_Name, 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 ) @@ -67,28 +68,40 @@ 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 = ( 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 ; @@ -170,7 +183,7 @@ rename this_mod@(HsModule mod_name vers exports imports local_decls mod_deprec l 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 @@ -596,24 +609,26 @@ getInstDeclGates other = emptyFVs \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 ; @@ -718,7 +733,7 @@ reportUnusedNames mod_name direct_import_mods 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) @@ -783,13 +798,18 @@ reportUnusedNames mod_name direct_import_mods 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 -> @@ -825,16 +845,16 @@ rnDump :: [RenamedHsDecl] -- Renamed imported decls -> [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} diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 43133a0a97..1d4711f515 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -4,10 +4,9 @@ \section[RnIfaces]{Cacheing and Renaming of Interfaces} \begin{code} -module RnIfaces ( -#if 1 - lookupFixityRn -#else +module RnIfaces +#if 0 + ( findAndReadIface, getInterfaceExports, getDeferredDecls, @@ -20,8 +19,9 @@ module RnIfaces ( getDeclBinders, getDeclSysBinders, removeContext -- removeContext probably belongs somewhere else + ) #endif - ) where +where #include "HsVersions.h" @@ -72,7 +72,26 @@ import List ( nub ) #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} diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index bdac32a0b0..ddff54f80d 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -522,6 +522,10 @@ checkErrsRn (RnDown {rn_errs = errs_var}) l_down 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} diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index a51c1d509e..877974c87f 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -10,38 +10,40 @@ module RnNames ( #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} @@ -176,7 +178,7 @@ checkEarlyExit mod_name -- 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) @@ -192,7 +194,7 @@ checkEarlyExit mod_name 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} @@ -215,7 +217,7 @@ importsFromImportDecl is_unqual (ImportDecl imp_mod_name from qual_only as_mod i let mk_provenance name = NonLocalDef (UserImport imp_mod iloc (name `elemNameSet` explicits)) - (is_unqual name)) + (is_unqual name) in qualifyImports imp_mod_name @@ -253,7 +255,7 @@ importsFromLocalDecls mod_name rec_exp_fn decls (\n -> LocalDef) -- Provenance is local avails where - mod = mkThisModule mod_name + mod = mkModuleInThisPackage mod_name getLocalDeclBinders :: Module -> (Name -> Bool) -- Is-exported predicate @@ -531,8 +533,10 @@ exportsFromAvail this_mod Nothing export_avails global_name_env 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 @@ -540,12 +544,11 @@ exportsFromAvail this_mod (Just export_items) 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 @@ -558,12 +561,12 @@ exportsFromAvail this_mod (Just export_items) 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 @@ -587,7 +590,7 @@ exportsFromAvail this_mod (Just export_items) 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 @@ -602,14 +605,15 @@ exportsFromAvail this_mod (Just export_items) 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 @@ -630,7 +634,7 @@ mk_export_fn exported_names = \name -> name `elemNameSet` exported_names \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 @@ -642,7 +646,7 @@ dodgyMsg kind item@(IEThingAll tc) 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), @@ -667,6 +671,6 @@ dupExportWarn occ_name ie1 ie2 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} diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 07afca2764..b0d5e4669d 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -39,14 +39,15 @@ import NameSet 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 ) @@ -155,7 +156,7 @@ rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls nconstrs derivin 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) -> @@ -574,7 +575,7 @@ rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau) -- 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) @@ -911,23 +912,24 @@ badDataCon name = 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, diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index a26f066180..850dc53fb1 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -43,7 +43,7 @@ import Type ( funResultTy, splitForAllTys ) 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 ) @@ -83,12 +83,13 @@ data TcResults --------------- 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) @@ -98,7 +99,6 @@ typecheckModule dflags pcs hst (HsModule mod_name _ _ _ decls _ src_loc) 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) |