import PrelNames ( runMainIOName, rootMainKey, rOOT_MAIN, mAIN,
main_RDR_Unqual )
import RdrName ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv )
+import TyCon ( isOpenTyCon )
import TcHsSyn ( zonkTopDecls )
import TcExpr ( tcInferRho )
import TcRnMonad
-import TcType ( tidyTopType, tcEqType, mkTyVarTys, substTyWith )
+import TcType ( tidyTopType, tcEqType )
import Inst ( showLIE )
import InstEnv ( extendInstEnvList, Instance, pprInstances, instanceDFunId )
import TcBinds ( tcTopBinds, tcHsBootSigs )
import TcForeign ( tcForeignImports, tcForeignExports )
import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
import TcIface ( tcExtCoreBindings, tcHiBootIface )
+import MkIface ( tyThingToIfaceDecl )
+import IfaceSyn ( checkBootDecl, IfaceExtName(..) )
import TcSimplify ( tcSimplifyTop )
import TcTyClsDecls ( tcTyAndClassDecls )
import LoadIface ( loadOrphanModules )
import RnSource ( rnSrcDecls, rnTyClDecls, checkModDeprec )
import PprCore ( pprRules, pprCoreBindings )
import CoreSyn ( CoreRule, bindersOfBinds )
-import DataCon ( dataConWrapId )
import ErrUtils ( Messages, mkDumpDoc, showPass )
import Id ( Id, mkExportedLocalId, isLocalId, idName, idType )
import Var ( Var )
import UniqFM ( elemUFM, eltsUFM )
import OccName ( mkVarOccFS, plusOccEnv )
import Name ( Name, NamedThing(..), isExternalName, getSrcLoc, isWiredInName,
- mkExternalName )
+ nameModule, nameOccName, isImplicitName, mkExternalName )
import NameSet
-import TyCon ( tyConHasGenerics, isSynTyCon, synTyConDefn, tyConKind )
+import TyCon ( tyConHasGenerics )
import SrcLoc ( srcLocSpan, Located(..), noLoc )
import DriverPhases ( HscSource(..), isHsBoot )
import HscTypes ( ModGuts(..), ModDetails(..), emptyModDetails,
HscEnv(..), ExternalPackageState(..),
IsBootInterface, noDependencies,
Deprecs( NoDeprecs ), plusDeprecs,
- ForeignStubs(NoStubs), TyThing(..),
+ ForeignStubs(NoStubs),
TypeEnv, lookupTypeEnv, hptInstances,
extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons, typeEnvElts,
emptyFixityEnv
HsLocalBinds(..), HsValBinds(..),
LStmt, LHsExpr, LHsType, mkMatch, emptyLocalBinds,
collectLStmtsBinders, collectLStmtBinders, nlVarPat,
- mkFunBind, placeHolderType, noSyntaxExpr )
+ mkFunBind, placeHolderType, noSyntaxExpr, nlHsTyApp )
import RdrName ( GlobalRdrElt(..), globalRdrEnvElts,
unQualOK, lookupLocalRdrEnv, extendLocalRdrEnv )
import RnSource ( addTcgDUs )
import TcMType ( zonkTcType, zonkQuantifiedTyVar )
import TcMatches ( tcStmts, tcDoStmt )
import TcSimplify ( tcSimplifyInteractive, tcSimplifyInfer )
+import TcGadt ( emptyRefinement )
import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType, isTauTy,
isUnLiftedType, tyClsNamesOfDFunHead, tyClsNamesOfType, isUnitTy )
import TcEnv ( tcLookupTyCon, tcLookupId, tcLookupGlobal )
+import TypeRep ( TyThing(..) )
import RnTypes ( rnLHsType )
import Inst ( tcGetInstEnvs )
import InstEnv ( classInstances, instEnvElts )
import TyCon ( tyConName )
import TysWiredIn ( mkListTy, unitTy )
import IdInfo ( GlobalIdDetails(..) )
-import Kind ( Kind )
+import {- Kind parts of -} Type ( Kind )
import Var ( globaliseId )
-import Name ( nameOccName, nameModule, isBuiltInSyntax, isInternalName )
+import Name ( isBuiltInSyntax, isInternalName )
import OccName ( isTcOcc )
import NameEnv ( delListFromNameEnv )
import PrelNames ( iNTERACTIVE, ioTyConName, printName, itName,
Dependencies(..) )
import BasicTypes ( Fixity, RecFlag(..) )
import SrcLoc ( unLoc )
+import Data.Maybe ( isNothing )
#endif
import FastString ( mkFastString )
import Util ( sortLe )
import Bag ( unionBags, snocBag, emptyBag, unitBag, unionManyBags )
-import Data.Maybe ( isJust, isNothing )
+import Data.Maybe ( isJust )
\end{code}
reportDeprecations (hsc_dflags hsc_env) tcg_env ;
-- Process the export list
- rn_exports <- rnExports export_ies ;
+ rn_exports <- rnExports export_ies;
let { liftM2' fn a b = do a' <- a; b' <- b; return (fn a' b') } ;
- exports <- mkExportNameSet (isJust maybe_mod) (liftM2' (,) rn_exports export_ies) ;
+ exports <- mkExportNameSet (isJust maybe_mod)
+ (liftM2' (,) rn_exports export_ies) ;
-- Check whether the entire module is deprecated
-- This happens only once per module
-- Rename the splice expression, and get its supporting decls
(rn_splice_expr, splice_fvs) <- rnLExpr splice_expr ;
failIfErrsM ; -- Don't typecheck if renaming failed
+ rnDump (ppr rn_splice_expr) ;
-- Execute the splice
spliced_decls <- tcSpliceDecls rn_splice_expr ;
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_one (typeEnvElts boot_type_env)
+ = do { traceTc (text "checkHiBootIface" <+> (ppr boot_type_env $$ ppr boot_insts)) ;
+ ; mapM_ check_one (typeEnvElts boot_type_env)
; dfun_binds <- mapM check_inst boot_insts
; return (unionManyBags dfun_binds) }
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
+ | Just real_thing <- lookupTypeEnv local_type_env name
+ = do { let boot_decl = tyThingToIfaceDecl ext_nm boot_thing
+ real_decl = tyThingToIfaceDecl ext_nm real_thing
+ ; checkTc (checkBootDecl boot_decl real_decl)
+ (bootMisMatch boot_thing boot_decl real_decl) }
+ -- The easiest way to check compatibility is to convert to
+ -- iface syntax, where we already have good comparison functions
+ | otherwise
+ = addErrTc (missingBootThing boot_thing)
where
name = getName boot_thing
+ ext_nm name = ExtPkg (nameModule name) (nameOccName name)
+ -- Just enough to compare; no versions etc needed
+
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
+ || isImplicitName name -- Has a parent, which we'll check
+
dfun_names = map getName boot_insts
check_inst boot_inst
local_boot_dfun = mkExportedLocalId (idName boot_dfun) boot_inst_ty
----------------
-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) = synTyConDefn boot_tc
- (tvs2, defn2) = synTyConDefn 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 hs-boot file, but not in the module")
-bootMisMatch thing
+bootMisMatch thing boot_decl real_decl
= ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hs-boot file")
+ $+$ (ppr boot_decl) $+$ (ppr real_decl)
instMisMatch inst
= hang (ppr inst)
2 (ptext SLIT("is defined in the hs-boot file, but not in the module"))
io_ty = mkTyConApp ioTyCon [] ;
ret_ty = mkListTy unitTy ;
io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
+ tc_io_stmts stmts = tcStmts DoExpr (tcDoStmt io_ty) stmts
+ (emptyRefinement, io_ret_ty) ;
names = map unLoc (collectLStmtsBinders stmts) ;
-- then the type checker would instantiate x..z, and we wouldn't
-- get their *polymorphic* values. (And we'd get ambiguity errs
-- if they were overloaded, since they aren't applied to anything.)
- mk_return ids = nlHsApp (noLoc $ TyApp (nlHsVar ret_id) [ret_ty])
+ mk_return ids = nlHsApp (nlHsTyApp ret_id [ret_ty])
(noLoc $ ExplicitList unitTy (map mk_item ids)) ;
- mk_item id = nlHsApp (noLoc $ TyApp (nlHsVar unsafeCoerceId) [idType id, unitTy])
+ mk_item id = nlHsApp (nlHsTyApp unsafeCoerceId [idType id, unitTy])
(nlHsVar id)
} ;
-- OK, we're ready to typecheck the stmts
traceTc (text "tcs 2") ;
- ((tc_stmts, ids), lie) <- getLIE $
- tcStmts DoExpr (tcDoStmt io_ty) stmts io_ret_ty $ \ _ ->
- mappM tcLookupId names ;
+ ((tc_stmts, ids), lie) <- getLIE $ tc_io_stmts stmts $ \ _ ->
+ mappM tcLookupId names ;
-- Look up the names right in the middle,
-- where they will all be in scope
projects / ghc-hetmet.git / blobdiff