Commit da95f4a0 authored by simonpj's avatar simonpj

[project @ 2004-10-01 10:08:49 by simonpj]

-----------------------------------
	Do simple checking on hi-boot files
	-----------------------------------

This commit arranges that, when compiling A.hs, we compare
the types we infer with those in A.hi-boot, if the latter 
exists.  (Or, more accurately, if anything A.hs imports in
turn imports A.hi-boot, directly or indirectly.)

This has been on the to-do list forever.
parent 1276aa3f
......@@ -6,7 +6,7 @@
\begin{code}
module LoadIface (
loadHomeInterface, loadInterface,
loadSrcInterface, loadOrphanModules,
loadSrcInterface, loadOrphanModules, loadHiBootInterface,
readIface, -- Used when reading the module's old interface
predInstGates, ifaceInstGates, ifaceStats, discardDeclPrags,
initExternalPackageState
......@@ -50,7 +50,8 @@ import MkId ( seqId )
import Packages ( basePackage )
import Module ( Module, ModuleName, ModLocation(ml_hi_file),
moduleName, isHomeModule, emptyModuleEnv,
extendModuleEnv, lookupModuleEnvByName, moduleUserString
extendModuleEnv, lookupModuleEnvByName, lookupModuleEnv,
moduleUserString
)
import OccName ( OccName, mkOccEnv, lookupOccEnv, mkClassTyConOcc, mkClassDataConOcc,
mkSuperDictSelOcc, mkDataConWrapperOcc, mkDataConWorkerOcc )
......@@ -99,6 +100,34 @@ loadSrcInterface doc mod_name want_boot
elaborate err = hang (ptext SLIT("Failed to load interface for") <+>
quotes (ppr mod_name) <> colon) 4 err
loadHiBootInterface :: TcRn (Maybe ModIface)
-- Load the hi-boot iface for the module being compiled,
-- if it indeed exists in the transitive closure of imports
loadHiBootInterface
= do { eps <- getEps
; mod <- getModule
-- 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 Nothing -- The typical case
Just (mod_nm, True) -> -- There's a hi-boot interface below us
-- Load it (into the PTE), and return its interface
do { iface <- loadSrcInterface (mk_doc mod_nm) mod_nm True
; return (Just iface) }
Just (_, False) -> -- Someone below us imported us!
-- This is a loop with no hi-boot in the way
failWithTc (moduleLoop mod)
}
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")
loadOrphanModules :: [ModuleName] -> TcM ()
loadOrphanModules mods
| null mods = returnM ()
......
......@@ -120,10 +120,13 @@ data HscEnv
-- are compiling right now.
-- (In one-shot mode the current module is the only
-- home-package module, so hsc_HPT is empty. All other
-- modules count as "external-package" modules.)
-- modules count as "external-package" modules.
-- However, even in GHCi mode, hi-boot interfaces are
-- demand-loadeded into the external-package table.)
--
-- hsc_HPT is not mutable because we only demand-load
-- external packages; the home package is eagerly
-- loaded by the compilation manager.
-- loaded, module by module, by the compilation manager.
-- The next two are side-effected by compiling
-- to reflect sucking in interface files
......
......@@ -204,7 +204,7 @@ importsFromImportDecl this_mod
-- (a) remove this_mod (might be there as a hi-boot)
-- (b) add imp_mod itself
-- Take its dependent packages unchanged
((imp_mod_name, want_boot) : filter not_self (dep_mods deps), dep_pkgs deps)
((imp_mod_name, want_boot) : dep_mods deps, dep_pkgs deps)
| otherwise
= -- Imported module is from another package
......
......@@ -52,7 +52,7 @@ import TcMType ( zonkTcType, zonkTcTyVar, zonkTcTyVarsAndFV )
import TcType ( Type, TcKind, TcTyVar, TcTyVarSet,
tyVarsOfType, tyVarsOfTypes, tcSplitDFunTy, mkGenTyConApp,
getDFunTyKey, tcTyConAppTyCon,
tidyOpenType, tidyOpenTyVar
tidyOpenType, tidyOpenTyVar, pprTyThingCategory
)
import qualified Type ( getTyVar_maybe )
import Id ( idName, isLocalId )
......@@ -605,10 +605,7 @@ wrongThingErr expected thing name
= failWithTc (pp_thing thing <+> quotes (ppr name) <+>
ptext SLIT("used as a") <+> text expected)
where
pp_thing (AGlobal (ATyCon _)) = ptext SLIT("Type constructor")
pp_thing (AGlobal (AClass _)) = ptext SLIT("Class")
pp_thing (AGlobal (AnId _)) = ptext SLIT("Identifier")
pp_thing (AGlobal (ADataCon _)) = ptext SLIT("Data constructor")
pp_thing (ATyVar _) = ptext SLIT("Type variable")
pp_thing (ATcId _ _ _) = ptext SLIT("Local identifier")
pp_thing (AGlobal thing) = pprTyThingCategory thing
pp_thing (ATyVar _) = ptext SLIT("Type variable")
pp_thing (ATcId _ _ _) = ptext SLIT("Local identifier")
\end{code}
......@@ -22,7 +22,7 @@ import HsSyn ( HsExpr(..), LHsExpr, HsLit(..), ArithSeqInfo(..), recBindFields,
import TcHsSyn ( hsLitType, (<$>) )
import TcRnMonad
import TcUnify ( Expected(..), tcInfer, zapExpectedType, zapExpectedTo, tcSubExp, tcGen,
unifyFunTys, zapToListTy, zapToTyConApp, readExpectedType )
unifyFunTys, zapToListTy, zapToTyConApp )
import BasicTypes ( isMarkedStrict )
import Inst ( InstOrigin(..),
newOverloadedLit, newMethodFromName, newIPDict,
......
......@@ -36,10 +36,10 @@ import Id ( idType, setIdType, Id )
import TcRnMonad
import Type ( Type )
import TcType ( TcType, TcTyVar, mkTyVarTy, tcGetTyVar, mkTyConApp, isImmutableTyVar )
import TcType ( TcType, TcTyVar, mkTyVarTy, mkTyConApp, isImmutableTyVar )
import Kind ( isLiftedTypeKind, liftedTypeKind, isSubKind )
import qualified Type
import TcMType ( zonkQuantifiedTyVar, zonkType, zonkTcType, zonkTcTyVars,
import TcMType ( zonkQuantifiedTyVar, zonkType, zonkTcType,
putMetaTyVar )
import TysPrim ( charPrimTy, intPrimTy, floatPrimTy,
doublePrimTy, addrPrimTy
......
......@@ -52,7 +52,7 @@ import TypeRep ( Type(..), PredType(..), TyNote(..), -- Friend; can see repres
import TcType ( TcType, TcThetaType, TcTauType, TcPredType,
TcTyVarSet, TcKind, TcTyVar, TcTyVarDetails(..),
MetaDetails(..), SkolemInfo(..), isMetaTyVar, metaTvRef,
tcEqType, tcCmpPred, isClassPred,
tcCmpPred, isClassPred,
tcSplitPhiTy, tcSplitPredTy_maybe, tcSplitAppTy_maybe,
tcSplitTyConApp_maybe, tcSplitForAllTys,
tcIsTyVarTy, tcSplitSigmaTy, tcIsTyVarTy,
......@@ -70,7 +70,7 @@ import Type ( TvSubst, zipTopTvSubst, substTy )
import Class ( Class, classArity, className )
import TyCon ( TyCon, isSynTyCon, isUnboxedTupleTyCon,
tyConArity, tyConName )
import Var ( TyVar, tyVarKind, tyVarName, isTyVar,
import Var ( TyVar, tyVarKind, tyVarName,
mkTyVar, mkTcTyVar, tcTyVarDetails, isTcTyVar )
-- others:
......
......@@ -22,7 +22,7 @@ import Name ( Name )
import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
import TcEnv ( newLocalName, tcExtendIdEnv1, tcExtendTyVarEnv,
tcLookupClass, tcLookupDataCon, tcLookupId )
import TcMType ( newTyFlexiVarTy, arityErr, tcSkolTyVars, isRigidType )
import TcMType ( newTyFlexiVarTy, arityErr, tcSkolTyVars )
import TcType ( TcType, TcTyVar, TcSigmaType, TcTauType, zipTopTvSubst,
SkolemInfo(PatSkol), isSkolemTyVar, pprSkolemTyVar,
mkTyVarTys, mkClassPred, mkTyConApp, isOverloadedTy )
......
......@@ -33,7 +33,7 @@ import RdrName ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv,
import TcHsSyn ( zonkTopDecls )
import TcExpr ( tcInferRho )
import TcRnMonad
import TcType ( tidyTopType )
import TcType ( tidyTopType, tcEqType, mkTyVarTys, substTyWith )
import Inst ( showLIE )
import TcBinds ( tcTopBinds )
import TcDefaults ( tcDefaults )
......@@ -44,7 +44,8 @@ import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
import TcIface ( tcExtCoreBindings )
import TcSimplify ( tcSimplifyTop )
import TcTyClsDecls ( tcTyAndClassDecls )
import LoadIface ( loadOrphanModules )
import LoadIface ( loadOrphanModules, loadHiBootInterface )
import IfaceEnv ( lookupOrig )
import RnNames ( importsFromLocalDecls, rnImports, exportsFromAvail,
reportUnusedNames, reportDeprecations )
import RnEnv ( lookupSrcOcc_maybe )
......@@ -58,15 +59,16 @@ import Module ( mkHomeModule, mkModuleName, moduleName, moduleEnvElts
import OccName ( mkVarOcc )
import Name ( Name, isExternalName, getSrcLoc, getOccName )
import NameSet
import TyCon ( tyConHasGenerics )
import TyCon ( tyConHasGenerics, isSynTyCon, getSynTyConDefn, tyConKind )
import SrcLoc ( srcLocSpan, Located(..), noLoc )
import Outputable
import HscTypes ( ModGuts(..), HscEnv(..), ExternalPackageState(..),
GhciMode(..), noDependencies, isOneShot,
Deprecs( NoDeprecs ), plusDeprecs,
ForeignStubs(NoStubs), TypeEnv,
Deprecs( NoDeprecs ), ModIface(..), plusDeprecs,
ForeignStubs(NoStubs), TyThing(..),
TypeEnv, lookupTypeEnv,
extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons,
emptyFixityEnv
emptyFixityEnv, availName
)
#ifdef GHCI
import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), HsBindGroup(..),
......@@ -113,8 +115,8 @@ import PrelNames ( iNTERACTIVE, ioTyConName, printName, monadNames, itName, retu
import Module ( ModuleName, lookupModuleEnvByName )
import HscTypes ( InteractiveContext(..), ExternalPackageState( eps_PTE ),
HomeModInfo(..), typeEnvElts, typeEnvClasses,
TyThing(..), availName, availNames, icPrintUnqual,
ModIface(..), ModDetails(..), Dependencies(..) )
availNames, icPrintUnqual,
ModDetails(..), Dependencies(..) )
import BasicTypes ( RecFlag(..), Fixity )
import Bag ( unitBag )
import ListSetOps ( removeDups )
......@@ -321,7 +323,9 @@ tcRnSrcDecls :: [LHsDecl RdrName] -> TcM TcGblEnv
-- Returns the variables free in the decls
-- Reason: solely to report unused imports and bindings
tcRnSrcDecls decls
= do { -- Do all the declarations
= do { mb_boot_iface <- loadHiBootInterface ;
-- Do all the declarations
(tc_envs, lie) <- getLIE (tc_rn_src_decls decls) ;
-- tcSimplifyTop deals with constant or ambiguous InstIds.
......@@ -348,6 +352,9 @@ tcRnSrcDecls decls
let { final_type_env = extendTypeEnvWithIds type_env bind_ids } ;
-- Compre the hi-boot iface (if any) with the real thing
checkHiBootIface final_type_env mb_boot_iface ;
-- Make the new type env available to stuff slurped from interface files
writeMutVar (tcg_type_env_var tcg_env) final_type_env ;
......@@ -399,6 +406,75 @@ tc_rn_src_decls ds
}}}
\end{code}
%************************************************************************
%* *
Comparing the hi-boot interface with the real thing
%* *
%************************************************************************
In both one-shot mode and GHCi mode, hi-boot interfaces are demand-loaded
into the External Package Table. Once we've typechecked the body of the
module, we want to compare what we've found (gathered in a TypeEnv) with
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 -> Maybe ModIface -> TcM ()
-- Compare the hi-boot file for this module (if there is one)
-- with the type environment we've just come up with
checkHiBootIface env Nothing -- No hi-boot
= return ()
checkHiBootIface env (Just iface)
= mapM_ (check_one env) exports
where
exports = [ (mod, availName avail) | (mod,avails) <- mi_exports iface,
avail <- avails]
----------------
check_one local_env (mod,occ)
= do { name <- lookupOrig mod occ
; eps <- getEps
-- Look up the hi-boot one;
-- it should jolly well be there (else GHC bug)
; case lookupTypeEnv (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
} }
----------------
check_thing (ATyCon boot_tc) (ATyCon real_tc)
| isSynTyCon boot_tc && isSynTyCon real_tc,
defn1 `tcEqType` substTyWith tvs2 (mkTyVarTys tvs1) defn2
= return ()
| tyConKind boot_tc == tyConKind real_tc
= return ()
where
(tvs1, defn1) = getSynTyConDefn boot_tc
(tvs2, defn2) = getSynTyConDefn boot_tc
check_thing (AnId boot_id) (AnId real_id)
| idType boot_id `tcEqType` idType real_id
= return ()
check_thing boot_thing real_thing -- Default case; failure
= addErrAt (srcLocSpan (getSrcLoc real_thing))
(bootMisMatch real_thing)
----------------
missingBootThing thing
= ppr thing <+> ptext SLIT("is defined in the hi-boot file, but not in the module")
bootMisMatch thing
= ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hi-boot file")
\end{code}
%************************************************************************
%* *
......
......@@ -111,14 +111,14 @@ type TcM a = TcRn a -- Historical
data Env gbl lcl -- Changes as we move into an expression
= Env {
env_top :: HscEnv, -- Top-level stuff that never changes
-- Includes all info about imported things
-- Includes all info about imported things
env_us :: TcRef UniqSupply, -- Unique supply for local varibles
env_gbl :: gbl, -- Info about things defined at the top level
-- of the module being compiled
-- of the module being compiled
env_lcl :: lcl -- Nested stuff -- changes as we go into
env_lcl :: lcl -- Nested stuff; changes as we go into
-- an expression
}
......
......@@ -47,6 +47,13 @@ import Outputable
%* *
%************************************************************************
Checking for class-decl loops is easy, because we don't allow class decls
in interface files.
We allow type synonyms in hi-boot files, but we *trust* hi-boot files,
so we don't check for loops that involve them. So we only look for synonym
loops in the module being compiled.
We check for type synonym and class cycles on the *source* code.
Main reasons:
......@@ -64,8 +71,9 @@ Main reasons:
The main disadvantage is that a cycle that goes via a type synonym in an
.hi-boot file can lead the compiler into a loop, because it assumes that cycles
only occur in source code. But hi-boot files are trusted anyway, so this isn't
much worse than (say) a kind error.
only occur entirely within the source code of the module being compiled.
But hi-boot files are trusted anyway, so this isn't much worse than (say)
a kind error.
[ NOTE ----------------------------------------------
If we reverse this decision, this comment came from tcTyDecl1, and should
......@@ -136,6 +144,14 @@ calcClassCycles decls
%* *
%************************************************************************
For newtypes, we label some as "recursive" such that
INVARIANT: there is no cycle of non-recursive newtypes
In any loop, only one newtype need be marked as recursive; it is
a "loop breaker". Labelling more than necessary as recursive is OK,
provided the invariant is maintained.
A newtype M.T is defined to be "recursive" iff
(a) its rhs mentions an abstract (hi-boot) TyCon
or (b) one can get from T's rhs to T via type
......@@ -163,7 +179,7 @@ back to it. (This is an error too.)
Hi-boot types
~~~~~~~~~~~~~
A data type read from an hi-boot file will have an Unknown in its data constructors,
A data type read from an hi-boot file will have an AbstractTyCon as its AlgTyConRhs
and will respond True to isHiBootTyCon. The idea is that we treat these as if one
could get from these types to anywhere. So when we see
......
......@@ -110,7 +110,7 @@ module TcType (
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
pprKind, pprParendKind,
pprType, pprParendType,
pprType, pprParendType, pprTyThingCategory,
pprPred, pprTheta, pprThetaArrow, pprClassPred
) where
......@@ -150,7 +150,7 @@ import Type ( -- Re-exports
typeKind, repType,
pprKind, pprParendKind,
pprType, pprParendType,
pprType, pprParendType, pprTyThingCategory,
pprPred, pprTheta, pprThetaArrow, pprClassPred
)
import TyCon ( TyCon, isUnLiftedTyCon, tyConUnique )
......
......@@ -65,7 +65,7 @@ import Name ( isSystemName, mkSysTvName )
import ErrUtils ( Message )
import SrcLoc ( noLoc )
import BasicTypes ( Arity )
import Util ( equalLength, notNull )
import Util ( notNull )
import Outputable
\end{code}
......
......@@ -73,7 +73,7 @@ module Type (
deShadowTy,
-- Pretty-printing
pprType, pprParendType,
pprType, pprParendType, pprTyThingCategory,
pprPred, pprTheta, pprThetaArrow, pprClassPred
) where
......
......@@ -14,7 +14,7 @@ module TypeRep (
funTyCon,
-- Pretty-printing
pprType, pprParendType,
pprType, pprParendType, pprTyThingCategory,
pprPred, pprTheta, pprThetaArrow, pprClassPred,
-- Re-export fromKind
......@@ -251,10 +251,13 @@ data TyThing = AnId Id
| AClass Class
instance Outputable TyThing where
ppr (AnId id) = ptext SLIT("AnId") <+> ppr id
ppr (ATyCon tc) = ptext SLIT("ATyCon") <+> ppr tc
ppr (AClass cl) = ptext SLIT("AClass") <+> ppr cl
ppr (ADataCon dc) = ptext SLIT("ADataCon") <+> ppr (dataConName dc)
ppr thing = pprTyThingCategory thing <+> quotes (ppr (getName thing))
pprTyThingCategory :: TyThing -> SDoc
pprTyThingCategory (ATyCon _) = ptext SLIT("Type constructor")
pprTyThingCategory (AClass _) = ptext SLIT("Class")
pprTyThingCategory (AnId _) = ptext SLIT("Identifier")
pprTyThingCategory (ADataCon _) = ptext SLIT("Data constructor")
instance NamedThing TyThing where -- Can't put this with the type
getName (AnId id) = getName id -- decl, because the DataCon instance
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment