diff options
Diffstat (limited to 'compiler/deSugar/Match.lhs')
| -rw-r--r-- | compiler/deSugar/Match.lhs | 740 |
1 files changed, 740 insertions, 0 deletions
diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs new file mode 100644 index 0000000000..d72d6adf17 --- /dev/null +++ b/compiler/deSugar/Match.lhs @@ -0,0 +1,740 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section[Main_match]{The @match@ function} + +\begin{code} +module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat ) where + +#include "HsVersions.h" + +import DynFlags ( DynFlag(..), dopt ) +import HsSyn +import TcHsSyn ( mkVanillaTuplePat ) +import Check ( check, ExhaustivePat ) +import CoreSyn +import CoreUtils ( bindNonRec, exprType ) +import DsMonad +import DsBinds ( dsLHsBinds ) +import DsGRHSs ( dsGRHSs ) +import DsUtils +import Id ( idName, idType, Id ) +import DataCon ( dataConFieldLabels, dataConInstOrigArgTys, isVanillaDataCon ) +import MatchCon ( matchConFamily ) +import MatchLit ( matchLiterals, matchNPlusKPats, matchNPats, tidyLitPat, tidyNPat ) +import PrelInfo ( pAT_ERROR_ID ) +import TcType ( Type, tcTyConAppArgs ) +import Type ( splitFunTysN, mkTyVarTys ) +import TysWiredIn ( consDataCon, mkListTy, unitTy, + tupleCon, parrFakeCon, mkPArrTy ) +import BasicTypes ( Boxity(..) ) +import ListSetOps ( runs ) +import SrcLoc ( noLoc, unLoc, Located(..) ) +import Util ( lengthExceeds, notNull ) +import Name ( Name ) +import Outputable +\end{code} + +This function is a wrapper of @match@, it must be called from all the parts where +it was called match, but only substitutes the firs call, .... +if the associated flags are declared, warnings will be issued. +It can not be called matchWrapper because this name already exists :-( + +JJCQ 30-Nov-1997 + +\begin{code} +matchCheck :: DsMatchContext + -> [Id] -- Vars rep'ing the exprs we're matching with + -> Type -- Type of the case expression + -> [EquationInfo] -- Info about patterns, etc. (type synonym below) + -> DsM MatchResult -- Desugared result! + +matchCheck ctx vars ty qs + = getDOptsDs `thenDs` \ dflags -> + matchCheck_really dflags ctx vars ty qs + +matchCheck_really dflags ctx vars ty qs + | incomplete && shadow = + dsShadowWarn ctx eqns_shadow `thenDs` \ () -> + dsIncompleteWarn ctx pats `thenDs` \ () -> + match vars ty qs + | incomplete = + dsIncompleteWarn ctx pats `thenDs` \ () -> + match vars ty qs + | shadow = + dsShadowWarn ctx eqns_shadow `thenDs` \ () -> + match vars ty qs + | otherwise = + match vars ty qs + where (pats, eqns_shadow) = check qs + incomplete = want_incomplete && (notNull pats) + want_incomplete = case ctx of + DsMatchContext RecUpd _ -> + dopt Opt_WarnIncompletePatternsRecUpd dflags + _ -> + dopt Opt_WarnIncompletePatterns dflags + shadow = dopt Opt_WarnOverlappingPatterns dflags + && not (null eqns_shadow) +\end{code} + +This variable shows the maximum number of lines of output generated for warnings. +It will limit the number of patterns/equations displayed to@ maximum_output@. + +(ToDo: add command-line option?) + +\begin{code} +maximum_output = 4 +\end{code} + +The next two functions create the warning message. + +\begin{code} +dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM () +dsShadowWarn ctx@(DsMatchContext kind loc) qs + = putSrcSpanDs loc (dsWarn warn) + where + warn | qs `lengthExceeds` maximum_output + = pp_context ctx (ptext SLIT("are overlapped")) + (\ f -> vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$ + ptext SLIT("...")) + | otherwise + = pp_context ctx (ptext SLIT("are overlapped")) + (\ f -> vcat $ map (ppr_eqn f kind) qs) + + +dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM () +dsIncompleteWarn ctx@(DsMatchContext kind loc) pats + = putSrcSpanDs loc (dsWarn warn) + where + warn = pp_context ctx (ptext SLIT("are non-exhaustive")) + (\f -> hang (ptext SLIT("Patterns not matched:")) + 4 ((vcat $ map (ppr_incomplete_pats kind) + (take maximum_output pats)) + $$ dots)) + + dots | pats `lengthExceeds` maximum_output = ptext SLIT("...") + | otherwise = empty + +pp_context (DsMatchContext kind _loc) msg rest_of_msg_fun + = vcat [ptext SLIT("Pattern match(es)") <+> msg, + sep [ptext SLIT("In") <+> ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]] + where + (ppr_match, pref) + = case kind of + FunRhs fun -> (pprMatchContext kind, \ pp -> ppr fun <+> pp) + other -> (pprMatchContext kind, \ pp -> pp) + +ppr_pats pats = sep (map ppr pats) + +ppr_shadow_pats kind pats + = sep [ppr_pats pats, matchSeparator kind, ptext SLIT("...")] + +ppr_incomplete_pats kind (pats,[]) = ppr_pats pats +ppr_incomplete_pats kind (pats,constraints) = + sep [ppr_pats pats, ptext SLIT("with"), + sep (map ppr_constraint constraints)] + + +ppr_constraint (var,pats) = sep [ppr var, ptext SLIT("`notElem`"), ppr pats] + +ppr_eqn prefixF kind eqn = prefixF (ppr_shadow_pats kind (eqn_pats eqn)) +\end{code} + + +The function @match@ is basically the same as in the Wadler chapter, +except it is monadised, to carry around the name supply, info about +annotations, etc. + +Notes on @match@'s arguments, assuming $m$ equations and $n$ patterns: +\begin{enumerate} +\item +A list of $n$ variable names, those variables presumably bound to the +$n$ expressions being matched against the $n$ patterns. Using the +list of $n$ expressions as the first argument showed no benefit and +some inelegance. + +\item +The second argument, a list giving the ``equation info'' for each of +the $m$ equations: +\begin{itemize} +\item +the $n$ patterns for that equation, and +\item +a list of Core bindings [@(Id, CoreExpr)@ pairs] to be ``stuck on +the front'' of the matching code, as in: +\begin{verbatim} +let <binds> +in <matching-code> +\end{verbatim} +\item +and finally: (ToDo: fill in) + +The right way to think about the ``after-match function'' is that it +is an embryonic @CoreExpr@ with a ``hole'' at the end for the +final ``else expression''. +\end{itemize} + +There is a type synonym, @EquationInfo@, defined in module @DsUtils@. + +An experiment with re-ordering this information about equations (in +particular, having the patterns available in column-major order) +showed no benefit. + +\item +A default expression---what to evaluate if the overall pattern-match +fails. This expression will (almost?) always be +a measly expression @Var@, unless we know it will only be used once +(as we do in @glue_success_exprs@). + +Leaving out this third argument to @match@ (and slamming in lots of +@Var "fail"@s) is a positively {\em bad} idea, because it makes it +impossible to share the default expressions. (Also, it stands no +chance of working in our post-upheaval world of @Locals@.) +\end{enumerate} +So, the full type signature: +\begin{code} +match :: [Id] -- Variables rep'ing the exprs we're matching with + -> Type -- Type of the case expression + -> [EquationInfo] -- Info about patterns, etc. (type synonym below) + -> DsM MatchResult -- Desugared result! +\end{code} + +Note: @match@ is often called via @matchWrapper@ (end of this module), +a function that does much of the house-keeping that goes with a call +to @match@. + +It is also worth mentioning the {\em typical} way a block of equations +is desugared with @match@. At each stage, it is the first column of +patterns that is examined. The steps carried out are roughly: +\begin{enumerate} +\item +Tidy the patterns in column~1 with @tidyEqnInfo@ (this may add +bindings to the second component of the equation-info): +\begin{itemize} +\item +Remove the `as' patterns from column~1. +\item +Make all constructor patterns in column~1 into @ConPats@, notably +@ListPats@ and @TuplePats@. +\item +Handle any irrefutable (or ``twiddle'') @LazyPats@. +\end{itemize} +\item +Now {\em unmix} the equations into {\em blocks} [w/ local function +@unmix_eqns@], in which the equations in a block all have variable +patterns in column~1, or they all have constructor patterns in ... +(see ``the mixture rule'' in SLPJ). +\item +Call @matchEqnBlock@ on each block of equations; it will do the +appropriate thing for each kind of column-1 pattern, usually ending up +in a recursive call to @match@. +\end{enumerate} + +%************************************************************************ +%* * +%* match: empty rule * +%* * +%************************************************************************ +\subsection[Match-empty-rule]{The ``empty rule''} + +We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87) +than the Wadler-chapter code for @match@ (p.~93, first @match@ clause). +And gluing the ``success expressions'' together isn't quite so pretty. + +\begin{code} +match [] ty eqns_info + = ASSERT( not (null eqns_info) ) + returnDs (foldr1 combineMatchResults match_results) + where + match_results = [ ASSERT( null (eqn_pats eqn) ) + adjustMatchResult (eqn_wrap eqn) (eqn_rhs eqn) + | eqn <- eqns_info ] +\end{code} + + +%************************************************************************ +%* * +%* match: non-empty rule * +%* * +%************************************************************************ +\subsection[Match-nonempty]{@match@ when non-empty: unmixing} + +This (more interesting) clause of @match@ uses @tidy_and_unmix_eqns@ +(a)~to get `as'- and `twiddle'-patterns out of the way (tidying), and +(b)~to do ``the mixture rule'' (SLPJ, p.~88) [which really {\em +un}mixes the equations], producing a list of equation-info +blocks, each block having as its first column of patterns either all +constructors, or all variables (or similar beasts), etc. + +@match_unmixed_eqn_blks@ simply takes the place of the @foldr@ in the +Wadler-chapter @match@ (p.~93, last clause), and @match_unmixed_blk@ +corresponds roughly to @matchVarCon@. + +\begin{code} +match vars@(v:_) ty eqns_info + = do { tidy_eqns <- mappM (tidyEqnInfo v) eqns_info + ; let eqns_blks = runs same_family tidy_eqns + ; match_results <- mappM match_block eqns_blks + ; ASSERT( not (null match_results) ) + return (foldr1 combineMatchResults match_results) } + where + same_family eqn1 eqn2 + = samePatFamily (firstPat eqn1) (firstPat eqn2) + + match_block eqns + = case firstPat (head eqns) of + WildPat {} -> matchVariables vars ty eqns + ConPatOut {} -> matchConFamily vars ty eqns + NPlusKPat {} -> matchNPlusKPats vars ty eqns + NPat {} -> matchNPats vars ty eqns + LitPat {} -> matchLiterals vars ty eqns + +-- After tidying, there are only five kinds of patterns +samePatFamily (WildPat {}) (WildPat {}) = True +samePatFamily (ConPatOut {}) (ConPatOut {}) = True +samePatFamily (NPlusKPat {}) (NPlusKPat {}) = True +samePatFamily (NPat {}) (NPat {}) = True +samePatFamily (LitPat {}) (LitPat {}) = True +samePatFamily _ _ = False + +matchVariables :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult +-- Real true variables, just like in matchVar, SLPJ p 94 +-- No binding to do: they'll all be wildcards by now (done in tidy) +matchVariables (var:vars) ty eqns = match vars ty (shiftEqns eqns) +\end{code} + + +\end{code} + +Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@ +which will be scrutinised. This means: +\begin{itemize} +\item +Replace variable patterns @x@ (@x /= v@) with the pattern @_@, +together with the binding @x = v@. +\item +Replace the `as' pattern @x@@p@ with the pattern p and a binding @x = v@. +\item +Removing lazy (irrefutable) patterns (you don't want to know...). +\item +Converting explicit tuple-, list-, and parallel-array-pats into ordinary +@ConPats@. +\item +Convert the literal pat "" to []. +\end{itemize} + +The result of this tidying is that the column of patterns will include +{\em only}: +\begin{description} +\item[@WildPats@:] +The @VarPat@ information isn't needed any more after this. + +\item[@ConPats@:] +@ListPats@, @TuplePats@, etc., are all converted into @ConPats@. + +\item[@LitPats@ and @NPats@:] +@LitPats@/@NPats@ of ``known friendly types'' (Int, Char, +Float, Double, at least) are converted to unboxed form; e.g., +\tr{(NPat (HsInt i) _ _)} is converted to: +\begin{verbatim} +(ConPat I# _ _ [LitPat (HsIntPrim i)]) +\end{verbatim} +\end{description} + +\begin{code} +tidyEqnInfo :: Id -> EquationInfo -> DsM EquationInfo + -- DsM'd because of internal call to dsLHsBinds + -- and mkSelectorBinds. + -- "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 eqn@(EqnInfo { eqn_wrap = wrap, eqn_pats = pat : pats }) + = tidy1 v wrap pat `thenDs` \ (wrap', pat') -> + returnDs (eqn { eqn_wrap = wrap', eqn_pats = pat' : pats }) + +tidy1 :: Id -- The Id being scrutinised + -> DsWrapper -- Previous wrapping bindings + -> Pat Id -- The pattern against which it is to be matched + -> DsM (DsWrapper, -- Extra bindings around what to do afterwards + Pat Id) -- Equivalent pattern + +-- The extra bindings etc are all wrapped around the RHS of the match +-- so they are only available when matching is complete. But that's ok +-- becuase, for example, in the pattern x@(...), the x can only be +-- used in the RHS, not in the nested pattern, nor subsquent patterns +-- +-- However this does have an awkward consequence. The bindings in +-- a VarPatOut get wrapped around the result in right to left order, +-- rather than left to right. This only matters if one set of +-- bindings can mention things used in another, and that can happen +-- if we allow equality dictionary bindings of form d1=d2. +-- bindIInstsOfLocalFuns is now careful not to do this, but it's a wart. +-- (Without this care in bindInstsOfLocalFuns, compiling +-- Data.Generics.Schemes.hs fails in function everywhereBut.) + +------------------------------------------------------- +-- (pat', mr') = tidy1 v pat mr +-- tidies the *outer level only* of pat, giving pat' +-- It eliminates many pattern forms (as-patterns, variable patterns, +-- list patterns, etc) yielding one of: +-- WildPat +-- ConPatOut +-- LitPat +-- NPat +-- NPlusKPat + +tidy1 v wrap (ParPat pat) = tidy1 v wrap (unLoc pat) +tidy1 v wrap (SigPatOut pat _) = tidy1 v wrap (unLoc pat) +tidy1 v wrap (WildPat ty) = returnDs (wrap, WildPat ty) + + -- case v of { x -> mr[] } + -- = case v of { _ -> let x=v in mr[] } +tidy1 v wrap (VarPat var) + = returnDs (wrap . wrapBind var v, WildPat (idType var)) + +tidy1 v wrap (VarPatOut var binds) + = do { prs <- dsLHsBinds binds + ; return (wrap . wrapBind var v . mkDsLet (Rec prs), + WildPat (idType var)) } + + -- case v of { x@p -> mr[] } + -- = case v of { p -> let x=v in mr[] } +tidy1 v wrap (AsPat (L _ var) pat) + = tidy1 v (wrap . wrapBind var v) (unLoc pat) + +tidy1 v wrap (BangPat pat) + = tidy1 v (wrap . seqVar v) (unLoc pat) + +{- now, here we handle lazy patterns: + tidy1 v ~p bs = (v, v1 = case v of p -> v1 : + v2 = case v of p -> v2 : ... : bs ) + + where the v_i's are the binders in the pattern. + + ToDo: in "v_i = ... -> v_i", are the v_i's really the same thing? + + The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr +-} + +tidy1 v wrap (LazyPat pat) + = do { v' <- newSysLocalDs (idType v) + ; sel_prs <- mkSelectorBinds pat (Var v) + ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs] + ; returnDs (wrap . wrapBind v' v . mkDsLets sel_binds, + WildPat (idType v)) } + +-- re-express <con-something> as (ConPat ...) [directly] + +tidy1 v wrap (ConPatOut (L loc con) ex_tvs dicts binds ps pat_ty) + = returnDs (wrap, ConPatOut (L loc con) ex_tvs dicts binds tidy_ps pat_ty) + where + tidy_ps = PrefixCon (tidy_con con ex_tvs pat_ty ps) + +tidy1 v wrap (ListPat pats ty) + = returnDs (wrap, unLoc list_ConPat) + where + list_ty = mkListTy ty + list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] list_ty) + (mkNilPat list_ty) + pats + +-- Introduce fake parallel array constructors to be able to handle parallel +-- arrays with the existing machinery for constructor pattern +tidy1 v wrap (PArrPat pats ty) + = returnDs (wrap, unLoc parrConPat) + where + arity = length pats + parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty) + +tidy1 v wrap (TuplePat pats boxity ty) + = returnDs (wrap, unLoc tuple_ConPat) + where + arity = length pats + tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats ty + +tidy1 v wrap (DictPat dicts methods) + = case num_of_d_and_ms of + 0 -> tidy1 v wrap (TuplePat [] Boxed unitTy) + 1 -> tidy1 v wrap (unLoc (head dict_and_method_pats)) + _ -> tidy1 v wrap (mkVanillaTuplePat dict_and_method_pats Boxed) + where + num_of_d_and_ms = length dicts + length methods + dict_and_method_pats = map nlVarPat (dicts ++ methods) + +-- LitPats: we *might* be able to replace these w/ a simpler form +tidy1 v wrap pat@(LitPat lit) + = returnDs (wrap, unLoc (tidyLitPat lit (noLoc pat))) + +-- NPats: we *might* be able to replace these w/ a simpler form +tidy1 v wrap pat@(NPat lit mb_neg _ lit_ty) + = returnDs (wrap, unLoc (tidyNPat lit mb_neg lit_ty (noLoc pat))) + +-- and everything else goes through unchanged... + +tidy1 v wrap non_interesting_pat + = returnDs (wrap, non_interesting_pat) + + +tidy_con data_con ex_tvs pat_ty (PrefixCon ps) = ps +tidy_con data_con ex_tvs pat_ty (InfixCon p1 p2) = [p1,p2] +tidy_con data_con ex_tvs pat_ty (RecCon rpats) + | null rpats + = -- Special case for C {}, which can be used for + -- a constructor that isn't declared to have + -- fields at all + map (noLoc . WildPat) con_arg_tys' + + | otherwise + = map mk_pat tagged_arg_tys + where + -- Boring stuff to find the arg-tys of the constructor + + inst_tys | isVanillaDataCon data_con = tcTyConAppArgs pat_ty -- Newtypes must be opaque + | otherwise = mkTyVarTys ex_tvs + + con_arg_tys' = dataConInstOrigArgTys 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 + mk_pat (arg_ty, lbl) = + case [ pat | (sel_id,pat) <- rpats, idName (unLoc sel_id) == lbl] of + (pat:pats) -> ASSERT( null pats ) pat + [] -> noLoc (WildPat arg_ty) +\end{code} + +\noindent +{\bf Previous @matchTwiddled@ stuff:} + +Now we get to the only interesting part; note: there are choices for +translation [from Simon's notes]; translation~1: +\begin{verbatim} +deTwiddle [s,t] e +\end{verbatim} +returns +\begin{verbatim} +[ w = e, + s = case w of [s,t] -> s + t = case w of [s,t] -> t +] +\end{verbatim} + +Here \tr{w} is a fresh variable, and the \tr{w}-binding prevents multiple +evaluation of \tr{e}. An alternative translation (No.~2): +\begin{verbatim} +[ w = case e of [s,t] -> (s,t) + s = case w of (s,t) -> s + t = case w of (s,t) -> t +] +\end{verbatim} + +%************************************************************************ +%* * +\subsubsection[improved-unmixing]{UNIMPLEMENTED idea for improved unmixing} +%* * +%************************************************************************ + +We might be able to optimise unmixing when confronted by +only-one-constructor-possible, of which tuples are the most notable +examples. Consider: +\begin{verbatim} +f (a,b,c) ... = ... +f d ... (e:f) = ... +f (g,h,i) ... = ... +f j ... = ... +\end{verbatim} +This definition would normally be unmixed into four equation blocks, +one per equation. But it could be unmixed into just one equation +block, because if the one equation matches (on the first column), +the others certainly will. + +You have to be careful, though; the example +\begin{verbatim} +f j ... = ... +------------------- +f (a,b,c) ... = ... +f d ... (e:f) = ... +f (g,h,i) ... = ... +\end{verbatim} +{\em must} be broken into two blocks at the line shown; otherwise, you +are forcing unnecessary evaluation. In any case, the top-left pattern +always gives the cue. You could then unmix blocks into groups of... +\begin{description} +\item[all variables:] +As it is now. +\item[constructors or variables (mixed):] +Need to make sure the right names get bound for the variable patterns. +\item[literals or variables (mixed):] +Presumably just a variant on the constructor case (as it is now). +\end{description} + +%************************************************************************ +%* * +%* matchWrapper: a convenient way to call @match@ * +%* * +%************************************************************************ +\subsection[matchWrapper]{@matchWrapper@: a convenient interface to @match@} + +Calls to @match@ often involve similar (non-trivial) work; that work +is collected here, in @matchWrapper@. This function takes as +arguments: +\begin{itemize} +\item +Typchecked @Matches@ (of a function definition, or a case or lambda +expression)---the main input; +\item +An error message to be inserted into any (runtime) pattern-matching +failure messages. +\end{itemize} + +As results, @matchWrapper@ produces: +\begin{itemize} +\item +A list of variables (@Locals@) that the caller must ``promise'' to +bind to appropriate values; and +\item +a @CoreExpr@, the desugared output (main result). +\end{itemize} + +The main actions of @matchWrapper@ include: +\begin{enumerate} +\item +Flatten the @[TypecheckedMatch]@ into a suitable list of +@EquationInfo@s. +\item +Create as many new variables as there are patterns in a pattern-list +(in any one of the @EquationInfo@s). +\item +Create a suitable ``if it fails'' expression---a call to @error@ using +the error-string input; the {\em type} of this fail value can be found +by examining one of the RHS expressions in one of the @EquationInfo@s. +\item +Call @match@ with all of this information! +\end{enumerate} + +\begin{code} +matchWrapper :: HsMatchContext Name -- For shadowing warning messages + -> MatchGroup Id -- Matches being desugared + -> DsM ([Id], CoreExpr) -- Results +\end{code} + + There is one small problem with the Lambda Patterns, when somebody + writes something similar to: +\begin{verbatim} + (\ (x:xs) -> ...) +\end{verbatim} + he/she don't want a warning about incomplete patterns, that is done with + the flag @opt_WarnSimplePatterns@. + This problem also appears in the: +\begin{itemize} +\item @do@ patterns, but if the @do@ can fail + it creates another equation if the match can fail + (see @DsExpr.doDo@ function) +\item @let@ patterns, are treated by @matchSimply@ + List Comprension Patterns, are treated by @matchSimply@ also +\end{itemize} + +We can't call @matchSimply@ with Lambda patterns, +due to the fact that lambda patterns can have more than +one pattern, and match simply only accepts one pattern. + +JJQC 30-Nov-1997 + +\begin{code} +matchWrapper ctxt (MatchGroup matches match_ty) + = do { eqns_info <- mapM mk_eqn_info matches + ; new_vars <- selectMatchVars arg_pats pat_tys + ; result_expr <- matchEquations ctxt new_vars eqns_info rhs_ty + ; return (new_vars, result_expr) } + where + arg_pats = map unLoc (hsLMatchPats (head matches)) + n_pats = length arg_pats + (pat_tys, rhs_ty) = splitFunTysN n_pats match_ty + + mk_eqn_info (L _ (Match pats _ grhss)) + = do { let upats = map unLoc pats + ; match_result <- dsGRHSs ctxt upats grhss rhs_ty + ; return (EqnInfo { eqn_wrap = idWrapper, + eqn_pats = upats, + eqn_rhs = match_result}) } + + +matchEquations :: HsMatchContext Name + -> [Id] -> [EquationInfo] -> Type + -> DsM CoreExpr +matchEquations ctxt vars eqns_info rhs_ty + = do { dflags <- getDOptsDs + ; locn <- getSrcSpanDs + ; let ds_ctxt = DsMatchContext ctxt locn + error_string = matchContextErrString ctxt + + ; match_result <- match_fun dflags ds_ctxt vars rhs_ty eqns_info + + ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_string + ; extractMatchResult match_result fail_expr } + where + match_fun dflags ds_ctxt + = case ctxt of + LambdaExpr | dopt Opt_WarnSimplePatterns dflags -> matchCheck ds_ctxt + | otherwise -> match + _ -> matchCheck ds_ctxt +\end{code} + +%************************************************************************ +%* * +\subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern} +%* * +%************************************************************************ + +@mkSimpleMatch@ is a wrapper for @match@ which deals with the +situation where we want to match a single expression against a single +pattern. It returns an expression. + +\begin{code} +matchSimply :: CoreExpr -- Scrutinee + -> HsMatchContext Name -- Match kind + -> LPat Id -- Pattern it should match + -> CoreExpr -- Return this if it matches + -> CoreExpr -- Return this if it doesn't + -> DsM CoreExpr + +matchSimply scrut hs_ctx pat result_expr fail_expr + = let + match_result = cantFailMatchResult result_expr + rhs_ty = exprType fail_expr + -- Use exprType of fail_expr, because won't refine in the case of failure! + in + matchSinglePat scrut hs_ctx pat rhs_ty match_result `thenDs` \ match_result' -> + extractMatchResult match_result' fail_expr + + +matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat Id + -> Type -> MatchResult -> DsM MatchResult +matchSinglePat (Var var) hs_ctx (L _ pat) ty match_result + = getDOptsDs `thenDs` \ dflags -> + getSrcSpanDs `thenDs` \ locn -> + let + match_fn dflags + | dopt Opt_WarnSimplePatterns dflags = matchCheck ds_ctx + | otherwise = match + where + ds_ctx = DsMatchContext hs_ctx locn + in + match_fn dflags [var] ty [EqnInfo { eqn_wrap = idWrapper, + eqn_pats = [pat], + eqn_rhs = match_result }] + +matchSinglePat scrut hs_ctx pat ty match_result + = selectSimpleMatchVarL pat `thenDs` \ var -> + matchSinglePat (Var var) hs_ctx pat ty match_result `thenDs` \ match_result' -> + returnDs (adjustMatchResult (bindNonRec var scrut) match_result') +\end{code} + |