From f895f334d117b8295471897c527dd57335e75eb7 Mon Sep 17 00:00:00 2001
From: Simon Peyton Jones <simonpj@microsoft.com>
Date: Thu, 5 Jun 2014 11:03:45 +0100
Subject: [PATCH] Fix egregious instantiation bug in matchOneConLike (fixing
Trac #9023)
We simply weren't giving anything like the right instantiating types
to patSynInstArgTys in matchOneConLike.
To get these instantiating types would have involved matching the
result type of the pattern synonym with the pattern type, which is
tiresome. So instead I changed ConPatOut so that instead of recording
the type of the *whole* pattern (in old field pat_ty), it not records
the *instantiating* types (in new field pat_arg_tys). Then we canuse
TcHsSyn.conLikeResTy to get the pattern type when needed.
There are lots of knock-on incidental effects, but they mostly made
the code simpler, so I'm happy.
(cherry picked from commit 0a55a3cada2fea37586b1a270c1511ed9957dbd4)
---
compiler/basicTypes/PatSyn.lhs | 25 +++++++++++++++++++++++--
compiler/deSugar/Check.lhs | 32 +++++++++++++++-----------------
compiler/deSugar/DsExpr.lhs | 2 +-
compiler/deSugar/DsUtils.lhs | 3 +--
compiler/deSugar/Match.lhs | 11 +++++------
compiler/deSugar/MatchCon.lhs | 33 +++++++++++++++------------------
compiler/deSugar/MatchLit.lhs | 6 +++---
compiler/hsSyn/Convert.lhs | 4 ++--
compiler/hsSyn/HsPat.lhs | 31 ++++++++++++++++++++-----------
compiler/hsSyn/HsUtils.lhs | 2 +-
compiler/parser/RdrHsSyn.lhs | 2 +-
compiler/rename/RnPat.lhs | 2 +-
compiler/typecheck/TcHsSyn.lhs | 24 ++++++++++++++++--------
compiler/typecheck/TcPat.lhs | 18 +++++++++---------
14 files changed, 113 insertions(+), 82 deletions(-)
diff --git a/compiler/basicTypes/PatSyn.lhs b/compiler/basicTypes/PatSyn.lhs
index 29c1193482a0..b3c85016ec51 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 960475cedd03..409c05b176dd 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 859309d59237..a9b70037889d 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 2ad70c67d360..05c217015bec 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 b42a720c32d8..2a865a9eb4e1 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 2b51638bf36b..fb024565ff20 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 7429a613d989..9652bdf3ff08 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 bd70cd7affe1..d40e9c88a16e 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 ef888fe5a8e2..4b8fcdaae73b 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 eff67df3cfbe..a5ffda233b5e 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 03ec62222305..ec00a8f22b8f 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 3c48f340324b..e668ceed8605 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 59b42ea6732f..a99888fae8f6 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 951c168b5789..927062e41887 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) }
--
GitLab