diff options
Diffstat (limited to 'compiler/deSugar/MatchCon.lhs')
| -rw-r--r-- | compiler/deSugar/MatchCon.lhs | 36 |
1 files changed, 17 insertions, 19 deletions
diff --git a/compiler/deSugar/MatchCon.lhs b/compiler/deSugar/MatchCon.lhs index 2b51638bf3..8e581f66e2 100644 --- a/compiler/deSugar/MatchCon.lhs +++ b/compiler/deSugar/MatchCon.lhs @@ -6,7 +6,8 @@ Pattern-matching constructors \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and -- detab the module (please do the detabbing in a separate patch). See @@ -124,7 +125,7 @@ matchOneConLike :: [Id] -> [EquationInfo] -> DsM (CaseAlt ConLike) matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor - = do { arg_vars <- selectConMatchVars arg_tys args1 + = do { arg_vars <- selectConMatchVars val_arg_tys args1 -- Use the first equation as a source of -- suggestions for the new variables @@ -140,27 +141,24 @@ matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor alt_wrapper = wrapper1, alt_result = foldr1 combineMatchResults match_results } } where - ConPatOut { pat_con = L _ con1, pat_ty = pat_ty1, pat_wrap = wrapper1, + ConPatOut { pat_con = L _ con1, pat_arg_tys = arg_tys, pat_wrap = wrapper1, pat_tvs = tvs1, pat_dicts = dicts1, pat_args = args1 } = firstPat eqn1 fields1 = case con1 of - RealDataCon dcon1 -> dataConFieldLabels dcon1 - PatSynCon{} -> [] - - arg_tys = inst inst_tys - where - inst = case con1 of - RealDataCon dcon1 -> dataConInstOrigArgTys dcon1 - PatSynCon psyn1 -> patSynInstArgTys psyn1 - inst_tys = tcTyConAppArgs pat_ty1 ++ - mkTyVarTys (takeList exVars tvs1) - -- Newtypes opaque, hence tcTyConAppArgs + RealDataCon dcon1 -> dataConFieldLabels dcon1 + PatSynCon{} -> [] + + val_arg_tys = case con1 of + RealDataCon dcon1 -> dataConInstOrigArgTys dcon1 inst_tys + PatSynCon psyn1 -> patSynInstArgTys psyn1 inst_tys + inst_tys = ASSERT( tvs1 `equalLength` ex_tvs ) + arg_tys ++ mkTyVarTys tvs1 -- dataConInstOrigArgTys takes the univ and existential tyvars -- and returns the types of the *value* args, which is what we want - where - exVars = case con1 of - RealDataCon dcon1 -> dataConExTyVars dcon1 - PatSynCon psyn1 -> patSynExTyVars psyn1 + + ex_tvs = case con1 of + RealDataCon dcon1 -> dataConExTyVars dcon1 + PatSynCon psyn1 -> patSynExTyVars psyn1 match_group :: [Id] -> [(ConArgPats, EquationInfo)] -> DsM MatchResult -- All members of the group have compatible ConArgPats @@ -178,7 +176,7 @@ matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor return ( wrapBinds (tvs `zip` tvs1) . wrapBinds (ds `zip` dicts1) . mkCoreLets ds_bind - , eqn { eqn_pats = conArgPats arg_tys args ++ pats } + , eqn { eqn_pats = conArgPats val_arg_tys args ++ pats } ) shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps) |