From: Manuel M T Chakravarty Date: Mon, 18 Sep 2006 20:40:38 +0000 (+0000) Subject: GADT pattern matching fix X-Git-Tag: After_FC_branch_merge~112 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=f86fa5fd11a2847c6687ad84d579760a7a06eb8b 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 --- 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,