X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnDriver.lhs;h=5cfb612fe83a68f30adf84157d825ffac3d28120;hb=ea551d6a25581168f790a08c43bb09bda8c314f6;hp=12069ff87e15b95e97c2e0b326284e6d50d09061;hpb=63489d40bdee972656ff115ab2309b809c0e39fc;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 12069ff..5cfb612 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -40,6 +40,7 @@ import TcHsSyn
 import TcExpr
 import TcRnMonad
 import TcType
+import Coercion
 import Inst
 import FamInst
 import InstEnv
@@ -74,6 +75,7 @@ import Name
 import NameEnv
 import NameSet
 import TyCon
+import TysPrim
 import TysWiredIn
 import SrcLoc
 import HscTypes
@@ -555,6 +557,15 @@ checkHiBootIface
 		-- Check the exports of the boot module, one by one
 	; mapM_ check_export boot_exports
 
+		-- Check instance declarations
+	; mb_dfun_prs <- mapM check_inst boot_insts
+	; let tcg_env' = tcg_env { tcg_binds    = binds `unionBags` dfun_binds,
+				   tcg_type_env = extendTypeEnvWithIds local_type_env boot_dfuns }
+	      dfun_prs   = catMaybes mb_dfun_prs
+	      boot_dfuns = map fst dfun_prs
+	      dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun)
+				     | (boot_dfun, dfun) <- dfun_prs ]
+
 		-- Check for no family instances
 	; unless (null boot_fam_insts) $
 	    panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++
@@ -569,7 +580,7 @@ checkHiBootIface
 	      final_type_env = extendTypeEnvWithIds local_type_env boot_dfuns
 	      dfun_prs   = catMaybes mb_dfun_prs
 	      boot_dfuns = map fst dfun_prs
-	      dfun_binds = listToBag [ noLoc $ VarBind boot_dfun (nlHsVar dfun)
+	      dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun)
 				     | (boot_dfun, dfun) <- dfun_prs ]
 
         ; failIfErrsM
@@ -929,7 +940,7 @@ check_main dflags tcg_env
 						    (mkTyConApp ioTyCon [res_ty])
 	      ; co  = mkWpTyApps [res_ty]
 	      ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) main_expr
-	      ; main_bind = noLoc (VarBind root_main_id rhs) }
+	      ; main_bind = mkVarBind root_main_id rhs }
 
 	; return (tcg_env { tcg_binds = tcg_binds tcg_env 
 					`snocBag` main_bind,
@@ -1392,7 +1403,7 @@ tcRnGetInfo :: HscEnv
 	    -> Name
 	    -> IO (Messages, Maybe (TyThing, Fixity, [Instance]))
 
--- Used to implemnent :info in GHCi
+-- Used to implement :info in GHCi
 --
 -- Look up a RdrName and return all the TyThings it might be
 -- A capitalised RdrName is given to us in the DataName namespace,
@@ -1571,8 +1582,12 @@ ppr_tydecls tycons
   where
     le_sig tycon1 tycon2 = getOccName tycon1 <= getOccName tycon2
     ppr_tycon tycon 
-      | isCoercionTyCon tycon = ptext (sLit "coercion") <+> ppr tycon
+      | isCoercionTyCon tycon 
+      = sep [ptext (sLit "coercion") <+> ppr tycon <+> ppr tvs
+            , nest 2 (dcolon <+> pprEqPred (coercionKind (mkTyConApp tycon (mkTyVarTys tvs))))]
       | otherwise             = ppr (tyThingToIfaceDecl (ATyCon tycon))
+      where
+        tvs = take (tyConArity tycon) alphaTyVars
 
 ppr_rules :: [CoreRule] -> SDoc
 ppr_rules [] = empty