Commit 9bedea20 authored by sewardj's avatar sewardj
Browse files

[project @ 2000-10-19 15:00:16 by sewardj]

Stagger dazedly towards getting the renamer to compile.
parent 9aa6d18b
......@@ -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}
......
......@@ -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
......
......@@ -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
......
......@@ -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}
......
......@@ -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}
......
......@@ -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}
......
......@@ -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}
......@@ -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 ()