Commit 9d2575d7 authored by simonpj's avatar simonpj

[project @ 2005-04-16 22:47:23 by simonpj]

Significant clean-up of the handling of hi-boot files. 
Previously, when compling A.hs, we loaded A.hi-boot, and
it went into the External Package Table.  It was strange
but it worked.  This tidy up stops it going anywhere;
it's just read in, and typechecked into a ModDetails.

All this was on the way to improving the handling of
instances in hs-boot files, something Chris Ryder wanted.
I think they work quite sensibly now.  

If I've got all this right (have not had a chance to
fully test it) we can merge it into STABLE.
parent f857ebdc
......@@ -4,11 +4,13 @@
module IfaceEnv (
newGlobalBinder, newIPName, newImplicitBinder,
lookupIfaceTop, lookupIfaceExt,
lookupOrig, lookupAvail, lookupIfaceTc,
lookupOrig, lookupIfaceTc,
newIfaceName, newIfaceNames,
extendIfaceIdEnv, extendIfaceTyVarEnv,
tcIfaceLclId, tcIfaceTyVar,
lookupAvail, ifaceExportNames,
-- Name-cache stuff
allocateGlobalBinder, initNameCache,
) where
......@@ -18,7 +20,8 @@ module IfaceEnv (
import TcRnMonad
import IfaceType ( IfaceExtName(..), IfaceTyCon(..), ifaceTyConName )
import TysWiredIn ( tupleTyCon, tupleCon )
import HscTypes ( NameCache(..), HscEnv(..), GenAvailInfo(..), OrigNameCache )
import HscTypes ( NameCache(..), HscEnv(..), GenAvailInfo(..),
IfaceExport, OrigNameCache )
import TyCon ( TyCon, tyConName )
import DataCon ( dataConWorkId, dataConName )
import Var ( TyVar, Id, varName )
......@@ -27,7 +30,7 @@ import Name ( Name, nameUnique, nameModule,
getOccName, nameParent_maybe,
isWiredInName, mkIPName,
mkExternalName, mkInternalName )
import NameSet ( NameSet, emptyNameSet, addListToNameSet )
import OccName ( OccName, isTupleOcc_maybe, tcName, dataName,
lookupOccEnv, unitOccEnv, extendOccEnv, extendOccEnvList )
import PrelNames ( gHC_PRIM, pREL_TUP )
......@@ -127,6 +130,14 @@ newImplicitBinder base_name mk_sys_occ
Just parent_name -> parent_name
Nothing -> base_name
ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl NameSet
ifaceExportNames exports
= foldlM do_one emptyNameSet exports
where
do_one acc (mod, exports) = foldlM (do_avail mod) acc exports
do_avail mod acc avail = do { ns <- lookupAvail mod avail
; return (addListToNameSet acc ns) }
lookupAvail :: Module -> GenAvailInfo OccName -> TcRnIf a b [Name]
-- Find all the names arising from an import
-- Make sure the parent info is correct, even though we may not
......
......@@ -6,8 +6,8 @@
\begin{code}
module LoadIface (
loadHomeInterface, loadInterface, loadDecls,
loadSrcInterface, loadOrphanModules, loadHiBootInterface,
readIface, -- Used when reading the module's old interface
loadSrcInterface, loadOrphanModules,
findAndReadIface, readIface, -- Used when reading the module's old interface
predInstGates, ifaceInstGates, ifaceStats, discardDeclPrags,
initExternalPackageState
) where
......@@ -83,52 +83,16 @@ loadSrcInterface :: SDoc -> Module -> IsBootInterface -> RnM ModIface
-- This is called for each 'import' declaration in the source code
-- On a failure, fail in the monad with an error message
loadSrcInterface doc mod_name want_boot
= do { mb_iface <- initIfaceTcRn $ loadInterface doc mod_name
(ImportByUser want_boot)
loadSrcInterface doc mod want_boot
= do { mb_iface <- initIfaceTcRn $
loadInterface doc mod (ImportByUser want_boot)
; case mb_iface of
Failed err -> failWithTc (elaborate err)
Failed err -> failWithTc (elaborate err)
Succeeded iface -> return iface
}
where
elaborate err = hang (ptext SLIT("Failed to load interface for") <+>
quotes (ppr mod_name) <> colon) 4 err
loadHiBootInterface :: TcRn [Name]
-- Load the hi-boot iface for the module being compiled,
-- if it indeed exists in the transitive closure of imports
-- Return the list of names exported by the hi-boot file
loadHiBootInterface
= do { eps <- getEps
; mod <- getModule
; traceIf (text "loadHiBootInterface" <+> ppr mod)
-- We're read all the direct imports by now, so eps_is_boot will
-- record if any of our imports mention us by way of hi-boot file
; case lookupModuleEnv (eps_is_boot eps) mod of {
Nothing -> return [] ; -- The typical case
Just (_, False) -> -- Someone below us imported us!
-- This is a loop with no hi-boot in the way
failWithTc (moduleLoop mod) ;
Just (mod_nm, True) -> -- There's a hi-boot interface below us
do { -- Load it (into the PTE), and return the exported names
iface <- loadSrcInterface (mk_doc mod_nm) mod_nm True
; ns_s <- sequenceM [ lookupAvail mod_nm avail
| (mod,avails) <- mi_exports iface,
avail <- avails ]
; return (concat ns_s)
}}}
where
mk_doc mod = ptext SLIT("Need the hi-boot interface for") <+> ppr mod
<+> ptext SLIT("to compare against the Real Thing")
moduleLoop mod = ptext SLIT("Circular imports: module") <+> quotes (ppr mod)
<+> ptext SLIT("depends on itself")
quotes (ppr mod) <> colon) 4 err
loadOrphanModules :: [Module] -> TcM ()
loadOrphanModules mods
......@@ -551,7 +515,7 @@ findAndReadIface :: Bool -- True <=> explicit user import
-> SDoc -> Module
-> IsBootInterface -- True <=> Look for a .hi-boot file
-- False <=> Look for .hi file
-> IfM lcl (MaybeErr Message (ModIface, FilePath))
-> TcRnIf gbl lcl (MaybeErr Message (ModIface, FilePath))
-- Nothing <=> file not found, or unreadable, or illegible
-- Just x <=> successfully found and parsed
......@@ -626,7 +590,7 @@ findHiFile hsc_env explicit mod_name hi_boot_file
\begin{code}
readIface :: Module -> String -> IsBootInterface
-> IfM lcl (MaybeErr Message ModIface)
-> TcRnIf gbl lcl (MaybeErr Message ModIface)
-- Failed err <=> file not found, or unreadable, or illegible
-- Succeeded iface <=> successfully found and parsed
......
......@@ -5,7 +5,8 @@
\begin{code}
module TcIface (
tcImportDecl, typecheckIface, tcIfaceDecl, tcIfaceGlobal,
tcImportDecl, tcHiBootIface, typecheckIface,
tcIfaceDecl, tcIfaceGlobal,
loadImportedInsts, loadImportedRules,
tcExtCoreBindings
) where
......@@ -14,11 +15,11 @@ module TcIface (
import IfaceSyn
import LoadIface ( loadHomeInterface, loadInterface, predInstGates,
loadDecls )
loadDecls, findAndReadIface )
import IfaceEnv ( lookupIfaceTop, lookupIfaceExt, newGlobalBinder,
extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName,
tcIfaceTyVar, tcIfaceLclId,
newIfaceName, newIfaceNames )
tcIfaceTyVar, tcIfaceLclId,
newIfaceName, newIfaceNames, ifaceExportNames )
import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass,
mkAbstractTyConRhs, mkDataTyConRhs, mkNewTyConRhs )
import TcRnMonad
......@@ -30,6 +31,7 @@ import TyCon ( TyCon, tyConName, isSynTyCon )
import HscTypes ( ExternalPackageState(..), EpsStats(..), PackageInstEnv,
HscEnv, TyThing(..), tyThingClass, tyThingTyCon,
ModIface(..), ModDetails(..), ModGuts,
emptyModDetails,
extendTypeEnv, lookupTypeEnv, lookupType, typeEnvIds )
import InstEnv ( extendInstEnvList )
import CoreSyn
......@@ -55,7 +57,7 @@ import Name ( Name, nameModule, nameIsLocalOrFrom,
isWiredInName, wiredInNameTyThing_maybe, nameParent )
import NameEnv
import OccName ( OccName )
import Module ( Module )
import Module ( Module, lookupModuleEnv )
import UniqSupply ( initUs_ )
import Outputable
import ErrUtils ( Message )
......@@ -167,11 +169,12 @@ knot. Remember, the decls aren't necessarily in dependency order --
and even if they were, the type decls might be mutually recursive.
\begin{code}
typecheckIface :: HscEnv
-> ModIface -- Get the decls from here
-> IO ModDetails
typecheckIface hsc_env iface
= initIfaceTc hsc_env iface $ \ tc_env_var -> do
typecheckIface :: ModIface -- Get the decls from here
-> TcRnIf gbl lcl ModDetails
typecheckIface iface
= initIfaceTc iface $ \ tc_env_var -> do
-- The tc_env_var is freshly allocated, private to
-- type-checking this particular interface
{ -- Get the right set of decls and rules. If we are compiling without -O
-- we discard pragmas before typechecking, so that we don't "see"
-- information that we shouldn't. From a versioning point of view
......@@ -193,12 +196,65 @@ typecheckIface hsc_env iface
; dfuns <- mapM tcIfaceInst dfuns
; rules <- mapM tcIfaceRule rules
-- Exports
; exports <- ifaceExportNames (mi_exports iface)
-- Finished
; return (ModDetails { md_types = type_env, md_insts = dfuns, md_rules = rules })
; return (ModDetails { md_types = type_env,
md_insts = dfuns,
md_rules = rules,
md_exports = exports })
}
\end{code}
%************************************************************************
%* *
Type and class declarations
%* *
%************************************************************************
\begin{code}
tcHiBootIface :: Module -> TcRn ModDetails
-- Load the hi-boot iface for the module being compiled,
-- if it indeed exists in the transitive closure of imports
-- Return the ModDetails, empty if no hi-boot iface
tcHiBootIface mod
= do { traceIf (text "loadHiBootInterface" <+> ppr mod)
-- We're read all the direct imports by now, so eps_is_boot will
-- record if any of our imports mention us by way of hi-boot file
; eps <- getEps
; case lookupModuleEnv (eps_is_boot eps) mod of {
Nothing -> return emptyModDetails ; -- The typical case
Just (_, False) -> failWithTc moduleLoop ;
-- Someone below us imported us!
-- This is a loop with no hi-boot in the way
Just (mod, True) -> -- There's a hi-boot interface below us
do { read_result <- findAndReadIface
True -- Explicit import?
need mod
True -- Hi-boot file
; case read_result of
Failed err -> failWithTc (elaborate err)
Succeeded (iface, _path) -> typecheckIface iface
}}}
where
need = ptext SLIT("Need the hi-boot interface for") <+> ppr mod
<+> ptext SLIT("to compare against the Real Thing")
moduleLoop = ptext SLIT("Circular imports: module") <+> quotes (ppr mod)
<+> ptext SLIT("depends on itself")
elaborate err = hang (ptext SLIT("Could not find hi-boot interface for") <+>
quotes (ppr mod) <> colon) 4 err
\end{code}
%************************************************************************
%* *
Type and class declarations
......
......@@ -51,8 +51,8 @@ import Parser
import Lexer ( P(..), ParseResult(..), mkPState )
import SrcLoc ( mkSrcLoc )
import TcRnDriver ( tcRnModule, tcRnExtCore )
import TcRnTypes ( TcGblEnv(..) )
import TcIface ( typecheckIface )
import TcRnMonad ( initIfaceCheck, TcGblEnv(..) )
import IfaceEnv ( initNameCache )
import LoadIface ( ifaceStats, initExternalPackageState )
import PrelInfo ( wiredInThings, basicKnownKeyNames )
......@@ -208,7 +208,8 @@ hscNoRecomp hsc_env msg_act mod_summary
"Skipping " ++ showModMsg have_object mod_summary)
; new_details <- {-# SCC "tcRnIface" #-}
typecheckIface hsc_env old_iface ;
initIfaceCheck hsc_env $
typecheckIface old_iface ;
; dumpIfaceStats hsc_env
; return (HscNoRecomp new_details old_iface)
......
......@@ -7,7 +7,7 @@
module RnNames (
rnImports, importsFromLocalDecls,
reportUnusedNames, reportDeprecations,
mkModDeps, exportsToAvails, exportsFromAvail
mkModDeps, exportsFromAvail
) where
#include "HsVersions.h"
......@@ -18,7 +18,7 @@ import HsSyn ( IE(..), ieName, ImportDecl(..), LImportDecl,
Sig(..), collectGroupBinders, tyClDeclNames
)
import RnEnv
import IfaceEnv ( lookupAvail )
import IfaceEnv ( ifaceExportNames )
import LoadIface ( loadSrcInterface )
import TcRnMonad
......@@ -183,7 +183,7 @@ importsFromImportDecl this_mod
is_loc = loc, is_as = qual_mod_name }
in
-- Get the total imports, and filter them according to the import list
exportsToAvails filtered_exports `thenM` \ total_avails ->
ifaceExportNames filtered_exports `thenM` \ total_avails ->
filterImports iface imp_spec
imp_details total_avails `thenM` \ (avail_env, gbl_env) ->
......@@ -246,14 +246,6 @@ importsFromImportDecl this_mod
returnM (gbl_env, imports)
exportsToAvails :: [IfaceExport] -> TcRnIf gbl lcl NameSet
exportsToAvails exports
= foldlM do_one emptyNameSet exports
where
do_one acc (mod, exports) = foldlM (do_avail mod) acc exports
do_avail mod acc avail = do { ns <- lookupAvail mod avail
; return (addListToNameSet acc ns) }
warnRedundantSourceImport mod_name
= ptext SLIT("Unnecessary {- SOURCE -} in the import of module")
<+> quotes (ppr mod_name)
......
......@@ -499,8 +499,8 @@ other modules
\begin{code}
newDFunName :: Class -> [Type] -> SrcLoc -> TcM Name
newDFunName clas (ty:_) loc
= newUnique `thenM` \ uniq ->
returnM (mkInternalName uniq (mkDFunOcc dfun_string) loc)
= do { uniq <- newUnique
; return (mkInternalName uniq (mkDFunOcc dfun_string) loc) }
where
-- Any string that is somewhat unique will do
dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty)
......
......@@ -43,14 +43,14 @@ import Inst ( showLIE )
import InstEnv ( extendInstEnvList )
import TcBinds ( tcTopBinds, tcHsBootSigs )
import TcDefaults ( tcDefaults )
import TcEnv ( tcExtendGlobalValEnv )
import TcEnv ( tcExtendGlobalValEnv, iDFunId )
import TcRules ( tcRules )
import TcForeign ( tcForeignImports, tcForeignExports )
import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
import TcIface ( tcExtCoreBindings )
import TcIface ( tcExtCoreBindings, tcHiBootIface )
import TcSimplify ( tcSimplifyTop )
import TcTyClsDecls ( tcTyAndClassDecls )
import LoadIface ( loadOrphanModules, loadHiBootInterface )
import LoadIface ( loadOrphanModules )
import RnNames ( importsFromLocalDecls, rnImports, exportsFromAvail,
reportUnusedNames, reportDeprecations )
import RnEnv ( lookupSrcOcc_maybe )
......@@ -63,17 +63,19 @@ import Id ( mkExportedLocalId, isLocalId, idName, idType )
import Var ( Var )
import Module ( Module, ModuleEnv, mkModule, moduleEnvElts, lookupModuleEnv )
import OccName ( mkVarOcc )
import Name ( Name, isExternalName, getSrcLoc, getOccName, isWiredInName )
import Name ( Name, NamedThing(..), isExternalName, getSrcLoc,
getOccName, isWiredInName )
import NameSet
import TyCon ( tyConHasGenerics, isSynTyCon, getSynTyConDefn, tyConKind )
import SrcLoc ( srcLocSpan, Located(..), noLoc )
import DriverPhases ( HscSource(..), isHsBoot )
import HscTypes ( ModGuts(..), HscEnv(..), ExternalPackageState(..),
import HscTypes ( ModGuts(..), ModDetails(..), emptyModDetails,
HscEnv(..), ExternalPackageState(..),
IsBootInterface, noDependencies,
Deprecs( NoDeprecs ), plusDeprecs,
ForeignStubs(NoStubs), TyThing(..),
TypeEnv, lookupTypeEnv, hptInstances, lookupType,
extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons,
TypeEnv, lookupTypeEnv, hptInstances,
extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons, typeEnvElts,
emptyFixityEnv
)
import Outputable
......@@ -100,14 +102,13 @@ import RnTypes ( rnLHsType )
import Inst ( tcGetInstEnvs )
import InstEnv ( DFunId, classInstances, instEnvElts )
import RnExpr ( rnStmts, rnLExpr )
import RnNames ( exportsToAvails )
import LoadIface ( loadSrcInterface, ifaceInstGates )
import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..),
IfaceExtName(..), IfaceConDecls(..), IfaceInst(..),
tyThingToIfaceDecl, dfunToIfaceInst )
import IfaceType ( IfaceTyCon(..), IfaceType, toIfaceType,
interactiveExtNameFun, isLocalIfaceExtName )
import IfaceEnv ( lookupOrig )
import IfaceEnv ( lookupOrig, ifaceExportNames )
import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn )
import Id ( Id, isImplicitId, setIdType, globalIdDetails )
import MkId ( unsafeCoerceId )
......@@ -297,7 +298,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
-- Typecheck them all together so that
-- any mutually recursive types are done right
tcg_env <- checkNoErrs (tcTyAndClassDecls [{- no boot names -}] rn_decls) ;
tcg_env <- checkNoErrs (tcTyAndClassDecls emptyModDetails rn_decls) ;
-- Make the new type env available to stuff slurped from interface files
setGblEnv tcg_env $ do {
......@@ -359,10 +360,11 @@ tcRnSrcDecls decls
-- We do this now so that the boot_names can be passed
-- to tcTyAndClassDecls, because the boot_names are
-- automatically considered to be loop breakers
boot_names <- loadHiBootInterface ;
mod <- getModule ;
boot_iface <- tcHiBootIface mod ;
-- Do all the declarations
(tc_envs, lie) <- getLIE (tc_rn_src_decls boot_names decls) ;
(tc_envs, lie) <- getLIE (tc_rn_src_decls boot_iface decls) ;
-- tcSimplifyTop deals with constant or ambiguous InstIds.
-- How could there be ambiguous ones? They can only arise if a
......@@ -386,27 +388,29 @@ tcRnSrcDecls decls
(bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds)
rules fords ;
let { final_type_env = extendTypeEnvWithIds type_env bind_ids } ;
let { final_type_env = extendTypeEnvWithIds type_env bind_ids
; tcg_env' = tcg_env { tcg_type_env = final_type_env,
tcg_binds = binds', tcg_rules = rules',
tcg_fords = fords' } } ;
-- Compre the hi-boot iface (if any) with the real thing
checkHiBootIface final_type_env boot_names ;
-- Compare the hi-boot iface (if any) with the real thing
checkHiBootIface tcg_env' boot_iface ;
-- Make the new type env available to stuff slurped from interface files
writeMutVar (tcg_type_env_var tcg_env) final_type_env ;
return (tcg_env { tcg_type_env = final_type_env,
tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' })
return tcg_env'
}
tc_rn_src_decls :: [Name] -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv)
tc_rn_src_decls :: ModDetails -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv)
-- Loops around dealing with each top level inter-splice group
-- in turn, until it's dealt with the entire module
tc_rn_src_decls boot_names ds
tc_rn_src_decls boot_details ds
= do { let { (first_group, group_tail) = findSplice ds } ;
-- If ds is [] we get ([], Nothing)
-- Type check the decls up to, but not including, the first splice
tc_envs@(tcg_env,tcl_env) <- tcRnGroup boot_names first_group ;
tc_envs@(tcg_env,tcl_env) <- tcRnGroup boot_details first_group ;
-- Bale out if errors; for example, error recovery when checking
-- the RHS of 'main' can mean that 'main' is not in the envt for
......@@ -437,7 +441,7 @@ tc_rn_src_decls boot_names ds
-- Glue them on the front of the remaining decls and loop
setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
tc_rn_src_decls boot_names (spliced_decls ++ rest_ds)
tc_rn_src_decls boot_details (spliced_decls ++ rest_ds)
#endif /* GHCI */
}}}
\end{code}
......@@ -467,7 +471,7 @@ tcRnHsBootDecls decls
-- Typecheck type/class decls
; traceTc (text "Tc2")
; let tycl_decls = hs_tyclds rn_group
; tcg_env <- checkNoErrs (tcTyAndClassDecls [{- no boot_names -}] tycl_decls)
; tcg_env <- checkNoErrs (tcTyAndClassDecls emptyModDetails tycl_decls)
; setGblEnv tcg_env $ do {
-- Typecheck instance decls
......@@ -477,15 +481,21 @@ tcRnHsBootDecls decls
-- Typecheck value declarations
; traceTc (text "Tc5")
; new_ids <- tcHsBootSigs (hs_valds rn_group)
; val_ids <- tcHsBootSigs (hs_valds rn_group)
-- Wrap up
-- No simplification or zonking to do
; traceTc (text "Tc7a")
; gbl_env <- getGblEnv
; let { final_type_env = extendTypeEnvWithIds (tcg_type_env gbl_env) new_ids }
; return (gbl_env { tcg_type_env = final_type_env })
-- Make the final type-env
-- Include the dfun_ids so that their type sigs get
-- are written into the interface file
; let { type_env0 = tcg_type_env gbl_env
; type_env1 = extendTypeEnvWithIds type_env0 val_ids
; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids
; dfun_ids = map iDFunId inst_infos }
; return (gbl_env { tcg_type_env = type_env2 })
}}}}
spliceInHsBootErr (SpliceDecl (L loc _), _)
......@@ -499,33 +509,38 @@ the hi-boot stuff in the EPT. We do so here, using the export list of
the hi-boot interface as our checklist.
\begin{code}
checkHiBootIface :: TypeEnv -> [Name] -> TcM ()
checkHiBootIface :: TcGblEnv -> ModDetails -> TcM ()
-- Compare the hi-boot file for this module (if there is one)
-- with the type environment we've just come up with
-- In the common case where there is no hi-boot file, the list
-- of boot_names is empty.
checkHiBootIface env boot_names
= mapM_ (check_one env) boot_names
----------------
check_one local_env name
| isWiredInName name -- No checking for wired-in names. In particular, 'error'
= return () -- is handled by a rather gross hack (see comments in GHC.Err.hs-boot)
| otherwise
= do { (eps,hpt) <- getEpsAndHpt
-- Look up the hi-boot one;
-- it should jolly well be there (else GHC bug)
; case lookupType hpt (eps_PTE eps) name of {
Nothing -> pprPanic "checkHiBootIface" (ppr name) ;
Just boot_thing ->
-- Look it up in the local type env
-- It should be there, but it's a programmer error if not
case lookupTypeEnv local_env name of
Nothing -> addErrTc (missingBootThing boot_thing)
Just real_thing -> check_thing boot_thing real_thing
} }
checkHiBootIface
(TcGblEnv { tcg_insts = local_insts, tcg_type_env = local_type_env })
(ModDetails { md_insts = boot_insts, md_types = boot_type_env })
= do { mapM_ check_inst boot_insts
; mapM_ check_one (typeEnvElts boot_type_env) }
where
check_one boot_thing
| no_check name
= return ()
| otherwise
= case lookupTypeEnv local_type_env name of
Nothing -> addErrTc (missingBootThing boot_thing)
Just real_thing -> check_thing boot_thing real_thing
where
name = getName boot_thing
no_check name = isWiredInName name -- No checking for wired-in names. In particular,
-- 'error' is handled by a rather gross hack
-- (see comments in GHC.Err.hs-boot)
|| name `elem` dfun_names
dfun_names = map getName boot_insts
check_inst inst
| null [i | i <- local_insts, idType i `tcEqType` idType inst]
= addErrTc (instMisMatch inst)
| otherwise
= return ()
----------------
check_thing (ATyCon boot_tc) (ATyCon real_tc)
......@@ -558,6 +573,9 @@ missingBootThing thing
= ppr thing <+> ptext SLIT("is defined in the hs-boot file, but not in the module")
bootMisMatch thing
= ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hs-boot file")
instMisMatch inst
= hang (ptext SLIT("instance") <+> ppr (idType inst))
2 (ptext SLIT("is defined in the hs-boot file, but not in the module"))
\end{code}
......@@ -579,15 +597,15 @@ declarations. It expects there to be an incoming TcGblEnv in the
monad; it augments it and returns the new TcGblEnv.
\begin{code}
tcRnGroup :: [Name] -> HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv)
tcRnGroup :: ModDetails -> HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv)
-- Returns the variables free in the decls, for unused-binding reporting
tcRnGroup boot_names decls
tcRnGroup boot_details decls
= do { -- Rename the declarations
(tcg_env, rn_decls) <- rnTopSrcDecls decls ;
setGblEnv tcg_env $ do {
-- Typecheck the declarations
tcTopSrcDecls boot_names rn_decls
tcTopSrcDecls boot_details rn_decls
}}
------------------------------------------------
......@@ -613,8 +631,8 @@ rnTopSrcDecls group
}}
------------------------------------------------
tcTopSrcDecls :: [Name] -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
tcTopSrcDecls boot_names
tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
tcTopSrcDecls boot_details
(HsGroup { hs_tyclds = tycl_decls,
hs_instds = inst_decls,
hs_fords = foreign_decls,
......@@ -625,7 +643,7 @@ tcTopSrcDecls boot_names
-- The latter come in via tycl_decls
traceTc (text "Tc2") ;
tcg_env <- checkNoErrs (tcTyAndClassDecls boot_names tycl_decls) ;
tcg_env <- checkNoErrs (tcTyAndClassDecls boot_details tycl_decls) ;
-- tcTyAndClassDecls recovers internally, but if anything gave rise to
-- an error we'd better stop now, to avoid a cascade
......@@ -1051,7 +1069,7 @@ getModuleExports mod
; loadOrphanModules (dep_orphs (mi_deps iface))
-- Load any orphan-module interfaces,
-- so their instances are visible
; names <- exportsToAvails (mi_exports iface)
; names <- ifaceExportNames (mi_exports iface)
; let { gres = [ GRE { gre_name = name, gre_prov = vanillaProv mod }
| name <- nameSetToList names ] }
; returnM (mkGlobalRdrEnv gres) }
......
......@@ -836,16 +836,16 @@ initIfaceCheck hsc_env do_this
; initTcRnIf 'i' hsc_env gbl_env () do_this
}
initIfaceTc :: HscEnv -> ModIface
-> (TcRef TypeEnv -> IfL a) -> IO a
initIfaceTc :: ModIface
-> (TcRef TypeEnv -> IfL a) -> TcRnIf gbl lcl a
-- Used when type-checking checking an up-to-date interface file
-- No type envt from the current module, but we do know the module dependencies
initIfaceTc hsc_env iface do_this
= do { tc_env_var <- newIORef emptyTypeEnv
initIfaceTc iface do_this
= do { tc_env_var <- newMutVar emptyTypeEnv
; let { gbl_env = IfGblEnv { if_rec_types = Just (mod, readMutVar tc_env_var) } ;
; if_lenv = mkIfLclEnv mod doc
}
; initTcRnIf 'i' hsc_env gbl_env if_lenv (do_this tc_env_var)
; setEnvs (gbl_env, if_lenv) (do_this tc_env_var)
}
where
mod = mi_module iface
......
......@@ -37,7 +37,7 @@ import TypeRep ( Type(..), PredType(..), TyThing(..) ) -- For reification
import Name ( Name, NamedThing(..), nameOccName, nameModule, isExternalName,
mkInternalName, nameIsLocalOrFrom )
import NameEnv ( lookupNameEnv )
import HscTypes ( lookupType, ExternalPackageState(..) )
import HscTypes ( lookupType, ExternalPackageState(..), emptyModDetails )
import OccName
import Var ( Id, TyVar, idType )
import Module ( moduleUserString, mkModule )
......@@ -141,7 +141,7 @@ tc_bracket (TypBr typ)
-- Result type is Type (= Q Typ)
tc_bracket (DecBr decls)
= tcTopSrcDecls [{- no boot-names -}] decls `thenM_`
= tcTopSrcDecls emptyModDetails decls `thenM_`
-- Typecheck the declarations, dicarding the result
-- We'll get all that stuff later, when we splice it in
......
......@@ -17,7 +17,7 @@ import HsSyn ( TyClDecl(..), HsConDetails(..), HsTyVarBndr(..),
)
import HsTypes ( HsBang(..), getBangStrictness )
import BasicTypes ( RecFlag(..), StrictnessMark(..) )
import HscTypes ( implicitTyThings )
import HscTypes ( implicitTyThings, ModDetails )
import BuildTyCl ( buildClass, buildAlgTyCon, buildSynTyCon, buildDataCon,
mkDataTyConRhs, mkNewTyConRhs )
import TcRnMonad
......@@ -109,15 +109,15 @@ The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to
@TyThing@s. @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
\begin{code}
tcTyAndClassDecls :: [Name] -> [LTyClDecl Name]
tcTyAndClassDecls :: ModDetails -> [LTyClDecl Name]
-> TcM TcGblEnv -- Input env extended by types and classes
-- and their implicit Ids,DataCons
tcTyAndClassDecls boot_names decls
tcTyAndClassDecls boot_details decls
= do { -- First check for cyclic type synonysm or classes
-- See notes with checkCycleErrs
checkCycleErrs decls
; mod <- getModule
; traceTc (text "tcTyAndCl" <+> ppr mod <+> ppr boot_names)
; traceTc (text "tcTyAndCl" <+> ppr mod)