Commit 33d4a6bd authored by simonpj's avatar simonpj

[project @ 2000-10-24 15:55:35 by simonpj]

More renamer
parent 96226887
......@@ -14,8 +14,7 @@ We could either use this, or parameterise @GenCoreExpr@ on @Types@ and
module HsCore (
UfExpr(..), UfAlt, UfBinder(..), UfNote(..),
UfBinding(..), UfConAlt(..),
HsIdInfo(..),
IfaceSig(..), ifaceSigName,
HsIdInfo(..), pprHsIdInfo,
eq_ufExpr, eq_ufBinders, pprUfExpr,
......@@ -315,26 +314,6 @@ eq_ufConAlt env _ _ = False
\end{code}
%************************************************************************
%* *
\subsection{Signatures in interface files}
%* *
%************************************************************************
\begin{code}
data IfaceSig name = IfaceSig name (HsType name) [HsIdInfo name] SrcLoc
instance Ord name => Eq (IfaceSig name) where
(==) (IfaceSig n1 t1 i1 _) (IfaceSig n2 t2 i2 _) = n1==n2 && t1==t2 && i1==i2
instance (Outputable name) => Outputable (IfaceSig name) where
ppr (IfaceSig var ty info _) = hsep [ppr var, dcolon, ppr ty, pprHsIdInfo info]
ifaceSigName :: IfaceSig name -> name
ifaceSigName (IfaceSig name _ _ _) = name
\end{code}
%************************************************************************
%* *
\subsection{Rules in interface files}
......
......@@ -13,7 +13,6 @@ module HsDecls (
ExtName(..), isDynamicExtName, extNameStatic,
ConDecl(..), ConDetails(..),
BangType(..), getBangType,
IfaceSig(..),
DeprecDecl(..), DeprecTxt,
hsDeclName, instDeclName, tyClDeclName, tyClDeclNames,
isClassDecl, isSynDecl, isDataDecl, countTyClDecls, toHsRule,
......@@ -28,7 +27,7 @@ import HsBinds ( HsBinds, MonoBinds, Sig(..), FixitySig(..) )
import HsExpr ( HsExpr )
import HsTypes
import PprCore ( pprCoreRule )
import HsCore ( UfExpr(UfVar), UfBinder, IfaceSig(..), ifaceSigName,
import HsCore ( UfExpr(UfVar), UfBinder, HsIdInfo, pprHsIdInfo,
eq_ufBinders, eq_ufExpr, pprUfExpr, toUfExpr, toUfBndr
)
import CoreSyn ( CoreRule(..) )
......@@ -58,7 +57,6 @@ data HsDecl name pat
| DefD (DefaultDecl name)
| ValD (HsBinds name pat)
| ForD (ForeignDecl name)
| SigD (IfaceSig name)
| FixD (FixitySig name)
| DeprecD (DeprecDecl name)
| RuleD (RuleDecl name pat)
......@@ -84,7 +82,6 @@ hsDeclName :: (Outputable name, Outputable pat)
#endif
hsDeclName (TyClD decl) = tyClDeclName decl
hsDeclName (InstD decl) = instDeclName decl
hsDeclName (SigD decl) = ifaceSigName decl
hsDeclName (ForD (ForeignDecl name _ _ _ _ _)) = name
hsDeclName (FixD (FixitySig name _ _)) = name
-- Others don't make sense
......@@ -103,7 +100,6 @@ instance (Outputable name, Outputable pat)
=> Outputable (HsDecl name pat) where
ppr (TyClD dcl) = ppr dcl
ppr (SigD sig) = ppr sig
ppr (ValD binds) = ppr binds
ppr (DefD def) = ppr def
ppr (InstD inst) = ppr inst
......@@ -117,7 +113,6 @@ instance (Outputable name, Outputable pat)
instance Ord name => Eq (HsDecl name pat) where
-- Used only when comparing interfaces,
-- at which time only signature and type/class decls
(SigD s1) == (SigD s2) = s1 == s2
(TyClD d1) == (TyClD d2) = d1 == d2
_ == _ = False
\end{code}
......@@ -173,7 +168,12 @@ Plan of attack:
\begin{code}
data TyClDecl name pat
= TyData NewOrData
= IfaceSig name -- It may seem odd to classify an interface-file signature
(HsType name) -- as a 'TyClDecl', but it's very convenient. These three
[HsIdInfo name] -- are the kind that appear in interface files.
SrcLoc
| TyData NewOrData
(HsContext name) -- context
name -- type constructor
[HsTyVarBndr name] -- type variables
......@@ -202,6 +202,7 @@ data TyClDecl name pat
SrcLoc
tyClDeclName :: TyClDecl name pat -> name
tyClDeclName (IfaceSig name _ _ _) = name
tyClDeclName (TyData _ _ name _ _ _ _ _ _ _) = name
tyClDeclName (TySynonym name _ _ _) = name
tyClDeclName (ClassDecl _ name _ _ _ _ _ _) = name
......@@ -222,6 +223,7 @@ tyClDeclNames (ClassDecl _ name _ _ sigs _ _ loc)
tyClDeclNames (TyData _ _ name _ cons _ _ loc _ _)
= (name,loc) : conDeclsNames cons
tyClDeclNames (IfaceSig _ _ _ _) = []
type ClassDeclSysNames name = [name]
-- [tycon, datacon wrapper, datacon worker,
......@@ -252,6 +254,9 @@ isClassDecl other = False
\begin{code}
instance Ord name => Eq (TyClDecl name pat) where
-- Used only when building interface files
(==) (IfaceSig n1 t1 i1 _)
(IfaceSig n2 t2 i2 _) = n1==n2 && t1==t2 && i1==i2
(==) (TyData nd1 cxt1 n1 tvs1 cons1 _ _ _ _ _)
(TyData nd2 cxt2 n2 tvs2 cons2 _ _ _ _ _)
= n1 == n2 &&
......@@ -294,19 +299,22 @@ eq_cls_sig env (ClassOpSig n1 dm1 ty1 _) (ClassOpSig n2 dm2 ty2 _)
\end{code}
\begin{code}
countTyClDecls :: [TyClDecl name pat] -> (Int, Int, Int, Int)
countTyClDecls :: [TyClDecl name pat] -> (Int, Int, Int, Int, Int)
-- class, data, newtype, synonym decls
countTyClDecls decls
= (length [() | ClassDecl _ _ _ _ _ _ _ _ <- decls],
length [() | TyData DataType _ _ _ _ _ _ _ _ _ <- decls],
length [() | TyData NewType _ _ _ _ _ _ _ _ _ <- decls],
length [() | TySynonym _ _ _ _ <- decls])
length [() | TySynonym _ _ _ _ <- decls],
length [() | IfaceSig _ _ _ _ <- decls])
\end{code}
\begin{code}
instance (Outputable name, Outputable pat)
=> Outputable (TyClDecl name pat) where
ppr (IfaceSig var ty info _) = hsep [ppr var, dcolon, ppr ty, pprHsIdInfo info]
ppr (TySynonym tycon tyvars mono_ty src_loc)
= hang (ptext SLIT("type") <+> pp_decl_head [] tycon tyvars <+> equals)
4 (ppr mono_ty)
......
......@@ -67,7 +67,7 @@ ppSourceStats short (HsModule name version exports imports decls _ src_loc)
-- in class decls. ToDo
tycl_decls = [d | TyClD d <- decls]
(class_ds, data_ds, newt_ds, type_ds) = countTyClDecls tycl_decls
(class_ds, data_ds, newt_ds, type_ds, _) = countTyClDecls tycl_decls
inst_decls = [d | InstD d <- decls]
inst_ds = length inst_decls
......
......@@ -60,8 +60,8 @@ import TyCon ( TyCon )
import BasicTypes ( Version, initialVersion, Fixity )
import HsSyn ( DeprecTxt )
import RdrHsSyn ( RdrNameHsDecl )
import RnHsSyn ( RenamedTyClDecl, RenamedIfaceSig, RenamedRuleDecl, RenamedInstDecl )
import RdrHsSyn ( RdrNameHsDecl, RdrNameTyClDecl )
import RnHsSyn ( RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl )
import CoreSyn ( CoreRule )
import Type ( Type )
......@@ -138,7 +138,6 @@ data ModIface
}
data IfaceDecls = IfaceDecls { dcl_tycl :: [RenamedTyClDecl], -- Sorted
dcl_sigs :: [RenamedIfaceSig], -- Sorted
dcl_rules :: [RenamedRuleDecl], -- Sorted
dcl_insts :: [RenamedInstDecl] } -- Unsorted
......@@ -451,7 +450,7 @@ including the constructors of a type decl etc. The Bool is True just
for the 'main' Name.
\begin{code}
type DeclsMap = NameEnv (AvailInfo, Bool, (Module, RdrNameHsDecl))
type DeclsMap = NameEnv (AvailInfo, Bool, (Module, RdrNameTyClDecl))
type IfaceInsts = Bag GatedDecl
type IfaceRules = Bag GatedDecl
......
......@@ -67,14 +67,15 @@ import List ( partition )
%************************************************************************
\begin{code}
completeModDetails :: ModDetails
-> [CoreBind] -> [Id] -- Final bindings, plus the top-level Ids from the
-- code generator; they have authoritative arity info
-> [ProtoCoreRule] -- Tidy orphan rules
-> ModDetails
completeIface :: Maybe ModIface -- The old interface, if we have it
-> ModIface -- The new one, minus the decls and versions
-> ModDetails -- The ModDetails for this module
-> [CoreBind] -> [Id] -- Final bindings, plus the top-level Ids from the
-- code generator; they have authoritative arity info
-> [ProtoCoreRule] -- Tidy orphan rules
-> Maybe (ModIface, SDoc) -- The new one, complete with decls and versions
-- The SDoc is a debug document giving differences
-- Nothing => no change
......@@ -94,9 +95,8 @@ completeIface maybe_old_iface new_iface mod_details
declsFromDetails :: ModDetails -> [CoreBind] -> [Id] -> [ProtoCoreRule] -> IfaceDecls
declsFromDetails details tidy_binds final_ids tidy_orphan_rules
= IfaceDecls { dcl_tycl = ty_cls_dcls,
= IfaceDecls { dcl_tycl = ty_cls_dcls ++ bagToList val_dcls,
dcl_insts = inst_dcls,
dcl_sigs = bagToList val_dcls,
dcl_rules = rule_dcls }
where
dfun_ids = md_insts details
......@@ -326,7 +326,7 @@ ifaceId :: (Id -> IdInfo) -- This function "knows" the extra info added
-> Bool -- True <=> recursive, so don't print unfolding
-> Id
-> CoreExpr -- The Id's right hand side
-> (RenamedIfaceSig, IdSet) -- The emitted stuff, plus any *extra* needed Ids
-> (RenamedTyClDecl, IdSet) -- The emitted stuff, plus any *extra* needed Ids
ifaceId get_idinfo is_rec id rhs
= (IfaceSig (getName id) (toHsType id_type) hs_idinfo noSrcLoc, new_needed_ids)
......@@ -484,7 +484,7 @@ addVersionInfo (Just old_iface@(ModIface { mi_version = old_version,
vers_rules = bumpVersion no_rule_change (vers_rules old_version),
vers_decls = sig_vers `plusNameEnv` tc_vers }
no_output_change = no_sig_change && no_tc_change && no_rule_change && no_export_change
no_output_change = no_tc_change && no_rule_change && no_export_change
no_usage_change = mi_usages old_iface == mi_usages new_iface
no_export_change = mi_exports old_iface == mi_exports new_iface -- Kept sorted
......@@ -494,30 +494,24 @@ addVersionInfo (Just old_iface@(ModIface { mi_version = old_version,
-- Set the flag if anything changes.
-- Assumes that the decls are sorted by hsDeclName.
old_vers_decls = vers_decls old_version
(no_sig_change, pp_sig_diffs, sig_vers) = diffDecls ifaceSigName eq_sig old_vers_decls
(dcl_sigs old_decls) (dcl_sigs new_decls)
(no_tc_change, pp_tc_diffs, tc_vers) = diffDecls tyClDeclName eq_tc old_vers_decls
(dcl_tycl old_decls) (dcl_tycl new_decls)
(no_tc_change, pp_tc_diffs, tc_vers) = diffDecls old_vers_decls (dcl_tycl old_decls) (dcl_tycl new_decls)
-- When seeing if two decls are the same,
-- remember to check whether any relevant fixity has changed
eq_sig i1 i2 = i1 == i2 && same_fixity (ifaceSigName i1)
eq_tc d1 d2 = d1 == d2 && all (same_fixity . fst) (tyClDeclNames d1)
same_fixity n = lookupNameEnv old_fixities n == lookupNameEnv new_fixities n
diffDecls :: (Outputable decl)
=> (decl->Name)
-> (decl->decl->Bool) -- True if no change
-> NameEnv Version -- Old version map
-> [decl] -> [decl] -- Old and new decls
diffDecls :: NameEnv Version -- Old version map
-> [RenamedTyClDecl] -> [RenamedTyClDecl] -- Old and new decls
-> (Bool, -- True <=> no change
SDoc, -- Record of differences
NameEnv Version) -- New version
diffDecls get_name eq old_vers old new
diffDecls old_vers old new
= diff True empty emptyNameEnv old new
where
-- When seeing if two decls are the same,
-- remember to check whether any relevant fixity has changed
eq_tc d1 d2 = d1 == d2 && all (same_fixity . fst) (tyClDeclNames d1)
same_fixity n = lookupNameEnv old_fixities n == lookupNameEnv new_fixities n
diff ok_so_far pp new_vers [] [] = (ok_so_far, pp, new_vers)
diff ok_so_far pp new_vers old [] = (False, pp, new_vers)
diff ok_so_far pp new_vers [] (nd:nds) = diff False (pp $$ only_new nd) new_vers [] nds
......
......@@ -256,7 +256,6 @@ mk_tc_gen_info mod tc_uniq tc_name tycon
name1 = mkWiredInName mod occ_name1 fn1_key
name2 = mkWiredInName mod occ_name2 fn2_key
gen_info = mkTyConGenInfo tycon name1 name2
Just (EP id1 id2) = gen_info
unitTyCon = tupleTyCon Boxed 0
unitDataConId = dataConId (head (tyConDataCons unitTyCon))
......@@ -576,8 +575,6 @@ data (,) a b = (,,) a b
mkListTy :: Type -> Type
mkListTy ty = mkTyConApp listTyCon [ty]
alphaListTy = mkSigmaTy alpha_tyvar [] (mkTyConApp listTyCon alpha_ty)
listTyCon = pcRecDataTyCon listTyConName
alpha_tyvar [(True,False)] [nilDataCon, consDataCon]
......
......@@ -61,7 +61,7 @@ import OccName ( mkSysOccFS,
)
import Module ( ModuleName, PackageName, mkSysModuleNameFS, mkModule )
import SrcLoc ( SrcLoc )
import CmdLineOpts ( opt_InPackage )
import CmdLineOpts ( opt_InPackage, opt_IgnoreIfacePragmas )
import Outputable
import List ( insert )
import Class ( DefMeth (..) )
......@@ -355,31 +355,47 @@ inst_decl : src_loc 'instance' type '=' var_name ';'
--------------------------------------------------------------------------
decls_part :: { [(Version, RdrNameHsDecl)] }
decls_part :: { [(Version, RdrNameTyClDecl)] }
decls_part
: {- empty -} { [] }
| opt_version decl ';' decls_part { ($1,$2):$4 }
decl :: { RdrNameHsDecl }
decl :: { RdrNameTyClDecl }
decl : src_loc var_name '::' type maybe_idinfo
{ SigD (IfaceSig $2 $4 ($5 $2) $1) }
{ IfaceSig $2 $4 ($5 $2) $1 }
| src_loc 'type' tc_name tv_bndrs '=' type
{ TyClD (TySynonym $3 $4 $6 $1) }
{ TySynonym $3 $4 $6 $1 }
| src_loc 'data' opt_decl_context tc_name tv_bndrs constrs
{ TyClD (mkTyData DataType $3 $4 $5 $6 (length $6) Nothing $1) }
{ mkTyData DataType $3 $4 $5 $6 (length $6) Nothing $1 }
| src_loc 'newtype' opt_decl_context tc_name tv_bndrs newtype_constr
{ TyClD (mkTyData NewType $3 $4 $5 $6 1 Nothing $1) }
{ mkTyData NewType $3 $4 $5 $6 1 Nothing $1 }
| src_loc 'class' opt_decl_context tc_name tv_bndrs fds csigs
{ TyClD (mkClassDecl $3 $4 $5 $6 $7 EmptyMonoBinds $1) }
{ mkClassDecl $3 $4 $5 $6 $7 EmptyMonoBinds $1 }
maybe_idinfo :: { RdrName -> [HsIdInfo RdrName] }
maybe_idinfo : {- empty -} { \_ -> [] }
| pragma { \x -> case $1 of
POk _ (PIdInfo id_info) -> id_info
PFailed err ->
pprPanic "IdInfo parse failed"
(vcat [ppr x, err])
| pragma { \x -> if opt_IgnoreIfacePragmas then []
else case $1 of
POk _ (PIdInfo id_info) -> id_info
PFailed err -> pprPanic "IdInfo parse failed"
(vcat [ppr x, err])
}
{-
If a signature decl is being loaded, and opt_IgnoreIfacePragmas is on,
we toss away unfolding information.
Also, if the signature is loaded from a module we're importing from source,
we do the same. This is to avoid situations when compiling a pair of mutually
recursive modules, peering at unfolding info in the interface file of the other,
e.g., you compile A, it looks at B's interface file and may as a result change
its interface file. Hence, B is recompiled, maybe changing its interface file,
which will the unfolding info used in A to become invalid. Simple way out is to
just ignore unfolding info.
[Jan 99: I junked the second test above. If we're importing from an hi-boot
file there isn't going to *be* any pragma info. The above comment
dates from a time where we picked up a .hi file first if it existed.]
-}
pragma :: { ParseResult IfaceStuff }
pragma : src_loc PRAGMA { parseIface $2 PState{ bol = 0#, atbol = 1#,
......
......@@ -9,25 +9,28 @@ module Rename ( renameModule ) where
#include "HsVersions.h"
import HsSyn
import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameDeprecation )
import RnHsSyn ( RenamedHsDecl,
import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameDeprecation,
RdrNameTyClDecl, RdrNameRuleDecl, RdrNameInstDecl
)
import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl,
extractHsTyNames, extractHsCtxtTyNames
)
import CmdLineOpts ( DynFlags, DynFlag(..) )
import RnMonad
import RnNames ( getGlobalNames )
import RnSource ( rnSourceDecls, rnDecl )
import RnSource ( rnSourceDecls, rnDecl, rnTyClDecl, rnRuleDecl, rnInstDecl )
import RnIfaces ( getImportedInstDecls, importDecl, mkImportInfo,
getInterfaceExports,
getImportedRules, getSlurped,
ImportDeclResult(..)
ImportDeclResult(..),
RecompileRequired, recompileRequired
)
import RnHiFiles ( removeContext )
import RnHiFiles ( findAndReadIface, removeContext, loadExports, loadFixDecls, loadDeprecs )
import RnEnv ( availName, availsToNameSet,
emptyAvailEnv, unitAvailEnv, availEnvElts, plusAvailEnv, sortAvails,
warnUnusedImports, warnUnusedLocalBinds, warnUnusedModules,
lookupOrigNames, lookupGlobalRn,
lookupOrigNames, lookupGlobalRn, newGlobalName,
FreeVars, plusFVs, plusFV, unitFV, emptyFVs, isEmptyFVs, addOneFV
)
import Module ( Module, ModuleName, WhereFrom(..),
......@@ -60,7 +63,8 @@ import Maybes ( maybeToBool, catMaybes )
import Outputable
import IO ( openFile, IOMode(..) )
import HscTypes ( Finder, PersistentCompilerState, HomeIfaceTable, HomeSymbolTable,
ModIface(..), TyThing(..),
ModIface(..), TyThing(..), WhatsImported(..),
VersionInfo(..), ImportVersion, IfaceDecls(..),
GlobalRdrEnv, AvailEnv, Avails, GenAvailInfo(..), AvailInfo,
Provenance(..), ImportReason(..), initialVersionInfo,
Deprecations(..), lookupDeprec
......@@ -70,12 +74,19 @@ import List ( partition, nub )
%*********************************************************
%* *
\subsection{The main function: rename}
%* *
%*********************************************************
\begin{code}
renameModule :: DynFlags -> Finder
-> HomeIfaceTable -> HomeSymbolTable
-> PersistentCompilerState
-> Module -> RdrNameHsModule
-> IO (PersistentCompilerState, Maybe (ModIface, [RenamedHsDecl]))
-- Nothing => some error occurred in the renamer
renameModule dflags finder hit hst old_pcs this_module rdr_module
= -- Initialise the renamer monad
......@@ -86,9 +97,9 @@ renameModule dflags finder hit hst old_pcs this_module rdr_module
-- Dump any debugging output
dump_action ;
-- Return results
-- Return results. No harm in updating the PCS
if errors_found then
return (old_pcs, Nothing)
return (new_pcs, Nothing)
else
return (new_pcs, maybe_rn_stuff)
}
......@@ -332,8 +343,8 @@ slurpSourceRefs source_binders source_fvs
WiredIn -> returnRn (decls, fvs, gates `plusFV` getWiredInGates wanted_name)
Deferred -> returnRn (decls, fvs, gates `addOneFV` wanted_name) -- It's a type constructor
HereItIs decl -> rnIfaceDecl decl `thenRn` \ (new_decl, fvs1) ->
returnRn (new_decl : decls,
HereItIs decl -> rnIfaceTyClDecl decl `thenRn` \ (new_decl, fvs1) ->
returnRn (TyClD new_decl : decls,
fvs1 `plusFV` fvs,
gates `plusFV` getGates source_fvs new_decl)
......@@ -379,8 +390,8 @@ slurpDecl decls fvs wanted_name
= importDecl wanted_name `thenRn` \ import_result ->
case import_result of
-- Found a declaration... rename it
HereItIs decl -> rnIfaceDecl decl `thenRn` \ (new_decl, fvs1) ->
returnRn (new_decl:decls, fvs1 `plusFV` fvs)
HereItIs decl -> rnIfaceTyClDecl decl `thenRn` \ (new_decl, fvs1) ->
returnRn (TyClD new_decl:decls, fvs1 `plusFV` fvs)
-- No declaration... (wired in thing, or deferred, or already slurped)
other -> returnRn (decls, fvs)
......@@ -394,7 +405,8 @@ rnIfaceDecls decls fvs [] = returnRn (decls, fvs)
rnIfaceDecls decls fvs (d:ds) = rnIfaceDecl d `thenRn` \ (new_decl, fvs1) ->
rnIfaceDecls (new_decl:decls) (fvs1 `plusFV` fvs) ds
rnIfaceDecl (mod, decl) = initIfaceRnMS mod (rnDecl decl)
rnIfaceDecl (mod, decl) = initIfaceRnMS mod (rnDecl decl)
rnIfaceTyClDecl (mod, decl) = initIfaceRnMS mod (rnTyClDecl decl)
\end{code}
......@@ -466,10 +478,10 @@ decls for (say) @Eq Wibble@, when they can't possibly be useful.
vars of the source program, and extracts from the decl the gate names.
\begin{code}
getGates source_fvs (SigD (IfaceSig _ ty _ _))
getGates source_fvs (IfaceSig _ ty _ _)
= extractHsTyNames ty
getGates source_fvs (TyClD (ClassDecl ctxt cls tvs _ sigs _ _ _ ))
getGates source_fvs (ClassDecl ctxt cls tvs _ sigs _ _ _ )
= (delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs)
(hsTyVarNames tvs)
`addOneToNameSet` cls)
......@@ -489,12 +501,12 @@ getGates source_fvs (TyClD (ClassDecl ctxt cls tvs _ sigs _ _ _ ))
| otherwise
= emptyFVs
getGates source_fvs (TyClD (TySynonym tycon tvs ty _))
getGates source_fvs (TySynonym tycon tvs ty _)
= delListFromNameSet (extractHsTyNames ty)
(hsTyVarNames tvs)
-- A type synonym type constructor isn't a "gate" for instance decls
getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _ _ _))
getGates source_fvs (TyData _ ctxt tycon tvs cons _ _ _ _ _)
= delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons)
(hsTyVarNames tvs)
`addOneToNameSet` tycon
......@@ -522,8 +534,6 @@ getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _ _ _))
| otherwise = emptyFVs
get_bang bty = extractHsTyNames (getBangType bty)
getGates source_fvs other_decl = emptyFVs
\end{code}
@getWiredInGates@ is just like @getGates@, but it sees a wired-in @Name@
......@@ -630,6 +640,129 @@ rnDeprecs gbl_env Nothing decls
\end{code}
%************************************************************************
%* *
\subsection{Grabbing the old interface file and checking versions}
%* *
%************************************************************************
\begin{code}
checkOldIface :: DynFlags -> Finder
-> HomeIfaceTable -> HomeSymbolTable
-> PersistentCompilerState
-> Module
-> Bool -- Source unchanged
-> Maybe ModIface -- Old interface from compilation manager, if any
-> IO (PersistentCompilerState, Bool, (RecompileRequired, Maybe ModIface))
-- True <=> errors happened
checkOldIface dflags finder hit hst pcs mod source_unchanged maybe_iface
= initRn dflags finder hit hst pcs mod $
-- Load the old interface file, if we havn't already got it
loadOldIface mod maybe_iface `thenRn` \ maybe_iface ->
-- Check versions
recompileRequired mod source_unchanged maybe_iface `thenRn` \ recompile ->
returnRn (recompile, maybe_iface)
\end{code}
\begin{code}
loadOldIface :: Module -> Maybe ModIface -> RnMG (Maybe ModIface)
loadOldIface mod (Just iface)
= returnRn (Just iface)
loadOldIface mod Nothing
= -- LOAD THE OLD INTERFACE FILE
findAndReadIface doc_str (moduleName mod) False {- Not hi-boot -} `thenRn` \ read_result ->
case read_result of {
Left err -> -- Old interface file not found, or garbled, so we'd better bail out
traceRn (vcat [ptext SLIT("No old interface file:"), err]) `thenRn_`
returnRn Nothing ;
Right (_, iface) ->
-- RENAME IT
initIfaceRnMS mod (
loadHomeDecls (pi_decls iface) `thenRn` \ decls ->
loadHomeRules (pi_rules iface) `thenRn` \ rules ->
loadHomeInsts (pi_insts iface) `thenRn` \ insts ->
returnRn (decls, rules, insts)
) `thenRn` \ ((decls_vers, new_decls), (rule_vers, new_rules), new_insts) ->
mapRn loadHomeUsage (pi_usages iface) `thenRn` \ usages ->
loadExports (pi_exports iface) `thenRn` \ (export_vers, avails) ->
loadFixDecls mod (pi_fixity iface) `thenRn` \ fix_env ->
loadDeprecs mod (pi_deprecs iface) `thenRn` \ deprec_env ->
let
version = VersionInfo { vers_module = pi_vers iface,
vers_exports = export_vers,
vers_rules = rule_vers,
vers_decls = decls_vers }
decls = IfaceDecls { dcl_tycl = new_decls,
dcl_rules = new_rules,
dcl_insts = new_insts }
mod_iface = ModIface { mi_module = mod, mi_version = version,
mi_exports = avails, mi_orphan = pi_orphan iface,
mi_fixities = fix_env, mi_deprecs = deprec_env,
mi_usages = usages,
mi_decls = decls,
mi_globals = panic "No mi_globals in old interface"
}
in
returnRn (Just mod_iface)
}
where
doc_str = ptext SLIT("need usage info from") <+> ppr mod
\end{code}
\begin{code}
loadHomeDecls :: [(Version, RdrNameTyClDecl)]
-> RnMS (NameEnv Version, [RenamedTyClDecl])
loadHomeDecls decls = foldlRn loadHomeDecl (emptyNameEnv, []) decls
loadHomeDecl :: (NameEnv Version, [RenamedTyClDecl])
-> (Version, RdrNameTyClDecl)
-> RnMS (NameEnv Version, [RenamedTyClDecl])
loadHomeDecl (version_map, decls) (version, decl)
= rnTyClDecl decl `thenRn` \ (decl', _) ->
returnRn (extendNameEnv version_map (tyClDeclName decl') version, decl':decls)
------------------
loadHomeRules :: (Version, [RdrNameRuleDecl])
-> RnMS (Version, [RenamedRuleDecl])
loadHomeRules (version, rules)
= mapAndUnzipRn rnRuleDecl rules `thenRn` \ (rules', _) ->
returnRn (version, rules')
------------------
loadHomeInsts :: [RdrNameInstDecl]
-> RnMS [RenamedInstDecl]
loadHomeInsts insts = mapAndUnzipRn rnInstDecl insts `thenRn` \ (insts', _) ->
returnRn insts'
------------------
loadHomeUsage :: ImportVersion OccName
-> RnMG (ImportVersion Name)
loadHomeUsage (mod_name, orphans, is_boot, whats_imported)
= rn_imps whats_imported `thenRn` \ whats_imported' ->
returnRn (mod_name, orphans, is_boot, whats_imported')
where
rn_imps NothingAtAll = returnRn NothingAtAll
rn_imps (Everything v) = returnRn (Everything v)
rn_imps (Specifically mv ev items rv) = mapRn rn_imp items `thenRn` \ items' ->
returnRn (Specifically mv ev items' rv)
rn_imp (occ,vers) = newGlobalName mod_name occ `thenRn` \ name ->
returnRn (name,vers)
\end{code}
%*********************************************************
%* *
\subsection{Unused names}
......@@ -839,7 +972,7 @@ getRnStats imported_decls
not (isLocallyDefined (availName avail))
]
(cd_rd, dd_rd, nd_rd, sd_rd, vd_rd, _) = count_decls decls_read
(cd_rd, dd_rd, nd_rd, sd_rd, vd_rd) = countTyClDecls decls_read
(cd_sp, dd_sp, nd_sp, sd_sp, vd_sp, id_sp) = count_decls imported_decls
unslurped_insts = iInsts ifaces
......@@ -863,7 +996,7 @@ getRnStats imported_decls
text "cls dcls slurp" <+> fsep (map (ppr . tyClDeclName)
[d | TyClD d <- imported_decls, isClassDecl d]),
text "cls dcls read" <+> fsep (map (ppr . tyClDeclName)