module HsCore (
UfExpr(..), UfAlt, UfBinder(..), UfNote(..),
UfBinding(..), UfConAlt(..),
- HsIdInfo(..),
- IfaceSig(..), ifaceSigName,
+ HsIdInfo(..), pprHsIdInfo,
eq_ufExpr, eq_ufBinders, pprUfExpr,
%************************************************************************
%* *
-\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}
%* *
%************************************************************************
ExtName(..), isDynamicExtName, extNameStatic,
ConDecl(..), ConDetails(..),
BangType(..), getBangType,
- IfaceSig(..),
DeprecDecl(..), DeprecTxt,
hsDeclName, instDeclName, tyClDeclName, tyClDeclNames,
isClassDecl, isSynDecl, isDataDecl, countTyClDecls, toHsRule,
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(..) )
| DefD (DefaultDecl name)
| ValD (HsBinds name pat)
| ForD (ForeignDecl name)
- | SigD (IfaceSig name)
| FixD (FixitySig name)
| DeprecD (DeprecDecl name)
| RuleD (RuleDecl name 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
=> 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
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}
\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
SrcLoc
tyClDeclName :: TyClDecl name pat -> name
+tyClDeclName (IfaceSig name _ _ _) = name
tyClDeclName (TyData _ _ name _ _ _ _ _ _ _) = name
tyClDeclName (TySynonym name _ _ _) = name
tyClDeclName (ClassDecl _ name _ _ _ _ _ _) = name
tyClDeclNames (TyData _ _ name _ cons _ _ loc _ _)
= (name,loc) : conDeclsNames cons
+tyClDeclNames (IfaceSig _ _ _ _) = []
type ClassDeclSysNames name = [name]
-- [tycon, datacon wrapper, datacon worker,
\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 &&
\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)
-- 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
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 )
}
data IfaceDecls = IfaceDecls { dcl_tycl :: [RenamedTyClDecl], -- Sorted
- dcl_sigs :: [RenamedIfaceSig], -- Sorted
dcl_rules :: [RenamedRuleDecl], -- Sorted
dcl_insts :: [RenamedInstDecl] } -- Unsorted
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
%************************************************************************
\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
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
-> 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)
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
-- 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
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))
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]
)
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 (..) )
--------------------------------------------------------------------------
-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#,
#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(..),
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
+%*********************************************************
+%* *
+\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
-- 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)
}
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)
= 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)
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}
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)
| 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
| 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@
\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}
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
text "cls dcls slurp" <+> fsep (map (ppr . tyClDeclName)
[d | TyClD d <- imported_decls, isClassDecl d]),
text "cls dcls read" <+> fsep (map (ppr . tyClDeclName)
- [d | TyClD d <- decls_read, isClassDecl d])]
+ [d | d <- decls_read, isClassDecl d])]
in
returnRn (hcat [text "Renamer stats: ", stats])
inst_decls)
where
tycl_decls = [d | TyClD d <- decls]
- (class_decls, data_decls, newtype_decls, syn_decls) = countTyClDecls tycl_decls
+ (class_decls, data_decls, newtype_decls, syn_decls, val_decls) = countTyClDecls tycl_decls
- val_decls = length [() | SigD _ <- decls]
inst_decls = length [() | InstD _ <- decls]
\end{code}
module RnHiFiles (
findAndReadIface, loadInterface, loadHomeInterface,
tryLoadInterface, loadOrphanModules,
+ loadExports, loadFixDecls, loadDeprecs,
- getDeclBinders, getDeclSysBinders,
+ getTyClDeclBinders,
removeContext -- removeContext probably belongs somewhere else
) where
import CmdLineOpts ( opt_IgnoreIfacePragmas )
import HscTypes
-import HsSyn ( HsDecl(..), TyClDecl(..), InstDecl(..), IfaceSig(..),
+import HsSyn ( HsDecl(..), TyClDecl(..), InstDecl(..),
HsType(..), ConDecl(..),
- ForeignDecl(..), ForKind(..), isDynamicExtName,
FixitySig(..), RuleDecl(..),
tyClDeclNames
)
-import BasicTypes ( Version )
-import RdrHsSyn ( RdrNameHsDecl, RdrNameInstDecl, RdrNameRuleDecl,
+import RdrHsSyn ( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl,
extractHsTyRdrNames
)
+import BasicTypes ( Version )
import RnEnv
import RnMonad
import ParseIface ( parseIface, IfaceStuff(..) )
import Name ( Name {-instance NamedThing-}, nameOccName,
nameModule,
NamedThing(..),
- mkNameEnv, elemNameEnv, extendNameEnv
+ mkNameEnv, extendNameEnv
)
import Module ( Module,
moduleName, isModuleInThisPackage,
loadDecls mod (iDecls ifaces) (pi_decls iface) `thenRn` \ (decls_vers, new_decls) ->
loadRules mod (iRules ifaces) (pi_rules iface) `thenRn` \ (rule_vers, new_rules) ->
- loadFixDecls mod_name (pi_fixity iface) `thenRn` \ fix_env ->
- loadDeprecs mod (pi_deprecs iface) `thenRn` \ deprec_env ->
foldlRn (loadInstDecl mod) (iInsts ifaces) (pi_insts iface) `thenRn` \ new_insts ->
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,
loadDecls :: Module
-> DeclsMap
- -> [(Version, RdrNameHsDecl)]
+ -> [(Version, RdrNameTyClDecl)]
-> RnM d (NameEnv Version, DeclsMap)
loadDecls mod decls_map decls
= foldlRn (loadDecl mod) (emptyNameEnv, decls_map) decls
loadDecl :: Module
-> (NameEnv Version, DeclsMap)
- -> (Version, RdrNameHsDecl)
+ -> (Version, RdrNameTyClDecl)
-> RnM d (NameEnv Version, DeclsMap)
loadDecl mod (version_map, decls_map) (version, decl)
- = getDeclBinders new_name decl `thenRn` \ maybe_avail ->
- case maybe_avail of {
- Nothing -> returnRn (version_map, decls_map); -- No bindings
- Just avail ->
-
- getDeclSysBinders new_name decl `thenRn` \ sys_bndrs ->
+ = getIfaceDeclBinders new_name decl `thenRn` \ full_avail ->
let
- full_avail = addSysAvails avail sys_bndrs
- -- Add the sys-binders to avail. When we import the decl,
- -- it's full_avail that will get added to the 'already-slurped' set (iSlurp)
- -- If we miss out sys-binders, we'll read the decl multiple times!
-
- main_name = availName avail
- new_decls_map = foldl add_decl decls_map
- [ (name, (full_avail, name==main_name, (mod, decl')))
- | name <- availNames full_avail]
- add_decl decls_map (name, stuff)
- = WARN( name `elemNameEnv` decls_map, ppr name )
- extendNameEnv decls_map name stuff
+ main_name = availName full_avail
+ new_decls_map = extendNameEnvList decls_map stuff
+ stuff = [ (name, (full_avail, name==main_name, (mod, decl)))
+ | name <- availNames full_avail]
new_version_map = extendNameEnv version_map main_name version
in
returnRn (new_version_map, new_decls_map)
- }
where
-- newTopBinder puts into the cache the binder with the
-- module information set correctly. When the decl is later renamed,
-- the occurrences, so that doesn't matter
new_name rdr_name loc = newTopBinder mod rdr_name loc
- {-
- If a signature decl is being loaded, and optIgnoreIfacePragmas 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. Maybe the above comment
- dates from a time where we picked up a .hi file first if it existed?]
- -}
- decl' = case decl of
- SigD (IfaceSig name tp ls loc) | opt_IgnoreIfacePragmas
- -> SigD (IfaceSig name tp [] loc)
- other -> decl
-----------------------------------------------------
-- Loading fixity decls
-----------------------------------------------------
-loadFixDecls mod_name decls
+loadFixDecls mod decls
= mapRn (loadFixDecl mod_name) decls `thenRn` \ to_add ->
returnRn (mkNameEnv to_add)
+ where
+ mod_name = moduleName mod
loadFixDecl mod_name sig@(FixitySig rdr_name fixity loc)
= newGlobalName mod_name (rdrNameOcc rdr_name) `thenRn` \ name ->
loadDeprecs :: Module -> IfaceDeprecs -> RnM d Deprecations
loadDeprecs m Nothing = returnRn NoDeprecs
-loadDeprecs m (Just (Left txt)) = returnRn (DeprecAll txt)
+loadDeprecs m (Just (Left txt)) = returnRn (DeprecAll txt)
loadDeprecs m (Just (Right prs)) = setModuleRn m $
foldlRn loadDeprec emptyNameEnv prs `thenRn` \ env ->
returnRn (DeprecSome env)
are handled by the sourc-code specific stuff in @RnNames@.
\begin{code}
-getDeclBinders :: (RdrName -> SrcLoc -> RnM d Name) -- New-name function
- -> RdrNameHsDecl
- -> RnM d (Maybe AvailInfo)
+getIfaceDeclBinders, getTyClDeclBinders
+ :: (RdrName -> SrcLoc -> RnM d Name) -- New-name function
+ -> RdrNameTyClDecl
+ -> RnM d AvailInfo
+
+getIfaceDeclBinders new_name tycl_decl
+ = getTyClDeclBinders new_name tycl_decl `thenRn` \ avail ->
+ getSysTyClDeclBinders new_name tycl_decl `thenRn` \ extras ->
+ returnRn (addSysAvails avail extras)
+ -- Add the sys-binders to avail. When we import the decl,
+ -- it's full_avail that will get added to the 'already-slurped' set (iSlurp)
+ -- If we miss out sys-binders, we'll read the decl multiple times!
-getDeclBinders new_name (TyClD tycl_decl)
+getTyClDeclBinders new_name (IfaceSig var ty prags src_loc)
+ = new_name var src_loc `thenRn` \ var_name ->
+ returnRn (Avail var_name)
+
+getTyClDeclBinders new_name tycl_decl
= mapRn do_one (tyClDeclNames tycl_decl) `thenRn` \ (main_name:sub_names) ->
- returnRn (Just (AvailTC main_name (main_name : sub_names)))
+ returnRn (AvailTC main_name (main_name : sub_names))
where
do_one (name,loc) = new_name name loc
-
-getDeclBinders new_name (SigD (IfaceSig var ty prags src_loc))
- = new_name var src_loc `thenRn` \ var_name ->
- returnRn (Just (Avail var_name))
-
- -- foreign declarations
-getDeclBinders new_name (ForD (ForeignDecl nm kind _ dyn _ loc))
- | binds_haskell_name kind dyn
- = new_name nm loc `thenRn` \ name ->
- returnRn (Just (Avail name))
-
- | otherwise -- a foreign export
- = lookupOrigName nm `thenRn_`
- returnRn Nothing
-
-getDeclBinders new_name (FixD _) = returnRn Nothing
-getDeclBinders new_name (DeprecD _) = returnRn Nothing
-getDeclBinders new_name (DefD _) = returnRn Nothing
-getDeclBinders new_name (InstD _) = returnRn Nothing
-getDeclBinders new_name (RuleD _) = returnRn Nothing
-
-binds_haskell_name (FoImport _) _ = True
-binds_haskell_name FoLabel _ = True
-binds_haskell_name FoExport ext_nm = isDynamicExtName ext_nm
\end{code}
@getDeclSysBinders@ gets the implicit binders introduced by a decl.
bindings of their own elsewhere.
\begin{code}
-getDeclSysBinders new_name (TyClD (ClassDecl _ cname _ _ sigs _ names src_loc))
+getSysTyClDeclBinders new_name (ClassDecl _ cname _ _ sigs _ names src_loc)
= sequenceRn [new_name n src_loc | n <- names]
-getDeclSysBinders new_name (TyClD (TyData _ _ _ _ cons _ _ _ _ _))
+getSysTyClDeclBinders new_name (TyData _ _ _ _ cons _ _ _ _ _)
= sequenceRn [new_name wkr_name src_loc | ConDecl _ wkr_name _ _ _ src_loc <- cons]
-getDeclSysBinders new_name other_decl
+getSysTyClDeclBinders new_name other_decl
= returnRn []
\end{code}
+
%*********************************************************
%* *
\subsection{Reading an interface file}
findAndReadIface doc_str mod_name hi_boot_file
= traceRn trace_msg `thenRn_`
- -- we keep two maps for interface files,
- -- one for 'normal' ones, the other for .hi-boot files,
- -- hence the need to signal which kind we're interested.
getFinderRn `thenRn` \ finder ->
ioToRnM (finder mod_name) `thenRn` \ maybe_found ->
type RenamedFixitySig = FixitySig Name
type RenamedDeprecation = DeprecDecl Name
type RenamedHsOverLit = HsOverLit Name
-type RenamedIfaceSig = IfaceSig Name
\end{code}
%************************************************************************
importDecl, ImportDeclResult(..), recordLocalSlurps,
mkImportInfo, getSlurped,
- recompileRequired
+ RecompileRequired, outOfDate, upToDate, recompileRequired
)
where
import HsSyn ( HsDecl(..), InstDecl(..), HsType(..) )
import HsImpExp ( ImportDecl(..) )
import BasicTypes ( Version, defaultFixity )
-import RdrHsSyn ( RdrNameHsDecl, RdrNameInstDecl )
-import RnHiFiles ( tryLoadInterface, loadHomeInterface, loadInterface, loadOrphanModules )
+import RdrHsSyn ( RdrNameHsDecl, RdrNameTyClDecl, RdrNameInstDecl )
+import RnHiFiles ( tryLoadInterface, loadHomeInterface, loadInterface,
+ loadOrphanModules
+ )
import RnEnv
import RnMonad
import Name ( Name {-instance NamedThing-}, nameOccName,
%* *
%*********************************************************
+This has to be in RnIfaces (or RnHiFiles) because it calls loadHomeInterface
+
+\begin{code}
+lookupFixityRn :: Name -> RnMS Fixity
+lookupFixityRn name
+ | isLocallyDefined name
+ = getFixityEnv `thenRn` \ local_fix_env ->
+ returnRn (lookupLocalFixity local_fix_env name)
+
+ | otherwise -- Imported
+ -- For imported names, we have to get their fixities by doing a loadHomeInterface,
+ -- and consulting the Ifaces that comes back from that, because the interface
+ -- file for the Name might not have been loaded yet. Why not? Suppose you import module A,
+ -- which exports a function 'f', which is defined in module B. Then B isn't loaded
+ -- right away (after all, it's possible that nothing from B will be used).
+ -- When we come across a use of 'f', we need to know its fixity, and it's then,
+ -- and only then, that we load B.hi. That is what's happening here.
+ = getHomeIfaceTableRn `thenRn` \ hit ->
+ loadHomeInterface doc name `thenRn` \ ifaces ->
+ case lookupTable hit (iPIT ifaces) name of
+ Just iface -> returnRn (lookupNameEnv (mi_fixities iface) name `orElse` defaultFixity)
+ Nothing -> returnRn defaultFixity
+ where
+ doc = ptext SLIT("Checking fixity for") <+> ppr name
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Instance declarations are handled specially}
+%* *
+%*********************************************************
+
\begin{code}
getImportedInstDecls :: NameSet -> RnMG [(Module,RdrNameHsDecl)]
getImportedInstDecls gates
select (reqd, decl) (yes, no)
| isEmptyNameSet (reqd `minusNameSet` gates) = (decl:yes, no)
| otherwise = (yes, (reqd,decl) `consBag` no)
-
-lookupFixityRn :: Name -> RnMS Fixity
-lookupFixityRn name
- | isLocallyDefined name
- = getFixityEnv `thenRn` \ local_fix_env ->
- returnRn (lookupLocalFixity local_fix_env name)
-
- | otherwise -- Imported
- -- For imported names, we have to get their fixities by doing a loadHomeInterface,
- -- and consulting the Ifaces that comes back from that, because the interface
- -- file for the Name might not have been loaded yet. Why not? Suppose you import module A,
- -- which exports a function 'f', which is defined in module B. Then B isn't loaded
- -- right away (after all, it's possible that nothing from B will be used).
- -- When we come across a use of 'f', we need to know its fixity, and it's then,
- -- and only then, that we load B.hi. That is what's happening here.
- = getHomeIfaceTableRn `thenRn` \ hit ->
- loadHomeInterface doc name `thenRn` \ ifaces ->
- case lookupTable hit (iPIT ifaces) name of
- Just iface -> returnRn (lookupNameEnv (mi_fixities iface) name `orElse` defaultFixity)
- Nothing -> returnRn defaultFixity
- where
- doc = ptext SLIT("Checking fixity for") <+> ppr name
\end{code}
= AlreadySlurped
| WiredIn
| Deferred
- | HereItIs (Module, RdrNameHsDecl)
+ | HereItIs (Module, RdrNameTyClDecl)
importDecl name
= -- Check if it was loaded before beginning this module
upToDate = False -- Recompile not required
outOfDate = True -- Recompile required
-recompileRequired :: DynFlags -> Finder
- -> HomeIfaceTable -> HomeSymbolTable
- -> PersistentCompilerState
- -> Module
+recompileRequired :: Module
-> Bool -- Source unchanged
-> Maybe ModIface -- Old interface, if any
- -> IO (PersistentCompilerState, Bool, RecompileRequired)
- -- True <=> errors happened
-recompileRequired dflags finder hit hst pcs mod source_unchanged maybe_iface
- = initRn dflags finder hit hst pcs mod $
- traceRn (text "Considering whether compilation is required for" <+> ppr mod <> colon) `thenRn_`
+ -> RnMG RecompileRequired
+recompileRequired mod source_unchanged maybe_iface
+ = traceRn (text "Considering whether compilation is required for" <+> ppr mod <> colon) `thenRn_`
-- CHECK WHETHER THE SOURCE HAS CHANGED
if not source_unchanged then
pi_orphan :: WhetherHasOrphans, -- Whether this module has orphans
pi_usages :: [ImportVersion OccName], -- Usages
pi_exports :: (Version, [ExportItem]), -- Exports
- pi_decls :: [(Version, RdrNameHsDecl)], -- Local definitions
+ pi_decls :: [(Version, RdrNameTyClDecl)], -- Local definitions
pi_fixity :: [RdrNameFixitySig], -- Local fixity declarations,
pi_insts :: [RdrNameInstDecl], -- Local instance declarations
pi_rules :: (Version, [RdrNameRuleDecl]), -- Rules, with their version
import CmdLineOpts ( DynFlag(..), opt_NoImplicitPrelude )
import HsSyn ( HsModule(..), HsDecl(..), IE(..), ieName, ImportDecl(..),
+ ForeignDecl(..), ForKind(..), isDynamicExtName,
collectTopBinders
)
import RdrHsSyn ( RdrNameIE, RdrNameImportDecl,
RdrNameHsModule, RdrNameHsDecl
)
import RnIfaces ( getInterfaceExports, recordLocalSlurps )
-import RnHiFiles ( getDeclBinders )
+import RnHiFiles ( getTyClDeclBinders )
import RnEnv
import RnMonad
import RdrName ( RdrName, rdrNameOcc, setRdrNameOcc, mkRdrQual, mkRdrUnqual, isUnqual )
import OccName ( setOccNameSpace, dataName )
import NameSet ( elemNameSet, emptyNameSet )
+import SrcLoc ( SrcLoc )
import Outputable
import Maybes ( maybeToBool, catMaybes, mapMaybe )
import UniqFM ( emptyUFM, listToUFM )
\begin{code}
importsFromLocalDecls mod_name rec_exp_fn decls
- = mapRn (getLocalDeclBinders mod rec_exp_fn) decls `thenRn` \ avails_s ->
+ = mapRn (getLocalDeclBinders (newLocalName mod rec_exp_fn)) decls `thenRn` \ avails_s ->
let
avails = concat avails_s
where
mod = mkModuleInThisPackage mod_name
-getLocalDeclBinders :: Module
- -> (Name -> Bool) -- Is-exported predicate
+---------------------------
+getLocalDeclBinders :: (RdrName -> SrcLoc -> RnMG Name)
-> RdrNameHsDecl -> RnMG Avails
-getLocalDeclBinders mod rec_exp_fn (ValD binds)
+getLocalDeclBinders new_name (ValD binds)
= mapRn do_one (bagToList (collectTopBinders binds))
where
- do_one (rdr_name, loc) = newLocalName mod rec_exp_fn rdr_name loc `thenRn` \ name ->
+ do_one (rdr_name, loc) = new_name rdr_name loc `thenRn` \ name ->
returnRn (Avail name)
-getLocalDeclBinders mod rec_exp_fn decl
- = getDeclBinders (newLocalName mod rec_exp_fn) decl `thenRn` \ maybe_avail ->
- case maybe_avail of
- Nothing -> returnRn [] -- Instance decls and suchlike
- Just avail -> returnRn [avail]
+getLocalDeclBinders new_name (TyClD tycl_decl)
+ = getTyClDeclBinders new_name tycl_decl `thenRn` \ avail ->
+ returnRn [avail]
+getLocalDeclBinders new_name (ForD (ForeignDecl nm kind _ ext_nm _ loc))
+ | binds_haskell_name kind
+ = new_name nm loc `thenRn` \ name ->
+ returnRn [Avail name]
+
+ | otherwise -- a foreign export
+ = lookupOrigName nm `thenRn_`
+ returnRn []
+ where
+ binds_haskell_name (FoImport _) = True
+ binds_haskell_name FoLabel = True
+ binds_haskell_name FoExport = isDynamicExtName ext_nm
+
+getLocalDeclBinders new_name (FixD _) = returnRn []
+getLocalDeclBinders new_name (DeprecD _) = returnRn []
+getLocalDeclBinders new_name (DefD _) = returnRn []
+getLocalDeclBinders new_name (InstD _) = returnRn []
+getLocalDeclBinders new_name (RuleD _) = returnRn []
+
+
+---------------------------
newLocalName mod rec_exp_fn rdr_name loc
= check_unqual rdr_name loc `thenRn_`
newTopBinder mod rdr_name loc `thenRn` \ name ->
\section[RnSource]{Main pass of renamer}
\begin{code}
-module RnSource ( rnDecl, rnSourceDecls, rnHsType, rnHsSigType ) where
+module RnSource ( rnDecl, rnTyClDecl, rnRuleDecl, rnInstDecl,
+ rnSourceDecls, rnHsType, rnHsSigType
+ ) where
#include "HsVersions.h"
rnDecl (ValD binds) = rnTopBinds binds `thenRn` \ (new_binds, fvs) ->
returnRn (ValD new_binds, fvs)
+rnDecl (TyClD tycl_decl) = rnTyClDecl tycl_decl `thenRn` \ (new_decl, fvs) ->
+ returnRn (TyClD new_decl, fvs)
-rnDecl (SigD (IfaceSig name ty id_infos loc))
- = pushSrcLocRn loc $
- lookupTopBndrRn name `thenRn` \ name' ->
- rnHsType doc_str ty `thenRn` \ (ty',fvs1) ->
- mapFvRn rnIdInfo id_infos `thenRn` \ (id_infos', fvs2) ->
- returnRn (SigD (IfaceSig name' ty' id_infos' loc), fvs1 `plusFV` fvs2)
+rnDecl (RuleD rule)
+ = rnRuleDecl rule `thenRn` \ (new_rule, fvs) ->
+ returnRn (RuleD new_rule, fvs)
+
+rnDecl (InstD inst)
+ = rnInstDecl inst `thenRn` \ (new_inst, fvs) ->
+ returnRn (InstD new_inst, fvs)
+
+rnDecl (DefD (DefaultDecl tys src_loc))
+ = pushSrcLocRn src_loc $
+ rnHsTypes doc_str tys `thenRn` \ (tys', fvs) ->
+ returnRn (DefD (DefaultDecl tys' src_loc), fvs)
where
- doc_str = text "the interface signature for" <+> quotes (ppr name)
+ doc_str = text "a `default' declaration"
+
+rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
+ = pushSrcLocRn src_loc $
+ lookupOccRn name `thenRn` \ name' ->
+ let
+ extra_fvs FoExport
+ | isDyn = lookupOrigNames [makeStablePtr_RDR, deRefStablePtr_RDR,
+ bindIO_RDR, returnIO_RDR]
+ | otherwise =
+ lookupOrigNames [bindIO_RDR, returnIO_RDR] `thenRn` \ fvs ->
+ returnRn (addOneFV fvs name')
+ extra_fvs other = returnRn emptyFVs
+ in
+ checkRn (ok_ext_nm ext_nm) (badExtName ext_nm) `thenRn_`
+
+ extra_fvs imp_exp `thenRn` \ fvs1 ->
+
+ rnHsSigType fo_decl_msg ty `thenRn` \ (ty', fvs2) ->
+ returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc),
+ fvs1 `plusFV` fvs2)
+ where
+ fo_decl_msg = ptext SLIT("a foreign declaration")
+ isDyn = isDynamicExtName ext_nm
+
+ ok_ext_nm Dynamic = True
+ ok_ext_nm (ExtName nm (Just mb)) = isCLabelString nm && isCLabelString mb
+ ok_ext_nm (ExtName nm Nothing) = isCLabelString nm
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Instance declarations}
+%* *
+%*********************************************************
+
+\begin{code}
+rnInstDecl (InstDecl inst_ty mbinds uprags maybe_dfun_rdr_name src_loc)
+ = pushSrcLocRn src_loc $
+ rnHsSigType (text "an instance decl") inst_ty `thenRn` \ (inst_ty', inst_fvs) ->
+ let
+ inst_tyvars = case inst_ty' of
+ HsForAllTy (Just inst_tyvars) _ _ -> inst_tyvars
+ other -> []
+ -- (Slightly strangely) the forall-d tyvars scope over
+ -- the method bindings too
+ in
+
+ -- Rename the bindings
+ -- NB meth_names can be qualified!
+ checkDupNames meth_doc meth_names `thenRn_`
+ extendTyVarEnvFVRn (map hsTyVarName inst_tyvars) (
+ rnMethodBinds [] mbinds
+ ) `thenRn` \ (mbinds', meth_fvs) ->
+ let
+ binders = collectMonoBinders mbinds'
+ binder_set = mkNameSet binders
+ in
+ -- Rename the prags and signatures.
+ -- Note that the type variables are not in scope here,
+ -- so that instance Eq a => Eq (T a) where
+ -- {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
+ -- works OK.
+ --
+ -- But the (unqualified) method names are in scope
+ bindLocalNames binders (
+ renameSigs (okInstDclSig binder_set) uprags
+ ) `thenRn` \ (new_uprags, prag_fvs) ->
+
+ (case maybe_dfun_rdr_name of
+ Nothing -> returnRn (Nothing, emptyFVs)
+
+ Just dfun_rdr_name -> lookupSysBinder dfun_rdr_name `thenRn` \ dfun_name ->
+ returnRn (Just dfun_name, unitFV dfun_name)
+ ) `thenRn` \ (maybe_dfun_name, dfun_fv) ->
+
+ -- The typechecker checks that all the bindings are for the right class.
+ returnRn (InstDecl inst_ty' mbinds' new_uprags maybe_dfun_name src_loc,
+ inst_fvs `plusFV` meth_fvs `plusFV` prag_fvs `plusFV` dfun_fv)
+ where
+ meth_doc = text "the bindings in an instance declaration"
+ meth_names = collectLocatedMonoBinders mbinds
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Rules}
+%* *
+%*********************************************************
+
+\begin{code}
+rnRuleDecl (IfaceRule rule_name vars fn args rhs src_loc)
+ = pushSrcLocRn src_loc $
+ lookupOccRn fn `thenRn` \ fn' ->
+ rnCoreBndrs vars $ \ vars' ->
+ mapFvRn rnCoreExpr args `thenRn` \ (args', fvs1) ->
+ rnCoreExpr rhs `thenRn` \ (rhs', fvs2) ->
+ returnRn (IfaceRule rule_name vars' fn' args' rhs' src_loc,
+ (fvs1 `plusFV` fvs2) `addOneFV` fn')
+
+rnRuleDecl (IfaceRuleOut fn rule)
+ -- This one is used for BuiltInRules
+ -- The rule itself is already done, but the thing
+ -- to attach it to is not.
+ = lookupOccRn fn `thenRn` \ fn' ->
+ returnRn (IfaceRuleOut fn' rule, unitFV fn')
+
+rnRuleDecl (HsRule rule_name tvs vars lhs rhs src_loc)
+ = ASSERT( null tvs )
+ pushSrcLocRn src_loc $
+
+ bindTyVarsFV2Rn doc (map UserTyVar sig_tvs) $ \ sig_tvs' _ ->
+ bindLocalsFVRn doc (map get_var vars) $ \ ids ->
+ mapFvRn rn_var (vars `zip` ids) `thenRn` \ (vars', fv_vars) ->
+
+ rnExpr lhs `thenRn` \ (lhs', fv_lhs) ->
+ rnExpr rhs `thenRn` \ (rhs', fv_rhs) ->
+ checkRn (validRuleLhs ids lhs')
+ (badRuleLhsErr rule_name lhs') `thenRn_`
+ let
+ bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)]
+ in
+ mapRn (addErrRn . badRuleVar rule_name) bad_vars `thenRn_`
+ returnRn (HsRule rule_name sig_tvs' vars' lhs' rhs' src_loc,
+ fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)
+ where
+ doc = text "the transformation rule" <+> ptext rule_name
+ sig_tvs = extractRuleBndrsTyVars vars
+
+ get_var (RuleBndr v) = v
+ get_var (RuleBndrSig v _) = v
+
+ rn_var (RuleBndr v, id) = returnRn (RuleBndr id, emptyFVs)
+ rn_var (RuleBndrSig v t, id) = rnHsType doc t `thenRn` \ (t', fvs) ->
+ returnRn (RuleBndrSig id t', fvs)
\end{code}
+
%*********************************************************
%* *
-\subsection{Type declarations}
+\subsection{Type, class and iface sig declarations}
%* *
%*********************************************************
However, we can also do some scoping checks at the same time.
\begin{code}
-rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls nconstrs derivings src_loc gen_name1 gen_name2))
+rnTyClDecl (IfaceSig name ty id_infos loc)
+ = pushSrcLocRn loc $
+ lookupTopBndrRn name `thenRn` \ name' ->
+ rnHsType doc_str ty `thenRn` \ (ty',fvs1) ->
+ mapFvRn rnIdInfo id_infos `thenRn` \ (id_infos', fvs2) ->
+ returnRn (IfaceSig name' ty' id_infos' loc, fvs1 `plusFV` fvs2)
+ where
+ doc_str = text "the interface signature for" <+> quotes (ppr name)
+
+rnTyClDecl (TyData new_or_data context tycon tyvars condecls nconstrs derivings src_loc gen_name1 gen_name2)
= pushSrcLocRn src_loc $
lookupTopBndrRn tycon `thenRn` \ tycon' ->
bindTyVarsFVRn data_doc tyvars $ \ tyvars' ->
lookupSysBinder gen_name1 `thenRn` \ name1' ->
lookupSysBinder gen_name2 `thenRn` \ name2' ->
rnDerivs derivings `thenRn` \ (derivings', deriv_fvs) ->
- returnRn (TyClD (TyData new_or_data context' tycon' tyvars' condecls' nconstrs
- derivings' src_loc name1' name2'),
+ returnRn (TyData new_or_data context' tycon' tyvars' condecls' nconstrs
+ derivings' src_loc name1' name2',
cxt_fvs `plusFV` con_fvs `plusFV` deriv_fvs)
where
data_doc = text "the data type declaration for" <+> quotes (ppr tycon)
con_names = map conDeclName condecls
-rnDecl (TyClD (TySynonym name tyvars ty src_loc))
+rnTyClDecl (TySynonym name tyvars ty src_loc)
= pushSrcLocRn src_loc $
doptRn Opt_GlasgowExts `thenRn` \ glaExts ->
lookupTopBndrRn name `thenRn` \ name' ->
bindTyVarsFVRn syn_doc tyvars $ \ tyvars' ->
rnHsType syn_doc (unquantify glaExts ty) `thenRn` \ (ty', ty_fvs) ->
- returnRn (TyClD (TySynonym name' tyvars' ty' src_loc), ty_fvs)
+ returnRn (TySynonym name' tyvars' ty' src_loc, ty_fvs)
where
syn_doc = text "the declaration for type synonym" <+> quotes (ppr name)
unquantify glaExts (HsForAllTy Nothing ctxt ty) | glaExts = ty
unquantify glaExys ty = ty
-rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds names src_loc))
+rnTyClDecl (ClassDecl context cname tyvars fds sigs mbinds names src_loc)
= pushSrcLocRn src_loc $
lookupTopBndrRn cname `thenRn` \ cname' ->
-- The renamer *could* check this for class decls, but can't
-- for instance decls.
- returnRn (TyClD (ClassDecl context' cname' tyvars' fds' (non_ops' ++ sigs') mbinds'
- names' src_loc),
+ returnRn (ClassDecl context' cname' tyvars' fds' (non_ops' ++ sigs') mbinds'
+ names' src_loc,
sig_fvs `plusFV`
fix_fvs `plusFV`
%*********************************************************
%* *
-\subsection{Instance declarations}
-%* *
-%*********************************************************
-
-\begin{code}
-rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun_rdr_name src_loc))
- = pushSrcLocRn src_loc $
- rnHsSigType (text "an instance decl") inst_ty `thenRn` \ (inst_ty', inst_fvs) ->
- let
- inst_tyvars = case inst_ty' of
- HsForAllTy (Just inst_tyvars) _ _ -> inst_tyvars
- other -> []
- -- (Slightly strangely) the forall-d tyvars scope over
- -- the method bindings too
- in
-
- -- Rename the bindings
- -- NB meth_names can be qualified!
- checkDupNames meth_doc meth_names `thenRn_`
- extendTyVarEnvFVRn (map hsTyVarName inst_tyvars) (
- rnMethodBinds [] mbinds
- ) `thenRn` \ (mbinds', meth_fvs) ->
- let
- binders = collectMonoBinders mbinds'
- binder_set = mkNameSet binders
- in
- -- Rename the prags and signatures.
- -- Note that the type variables are not in scope here,
- -- so that instance Eq a => Eq (T a) where
- -- {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
- -- works OK.
- --
- -- But the (unqualified) method names are in scope
- bindLocalNames binders (
- renameSigs (okInstDclSig binder_set) uprags
- ) `thenRn` \ (new_uprags, prag_fvs) ->
-
- (case maybe_dfun_rdr_name of
- Nothing -> returnRn (Nothing, emptyFVs)
-
- Just dfun_rdr_name -> lookupSysBinder dfun_rdr_name `thenRn` \ dfun_name ->
- returnRn (Just dfun_name, unitFV dfun_name)
- ) `thenRn` \ (maybe_dfun_name, dfun_fv) ->
-
- -- The typechecker checks that all the bindings are for the right class.
- returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags maybe_dfun_name src_loc),
- inst_fvs `plusFV` meth_fvs `plusFV` prag_fvs `plusFV` dfun_fv)
- where
- meth_doc = text "the bindings in an instance declaration"
- meth_names = collectLocatedMonoBinders mbinds
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Default declarations}
-%* *
-%*********************************************************
-
-\begin{code}
-rnDecl (DefD (DefaultDecl tys src_loc))
- = pushSrcLocRn src_loc $
- rnHsTypes doc_str tys `thenRn` \ (tys', fvs) ->
- returnRn (DefD (DefaultDecl tys' src_loc), fvs)
- where
- doc_str = text "a `default' declaration"
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Foreign declarations}
-%* *
-%*********************************************************
-
-\begin{code}
-rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
- = pushSrcLocRn src_loc $
- lookupOccRn name `thenRn` \ name' ->
- let
- extra_fvs FoExport
- | isDyn = lookupOrigNames [makeStablePtr_RDR, deRefStablePtr_RDR,
- bindIO_RDR, returnIO_RDR]
- | otherwise =
- lookupOrigNames [bindIO_RDR, returnIO_RDR] `thenRn` \ fvs ->
- returnRn (addOneFV fvs name')
- extra_fvs other = returnRn emptyFVs
- in
- checkRn (ok_ext_nm ext_nm) (badExtName ext_nm) `thenRn_`
-
- extra_fvs imp_exp `thenRn` \ fvs1 ->
-
- rnHsSigType fo_decl_msg ty `thenRn` \ (ty', fvs2) ->
- returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc),
- fvs1 `plusFV` fvs2)
- where
- fo_decl_msg = ptext SLIT("a foreign declaration")
- isDyn = isDynamicExtName ext_nm
-
- ok_ext_nm Dynamic = True
- ok_ext_nm (ExtName nm (Just mb)) = isCLabelString nm && isCLabelString mb
- ok_ext_nm (ExtName nm Nothing) = isCLabelString nm
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Rules}
-%* *
-%*********************************************************
-
-\begin{code}
-rnDecl (RuleD (IfaceRule rule_name vars fn args rhs src_loc))
- = pushSrcLocRn src_loc $
- lookupOccRn fn `thenRn` \ fn' ->
- rnCoreBndrs vars $ \ vars' ->
- mapFvRn rnCoreExpr args `thenRn` \ (args', fvs1) ->
- rnCoreExpr rhs `thenRn` \ (rhs', fvs2) ->
- returnRn (RuleD (IfaceRule rule_name vars' fn' args' rhs' src_loc),
- (fvs1 `plusFV` fvs2) `addOneFV` fn')
-
-rnDecl (RuleD (IfaceRuleOut fn rule))
- -- This one is used for BuiltInRules
- -- The rule itself is already done, but the thing
- -- to attach it to is not.
- = lookupOccRn fn `thenRn` \ fn' ->
- returnRn (RuleD (IfaceRuleOut fn' rule), unitFV fn')
-
-rnDecl (RuleD (HsRule rule_name tvs vars lhs rhs src_loc))
- = ASSERT( null tvs )
- pushSrcLocRn src_loc $
-
- bindTyVarsFV2Rn doc (map UserTyVar sig_tvs) $ \ sig_tvs' _ ->
- bindLocalsFVRn doc (map get_var vars) $ \ ids ->
- mapFvRn rn_var (vars `zip` ids) `thenRn` \ (vars', fv_vars) ->
-
- rnExpr lhs `thenRn` \ (lhs', fv_lhs) ->
- rnExpr rhs `thenRn` \ (rhs', fv_rhs) ->
- checkRn (validRuleLhs ids lhs')
- (badRuleLhsErr rule_name lhs') `thenRn_`
- let
- bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)]
- in
- mapRn (addErrRn . badRuleVar rule_name) bad_vars `thenRn_`
- returnRn (RuleD (HsRule rule_name sig_tvs' vars' lhs' rhs' src_loc),
- fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)
- where
- doc = text "the transformation rule" <+> ptext rule_name
- sig_tvs = extractRuleBndrsTyVars vars
-
- get_var (RuleBndr v) = v
- get_var (RuleBndrSig v _) = v
-
- rn_var (RuleBndr v, id) = returnRn (RuleBndr id, emptyFVs)
- rn_var (RuleBndrSig v t, id) = rnHsType doc t `thenRn` \ (t', fvs) ->
- returnRn (RuleBndrSig id t', fvs)
-\end{code}
-
-
-%*********************************************************
-%* *
\subsection{Support code for type/data declarations}
%* *
%*********************************************************
#include "HsVersions.h"
-import HsSyn ( HsDecl(..), IfaceSig(..), HsTupCon(..) )
+import HsSyn ( HsDecl(..), TyClDecl(..), HsTupCon(..) )
import TcMonad
import TcMonoType ( tcHsType )
-- NB: all the tyars in interface files are kinded,
tcInterfaceSigs unf_env decls
= listTc [ do_one name ty id_infos src_loc
- | SigD (IfaceSig name ty id_infos src_loc) <- decls]
+ | TyClD (IfaceSig name ty id_infos src_loc) <- decls]
where
in_scope_vars = filter isLocallyDefined (tcEnvIds unf_env)
-> HomeSymbolTable
-> HomeIfaceTable
-> PackageIfaceTable
- -> RenamedHsModule
- -> IO (Maybe (TcEnv, TcResults))
+ -> [RenamedHsDecl]
+ -> IO (Maybe TcResults)
+
+typecheckModule dflags this_mod pcs hst hit pit decls
+ = do env <- initTcEnv global_symbol_table
+
+ (maybe_result, (errs,warns)) <- initTc dflags env tc_module
+
+ let maybe_tc_result :: Maybe TcResults
+ maybe_tc_result = mapMaybe snd maybe_result
-typecheckModule dflags this_mod pcs hst hit pit (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)
- printTcDump dflags maybe_result
+ printTcDump dflags maybe_tc_result
+
if isEmptyBag errs then
return Nothing
else
- return maybe_result
+ return maybe_tc_result
where
global_symbol_table = pcs_PST pcs `plusModuleEnv` hst
- tc_module = fixTc (\ ~(unf_env ,_)
- -> tcModule pcs hst get_fixity this_mod decls unf_env)
+ tc_module :: TcM (TcEnv, TcResults)
+ tc_module = fixTc (\ ~(unf_env ,_) -> tcModule pcs hst get_fixity this_mod decls unf_env)
get_fixity :: Name -> Maybe Fixity
get_fixity nm = lookupTable hit pit nm `thenMaybe` \ iface ->
\begin{code}
printTcDump dflags Nothing = return ()
-printTcDump dflags (Just (_,results))
+printTcDump dflags (Just results)
= do dumpIfSet_dyn dflags Opt_D_dump_types
"Type signatures" (dump_sigs results)
dumpIfSet_dyn dflags Opt_D_dump_tc
initTc :: DynFlags
-> TcEnv
- -> SrcLoc
-> TcM r
-> IO (Maybe r, (Bag ErrMsg, Bag WarnMsg))
-initTc dflags tc_env src_loc do_this
+initTc dflags tc_env do_this
= do {
us <- mkSplitUniqSupply 'a' ;
us_var <- newIORef us ;
let
init_down = TcDown dflags [] us_var dfun_var
- src_loc
+ noSrcLoc
[] errs_var
;
projects / ghc-hetmet.git / commitdiff