X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FMatch.lhs;h=b0f58d133262b1237e64aeda3ec5f3e89eff69a8;hb=0dfd6d6bac63c0976f4b94243499d678eee30765;hp=d7c3bdb4c1c130dca3e5247afe05cb03d13d25e2;hpb=2c8f04b5b883db74f449dfc8c224929fe28b027d;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index d7c3bdb..b0f58d1 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -1,42 +1,35 @@ - % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[Main_match]{The @match@ function} \begin{code} -module Match ( match, matchExport, matchWrapper, matchSimply ) where +module Match ( match, matchExport, matchWrapper, matchSimply, matchSinglePat ) where #include "HsVersions.h" -import {-# SOURCE #-} DsExpr ( dsExpr ) -import {-# SOURCE #-} DsBinds ( dsBinds ) +import {-# SOURCE #-} DsExpr ( dsExpr, dsLet ) import CmdLineOpts ( opt_WarnIncompletePatterns, opt_WarnOverlappingPatterns, opt_WarnSimplePatterns ) import HsSyn -import TcHsSyn ( TypecheckedPat, TypecheckedMatch, - TypecheckedHsBinds, TypecheckedHsExpr ) +import TcHsSyn ( TypecheckedPat, TypecheckedMatch ) import DsHsSyn ( outPatType ) -import Check ( check, ExhaustivePat, WarningPat, BoxedString ) +import Check ( check, ExhaustivePat ) import CoreSyn import CoreUtils ( coreExprType ) import DsMonad import DsGRHSs ( dsGRHSs ) import DsUtils -import Id ( idType, dataConFieldLabels, - dataConArgTys, recordSelectorFieldLabel, - Id - ) +import Id ( idType, recordSelectorFieldLabel, Id ) +import DataCon ( dataConFieldLabels, dataConArgTys ) import MatchCon ( matchConFamily ) import MatchLit ( matchLiterals ) -import Name ( Name {--O only-} ) import PrelVals ( pAT_ERROR_ID ) -import Type ( isUnpointedType, splitAlgTyConApp, +import Type ( isUnLiftedType, splitAlgTyConApp, Type ) -import TyVar ( TyVar ) import TysPrim ( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy, addrPrimTy, wordPrimTy ) @@ -44,9 +37,11 @@ import TysWiredIn ( nilDataCon, consDataCon, mkTupleTy, mkListTy, charTy, charDataCon, intTy, intDataCon, floatTy, floatDataCon, doubleTy, tupleCon, doubleDataCon, addrTy, - addrDataCon, wordTy, wordDataCon + addrDataCon, wordTy, wordDataCon, + mkUnboxedTupleTy, unboxedTupleCon ) import UniqSet +import ErrUtils ( addErrLocHdrLine, dontAddErrLoc ) import Outputable \end{code} @@ -62,7 +57,7 @@ matchExport :: [Id] -- Vars rep'ing the exprs we're matching with -> [EquationInfo] -- Info about patterns, etc. (type synonym below) -> DsM MatchResult -- Desugared result! -matchExport vars qs@((EqnInfo _ ctx _ (MatchResult _ _ _)) : _) +matchExport vars qs@((EqnInfo _ ctx _ (MatchResult _ _)) : _) | incomplete && shadow = dsShadowWarn ctx eqns_shadow `thenDs` \ () -> dsIncompleteWarn ctx pats `thenDs` \ () -> @@ -99,61 +94,79 @@ dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM () dsShadowWarn ctx@(DsMatchContext kind _ _) qs = dsWarn warn where warn | length qs > maximum_output - = hang (pp_context ctx (ptext SLIT("are overlapped"))) - 12 ((vcat $ map (ppr_eqn kind) (take maximum_output qs)) - $$ ptext SLIT("...")) + = pp_context ctx (ptext SLIT("are overlapped")) + 8 (\ f -> vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$ + ptext SLIT("...")) | otherwise - = hang (pp_context ctx (ptext SLIT("are overlapped"))) - 12 (vcat $ map (ppr_eqn kind) qs) + = pp_context ctx (ptext SLIT("are overlapped")) + 8 (\ f -> vcat $ map (ppr_eqn f kind) qs) + dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM () dsIncompleteWarn ctx@(DsMatchContext kind _ _) pats = dsWarn warn where warn | length pats > maximum_output - = hang (pp_context ctx (ptext SLIT("are non-exhaustive"))) - 12 (hang (ptext SLIT("Patterns not recognized:")) - 4 ((vcat $ map (ppr_incomplete_pats kind) (take maximum_output pats)) - $$ ptext SLIT("..."))) + = pp_context ctx (ptext SLIT("are non-exhaustive")) + 8 (\ f -> hang (ptext SLIT("Patterns not recognized:")) + 4 (vcat (map (ppr_incomplete_pats kind) + (take maximum_output pats)) + $$ ptext SLIT("..."))) | otherwise - = hang (pp_context ctx (ptext SLIT("are non-exhaustive"))) - 12 (hang (ptext SLIT("Patterns not recognized:")) - 4 (vcat $ map (ppr_incomplete_pats kind) pats)) + = pp_context ctx (ptext SLIT("are non-exhaustive")) + 8 (\ f -> hang (ptext SLIT("Patterns not recognized:")) + 4 (vcat $ map (ppr_incomplete_pats kind) pats)) -pp_context NoMatchContext msg = ptext SLIT("Some match(es)") <+> msg +pp_context NoMatchContext msg ind rest_of_msg_fun + = dontAddErrLoc "" (ptext SLIT("Some match(es)") <+> hang msg ind (rest_of_msg_fun id)) -pp_context (DsMatchContext kind pats loc) msg - = hang (hcat [ppr loc, ptext SLIT(": ")]) - 4 (hang message - 4 (pp_match kind pats)) +pp_context (DsMatchContext kind pats loc) msg ind rest_of_msg_fun + = case pp_match kind pats of + (ppr_match, pref) -> + addErrLocHdrLine loc message (nest ind (rest_of_msg_fun pref)) + where + message = ptext SLIT("Pattern match(es)") <+> msg <+> ppr_match <> char ':' where - message = ptext SLIT("Pattern match(es)") <+> msg - pp_match (FunMatch fun) pats - = hsep [ptext SLIT("in the definition of function"), quotes (ppr fun)] + = let ppr_fun = ppr fun in + ( hsep [ptext SLIT("in the definition of function"), quotes ppr_fun] + , (\ x -> ppr_fun <+> x) + ) pp_match CaseMatch pats - = hang (ptext SLIT("in a group of case alternatives beginning:")) - 4 (ppr_pats pats) + = (hang (ptext SLIT("in a group of case alternatives beginning")) + 4 (ppr_pats pats) + , id + ) pp_match PatBindMatch pats - = hang (ptext SLIT("in a pattern binding:")) - 4 (ppr_pats pats) + = ( hang (ptext SLIT("in a pattern binding")) + 4 (ppr_pats pats) + , id + ) pp_match LambdaMatch pats - = hang (ptext SLIT("in a lambda abstraction:")) - 4 (ppr_pats pats) + = ( hang (ptext SLIT("in a lambda abstraction")) + 4 (ppr_pats pats) + , id + ) pp_match DoBindMatch pats - = hang (ptext SLIT("in a `do' pattern binding:")) - 4 (ppr_pats pats) + = ( hang (ptext SLIT("in a `do' pattern binding")) + 4 (ppr_pats pats) + , id + ) pp_match ListCompMatch pats - = hang (ptext SLIT("in a `list comprension' pattern binding:")) - 4 (ppr_pats pats) + = ( hang (ptext SLIT("in a `list comprension' pattern binding")) + 4 (ppr_pats pats) + , id + ) pp_match LetMatch pats - = hang (ptext SLIT("in a `let' pattern binding:")) - 4 (ppr_pats pats) + = ( hang (ptext SLIT("in a `let' pattern binding")) + 4 (ppr_pats pats) + , id + ) ppr_pats pats = sep (map ppr pats) @@ -165,7 +178,8 @@ separator (DoBindMatch) = SLIT("<-") separator (ListCompMatch) = SLIT("<-") separator (LetMatch) = SLIT("=") -ppr_shadow_pats kind pats = sep [ppr_pats pats, ptext (separator kind), ptext SLIT("...")] +ppr_shadow_pats kind pats + = sep [ppr_pats pats, ptext (separator kind), ptext SLIT("...")] ppr_incomplete_pats kind (pats,[]) = ppr_pats pats ppr_incomplete_pats kind (pats,constraints) = @@ -175,8 +189,7 @@ ppr_incomplete_pats kind (pats,constraints) = ppr_constraint (var,pats) = sep [ppr var, ptext SLIT("`not_elem`"), ppr pats] -ppr_eqn kind (EqnInfo _ _ pats _) = ppr_shadow_pats kind pats - +ppr_eqn prefixF kind (EqnInfo _ _ pats _) = prefixF (ppr_shadow_pats kind pats) \end{code} @@ -289,10 +302,11 @@ match [] eqns_info complete_matches (eqn:eqns) = complete_match eqn `thenDs` \ match_result1 -> complete_matches eqns `thenDs` \ match_result2 -> - combineMatchResults match_result1 match_result2 + returnDs (combineMatchResults match_result1 match_result2) - complete_match (EqnInfo _ _ [] match_result@(MatchResult _ _ _)) - = returnDs match_result + complete_match (EqnInfo _ _ pats match_result) + = ASSERT( null pats ) + returnDs match_result \end{code} %************************************************************************ @@ -324,9 +338,9 @@ match vars@(v:vs) eqns_info unmix_eqns [] = [] unmix_eqns [eqn] = [ [eqn] ] unmix_eqns (eq1@(EqnInfo _ _ (p1:p1s) _) : eq2@(EqnInfo _ _ (p2:p2s) _) : eqs) - = if ( (irrefutablePat p1 && irrefutablePat p2) - || (isConPat p1 && isConPat p2) - || (isLitPat p1 && isLitPat p2) ) then + = if ( (isWildPat p1 && isWildPat p2) + || (isConPat p1 && isConPat p2) + || (isLitPat p1 && isLitPat p2) ) then eq1 `tack_onto` unmixed_rest else [ eq1 ] : unmixed_rest @@ -349,7 +363,7 @@ match vars@(v:vs) eqns_info match_unmixed_eqn_blks vars (eqn_blk:eqn_blks) = matchUnmixedEqns vars eqn_blk `thenDs` \ match_result1 -> -- try to match with first blk match_unmixed_eqn_blks vars eqn_blks `thenDs` \ match_result2 -> - combineMatchResults match_result1 match_result2 + returnDs (combineMatchResults match_result1 match_result2) \end{code} Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@ @@ -391,6 +405,15 @@ tidyEqnInfo :: Id -> EquationInfo -> DsM EquationInfo -- DsM'd because of internal call to "match". -- "tidy1" does the interesting stuff, looking at -- one pattern and fiddling the list of bindings. + -- + -- POST CONDITION: head pattern in the EqnInfo is + -- WildPat + -- ConPat + -- NPat + -- LitPat + -- NPlusKPat + -- but no other + tidyEqnInfo v (EqnInfo n ctx (pat : pats) match_result) = tidy1 v pat match_result `thenDs` \ (pat', match_result') -> returnDs (EqnInfo n ctx (pat' : pats) match_result') @@ -404,17 +427,16 @@ tidy1 :: Id -- The Id being scrutinised -- of new bindings to be added to the front tidy1 v (VarPat var) match_result - = returnDs (WildPat (idType var), - mkCoLetsMatchResult extra_binds match_result) + = returnDs (WildPat (idType var), match_result') where - extra_binds | v == var = [] - | otherwise = [NonRec var (Var v)] + match_result' | v == var = match_result + | otherwise = adjustMatchResult (bindNonRec var (Var v)) match_result tidy1 v (AsPat var pat) match_result - = tidy1 v pat (mkCoLetsMatchResult extra_binds match_result) + = tidy1 v pat match_result' where - extra_binds | v == var = [] - | otherwise = [NonRec var (Var v)] + match_result' | v == var = match_result + | otherwise = adjustMatchResult (bindNonRec var (Var v)) match_result tidy1 v (WildPat ty) match_result = returnDs (WildPat ty, match_result) @@ -437,18 +459,15 @@ tidy1 v (LazyPat pat) match_result -- re-express as (ConPat ...) [directly] -tidy1 v (ConOpPat pat1 id pat2 ty) match_result - = returnDs (ConPat id ty [pat1, pat2], match_result) - -tidy1 v (RecPat con_id pat_ty rpats) match_result - = returnDs (ConPat con_id pat_ty pats, match_result) +tidy1 v (RecPat data_con pat_ty tvs dicts rpats) match_result + = returnDs (ConPat data_con pat_ty tvs dicts pats, match_result) where pats = map mk_pat tagged_arg_tys -- Boring stuff to find the arg-tys of the constructor (_, inst_tys, _) = splitAlgTyConApp pat_ty - con_arg_tys' = dataConArgTys con_id inst_tys - tagged_arg_tys = con_arg_tys' `zip` (dataConFieldLabels con_id) + con_arg_tys' = dataConArgTys data_con inst_tys + tagged_arg_tys = con_arg_tys' `zip` (dataConFieldLabels data_con) -- mk_pat picks a WildPat of the appropriate type for absent fields, -- and the specified pattern for present fields @@ -464,24 +483,33 @@ tidy1 v (ListPat ty pats) match_result where list_ty = mkListTy ty list_ConPat - = foldr (\ x -> \y -> ConPat consDataCon list_ty [x, y]) - (ConPat nilDataCon list_ty []) + = foldr (\ x -> \y -> ConPat consDataCon list_ty [] [] [x, y]) + (ConPat nilDataCon list_ty [] [] []) pats -tidy1 v (TuplePat pats) match_result +tidy1 v (TuplePat pats True{-boxed-}) match_result = returnDs (tuple_ConPat, match_result) where arity = length pats tuple_ConPat = ConPat (tupleCon arity) - (mkTupleTy arity (map outPatType pats)) + (mkTupleTy arity (map outPatType pats)) [] [] + pats + +tidy1 v (TuplePat pats False{-unboxed-}) match_result + = returnDs (tuple_ConPat, match_result) + where + arity = length pats + tuple_ConPat + = ConPat (unboxedTupleCon arity) + (mkUnboxedTupleTy arity (map outPatType pats)) [] [] pats tidy1 v (DictPat dicts methods) match_result = case num_of_d_and_ms of - 0 -> tidy1 v (TuplePat []) match_result + 0 -> tidy1 v (TuplePat [] True) match_result 1 -> tidy1 v (head dict_and_method_pats) match_result - _ -> tidy1 v (TuplePat dict_and_method_pats) match_result + _ -> tidy1 v (TuplePat dict_and_method_pats True) match_result where num_of_d_and_ms = length dicts + length methods dict_and_method_pats = map VarPat (dicts ++ methods) @@ -492,11 +520,11 @@ tidy1 v (DictPat dicts methods) match_result -- LitPats: the desugarer only sees these at well-known types tidy1 v pat@(LitPat lit lit_ty) match_result - | isUnpointedType lit_ty + | isUnLiftedType lit_ty = returnDs (pat, match_result) | lit_ty == charTy - = returnDs (ConPat charDataCon charTy [LitPat (mk_char lit) charPrimTy], + = returnDs (ConPat charDataCon charTy [] [] [LitPat (mk_char lit) charPrimTy], match_result) | otherwise = pprPanic "tidy1:LitPat:" (ppr pat) @@ -510,15 +538,15 @@ tidy1 v pat@(NPat lit lit_ty _) match_result = returnDs (better_pat, match_result) where better_pat - | lit_ty == charTy = ConPat charDataCon lit_ty [LitPat (mk_char lit) charPrimTy] - | lit_ty == intTy = ConPat intDataCon lit_ty [LitPat (mk_int lit) intPrimTy] - | lit_ty == wordTy = ConPat wordDataCon lit_ty [LitPat (mk_word lit) wordPrimTy] - | lit_ty == addrTy = ConPat addrDataCon lit_ty [LitPat (mk_addr lit) addrPrimTy] - | lit_ty == floatTy = ConPat floatDataCon lit_ty [LitPat (mk_float lit) floatPrimTy] - | lit_ty == doubleTy = ConPat doubleDataCon lit_ty [LitPat (mk_double lit) doublePrimTy] + | lit_ty == charTy = ConPat charDataCon lit_ty [] [] [LitPat (mk_char lit) charPrimTy] + | lit_ty == intTy = ConPat intDataCon lit_ty [] [] [LitPat (mk_int lit) intPrimTy] + | lit_ty == wordTy = ConPat wordDataCon lit_ty [] [] [LitPat (mk_word lit) wordPrimTy] + | lit_ty == addrTy = ConPat addrDataCon lit_ty [] [] [LitPat (mk_addr lit) addrPrimTy] + | lit_ty == floatTy = ConPat floatDataCon lit_ty [] [] [LitPat (mk_float lit) floatPrimTy] + | lit_ty == doubleTy = ConPat doubleDataCon lit_ty [] [] [LitPat (mk_double lit) doublePrimTy] -- Convert the literal pattern "" to the constructor pattern []. - | null_str_lit lit = ConPat nilDataCon lit_ty [] + | null_str_lit lit = ConPat nilDataCon lit_ty [] [] [] | otherwise = pat @@ -632,9 +660,10 @@ matchUnmixedEqns :: [Id] matchUnmixedEqns [] _ = panic "matchUnmixedEqns: no names" matchUnmixedEqns all_vars@(var:vars) eqns_info - | irrefutablePat first_pat - = ASSERT( irrefutablePats column_1_pats ) -- Sanity check + | isWildPat first_pat + = ASSERT( all isWildPat column_1_pats ) -- Sanity check -- Real true variables, just like in matchVar, SLPJ p 94 + -- No binding to do: they'll all be wildcards by now (done in tidy) match vars remaining_eqns_info | isConPat first_pat @@ -705,36 +734,6 @@ matchWrapper :: DsMatchKind -- For shadowing warning messages -> DsM ([Id], CoreExpr) -- Results \end{code} - a special case for the common ...: - just one Match - lots of (all?) unfailable pats - e.g., - f x y z = .... - - This special case have been ``undone'' due to problems with the new warnings - messages (Check.lhs.check). We need there the name of the variables to be able to - print later the equation. JJQC 30-11-97 - -\begin{old_code} -matchWrapper kind [(PatMatch (VarPat var) match)] error_string - = matchWrapper kind [match] error_string `thenDs` \ (vars, core_expr) -> - returnDs (var:vars, core_expr) - -matchWrapper kind [(PatMatch (WildPat ty) match)] error_string - = newSysLocalDs ty `thenDs` \ var -> - matchWrapper kind [match] error_string `thenDs` \ (vars, core_expr) -> - returnDs (var:vars, core_expr) - -matchWrapper kind [(GRHSMatch - (GRHSsAndBindsOut [GRHS [] expr _] binds _))] error_string - = dsBinds False{-don't auto-scc-} binds `thenDs` \ core_binds -> - dsExpr expr `thenDs` \ core_expr -> - returnDs ([], mkCoLetsAny core_binds core_expr) -\end{old_code} - - And all the rest... (general case) - - There is one small problem with the Lambda Patterns, when somebody writes something similar to: (\ (x:xs) -> ...) @@ -752,15 +751,15 @@ one pattern, and match simply only accepts one pattern. JJQC 30-Nov-1997 \begin{code} - matchWrapper kind matches error_string - = flattenMatches kind 1 matches `thenDs` \ eqns_info@(EqnInfo _ _ arg_pats (MatchResult _ result_ty _) : _) -> - - selectMatchVars arg_pats `thenDs` \ new_vars -> + = flattenMatches kind matches `thenDs` \ (result_ty, eqns_info) -> + let + EqnInfo _ _ arg_pats _ : _ = eqns_info + in + mapDs selectMatchVar arg_pats `thenDs` \ new_vars -> match_fun new_vars eqns_info `thenDs` \ match_result -> mkErrorAppDs pAT_ERROR_ID result_ty error_string `thenDs` \ fail_expr -> - extractMatchResult match_result fail_expr `thenDs` \ result_expr -> returnDs (new_vars, result_expr) where match_fun = case kind of @@ -783,37 +782,33 @@ pattern. It returns an expression. matchSimply :: CoreExpr -- Scrutinee -> DsMatchKind -- Match kind -> TypecheckedPat -- Pattern it should match - -> Type -- Type of result -> CoreExpr -- Return this if it matches - -> CoreExpr -- Return this if it does + -> CoreExpr -- Return this if it doesn't -> DsM CoreExpr -matchSimply (Var var) kind pat result_ty result_expr fail_expr +matchSimply scrut kind pat result_expr fail_expr = getSrcLocDs `thenDs` \ locn -> let - ctx = DsMatchContext kind [pat] locn - eqn_info = EqnInfo 1 ctx [pat] initial_match_result + ctx = DsMatchContext kind [pat] locn + match_result = cantFailMatchResult result_expr in - match_fun [var] [eqn_info] `thenDs` \ match_result -> - extractMatchResult match_result fail_expr - where - initial_match_result = MatchResult CantFail result_ty (\ ignore -> result_expr) - match_fun = if opt_WarnSimplePatterns - then matchExport - else match + matchSinglePat scrut ctx pat match_result `thenDs` \ match_result' -> + extractMatchResult match_result' fail_expr -matchSimply scrut_expr kind pat result_ty result_expr msg - = newSysLocalDs (outPatType pat) `thenDs` \ scrut_var -> - matchSimply (Var scrut_var) kind pat result_ty result_expr msg `thenDs` \ expr -> - returnDs (Let (NonRec scrut_var scrut_expr) expr) +matchSinglePat :: CoreExpr -> DsMatchContext -> TypecheckedPat + -> MatchResult -> DsM MatchResult -extractMatchResult (MatchResult CantFail _ match_fn) fail_expr - = returnDs (match_fn (error "It can't fail!")) +matchSinglePat (Var var) ctx pat match_result + = match_fn [var] [EqnInfo 1 ctx [pat] match_result] + where + match_fn | opt_WarnSimplePatterns = matchExport + | otherwise = match -extractMatchResult (MatchResult CanFail result_ty match_fn) fail_expr - = mkFailurePair result_ty `thenDs` \ (fail_bind_fn, if_it_fails) -> - returnDs (Let (fail_bind_fn fail_expr) (match_fn if_it_fails)) +matchSinglePat scrut ctx pat match_result + = selectMatchVar pat `thenDs` \ var -> + matchSinglePat (Var var) ctx pat match_result `thenDs` \ match_result' -> + returnDs (adjustMatchResult (bindNonRec var scrut) match_result') \end{code} %************************************************************************ @@ -821,6 +816,7 @@ extractMatchResult (MatchResult CanFail result_ty match_fn) fail_expr %* flattenMatches : create a list of EquationInfo * %* * %************************************************************************ + \subsection[flattenMatches]{@flattenMatches@: create @[EquationInfo]@} This is actually local to @matchWrapper@. @@ -828,44 +824,19 @@ This is actually local to @matchWrapper@. \begin{code} flattenMatches :: DsMatchKind - -> EqnNo -> [TypecheckedMatch] - -> DsM [EquationInfo] - -flattenMatches kind n [] = returnDs [] + -> DsM (Type, [EquationInfo]) -flattenMatches kind n (match : matches) - = flatten_match [] n match `thenDs` \ eqn_info -> - flattenMatches kind (n+1) matches `thenDs` \ eqn_infos -> - returnDs (eqn_info : eqn_infos) +flattenMatches kind matches + = mapAndUnzipDs flatten_match (matches `zip` [1..]) `thenDs` \ (result_tys, eqn_infos) -> + let + result_ty = head result_tys + in + ASSERT( all (== result_ty) result_tys ) + returnDs (result_ty, eqn_infos) where - flatten_match :: [TypecheckedPat] -- Reversed list of patterns encountered so far - -> EqnNo - -> TypecheckedMatch - -> DsM EquationInfo - - flatten_match pats_so_far n (PatMatch pat match) - = flatten_match (pat:pats_so_far) n match - - flatten_match pats_so_far n (GRHSMatch (GRHSsAndBindsOut grhss binds ty)) - = dsBinds False{-don't auto-scc-} binds `thenDs` \ core_binds -> - dsGRHSs ty kind pats grhss `thenDs` \ match_result -> + flatten_match (Match _ pats _ grhss, n) + = dsGRHSs kind pats grhss `thenDs` \ (ty, match_result) -> getSrcLocDs `thenDs` \ locn -> - returnDs (EqnInfo n (DsMatchContext kind pats locn) pats - (mkCoLetsMatchResult core_binds match_result)) - where - pats = reverse pats_so_far -- They've accumulated in reverse order - - flatten_match pats_so_far n (SimpleMatch expr) - = dsExpr expr `thenDs` \ core_expr -> - getSrcLocDs `thenDs` \ locn -> - returnDs (EqnInfo n (DsMatchContext kind pats locn) pats - (MatchResult CantFail (coreExprType core_expr) - (\ ignore -> core_expr))) - - -- the matching can't fail, so we won't generate an error message. - where - pats = reverse pats_so_far -- They've accumulated in reverse order - + returnDs (ty, EqnInfo n (DsMatchContext kind pats locn) pats match_result) \end{code} -