X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnDriver.lhs;h=9747c22a724a1d02960d8965ec3bae1a22b79b40;hb=67ee8a93fc96a38c3f73468cb86d8421a11d2911;hp=7adb9d5eb58118613370c1faad7f2f7bb3bb8356;hpb=61d2625ae2e6a4cdae2ffc92df828905e81c24cc;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 7adb9d5..9747c22 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -38,7 +38,7 @@ import RdrName		( RdrName, mkRdrUnqual, emptyGlobalRdrEnv )
 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 )
@@ -48,6 +48,8 @@ import TcRules		( tcRules )
 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 )
@@ -58,7 +60,6 @@ import RnEnv		( lookupSrcOcc_maybe )
 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 )
@@ -66,16 +67,16 @@ import Module
 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
@@ -87,7 +88,7 @@ import HsSyn		( HsStmtContext(..), Stmt(..), HsExpr(..),
 			  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 )
@@ -96,9 +97,11 @@ import TcHsType		( kcHsType )
 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 )
@@ -111,9 +114,9 @@ import MkId		( unsafeCoerceId )
 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, 
@@ -123,13 +126,14 @@ import HscTypes		( InteractiveContext(..),
 			  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}
 
 
@@ -426,6 +430,7 @@ tc_rn_src_decls boot_details ds
 	-- 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 ;
@@ -509,24 +514,35 @@ checkHiBootIface :: TcGblEnv -> ModDetails -> TcM (LHsBinds Id)
 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
@@ -541,35 +557,9 @@ checkHiBootIface
 	  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")
 instMisMatch inst
   = hang (ppr inst)
@@ -994,6 +984,8 @@ tcGhciStmts stmts
 	    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) ;
 
@@ -1008,17 +1000,16 @@ tcGhciStmts 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