Commit 0a55a3ca authored by Simon Peyton Jones's avatar Simon Peyton Jones

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.
parent c63a4650
......@@ -15,7 +15,8 @@ module PatSyn (
patSynId, patSynType, patSynArity, patSynIsInfix,
patSynArgs, patSynTyDetails,
patSynWrapper, patSynMatcher,
patSynExTyVars, patSynSig, patSynInstArgTys
patSynExTyVars, patSynSig,
patSynInstArgTys, patSynInstResTy
) where
#include "HsVersions.h"
......@@ -125,7 +126,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,
......@@ -263,6 +264,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 )
......@@ -270,4 +278,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}
......@@ -23,7 +23,6 @@ import Name
import TysWiredIn
import PrelNames
import TyCon
import Type
import SrcLoc
import UniqSet
import Util
......@@ -146,7 +145,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"
......@@ -470,8 +469,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
......@@ -595,9 +594,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
......@@ -698,17 +697,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
......@@ -716,11 +714,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
......@@ -737,8 +735,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
......
......@@ -550,7 +550,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
......
......@@ -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
......
......@@ -554,9 +554,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
......@@ -565,13 +564,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)
......
......@@ -125,7 +125,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
......@@ -141,27 +141,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
......@@ -179,7 +176,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)
......
......@@ -266,8 +266,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
......@@ -299,7 +299,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
......
......@@ -830,8 +830,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
......
......@@ -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}
......
......@@ -383,7 +383,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
......
......@@ -668,7 +668,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)
......
......@@ -434,7 +434,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?
......
......@@ -17,6 +17,7 @@ module TcHsSyn (
mkHsAppTy, mkSimpleHsAlt,
nlHsIntLit,
shortCutLit, hsOverLitName,
conLikeResTy,
-- re-exported from TcMonad
TcId, TcIdSet,
......@@ -40,7 +41,9 @@ import TcEvidence
import TysPrim
import TysWiredIn
import Type
import ConLike
import DataCon
import PatSyn( patSynInstResTy )
import Name
import NameSet
import Var
......@@ -82,14 +85,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
......@@ -1027,16 +1035,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.
......@@ -1045,7 +1053,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,
......
......@@ -532,9 +532,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)
......@@ -731,14 +731,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])
......@@ -748,7 +748,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) }
......@@ -781,7 +781,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)
} }
......@@ -795,7 +795,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
......@@ -839,7 +839,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) }
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment