X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSimplify.lhs;h=d2f82426e84f06f5b33529705ec4cac431e626e8;hb=1c05d4fbb6ee7ab68470d0aa79d74a3a4f0d8383;hp=ee62c0e8b04e54ae38f08a18a3b69801ad12c603;hpb=fce61e356063836debcc579e336e99a65d61284e;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index ee62c0e..d2f8242 100644
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -33,6 +33,7 @@ import {-# SOURCE #-} TcUnify( unifyType )
 import HsSyn
 
 import TcRnMonad
+import TcHsSyn	( hsLPatType )
 import Inst
 import TcEnv
 import InstEnv
@@ -40,6 +41,7 @@ import TcType
 import TcMType
 import TcIface
 import TcTyFuns
+import DsUtils	-- Big-tuple functions
 import TypeRep
 import Var
 import Name
@@ -1006,16 +1008,15 @@ makeImplicationBind loc all_tvs
 	      (eq_irreds, dict_irreds) = partition isEqInst irreds
               n_dict_irreds = length dict_irreds
 	      dict_irred_ids = map instToId dict_irreds
-	      tup_ty = mkTupleTy Boxed n_dict_irreds (map idType dict_irred_ids)
-	      pat = TuplePat (map nlVarPat dict_irred_ids) Boxed tup_ty
+	      lpat = mkBigLHsPatTup (map (L span . VarPat) dict_irred_ids)
 	      rhs = L span (mkHsWrap co (HsVar (instToId implic_inst)))
 	      co  = mkWpApps (map instToId dict_givens)
 		    <.> mkWpTyApps eq_tyvar_cos
 		    <.> mkWpTyApps (mkTyVarTys all_tvs)
 	      bind | [dict_irred_id] <- dict_irred_ids  = VarBind dict_irred_id rhs
-		   | otherwise        = PatBind { pat_lhs = L span pat, 
+		   | otherwise        = PatBind { pat_lhs = lpat, 
 				                  pat_rhs = unguardedGRHSs rhs, 
-				      	          pat_rhs_ty = tup_ty,
+				      	          pat_rhs_ty = hsLPatType lpat,
 				      	          bind_fvs = placeHolderNames }
 	; traceTc $ text "makeImplicationBind" <+> ppr implic_inst
 	; return ([implic_inst], unitBag (L span bind)) 
@@ -2187,16 +2188,15 @@ reduceImplication env
 		      <.> WpLet (binds `unionBags` bind)
 		wrap_inline | null dict_ids = idHsWrapper
 			    | otherwise	    = WpInline
-		rhs = mkHsWrap co payload
+		rhs = mkLHsWrap co payload
 	        loc = instLocSpan inst_loc
-		payload | [dict_wanted] <- dict_wanteds = HsVar (instToId dict_wanted)
-			| otherwise = ExplicitTuple (map (L loc . HsVar . instToId) dict_wanteds) Boxed
+		payload = mkBigLHsTup (map (L loc . HsVar . instToId) dict_wanteds)
 
 	
 	; traceTc (vcat [text "reduceImplication" <+> ppr name,
 			 ppr simpler_implic_insts,
 			 text "->" <+> ppr rhs])
-	; return (unitBag (L loc (VarBind (instToId orig_implic) (L loc rhs))),
+	; return (unitBag (L loc (VarBind (instToId orig_implic) rhs)),
 		  simpler_implic_insts)
   	} 
     }
@@ -2237,12 +2237,29 @@ We can satisfy the (C Int) from the superclass of D, so we don't want
 to float the (C Int) out, even though it mentions no type variable in
 the constraints!
 
+One more example: the constraint
+	class C a => D a b
+	instance (C a, E c) => E (a,c)
+
+	constraint: forall b. D Int b => E (Int,c)
+
+You might think that the (D Int b) can't possibly contribute
+to solving (E (Int,c)), since the latter mentions 'c'.  But 
+in fact it can, because solving the (E (Int,c)) constraint needs 
+dictionaries
+	C Int, E c
+and the (C Int) can be satisfied from the superclass of (D Int b).
+So we must still not float (E (Int,c)) out.
+
+To think about: special cases for unary type classes?
+
 Note [Pruning the givens in an implication constraint]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Suppose we are about to form the implication constraint
 	forall tvs.  Eq a => Ord b
 The (Eq a) cannot contribute to the (Ord b), because it has no access to
 the type variable 'b'.  So we could filter out the (Eq a) from the givens.
+But BE CAREFUL of the examples above in [Freeness and implications].
 
 Doing so would be a bit tidier, but all the implication constraints get
 simplified away by the optimiser, so it's no great win.   So I don't take