import TcHsSyn ( zonkTopDecls )
import TcExpr ( tcInferRho )
import TcRnMonad
-import TcType ( tidyTopType, isUnLiftedType )
+import TcType ( tidyTopType, tcEqType, mkTyVarTys, substTyWith )
import Inst ( showLIE )
import TcBinds ( tcTopBinds )
import TcDefaults ( tcDefaults )
import TcRules ( tcRules )
import TcForeign ( tcForeignImports, tcForeignExports )
import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
-import TcIface ( tcExtCoreBindings, loadImportedInsts )
+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 RnSource ( rnSrcDecls, rnTyClDecls, checkModDeprec )
import PprCore ( pprIdRules, pprCoreBindings )
import CoreSyn ( IdCoreRule, bindersOfBinds )
+import DataCon ( dataConWrapId )
import ErrUtils ( Messages, mkDumpDoc, showPass )
import Id ( mkExportedLocalId, isLocalId, idName, idType )
import Var ( Var )
import Module ( mkHomeModule, mkModuleName, moduleName, moduleEnvElts )
import OccName ( mkVarOcc )
-import Name ( Name, isExternalName, getSrcLoc, getOccName, nameSrcLoc )
+import Name ( Name, isExternalName, getSrcLoc, getOccName )
import NameSet
-import TyCon ( tyConHasGenerics )
-import SrcLoc ( SrcLoc, srcLocSpan, Located(..), noLoc )
+import TyCon ( tyConHasGenerics, isSynTyCon, getSynTyConDefn, tyConKind )
+import SrcLoc ( srcLocSpan, Located(..), noLoc )
import Outputable
-import HscTypes ( ModGuts(..), HscEnv(..), ExternalPackageState( eps_is_boot ),
- GhciMode(..), isOneShot, Dependencies(..), noDependencies,
- Deprecs( NoDeprecs ), plusDeprecs,
- ForeignStubs(NoStubs), TypeEnv,
+import HscTypes ( ModGuts(..), HscEnv(..), ExternalPackageState(..),
+ GhciMode(..), noDependencies, isOneShot,
+ Deprecs( NoDeprecs ), ModIface(..), plusDeprecs,
+ ForeignStubs(NoStubs), TyThing(..),
+ TypeEnv, lookupTypeEnv,
extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons,
- emptyFixityEnv
+ emptyFixityEnv, availName
)
#ifdef GHCI
import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), HsBindGroup(..),
- LStmt, LHsExpr, LHsType,
+ LStmt, LHsExpr, LHsType, mkMatchGroup,
collectStmtsBinders, mkSimpleMatch, placeHolderType,
nlLetStmt, nlExprStmt, nlBindStmt, nlResultStmt, nlVarPat )
import RdrName ( GlobalRdrEnv, mkGlobalRdrEnv, GlobalRdrElt(..),
import TcHsSyn ( mkHsLet, zonkTopLExpr, zonkTopBndrs )
import TcHsType ( kcHsType )
import TcExpr ( tcCheckRho )
+import TcIface ( loadImportedInsts )
import TcMType ( zonkTcType )
+import TcUnify ( unifyTyConApp )
import TcMatches ( tcStmtsAndThen, TcStmtCtxt(..) )
import TcSimplify ( tcSimplifyInteractive, tcSimplifyInfer )
-import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType, tyClsNamesOfDFunHead )
+import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType,
+ isUnLiftedType, tyClsNamesOfDFunHead )
import TcEnv ( tcLookupTyCon, tcLookupId, tcLookupGlobal )
import RnTypes ( rnLHsType )
import Inst ( tcStdSyntaxName, tcGetInstEnvs )
tyThingToIfaceDecl, dfunToIfaceInst )
import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn )
import Id ( Id, isImplicitId, globalIdDetails )
-import FieldLabel ( fieldLabelTyCon )
import MkId ( unsafeCoerceId )
import DataCon ( dataConTyCon )
import TyCon ( tyConName )
import Module ( ModuleName, lookupModuleEnvByName )
import HscTypes ( InteractiveContext(..), ExternalPackageState( eps_PTE ),
HomeModInfo(..), typeEnvElts, typeEnvClasses,
- TyThing(..), availName, availNames, icPrintUnqual,
- ModIface(..), ModDetails(..) )
+ availNames, icPrintUnqual,
+ ModDetails(..), Dependencies(..) )
import BasicTypes ( RecFlag(..), Fixity )
import Bag ( unitBag )
import ListSetOps ( removeDups )
import Panic ( ghcError, GhcException(..) )
+import SrcLoc ( SrcLoc )
#endif
import FastString ( mkFastString )
-import Util ( sortLt )
+import Util ( sortLe )
import Bag ( unionBags, snocBag )
import Maybe ( isJust )
-- The normal case
initTc hsc_env this_mod $
- addSrcSpan loc $
+ setSrcSpan loc $
do { -- Deal with imports; sets tcg_rdr_env, tcg_imports
(rdr_env, imports) <- rnImports import_decls ;
- -- In one-shot mode, record boot-file info in the EPS
- ifM (isOneShot (hsc_mode hsc_env)) $
- updateEps_ (\eps -> eps { eps_is_boot = imp_dep_mods imports }) ;
+ -- Record boot-file info in the EPS, so that it's
+ -- visible to loadHiBootInterface in tcRnSrcDecls,
+ -- and any other incrementally-performed imports
+ updateEps_ (\eps -> eps { eps_is_boot = imp_dep_mods imports }) ;
-- Update the gbl env
updGblEnv ( \ gbl -> gbl { tcg_rdr_env = rdr_env,
-- Typecheck them all together so that
-- any mutually recursive types are done right
- tcg_env <- checkNoErrs (tcTyAndClassDecls rn_decls) ;
+ tcg_env <- checkNoErrs (tcTyAndClassDecls [{- no boot names -}] rn_decls) ;
-- Make the new type env available to stuff slurped from interface files
setGblEnv tcg_env $ do {
-- Returns the variables free in the decls
-- Reason: solely to report unused imports and bindings
tcRnSrcDecls decls
- = do { -- Do all the declarations
- (tc_envs, lie) <- getLIE (tc_rn_src_decls decls) ;
+ = do { boot_names <- loadHiBootInterface ;
+
+ -- Do all the declarations
+ (tc_envs, lie) <- getLIE (tc_rn_src_decls boot_names decls) ;
-- tcSimplifyTop deals with constant or ambiguous InstIds.
-- How could there be ambiguous ones? They can only arise if a
let { final_type_env = extendTypeEnvWithIds type_env bind_ids } ;
+ -- Compre the hi-boot iface (if any) with the real thing
+ checkHiBootIface final_type_env boot_names ;
+
-- Make the new type env available to stuff slurped from interface files
writeMutVar (tcg_type_env_var tcg_env) final_type_env ;
tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' })
}
-tc_rn_src_decls :: [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv)
+tc_rn_src_decls :: [Name] -> [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 ds
+tc_rn_src_decls boot_names 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 first_group ;
+ tc_envs@(tcg_env,tcl_env) <- tcRnGroup boot_names 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
-- Glue them on the front of the remaining decls and loop
setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
- tc_rn_src_decls (spliced_decls ++ rest_ds)
+ tc_rn_src_decls boot_names (spliced_decls ++ rest_ds)
#endif /* GHCI */
}}}
\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 -> [Name] -> 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
+ = do { 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 (ADataCon dc1) (ADataCon dc2)
+ | idType (dataConWrapId dc1) `tcEqType` idType (dataConWrapId dc2)
+ = return ()
+
+ -- Can't declare a class in a hi-boot file
+
+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}
+
%************************************************************************
%* *
monad; it augments it and returns the new TcGblEnv.
\begin{code}
-tcRnGroup :: HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv)
+tcRnGroup :: [Name] -> HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv)
-- Returns the variables free in the decls, for unused-binding reporting
-tcRnGroup decls
+tcRnGroup boot_names decls
= do { -- Rename the declarations
(tcg_env, rn_decls) <- rnTopSrcDecls decls ;
setGblEnv tcg_env $ do {
-- Typecheck the declarations
- tcTopSrcDecls rn_decls
+ tcTopSrcDecls boot_names rn_decls
}}
------------------------------------------------
}}
------------------------------------------------
-tcTopSrcDecls :: HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
-tcTopSrcDecls
+tcTopSrcDecls :: [Name] -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
+tcTopSrcDecls boot_names
(HsGroup { hs_tyclds = tycl_decls,
hs_instds = inst_decls,
hs_fords = foreign_decls,
-- The latter come in via tycl_decls
traceTc (text "Tc2") ;
- tcg_env <- checkNoErrs (tcTyAndClassDecls tycl_decls) ;
+ tcg_env <- checkNoErrs (tcTyAndClassDecls boot_names tycl_decls) ;
-- tcTyAndClassDecls recovers internally, but if anything gave rise to
-- an error we'd better stop now, to avoid a cascade
{ let { rhs = nlHsApp (nlHsVar runIOName) (nlHsVar main_name) }
-- :Main.main :: IO () = runIO main
- ; (main_expr, ty) <- addSrcSpan (srcLocSpan (getSrcLoc main_name)) $
+ ; (main_expr, ty) <- setSrcSpan (srcLocSpan (getSrcLoc main_name)) $
tcInferRho rhs
; let { root_main_id = mkExportedLocalId rootMainName ty ;
let
fresh_it = itName uniq
the_bind = noLoc $ FunBind (noLoc fresh_it) False
- [ mkSimpleMatch [] expr placeHolderType ]
+ (mkMatchGroup [mkSimpleMatch [] expr])
in
tryTcLIE_ (do { -- Try this if the other fails
traceTc (text "tcs 1b") ;
names = map unLoc (collectStmtsBinders stmts) ;
stmt_ctxt = SC { sc_what = DoExpr,
- sc_rhs = check_rhs,
+ sc_rhs = infer_rhs,
sc_body = check_body,
sc_ty = ret_ty } ;
- check_rhs rhs rhs_ty = tcCheckRho rhs (mkTyConApp ioTyCon [rhs_ty]) ;
- check_body body = tcCheckRho body io_ret_ty ;
+ infer_rhs rhs = do { (rhs', rhs_ty) <- tcInferRho rhs
+ ; [pat_ty] <- unifyTyConApp ioTyCon rhs_ty
+ ; return (rhs', pat_ty) } ;
+ check_body body = tcCheckRho body io_ret_ty ;
-- mk_return builds the expression
-- returnIO @ [()] [coerce () x, .., coerce () z]
smpl_doc = ptext SLIT("main expression")
\end{code}
-tcRnExpr just finds the kind of a type
+tcRnType just finds the kind of a type
\begin{code}
tcRnType :: HscEnv
---------------------
filter_decl occs decl@(IfaceClass {ifSigs = sigs})
= decl { ifSigs = filter (keep_sig occs) sigs }
-filter_decl occs decl@(IfaceData {ifCons = IfDataTyCon cons})
- = decl { ifCons = IfDataTyCon (filter (keep_con occs) cons) }
+filter_decl occs decl@(IfaceData {ifCons = IfDataTyCon th cons})
+ = decl { ifCons = IfDataTyCon th (filter (keep_con occs) cons) }
filter_decl occs decl@(IfaceData {ifCons = IfNewTyCon con})
| keep_con occs con = decl
| otherwise = decl {ifCons = IfAbstractTyCon} -- Hmm?
filter_decl occs decl
= decl
-keep_sig occs (IfaceClassOp occ _ _) = occ `elem` occs
-keep_con occs (IfaceConDecl occ _ _ _ _ _ _) = occ `elem` occs
+keep_sig occs (IfaceClassOp occ _ _) = occ `elem` occs
+keep_con occs con = ifConOcc con `elem` occs
availOccs avail = map nameOccName (availNames avail)
-- munge transforms a thing to it's "parent" thing
munge (ADataCon dc) = ATyCon (dataConTyCon dc)
munge (AnId id) = case globalIdDetails id of
- RecordSelId lbl -> ATyCon (fieldLabelTyCon lbl)
- ClassOpId cls -> AClass cls
- other -> AnId id
+ RecordSelId tc lbl -> ATyCon tc
+ ClassOpId cls -> AClass cls
+ other -> AnId id
munge other_thing = other_thing
#endif /* GHCI */
ppr_sigs :: [Var] -> SDoc
ppr_sigs ids
-- Print type signatures; sort by OccName
- = vcat (map ppr_sig (sortLt lt_sig ids))
+ = vcat (map ppr_sig (sortLe le_sig ids))
where
- lt_sig id1 id2 = getOccName id1 < getOccName id2
+ le_sig id1 id2 = getOccName id1 <= getOccName id2
ppr_sig id = ppr id <+> dcolon <+> ppr (tidyTopType (idType id))
ppr_rules :: [IdCoreRule] -> SDoc
projects / ghc-hetmet.git / blobdiff