\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
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 )
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 ()
-- 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
-- (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
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 )
= 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}
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,
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
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,
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:
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 )
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 )
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 )
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(..),
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 )
-- 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.
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 ;
}}}
\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}
+
%************************************************************************
%* *
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
}
%* *
%************************************************************************
+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:
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
%* *
%************************************************************************
+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
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
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
pprKind, pprParendKind,
- pprType, pprParendType,
+ pprType, pprParendType, pprTyThingCategory,
pprPred, pprTheta, pprThetaArrow, pprClassPred
) where
typeKind, repType,
pprKind, pprParendKind,
- pprType, pprParendType,
+ pprType, pprParendType, pprTyThingCategory,
pprPred, pprTheta, pprThetaArrow, pprClassPred
)
import TyCon ( TyCon, isUnLiftedTyCon, tyConUnique )
import ErrUtils ( Message )
import SrcLoc ( noLoc )
import BasicTypes ( Arity )
-import Util ( equalLength, notNull )
+import Util ( notNull )
import Outputable
\end{code}
deShadowTy,
-- Pretty-printing
- pprType, pprParendType,
+ pprType, pprParendType, pprTyThingCategory,
pprPred, pprTheta, pprThetaArrow, pprClassPred
) where
funTyCon,
-- Pretty-printing
- pprType, pprParendType,
+ pprType, pprParendType, pprTyThingCategory,
pprPred, pprTheta, pprThetaArrow, pprClassPred,
-- Re-export fromKind
| 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
projects / ghc-hetmet.git / commitdiff