GADT pattern matching fix

Sun Aug  6 17:01:59 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * 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 (file)
--- 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 (file)
--- 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,