Commit 17879095 authored by sewardj's avatar sewardj
Browse files

[project @ 2000-10-17 14:40:26 by sewardj]

Make RnEnv compile.
parent dbb27b50
......@@ -26,7 +26,7 @@ import Finder ( Finder, newFinder,
import CmSummarise ( summarise, ModSummary(..),
mi_name, ms_get_imports,
name_of_summary, deps_of_summary )
import CmCompile ( PCS, emptyPCS, HST, HIT, CompResult(..), cmCompile )
--import CmCompile ( PCS, emptyPCS, HST, HIT, CompResult(..), cmCompile )
import CmLink ( PLS, emptyPLS, Linkable(..),
link, LinkResult(..),
filterModuleLinkables, modname_of_linkable,
......
......@@ -10,9 +10,10 @@ module HscTypes (
TyThing(..), lookupTypeEnv, lookupFixityEnv,
WhetherHasOrphans, ImportVersion, ExportItem,
WhetherHasOrphans, ImportVersion, ExportItem, WhatsImported(..),
PersistentRenamerState(..), IsBootInterface, Avails, DeclsMap,
IfaceInsts, IfaceRules, DeprecationEnv, OrigNameEnv,
IfaceInsts, IfaceRules, DeprecationEnv,
OrigNameEnv(..), OrigNameNameEnv, OrigNameIParamEnv,
AvailEnv, AvailInfo, GenAvailInfo(..),
PersistentCompilerState(..),
......@@ -61,6 +62,7 @@ import VarSet ( TyVarSet )
import Panic ( panic )
import Outputable
import SrcLoc ( SrcLoc, isGoodSrcLoc )
import Util ( thenCmp )
\end{code}
%************************************************************************
......@@ -360,9 +362,14 @@ we just store junk. Then when we find the binding site, we fix it up.
\begin{code}
data OrigNameEnv
= Orig { origNames :: FiniteMap (ModuleName,OccName) Name, -- Ensures that one original name gets one unique
origIParam :: FiniteMap OccName Name -- Ensures that one implicit parameter name gets one unique
= Orig { origNames :: OrigNameNameEnv,
-- Ensures that one original name gets one unique
origIParam :: OrigNameIParamEnv
-- Ensures that one implicit parameter name gets one unique
}
type OrigNameNameEnv = FiniteMap (ModuleName,OccName) Name
type OrigNameIParamEnv = FiniteMap OccName Name
\end{code}
......@@ -453,6 +460,29 @@ data Provenance
ImportReason
PrintUnqualified
-- Just used for grouping error messages (in RnEnv.warnUnusedBinds)
instance Eq Provenance where
p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False
instance Eq ImportReason where
p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False
instance Ord Provenance where
compare LocalDef LocalDef = EQ
compare LocalDef (NonLocalDef _ _) = LT
compare (NonLocalDef _ _) LocalDef = GT
compare (NonLocalDef reason1 _) (NonLocalDef reason2 _)
= compare reason1 reason2
instance Ord ImportReason where
compare ImplicitImport ImplicitImport = EQ
compare ImplicitImport (UserImport _ _ _) = LT
compare (UserImport _ _ _) ImplicitImport = GT
compare (UserImport m1 loc1 _) (UserImport m2 loc2 _)
= (m1 `compare` m2) `thenCmp` (loc1 `compare` loc2)
{-
Moved here from Name.
pp_prov (LocalDef _ Exported) = char 'x'
......
......@@ -49,10 +49,11 @@ import IdInfo ( exactArity, InlinePragInfo(..) )
import PrimOp ( CCall(..), CCallTarget(..) )
import Lex
import RnMonad ( ImportVersion, ParsedIface(..), WhatsImported(..),
ExportItem, RdrAvailInfo, GenAvailInfo(..),
WhetherHasOrphans, IsBootInterface
)
import RnMonad ( ParsedIface(..) )
import HscTypes ( WhetherHasOrphans, IsBootInterface, GenAvailInfo(..),
ImportVersion, ExportItem, WhatsImported(..),
RdrAvailInfo )
import RdrName ( RdrName, mkRdrUnqual, mkSysQual, mkSysUnqual )
import Name ( OccName )
import OccName ( mkSysOccFS,
......@@ -246,7 +247,7 @@ import_part : { [] }
import_decl :: { ImportVersion OccName }
import_decl : 'import' mod_name orphans is_boot whats_imported ';'
{ (mkSysModuleNameFS $2, $3, $4, $5) }
{ ({-mkSysModuleNameFS-} $2, $3, $4, $5) }
orphans :: { WhetherHasOrphans }
orphans : { False }
......@@ -275,7 +276,7 @@ name_version_pair : var_occ version { ($1, $2) }
exports_part :: { [ExportItem] }
exports_part : { [] }
| '__export' mod_name entities ';'
exports_part { (mkSysModuleNameFS $2, $3) : $5 }
exports_part { ({-mkSysModuleNameFS-} $2, $3) : $5 }
entities :: { [RdrAvailInfo] }
entities : { [] }
......
......@@ -41,8 +41,6 @@ import PrelNames ( mkUnboundName )
import CmdLineOpts
\end{code}
%*********************************************************
%* *
\subsection{Making new names}
......@@ -50,8 +48,6 @@ import CmdLineOpts
%*********************************************************
\begin{code}
implicitImportProvenance = NonLocalDef ImplicitImport False
newTopBinder :: Module -> RdrName -> SrcLoc -> RnM d Name
newTopBinder mod rdr_name loc
= -- First check the cache
......@@ -173,8 +169,8 @@ lookupTopBndrRn rdr_name
getModuleRn `thenRn` \ mod ->
getGlobalNameEnv `thenRn` \ global_env ->
case lookupRdrEnv global_env (qualifyRdrName (moduleName mod) rdr_name) of
Just (name:rest) -> ASSERT( null rest )
returnRn name
Just ((name,_):rest) -> ASSERT( null rest )
returnRn name
Nothing -> -- Almost always this case is a compiler bug.
-- But consider a type signature that doesn't have
-- a corresponding binder:
......@@ -221,8 +217,9 @@ lookupGlobalOccRn rdr_name
getGlobalNameEnv `thenRn` \ global_env ->
case lookupRdrEnv global_env rdr_name of
Just [(name,_)] -> returnRn name
Just stuff@(_:_) -> addNameClashErrRn rdr_name stuff `thenRn_`
returnRn rdr_name
Just stuff@((name,_):_)
-> addNameClashErrRn rdr_name stuff `thenRn_`
returnRn name
Nothing -> -- Not found when processing source code; so fail
failWithRn (mkUnboundName rdr_name)
(unknownNameErr rdr_name)
......@@ -512,9 +509,9 @@ combine_globals ns_old ns_new -- ns_new is often short
(n,pn) `beats` (m,pm) = n==m && pn `hasBetterProv` pm
is_duplicate :: Provenance -> (Name,Provenance) -> Bool
is_duplicate (n1,LocalDef _) (n2,LocalDef _) = False
is_duplicate n1 n2 = n1 == n2
is_duplicate :: (Name,Provenance) -> (Name,Provenance) -> Bool
is_duplicate (n1,LocalDef) (n2,LocalDef) = False
is_duplicate (n1,_) (n2,_) = n1 == n2
\end{code}
We treat two bindings of a locally-defined name as a duplicate,
......@@ -685,7 +682,7 @@ mapFvRn f xs = mapRn f xs `thenRn` \ stuff ->
warnUnusedModules :: [Module] -> RnM d ()
warnUnusedModules mods
= doptRn Opt_WarnUnusedImports `thenRn` \ warn ->
if warn then mapRn_ (addWarnRn . unused_mod . moduleName) mods
if warn then mapRn_ (addWarnRn . unused_mod) mods
else returnRn ()
where
unused_mod m = vcat [ptext SLIT("Module") <+> quotes (ppr m) <+>
......@@ -696,7 +693,7 @@ warnUnusedModules mods
warnUnusedImports :: [(Name,Provenance)] -> RnM d ()
warnUnusedImports names
= doptRn Opt_WarnUnusedImports `thenRn` \ warn ->
if warn then warnUnusedBinds names else return ()
if warn then warnUnusedBinds names else returnRn ()
warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> RnM d ()
warnUnusedLocalBinds names
......@@ -717,15 +714,8 @@ warnUnusedBinds names
where
-- Group by provenance
groups = equivClasses cmp names
(_,prov1) `cmp` (_,prov2) = prov1 `cmp_prov` prov2
(_,prov1) `cmp` (_,prov2) = prov1 `compare` prov2
cmp_prov (LocalDef _ _) (NonLocalDef _ _) = LT
cmp_prov (LocalDef loc1 _) (LocalDef loc2 _) = loc1 `compare` loc2
cmp_prov (NonLocalDef (UserImport m1 loc1 _) _)
(NonLocalDef (UserImport m2 loc2 _) _) =
(m1 `compare` m2) `thenCmp` (loc1 `compare` loc2)
cmp_prov (NonLocalDef _ _) (LocalDef _ _) = GT
-- In-scope NonLocalDefs must have UserImport info on them
-------------------------
......@@ -736,13 +726,13 @@ warnUnusedGroup names
| otherwise
= pushSrcLocRn def_loc $
addWarnRn $
sep [msg <> colon, nest 4 (fsep (punctuate comma (map ppr filtered_names)))]
sep [msg <> colon, nest 4 (fsep (punctuate comma (map (ppr.fst) filtered_names)))]
where
filtered_names = filter reportable names
(name1, prov1) = head filtered_names
(is_local, def_loc, msg)
= case prov1 of
LocalDef loc _ -> (True, loc, text "Defined but not used")
LocalDef -> (True, getSrcLoc name1, text "Defined but not used")
NonLocalDef (UserImport mod loc _) _
-> (True, loc, text "Imported from" <+> quotes (ppr mod) <+> text "but not used")
......
......@@ -699,15 +699,15 @@ getInterfaceExports mod_name from
= getHomeSymbolTableRn `thenRn` \ hst ->
case lookupModuleEnvByName hst mod_name of {
Just mds -> returnRn (mdModule mds, mdExports mds) ;
loadInterface doc_str mod_name from `thenRn` \ ifaces ->
case lookupModuleEnv (iPST ifaces) mod_name of
Just mds -> returnRn (mdModule mod, mdExports mds)
-- loadInterface always puts something in the map
-- even if it's a fake
where
doc_str = sep [pprModuleName mod_name, ptext SLIT("is directly imported")]
}
where
doc_str = sep [pprModuleName mod_name, ptext SLIT("is directly imported")]
\end{code}
......
......@@ -60,7 +60,8 @@ import UniqSupply
import Outputable
import Finder ( Finder )
import PrelNames ( mkUnboundName )
import HscTypes ( GlobalSymbolTable, OrigNameEnv, AvailEnv,
import HscTypes ( GlobalSymbolTable, AvailEnv,
OrigNameEnv(..), OrigNameNameEnv, OrigNameIParamEnv,
WhetherHasOrphans, ImportVersion, ExportItem,
PersistentRenamerState(..), IsBootInterface, Avails,
DeclsMap, IfaceInsts, IfaceRules, DeprecationEnv,
......@@ -120,7 +121,9 @@ data RnDown
rn_hst :: HomeSymbolTable,
rn_errs :: IORef (Bag WarnMsg, Bag ErrMsg),
rn_ns :: IORef (UniqSupply, OrigNameEnv),
-- The second and third components are a flattened-out OrigNameEnv
rn_ns :: IORef (UniqSupply, OrigNameNameEnv, OrigNameIParamEnv),
rn_ifaces :: IORef Ifaces
}
......@@ -275,7 +278,8 @@ initRn dflags finder hst pcs mod loc do_rn
= do
let prs = pcs_PRS pcs
uniqs <- mkSplitUniqSupply 'r'
names_var <- newIORef (uniqs, prsOrig prs)
names_var <- newIORef (uniqs, origNames (prsOrig prs),
origIParam (prsOrig prs))
errs_var <- newIORef (emptyBag,emptyBag)
iface_var <- newIORef (initIfaces pcs)
let rn_down = RnDown { rn_mod = mod,
......@@ -294,11 +298,11 @@ initRn dflags finder hst pcs mod loc do_rn
res <- do_rn rn_down ()
-- Grab state and record it
(warns, errs) <- readIORef errs_var
new_ifaces <- readIORef iface_var
(_, new_orig) <- readIORef names_var
let new_prs = prs { prsOrig = new_orig,
(warns, errs) <- readIORef errs_var
new_ifaces <- readIORef iface_var
(_, new_origN, new_origIP) <- readIORef names_var
let new_orig = Orig { origNames = new_origN, origIParam = new_origIP }
let new_prs = prs { prsOrig = new_orig,
prsDecls = iDecls new_ifaces,
prsInsts = iInsts new_ifaces,
prsRules = iRules new_ifaces }
......@@ -360,9 +364,10 @@ renameSourceCode dflags mod prs m
-- only do any I/O if we need to read in a fixity declaration;
-- and that doesn't happen in pragmas etc
mkSplitUniqSupply 'r' >>= \ new_us ->
newIORef (new_us, prsOrig prs) >>= \ names_var ->
newIORef (emptyBag,emptyBag) >>= \ errs_var ->
mkSplitUniqSupply 'r' >>= \ new_us ->
newIORef (new_us, origNames (prsOrig prs),
origIParam (prsOrig prs)) >>= \ names_var ->
newIORef (emptyBag,emptyBag) >>= \ errs_var ->
let
rn_down = RnDown { rn_dflags = dflags,
rn_loc = generatedSrcLoc, rn_ns = names_var,
......@@ -551,21 +556,21 @@ getHomeSymbolTableRn down l_down = return (rn_hst down)
%=====================
\begin{code}
getNameSupplyRn :: RnM d (UniqSupply, OrigNameEnv)
getNameSupplyRn :: RnM d (UniqSupply, OrigNameNameEnv, OrigNameIParamEnv)
getNameSupplyRn rn_down l_down
= readIORef (rn_ns rn_down)
setNameSupplyRn :: (UniqSupply, OrigNameEnv) -> RnM d ()
setNameSupplyRn :: (UniqSupply, OrigNameNameEnv, OrigNameIParamEnv) -> RnM d ()
setNameSupplyRn names' (RnDown {rn_ns = names_var}) l_down
= writeIORef names_var names'
getUniqRn :: RnM d Unique
getUniqRn (RnDown {rn_ns = names_var}) l_down
= readIORef names_var >>= \ (us, {-cache,-} ipcache) ->
= readIORef names_var >>= \ (us, cache, ipcache) ->
let
(us1,us') = splitUniqSupply us
in
writeIORef names_var (us', {-cache,-} ipcache) >>
writeIORef names_var (us', cache, ipcache) >>
return (uniqFromSupply us1)
\end{code}
......
......@@ -48,7 +48,7 @@ import Type ( tyVarsOfTypes, splitFunTy, applyTys,
)
import TysWiredIn ( unitTy )
import VarSet ( intersectVarSet, isEmptyVarSet )
import PrelNames ( unpackCStringIdKey, unpackCStringUtf8IdKey )
import PrelNames ( unpackCStringName, unpackCStringUtf8Name )
import ListSetOps ( equivClasses )
\end{code}
......@@ -263,8 +263,8 @@ mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields)
-- data type use the same type variables
= checkTc (all (== field_ty) other_tys)
(fieldTypeMisMatch field_name) `thenTc_`
tcLookupGlobalId unpackCStringIdName `thenTc` \ unpack_id ->
tcLookupGlobalId unpackCStringUtf8IdName `thenTc` \ unpackUtf8_id ->
tcLookupGlobalId unpackCStringName `thenTc` \ unpack_id ->
tcLookupGlobalId unpackCStringUtf8Name `thenTc` \ unpackUtf8_id ->
returnTc (mkRecordSelId tycon first_field_label unpack_id unpackUtf8_id)
where
field_ty = fieldLabelType first_field_label
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment