Make RnEnv compile.
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,
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(..),
import Panic ( panic )
import Outputable
import SrcLoc ( SrcLoc, isGoodSrcLoc )
+import Util ( thenCmp )
\end{code}
%************************************************************************
\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}
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'
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,
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 }
exports_part :: { [ExportItem] }
exports_part : { [] }
| '__export' mod_name entities ';'
- exports_part { (mkSysModuleNameFS $2, $3) : $5 }
+ exports_part { ({-mkSysModuleNameFS-} $2, $3) : $5 }
entities :: { [RdrAvailInfo] }
entities : { [] }
import CmdLineOpts
\end{code}
-
-
%*********************************************************
%* *
\subsection{Making new names}
%*********************************************************
\begin{code}
-implicitImportProvenance = NonLocalDef ImplicitImport False
-
newTopBinder :: Module -> RdrName -> SrcLoc -> RnM d Name
newTopBinder mod rdr_name loc
= -- First check the cache
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:
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)
(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,
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) <+>
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
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
-------------------------
| 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")
= 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}
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,
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
}
= 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,
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 }
-- 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,
%=====================
\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}
)
import TysWiredIn ( unitTy )
import VarSet ( intersectVarSet, isEmptyVarSet )
-import PrelNames ( unpackCStringIdKey, unpackCStringUtf8IdKey )
+import PrelNames ( unpackCStringName, unpackCStringUtf8Name )
import ListSetOps ( equivClasses )
\end{code}
-- 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
projects / ghc-hetmet.git / commitdiff