3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
5 \section[Main_match]{The @match@ function}
8 module Match ( match, matchExport, matchWrapper, matchSimply ) where
10 #include "HsVersions.h"
12 import {-# SOURCE #-} DsExpr ( dsExpr )
13 import {-# SOURCE #-} DsBinds ( dsBinds )
15 import CmdLineOpts ( opt_WarnIncompletePatterns, opt_WarnOverlappingPatterns,
16 opt_WarnSimplePatterns
19 import TcHsSyn ( TypecheckedPat, TypecheckedMatch,
20 TypecheckedHsBinds, TypecheckedHsExpr )
21 import DsHsSyn ( outPatType )
22 import Check ( check, ExhaustivePat, WarningPat, BoxedString )
24 import CoreUtils ( coreExprType )
26 import DsGRHSs ( dsGRHSs )
28 import Id ( idType, dataConFieldLabels,
29 dataConArgTys, recordSelectorFieldLabel,
32 import MatchCon ( matchConFamily )
33 import MatchLit ( matchLiterals )
34 import Name ( Name {--O only-} )
35 import PrelVals ( pAT_ERROR_ID )
36 import Type ( isUnpointedType, splitAlgTyConApp,
39 import TyVar ( TyVar )
40 import TysPrim ( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy,
41 addrPrimTy, wordPrimTy
43 import TysWiredIn ( nilDataCon, consDataCon, mkTupleTy, mkListTy,
44 charTy, charDataCon, intTy, intDataCon,
45 floatTy, floatDataCon, doubleTy, tupleCon,
46 doubleDataCon, addrTy,
47 addrDataCon, wordTy, wordDataCon
53 This function is a wrapper of @match@, it must be called from all the parts where
54 it was called match, but only substitutes the firs call, ....
55 if the associated flags are declared, warnings will be issued.
56 It can not be called matchWrapper because this name already exists :-(
61 matchExport :: [Id] -- Vars rep'ing the exprs we're matching with
62 -> [EquationInfo] -- Info about patterns, etc. (type synonym below)
63 -> DsM MatchResult -- Desugared result!
65 matchExport vars qs@((EqnInfo _ ctx _ (MatchResult _ _ _)) : _)
66 | incomplete && shadow =
67 dsShadowWarn ctx eqns_shadow `thenDs` \ () ->
68 dsIncompleteWarn ctx pats `thenDs` \ () ->
71 dsIncompleteWarn ctx pats `thenDs` \ () ->
74 dsShadowWarn ctx eqns_shadow `thenDs` \ () ->
78 where (pats,indexs) = check qs
79 incomplete = opt_WarnIncompletePatterns && (length pats /= 0)
80 shadow = opt_WarnOverlappingPatterns && sizeUniqSet indexs < no_eqns
82 unused_eqns = uniqSetToList (mkUniqSet [1..no_eqns] `minusUniqSet` indexs)
83 eqns_shadow = map (\n -> qs!!(n - 1)) unused_eqns
86 This variable shows the maximun number of lines of output generated for warnings.
87 It will limit the number of patterns/equations displayed to maximum_output.
89 (ToDo: add command-line option?)
95 The next two functions creates the warning message.
98 dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM ()
99 dsShadowWarn ctx@(DsMatchContext kind _ _) qs = dsWarn warn
101 warn | length qs > maximum_output
102 = hang (pp_context ctx (ptext SLIT("are overlapped")))
103 12 ((vcat $ map (ppr_eqn kind) (take maximum_output qs))
104 $$ ptext SLIT("..."))
106 = hang (pp_context ctx (ptext SLIT("are overlapped")))
107 12 (vcat $ map (ppr_eqn kind) qs)
109 dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM ()
110 dsIncompleteWarn ctx@(DsMatchContext kind _ _) pats = dsWarn warn
112 warn | length pats > maximum_output
113 = hang (pp_context ctx (ptext SLIT("are non-exhaustive")))
114 12 (hang (ptext SLIT("Patterns not recognized:"))
115 4 ((vcat $ map (ppr_incomplete_pats kind) (take maximum_output pats))
116 $$ ptext SLIT("...")))
118 = hang (pp_context ctx (ptext SLIT("are non-exhaustive")))
119 12 (hang (ptext SLIT("Patterns not recognized:"))
120 4 (vcat $ map (ppr_incomplete_pats kind) pats))
122 pp_context NoMatchContext msg = ptext SLIT("Some match(es)") <+> msg
124 pp_context (DsMatchContext kind pats loc) msg
125 = hang (hcat [ppr loc, ptext SLIT(": ")])
127 4 (pp_match kind pats))
129 message = ptext SLIT("Pattern match(es)") <+> msg
131 pp_match (FunMatch fun) pats
132 = hsep [ptext SLIT("in the definition of function"), quotes (ppr fun)]
134 pp_match CaseMatch pats
135 = hang (ptext SLIT("in a group of case alternatives beginning:"))
138 pp_match PatBindMatch pats
139 = hang (ptext SLIT("in a pattern binding:"))
142 pp_match LambdaMatch pats
143 = hang (ptext SLIT("in a lambda abstraction:"))
146 pp_match DoBindMatch pats
147 = hang (ptext SLIT("in a `do' pattern binding:"))
150 pp_match ListCompMatch pats
151 = hang (ptext SLIT("in a `list comprension' pattern binding:"))
154 pp_match LetMatch pats
155 = hang (ptext SLIT("in a `let' pattern binding:"))
158 ppr_pats pats = sep (map ppr pats)
160 separator (FunMatch _) = SLIT("=")
161 separator (CaseMatch) = SLIT("->")
162 separator (LambdaMatch) = SLIT("->")
163 separator (PatBindMatch) = panic "When is this used?"
164 separator (DoBindMatch) = SLIT("<-")
165 separator (ListCompMatch) = SLIT("<-")
166 separator (LetMatch) = SLIT("=")
168 ppr_shadow_pats kind pats = sep [ppr_pats pats, ptext (separator kind), ptext SLIT("...")]
170 ppr_incomplete_pats kind (pats,[]) = ppr_pats pats
171 ppr_incomplete_pats kind (pats,constraints) =
172 sep [ppr_pats pats, ptext SLIT("with"),
173 sep (map ppr_constraint constraints)]
176 ppr_constraint (var,pats) = sep [ppr var, ptext SLIT("`not_elem`"), ppr pats]
178 ppr_eqn kind (EqnInfo _ _ pats _) = ppr_shadow_pats kind pats
183 The function @match@ is basically the same as in the Wadler chapter,
184 except it is monadised, to carry around the name supply, info about
187 Notes on @match@'s arguments, assuming $m$ equations and $n$ patterns:
190 A list of $n$ variable names, those variables presumably bound to the
191 $n$ expressions being matched against the $n$ patterns. Using the
192 list of $n$ expressions as the first argument showed no benefit and
196 The second argument, a list giving the ``equation info'' for each of
200 the $n$ patterns for that equation, and
202 a list of Core bindings [@(Id, CoreExpr)@ pairs] to be ``stuck on
203 the front'' of the matching code, as in:
209 and finally: (ToDo: fill in)
211 The right way to think about the ``after-match function'' is that it
212 is an embryonic @CoreExpr@ with a ``hole'' at the end for the
213 final ``else expression''.
216 There is a type synonym, @EquationInfo@, defined in module @DsUtils@.
218 An experiment with re-ordering this information about equations (in
219 particular, having the patterns available in column-major order)
223 A default expression---what to evaluate if the overall pattern-match
224 fails. This expression will (almost?) always be
225 a measly expression @Var@, unless we know it will only be used once
226 (as we do in @glue_success_exprs@).
228 Leaving out this third argument to @match@ (and slamming in lots of
229 @Var "fail"@s) is a positively {\em bad} idea, because it makes it
230 impossible to share the default expressions. (Also, it stands no
231 chance of working in our post-upheaval world of @Locals@.)
233 So, the full type signature:
235 match :: [Id] -- Variables rep'ing the exprs we're matching with
236 -> [EquationInfo] -- Info about patterns, etc. (type synonym below)
237 -> DsM MatchResult -- Desugared result!
240 Note: @match@ is often called via @matchWrapper@ (end of this module),
241 a function that does much of the house-keeping that goes with a call
244 It is also worth mentioning the {\em typical} way a block of equations
245 is desugared with @match@. At each stage, it is the first column of
246 patterns that is examined. The steps carried out are roughly:
249 Tidy the patterns in column~1 with @tidyEqnInfo@ (this may add
250 bindings to the second component of the equation-info):
253 Remove the `as' patterns from column~1.
255 Make all constructor patterns in column~1 into @ConPats@, notably
256 @ListPats@ and @TuplePats@.
258 Handle any irrefutable (or ``twiddle'') @LazyPats@.
261 Now {\em unmix} the equations into {\em blocks} [w/ local function
262 @unmix_eqns@], in which the equations in a block all have variable
263 patterns in column~1, or they all have constructor patterns in ...
264 (see ``the mixture rule'' in SLPJ).
266 Call @matchUnmixedEqns@ on each block of equations; it will do the
267 appropriate thing for each kind of column-1 pattern, usually ending up
268 in a recursive call to @match@.
271 %************************************************************************
273 %* match: empty rule *
275 %************************************************************************
276 \subsection[Match-empty-rule]{The ``empty rule''}
278 We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87)
279 than the Wadler-chapter code for @match@ (p.~93, first @match@ clause).
280 And gluing the ``success expressions'' together isn't quite so pretty.
284 = complete_matches eqns_info
286 complete_matches [eqn]
289 complete_matches (eqn:eqns)
290 = complete_match eqn `thenDs` \ match_result1 ->
291 complete_matches eqns `thenDs` \ match_result2 ->
292 combineMatchResults match_result1 match_result2
294 complete_match (EqnInfo _ _ [] match_result@(MatchResult _ _ _))
295 = returnDs match_result
298 %************************************************************************
300 %* match: non-empty rule *
302 %************************************************************************
303 \subsection[Match-nonempty]{@match@ when non-empty: unmixing}
305 This (more interesting) clause of @match@ uses @tidy_and_unmix_eqns@
306 (a)~to get `as'- and `twiddle'-patterns out of the way (tidying), and
307 (b)~to do ``the mixture rule'' (SLPJ, p.~88) [which really {\em
308 un}mixes the equations], producing a list of equation-info
309 blocks, each block having as its first column of patterns either all
310 constructors, or all variables (or similar beasts), etc.
312 @match_unmixed_eqn_blks@ simply takes the place of the @foldr@ in the
313 Wadler-chapter @match@ (p.~93, last clause), and @match_unmixed_blk@
314 corresponds roughly to @matchVarCon@.
317 match vars@(v:vs) eqns_info
318 = mapDs (tidyEqnInfo v) eqns_info `thenDs` \ tidy_eqns_info ->
320 tidy_eqns_blks = unmix_eqns tidy_eqns_info
322 match_unmixed_eqn_blks vars tidy_eqns_blks
325 unmix_eqns [eqn] = [ [eqn] ]
326 unmix_eqns (eq1@(EqnInfo _ _ (p1:p1s) _) : eq2@(EqnInfo _ _ (p2:p2s) _) : eqs)
327 = if ( (irrefutablePat p1 && irrefutablePat p2)
328 || (isConPat p1 && isConPat p2)
329 || (isLitPat p1 && isLitPat p2) ) then
330 eq1 `tack_onto` unmixed_rest
332 [ eq1 ] : unmixed_rest
334 unmixed_rest = unmix_eqns (eq2:eqs)
336 x `tack_onto` xss = ( x : head xss) : tail xss
338 -----------------------------------------------------------------------
339 -- loop through the blocks:
340 -- subsequent blocks create a "fail expr" for the first one...
341 match_unmixed_eqn_blks :: [Id]
342 -> [ [EquationInfo] ] -- List of eqn BLOCKS
345 match_unmixed_eqn_blks vars [] = panic "match_unmixed_eqn_blks"
347 match_unmixed_eqn_blks vars [eqn_blk] = matchUnmixedEqns vars eqn_blk
349 match_unmixed_eqn_blks vars (eqn_blk:eqn_blks)
350 = matchUnmixedEqns vars eqn_blk `thenDs` \ match_result1 -> -- try to match with first blk
351 match_unmixed_eqn_blks vars eqn_blks `thenDs` \ match_result2 ->
352 combineMatchResults match_result1 match_result2
355 Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@
356 which will be scrutinised. This means:
359 Replace variable patterns @x@ (@x /= v@) with the pattern @_@,
360 together with the binding @x = v@.
362 Replace the `as' pattern @x@@p@ with the pattern p and a binding @x = v@.
364 Removing lazy (irrefutable) patterns (you don't want to know...).
366 Converting explicit tuple- and list-pats into ordinary @ConPats@.
368 Convert the literal pat "" to [].
371 The result of this tidying is that the column of patterns will include
375 The @VarPat@ information isn't needed any more after this.
378 @ListPats@, @TuplePats@, etc., are all converted into @ConPats@.
380 \item[@LitPats@ and @NPats@:]
381 @LitPats@/@NPats@ of ``known friendly types'' (Int, Char,
382 Float, Double, at least) are converted to unboxed form; e.g.,
383 \tr{(NPat (HsInt i) _ _)} is converted to:
385 (ConPat I# _ _ [LitPat (HsIntPrim i) _])
390 tidyEqnInfo :: Id -> EquationInfo -> DsM EquationInfo
391 -- DsM'd because of internal call to "match".
392 -- "tidy1" does the interesting stuff, looking at
393 -- one pattern and fiddling the list of bindings.
394 tidyEqnInfo v (EqnInfo n ctx (pat : pats) match_result)
395 = tidy1 v pat match_result `thenDs` \ (pat', match_result') ->
396 returnDs (EqnInfo n ctx (pat' : pats) match_result')
398 tidy1 :: Id -- The Id being scrutinised
399 -> TypecheckedPat -- The pattern against which it is to be matched
400 -> MatchResult -- Current thing do do after matching
401 -> DsM (TypecheckedPat, -- Equivalent pattern
402 MatchResult) -- Augmented thing to do afterwards
403 -- The augmentation usually takes the form
404 -- of new bindings to be added to the front
406 tidy1 v (VarPat var) match_result
407 = returnDs (WildPat (idType var),
408 mkCoLetsMatchResult extra_binds match_result)
410 extra_binds | v == var = []
411 | otherwise = [NonRec var (Var v)]
413 tidy1 v (AsPat var pat) match_result
414 = tidy1 v pat (mkCoLetsMatchResult extra_binds match_result)
416 extra_binds | v == var = []
417 | otherwise = [NonRec var (Var v)]
419 tidy1 v (WildPat ty) match_result
420 = returnDs (WildPat ty, match_result)
422 {- now, here we handle lazy patterns:
423 tidy1 v ~p bs = (v, v1 = case v of p -> v1 :
424 v2 = case v of p -> v2 : ... : bs )
426 where the v_i's are the binders in the pattern.
428 ToDo: in "v_i = ... -> v_i", are the v_i's really the same thing?
430 The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr
433 tidy1 v (LazyPat pat) match_result
434 = mkSelectorBinds pat (Var v) `thenDs` \ sel_binds ->
435 returnDs (WildPat (idType v),
436 mkCoLetsMatchResult [NonRec b rhs | (b,rhs) <- sel_binds] match_result)
438 -- re-express <con-something> as (ConPat ...) [directly]
440 tidy1 v (ConOpPat pat1 id pat2 ty) match_result
441 = returnDs (ConPat id ty [pat1, pat2], match_result)
443 tidy1 v (RecPat con_id pat_ty rpats) match_result
444 = returnDs (ConPat con_id pat_ty pats, match_result)
446 pats = map mk_pat tagged_arg_tys
448 -- Boring stuff to find the arg-tys of the constructor
449 (_, inst_tys, _) = splitAlgTyConApp pat_ty
450 con_arg_tys' = dataConArgTys con_id inst_tys
451 tagged_arg_tys = con_arg_tys' `zip` (dataConFieldLabels con_id)
453 -- mk_pat picks a WildPat of the appropriate type for absent fields,
454 -- and the specified pattern for present fields
455 mk_pat (arg_ty, lbl) = case [pat | (sel_id,pat,_) <- rpats,
456 recordSelectorFieldLabel sel_id == lbl
458 (pat:pats) -> ASSERT( null pats )
462 tidy1 v (ListPat ty pats) match_result
463 = returnDs (list_ConPat, match_result)
465 list_ty = mkListTy ty
467 = foldr (\ x -> \y -> ConPat consDataCon list_ty [x, y])
468 (ConPat nilDataCon list_ty [])
471 tidy1 v (TuplePat pats) match_result
472 = returnDs (tuple_ConPat, match_result)
476 = ConPat (tupleCon arity)
477 (mkTupleTy arity (map outPatType pats))
480 tidy1 v (DictPat dicts methods) match_result
481 = case num_of_d_and_ms of
482 0 -> tidy1 v (TuplePat []) match_result
483 1 -> tidy1 v (head dict_and_method_pats) match_result
484 _ -> tidy1 v (TuplePat dict_and_method_pats) match_result
486 num_of_d_and_ms = length dicts + length methods
487 dict_and_method_pats = map VarPat (dicts ++ methods)
490 -- deeply ugly mangling for some (common) NPats/LitPats
492 -- LitPats: the desugarer only sees these at well-known types
494 tidy1 v pat@(LitPat lit lit_ty) match_result
495 | isUnpointedType lit_ty
496 = returnDs (pat, match_result)
499 = returnDs (ConPat charDataCon charTy [LitPat (mk_char lit) charPrimTy],
502 | otherwise = pprPanic "tidy1:LitPat:" (ppr pat)
504 mk_char (HsChar c) = HsCharPrim c
506 -- NPats: we *might* be able to replace these w/ a simpler form
509 tidy1 v pat@(NPat lit lit_ty _) match_result
510 = returnDs (better_pat, match_result)
513 | lit_ty == charTy = ConPat charDataCon lit_ty [LitPat (mk_char lit) charPrimTy]
514 | lit_ty == intTy = ConPat intDataCon lit_ty [LitPat (mk_int lit) intPrimTy]
515 | lit_ty == wordTy = ConPat wordDataCon lit_ty [LitPat (mk_word lit) wordPrimTy]
516 | lit_ty == addrTy = ConPat addrDataCon lit_ty [LitPat (mk_addr lit) addrPrimTy]
517 | lit_ty == floatTy = ConPat floatDataCon lit_ty [LitPat (mk_float lit) floatPrimTy]
518 | lit_ty == doubleTy = ConPat doubleDataCon lit_ty [LitPat (mk_double lit) doublePrimTy]
520 -- Convert the literal pattern "" to the constructor pattern [].
521 | null_str_lit lit = ConPat nilDataCon lit_ty []
525 mk_int (HsInt i) = HsIntPrim i
526 mk_int l@(HsLitLit s) = l
528 mk_char (HsChar c) = HsCharPrim c
529 mk_char l@(HsLitLit s) = l
531 mk_word l@(HsLitLit s) = l
533 mk_addr l@(HsLitLit s) = l
535 mk_float (HsInt i) = HsFloatPrim (fromInteger i)
536 mk_float (HsFrac f) = HsFloatPrim f
537 mk_float l@(HsLitLit s) = l
539 mk_double (HsInt i) = HsDoublePrim (fromInteger i)
540 mk_double (HsFrac f) = HsDoublePrim f
541 mk_double l@(HsLitLit s) = l
543 null_str_lit (HsString s) = _NULL_ s
544 null_str_lit other_lit = False
546 -- and everything else goes through unchanged...
548 tidy1 v non_interesting_pat match_result
549 = returnDs (non_interesting_pat, match_result)
552 PREVIOUS matchTwiddled STUFF:
554 Now we get to the only interesting part; note: there are choices for
555 translation [from Simon's notes]; translation~1:
562 s = case w of [s,t] -> s
563 t = case w of [s,t] -> t
567 Here \tr{w} is a fresh variable, and the \tr{w}-binding prevents multiple
568 evaluation of \tr{e}. An alternative translation (No.~2):
570 [ w = case e of [s,t] -> (s,t)
571 s = case w of (s,t) -> s
572 t = case w of (s,t) -> t
576 %************************************************************************
578 \subsubsection[improved-unmixing]{UNIMPLEMENTED idea for improved unmixing}
580 %************************************************************************
582 We might be able to optimise unmixing when confronted by
583 only-one-constructor-possible, of which tuples are the most notable
591 This definition would normally be unmixed into four equation blocks,
592 one per equation. But it could be unmixed into just one equation
593 block, because if the one equation matches (on the first column),
594 the others certainly will.
596 You have to be careful, though; the example
604 {\em must} be broken into two blocks at the line shown; otherwise, you
605 are forcing unnecessary evaluation. In any case, the top-left pattern
606 always gives the cue. You could then unmix blocks into groups of...
608 \item[all variables:]
610 \item[constructors or variables (mixed):]
611 Need to make sure the right names get bound for the variable patterns.
612 \item[literals or variables (mixed):]
613 Presumably just a variant on the constructor case (as it is now).
616 %************************************************************************
618 %* match on an unmixed block: the real business *
620 %************************************************************************
621 \subsection[matchUnmixedEqns]{@matchUnmixedEqns@: getting down to business}
623 The function @matchUnmixedEqns@ is where the matching stuff sets to
624 work a block of equations, to which the mixture rule has been applied.
625 Its arguments and results are the same as for the ``top-level'' @match@.
628 matchUnmixedEqns :: [Id]
632 matchUnmixedEqns [] _ = panic "matchUnmixedEqns: no names"
634 matchUnmixedEqns all_vars@(var:vars) eqns_info
635 | irrefutablePat first_pat
636 = ASSERT( irrefutablePats column_1_pats ) -- Sanity check
637 -- Real true variables, just like in matchVar, SLPJ p 94
638 match vars remaining_eqns_info
641 = ASSERT( patsAreAllCons column_1_pats )
642 matchConFamily all_vars eqns_info
645 = ASSERT( patsAreAllLits column_1_pats )
646 -- see notes in MatchLiteral
647 -- not worried about the same literal more than once in a column
648 -- (ToDo: sort this out later)
649 matchLiterals all_vars eqns_info
652 first_pat = head column_1_pats
653 column_1_pats = [pat | EqnInfo _ _ (pat:_) _ <- eqns_info]
654 remaining_eqns_info = [EqnInfo n ctx pats match_result | EqnInfo n ctx (_:pats) match_result <- eqns_info]
657 %************************************************************************
659 %* matchWrapper: a convenient way to call @match@ *
661 %************************************************************************
662 \subsection[matchWrapper]{@matchWrapper@: a convenient interface to @match@}
664 Calls to @match@ often involve similar (non-trivial) work; that work
665 is collected here, in @matchWrapper@. This function takes as
669 Typchecked @Matches@ (of a function definition, or a case or lambda
670 expression)---the main input;
672 An error message to be inserted into any (runtime) pattern-matching
676 As results, @matchWrapper@ produces:
679 A list of variables (@Locals@) that the caller must ``promise'' to
680 bind to appropriate values; and
682 a @CoreExpr@, the desugared output (main result).
685 The main actions of @matchWrapper@ include:
688 Flatten the @[TypecheckedMatch]@ into a suitable list of
691 Create as many new variables as there are patterns in a pattern-list
692 (in any one of the @EquationInfo@s).
694 Create a suitable ``if it fails'' expression---a call to @error@ using
695 the error-string input; the {\em type} of this fail value can be found
696 by examining one of the RHS expressions in one of the @EquationInfo@s.
698 Call @match@ with all of this information!
702 matchWrapper :: DsMatchKind -- For shadowing warning messages
703 -> [TypecheckedMatch] -- Matches being desugared
704 -> String -- Error message if the match fails
705 -> DsM ([Id], CoreExpr) -- Results
708 a special case for the common ...:
710 lots of (all?) unfailable pats
714 This special case have been ``undone'' due to problems with the new warnings
715 messages (Check.lhs.check). We need there the name of the variables to be able to
716 print later the equation. JJQC 30-11-97
719 matchWrapper kind [(PatMatch (VarPat var) match)] error_string
720 = matchWrapper kind [match] error_string `thenDs` \ (vars, core_expr) ->
721 returnDs (var:vars, core_expr)
723 matchWrapper kind [(PatMatch (WildPat ty) match)] error_string
724 = newSysLocalDs ty `thenDs` \ var ->
725 matchWrapper kind [match] error_string `thenDs` \ (vars, core_expr) ->
726 returnDs (var:vars, core_expr)
728 matchWrapper kind [(GRHSMatch
729 (GRHSsAndBindsOut [GRHS [] expr _] binds _))] error_string
730 = dsBinds False{-don't auto-scc-} binds `thenDs` \ core_binds ->
731 dsExpr expr `thenDs` \ core_expr ->
732 returnDs ([], mkCoLetsAny core_binds core_expr)
735 And all the rest... (general case)
738 There is one small problem with the Lambda Patterns, when somebody
739 writes something similar to:
741 he/she don't want a warning about incomplete patterns, that is done with
742 the flag opt_WarnSimplePatterns.
743 This problem also appears in the :
744 do patterns, but if the do can fail it creates another equation if the match can
745 fail (see DsExpr.doDo function)
746 let patterns, are treated by matchSimply
747 List Comprension Patterns, are treated by matchSimply also
749 We can't call matchSimply with Lambda patterns, due to lambda patterns can have more than
750 one pattern, and match simply only accepts one pattern.
756 matchWrapper kind matches error_string
757 = flattenMatches kind 1 matches `thenDs` \ eqns_info@(EqnInfo _ _ arg_pats (MatchResult _ result_ty _) : _) ->
759 selectMatchVars 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 ->
764 extractMatchResult match_result fail_expr `thenDs` \ result_expr ->
765 returnDs (new_vars, result_expr)
766 where match_fun = case kind of
767 LambdaMatch | opt_WarnSimplePatterns -> matchExport
772 %************************************************************************
774 \subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern}
776 %************************************************************************
778 @mkSimpleMatch@ is a wrapper for @match@ which deals with the
779 situation where we want to match a single expression against a single
780 pattern. It returns an expression.
783 matchSimply :: CoreExpr -- Scrutinee
784 -> DsMatchKind -- Match kind
785 -> TypecheckedPat -- Pattern it should match
786 -> Type -- Type of result
787 -> CoreExpr -- Return this if it matches
788 -> CoreExpr -- Return this if it does
791 matchSimply (Var var) kind pat result_ty result_expr fail_expr
792 = getSrcLocDs `thenDs` \ locn ->
794 ctx = DsMatchContext kind [pat] locn
795 eqn_info = EqnInfo 1 ctx [pat] initial_match_result
797 match_fun [var] [eqn_info] `thenDs` \ match_result ->
798 extractMatchResult match_result fail_expr
800 initial_match_result = MatchResult CantFail result_ty (\ ignore -> result_expr)
801 match_fun = if opt_WarnSimplePatterns
805 matchSimply scrut_expr kind pat result_ty result_expr msg
806 = newSysLocalDs (outPatType pat) `thenDs` \ scrut_var ->
807 matchSimply (Var scrut_var) kind pat result_ty result_expr msg `thenDs` \ expr ->
808 returnDs (Let (NonRec scrut_var scrut_expr) expr)
811 extractMatchResult (MatchResult CantFail _ match_fn) fail_expr
812 = returnDs (match_fn (error "It can't fail!"))
814 extractMatchResult (MatchResult CanFail result_ty match_fn) fail_expr
815 = mkFailurePair result_ty `thenDs` \ (fail_bind_fn, if_it_fails) ->
816 returnDs (Let (fail_bind_fn fail_expr) (match_fn if_it_fails))
819 %************************************************************************
821 %* flattenMatches : create a list of EquationInfo *
823 %************************************************************************
824 \subsection[flattenMatches]{@flattenMatches@: create @[EquationInfo]@}
826 This is actually local to @matchWrapper@.
832 -> [TypecheckedMatch]
833 -> DsM [EquationInfo]
835 flattenMatches kind n [] = returnDs []
837 flattenMatches kind n (match : matches)
838 = flatten_match [] n match `thenDs` \ eqn_info ->
839 flattenMatches kind (n+1) matches `thenDs` \ eqn_infos ->
840 returnDs (eqn_info : eqn_infos)
842 flatten_match :: [TypecheckedPat] -- Reversed list of patterns encountered so far
847 flatten_match pats_so_far n (PatMatch pat match)
848 = flatten_match (pat:pats_so_far) n match
850 flatten_match pats_so_far n (GRHSMatch (GRHSsAndBindsOut grhss binds ty))
851 = dsBinds False{-don't auto-scc-} binds `thenDs` \ core_binds ->
852 dsGRHSs ty kind pats grhss `thenDs` \ match_result ->
853 getSrcLocDs `thenDs` \ locn ->
854 returnDs (EqnInfo n (DsMatchContext kind pats locn) pats
855 (mkCoLetsMatchResult core_binds match_result))
857 pats = reverse pats_so_far -- They've accumulated in reverse order
859 flatten_match pats_so_far n (SimpleMatch expr)
860 = dsExpr expr `thenDs` \ core_expr ->
861 getSrcLocDs `thenDs` \ locn ->
862 returnDs (EqnInfo n (DsMatchContext kind pats locn) pats
863 (MatchResult CantFail (coreExprType core_expr)
864 (\ ignore -> core_expr)))
866 -- the matching can't fail, so we won't generate an error message.
868 pats = reverse pats_so_far -- They've accumulated in reverse order