2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[Main_match]{The @match@ function}
7 module Match ( match, matchExport, matchWrapper, matchSimply, matchSinglePat ) where
9 #include "HsVersions.h"
11 import {-# SOURCE #-} DsExpr( dsExpr )
12 import CmdLineOpts ( DynFlag(..), dopt )
14 import TcHsSyn ( hsPatType )
15 import Check ( check, ExhaustivePat )
17 import CoreUtils ( bindNonRec )
19 import DsGRHSs ( dsGRHSs )
21 import Id ( idType, recordSelectorFieldLabel, Id )
22 import DataCon ( dataConFieldLabels, dataConInstOrigArgTys )
23 import MatchCon ( matchConFamily )
24 import MatchLit ( matchLiterals )
25 import PrelInfo ( pAT_ERROR_ID )
26 import TcType ( mkTyVarTys, Type, tcTyConAppArgs, tcEqType )
27 import TysWiredIn ( consDataCon, mkTupleTy, mkListTy,
28 tupleCon, parrFakeCon, mkPArrTy )
29 import BasicTypes ( Boxity(..) )
31 import SrcLoc ( noSrcSpan, noLoc, unLoc, Located(..) )
32 import Util ( lengthExceeds, isSingleton, notNull )
37 This function is a wrapper of @match@, it must be called from all the parts where
38 it was called match, but only substitutes the firs call, ....
39 if the associated flags are declared, warnings will be issued.
40 It can not be called matchWrapper because this name already exists :-(
45 matchExport :: [Id] -- Vars rep'ing the exprs we're matching with
46 -> [EquationInfo] -- Info about patterns, etc. (type synonym below)
47 -> DsM MatchResult -- Desugared result!
51 = getDOptsDs `thenDs` \ dflags ->
52 matchExport_really dflags vars qs
54 matchExport_really dflags vars qs@((EqnInfo _ ctx _ (MatchResult _ _)) : _)
55 | incomplete && shadow =
56 dsShadowWarn ctx eqns_shadow `thenDs` \ () ->
57 dsIncompleteWarn ctx pats `thenDs` \ () ->
60 dsIncompleteWarn ctx pats `thenDs` \ () ->
63 dsShadowWarn ctx eqns_shadow `thenDs` \ () ->
67 where (pats,indexs) = check qs
68 incomplete = dopt Opt_WarnIncompletePatterns dflags
70 shadow = dopt Opt_WarnOverlappingPatterns dflags
71 && sizeUniqSet indexs < no_eqns
73 unused_eqns = uniqSetToList (mkUniqSet [1..no_eqns] `minusUniqSet` indexs)
74 eqns_shadow = map (\n -> qs!!(n - 1)) unused_eqns
77 This variable shows the maximum number of lines of output generated for warnings.
78 It will limit the number of patterns/equations displayed to@ maximum_output@.
80 (ToDo: add command-line option?)
86 The next two functions create the warning message.
89 dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM ()
90 dsShadowWarn ctx@(DsMatchContext kind _ _) qs = dsWarn warn
92 warn | qs `lengthExceeds` maximum_output
93 = pp_context ctx (ptext SLIT("are overlapped"))
94 (\ f -> vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$
97 = pp_context ctx (ptext SLIT("are overlapped"))
98 (\ f -> vcat $ map (ppr_eqn f kind) qs)
101 dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM ()
102 dsIncompleteWarn ctx@(DsMatchContext kind _ _) pats = dsWarn warn
104 warn = pp_context ctx (ptext SLIT("are non-exhaustive"))
105 (\f -> hang (ptext SLIT("Patterns not matched:"))
106 4 ((vcat $ map (ppr_incomplete_pats kind)
107 (take maximum_output pats))
110 dots | pats `lengthExceeds` maximum_output = ptext SLIT("...")
113 pp_context NoMatchContext msg rest_of_msg_fun
114 = (noSrcSpan, ptext SLIT("Some match(es)") <+> hang msg 8 (rest_of_msg_fun id))
116 pp_context (DsMatchContext kind pats loc) msg rest_of_msg_fun
117 = (loc, vcat [ptext SLIT("Pattern match(es)") <+> msg,
118 sep [ptext SLIT("In") <+> ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]])
122 FunRhs fun -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)
123 other -> (pprMatchContext kind, \ pp -> pp)
125 ppr_pats pats = sep (map ppr pats)
127 ppr_shadow_pats kind pats
128 = sep [ppr_pats pats, matchSeparator kind, ptext SLIT("...")]
130 ppr_incomplete_pats kind (pats,[]) = ppr_pats pats
131 ppr_incomplete_pats kind (pats,constraints) =
132 sep [ppr_pats pats, ptext SLIT("with"),
133 sep (map ppr_constraint constraints)]
136 ppr_constraint (var,pats) = sep [ppr var, ptext SLIT("`notElem`"), ppr pats]
138 ppr_eqn prefixF kind (EqnInfo _ _ pats _) = prefixF (ppr_shadow_pats kind pats)
142 The function @match@ is basically the same as in the Wadler chapter,
143 except it is monadised, to carry around the name supply, info about
146 Notes on @match@'s arguments, assuming $m$ equations and $n$ patterns:
149 A list of $n$ variable names, those variables presumably bound to the
150 $n$ expressions being matched against the $n$ patterns. Using the
151 list of $n$ expressions as the first argument showed no benefit and
155 The second argument, a list giving the ``equation info'' for each of
159 the $n$ patterns for that equation, and
161 a list of Core bindings [@(Id, CoreExpr)@ pairs] to be ``stuck on
162 the front'' of the matching code, as in:
168 and finally: (ToDo: fill in)
170 The right way to think about the ``after-match function'' is that it
171 is an embryonic @CoreExpr@ with a ``hole'' at the end for the
172 final ``else expression''.
175 There is a type synonym, @EquationInfo@, defined in module @DsUtils@.
177 An experiment with re-ordering this information about equations (in
178 particular, having the patterns available in column-major order)
182 A default expression---what to evaluate if the overall pattern-match
183 fails. This expression will (almost?) always be
184 a measly expression @Var@, unless we know it will only be used once
185 (as we do in @glue_success_exprs@).
187 Leaving out this third argument to @match@ (and slamming in lots of
188 @Var "fail"@s) is a positively {\em bad} idea, because it makes it
189 impossible to share the default expressions. (Also, it stands no
190 chance of working in our post-upheaval world of @Locals@.)
192 So, the full type signature:
194 match :: [Id] -- Variables rep'ing the exprs we're matching with
195 -> [EquationInfo] -- Info about patterns, etc. (type synonym below)
196 -> DsM MatchResult -- Desugared result!
199 Note: @match@ is often called via @matchWrapper@ (end of this module),
200 a function that does much of the house-keeping that goes with a call
203 It is also worth mentioning the {\em typical} way a block of equations
204 is desugared with @match@. At each stage, it is the first column of
205 patterns that is examined. The steps carried out are roughly:
208 Tidy the patterns in column~1 with @tidyEqnInfo@ (this may add
209 bindings to the second component of the equation-info):
212 Remove the `as' patterns from column~1.
214 Make all constructor patterns in column~1 into @ConPats@, notably
215 @ListPats@ and @TuplePats@.
217 Handle any irrefutable (or ``twiddle'') @LazyPats@.
220 Now {\em unmix} the equations into {\em blocks} [w/ local function
221 @unmix_eqns@], in which the equations in a block all have variable
222 patterns in column~1, or they all have constructor patterns in ...
223 (see ``the mixture rule'' in SLPJ).
225 Call @matchEqnBlock@ on each block of equations; it will do the
226 appropriate thing for each kind of column-1 pattern, usually ending up
227 in a recursive call to @match@.
230 %************************************************************************
232 %* match: empty rule *
234 %************************************************************************
235 \subsection[Match-empty-rule]{The ``empty rule''}
237 We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87)
238 than the Wadler-chapter code for @match@ (p.~93, first @match@ clause).
239 And gluing the ``success expressions'' together isn't quite so pretty.
243 = returnDs (foldr1 combineMatchResults match_results)
245 match_results = [ ASSERT( null pats) mr
246 | EqnInfo _ _ pats mr <- eqns_info ]
250 %************************************************************************
252 %* match: non-empty rule *
254 %************************************************************************
255 \subsection[Match-nonempty]{@match@ when non-empty: unmixing}
257 This (more interesting) clause of @match@ uses @tidy_and_unmix_eqns@
258 (a)~to get `as'- and `twiddle'-patterns out of the way (tidying), and
259 (b)~to do ``the mixture rule'' (SLPJ, p.~88) [which really {\em
260 un}mixes the equations], producing a list of equation-info
261 blocks, each block having as its first column of patterns either all
262 constructors, or all variables (or similar beasts), etc.
264 @match_unmixed_eqn_blks@ simply takes the place of the @foldr@ in the
265 Wadler-chapter @match@ (p.~93, last clause), and @match_unmixed_blk@
266 corresponds roughly to @matchVarCon@.
269 match vars@(v:vs) eqns_info
270 = mappM (tidyEqnInfo v) eqns_info `thenDs` \ tidy_eqns_info ->
272 tidy_eqns_blks = unmix_eqns tidy_eqns_info
274 mappM (matchEqnBlock vars) tidy_eqns_blks `thenDs` \ match_results ->
275 returnDs (foldr1 combineMatchResults match_results)
278 unmix_eqns [eqn] = [ [eqn] ]
279 unmix_eqns (eq1@(EqnInfo _ _ (p1:p1s) _) : eq2@(EqnInfo _ _ (p2:p2s) _) : eqs)
280 = if ( (isWildPat p1 && isWildPat p2)
281 || (isConPat p1 && isConPat p2)
282 || (isLitPat p1 && isLitPat p2) ) then
283 eq1 `tack_onto` unmixed_rest
285 [ eq1 ] : unmixed_rest
287 unmixed_rest = unmix_eqns (eq2:eqs)
289 x `tack_onto` xss = ( x : head xss) : tail xss
292 Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@
293 which will be scrutinised. This means:
296 Replace variable patterns @x@ (@x /= v@) with the pattern @_@,
297 together with the binding @x = v@.
299 Replace the `as' pattern @x@@p@ with the pattern p and a binding @x = v@.
301 Removing lazy (irrefutable) patterns (you don't want to know...).
303 Converting explicit tuple-, list-, and parallel-array-pats into ordinary
306 Convert the literal pat "" to [].
309 The result of this tidying is that the column of patterns will include
313 The @VarPat@ information isn't needed any more after this.
316 @ListPats@, @TuplePats@, etc., are all converted into @ConPats@.
318 \item[@LitPats@ and @NPats@:]
319 @LitPats@/@NPats@ of ``known friendly types'' (Int, Char,
320 Float, Double, at least) are converted to unboxed form; e.g.,
321 \tr{(NPat (HsInt i) _ _)} is converted to:
323 (ConPat I# _ _ [LitPat (HsIntPrim i)])
328 tidyEqnInfo :: Id -> EquationInfo -> DsM EquationInfo
329 -- DsM'd because of internal call to "match".
330 -- "tidy1" does the interesting stuff, looking at
331 -- one pattern and fiddling the list of bindings.
333 -- POST CONDITION: head pattern in the EqnInfo is
342 tidyEqnInfo v (EqnInfo n ctx (pat : pats) match_result)
343 = tidy1 v pat match_result `thenDs` \ (pat', match_result') ->
344 returnDs (EqnInfo n ctx (pat' : pats) match_result')
347 tidy1 :: Id -- The Id being scrutinised
348 -> Pat Id -- The pattern against which it is to be matched
349 -> MatchResult -- Current thing do do after matching
350 -> DsM (Pat Id, -- Equivalent pattern
351 MatchResult) -- Augmented thing to do afterwards
352 -- The augmentation usually takes the form
353 -- of new bindings to be added to the front
355 -------------------------------------------------------
356 -- (pat', mr') = tidy1 v pat mr
357 -- tidies the *outer level only* of pat, giving pat'
358 -- It eliminates many pattern forms (as-patterns, variable patterns,
359 -- list patterns, etc) yielding one of:
367 tidy1 v (ParPat pat) match_result
368 = tidy1 v (unLoc pat) match_result
370 -- case v of { x -> mr[] }
371 -- = case v of { _ -> let x=v in mr[] }
372 tidy1 v (VarPat var) match_result
373 = returnDs (WildPat (idType var), match_result')
375 match_result' | v == var = match_result
376 | otherwise = adjustMatchResult (bindNonRec var (Var v)) match_result
378 -- case v of { x@p -> mr[] }
379 -- = case v of { p -> let x=v in mr[] }
380 tidy1 v (AsPat (L _ var) pat) match_result
381 = tidy1 v (unLoc pat) match_result'
383 match_result' | v == var = match_result
384 | otherwise = adjustMatchResult (bindNonRec var (Var v)) match_result
386 tidy1 v (WildPat ty) match_result
387 = returnDs (WildPat ty, match_result)
389 {- now, here we handle lazy patterns:
390 tidy1 v ~p bs = (v, v1 = case v of p -> v1 :
391 v2 = case v of p -> v2 : ... : bs )
393 where the v_i's are the binders in the pattern.
395 ToDo: in "v_i = ... -> v_i", are the v_i's really the same thing?
397 The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr
400 tidy1 v (LazyPat pat) match_result
401 = mkSelectorBinds pat (Var v) `thenDs` \ sel_binds ->
402 returnDs (WildPat (idType v),
403 mkCoLetsMatchResult [NonRec b rhs | (b,rhs) <- sel_binds] match_result)
405 -- re-express <con-something> as (ConPat ...) [directly]
407 tidy1 v (ConPatOut con ps pat_ty ex_tvs dicts) match_result
408 = returnDs (ConPatOut con tidy_ps pat_ty ex_tvs dicts, match_result)
410 tidy_ps = PrefixCon (tidy_con con pat_ty ex_tvs ps)
412 tidy1 v (ListPat pats ty) match_result
413 = returnDs (unLoc list_ConPat, match_result)
415 list_ty = mkListTy ty
416 list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] list_ty)
420 -- introduce fake parallel array constructors to be able to handle parallel
421 -- arrays with the existing machinery for constructor pattern
423 tidy1 v (PArrPat pats ty) match_result
424 = returnDs (unLoc parrConPat, match_result)
427 parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty)
429 tidy1 v (TuplePat pats boxity) match_result
430 = returnDs (unLoc tuple_ConPat, match_result)
433 tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats
434 (mkTupleTy boxity arity (map hsPatType pats))
436 tidy1 v (DictPat dicts methods) match_result
437 = case num_of_d_and_ms of
438 0 -> tidy1 v (TuplePat [] Boxed) match_result
439 1 -> tidy1 v (unLoc (head dict_and_method_pats)) match_result
440 _ -> tidy1 v (TuplePat dict_and_method_pats Boxed) match_result
442 num_of_d_and_ms = length dicts + length methods
443 dict_and_method_pats = map nlVarPat (dicts ++ methods)
445 -- LitPats: we *might* be able to replace these w/ a simpler form
446 tidy1 v pat@(LitPat lit) match_result
447 = returnDs (unLoc (tidyLitPat lit (noLoc pat)), match_result)
449 -- NPats: we *might* be able to replace these w/ a simpler form
450 tidy1 v pat@(NPatOut lit lit_ty _) match_result
451 = returnDs (unLoc (tidyNPat lit lit_ty (noLoc pat)), match_result)
453 -- and everything else goes through unchanged...
455 tidy1 v non_interesting_pat match_result
456 = returnDs (non_interesting_pat, match_result)
459 tidy_con data_con pat_ty ex_tvs (PrefixCon ps) = ps
460 tidy_con data_con pat_ty ex_tvs (InfixCon p1 p2) = [p1,p2]
461 tidy_con data_con pat_ty ex_tvs (RecCon rpats)
463 = -- Special case for C {}, which can be used for
464 -- a constructor that isn't declared to have
466 map (noLoc.WildPat) con_arg_tys'
469 = map mk_pat tagged_arg_tys
471 -- Boring stuff to find the arg-tys of the constructor
472 inst_tys = tcTyConAppArgs pat_ty -- Newtypes must be opaque
473 con_arg_tys' = dataConInstOrigArgTys data_con (inst_tys ++ mkTyVarTys ex_tvs)
474 tagged_arg_tys = con_arg_tys' `zip` (dataConFieldLabels data_con)
476 -- mk_pat picks a WildPat of the appropriate type for absent fields,
477 -- and the specified pattern for present fields
478 mk_pat (arg_ty, lbl) =
479 case [ pat | (sel_id,pat) <- rpats,
480 recordSelectorFieldLabel (unLoc sel_id) == lbl
482 (pat:pats) -> ASSERT( null pats )
484 [] -> noLoc (WildPat arg_ty)
488 {\bf Previous @matchTwiddled@ stuff:}
490 Now we get to the only interesting part; note: there are choices for
491 translation [from Simon's notes]; translation~1:
498 s = case w of [s,t] -> s
499 t = case w of [s,t] -> t
503 Here \tr{w} is a fresh variable, and the \tr{w}-binding prevents multiple
504 evaluation of \tr{e}. An alternative translation (No.~2):
506 [ w = case e of [s,t] -> (s,t)
507 s = case w of (s,t) -> s
508 t = case w of (s,t) -> t
512 %************************************************************************
514 \subsubsection[improved-unmixing]{UNIMPLEMENTED idea for improved unmixing}
516 %************************************************************************
518 We might be able to optimise unmixing when confronted by
519 only-one-constructor-possible, of which tuples are the most notable
527 This definition would normally be unmixed into four equation blocks,
528 one per equation. But it could be unmixed into just one equation
529 block, because if the one equation matches (on the first column),
530 the others certainly will.
532 You have to be careful, though; the example
540 {\em must} be broken into two blocks at the line shown; otherwise, you
541 are forcing unnecessary evaluation. In any case, the top-left pattern
542 always gives the cue. You could then unmix blocks into groups of...
544 \item[all variables:]
546 \item[constructors or variables (mixed):]
547 Need to make sure the right names get bound for the variable patterns.
548 \item[literals or variables (mixed):]
549 Presumably just a variant on the constructor case (as it is now).
552 %************************************************************************
554 %* match on an unmixed block: the real business *
556 %************************************************************************
557 \subsection[matchEqnBlock]{@matchEqnBlock@: getting down to business}
559 The function @matchEqnBlock@ is where the matching stuff sets to
560 work a block of equations, to which the mixture rule has been applied.
561 Its arguments and results are the same as for the ``top-level'' @match@.
564 matchEqnBlock :: [Id]
568 matchEqnBlock [] _ = panic "matchEqnBlock: no names"
570 matchEqnBlock all_vars@(var:vars) eqns_info
571 | isWildPat first_pat
572 = ASSERT( all isWildPat column_1_pats ) -- Sanity check
573 -- Real true variables, just like in matchVar, SLPJ p 94
574 -- No binding to do: they'll all be wildcards by now (done in tidy)
575 match vars remaining_eqns_info
578 = ASSERT( patsAreAllCons column_1_pats )
579 matchConFamily all_vars eqns_info
582 = ASSERT( patsAreAllLits column_1_pats )
583 -- see notes in MatchLiteral
584 -- not worried about the same literal more than once in a column
585 -- (ToDo: sort this out later)
586 matchLiterals all_vars eqns_info
589 = ASSERT( isSingleton eqns_info )
590 matchSigPat all_vars (head eqns_info)
592 first_pat = head column_1_pats
593 column_1_pats = [pat | EqnInfo _ _ (pat:_) _ <- eqns_info]
594 remaining_eqns_info = [EqnInfo n ctx pats match_result | EqnInfo n ctx (_:pats) match_result <- eqns_info]
597 A SigPat is a type coercion and must be handled one at at time. We can't
598 combine them unless the type of the pattern inside is identical, and we don't
599 bother to check for that. For example:
601 data T = T1 Int | T2 Bool
602 f :: (forall a. a -> a) -> T -> t
603 f (g::Int->Int) (T1 i) = T1 (g i)
604 f (g::Bool->Bool) (T2 b) = T2 (g b)
606 We desugar this as follows:
608 f = \ g::(forall a. a->a) t::T ->
610 in case t of { T1 i -> T1 (gi i)
613 in case t of { T2 b -> T2 (gb b)
616 Note that we do not treat the first column of patterns as a
617 column of variables, because the coerced variables (gi, gb)
618 would be of different types. So we get rather grotty code.
619 But I don't think this is a common case, and if it was we could
620 doubtless improve it.
622 Meanwhile, the strategy is:
623 * treat each SigPat coercion (always non-identity coercions)
625 * deal with the stuff inside, and then wrap a binding round
626 the result to bind the new variable (gi, gb, etc)
629 matchSigPat :: [Id] -> EquationInfo -> DsM MatchResult
630 matchSigPat (var:vars) (EqnInfo n ctx (SigPatOut pat ty co_fn : pats) result)
631 = selectMatchVarL pat `thenDs` \ new_var ->
632 dsExpr (HsApp (noLoc co_fn) (nlHsVar var)) `thenDs` \ rhs ->
633 match (new_var:vars) [EqnInfo n ctx (unLoc pat:pats) result] `thenDs` \ result' ->
634 returnDs (adjustMatchResult (bindNonRec new_var rhs) result')
637 %************************************************************************
639 %* matchWrapper: a convenient way to call @match@ *
641 %************************************************************************
642 \subsection[matchWrapper]{@matchWrapper@: a convenient interface to @match@}
644 Calls to @match@ often involve similar (non-trivial) work; that work
645 is collected here, in @matchWrapper@. This function takes as
649 Typchecked @Matches@ (of a function definition, or a case or lambda
650 expression)---the main input;
652 An error message to be inserted into any (runtime) pattern-matching
656 As results, @matchWrapper@ produces:
659 A list of variables (@Locals@) that the caller must ``promise'' to
660 bind to appropriate values; and
662 a @CoreExpr@, the desugared output (main result).
665 The main actions of @matchWrapper@ include:
668 Flatten the @[TypecheckedMatch]@ into a suitable list of
671 Create as many new variables as there are patterns in a pattern-list
672 (in any one of the @EquationInfo@s).
674 Create a suitable ``if it fails'' expression---a call to @error@ using
675 the error-string input; the {\em type} of this fail value can be found
676 by examining one of the RHS expressions in one of the @EquationInfo@s.
678 Call @match@ with all of this information!
682 matchWrapper :: HsMatchContext Name -- For shadowing warning messages
683 -> [LMatch Id] -- Matches being desugared
684 -> DsM ([Id], CoreExpr) -- Results
687 There is one small problem with the Lambda Patterns, when somebody
688 writes something similar to:
692 he/she don't want a warning about incomplete patterns, that is done with
693 the flag @opt_WarnSimplePatterns@.
694 This problem also appears in the:
696 \item @do@ patterns, but if the @do@ can fail
697 it creates another equation if the match can fail
698 (see @DsExpr.doDo@ function)
699 \item @let@ patterns, are treated by @matchSimply@
700 List Comprension Patterns, are treated by @matchSimply@ also
703 We can't call @matchSimply@ with Lambda patterns,
704 due to the fact that lambda patterns can have more than
705 one pattern, and match simply only accepts one pattern.
710 matchWrapper ctxt matches
711 = getDOptsDs `thenDs` \ dflags ->
712 flattenMatches ctxt matches `thenDs` \ (result_ty, eqns_info) ->
714 EqnInfo _ _ arg_pats _ : _ = eqns_info
715 error_string = matchContextErrString ctxt
717 mappM selectMatchVar arg_pats `thenDs` \ new_vars ->
718 match_fun dflags new_vars eqns_info `thenDs` \ match_result ->
720 mkErrorAppDs pAT_ERROR_ID result_ty error_string `thenDs` \ fail_expr ->
721 extractMatchResult match_result fail_expr `thenDs` \ result_expr ->
722 returnDs (new_vars, result_expr)
723 where match_fun dflags
725 LambdaExpr | dopt Opt_WarnSimplePatterns dflags -> matchExport
730 %************************************************************************
732 \subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern}
734 %************************************************************************
736 @mkSimpleMatch@ is a wrapper for @match@ which deals with the
737 situation where we want to match a single expression against a single
738 pattern. It returns an expression.
741 matchSimply :: CoreExpr -- Scrutinee
742 -> HsMatchContext Name -- Match kind
743 -> LPat Id -- Pattern it should match
744 -> CoreExpr -- Return this if it matches
745 -> CoreExpr -- Return this if it doesn't
748 matchSimply scrut kind pat result_expr fail_expr
749 = getSrcSpanDs `thenDs` \ locn ->
751 ctx = DsMatchContext kind [unLoc pat] locn
752 match_result = cantFailMatchResult result_expr
754 matchSinglePat scrut ctx pat match_result `thenDs` \ match_result' ->
755 extractMatchResult match_result' fail_expr
758 matchSinglePat :: CoreExpr -> DsMatchContext -> LPat Id
759 -> MatchResult -> DsM MatchResult
761 matchSinglePat (Var var) ctx pat match_result
762 = getDOptsDs `thenDs` \ dflags ->
763 match_fn dflags [var] [EqnInfo 1 ctx [unLoc pat] match_result]
766 | dopt Opt_WarnSimplePatterns dflags = matchExport
769 matchSinglePat scrut ctx pat match_result
770 = selectMatchVarL pat `thenDs` \ var ->
771 matchSinglePat (Var var) ctx pat match_result `thenDs` \ match_result' ->
772 returnDs (adjustMatchResult (bindNonRec var scrut) match_result')
775 %************************************************************************
777 %* flattenMatches : create a list of EquationInfo *
779 %************************************************************************
781 \subsection[flattenMatches]{@flattenMatches@: create @[EquationInfo]@}
783 This is actually local to @matchWrapper@.
786 flattenMatches :: HsMatchContext Name
788 -> DsM (Type, [EquationInfo])
790 flattenMatches kind matches
791 = mapAndUnzipDs flatten_match (matches `zip` [1..]) `thenDs` \ (result_tys, eqn_infos) ->
793 result_ty = head result_tys
795 ASSERT( all (tcEqType result_ty) result_tys )
796 returnDs (result_ty, eqn_infos)
798 flatten_match (L _ (Match pats _ grhss), n)
799 = dsGRHSs kind upats grhss `thenDs` \ (ty, match_result) ->
800 getSrcSpanDs `thenDs` \ locn ->
801 returnDs (ty, EqnInfo n (DsMatchContext kind upats locn) upats match_result)
802 where upats = map unLoc pats