X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnDriver.lhs;h=38c4d7a0275b085efce05dce0fbfa723ab779199;hb=43cc549d6b596a0ba33fff2b126e5149f07eca29;hp=773f307053344ef19f2aa8a070867c3f1c72b02f;hpb=6ea06bbf08517d9805feb82df65cc56ecbaf23a4;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 773f307..38c4d7a 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -72,7 +72,7 @@ import Outputable
 import DataCon
 import Type
 import Class
-import TcType   ( tyClsNamesOfDFunHead )
+import TcType   ( orphNamesOfDFunHead )
 import Inst	( tcGetInstEnvs )
 import Data.List ( sortBy )
 
@@ -505,6 +505,7 @@ tcRnHsBootDecls decls
 	; traceTc "Tc3" empty
 	; (tcg_env, inst_infos, _deriv_binds) 
             <- tcInstDecls1 (concat tycl_decls) inst_decls deriv_decls
+
 	; setGblEnv tcg_env	$ do {
 
 		-- Typecheck value declarations
@@ -639,7 +640,11 @@ checkHiBootIface
 	= case [dfun | inst <- local_insts, 
 		       let dfun = instanceDFunId inst,
 		       idType dfun `tcEqType` boot_inst_ty ] of
-	    [] -> do { addErrTc (instMisMatch boot_inst); return Nothing }
+	    [] -> do { traceTc "check_inst" (vcat [ text "local_insts" <+> vcat (map (ppr . idType . instanceDFunId) local_insts)
+                                                  , text "boot_inst"   <+> ppr boot_inst
+                                                  , text "boot_inst_ty" <+> ppr boot_inst_ty
+                                                  ]) 
+                     ; addErrTc (instMisMatch boot_inst); return Nothing }
 	    (dfun:_) -> return (Just (local_boot_dfun, dfun))
 	where
 	  boot_dfun = instanceDFunId boot_inst
@@ -1308,9 +1313,16 @@ tcRnExpr hsc_env ictxt rdr_expr
 
 	-- Now typecheck the expression; 
 	-- it might have a rank-2 type (e.g. :t runST)
-    ((_tc_expr, res_ty), lie)	<- captureConstraints (tcInferRho rn_expr) ;
-    ((qtvs, dicts, _), lie_top) <- captureConstraints (simplifyInfer False {- No MR for now -}
-                                                      (tyVarsOfType res_ty) lie)  ;
+
+    uniq <- newUnique ;
+    let { fresh_it  = itName uniq } ;
+    ((_tc_expr, res_ty), lie)   <- captureConstraints (tcInferRho rn_expr) ;
+    ((qtvs, dicts, _), lie_top) <- captureConstraints $
+                                   simplifyInfer TopLevel
+                                                 False {- No MR for now -}
+                                                 [(fresh_it, res_ty)]
+                                                 lie  ;
+
     _ <- simplifyInteractive lie_top ;       -- Ignore the dicionary bindings
 
     let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts res_ty) } ;
@@ -1487,7 +1499,7 @@ lookupInsts (ATyCon tc)
 		 , let dfun = instanceDFunId ispec
 		 , relevant dfun ] } 
   where
-    relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df)
+    relevant df = tc_name `elemNameSet` orphNamesOfDFunHead (idType df)
     tc_name     = tyConName tc		  
 
 lookupInsts _ = return []