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 (file)
--- 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 (file)
--- 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)
        } 
     }