diff options
| author | Lemmih <lemmih@gmail.com> | 2007-06-07 21:38:37 +0000 |
|---|---|---|
| committer | Lemmih <lemmih@gmail.com> | 2007-06-07 21:38:37 +0000 |
| commit | 00b6d2567426ec52a113b1d3687e1d61368cafda (patch) | |
| tree | 12bb409c49bfb5c2eb7b0971ac150c8bfe7d0f7f /compiler/deSugar/MatchCon.lhs | |
| parent | 481b014b46dd53ef5d1c5e679e1d9f08207af96e (diff) | |
| download | haskell-00b6d2567426ec52a113b1d3687e1d61368cafda.tar.gz | |
Fix a bug in MatchCon, and clarify what dataConInstOrigArgTys does
There was an outright bug in MatchCon.matchOneCon, in the construction
of arg_tys. Easily fixed. It never showed up becuase the arg_tys are
only used in WildPats, and they in turn seldom have their types looked
(except by hsPatType). So I can't make a test case for htis.
While I was investigating, I added a bit of clarifation and
invariant-checking to dataConInstOrigArgTys and dataConInstArgTys
Diffstat (limited to 'compiler/deSugar/MatchCon.lhs')
| -rw-r--r-- | compiler/deSugar/MatchCon.lhs | 20 |
1 files changed, 12 insertions, 8 deletions
diff --git a/compiler/deSugar/MatchCon.lhs b/compiler/deSugar/MatchCon.lhs index 5233d59037..3f25fc7a6e 100644 --- a/compiler/deSugar/MatchCon.lhs +++ b/compiler/deSugar/MatchCon.lhs @@ -20,7 +20,7 @@ import Type import CoreSyn import DsMonad import DsUtils - +import Util ( takeList ) import Id import SrcLoc import Outputable @@ -88,21 +88,23 @@ matchConFamily (var:vars) ty groups matchOneCon vars ty (eqn1 : eqns) -- All eqns for a single constructor = do { (wraps, eqns') <- mapAndUnzipM shift (eqn1:eqns) - ; arg_vars <- selectMatchVars (take (dataConSourceArity con) + ; arg_vars <- selectMatchVars (take (dataConSourceArity con1) (eqn_pats (head eqns'))) -- Use the new arugment patterns as a source of -- suggestions for the new variables ; match_result <- match (arg_vars ++ vars) ty eqns' - ; return (con, tvs1 ++ dicts1 ++ arg_vars, + ; return (con1, tvs1 ++ dicts1 ++ arg_vars, adjustMatchResult (foldr1 (.) wraps) match_result) } where - ConPatOut { pat_con = L _ con, pat_ty = pat_ty1, + ConPatOut { pat_con = L _ con1, pat_ty = pat_ty1, pat_tvs = tvs1, pat_dicts = dicts1 } = firstPat eqn1 - arg_tys = dataConInstOrigArgTys con inst_tys - n_co_args = length (dataConEqSpec con) - inst_tys = tcTyConAppArgs pat_ty1 ++ (drop n_co_args $ mkTyVarTys tvs1) + arg_tys = dataConInstOrigArgTys con1 inst_tys + inst_tys = tcTyConAppArgs pat_ty1 ++ + mkTyVarTys (takeList (dataConExTyVars con1) tvs1) -- Newtypes opaque, hence tcTyConAppArgs + -- dataConInstOrigArgTys takes the univ and existential tyvars + -- and returns the types of the *value* args, which is what we want shift eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_tvs = tvs, pat_dicts = ds, pat_binds = bind, pat_args = args @@ -111,10 +113,12 @@ matchOneCon vars ty (eqn1 : eqns) -- All eqns for a single constructor ; return (wrapBinds (tvs `zip` tvs1) . wrapBinds (ds `zip` dicts1) . mkDsLet (Rec prs), - eqn { eqn_pats = conArgPats con arg_tys args ++ pats }) } + eqn { eqn_pats = conArgPats con1 arg_tys args ++ pats }) } conArgPats :: DataCon -> [Type] -- Instantiated argument types + -- Used only to fill in the types of WildPats, which + -- are probably never looked at anyway -> HsConDetails Id (LPat Id) -> [Pat Id] conArgPats data_con arg_tys (PrefixCon ps) = map unLoc ps |