X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcUnify.lhs;h=d1ea6c0886887350fa8b1114846281999c2bcda5;hb=6efa3901fd6f1583fb654bd3659e88702dfd579a;hp=6509cf75ddc7ad5f81fb5c317b87ef5b84ee55be;hpb=f38eb88276e50b562fed84f436f3acee39f48587;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs
index 6509cf7..d1ea6c0 100644
--- a/compiler/typecheck/TcUnify.lhs
+++ b/compiler/typecheck/TcUnify.lhs
@@ -1088,7 +1088,7 @@ uTysOuter :: InBox -> TcType    -- ty1 is the *actual*   type
           -> TcM CoercionI
 -- We've just pushed a context describing ty1,ty2
 uTysOuter nb1 ty1 nb2 ty2
-        = do { traceTc (text "uTysOuter" <+> ppr ty1 <+> ppr ty2)
+        = do { traceTc (text "uTysOuter" <+> sep [ppr ty1, ppr ty2])
              ; u_tys (Unify True ty1 ty2) nb1 ty1 ty1 nb2 ty2 ty2 }
 
 uTys :: InBox -> TcType -> InBox -> TcType -> TcM CoercionI
@@ -1174,8 +1174,7 @@ u_tys outer nb1 orig_ty1 ty1 nb2 orig_ty2 ty2
 
              ; addErrCtxtM (unifyForAllCtxt tvs phi1 phi2) $ do
              { unless (equalLength theta1 theta2) (bale_out outer)
-             ; _cois <- uPreds outer nb1 theta1 nb2 theta2 -- TOMDO: do something with these pred_cois
-             ; traceTc (text "TOMDO!")
+             ; cois <- uPreds outer nb1 theta1 nb2 theta2
              ; coi <- uTys nb1 tau1 nb2 tau2
 
                 -- Check for escape; e.g. (forall a. a->b) ~ (forall a. a->a)
@@ -1190,7 +1189,13 @@ u_tys outer nb1 orig_ty1 ty1 nb2 orig_ty2 ty2
                 -- This check comes last, because the error message is
                 -- extremely unhelpful.
              ; when (nb1 && nb2) (notMonoType ty1)
-             ; return coi
+             ; let mk_fun (pred, coi_pred) (ty, coi) 
+                       = (mkFunTy pred_ty ty, mkFunTyCoI pred_ty coi_pred ty coi)
+                       where
+                         pred_ty = mkPredTy pred
+             ; return (foldr mkForAllTyCoI 
+                             (snd (foldr mk_fun (tau1,coi) (theta1 `zip` cois)))
+                             tvs)
              }}
       where
         (tvs1, body1) = tcSplitForAllTys ty1