From: simonpj@microsoft.com <unknown>
Date: Thu, 5 Jun 2008 14:56:17 +0000 (+0000)
Subject: Fix Trac #2045: use big-tuple machiney for implication constraints
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=4edf8929c0007b6626c32e382a337afc2c8a75ab

Fix Trac #2045: use big-tuple machiney for implication constraints
---

diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs
index 553b468..cf171ce 100644
--- a/compiler/deSugar/DsUtils.lhs
+++ b/compiler/deSugar/DsUtils.lhs
@@ -797,17 +797,18 @@ mkLHsVarTup ids  = mkLHsTup (map nlHsVar ids)
 mkLHsTup :: [LHsExpr Id] -> LHsExpr Id
 mkLHsTup []     = nlHsVar unitDataConId
 mkLHsTup [lexp] = lexp
-mkLHsTup lexps  = noLoc $ ExplicitTuple lexps Boxed
-
+mkLHsTup lexps  = L (getLoc (head lexps)) $ 
+		  ExplicitTuple lexps Boxed
 
 -- Smart constructors for source tuple patterns
 mkLHsVarPatTup :: [Id] -> LPat Id
 mkLHsVarPatTup bs  = mkLHsPatTup (map nlVarPat bs)
 
 mkLHsPatTup :: [LPat Id] -> LPat Id
+mkLHsPatTup []     = noLoc $ mkVanillaTuplePat [] Boxed
 mkLHsPatTup [lpat] = lpat
-mkLHsPatTup lpats  = noLoc $ mkVanillaTuplePat lpats Boxed -- Handles the case where lpats = [] gracefully
-
+mkLHsPatTup lpats  = L (getLoc (head lpats)) $ 
+		     mkVanillaTuplePat lpats Boxed
 
 -- The Big equivalents for the source tuple expressions
 mkBigLHsVarTup :: [Id] -> LHsExpr Id
@@ -823,7 +824,6 @@ mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs)
 
 mkBigLHsPatTup :: [LPat Id] -> LPat Id
 mkBigLHsPatTup = mkBigTuple mkLHsPatTup
-
 \end{code}
 
 
diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index a6bae24..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)
   	} 
     }