Merge Haddock comment support from ghc.haddock -- big patch

[ghc-hetmet.git] / compiler / deSugar / MatchCon.lhs

diff --git a/compiler/deSugar/MatchCon.lhs b/compiler/deSugar/MatchCon.lhs
index 2612b50..c4c38b1 100644 (file)
--- a/compiler/deSugar/MatchCon.lhs
+++ b/compiler/deSugar/MatchCon.lhs
@@ -10,9 +10,9 @@ module MatchCon ( matchConFamily ) where
 
 import {-# SOURCE #-} Match    ( match )
 
-import HsSyn           ( Pat(..), LPat, HsConDetails(..) )
+import HsSyn           ( Pat(..), LPat, HsConDetails(..), HsRecField(..) )
 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, 
@@ -131,7 +132,7 @@ conArgPats data_con arg_tys (RecCon rpats)
        -- mk_pat picks a WildPat of the appropriate type for absent fields,
        -- and the specified pattern for present fields
     mk_pat lbl arg_ty
-       = case [ pat | (sel_id,pat) <- rpats, idName (unLoc sel_id) == lbl] of
+       = case [ pat | HsRecField sel_id pat _ <- rpats, idName (unLoc sel_id) == lbl ] of
            (pat:pats) -> ASSERT( null pats ) unLoc pat
            []         -> WildPat arg_ty
 \end{code}