diff --git a/compiler/basicTypes/PatSyn.lhs b/compiler/basicTypes/PatSyn.lhs
index 29c1193482a03347b0c51013fe2c9b4ddacd1e11..b3c85016ec515dcf8443cbb72f96bdee61e6d58f 100644
--- a/compiler/basicTypes/PatSyn.lhs
+++ b/compiler/basicTypes/PatSyn.lhs
@@ -14,7 +14,8 @@ module PatSyn (
patSynId, patSynType, patSynArity, patSynIsInfix,
patSynArgs, patSynTyDetails,
patSynWrapper, patSynMatcher,
- patSynExTyVars, patSynSig, patSynInstArgTys
+ patSynExTyVars, patSynSig,
+ patSynInstArgTys, patSynInstResTy
) where
#include "HsVersions.h"
@@ -124,7 +125,7 @@ data PatSyn
psExTyVars :: [TyVar], -- Existentially-quantified type vars
psProvTheta :: ThetaType, -- Provided dictionaries
psReqTheta :: ThetaType, -- Required dictionaries
- psOrigResTy :: Type,
+ psOrigResTy :: Type, -- Mentions only psUnivTyVars
-- See Note [Matchers and wrappers for pattern synonyms]
psMatcher :: Id,
@@ -262,6 +263,13 @@ patSynMatcher :: PatSyn -> Id
patSynMatcher = psMatcher
patSynInstArgTys :: PatSyn -> [Type] -> [Type]
+-- Return the types of the argument patterns
+-- e.g. data D a = forall b. MkD a b (b->a)
+-- pattern P f x y = MkD (x,True) y f
+-- D :: forall a. forall b. a -> b -> (b->a) -> D a
+-- P :: forall c. forall b. (b->(c,Bool)) -> c -> b -> P c
+-- patSynInstArgTys P [Int,bb] = [bb->(Int,Bool), Int, bb]
+-- NB: the inst_tys should be both universal and existential
patSynInstArgTys ps inst_tys
= ASSERT2( length tyvars == length inst_tys
, ptext (sLit "patSynInstArgTys") <+> ppr ps $$ ppr tyvars $$ ppr inst_tys )
@@ -269,4 +277,17 @@ patSynInstArgTys ps inst_tys
where
(univ_tvs, ex_tvs, _, _) = patSynSig ps
tyvars = univ_tvs ++ ex_tvs
+
+patSynInstResTy :: PatSyn -> [Type] -> Type
+-- Return the type of whole pattern
+-- E.g. pattern P x y = Just (x,x,y)
+-- P :: a -> b -> Just (a,a,b)
+-- (patSynInstResTy P [Int,Bool] = Maybe (Int,Int,Bool)
+-- NB: unlikepatSynInstArgTys, the inst_tys should be just the *universal* tyvars
+patSynInstResTy ps inst_tys
+ = ASSERT2( length univ_tvs == length inst_tys
+ , ptext (sLit "patSynInstResTy") <+> ppr ps $$ ppr univ_tvs $$ ppr inst_tys )
+ substTyWith univ_tvs inst_tys (psOrigResTy ps)
+ where
+ (univ_tvs, _, _, _) = patSynSig ps
\end{code}
diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs
index 960475cedd035d531ac39898584d402f67d4074c..409c05b176dd25d2ae2cb95ad99d913345b56dbd 100644
--- a/compiler/deSugar/Check.lhs
+++ b/compiler/deSugar/Check.lhs
@@ -21,7 +21,6 @@ import Name
import TysWiredIn
import PrelNames
import TyCon
-import Type
import SrcLoc
import UniqSet
import Util
@@ -144,7 +143,7 @@ untidy b (L loc p) = L loc (untidy' b p)
untidy' _ p@(ConPatIn _ (PrefixCon [])) = p
untidy' b (ConPatIn name ps) = pars b (L loc (ConPatIn name (untidy_con ps)))
untidy' _ (ListPat pats ty Nothing) = ListPat (map untidy_no_pars pats) ty Nothing
- untidy' _ (TuplePat pats box ty) = TuplePat (map untidy_no_pars pats) box ty
+ untidy' _ (TuplePat pats box tys) = TuplePat (map untidy_no_pars pats) box tys
untidy' _ (ListPat _ _ (Just _)) = panic "Check.untidy: Overloaded ListPat"
untidy' _ (PArrPat _ _) = panic "Check.untidy: Shouldn't get a parallel array here!"
untidy' _ (SigPatIn _ _) = panic "Check.untidy: SigPat"
@@ -468,8 +467,8 @@ get_unused_cons used_cons = ASSERT( not (null used_cons) ) unused_cons
where
used_set :: UniqSet DataCon
used_set = mkUniqSet [d | ConPatOut{ pat_con = L _ (RealDataCon d) } <- used_cons]
- (ConPatOut { pat_ty = ty }) = head used_cons
- Just (ty_con, inst_tys) = splitTyConApp_maybe ty
+ (ConPatOut { pat_con = L _ (RealDataCon con1), pat_arg_tys = inst_tys }) = head used_cons
+ ty_con = dataConTyCon con1
unused_cons = filterOut is_used (tyConDataCons ty_con)
is_used con = con `elementOfUniqSet` used_set
|| dataConCannotMatch inst_tys con
@@ -593,9 +592,9 @@ make_con (ConPatOut{ pat_con = L _ (RealDataCon id) }) (lp:lq:ps, constraints)
| isInfixCon id = (nlInfixConPat (getName id) lp lq : ps, constraints)
where q = unLoc lq
-make_con (ConPatOut{ pat_con = L _ (RealDataCon id), pat_args = PrefixCon pats, pat_ty = 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)
+make_con (ConPatOut{ pat_con = L _ (RealDataCon id), pat_args = PrefixCon pats, pat_arg_tys = tys }) (ps, constraints)
+ | isTupleTyCon tc = (noLoc (TuplePat pats_con (tupleTyConBoxity tc) tys) : 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
@@ -696,17 +695,16 @@ tidy_pat (CoPat _ pat _) = tidy_pat pat
tidy_pat (NPlusKPat id _ _ _) = WildPat (idType (unLoc id))
tidy_pat (ViewPat _ _ ty) = WildPat ty
tidy_pat (ListPat _ _ (Just (ty,_))) = WildPat ty
-tidy_pat (ConPatOut { pat_con = L _ PatSynCon{}, pat_ty = ty })
- = WildPat ty
+tidy_pat (ConPatOut { pat_con = L _ (PatSynCon syn), pat_arg_tys = tys })
+ = WildPat (patSynInstResTy syn tys)
tidy_pat pat@(ConPatOut { pat_con = L _ con, pat_args = ps })
= pat { pat_args = tidy_con con ps }
tidy_pat (ListPat ps ty Nothing)
- = unLoc $ foldr (\ x y -> mkPrefixConPat consDataCon [x,y] list_ty)
- (mkNilPat list_ty)
+ = unLoc $ foldr (\ x y -> mkPrefixConPat consDataCon [x,y] [ty])
+ (mkNilPat ty)
(map tidy_lpat ps)
- where list_ty = mkListTy ty
-- introduce fake parallel array constructors to be able to handle parallel
-- arrays with the existing machinery for constructor pattern
@@ -714,11 +712,11 @@ tidy_pat (ListPat ps ty Nothing)
tidy_pat (PArrPat ps ty)
= unLoc $ mkPrefixConPat (parrFakeCon (length ps))
(map tidy_lpat ps)
- (mkPArrTy ty)
+ [ty]
-tidy_pat (TuplePat ps boxity ty)
+tidy_pat (TuplePat ps boxity tys)
= unLoc $ mkPrefixConPat (tupleCon (boxityNormalTupleSort boxity) arity)
- (map tidy_lpat ps) ty
+ (map tidy_lpat ps) tys
where
arity = length ps
@@ -735,8 +733,8 @@ tidy_lit_pat :: HsLit -> Pat Id
-- overlap with each other, or even explicit lists of Chars.
tidy_lit_pat lit
| HsString s <- lit
- = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] stringTy)
- (mkPrefixConPat nilDataCon [] stringTy) (unpackFS s)
+ = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] [charTy])
+ (mkPrefixConPat nilDataCon [] [charTy]) (unpackFS s)
| otherwise
= tidyLitPat lit
diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 859309d5923718a9a83b82c335d748a051c09358..a9b70037889dfadbc3359a38ef5bbabc250cb4b7 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -548,7 +548,7 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
, pat_dicts = eqs_vars ++ theta_vars
, pat_binds = emptyTcEvBinds
, pat_args = PrefixCon $ map nlVarPat arg_ids
- , pat_ty = in_ty
+ , pat_arg_tys = in_inst_tys
, pat_wrap = idHsWrapper }
; let wrapped_rhs | null eq_spec = rhs
| otherwise = mkLHsWrap (mkWpCast (mkTcSubCo wrap_co)) rhs
diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs
index 2ad70c67d360b3be0ad0c1a49e55712f062f5cec..05c217015bec7f3ce0188e47c1c87b3541259eaf 100644
--- a/compiler/deSugar/DsUtils.lhs
+++ b/compiler/deSugar/DsUtils.lhs
@@ -709,8 +709,7 @@ mkLHsVarPatTup bs = mkLHsPatTup (map nlVarPat bs)
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 (boxityNormalTupleSort box) (map hsLPatType pats))
+mkVanillaTuplePat pats box = TuplePat pats box (map hsLPatType pats)
-- The Big equivalents for the source tuple expressions
mkBigLHsVarTup :: [Id] -> LHsExpr Id
diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs
index b42a720c32d84bf9d573290791d7ed598c1d3229..2a865a9eb4e117d295194af9872ec38223d2843b 100644
--- a/compiler/deSugar/Match.lhs
+++ b/compiler/deSugar/Match.lhs
@@ -552,9 +552,8 @@ tidy1 v (LazyPat pat)
tidy1 _ (ListPat pats ty Nothing)
= return (idDsWrapper, unLoc list_ConPat)
where
- list_ty = mkListTy ty
- list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] list_ty)
- (mkNilPat list_ty)
+ list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty])
+ (mkNilPat ty)
pats
-- Introduce fake parallel array constructors to be able to handle parallel
@@ -563,13 +562,13 @@ tidy1 _ (PArrPat pats ty)
= return (idDsWrapper, unLoc parrConPat)
where
arity = length pats
- parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty)
+ parrConPat = mkPrefixConPat (parrFakeCon arity) pats [ty]
-tidy1 _ (TuplePat pats boxity ty)
+tidy1 _ (TuplePat pats boxity tys)
= return (idDsWrapper, unLoc tuple_ConPat)
where
arity = length pats
- tuple_ConPat = mkPrefixConPat (tupleCon (boxityNormalTupleSort boxity) arity) pats ty
+ tuple_ConPat = mkPrefixConPat (tupleCon (boxityNormalTupleSort boxity) arity) pats tys
-- LitPats: we *might* be able to replace these w/ a simpler form
tidy1 _ (LitPat lit)
diff --git a/compiler/deSugar/MatchCon.lhs b/compiler/deSugar/MatchCon.lhs
index 2b51638bf36b36b2484eb68ff4405230fceee174..fb024565ff2057db0175ddb4b988488730532c92 100644
--- a/compiler/deSugar/MatchCon.lhs
+++ b/compiler/deSugar/MatchCon.lhs
@@ -124,7 +124,7 @@ matchOneConLike :: [Id]
-> [EquationInfo]
-> DsM (CaseAlt ConLike)
matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor
- = do { arg_vars <- selectConMatchVars arg_tys args1
+ = do { arg_vars <- selectConMatchVars val_arg_tys args1
-- Use the first equation as a source of
-- suggestions for the new variables
@@ -140,27 +140,24 @@ matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor
alt_wrapper = wrapper1,
alt_result = foldr1 combineMatchResults match_results } }
where
- ConPatOut { pat_con = L _ con1, pat_ty = pat_ty1, pat_wrap = wrapper1,
+ ConPatOut { pat_con = L _ con1, pat_arg_tys = arg_tys, pat_wrap = wrapper1,
pat_tvs = tvs1, pat_dicts = dicts1, pat_args = args1 }
= firstPat eqn1
fields1 = case con1 of
- RealDataCon dcon1 -> dataConFieldLabels dcon1
- PatSynCon{} -> []
-
- arg_tys = inst inst_tys
- where
- inst = case con1 of
- RealDataCon dcon1 -> dataConInstOrigArgTys dcon1
- PatSynCon psyn1 -> patSynInstArgTys psyn1
- inst_tys = tcTyConAppArgs pat_ty1 ++
- mkTyVarTys (takeList exVars tvs1)
- -- Newtypes opaque, hence tcTyConAppArgs
+ RealDataCon dcon1 -> dataConFieldLabels dcon1
+ PatSynCon{} -> []
+
+ val_arg_tys = case con1 of
+ RealDataCon dcon1 -> dataConInstOrigArgTys dcon1 inst_tys
+ PatSynCon psyn1 -> patSynInstArgTys psyn1 inst_tys
+ inst_tys = ASSERT( tvs1 `equalLength` ex_tvs )
+ arg_tys ++ mkTyVarTys tvs1
-- dataConInstOrigArgTys takes the univ and existential tyvars
-- and returns the types of the *value* args, which is what we want
- where
- exVars = case con1 of
- RealDataCon dcon1 -> dataConExTyVars dcon1
- PatSynCon psyn1 -> patSynExTyVars psyn1
+
+ ex_tvs = case con1 of
+ RealDataCon dcon1 -> dataConExTyVars dcon1
+ PatSynCon psyn1 -> patSynExTyVars psyn1
match_group :: [Id] -> [(ConArgPats, EquationInfo)] -> DsM MatchResult
-- All members of the group have compatible ConArgPats
@@ -178,7 +175,7 @@ matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor
return ( wrapBinds (tvs `zip` tvs1)
. wrapBinds (ds `zip` dicts1)
. mkCoreLets ds_bind
- , eqn { eqn_pats = conArgPats arg_tys args ++ pats }
+ , eqn { eqn_pats = conArgPats val_arg_tys args ++ pats }
)
shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps)
diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs
index 7429a613d9894b9370c15f3a089223770cf6da53..9652bdf3ff080c6c8a248bc6add369cf0e2702a9 100644
--- a/compiler/deSugar/MatchLit.lhs
+++ b/compiler/deSugar/MatchLit.lhs
@@ -264,8 +264,8 @@ tidyLitPat :: HsLit -> Pat Id
tidyLitPat (HsChar c) = unLoc (mkCharLitPat c)
tidyLitPat (HsString s)
| lengthFS s <= 1 -- Short string literals only
- = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] stringTy)
- (mkNilPat stringTy) (unpackFS s)
+ = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] [charTy])
+ (mkNilPat charTy) (unpackFS s)
-- The stringTy is the type of the whole pattern, not
-- the type to instantiate (:) or [] with!
tidyLitPat lit = LitPat lit
@@ -297,7 +297,7 @@ tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _
| isStringTy ty, Just str_lit <- mb_str_lit = tidy_lit_pat (HsString str_lit)
where
mk_con_pat :: DataCon -> HsLit -> Pat Id
- mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] ty)
+ mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] [])
mb_int_lit :: Maybe Integer
mb_int_lit = case (mb_neg, val) of
diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index bd70cd7affe1fe11a0398291fc3da97f2a09db06..d40e9c88a16eb8ee4d6b18288169331af4b8c930 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -827,8 +827,8 @@ 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]) = do { p' <- cvtPat p; return $ ParPat p' } -- Note [Dropping constructors]
-cvtp (TupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed void }
-cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Unboxed void }
+cvtp (TupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed [] }
+cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Unboxed [] }
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
diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs
index ef888fe5a8e2655040a51055458b0bbd4def608b..4b8fcdaae73b6cf930bd8f37caca58b4a46c506c 100644
--- a/compiler/hsSyn/HsPat.lhs
+++ b/compiler/hsSyn/HsPat.lhs
@@ -75,10 +75,13 @@ data Pat id
-- overall type of the pattern, and the toList
-- function to convert the scrutinee to a list value
- | TuplePat [LPat id] -- Tuple
- Boxity -- UnitPat is TuplePat []
- PostTcType
- -- You might think that the PostTcType was redundant, but it's essential
+ | TuplePat [LPat id] -- Tuple sub-patterns
+ Boxity -- UnitPat is TuplePat []
+ [PostTcType] -- [] before typechecker, filled in afterwards with
+ -- the types of the tuple components
+ -- You might think that the PostTcType was redundant, because we can
+ -- get the pattern type by getting the types of the sub-patterns.
+ -- But it's essential
-- data T a where
-- T1 :: Int -> T Int
-- f :: (T a, a) -> Int
@@ -89,6 +92,8 @@ data Pat id
-- 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
+ -- (June 14: I'm not sure this comment is right; the sub-patterns
+ -- will be wrapped in CoPats, no?)
| PArrPat [LPat id] -- Syntactic parallel array
PostTcType -- The type of the elements
@@ -98,14 +103,18 @@ data Pat id
(HsConPatDetails id)
| ConPatOut {
- pat_con :: Located ConLike,
+ pat_con :: Located ConLike,
+ pat_arg_tys :: [Type], -- The univeral arg types, 1-1 with the universal
+ -- tyvars of the constructor/pattern synonym
+ -- Use (conLikeResTy pat_con pat_arg_tys) to get
+ -- the type of the pattern
+
pat_tvs :: [TyVar], -- Existentially bound type variables (tyvars only)
pat_dicts :: [EvVar], -- Ditto *coercion variables* and *dictionaries*
-- One reason for putting coercion variable here, I think,
-- is to ensure their kinds are zonked
pat_binds :: TcEvBinds, -- Bindings involving those dictionaries
pat_args :: HsConPatDetails id,
- pat_ty :: Type, -- The type of the pattern
pat_wrap :: HsWrapper -- Extra wrapper to pass to the matcher
}
@@ -313,18 +322,18 @@ instance (OutputableBndr id, Outputable arg)
%************************************************************************
\begin{code}
-mkPrefixConPat :: DataCon -> [OutPat id] -> Type -> OutPat id
+mkPrefixConPat :: DataCon -> [OutPat id] -> [Type] -> OutPat id
-- Make a vanilla Prefix constructor pattern
-mkPrefixConPat dc pats ty
+mkPrefixConPat dc pats tys
= noLoc $ ConPatOut { pat_con = noLoc (RealDataCon dc), pat_tvs = [], pat_dicts = [],
pat_binds = emptyTcEvBinds, pat_args = PrefixCon pats,
- pat_ty = ty, pat_wrap = idHsWrapper }
+ pat_arg_tys = tys, pat_wrap = idHsWrapper }
mkNilPat :: Type -> OutPat id
-mkNilPat ty = mkPrefixConPat nilDataCon [] ty
+mkNilPat ty = mkPrefixConPat nilDataCon [] [ty]
mkCharLitPat :: Char -> OutPat id
-mkCharLitPat c = mkPrefixConPat charDataCon [noLoc $ LitPat (HsCharPrim c)] charTy
+mkCharLitPat c = mkPrefixConPat charDataCon [noLoc $ LitPat (HsCharPrim c)] []
\end{code}
diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index eff67df3cfbe4bc61cef0f585957363e44912af9..a5ffda233b5ec887e99f5135fb433fcd43e66f17 100644
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -382,7 +382,7 @@ mkLHsVarTuple :: [a] -> LHsExpr a
mkLHsVarTuple ids = mkLHsTupleExpr (map nlHsVar ids)
nlTuplePat :: [LPat id] -> Boxity -> LPat id
-nlTuplePat pats box = noLoc (TuplePat pats box placeHolderType)
+nlTuplePat pats box = noLoc (TuplePat pats box [])
missingTupArg :: HsTupArg a
missingTupArg = Missing placeHolderType
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 03ec622223050a3b7e66be307da14826ef2139d4..ec00a8f22b8f2f7564168fcc1c24c30a021d1a8b 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -666,7 +666,7 @@ checkAPat msg loc e0 = do
ExplicitTuple es b
| all tupArgPresent es -> do ps <- mapM (checkLPat msg) [e | Present e <- es]
- return (TuplePat ps b placeHolderType)
+ return (TuplePat ps b [])
| otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0)
RecordCon c _ (HsRecFields fs dd)
diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs
index 3c48f340324b0c35839dae842c0cfa73aa3a5407..e668ceed8605b4e0d643390f6c7a2f7cd8017f8f 100644
--- a/compiler/rename/RnPat.lhs
+++ b/compiler/rename/RnPat.lhs
@@ -439,7 +439,7 @@ rnPatAndThen mk (PArrPat pats _)
rnPatAndThen mk (TuplePat pats boxed _)
= do { liftCps $ checkTupSize (length pats)
; pats' <- rnLPatsAndThen mk pats
- ; return (TuplePat pats' boxed placeHolderType) }
+ ; return (TuplePat pats' boxed []) }
rnPatAndThen _ (SplicePat splice)
= do { -- XXX How to deal with free variables?
diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index 59b42ea6732f5d6a1cc329c297fd6a2c3b96670a..a99888fae8f64747a6c7fa49f99dbc1bfac60bfd 100644
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -15,6 +15,7 @@ module TcHsSyn (
mkHsAppTy, mkSimpleHsAlt,
nlHsIntLit,
shortCutLit, hsOverLitName,
+ conLikeResTy,
-- re-exported from TcMonad
TcId, TcIdSet,
@@ -38,7 +39,9 @@ import TcEvidence
import TysPrim
import TysWiredIn
import Type
+import ConLike
import DataCon
+import PatSyn( patSynInstResTy )
import Name
import NameSet
import Var
@@ -80,14 +83,19 @@ hsPatType (ViewPat _ _ ty) = ty
hsPatType (ListPat _ ty Nothing) = mkListTy ty
hsPatType (ListPat _ _ (Just (ty,_))) = ty
hsPatType (PArrPat _ ty) = mkPArrTy ty
-hsPatType (TuplePat _ _ ty) = ty
-hsPatType (ConPatOut { pat_ty = ty }) = ty
+hsPatType (TuplePat _ bx tys) = mkTupleTy (boxityNormalTupleSort bx) tys
+hsPatType (ConPatOut { pat_con = L _ con, pat_arg_tys = tys })
+ = conLikeResTy con tys
hsPatType (SigPatOut _ ty) = ty
hsPatType (NPat lit _ _) = overLitType lit
hsPatType (NPlusKPat id _ _ _) = idType (unLoc id)
hsPatType (CoPat _ _ ty) = ty
hsPatType p = pprPanic "hsPatType" (ppr p)
+conLikeResTy :: ConLike -> [Type] -> Type
+conLikeResTy (RealDataCon con) tys = mkTyConApp (dataConTyCon con) tys
+conLikeResTy (PatSynCon ps) tys = patSynInstResTy ps tys
+
hsLitType :: HsLit -> TcType
hsLitType (HsChar _) = charTy
hsLitType (HsCharPrim _) = charPrimTy
@@ -1025,16 +1033,16 @@ zonk_pat env (PArrPat pats ty)
; (env', pats') <- zonkPats env pats
; return (env', PArrPat pats' ty') }
-zonk_pat env (TuplePat pats boxed ty)
- = do { ty' <- zonkTcTypeToType env ty
+zonk_pat env (TuplePat pats boxed tys)
+ = do { tys' <- mapM (zonkTcTypeToType env) tys
; (env', pats') <- zonkPats env pats
- ; return (env', TuplePat pats' boxed ty') }
+ ; return (env', TuplePat pats' boxed tys') }
-zonk_pat env p@(ConPatOut { pat_ty = ty, pat_tvs = tyvars
+zonk_pat env p@(ConPatOut { pat_arg_tys = tys, pat_tvs = tyvars
, pat_dicts = evs, pat_binds = binds
, pat_args = args, pat_wrap = wrapper })
= ASSERT( all isImmutableTyVar tyvars )
- do { new_ty <- zonkTcTypeToType env ty
+ do { new_tys <- mapM (zonkTcTypeToType env) tys
; (env0, new_tyvars) <- zonkTyBndrsX env tyvars
-- Must zonk the existential variables, because their
-- /kind/ need potential zonking.
@@ -1043,7 +1051,7 @@ zonk_pat env p@(ConPatOut { pat_ty = ty, pat_tvs = tyvars
; (env2, new_binds) <- zonkTcEvBinds env1 binds
; (env3, new_wrapper) <- zonkCoFn env2 wrapper
; (env', new_args) <- zonkConStuff env3 args
- ; return (env', p { pat_ty = new_ty,
+ ; return (env', p { pat_arg_tys = new_tys,
pat_tvs = new_tyvars,
pat_dicts = new_evs,
pat_binds = new_binds,
diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs
index 951c168b5789183ec62c4df8e829688015405f33..927062e418872225d446dde59ea3df145d7db24b 100644
--- a/compiler/typecheck/TcPat.lhs
+++ b/compiler/typecheck/TcPat.lhs
@@ -531,9 +531,9 @@ tc_pat penv (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 pat_ty' = mkTyConApp tc arg_tys
- -- pat_ty /= pat_ty iff coi /= IdCo
- unmangled_result = TuplePat pats' boxity pat_ty'
+ ; let
+ unmangled_result = TuplePat pats' boxity arg_tys
+ -- pat_ty /= pat_ty iff coi /= IdCo
possibly_mangled_result
| gopt Opt_IrrefutableTuples dflags &&
isBoxed boxity = LazyPat (noLoc unmangled_result)
@@ -730,14 +730,14 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty arg_pats thing_inside
(zipTopTvSubst univ_tvs ctxt_res_tys) ex_tvs
-- Get location from monad, not from ex_tvs
- ; let pat_ty' = mkTyConApp tycon ctxt_res_tys
+ ; let -- pat_ty' = mkTyConApp tycon ctxt_res_tys
-- pat_ty' is type of the actual constructor application
-- pat_ty' /= pat_ty iff coi /= IdCo
arg_tys' = substTys tenv arg_tys
; traceTc "tcConPat" (vcat [ ppr con_name, ppr univ_tvs, ppr ex_tvs, ppr eq_spec
- , ppr ex_tvs', ppr pat_ty', ppr arg_tys' ])
+ , ppr ex_tvs', ppr ctxt_res_tys, ppr arg_tys' ])
; if null ex_tvs && null eq_spec && null theta
then do { -- The common case; no class bindings etc
-- (see Note [Arrows and patterns])
@@ -747,7 +747,7 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty arg_pats thing_inside
pat_tvs = [], pat_dicts = [],
pat_binds = emptyTcEvBinds,
pat_args = arg_pats',
- pat_ty = pat_ty',
+ pat_arg_tys = ctxt_res_tys,
pat_wrap = idHsWrapper }
; return (mkHsWrapPat wrap res_pat pat_ty, res) }
@@ -780,7 +780,7 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty arg_pats thing_inside
pat_dicts = given,
pat_binds = ev_binds,
pat_args = arg_pats',
- pat_ty = pat_ty',
+ pat_arg_tys = ctxt_res_tys,
pat_wrap = idHsWrapper }
; return (mkHsWrapPat wrap res_pat pat_ty, res)
} }
@@ -794,7 +794,7 @@ tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside
arg_tys = patSynArgs pat_syn
ty = patSynType pat_syn
- ; (_univ_tvs', inst_tys, subst) <- tcInstTyVars univ_tvs
+ ; (univ_tvs', inst_tys, subst) <- tcInstTyVars univ_tvs
; checkExistentials ex_tvs penv
; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX subst ex_tvs
@@ -838,7 +838,7 @@ tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside
pat_dicts = prov_dicts',
pat_binds = ev_binds,
pat_args = arg_pats',
- pat_ty = ty',
+ pat_arg_tys = mkTyVarTys univ_tvs',
pat_wrap = req_wrap }
; return (mkHsWrapPat wrap res_pat pat_ty, res) }