Record the type in TuplePat (necessary for GADTs)

We must record the type of a TuplePat after typechecking, just like a ConPatOut,
so that desugaring works correctly for GADTs. See comments with the declaration
of HsPat.TuplePat, and test gadt15

ghc/compiler/deSugar/Check.lhs

@@ -11,7 +11,7 @@ module Check ( check , ExhaustivePat ) where
 
 
 import HsSyn		
-import TcHsSyn		( hsPatType )
+import TcHsSyn		( hsPatType, mkVanillaTuplePat )
 import TcType		( tcTyConAppTyCon )
 import DsUtils		( EquationInfo(..), MatchResult(..), 
 			  CanItFail(..), firstPat )
@@ -145,7 +145,7 @@ untidy b (L loc p) = L loc (untidy' b p)
     untidy' _ p@(ConPatIn name (PrefixCon [])) = p
     untidy' b (ConPatIn name ps)     = pars b (L loc (ConPatIn name (untidy_con ps)))
     untidy' _ (ListPat pats ty)      = ListPat (map untidy_no_pars pats) ty
-    untidy' _ (TuplePat pats boxed)  = TuplePat (map untidy_no_pars pats) boxed
+    untidy' _ (TuplePat pats box ty) = TuplePat (map untidy_no_pars pats) box ty
     untidy' _ (PArrPat _ _)	     = panic "Check.untidy: Shouldn't get a parallel array here!"
     untidy' _ (SigPatIn _ _) 	     = panic "Check.untidy: SigPat"
 
@@ -557,9 +557,9 @@ make_con (ConPatOut (L _ id) _ _ _ _ _) (lp:lq:ps, constraints)
      | isInfixCon id    = (nlInfixConPat (getName id) lp lq : ps, constraints) 
    where q  = unLoc lq	
 
-make_con (ConPatOut (L _ id) _ _ _ (PrefixCon pats) _) (ps, constraints) 
-      | isTupleTyCon tc  = (noLoc (TuplePat pats_con (tupleTyConBoxity tc)) : rest_pats, constraints) 
-      | isPArrFakeCon id = (noLoc (PArrPat pats_con placeHolderType)        : rest_pats, constraints) 
+make_con (ConPatOut (L _ id) _ _ _ (PrefixCon pats) ty) (ps, constraints) 
+      | isTupleTyCon tc  = (noLoc (TuplePat pats_con (tupleTyConBoxity tc) ty) : rest_pats, constraints) 
+      | isPArrFakeCon id = (noLoc (PArrPat pats_con placeHolderType)           : rest_pats, constraints) 
       | otherwise        = (nlConPat name pats_con      : rest_pats, constraints)
     where 
 	name     	      = getName id
@@ -609,7 +609,7 @@ has_nplusk_pat (AsPat _ p) 	   	 = has_nplusk_lpat p
 has_nplusk_pat (SigPatOut p _ )    	 = has_nplusk_lpat p
 has_nplusk_pat (ConPatOut _ _ _ _ ps ty) = any has_nplusk_lpat (hsConArgs ps)
 has_nplusk_pat (ListPat ps _)  		 = any has_nplusk_lpat ps
-has_nplusk_pat (TuplePat ps _) 		 = any has_nplusk_lpat ps
+has_nplusk_pat (TuplePat ps _ _) 	 = any has_nplusk_lpat ps
 has_nplusk_pat (PArrPat ps _)  		 = any has_nplusk_lpat ps
 has_nplusk_pat (LazyPat p)     		 = False
 has_nplusk_pat p = False 	-- VarPat, VarPatOut, WildPat, LitPat, NPat, TypePat, DictPat
@@ -643,10 +643,10 @@ simplify_pat (PArrPat ps ty)
 		      (PrefixCon (map simplify_lpat ps)) 
 		      (mkPArrTy ty)
 
-simplify_pat (TuplePat ps boxity)
+simplify_pat (TuplePat ps boxity ty)
   = mk_simple_con_pat (tupleCon boxity arity)
 		      (PrefixCon (map simplify_lpat ps))
-		      (mkTupleTy boxity arity (map hsPatType ps))
+		      ty
   where
     arity = length ps
 
@@ -667,9 +667,9 @@ simplify_pat (NPlusKPat id hslit hsexpr1 hsexpr2)
 
 simplify_pat (DictPat dicts methods)
   = case num_of_d_and_ms of
-       0 -> simplify_pat (TuplePat [] Boxed) 
+       0 -> simplify_pat (TuplePat [] Boxed unitTy) 
        1 -> simplify_pat (head dict_and_method_pats) 
-       _ -> simplify_pat (TuplePat (map noLoc dict_and_method_pats) Boxed)
+       _ -> simplify_pat (mkVanillaTuplePat (map noLoc dict_and_method_pats) Boxed)
     where
        num_of_d_and_ms	 = length dicts + length methods
        dict_and_method_pats = map VarPat (dicts ++ methods)

ghc/compiler/deSugar/DsExpr.lhs

@@ -26,7 +26,7 @@ import DsMeta		( dsBracket )
 #endif
 
 import HsSyn
-import TcHsSyn		( hsPatType )
+import TcHsSyn		( hsPatType, mkVanillaTuplePat )
 
 -- NB: The desugarer, which straddles the source and Core worlds, sometimes
 --     needs to see source types (newtypes etc), and sometimes not
@@ -736,7 +736,7 @@ dsMDo tbl stmts body result_ty
 
  	mk_tup_pat :: [LPat Id] -> LPat Id
   	mk_tup_pat [p] = p
-	mk_tup_pat ps  = noLoc $ TuplePat ps Boxed
+	mk_tup_pat ps  = noLoc $ mkVanillaTuplePat ps Boxed
 
 	mk_ret_tup :: [LHsExpr Id] -> LHsExpr Id
 	mk_ret_tup [r] = r

ghc/compiler/deSugar/DsListComp.lhs

@@ -12,7 +12,7 @@ import {-# SOURCE #-} DsExpr ( dsLExpr, dsLocalBinds )
 
 import BasicTypes	( Boxity(..) )
 import HsSyn
-import TcHsSyn		( hsPatType )
+import TcHsSyn		( hsPatType, mkVanillaTuplePat )
 import CoreSyn
 
 import DsMonad		-- the monadery used in the desugarer
@@ -157,7 +157,7 @@ deListComp (ParStmt stmtss_w_bndrs : quals) body list
 	bndrs_s = map snd stmtss_w_bndrs
 
 	-- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above
-	pat	 = noLoc (TuplePat pats Boxed)
+	pat	 = mkTuplePat pats
 	pats	 = map mk_hs_tuple_pat bndrs_s
 
 	-- Types of (x1,..,xn), (y1,..,yn) etc
@@ -263,8 +263,7 @@ mk_hs_tuple_expr [id] = nlHsVar id
 mk_hs_tuple_expr ids  = noLoc $ ExplicitTuple [ nlHsVar i | i <- ids ] Boxed
 
 mk_hs_tuple_pat :: [Id] -> LPat Id
-mk_hs_tuple_pat [b] = nlVarPat b
-mk_hs_tuple_pat bs  = noLoc $ TuplePat (map nlVarPat bs) Boxed
+mk_hs_tuple_pat bs  = mkTuplePat (map nlVarPat bs)
 \end{code}
 
 
@@ -505,9 +504,9 @@ parrElemType e  =
 
 -- Smart constructor for source tuple patterns
 --
-mkTuplePat :: [LPat id] -> LPat id
+mkTuplePat :: [LPat Id] -> LPat Id
 mkTuplePat [lpat] = lpat
-mkTuplePat lpats  = noLoc $ TuplePat lpats Boxed
+mkTuplePat lpats  = noLoc $ mkVanillaTuplePat lpats Boxed
 
 -- Smart constructor for source tuple expressions
 --

ghc/compiler/deSugar/DsMeta.hs

@@ -799,14 +799,14 @@ repLP :: LPat Name -> DsM (Core TH.PatQ)
 repLP (L _ p) = repP p
 
 repP :: Pat Name -> DsM (Core TH.PatQ)
-repP (WildPat _)     = repPwild 
-repP (LitPat l)      = do { l2 <- repLiteral l; repPlit l2 }
-repP (VarPat x)      = do { x' <- lookupBinder x; repPvar x' }
-repP (LazyPat p)     = do { p1 <- repLP p; repPtilde p1 }
-repP (AsPat x p)     = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
-repP (ParPat p)      = repLP p 
-repP (ListPat ps _)  = do { qs <- repLPs ps; repPlist qs }
-repP (TuplePat ps _) = do { qs <- repLPs ps; repPtup qs }
+repP (WildPat _)       = repPwild 
+repP (LitPat l)        = do { l2 <- repLiteral l; repPlit l2 }
+repP (VarPat x)        = do { x' <- lookupBinder x; repPvar x' }
+repP (LazyPat p)       = do { p1 <- repLP p; repPtilde p1 }
+repP (AsPat x p)       = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
+repP (ParPat p)        = repLP p 
+repP (ListPat ps _)    = do { qs <- repLPs ps; repPlist qs }
+repP (TuplePat ps _ _) = do { qs <- repLPs ps; repPtup qs }
 repP (ConPatIn dc details)
  = do { con_str <- lookupLOcc dc
       ; case details of

ghc/compiler/deSugar/DsUtils.lhs

@@ -586,7 +586,7 @@ mkSelectorBinds pat val_expr
 
     is_simple_lpat p = is_simple_pat (unLoc p)
 
-    is_simple_pat (TuplePat ps Boxed)      = all is_triv_lpat ps
+    is_simple_pat (TuplePat ps Boxed _)    = all is_triv_lpat ps
     is_simple_pat (ConPatOut _ _ _ _ ps _) = all is_triv_lpat (hsConArgs ps)
     is_simple_pat (VarPat _)	       	   = True
     is_simple_pat (ParPat p)		   = is_simple_lpat p

ghc/compiler/deSugar/Match.lhs

@@ -10,7 +10,7 @@ module Match ( match, matchWrapper, matchSimply, matchSinglePat ) where
 
 import DynFlags	( DynFlag(..), dopt )
 import HsSyn		
-import TcHsSyn		( hsPatType )
+import TcHsSyn		( mkVanillaTuplePat )
 import Check            ( check, ExhaustivePat )
 import CoreSyn
 import CoreUtils	( bindNonRec, exprType )
@@ -25,7 +25,7 @@ import MatchLit		( matchLiterals, matchNPlusKPats, matchNPats, tidyLitPat, tidyN
 import PrelInfo		( pAT_ERROR_ID )
 import TcType		( Type, tcTyConAppArgs )
 import Type		( splitFunTysN, mkTyVarTys )
-import TysWiredIn	( consDataCon, mkTupleTy, mkListTy,
+import TysWiredIn	( consDataCon, mkListTy, unitTy,
 			  tupleCon, parrFakeCon, mkPArrTy )
 import BasicTypes	( Boxity(..) )
 import ListSetOps	( runs )
@@ -452,18 +452,17 @@ tidy1 v wrap (PArrPat pats ty)
     arity      = length pats
     parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty)
 
-tidy1 v wrap (TuplePat pats boxity)
+tidy1 v wrap (TuplePat pats boxity ty)
   = returnDs (wrap, unLoc tuple_ConPat)
   where
     arity = length pats
-    tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats
-				  (mkTupleTy boxity arity (map hsPatType pats))
+    tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats ty
 
 tidy1 v wrap (DictPat dicts methods)
   = case num_of_d_and_ms of
-	0 -> tidy1 v wrap (TuplePat [] Boxed) 
+	0 -> tidy1 v wrap (TuplePat [] Boxed unitTy) 
 	1 -> tidy1 v wrap (unLoc (head dict_and_method_pats))
-	_ -> tidy1 v wrap (TuplePat dict_and_method_pats Boxed)
+	_ -> tidy1 v wrap (mkVanillaTuplePat dict_and_method_pats Boxed)
   where
     num_of_d_and_ms	 = length dicts + length methods
     dict_and_method_pats = map nlVarPat (dicts ++ methods)

ghc/compiler/deSugar/MatchCon.lhs

@@ -8,6 +8,8 @@ module MatchCon ( matchConFamily ) where
 
 #include "HsVersions.h"
 
+import Id( idType )
+
 import {-# SOURCE #-} Match	( match )
 
 import HsSyn		( Pat(..), HsConDetails(..) )

ghc/compiler/hsSyn/Convert.lhs

@@ -437,7 +437,7 @@ cvtp (TH.LitP l)
   | otherwise	      = do { l' <- cvtLit l; return $ Hs.LitPat l' }
 cvtp (TH.VarP s)      = do { s' <- vName s; return $ Hs.VarPat s' }
 cvtp (TupP [p])       = cvtp p
-cvtp (TupP ps)        = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed }
+cvtp (TupP ps)        = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed void }
 cvtp (ConP s ps)      = do { s' <- cNameL s; ps' <- cvtPats ps; return $ ConPatIn s' (PrefixCon ps') }
 cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
 			   ; return $ ConPatIn s' (InfixCon p1' p2') }

ghc/compiler/hsSyn/HsPat.lhs

@@ -60,6 +60,18 @@ data Pat id
    	    	    
   | TuplePat	[LPat id]		-- Tuple
 		Boxity			-- UnitPat is TuplePat []
+		PostTcType
+	-- You might think that the PostTcType was redundant, but it's essential
+	--	data T a where
+	--	  T1 :: Int -> T Int
+	--	f :: (T a, a) -> Int
+	--	f (T1 x, z) = z
+	-- When desugaring, we must generate
+	--	f = /\a. \v::a.  case v of (t::T a, w::a) ->
+	--			 case t of (T1 (x::Int)) -> 
+	-- Note the (w::a), NOT (w::Int), because we have not yet
+	-- refined 'a' to Int.  So we must know that the second component
+	-- of the tuple is of type 'a' not Int.  See selectMatchVar
 
   | PArrPat	[LPat id]		-- Syntactic parallel array
 		PostTcType		-- The type of the elements
@@ -145,16 +157,16 @@ pprPatBndr var		  	-- Print with type info if -dppr-debug is on
 
 pprPat :: (OutputableBndr name) => Pat name -> SDoc
 
-pprPat (VarPat var)  	  = pprPatBndr var
-pprPat (VarPatOut var bs) = parens (pprPatBndr var <+> braces (ppr bs))
-pprPat (WildPat _)	  = char '_'
-pprPat (LazyPat pat)      = char '~' <> ppr pat
-pprPat (AsPat name pat)   = parens (hcat [ppr name, char '@', ppr pat])
-pprPat (ParPat pat)	  = parens (ppr pat)
+pprPat (VarPat var)  	    = pprPatBndr var
+pprPat (VarPatOut var bs)   = parens (pprPatBndr var <+> braces (ppr bs))
+pprPat (WildPat _)	    = char '_'
+pprPat (LazyPat pat)        = char '~' <> ppr pat
+pprPat (AsPat name pat)     = parens (hcat [ppr name, char '@', ppr pat])
+pprPat (ParPat pat)	    = parens (ppr pat)
 
-pprPat (ListPat pats _)   = brackets (interpp'SP pats)
-pprPat (PArrPat pats _)   = pabrackets (interpp'SP pats)
-pprPat (TuplePat pats bx) = tupleParens bx (interpp'SP pats)
+pprPat (ListPat pats _)     = brackets (interpp'SP pats)
+pprPat (PArrPat pats _)     = pabrackets (interpp'SP pats)
+pprPat (TuplePat pats bx _) = tupleParens bx (interpp'SP pats)
 
 pprPat (ConPatIn con details) = pprUserCon con details
 pprPat (ConPatOut con tvs dicts binds details _) 
@@ -253,7 +265,7 @@ isConPat (ConPatIn _ _)		 = True
 isConPat (ConPatOut _ _ _ _ _ _) = True
 isConPat (ListPat _ _)		 = True
 isConPat (PArrPat _ _)		 = True
-isConPat (TuplePat _ _)		 = True
+isConPat (TuplePat _ _ _)	 = True
 isConPat (DictPat ds ms)	 = (length ds + length ms) > 1
 isConPat other			 = False
 
@@ -279,17 +291,17 @@ isIrrefutableHsPat pat
   where
     go (L _ pat)	 = go1 pat
 
-    go1 (WildPat _)       = True
-    go1 (VarPat _)        = True
-    go1 (VarPatOut _ _)   = True
-    go1 (LazyPat pat)     = True
-    go1 (ParPat pat)      = go pat
-    go1 (AsPat _ pat)     = go pat
-    go1 (SigPatIn pat _)  = go pat
-    go1 (SigPatOut pat _) = go pat
-    go1 (TuplePat pats _) = all go pats
-    go1 (ListPat pats _)  = False
-    go1 (PArrPat pats _)  = False	-- ?
+    go1 (WildPat _)         = True
+    go1 (VarPat _)          = True
+    go1 (VarPatOut _ _)     = True
+    go1 (LazyPat pat)       = True
+    go1 (ParPat pat)        = go pat
+    go1 (AsPat _ pat)       = go pat
+    go1 (SigPatIn pat _)    = go pat
+    go1 (SigPatOut pat _)   = go pat
+    go1 (TuplePat pats _ _) = all go pats
+    go1 (ListPat pats _)    = False
+    go1 (PArrPat pats _)    = False	-- ?
 
     go1 (ConPatIn _ _) = False	-- Conservative
     go1 (ConPatOut (L _ con) _ _ _ details _) 

ghc/compiler/hsSyn/HsUtils.lhs

@@ -200,7 +200,7 @@ nlWildConPat :: DataCon -> LPat RdrName
 nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
 				   (PrefixCon (nOfThem (dataConSourceArity con) nlWildPat)))
 
-nlTuplePat pats box = noLoc (TuplePat pats box)
+nlTuplePat pats box = noLoc (TuplePat pats box placeHolderType)
 nlWildPat  = noLoc (WildPat placeHolderType)	-- Pre-typechecking
 
 nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> LHsExpr id
@@ -381,7 +381,7 @@ collectl (L l pat) bndrs
 				  
     go (ListPat pats _)    	  = foldr collectl bndrs pats
     go (PArrPat pats _)    	  = foldr collectl bndrs pats
-    go (TuplePat pats _)  	  = foldr collectl bndrs pats
+    go (TuplePat pats _ _)  	  = foldr collectl bndrs pats
 				  
     go (ConPatIn c ps)   	  = foldr collectl bndrs (hsConArgs ps)
     go (ConPatOut c _ ds bs ps _) = map noLoc ds
@@ -407,15 +407,15 @@ collectSigTysFromPat pat = collect_lpat pat []
 
 collect_lpat pat acc = collect_pat (unLoc pat) acc
 
-collect_pat (SigPatIn pat ty)  acc = collect_lpat pat (ty:acc)
-collect_pat (TypePat ty)       acc = ty:acc
-
-collect_pat (LazyPat pat)      acc = collect_lpat pat acc
-collect_pat (AsPat a pat)      acc = collect_lpat pat acc
-collect_pat (ParPat  pat)      acc = collect_lpat pat acc
-collect_pat (ListPat pats _)   acc = foldr collect_lpat acc pats
-collect_pat (PArrPat pats _)   acc = foldr collect_lpat acc pats
-collect_pat (TuplePat pats _)  acc = foldr collect_lpat acc pats
-collect_pat (ConPatIn c ps)    acc = foldr collect_lpat acc (hsConArgs ps)
-collect_pat other	       acc = acc 	-- Literals, vars, wildcard
+collect_pat (SigPatIn pat ty)  	acc = collect_lpat pat (ty:acc)
+collect_pat (TypePat ty)       	acc = ty:acc
+
+collect_pat (LazyPat pat)      	acc = collect_lpat pat acc
+collect_pat (AsPat a pat)      	acc = collect_lpat pat acc
+collect_pat (ParPat  pat)      	acc = collect_lpat pat acc
+collect_pat (ListPat pats _)   	acc = foldr collect_lpat acc pats
+collect_pat (PArrPat pats _)   	acc = foldr collect_lpat acc pats
+collect_pat (TuplePat pats _ _) acc = foldr collect_lpat acc pats
+collect_pat (ConPatIn c ps)    	acc = foldr collect_lpat acc (hsConArgs ps)
+collect_pat other	       	acc = acc 	-- Literals, vars, wildcard
 \end{code}

ghc/compiler/parser/RdrHsSyn.lhs

@@ -557,7 +557,7 @@ checkAPat loc e = case e of
    			 return (PArrPat ps placeHolderType)
    
    ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
-   			 return (TuplePat ps b)
+   			 return (TuplePat ps b placeHolderType)
    
    RecordCon c _ fs   -> mapM checkPatField fs >>= \fs ->
 			 return (ConPatIn c (RecCon fs))

ghc/compiler/rename/RnTypes.lhs

@@ -617,10 +617,11 @@ rnPat (PArrPat pats _)
   where
     implicit_fvs = mkFVs [lengthPName, indexPName]
 
-rnPat (TuplePat pats boxed)
+rnPat (TuplePat pats boxed _)
   = checkTupSize tup_size	`thenM_`
     rnLPats pats			`thenM` \ (patslist, fvs) ->
-    returnM (TuplePat patslist boxed, fvs `addOneFV` tycon_name)
+    returnM (TuplePat patslist boxed placeHolderType, 
+	     fvs `addOneFV` tycon_name)
   where
     tup_size   = length pats
     tycon_name = tupleTyCon_name boxed tup_size

ghc/compiler/typecheck/TcExpr.lhs

@@ -40,14 +40,12 @@ import TcMatches	( tcMatchesCase, tcMatchLambda, tcDoStmts, TcMatchCtxt(..) )
 import TcHsType		( tcHsSigType, UserTypeCtxt(..) )
 import TcPat		( tcOverloadedLit, badFieldCon )
 import TcMType		( tcInstTyVars, newFlexiTyVarTy, newBoxyTyVars, readFilledBox, 
-			  tcInstBoxyTyVar, tcInstTyVar, zonkTcType )
+			  tcInstBoxyTyVar, tcInstTyVar )
 import TcType		( TcType, TcSigmaType, TcRhoType, 
 			  BoxySigmaType, BoxyRhoType, ThetaType,
-			  tcSplitFunTys, mkTyVarTys, mkFunTys, 
-			  tcMultiSplitSigmaTy, tcSplitFunTysN, 
+			  mkTyVarTys, mkFunTys, tcMultiSplitSigmaTy, tcSplitFunTysN, 
 			  isSigmaTy, mkFunTy, mkTyConApp, isLinearPred,
 			  exactTyVarsOfType, exactTyVarsOfTypes, mkTyVarTy, 
-			  tidyOpenType,
 			  zipTopTvSubst, zipOpenTvSubst, substTys, substTyVar, lookupTyVar
 			)
 import Kind		( argTypeKind )

ghc/compiler/typecheck/TcHsSyn.lhs

@@ -11,7 +11,7 @@ module TcHsSyn (
 	mkHsTyApp, mkHsDictApp, mkHsConApp,
 	mkHsTyLam, mkHsDictLam, mkHsDictLet, mkHsApp,
 	hsLitType, hsPatType, mkHsAppTy, mkSimpleHsAlt,
-	nlHsIntLit, 
+	nlHsIntLit, mkVanillaTuplePat,
 	
 
 	-- re-exported from TcMonad
@@ -66,6 +66,11 @@ import Outputable
 Note: If @hsPatType@ doesn't bear a strong resemblance to @exprType@,
 then something is wrong.
 \begin{code}
+mkVanillaTuplePat :: [OutPat Id] -> Boxity -> Pat Id
+-- A vanilla tuple pattern simply gets its type from its sub-patterns
+mkVanillaTuplePat pats box 
+  = TuplePat pats box (mkTupleTy box (length pats) (map hsPatType pats))
+
 hsPatType :: OutPat Id -> Type
 hsPatType pat = pat_type (unLoc pat)
 
@@ -78,7 +83,7 @@ pat_type (LitPat lit)		   = hsLitType lit
 pat_type (AsPat var pat)	   = idType (unLoc var)
 pat_type (ListPat _ ty)		   = mkListTy ty
 pat_type (PArrPat _ ty)		   = mkPArrTy ty
-pat_type (TuplePat pats box)	   = mkTupleTy box (length pats) (map hsPatType pats)
+pat_type (TuplePat pats box ty)	   = ty
 pat_type (ConPatOut _ _ _ _ _ ty)  = ty
 pat_type (SigPatOut pat ty)	   = ty
 pat_type (NPat lit _ _ ty)	   = ty
@@ -723,9 +728,10 @@ zonk_pat env (PArrPat pats ty)
 	; (env', pats') <- zonkPats env pats
 	; return (env', PArrPat pats' ty') }
 
-zonk_pat env (TuplePat pats boxed)
-  = do	{ (env', pats') <- zonkPats env pats
-	; return (env', TuplePat pats' boxed) }
+zonk_pat env (TuplePat pats boxed ty)
+  = do	{ ty' <- zonkTcTypeToType env ty
+	; (env', pats') <- zonkPats env pats
+	; return (env', TuplePat pats' boxed ty') }
 
 zonk_pat env (ConPatOut n tvs dicts binds stuff ty)
   = ASSERT( all isImmutableTyVar tvs )

ghc/compiler/typecheck/TcPat.lhs

@@ -336,7 +336,7 @@ tc_pat pstate (PArrPat pats _) pat_ty thing_inside
 	; ifM (null pats) (zapToMonotype pat_ty)	-- c.f. ExplicitPArr in TcExpr
 	; return (PArrPat pats' elt_ty, pats_tvs, res) }
 
-tc_pat pstate (TuplePat pats boxity) pat_ty thing_inside
+tc_pat pstate (TuplePat pats boxity _) pat_ty thing_inside
   = do	{ arg_tys <- boxySplitTyConApp (tupleTyCon boxity (length pats)) pat_ty
 	; (pats', pats_tvs, res) <- tc_lpats pstate pats arg_tys thing_inside
 
@@ -344,7 +344,7 @@ tc_pat pstate (TuplePat pats boxity) pat_ty thing_inside
 	-- so that we can experiment with lazy tuple-matching.
 	-- This is a pretty odd place to make the switch, but
 	-- it was easy to do.
-	; let unmangled_result = TuplePat pats' boxity
+	; let unmangled_result = TuplePat pats' boxity pat_ty
 	      possibly_mangled_result
 	        | opt_IrrefutableTuples && isBoxed boxity = LazyPat (noLoc unmangled_result)
 	        | otherwise			          = unmangled_result

ghc/compiler/types/Generics.lhs

@@ -523,7 +523,7 @@ bimapTuple eps
 	 toEP   = mkHsLam [noLoc tuple_pat] (noLoc to_body) }
   where
     names	= takeList eps gs_RDR
-    tuple_pat	= TuplePat (map nlVarPat names) Boxed
+    tuple_pat	= TuplePat (map nlVarPat names) Boxed placeHolderType
     eps_w_names = eps `zip` names
     to_body     = ExplicitTuple [toEP   ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names] Boxed
     from_body   = ExplicitTuple [fromEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names] Boxed