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 PprType ( GenType{-instance-}, GenTyVar{-ditto-} )
36 import PrelVals ( pAT_ERROR_ID )
37 import Type ( isUnpointedType, splitAlgTyConApp,
40 import TyVar ( TyVar )
41 import TysPrim ( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy,
42 addrPrimTy, wordPrimTy
44 import TysWiredIn ( nilDataCon, consDataCon, mkTupleTy, mkListTy,
45 charTy, charDataCon, intTy, intDataCon,
46 floatTy, floatDataCon, doubleTy, tupleCon,
47 doubleDataCon, addrTy,
48 addrDataCon, wordTy, wordDataCon
54 This function is a wrapper of @match@, it must be called from all the parts where
55 it was called match, but only substitutes the firs call, ....
56 if the associated flags are declared, warnings will be issued.
57 It can not be called matchWrapper because this name already exists :-(
62 matchExport :: [Id] -- Vars rep'ing the exprs we're matching with
63 -> [EquationInfo] -- Info about patterns, etc. (type synonym below)
64 -> DsM MatchResult -- Desugared result!
66 matchExport vars qs@((EqnInfo _ ctx _ (MatchResult _ _ _)) : _)
67 | incomplete && shadow =
68 dsShadowWarn ctx eqns_shadow `thenDs` \ () ->
69 dsIncompleteWarn ctx pats `thenDs` \ () ->
72 dsIncompleteWarn ctx pats `thenDs` \ () ->
75 dsShadowWarn ctx eqns_shadow `thenDs` \ () ->
79 where (pats,indexs) = check qs
80 incomplete = opt_WarnIncompletePatterns && (length pats /= 0)
81 shadow = opt_WarnOverlappingPatterns && sizeUniqSet indexs < no_eqns
83 unused_eqns = uniqSetToList (mkUniqSet [1..no_eqns] `minusUniqSet` indexs)
84 eqns_shadow = map (\n -> qs!!(n - 1)) unused_eqns
87 This variable shows the maximun number of lines of output generated for warnings.
88 It will limit the number of patterns/equations displayed to maximum_output.
90 (ToDo: add command-line option?)
96 The next two functions creates the warning message.
99 dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM ()
100 dsShadowWarn ctx@(DsMatchContext kind _ _) qs = dsWarn warn
102 warn | length qs > maximum_output
103 = hang (pp_context ctx (ptext SLIT("are overlapped")))
104 12 ((vcat $ map (ppr_eqn kind) (take maximum_output qs))
105 $$ ptext SLIT("..."))
107 = hang (pp_context ctx (ptext SLIT("are overlapped")))
108 12 (vcat $ map (ppr_eqn kind) qs)
110 dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM ()
111 dsIncompleteWarn ctx@(DsMatchContext kind _ _) pats = dsWarn warn
113 warn | length pats > maximum_output
114 = hang (pp_context ctx (ptext SLIT("are non-exhaustive")))
115 12 (hang (ptext SLIT("Patterns not recognized:"))
116 4 ((vcat $ map (ppr_incomplete_pats kind) (take maximum_output pats))
117 $$ ptext SLIT("...")))
119 = hang (pp_context ctx (ptext SLIT("are non-exhaustive")))
120 12 (hang (ptext SLIT("Patterns not recognized:"))
121 4 (vcat $ map (ppr_incomplete_pats kind) pats))
123 pp_context NoMatchContext msg = ptext SLIT("Some match(es)") <+> msg
125 pp_context (DsMatchContext kind pats loc) msg
126 = hang (hcat [ppr loc, ptext SLIT(": ")])
128 4 (pp_match kind pats))
130 message = ptext SLIT("Pattern match(es)") <+> msg
132 pp_match (FunMatch fun) pats
133 = hsep [ptext SLIT("in the definition of function"), quotes (ppr fun)]
135 pp_match CaseMatch pats
136 = hang (ptext SLIT("in a group of case alternatives beginning:"))
139 pp_match PatBindMatch pats
140 = hang (ptext SLIT("in a pattern binding:"))
143 pp_match LambdaMatch pats
144 = hang (ptext SLIT("in a lambda abstraction:"))
147 pp_match DoBindMatch pats
148 = hang (ptext SLIT("in a `do' pattern binding:"))
151 pp_match ListCompMatch pats
152 = hang (ptext SLIT("in a `list comprension' pattern binding:"))
155 pp_match LetMatch pats
156 = hang (ptext SLIT("in a `let' pattern binding:"))
159 ppr_pats pats = sep (map ppr pats)
161 separator (FunMatch _) = SLIT("=")
162 separator (CaseMatch) = SLIT("->")
163 separator (LambdaMatch) = SLIT("->")
164 separator (PatBindMatch) = panic "When is this used?"
165 separator (DoBindMatch) = SLIT("<-")
166 separator (ListCompMatch) = SLIT("<-")
167 separator (LetMatch) = SLIT("=")
169 ppr_shadow_pats kind pats = sep [ppr_pats pats, ptext (separator kind), ptext SLIT("...")]
171 ppr_incomplete_pats kind (pats,[]) = ppr_pats pats
172 ppr_incomplete_pats kind (pats,constraints) =
173 sep [ppr_pats pats, ptext SLIT("with"),
174 sep (map ppr_constraint constraints)]
177 ppr_constraint (var,pats) = sep [ppr var, ptext SLIT("`not_elem`"), ppr pats]
179 ppr_eqn kind (EqnInfo _ _ pats _) = ppr_shadow_pats kind pats
184 The function @match@ is basically the same as in the Wadler chapter,
185 except it is monadised, to carry around the name supply, info about
188 Notes on @match@'s arguments, assuming $m$ equations and $n$ patterns:
191 A list of $n$ variable names, those variables presumably bound to the
192 $n$ expressions being matched against the $n$ patterns. Using the
193 list of $n$ expressions as the first argument showed no benefit and
197 The second argument, a list giving the ``equation info'' for each of
201 the $n$ patterns for that equation, and
203 a list of Core bindings [@(Id, CoreExpr)@ pairs] to be ``stuck on
204 the front'' of the matching code, as in:
210 and finally: (ToDo: fill in)
212 The right way to think about the ``after-match function'' is that it
213 is an embryonic @CoreExpr@ with a ``hole'' at the end for the
214 final ``else expression''.
217 There is a type synonym, @EquationInfo@, defined in module @DsUtils@.
219 An experiment with re-ordering this information about equations (in
220 particular, having the patterns available in column-major order)
224 A default expression---what to evaluate if the overall pattern-match
225 fails. This expression will (almost?) always be
226 a measly expression @Var@, unless we know it will only be used once
227 (as we do in @glue_success_exprs@).
229 Leaving out this third argument to @match@ (and slamming in lots of
230 @Var "fail"@s) is a positively {\em bad} idea, because it makes it
231 impossible to share the default expressions. (Also, it stands no
232 chance of working in our post-upheaval world of @Locals@.)
234 So, the full type signature:
236 match :: [Id] -- Variables rep'ing the exprs we're matching with
237 -> [EquationInfo] -- Info about patterns, etc. (type synonym below)
238 -> DsM MatchResult -- Desugared result!
241 Note: @match@ is often called via @matchWrapper@ (end of this module),
242 a function that does much of the house-keeping that goes with a call
245 It is also worth mentioning the {\em typical} way a block of equations
246 is desugared with @match@. At each stage, it is the first column of
247 patterns that is examined. The steps carried out are roughly:
250 Tidy the patterns in column~1 with @tidyEqnInfo@ (this may add
251 bindings to the second component of the equation-info):
254 Remove the `as' patterns from column~1.
256 Make all constructor patterns in column~1 into @ConPats@, notably
257 @ListPats@ and @TuplePats@.
259 Handle any irrefutable (or ``twiddle'') @LazyPats@.
262 Now {\em unmix} the equations into {\em blocks} [w/ local function
263 @unmix_eqns@], in which the equations in a block all have variable
264 patterns in column~1, or they all have constructor patterns in ...
265 (see ``the mixture rule'' in SLPJ).
267 Call @matchUnmixedEqns@ on each block of equations; it will do the
268 appropriate thing for each kind of column-1 pattern, usually ending up
269 in a recursive call to @match@.
272 %************************************************************************
274 %* match: empty rule *
276 %************************************************************************
277 \subsection[Match-empty-rule]{The ``empty rule''}
279 We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87)
280 than the Wadler-chapter code for @match@ (p.~93, first @match@ clause).
281 And gluing the ``success expressions'' together isn't quite so pretty.
285 = complete_matches eqns_info
287 complete_matches [eqn]
290 complete_matches (eqn:eqns)
291 = complete_match eqn `thenDs` \ match_result1 ->
292 complete_matches eqns `thenDs` \ match_result2 ->
293 combineMatchResults match_result1 match_result2
295 complete_match (EqnInfo _ _ [] match_result@(MatchResult _ _ _))
296 = returnDs match_result
299 %************************************************************************
301 %* match: non-empty rule *
303 %************************************************************************
304 \subsection[Match-nonempty]{@match@ when non-empty: unmixing}
306 This (more interesting) clause of @match@ uses @tidy_and_unmix_eqns@
307 (a)~to get `as'- and `twiddle'-patterns out of the way (tidying), and
308 (b)~to do ``the mixture rule'' (SLPJ, p.~88) [which really {\em
309 un}mixes the equations], producing a list of equation-info
310 blocks, each block having as its first column of patterns either all
311 constructors, or all variables (or similar beasts), etc.
313 @match_unmixed_eqn_blks@ simply takes the place of the @foldr@ in the
314 Wadler-chapter @match@ (p.~93, last clause), and @match_unmixed_blk@
315 corresponds roughly to @matchVarCon@.
318 match vars@(v:vs) eqns_info
319 = mapDs (tidyEqnInfo v) eqns_info `thenDs` \ tidy_eqns_info ->
321 tidy_eqns_blks = unmix_eqns tidy_eqns_info
323 match_unmixed_eqn_blks vars tidy_eqns_blks
326 unmix_eqns [eqn] = [ [eqn] ]
327 unmix_eqns (eq1@(EqnInfo _ _ (p1:p1s) _) : eq2@(EqnInfo _ _ (p2:p2s) _) : eqs)
328 = if ( (irrefutablePat p1 && irrefutablePat p2)
329 || (isConPat p1 && isConPat p2)
330 || (isLitPat p1 && isLitPat p2) ) then
331 eq1 `tack_onto` unmixed_rest
333 [ eq1 ] : unmixed_rest
335 unmixed_rest = unmix_eqns (eq2:eqs)
337 x `tack_onto` xss = ( x : head xss) : tail xss
339 -----------------------------------------------------------------------
340 -- loop through the blocks:
341 -- subsequent blocks create a "fail expr" for the first one...
342 match_unmixed_eqn_blks :: [Id]
343 -> [ [EquationInfo] ] -- List of eqn BLOCKS
346 match_unmixed_eqn_blks vars [] = panic "match_unmixed_eqn_blks"
348 match_unmixed_eqn_blks vars [eqn_blk] = matchUnmixedEqns vars eqn_blk
350 match_unmixed_eqn_blks vars (eqn_blk:eqn_blks)
351 = matchUnmixedEqns vars eqn_blk `thenDs` \ match_result1 -> -- try to match with first blk
352 match_unmixed_eqn_blks vars eqn_blks `thenDs` \ match_result2 ->
353 combineMatchResults match_result1 match_result2
356 Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@
357 which will be scrutinised. This means:
360 Replace variable patterns @x@ (@x /= v@) with the pattern @_@,
361 together with the binding @x = v@.
363 Replace the `as' pattern @x@@p@ with the pattern p and a binding @x = v@.
365 Removing lazy (irrefutable) patterns (you don't want to know...).
367 Converting explicit tuple- and list-pats into ordinary @ConPats@.
369 Convert the literal pat "" to [].
372 The result of this tidying is that the column of patterns will include
376 The @VarPat@ information isn't needed any more after this.
379 @ListPats@, @TuplePats@, etc., are all converted into @ConPats@.
381 \item[@LitPats@ and @NPats@:]
382 @LitPats@/@NPats@ of ``known friendly types'' (Int, Char,
383 Float, Double, at least) are converted to unboxed form; e.g.,
384 \tr{(NPat (HsInt i) _ _)} is converted to:
386 (ConPat I# _ _ [LitPat (HsIntPrim i) _])
391 tidyEqnInfo :: Id -> EquationInfo -> DsM EquationInfo
392 -- DsM'd because of internal call to "match".
393 -- "tidy1" does the interesting stuff, looking at
394 -- one pattern and fiddling the list of bindings.
395 tidyEqnInfo v (EqnInfo n ctx (pat : pats) match_result)
396 = tidy1 v pat match_result `thenDs` \ (pat', match_result') ->
397 returnDs (EqnInfo n ctx (pat' : pats) match_result')
399 tidy1 :: Id -- The Id being scrutinised
400 -> TypecheckedPat -- The pattern against which it is to be matched
401 -> MatchResult -- Current thing do do after matching
402 -> DsM (TypecheckedPat, -- Equivalent pattern
403 MatchResult) -- Augmented thing to do afterwards
404 -- The augmentation usually takes the form
405 -- of new bindings to be added to the front
407 tidy1 v (VarPat var) match_result
408 = returnDs (WildPat (idType var),
409 mkCoLetsMatchResult extra_binds match_result)
411 extra_binds | v == var = []
412 | otherwise = [NonRec var (Var v)]
414 tidy1 v (AsPat var pat) match_result
415 = tidy1 v pat (mkCoLetsMatchResult extra_binds match_result)
417 extra_binds | v == var = []
418 | otherwise = [NonRec var (Var v)]
420 tidy1 v (WildPat ty) match_result
421 = returnDs (WildPat ty, match_result)
423 {- now, here we handle lazy patterns:
424 tidy1 v ~p bs = (v, v1 = case v of p -> v1 :
425 v2 = case v of p -> v2 : ... : bs )
427 where the v_i's are the binders in the pattern.
429 ToDo: in "v_i = ... -> v_i", are the v_i's really the same thing?
431 The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr
434 tidy1 v (LazyPat pat) match_result
435 = mkSelectorBinds pat (Var v) `thenDs` \ sel_binds ->
436 returnDs (WildPat (idType v),
437 mkCoLetsMatchResult [NonRec b rhs | (b,rhs) <- sel_binds] match_result)
439 -- re-express <con-something> as (ConPat ...) [directly]
441 tidy1 v (ConOpPat pat1 id pat2 ty) match_result
442 = returnDs (ConPat id ty [pat1, pat2], match_result)
444 tidy1 v (RecPat con_id pat_ty rpats) match_result
445 = returnDs (ConPat con_id pat_ty pats, match_result)
447 pats = map mk_pat tagged_arg_tys
449 -- Boring stuff to find the arg-tys of the constructor
450 (_, inst_tys, _) = splitAlgTyConApp pat_ty
451 con_arg_tys' = dataConArgTys con_id inst_tys
452 tagged_arg_tys = con_arg_tys' `zip` (dataConFieldLabels con_id)
454 -- mk_pat picks a WildPat of the appropriate type for absent fields,
455 -- and the specified pattern for present fields
456 mk_pat (arg_ty, lbl) = case [pat | (sel_id,pat,_) <- rpats,
457 recordSelectorFieldLabel sel_id == lbl
459 (pat:pats) -> ASSERT( null pats )
463 tidy1 v (ListPat ty pats) match_result
464 = returnDs (list_ConPat, match_result)
466 list_ty = mkListTy ty
468 = foldr (\ x -> \y -> ConPat consDataCon list_ty [x, y])
469 (ConPat nilDataCon list_ty [])
472 tidy1 v (TuplePat pats) match_result
473 = returnDs (tuple_ConPat, match_result)
477 = ConPat (tupleCon arity)
478 (mkTupleTy arity (map outPatType pats))
481 tidy1 v (DictPat dicts methods) match_result
482 = case num_of_d_and_ms of
483 0 -> tidy1 v (TuplePat []) match_result
484 1 -> tidy1 v (head dict_and_method_pats) match_result
485 _ -> tidy1 v (TuplePat dict_and_method_pats) match_result
487 num_of_d_and_ms = length dicts + length methods
488 dict_and_method_pats = map VarPat (dicts ++ methods)
491 -- deeply ugly mangling for some (common) NPats/LitPats
493 -- LitPats: the desugarer only sees these at well-known types
495 tidy1 v pat@(LitPat lit lit_ty) match_result
496 | isUnpointedType lit_ty
497 = returnDs (pat, match_result)
500 = returnDs (ConPat charDataCon charTy [LitPat (mk_char lit) charPrimTy],
503 | otherwise = pprPanic "tidy1:LitPat:" (ppr pat)
505 mk_char (HsChar c) = HsCharPrim c
507 -- NPats: we *might* be able to replace these w/ a simpler form
510 tidy1 v pat@(NPat lit lit_ty _) match_result
511 = returnDs (better_pat, match_result)
514 | lit_ty == charTy = ConPat charDataCon lit_ty [LitPat (mk_char lit) charPrimTy]
515 | lit_ty == intTy = ConPat intDataCon lit_ty [LitPat (mk_int lit) intPrimTy]
516 | lit_ty == wordTy = ConPat wordDataCon lit_ty [LitPat (mk_word lit) wordPrimTy]
517 | lit_ty == addrTy = ConPat addrDataCon lit_ty [LitPat (mk_addr lit) addrPrimTy]
518 | lit_ty == floatTy = ConPat floatDataCon lit_ty [LitPat (mk_float lit) floatPrimTy]
519 | lit_ty == doubleTy = ConPat doubleDataCon lit_ty [LitPat (mk_double lit) doublePrimTy]
521 -- Convert the literal pattern "" to the constructor pattern [].
522 | null_str_lit lit = ConPat nilDataCon lit_ty []
526 mk_int (HsInt i) = HsIntPrim i
527 mk_int l@(HsLitLit s) = l
529 mk_char (HsChar c) = HsCharPrim c
530 mk_char l@(HsLitLit s) = l
532 mk_word l@(HsLitLit s) = l
534 mk_addr l@(HsLitLit s) = l
536 mk_float (HsInt i) = HsFloatPrim (fromInteger i)
537 mk_float (HsFrac f) = HsFloatPrim f
538 mk_float l@(HsLitLit s) = l
540 mk_double (HsInt i) = HsDoublePrim (fromInteger i)
541 mk_double (HsFrac f) = HsDoublePrim f
542 mk_double l@(HsLitLit s) = l
544 null_str_lit (HsString s) = _NULL_ s
545 null_str_lit other_lit = False
547 -- and everything else goes through unchanged...
549 tidy1 v non_interesting_pat match_result
550 = returnDs (non_interesting_pat, match_result)
553 PREVIOUS matchTwiddled STUFF:
555 Now we get to the only interesting part; note: there are choices for
556 translation [from Simon's notes]; translation~1:
563 s = case w of [s,t] -> s
564 t = case w of [s,t] -> t
568 Here \tr{w} is a fresh variable, and the \tr{w}-binding prevents multiple
569 evaluation of \tr{e}. An alternative translation (No.~2):
571 [ w = case e of [s,t] -> (s,t)
572 s = case w of (s,t) -> s
573 t = case w of (s,t) -> t
577 %************************************************************************
579 \subsubsection[improved-unmixing]{UNIMPLEMENTED idea for improved unmixing}
581 %************************************************************************
583 We might be able to optimise unmixing when confronted by
584 only-one-constructor-possible, of which tuples are the most notable
592 This definition would normally be unmixed into four equation blocks,
593 one per equation. But it could be unmixed into just one equation
594 block, because if the one equation matches (on the first column),
595 the others certainly will.
597 You have to be careful, though; the example
605 {\em must} be broken into two blocks at the line shown; otherwise, you
606 are forcing unnecessary evaluation. In any case, the top-left pattern
607 always gives the cue. You could then unmix blocks into groups of...
609 \item[all variables:]
611 \item[constructors or variables (mixed):]
612 Need to make sure the right names get bound for the variable patterns.
613 \item[literals or variables (mixed):]
614 Presumably just a variant on the constructor case (as it is now).
617 %************************************************************************
619 %* match on an unmixed block: the real business *
621 %************************************************************************
622 \subsection[matchUnmixedEqns]{@matchUnmixedEqns@: getting down to business}
624 The function @matchUnmixedEqns@ is where the matching stuff sets to
625 work a block of equations, to which the mixture rule has been applied.
626 Its arguments and results are the same as for the ``top-level'' @match@.
629 matchUnmixedEqns :: [Id]
633 matchUnmixedEqns [] _ = panic "matchUnmixedEqns: no names"
635 matchUnmixedEqns all_vars@(var:vars) eqns_info
636 | irrefutablePat first_pat
637 = ASSERT( irrefutablePats column_1_pats ) -- Sanity check
638 -- Real true variables, just like in matchVar, SLPJ p 94
639 match vars remaining_eqns_info
642 = ASSERT( patsAreAllCons column_1_pats )
643 matchConFamily all_vars eqns_info
646 = ASSERT( patsAreAllLits column_1_pats )
647 -- see notes in MatchLiteral
648 -- not worried about the same literal more than once in a column
649 -- (ToDo: sort this out later)
650 matchLiterals all_vars eqns_info
653 first_pat = head column_1_pats
654 column_1_pats = [pat | EqnInfo _ _ (pat:_) _ <- eqns_info]
655 remaining_eqns_info = [EqnInfo n ctx pats match_result | EqnInfo n ctx (_:pats) match_result <- eqns_info]
658 %************************************************************************
660 %* matchWrapper: a convenient way to call @match@ *
662 %************************************************************************
663 \subsection[matchWrapper]{@matchWrapper@: a convenient interface to @match@}
665 Calls to @match@ often involve similar (non-trivial) work; that work
666 is collected here, in @matchWrapper@. This function takes as
670 Typchecked @Matches@ (of a function definition, or a case or lambda
671 expression)---the main input;
673 An error message to be inserted into any (runtime) pattern-matching
677 As results, @matchWrapper@ produces:
680 A list of variables (@Locals@) that the caller must ``promise'' to
681 bind to appropriate values; and
683 a @CoreExpr@, the desugared output (main result).
686 The main actions of @matchWrapper@ include:
689 Flatten the @[TypecheckedMatch]@ into a suitable list of
692 Create as many new variables as there are patterns in a pattern-list
693 (in any one of the @EquationInfo@s).
695 Create a suitable ``if it fails'' expression---a call to @error@ using
696 the error-string input; the {\em type} of this fail value can be found
697 by examining one of the RHS expressions in one of the @EquationInfo@s.
699 Call @match@ with all of this information!
703 matchWrapper :: DsMatchKind -- For shadowing warning messages
704 -> [TypecheckedMatch] -- Matches being desugared
705 -> String -- Error message if the match fails
706 -> DsM ([Id], CoreExpr) -- Results
709 a special case for the common ...:
711 lots of (all?) unfailable pats
715 This special case have been ``undone'' due to problems with the new warnings
716 messages (Check.lhs.check). We need there the name of the variables to be able to
717 print later the equation. JJQC 30-11-97
720 matchWrapper kind [(PatMatch (VarPat var) match)] error_string
721 = matchWrapper kind [match] error_string `thenDs` \ (vars, core_expr) ->
722 returnDs (var:vars, core_expr)
724 matchWrapper kind [(PatMatch (WildPat ty) match)] error_string
725 = newSysLocalDs ty `thenDs` \ var ->
726 matchWrapper kind [match] error_string `thenDs` \ (vars, core_expr) ->
727 returnDs (var:vars, core_expr)
729 matchWrapper kind [(GRHSMatch
730 (GRHSsAndBindsOut [GRHS [] expr _] binds _))] error_string
731 = dsBinds False{-don't auto-scc-} binds `thenDs` \ core_binds ->
732 dsExpr expr `thenDs` \ core_expr ->
733 returnDs ([], mkCoLetsAny core_binds core_expr)
736 And all the rest... (general case)
739 There is one small problem with the Lambda Patterns, when somebody
740 writes something similar to:
742 he/she don't want a warning about incomplete patterns, that is done with
743 the flag opt_WarnSimplePatterns.
744 This problem also appears in the :
745 do patterns, but if the do can fail it creates another equation if the match can
746 fail (see DsExpr.doDo function)
747 let patterns, are treated by matchSimply
748 List Comprension Patterns, are treated by matchSimply also
750 We can't call matchSimply with Lambda patterns, due to lambda patterns can have more than
751 one pattern, and match simply only accepts one pattern.
757 matchWrapper kind matches error_string
758 = flattenMatches kind 1 matches `thenDs` \ eqns_info@(EqnInfo _ _ arg_pats (MatchResult _ result_ty _) : _) ->
760 selectMatchVars arg_pats `thenDs` \ new_vars ->
761 match_fun new_vars eqns_info `thenDs` \ match_result ->
763 mkErrorAppDs pAT_ERROR_ID result_ty error_string `thenDs` \ fail_expr ->
765 extractMatchResult match_result fail_expr `thenDs` \ result_expr ->
766 returnDs (new_vars, result_expr)
767 where match_fun = case kind of
768 LambdaMatch | opt_WarnSimplePatterns -> matchExport
773 %************************************************************************
775 \subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern}
777 %************************************************************************
779 @mkSimpleMatch@ is a wrapper for @match@ which deals with the
780 situation where we want to match a single expression against a single
781 pattern. It returns an expression.
784 matchSimply :: CoreExpr -- Scrutinee
785 -> DsMatchKind -- Match kind
786 -> TypecheckedPat -- Pattern it should match
787 -> Type -- Type of result
788 -> CoreExpr -- Return this if it matches
789 -> CoreExpr -- Return this if it does
792 matchSimply (Var var) kind pat result_ty result_expr fail_expr
793 = getSrcLocDs `thenDs` \ locn ->
795 ctx = DsMatchContext kind [pat] locn
796 eqn_info = EqnInfo 1 ctx [pat] initial_match_result
798 match_fun [var] [eqn_info] `thenDs` \ match_result ->
799 extractMatchResult match_result fail_expr
801 initial_match_result = MatchResult CantFail result_ty (\ ignore -> result_expr)
802 match_fun = if opt_WarnSimplePatterns
806 matchSimply scrut_expr kind pat result_ty result_expr msg
807 = newSysLocalDs (outPatType pat) `thenDs` \ scrut_var ->
808 matchSimply (Var scrut_var) kind pat result_ty result_expr msg `thenDs` \ expr ->
809 returnDs (Let (NonRec scrut_var scrut_expr) expr)
812 extractMatchResult (MatchResult CantFail _ match_fn) fail_expr
813 = returnDs (match_fn (error "It can't fail!"))
815 extractMatchResult (MatchResult CanFail result_ty match_fn) fail_expr
816 = mkFailurePair result_ty `thenDs` \ (fail_bind_fn, if_it_fails) ->
817 returnDs (Let (fail_bind_fn fail_expr) (match_fn if_it_fails))
820 %************************************************************************
822 %* flattenMatches : create a list of EquationInfo *
824 %************************************************************************
825 \subsection[flattenMatches]{@flattenMatches@: create @[EquationInfo]@}
827 This is actually local to @matchWrapper@.
833 -> [TypecheckedMatch]
834 -> DsM [EquationInfo]
836 flattenMatches kind n [] = returnDs []
838 flattenMatches kind n (match : matches)
839 = flatten_match [] n match `thenDs` \ eqn_info ->
840 flattenMatches kind (n+1) matches `thenDs` \ eqn_infos ->
841 returnDs (eqn_info : eqn_infos)
843 flatten_match :: [TypecheckedPat] -- Reversed list of patterns encountered so far
848 flatten_match pats_so_far n (PatMatch pat match)
849 = flatten_match (pat:pats_so_far) n match
851 flatten_match pats_so_far n (GRHSMatch (GRHSsAndBindsOut grhss binds ty))
852 = dsBinds False{-don't auto-scc-} binds `thenDs` \ core_binds ->
853 dsGRHSs ty kind pats grhss `thenDs` \ match_result ->
854 getSrcLocDs `thenDs` \ locn ->
855 returnDs (EqnInfo n (DsMatchContext kind pats locn) pats
856 (mkCoLetsMatchResult core_binds match_result))
858 pats = reverse pats_so_far -- They've accumulated in reverse order
860 flatten_match pats_so_far n (SimpleMatch expr)
861 = dsExpr expr `thenDs` \ core_expr ->
862 getSrcLocDs `thenDs` \ locn ->
863 returnDs (EqnInfo n (DsMatchContext kind pats locn) pats
864 (MatchResult CantFail (coreExprType core_expr)
865 (\ ignore -> core_expr)))
867 -- the matching can't fail, so we won't generate an error message.
869 pats = reverse pats_so_far -- They've accumulated in reverse order