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, dsLet )
13 import CmdLineOpts ( opt_WarnIncompletePatterns, opt_WarnOverlappingPatterns,
14 opt_WarnSimplePatterns
17 import TcHsSyn ( TypecheckedPat, TypecheckedMatch )
18 import DsHsSyn ( outPatType )
19 import Check ( check, ExhaustivePat )
21 import CoreUtils ( coreExprType )
23 import DsGRHSs ( dsGRHSs )
25 import Id ( idType, recordSelectorFieldLabel, Id )
26 import DataCon ( dataConFieldLabels, dataConArgTys )
27 import MatchCon ( matchConFamily )
28 import MatchLit ( matchLiterals )
29 import PrelVals ( pAT_ERROR_ID )
30 import Type ( isUnLiftedType, splitAlgTyConApp,
33 import TysPrim ( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy,
34 addrPrimTy, wordPrimTy
36 import TysWiredIn ( nilDataCon, consDataCon, mkTupleTy, mkListTy,
37 charTy, charDataCon, intTy, intDataCon,
38 floatTy, floatDataCon, doubleTy, tupleCon,
39 doubleDataCon, addrTy,
40 addrDataCon, wordTy, wordDataCon,
41 mkUnboxedTupleTy, unboxedTupleCon
47 This function is a wrapper of @match@, it must be called from all the parts where
48 it was called match, but only substitutes the firs call, ....
49 if the associated flags are declared, warnings will be issued.
50 It can not be called matchWrapper because this name already exists :-(
55 matchExport :: [Id] -- Vars rep'ing the exprs we're matching with
56 -> [EquationInfo] -- Info about patterns, etc. (type synonym below)
57 -> DsM MatchResult -- Desugared result!
59 matchExport vars qs@((EqnInfo _ ctx _ (MatchResult _ _)) : _)
60 | incomplete && shadow =
61 dsShadowWarn ctx eqns_shadow `thenDs` \ () ->
62 dsIncompleteWarn ctx pats `thenDs` \ () ->
65 dsIncompleteWarn ctx pats `thenDs` \ () ->
68 dsShadowWarn ctx eqns_shadow `thenDs` \ () ->
72 where (pats,indexs) = check qs
73 incomplete = opt_WarnIncompletePatterns && (length pats /= 0)
74 shadow = opt_WarnOverlappingPatterns && sizeUniqSet indexs < no_eqns
76 unused_eqns = uniqSetToList (mkUniqSet [1..no_eqns] `minusUniqSet` indexs)
77 eqns_shadow = map (\n -> qs!!(n - 1)) unused_eqns
80 This variable shows the maximun number of lines of output generated for warnings.
81 It will limit the number of patterns/equations displayed to maximum_output.
83 (ToDo: add command-line option?)
89 The next two functions creates the warning message.
92 dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM ()
93 dsShadowWarn ctx@(DsMatchContext kind _ _) qs = dsWarn warn
95 warn | length qs > maximum_output
96 = hang (pp_context ctx (ptext SLIT("are overlapped")))
97 12 ((vcat $ map (ppr_eqn kind) (take maximum_output qs))
100 = hang (pp_context ctx (ptext SLIT("are overlapped")))
101 12 (vcat $ map (ppr_eqn kind) qs)
103 dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM ()
104 dsIncompleteWarn ctx@(DsMatchContext kind _ _) pats = dsWarn warn
106 warn | length pats > maximum_output
107 = hang (pp_context ctx (ptext SLIT("are non-exhaustive")))
108 12 (hang (ptext SLIT("Patterns not recognized:"))
109 4 ((vcat $ map (ppr_incomplete_pats kind) (take maximum_output pats))
110 $$ ptext SLIT("...")))
112 = hang (pp_context ctx (ptext SLIT("are non-exhaustive")))
113 12 (hang (ptext SLIT("Patterns not recognized:"))
114 4 (vcat $ map (ppr_incomplete_pats kind) pats))
116 pp_context NoMatchContext msg = ptext SLIT("Some match(es)") <+> msg
118 pp_context (DsMatchContext kind pats loc) msg
119 = hang (hcat [ppr loc, ptext SLIT(": ")])
121 4 (pp_match kind pats))
123 message = ptext SLIT("Pattern match(es)") <+> msg
125 pp_match (FunMatch fun) pats
126 = hsep [ptext SLIT("in the definition of function"), quotes (ppr fun)]
128 pp_match CaseMatch pats
129 = hang (ptext SLIT("in a group of case alternatives beginning:"))
132 pp_match PatBindMatch pats
133 = hang (ptext SLIT("in a pattern binding:"))
136 pp_match LambdaMatch pats
137 = hang (ptext SLIT("in a lambda abstraction:"))
140 pp_match DoBindMatch pats
141 = hang (ptext SLIT("in a `do' pattern binding:"))
144 pp_match ListCompMatch pats
145 = hang (ptext SLIT("in a `list comprension' pattern binding:"))
148 pp_match LetMatch pats
149 = hang (ptext SLIT("in a `let' pattern binding:"))
152 ppr_pats pats = sep (map ppr pats)
154 separator (FunMatch _) = SLIT("=")
155 separator (CaseMatch) = SLIT("->")
156 separator (LambdaMatch) = SLIT("->")
157 separator (PatBindMatch) = panic "When is this used?"
158 separator (DoBindMatch) = SLIT("<-")
159 separator (ListCompMatch) = SLIT("<-")
160 separator (LetMatch) = SLIT("=")
162 ppr_shadow_pats kind pats = sep [ppr_pats pats, ptext (separator kind), ptext SLIT("...")]
164 ppr_incomplete_pats kind (pats,[]) = ppr_pats pats
165 ppr_incomplete_pats kind (pats,constraints) =
166 sep [ppr_pats pats, ptext SLIT("with"),
167 sep (map ppr_constraint constraints)]
170 ppr_constraint (var,pats) = sep [ppr var, ptext SLIT("`not_elem`"), ppr pats]
172 ppr_eqn kind (EqnInfo _ _ pats _) = ppr_shadow_pats kind pats
176 The function @match@ is basically the same as in the Wadler chapter,
177 except it is monadised, to carry around the name supply, info about
180 Notes on @match@'s arguments, assuming $m$ equations and $n$ patterns:
183 A list of $n$ variable names, those variables presumably bound to the
184 $n$ expressions being matched against the $n$ patterns. Using the
185 list of $n$ expressions as the first argument showed no benefit and
189 The second argument, a list giving the ``equation info'' for each of
193 the $n$ patterns for that equation, and
195 a list of Core bindings [@(Id, CoreExpr)@ pairs] to be ``stuck on
196 the front'' of the matching code, as in:
202 and finally: (ToDo: fill in)
204 The right way to think about the ``after-match function'' is that it
205 is an embryonic @CoreExpr@ with a ``hole'' at the end for the
206 final ``else expression''.
209 There is a type synonym, @EquationInfo@, defined in module @DsUtils@.
211 An experiment with re-ordering this information about equations (in
212 particular, having the patterns available in column-major order)
216 A default expression---what to evaluate if the overall pattern-match
217 fails. This expression will (almost?) always be
218 a measly expression @Var@, unless we know it will only be used once
219 (as we do in @glue_success_exprs@).
221 Leaving out this third argument to @match@ (and slamming in lots of
222 @Var "fail"@s) is a positively {\em bad} idea, because it makes it
223 impossible to share the default expressions. (Also, it stands no
224 chance of working in our post-upheaval world of @Locals@.)
226 So, the full type signature:
228 match :: [Id] -- Variables rep'ing the exprs we're matching with
229 -> [EquationInfo] -- Info about patterns, etc. (type synonym below)
230 -> DsM MatchResult -- Desugared result!
233 Note: @match@ is often called via @matchWrapper@ (end of this module),
234 a function that does much of the house-keeping that goes with a call
237 It is also worth mentioning the {\em typical} way a block of equations
238 is desugared with @match@. At each stage, it is the first column of
239 patterns that is examined. The steps carried out are roughly:
242 Tidy the patterns in column~1 with @tidyEqnInfo@ (this may add
243 bindings to the second component of the equation-info):
246 Remove the `as' patterns from column~1.
248 Make all constructor patterns in column~1 into @ConPats@, notably
249 @ListPats@ and @TuplePats@.
251 Handle any irrefutable (or ``twiddle'') @LazyPats@.
254 Now {\em unmix} the equations into {\em blocks} [w/ local function
255 @unmix_eqns@], in which the equations in a block all have variable
256 patterns in column~1, or they all have constructor patterns in ...
257 (see ``the mixture rule'' in SLPJ).
259 Call @matchUnmixedEqns@ on each block of equations; it will do the
260 appropriate thing for each kind of column-1 pattern, usually ending up
261 in a recursive call to @match@.
264 %************************************************************************
266 %* match: empty rule *
268 %************************************************************************
269 \subsection[Match-empty-rule]{The ``empty rule''}
271 We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87)
272 than the Wadler-chapter code for @match@ (p.~93, first @match@ clause).
273 And gluing the ``success expressions'' together isn't quite so pretty.
277 = complete_matches eqns_info
279 complete_matches [eqn]
282 complete_matches (eqn:eqns)
283 = complete_match eqn `thenDs` \ match_result1 ->
284 complete_matches eqns `thenDs` \ match_result2 ->
285 returnDs (combineMatchResults match_result1 match_result2)
287 complete_match (EqnInfo _ _ pats match_result)
288 = ASSERT( null pats )
289 returnDs match_result
292 %************************************************************************
294 %* match: non-empty rule *
296 %************************************************************************
297 \subsection[Match-nonempty]{@match@ when non-empty: unmixing}
299 This (more interesting) clause of @match@ uses @tidy_and_unmix_eqns@
300 (a)~to get `as'- and `twiddle'-patterns out of the way (tidying), and
301 (b)~to do ``the mixture rule'' (SLPJ, p.~88) [which really {\em
302 un}mixes the equations], producing a list of equation-info
303 blocks, each block having as its first column of patterns either all
304 constructors, or all variables (or similar beasts), etc.
306 @match_unmixed_eqn_blks@ simply takes the place of the @foldr@ in the
307 Wadler-chapter @match@ (p.~93, last clause), and @match_unmixed_blk@
308 corresponds roughly to @matchVarCon@.
311 match vars@(v:vs) eqns_info
312 = mapDs (tidyEqnInfo v) eqns_info `thenDs` \ tidy_eqns_info ->
314 tidy_eqns_blks = unmix_eqns tidy_eqns_info
316 match_unmixed_eqn_blks vars tidy_eqns_blks
319 unmix_eqns [eqn] = [ [eqn] ]
320 unmix_eqns (eq1@(EqnInfo _ _ (p1:p1s) _) : eq2@(EqnInfo _ _ (p2:p2s) _) : eqs)
321 = if ( (irrefutablePat p1 && irrefutablePat p2)
322 || (isConPat p1 && isConPat p2)
323 || (isLitPat p1 && isLitPat p2) ) then
324 eq1 `tack_onto` unmixed_rest
326 [ eq1 ] : unmixed_rest
328 unmixed_rest = unmix_eqns (eq2:eqs)
330 x `tack_onto` xss = ( x : head xss) : tail xss
332 -----------------------------------------------------------------------
333 -- loop through the blocks:
334 -- subsequent blocks create a "fail expr" for the first one...
335 match_unmixed_eqn_blks :: [Id]
336 -> [ [EquationInfo] ] -- List of eqn BLOCKS
339 match_unmixed_eqn_blks vars [] = panic "match_unmixed_eqn_blks"
341 match_unmixed_eqn_blks vars [eqn_blk] = matchUnmixedEqns vars eqn_blk
343 match_unmixed_eqn_blks vars (eqn_blk:eqn_blks)
344 = matchUnmixedEqns vars eqn_blk `thenDs` \ match_result1 -> -- try to match with first blk
345 match_unmixed_eqn_blks vars eqn_blks `thenDs` \ match_result2 ->
346 returnDs (combineMatchResults match_result1 match_result2)
349 Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@
350 which will be scrutinised. This means:
353 Replace variable patterns @x@ (@x /= v@) with the pattern @_@,
354 together with the binding @x = v@.
356 Replace the `as' pattern @x@@p@ with the pattern p and a binding @x = v@.
358 Removing lazy (irrefutable) patterns (you don't want to know...).
360 Converting explicit tuple- and list-pats into ordinary @ConPats@.
362 Convert the literal pat "" to [].
365 The result of this tidying is that the column of patterns will include
369 The @VarPat@ information isn't needed any more after this.
372 @ListPats@, @TuplePats@, etc., are all converted into @ConPats@.
374 \item[@LitPats@ and @NPats@:]
375 @LitPats@/@NPats@ of ``known friendly types'' (Int, Char,
376 Float, Double, at least) are converted to unboxed form; e.g.,
377 \tr{(NPat (HsInt i) _ _)} is converted to:
379 (ConPat I# _ _ [LitPat (HsIntPrim i) _])
384 tidyEqnInfo :: Id -> EquationInfo -> DsM EquationInfo
385 -- DsM'd because of internal call to "match".
386 -- "tidy1" does the interesting stuff, looking at
387 -- one pattern and fiddling the list of bindings.
388 tidyEqnInfo v (EqnInfo n ctx (pat : pats) match_result)
389 = tidy1 v pat match_result `thenDs` \ (pat', match_result') ->
390 returnDs (EqnInfo n ctx (pat' : pats) match_result')
392 tidy1 :: Id -- The Id being scrutinised
393 -> TypecheckedPat -- The pattern against which it is to be matched
394 -> MatchResult -- Current thing do do after matching
395 -> DsM (TypecheckedPat, -- Equivalent pattern
396 MatchResult) -- Augmented thing to do afterwards
397 -- The augmentation usually takes the form
398 -- of new bindings to be added to the front
400 tidy1 v (VarPat var) match_result
401 = returnDs (WildPat (idType var), match_result')
403 match_result' | v == var = match_result
404 | otherwise = adjustMatchResult (bindNonRec var (Var v)) match_result
406 tidy1 v (AsPat var pat) match_result
407 = tidy1 v pat match_result'
409 match_result' | v == var = match_result
410 | otherwise = adjustMatchResult (bindNonRec var (Var v)) match_result
412 tidy1 v (WildPat ty) match_result
413 = returnDs (WildPat ty, match_result)
415 {- now, here we handle lazy patterns:
416 tidy1 v ~p bs = (v, v1 = case v of p -> v1 :
417 v2 = case v of p -> v2 : ... : bs )
419 where the v_i's are the binders in the pattern.
421 ToDo: in "v_i = ... -> v_i", are the v_i's really the same thing?
423 The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr
426 tidy1 v (LazyPat pat) match_result
427 = mkSelectorBinds pat (Var v) `thenDs` \ sel_binds ->
428 returnDs (WildPat (idType v),
429 mkCoLetsMatchResult [NonRec b rhs | (b,rhs) <- sel_binds] match_result)
431 -- re-express <con-something> as (ConPat ...) [directly]
433 tidy1 v (RecPat data_con pat_ty tvs dicts rpats) match_result
434 = returnDs (ConPat data_con pat_ty tvs dicts pats, match_result)
436 pats = map mk_pat tagged_arg_tys
438 -- Boring stuff to find the arg-tys of the constructor
439 (_, inst_tys, _) = splitAlgTyConApp pat_ty
440 con_arg_tys' = dataConArgTys data_con inst_tys
441 tagged_arg_tys = con_arg_tys' `zip` (dataConFieldLabels data_con)
443 -- mk_pat picks a WildPat of the appropriate type for absent fields,
444 -- and the specified pattern for present fields
445 mk_pat (arg_ty, lbl) = case [pat | (sel_id,pat,_) <- rpats,
446 recordSelectorFieldLabel sel_id == lbl
448 (pat:pats) -> ASSERT( null pats )
452 tidy1 v (ListPat ty pats) match_result
453 = returnDs (list_ConPat, match_result)
455 list_ty = mkListTy ty
457 = foldr (\ x -> \y -> ConPat consDataCon list_ty [] [] [x, y])
458 (ConPat nilDataCon list_ty [] [] [])
461 tidy1 v (TuplePat pats True{-boxed-}) match_result
462 = returnDs (tuple_ConPat, match_result)
466 = ConPat (tupleCon arity)
467 (mkTupleTy arity (map outPatType pats)) [] []
470 tidy1 v (TuplePat pats False{-unboxed-}) match_result
471 = returnDs (tuple_ConPat, match_result)
475 = ConPat (unboxedTupleCon arity)
476 (mkUnboxedTupleTy arity (map outPatType pats)) [] []
479 tidy1 v (DictPat dicts methods) match_result
480 = case num_of_d_and_ms of
481 0 -> tidy1 v (TuplePat [] True) match_result
482 1 -> tidy1 v (head dict_and_method_pats) match_result
483 _ -> tidy1 v (TuplePat dict_and_method_pats True) match_result
485 num_of_d_and_ms = length dicts + length methods
486 dict_and_method_pats = map VarPat (dicts ++ methods)
489 -- deeply ugly mangling for some (common) NPats/LitPats
491 -- LitPats: the desugarer only sees these at well-known types
493 tidy1 v pat@(LitPat lit lit_ty) match_result
494 | isUnLiftedType lit_ty
495 = returnDs (pat, match_result)
498 = returnDs (ConPat charDataCon charTy [] [] [LitPat (mk_char lit) charPrimTy],
501 | otherwise = pprPanic "tidy1:LitPat:" (ppr pat)
503 mk_char (HsChar c) = HsCharPrim c
505 -- NPats: we *might* be able to replace these w/ a simpler form
508 tidy1 v pat@(NPat lit lit_ty _) match_result
509 = returnDs (better_pat, match_result)
512 | lit_ty == charTy = ConPat charDataCon lit_ty [] [] [LitPat (mk_char lit) charPrimTy]
513 | lit_ty == intTy = ConPat intDataCon lit_ty [] [] [LitPat (mk_int lit) intPrimTy]
514 | lit_ty == wordTy = ConPat wordDataCon lit_ty [] [] [LitPat (mk_word lit) wordPrimTy]
515 | lit_ty == addrTy = ConPat addrDataCon lit_ty [] [] [LitPat (mk_addr lit) addrPrimTy]
516 | lit_ty == floatTy = ConPat floatDataCon lit_ty [] [] [LitPat (mk_float lit) floatPrimTy]
517 | lit_ty == doubleTy = ConPat doubleDataCon lit_ty [] [] [LitPat (mk_double lit) doublePrimTy]
519 -- Convert the literal pattern "" to the constructor pattern [].
520 | null_str_lit lit = ConPat nilDataCon lit_ty [] [] []
524 mk_int (HsInt i) = HsIntPrim i
525 mk_int l@(HsLitLit s) = l
527 mk_char (HsChar c) = HsCharPrim c
528 mk_char l@(HsLitLit s) = l
530 mk_word l@(HsLitLit s) = l
532 mk_addr l@(HsLitLit s) = l
534 mk_float (HsInt i) = HsFloatPrim (fromInteger i)
535 mk_float (HsFrac f) = HsFloatPrim f
536 mk_float l@(HsLitLit s) = l
538 mk_double (HsInt i) = HsDoublePrim (fromInteger i)
539 mk_double (HsFrac f) = HsDoublePrim f
540 mk_double l@(HsLitLit s) = l
542 null_str_lit (HsString s) = _NULL_ s
543 null_str_lit other_lit = False
545 -- and everything else goes through unchanged...
547 tidy1 v non_interesting_pat match_result
548 = returnDs (non_interesting_pat, match_result)
551 PREVIOUS matchTwiddled STUFF:
553 Now we get to the only interesting part; note: there are choices for
554 translation [from Simon's notes]; translation~1:
561 s = case w of [s,t] -> s
562 t = case w of [s,t] -> t
566 Here \tr{w} is a fresh variable, and the \tr{w}-binding prevents multiple
567 evaluation of \tr{e}. An alternative translation (No.~2):
569 [ w = case e of [s,t] -> (s,t)
570 s = case w of (s,t) -> s
571 t = case w of (s,t) -> t
575 %************************************************************************
577 \subsubsection[improved-unmixing]{UNIMPLEMENTED idea for improved unmixing}
579 %************************************************************************
581 We might be able to optimise unmixing when confronted by
582 only-one-constructor-possible, of which tuples are the most notable
590 This definition would normally be unmixed into four equation blocks,
591 one per equation. But it could be unmixed into just one equation
592 block, because if the one equation matches (on the first column),
593 the others certainly will.
595 You have to be careful, though; the example
603 {\em must} be broken into two blocks at the line shown; otherwise, you
604 are forcing unnecessary evaluation. In any case, the top-left pattern
605 always gives the cue. You could then unmix blocks into groups of...
607 \item[all variables:]
609 \item[constructors or variables (mixed):]
610 Need to make sure the right names get bound for the variable patterns.
611 \item[literals or variables (mixed):]
612 Presumably just a variant on the constructor case (as it is now).
615 %************************************************************************
617 %* match on an unmixed block: the real business *
619 %************************************************************************
620 \subsection[matchUnmixedEqns]{@matchUnmixedEqns@: getting down to business}
622 The function @matchUnmixedEqns@ is where the matching stuff sets to
623 work a block of equations, to which the mixture rule has been applied.
624 Its arguments and results are the same as for the ``top-level'' @match@.
627 matchUnmixedEqns :: [Id]
631 matchUnmixedEqns [] _ = panic "matchUnmixedEqns: no names"
633 matchUnmixedEqns all_vars@(var:vars) eqns_info
634 | irrefutablePat first_pat
635 = ASSERT( irrefutablePats column_1_pats ) -- Sanity check
636 -- Real true variables, just like in matchVar, SLPJ p 94
637 match vars remaining_eqns_info
640 = ASSERT( patsAreAllCons column_1_pats )
641 matchConFamily all_vars eqns_info
644 = ASSERT( patsAreAllLits column_1_pats )
645 -- see notes in MatchLiteral
646 -- not worried about the same literal more than once in a column
647 -- (ToDo: sort this out later)
648 matchLiterals all_vars eqns_info
651 first_pat = head column_1_pats
652 column_1_pats = [pat | EqnInfo _ _ (pat:_) _ <- eqns_info]
653 remaining_eqns_info = [EqnInfo n ctx pats match_result | EqnInfo n ctx (_:pats) match_result <- eqns_info]
656 %************************************************************************
658 %* matchWrapper: a convenient way to call @match@ *
660 %************************************************************************
661 \subsection[matchWrapper]{@matchWrapper@: a convenient interface to @match@}
663 Calls to @match@ often involve similar (non-trivial) work; that work
664 is collected here, in @matchWrapper@. This function takes as
668 Typchecked @Matches@ (of a function definition, or a case or lambda
669 expression)---the main input;
671 An error message to be inserted into any (runtime) pattern-matching
675 As results, @matchWrapper@ produces:
678 A list of variables (@Locals@) that the caller must ``promise'' to
679 bind to appropriate values; and
681 a @CoreExpr@, the desugared output (main result).
684 The main actions of @matchWrapper@ include:
687 Flatten the @[TypecheckedMatch]@ into a suitable list of
690 Create as many new variables as there are patterns in a pattern-list
691 (in any one of the @EquationInfo@s).
693 Create a suitable ``if it fails'' expression---a call to @error@ using
694 the error-string input; the {\em type} of this fail value can be found
695 by examining one of the RHS expressions in one of the @EquationInfo@s.
697 Call @match@ with all of this information!
701 matchWrapper :: DsMatchKind -- For shadowing warning messages
702 -> [TypecheckedMatch] -- Matches being desugared
703 -> String -- Error message if the match fails
704 -> DsM ([Id], CoreExpr) -- Results
707 a special case for the common ...:
709 lots of (all?) unfailable pats
713 This special case have been ``undone'' due to problems with the new warnings
714 messages (Check.lhs.check). We need there the name of the variables to be able to
715 print later the equation. JJQC 30-11-97
718 matchWrapper kind [(PatMatch (VarPat var) match)] error_string
719 = matchWrapper kind [match] error_string `thenDs` \ (vars, core_expr) ->
720 returnDs (var:vars, core_expr)
722 matchWrapper kind [(PatMatch (WildPat ty) match)] error_string
723 = newSysLocalDs ty `thenDs` \ var ->
724 matchWrapper kind [match] error_string `thenDs` \ (vars, core_expr) ->
725 returnDs (var:vars, core_expr)
727 matchWrapper kind [(GRHSMatch
728 (GRHSsAndBindsOut [GRHS [ExprStmt expr _]] binds _))] error_string
729 = dsExpr expr `thenDs` \ core_expr ->
730 dsLet binds core_expr `thenDs` \ rhs ->
734 And all the rest... (general case)
737 There is one small problem with the Lambda Patterns, when somebody
738 writes something similar to:
740 he/she don't want a warning about incomplete patterns, that is done with
741 the flag opt_WarnSimplePatterns.
742 This problem also appears in the :
743 do patterns, but if the do can fail it creates another equation if the match can
744 fail (see DsExpr.doDo function)
745 let patterns, are treated by matchSimply
746 List Comprension Patterns, are treated by matchSimply also
748 We can't call matchSimply with Lambda patterns, due to lambda patterns can have more than
749 one pattern, and match simply only accepts one pattern.
754 matchWrapper kind matches error_string
755 = flattenMatches kind matches `thenDs` \ (result_ty, eqns_info) ->
757 EqnInfo _ _ arg_pats _ : _ = eqns_info
759 mapDs selectMatchVar arg_pats `thenDs` \ new_vars ->
760 match_fun new_vars eqns_info `thenDs` \ match_result ->
762 mkErrorAppDs pAT_ERROR_ID result_ty error_string `thenDs` \ fail_expr ->
763 extractMatchResult match_result fail_expr `thenDs` \ result_expr ->
764 returnDs (new_vars, result_expr)
765 where match_fun = case kind of
766 LambdaMatch | opt_WarnSimplePatterns -> matchExport
771 %************************************************************************
773 \subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern}
775 %************************************************************************
777 @mkSimpleMatch@ is a wrapper for @match@ which deals with the
778 situation where we want to match a single expression against a single
779 pattern. It returns an expression.
782 matchSimply :: CoreExpr -- Scrutinee
783 -> DsMatchKind -- Match kind
784 -> TypecheckedPat -- Pattern it should match
785 -> CoreExpr -- Return this if it matches
786 -> CoreExpr -- Return this if it doesn't
789 matchSimply scrut kind pat result_expr fail_expr
790 = getSrcLocDs `thenDs` \ locn ->
792 ctx = DsMatchContext kind [pat] locn
793 match_result = cantFailMatchResult result_expr
795 matchSinglePat scrut ctx pat match_result `thenDs` \ match_result' ->
796 extractMatchResult match_result' fail_expr
799 matchSinglePat :: CoreExpr -> DsMatchContext -> TypecheckedPat
800 -> MatchResult -> DsM MatchResult
802 matchSinglePat (Var var) ctx pat match_result
803 = match_fn [var] [EqnInfo 1 ctx [pat] match_result]
805 match_fn | opt_WarnSimplePatterns = matchExport
808 matchSinglePat scrut ctx pat match_result
809 = selectMatchVar pat `thenDs` \ var ->
810 matchSinglePat (Var var) ctx pat match_result `thenDs` \ match_result' ->
811 returnDs (adjustMatchResult (bindNonRec var scrut) match_result')
814 %************************************************************************
816 %* flattenMatches : create a list of EquationInfo *
818 %************************************************************************
820 \subsection[flattenMatches]{@flattenMatches@: create @[EquationInfo]@}
822 This is actually local to @matchWrapper@.
827 -> [TypecheckedMatch]
828 -> DsM (Type, [EquationInfo])
830 flattenMatches kind matches
831 = mapAndUnzipDs flatten_match (matches `zip` [1..]) `thenDs` \ (result_tys, eqn_infos) ->
833 result_ty = head result_tys
835 ASSERT( all (== result_ty) result_tys )
836 returnDs (result_ty, eqn_infos)
838 flatten_match (match, eqn_no) = flatten_match_help [] match eqn_no
840 flatten_match_help :: [TypecheckedPat] -- Reversed list of patterns encountered so far
843 -> DsM (Type, EquationInfo)
845 flatten_match_help pats_so_far (PatMatch pat match) n
846 = flatten_match_help (pat:pats_so_far) match n
848 flatten_match_help pats_so_far (GRHSMatch (GRHSsAndBindsOut grhss binds ty)) n
849 = dsGRHSs kind pats grhss `thenDs` \ match_result ->
850 getSrcLocDs `thenDs` \ locn ->
851 returnDs (ty, EqnInfo n (DsMatchContext kind pats locn) pats
852 (adjustMatchResultDs (dsLet binds) match_result))
853 -- NB: nested dsLet inside matchResult
855 pats = reverse pats_so_far -- They've accumulated in reverse order
857 flatten_match_help pats_so_far (SimpleMatch expr) n
858 = dsExpr expr `thenDs` \ core_expr ->
859 getSrcLocDs `thenDs` \ locn ->
860 returnDs (coreExprType core_expr,
861 EqnInfo n (DsMatchContext kind pats locn) pats
862 (cantFailMatchResult core_expr))
864 pats = reverse pats_so_far -- They've accumulated in reverse order