From f86fa5fd11a2847c6687ad84d579760a7a06eb8b Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Mon, 18 Sep 2006 20:40:38 +0000 Subject: [PATCH] GADT pattern matching fix Sun Aug 6 17:01:59 EDT 2006 Manuel M T Chakravarty * GADT pattern matching fix Wed Jul 19 10:53:09 EDT 2006 kevind@bu.edu --- compiler/basicTypes/DataCon.lhs | 4 ++-- compiler/deSugar/MatchCon.lhs | 5 +++-- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index 8d300d2..289fdef 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -603,10 +603,10 @@ dataConInstArgTys (MkData {dcRepArgTys = arg_tys, -- And the same deal for the original arg tys dataConInstOrigArgTys :: DataCon -> [Type] -> [Type] -dataConInstOrigArgTys (MkData {dcOrigArgTys = arg_tys, +dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys, dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs}) inst_tys - = ASSERT( length tyvars == length inst_tys ) + = ASSERT2( length tyvars == length inst_tys, ptext SLIT("dataConInstOrigArgTys") <+> ppr dc <+> ppr inst_tys ) map (substTyWith tyvars inst_tys) arg_tys where tyvars = univ_tvs ++ ex_tvs diff --git a/compiler/deSugar/MatchCon.lhs b/compiler/deSugar/MatchCon.lhs index 2612b50..fd840e6 100644 --- a/compiler/deSugar/MatchCon.lhs +++ b/compiler/deSugar/MatchCon.lhs @@ -12,7 +12,7 @@ import {-# SOURCE #-} Match ( match ) import HsSyn ( Pat(..), LPat, HsConDetails(..) ) import DsBinds ( dsLHsBinds ) -import DataCon ( DataCon, dataConInstOrigArgTys, +import DataCon ( DataCon, dataConInstOrigArgTys, dataConEqSpec, dataConFieldLabels, dataConSourceArity ) import TcType ( tcTyConAppArgs ) import Type ( mkTyVarTys ) @@ -100,7 +100,8 @@ matchOneCon vars ty (eqn1 : eqns) -- All eqns for a single constructor pat_tvs = tvs1, pat_dicts = dicts1 } = firstPat eqn1 arg_tys = dataConInstOrigArgTys con inst_tys - inst_tys = tcTyConAppArgs pat_ty1 ++ mkTyVarTys tvs1 + n_co_args = length (dataConEqSpec con) + inst_tys = tcTyConAppArgs pat_ty1 ++ (drop n_co_args $ mkTyVarTys tvs1) -- Newtypes opaque, hence tcTyConAppArgs shift eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_tvs = tvs, pat_dicts = ds, -- 1.7.10.4