3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
5 \section[Main_match]{The @match@ function}
8 #include "HsVersions.h"
10 module Match ( matchExport, match, matchWrapper, matchSimply ) where
13 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
14 IMPORT_DELOOPER(DsLoop) -- here for paranoia-checking reasons
15 -- and to break dsExpr/dsBinds-ish loop
17 import {-# SOURCE #-} DsExpr ( dsExpr )
18 import {-# SOURCE #-} DsBinds ( dsBinds )
21 import CmdLineOpts ( opt_WarnIncompletePatterns, opt_WarnOverlappingPatterns,
22 opt_PprUserLength,opt_WarnSimplePatterns
25 import TcHsSyn ( SYN_IE(TypecheckedPat), SYN_IE(TypecheckedMatch),
26 SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr) )
27 import DsHsSyn ( outPatType, collectTypedPatBinders )
28 import Check ( check, SYN_IE(ExhaustivePat), SYN_IE(WarningPat), BoxedString )
30 import CoreUtils ( coreExprType )
32 import DsGRHSs ( dsGRHSs )
34 import ErrUtils ( SYN_IE(Warning) )
35 import FieldLabel ( FieldLabel {- Eq instance -} )
36 import Id ( idType, dataConFieldLabels,
37 dataConArgTys, recordSelectorFieldLabel,
38 GenId{-instance-}, SYN_IE(Id)
40 import MatchCon ( matchConFamily )
41 import MatchLit ( matchLiterals )
42 import Name ( Name {--O only-} )
43 import Outputable ( PprStyle(..), Outputable(..), pprQuote )
44 import PprType ( GenType{-instance-}, GenTyVar{-ditto-} )
46 import PrelVals ( pAT_ERROR_ID )
47 import SrcLoc ( noSrcLoc, SrcLoc )
48 import Type ( isPrimType, eqTy, getAppDataTyConExpandingDicts,
49 instantiateTauTy, SYN_IE(Type)
51 import TyVar ( GenTyVar{-instance Eq-}, SYN_IE(TyVar) )
52 import TysPrim ( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy,
53 addrPrimTy, wordPrimTy
55 import TysWiredIn ( nilDataCon, consDataCon, mkTupleTy, mkListTy,
56 charTy, charDataCon, intTy, intDataCon,
57 floatTy, floatDataCon, doubleTy, tupleCon,
58 doubleDataCon, stringTy, addrTy,
59 addrDataCon, wordTy, wordDataCon
61 import Unique ( Unique{-instance Eq-} )
63 import Util ( panic, pprPanic, assertPanic )
66 This function is a wrapper of @match@, it must be called from all the parts where
67 it was called match, but only substitutes the firs call, ....
68 if the associated flags are declared, warnings will be issued.
69 It can not be called matchWrapper because this name already exists :-(
74 matchExport :: [Id] -- Vars rep'ing the exprs we're matching with
75 -> [EquationInfo] -- Info about patterns, etc. (type synonym below)
76 -> DsM MatchResult -- Desugared result!
78 matchExport vars qs@((EqnInfo _ ctx _ (MatchResult _ _ _)) : _)
79 | incomplete && shadow =
80 dsShadowWarn ctx eqns_shadow `thenDs` \ () ->
81 dsIncompleteWarn ctx pats `thenDs` \ () ->
84 dsIncompleteWarn ctx pats `thenDs` \ () ->
87 dsShadowWarn ctx eqns_shadow `thenDs` \ () ->
91 where (pats,indexs) = check qs
92 incomplete = opt_WarnIncompletePatterns && (length pats /= 0)
93 shadow = opt_WarnOverlappingPatterns && sizeUniqSet indexs < no_eqns
95 unused_eqns = uniqSetToList (mkUniqSet [1..no_eqns] `minusUniqSet` indexs)
96 eqns_shadow = map (\n -> qs!!(n - 1)) unused_eqns
99 This variable shows the maximun number of lines of output generated for warnings.
100 It will limit the number of patterns/equations displayed to maximum_output.
102 (ToDo: add command-line option?)
108 The next two functions creates the warning message.
111 dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM ()
112 dsShadowWarn ctx@(DsMatchContext kind _ _) qs = dsWarn warn
114 warn sty | length qs > maximum_output =
115 hang (pp_context sty ctx (ptext SLIT("are overlapped")))
116 12 ((vcat $ map (ppr_eqn kind sty) (take maximum_output qs))
117 $$ ptext SLIT("..."))
119 hang (pp_context sty ctx (ptext SLIT("are overlapped")))
120 12 (vcat $ map (ppr_eqn kind sty) qs)
122 dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM ()
123 dsIncompleteWarn ctx@(DsMatchContext kind _ _) pats = dsWarn warn
125 warn sty | length pats > maximum_output =
126 hang (pp_context sty ctx (ptext SLIT("are non-exhaustive")))
127 12 (hang (ptext SLIT("Patterns not recognized:"))
128 4 ((vcat $ map (ppr_incomplete_pats kind sty) (take maximum_output pats))
129 $$ ptext SLIT("...")))
131 hang (pp_context sty ctx (ptext SLIT("are non-exhaustive")))
132 12 (hang (ptext SLIT("Patterns not recognized:"))
133 4 (vcat $ map (ppr_incomplete_pats kind sty) pats))
135 pp_context sty NoMatchContext msg = ptext SLIT("Warning: Some match(es)") <+> msg
137 pp_context sty (DsMatchContext kind pats loc) msg
138 = hang (hcat [ppr (PprForUser opt_PprUserLength) loc, ptext SLIT(": ")])
140 4 (pp_match kind pats))
142 message = ptext SLIT("Warning: Pattern match(es)") <+> msg
144 pp_match (FunMatch fun) pats
145 = hsep [ptext SLIT("in the definition of function"), ppr sty fun]
147 pp_match CaseMatch pats
148 = hang (ptext SLIT("in a group of case alternatives beginning:"))
149 4 (ppr_pats sty pats)
151 pp_match PatBindMatch pats
152 = hang (ptext SLIT("in a pattern binding:"))
153 4 (ppr_pats sty pats)
155 pp_match LambdaMatch pats
156 = hang (ptext SLIT("in a lambda abstraction:"))
157 4 (ppr_pats sty pats)
159 pp_match DoBindMatch pats
160 = hang (ptext SLIT("in a `do' pattern binding:"))
161 4 (ppr_pats sty pats)
163 pp_match ListCompMatch pats
164 = hang (ptext SLIT("in a `list comprension' pattern binding:"))
165 4 (ppr_pats sty pats)
167 pp_match LetMatch pats
168 = hang (ptext SLIT("in a `let' pattern binding:"))
169 4 (ppr_pats sty pats)
171 ppr_pats sty pats = pprQuote sty $ \ sty -> sep (map (ppr sty) pats)
173 separator (FunMatch _) = SLIT("=")
174 separator (CaseMatch) = SLIT("->")
175 separator (LambdaMatch) = SLIT("->")
176 separator (PatBindMatch) = panic "When is this used?"
177 separator (DoBindMatch) = SLIT("<-")
178 separator (ListCompMatch) = SLIT("<-")
179 separator (LetMatch) = SLIT("=")
181 ppr_shadow_pats kind sty pats = pprQuote sty $ \ sty ->
182 sep [sep (map (ppr sty) pats), ptext (separator kind), ptext SLIT("...")]
184 ppr_incomplete_pats kind sty (pats,[]) = pprQuote sty $ \ sty ->
185 sep [sep (map (ppr sty) pats)]
186 ppr_incomplete_pats kind sty (pats,constraints) = pprQuote sty $ \ sty ->
187 sep [sep (map (ppr sty) pats), ptext SLIT("with"),
188 sep (map (ppr_constraint sty) constraints)]
191 ppr_constraint sty (var,pats) = sep [ppr sty var, ptext SLIT("`not_elem`"),ppr sty pats]
193 ppr_eqn kind sty (EqnInfo _ _ pats _) = ppr_shadow_pats kind sty pats
198 The function @match@ is basically the same as in the Wadler chapter,
199 except it is monadised, to carry around the name supply, info about
202 Notes on @match@'s arguments, assuming $m$ equations and $n$ patterns:
205 A list of $n$ variable names, those variables presumably bound to the
206 $n$ expressions being matched against the $n$ patterns. Using the
207 list of $n$ expressions as the first argument showed no benefit and
211 The second argument, a list giving the ``equation info'' for each of
215 the $n$ patterns for that equation, and
217 a list of Core bindings [@(Id, CoreExpr)@ pairs] to be ``stuck on
218 the front'' of the matching code, as in:
224 and finally: (ToDo: fill in)
226 The right way to think about the ``after-match function'' is that it
227 is an embryonic @CoreExpr@ with a ``hole'' at the end for the
228 final ``else expression''.
231 There is a type synonym, @EquationInfo@, defined in module @DsUtils@.
233 An experiment with re-ordering this information about equations (in
234 particular, having the patterns available in column-major order)
238 A default expression---what to evaluate if the overall pattern-match
239 fails. This expression will (almost?) always be
240 a measly expression @Var@, unless we know it will only be used once
241 (as we do in @glue_success_exprs@).
243 Leaving out this third argument to @match@ (and slamming in lots of
244 @Var "fail"@s) is a positively {\em bad} idea, because it makes it
245 impossible to share the default expressions. (Also, it stands no
246 chance of working in our post-upheaval world of @Locals@.)
248 So, the full type signature:
250 match :: [Id] -- Variables rep'ing the exprs we're matching with
251 -> [EquationInfo] -- Info about patterns, etc. (type synonym below)
252 -> DsM MatchResult -- Desugared result!
255 Note: @match@ is often called via @matchWrapper@ (end of this module),
256 a function that does much of the house-keeping that goes with a call
259 It is also worth mentioning the {\em typical} way a block of equations
260 is desugared with @match@. At each stage, it is the first column of
261 patterns that is examined. The steps carried out are roughly:
264 Tidy the patterns in column~1 with @tidyEqnInfo@ (this may add
265 bindings to the second component of the equation-info):
268 Remove the `as' patterns from column~1.
270 Make all constructor patterns in column~1 into @ConPats@, notably
271 @ListPats@ and @TuplePats@.
273 Handle any irrefutable (or ``twiddle'') @LazyPats@.
276 Now {\em unmix} the equations into {\em blocks} [w/ local function
277 @unmix_eqns@], in which the equations in a block all have variable
278 patterns in column~1, or they all have constructor patterns in ...
279 (see ``the mixture rule'' in SLPJ).
281 Call @matchUnmixedEqns@ on each block of equations; it will do the
282 appropriate thing for each kind of column-1 pattern, usually ending up
283 in a recursive call to @match@.
286 %************************************************************************
288 %* match: empty rule *
290 %************************************************************************
291 \subsection[Match-empty-rule]{The ``empty rule''}
293 We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87)
294 than the Wadler-chapter code for @match@ (p.~93, first @match@ clause).
295 And gluing the ``success expressions'' together isn't quite so pretty.
299 = complete_matches eqns_info
301 complete_matches [eqn]
304 complete_matches (eqn:eqns)
305 = complete_match eqn `thenDs` \ match_result1 ->
306 complete_matches eqns `thenDs` \ match_result2 ->
307 combineMatchResults match_result1 match_result2
309 complete_match (EqnInfo _ _ [] match_result@(MatchResult _ _ _))
310 = returnDs match_result
313 %************************************************************************
315 %* match: non-empty rule *
317 %************************************************************************
318 \subsection[Match-nonempty]{@match@ when non-empty: unmixing}
320 This (more interesting) clause of @match@ uses @tidy_and_unmix_eqns@
321 (a)~to get `as'- and `twiddle'-patterns out of the way (tidying), and
322 (b)~to do ``the mixture rule'' (SLPJ, p.~88) [which really {\em
323 un}mixes the equations], producing a list of equation-info
324 blocks, each block having as its first column of patterns either all
325 constructors, or all variables (or similar beasts), etc.
327 @match_unmixed_eqn_blks@ simply takes the place of the @foldr@ in the
328 Wadler-chapter @match@ (p.~93, last clause), and @match_unmixed_blk@
329 corresponds roughly to @matchVarCon@.
332 match vars@(v:vs) eqns_info
333 = mapDs (tidyEqnInfo v) eqns_info `thenDs` \ tidy_eqns_info ->
335 tidy_eqns_blks = unmix_eqns tidy_eqns_info
337 match_unmixed_eqn_blks vars tidy_eqns_blks
340 unmix_eqns [eqn] = [ [eqn] ]
341 unmix_eqns (eq1@(EqnInfo _ _ (p1:p1s) _) : eq2@(EqnInfo _ _ (p2:p2s) _) : eqs)
342 = if ( (irrefutablePat p1 && irrefutablePat p2)
343 || (isConPat p1 && isConPat p2)
344 || (isLitPat p1 && isLitPat p2) ) then
345 eq1 `tack_onto` unmixed_rest
347 [ eq1 ] : unmixed_rest
349 unmixed_rest = unmix_eqns (eq2:eqs)
351 x `tack_onto` xss = ( x : head xss) : tail xss
353 -----------------------------------------------------------------------
354 -- loop through the blocks:
355 -- subsequent blocks create a "fail expr" for the first one...
356 match_unmixed_eqn_blks :: [Id]
357 -> [ [EquationInfo] ] -- List of eqn BLOCKS
360 match_unmixed_eqn_blks vars [] = panic "match_unmixed_eqn_blks"
362 match_unmixed_eqn_blks vars [eqn_blk] = matchUnmixedEqns vars eqn_blk
364 match_unmixed_eqn_blks vars (eqn_blk:eqn_blks)
365 = matchUnmixedEqns vars eqn_blk `thenDs` \ match_result1 -> -- try to match with first blk
366 match_unmixed_eqn_blks vars eqn_blks `thenDs` \ match_result2 ->
367 combineMatchResults match_result1 match_result2
370 Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@
371 which will be scrutinised. This means:
374 Replace variable patterns @x@ (@x /= v@) with the pattern @_@,
375 together with the binding @x = v@.
377 Replace the `as' pattern @x@@p@ with the pattern p and a binding @x = v@.
379 Removing lazy (irrefutable) patterns (you don't want to know...).
381 Converting explicit tuple- and list-pats into ordinary @ConPats@.
383 Convert the literal pat "" to [].
386 The result of this tidying is that the column of patterns will include
390 The @VarPat@ information isn't needed any more after this.
393 @ListPats@, @TuplePats@, etc., are all converted into @ConPats@.
395 \item[@LitPats@ and @NPats@:]
396 @LitPats@/@NPats@ of ``known friendly types'' (Int, Char,
397 Float, Double, at least) are converted to unboxed form; e.g.,
398 \tr{(NPat (HsInt i) _ _)} is converted to:
400 (ConPat I# _ _ [LitPat (HsIntPrim i) _])
405 tidyEqnInfo :: Id -> EquationInfo -> DsM EquationInfo
406 -- DsM'd because of internal call to "match".
407 -- "tidy1" does the interesting stuff, looking at
408 -- one pattern and fiddling the list of bindings.
409 tidyEqnInfo v (EqnInfo n ctx (pat : pats) match_result)
410 = tidy1 v pat match_result `thenDs` \ (pat', match_result') ->
411 returnDs (EqnInfo n ctx (pat' : pats) match_result')
413 tidy1 :: Id -- The Id being scrutinised
414 -> TypecheckedPat -- The pattern against which it is to be matched
415 -> MatchResult -- Current thing do do after matching
416 -> DsM (TypecheckedPat, -- Equivalent pattern
417 MatchResult) -- Augmented thing to do afterwards
418 -- The augmentation usually takes the form
419 -- of new bindings to be added to the front
421 tidy1 v (VarPat var) match_result
422 = returnDs (WildPat (idType var),
423 mkCoLetsMatchResult extra_binds match_result)
425 extra_binds | v == var = []
426 | otherwise = [NonRec var (Var v)]
428 tidy1 v (AsPat var pat) match_result
429 = tidy1 v pat (mkCoLetsMatchResult extra_binds match_result)
431 extra_binds | v == var = []
432 | otherwise = [NonRec var (Var v)]
434 tidy1 v (WildPat ty) match_result
435 = returnDs (WildPat ty, match_result)
437 {- now, here we handle lazy patterns:
438 tidy1 v ~p bs = (v, v1 = case v of p -> v1 :
439 v2 = case v of p -> v2 : ... : bs )
441 where the v_i's are the binders in the pattern.
443 ToDo: in "v_i = ... -> v_i", are the v_i's really the same thing?
445 The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr
448 tidy1 v (LazyPat pat) match_result
449 = mkSelectorBinds pat (Var v) `thenDs` \ sel_binds ->
450 returnDs (WildPat (idType v),
451 mkCoLetsMatchResult [NonRec b rhs | (b,rhs) <- sel_binds] match_result)
453 -- re-express <con-something> as (ConPat ...) [directly]
455 tidy1 v (ConOpPat pat1 id pat2 ty) match_result
456 = returnDs (ConPat id ty [pat1, pat2], match_result)
458 tidy1 v (RecPat con_id pat_ty rpats) match_result
459 = returnDs (ConPat con_id pat_ty pats, match_result)
461 pats = map mk_pat tagged_arg_tys
463 -- Boring stuff to find the arg-tys of the constructor
464 (_, inst_tys, _) = getAppDataTyConExpandingDicts pat_ty
465 con_arg_tys' = dataConArgTys con_id inst_tys
466 tagged_arg_tys = con_arg_tys' `zip` (dataConFieldLabels con_id)
468 -- mk_pat picks a WildPat of the appropriate type for absent fields,
469 -- and the specified pattern for present fields
470 mk_pat (arg_ty, lbl) = case [pat | (sel_id,pat,_) <- rpats,
471 recordSelectorFieldLabel sel_id == lbl
473 (pat:pats) -> ASSERT( null pats )
477 tidy1 v (ListPat ty pats) match_result
478 = returnDs (list_ConPat, match_result)
480 list_ty = mkListTy ty
482 = foldr (\ x -> \y -> ConPat consDataCon list_ty [x, y])
483 (ConPat nilDataCon list_ty [])
486 tidy1 v (TuplePat pats) match_result
487 = returnDs (tuple_ConPat, match_result)
491 = ConPat (tupleCon arity)
492 (mkTupleTy arity (map outPatType pats))
495 tidy1 v (DictPat dicts methods) match_result
496 = case num_of_d_and_ms of
497 0 -> tidy1 v (TuplePat []) match_result
498 1 -> tidy1 v (head dict_and_method_pats) match_result
499 _ -> tidy1 v (TuplePat dict_and_method_pats) match_result
501 num_of_d_and_ms = length dicts + length methods
502 dict_and_method_pats = map VarPat (dicts ++ methods)
505 -- deeply ugly mangling for some (common) NPats/LitPats
507 -- LitPats: the desugarer only sees these at well-known types
509 tidy1 v pat@(LitPat lit lit_ty) match_result
511 = returnDs (pat, match_result)
513 | lit_ty `eqTy` charTy
514 = returnDs (ConPat charDataCon charTy [LitPat (mk_char lit) charPrimTy],
517 | otherwise = pprPanic "tidy1:LitPat:" (ppr PprDebug pat)
519 mk_char (HsChar c) = HsCharPrim c
521 -- NPats: we *might* be able to replace these w/ a simpler form
524 tidy1 v pat@(NPat lit lit_ty _) match_result
525 = returnDs (better_pat, match_result)
528 | lit_ty `eqTy` charTy = ConPat charDataCon lit_ty [LitPat (mk_char lit) charPrimTy]
529 | lit_ty `eqTy` intTy = ConPat intDataCon lit_ty [LitPat (mk_int lit) intPrimTy]
530 | lit_ty `eqTy` wordTy = ConPat wordDataCon lit_ty [LitPat (mk_word lit) wordPrimTy]
531 | lit_ty `eqTy` addrTy = ConPat addrDataCon lit_ty [LitPat (mk_addr lit) addrPrimTy]
532 | lit_ty `eqTy` floatTy = ConPat floatDataCon lit_ty [LitPat (mk_float lit) floatPrimTy]
533 | lit_ty `eqTy` doubleTy = ConPat doubleDataCon lit_ty [LitPat (mk_double lit) doublePrimTy]
535 -- Convert the literal pattern "" to the constructor pattern [].
536 | null_str_lit lit = ConPat nilDataCon lit_ty []
540 mk_int (HsInt i) = HsIntPrim i
541 mk_int l@(HsLitLit s) = l
543 mk_char (HsChar c) = HsCharPrim c
544 mk_char l@(HsLitLit s) = l
546 mk_word l@(HsLitLit s) = l
548 mk_addr l@(HsLitLit s) = l
550 mk_float (HsInt i) = HsFloatPrim (fromInteger i)
551 mk_float (HsFrac f) = HsFloatPrim f
552 mk_float l@(HsLitLit s) = l
554 mk_double (HsInt i) = HsDoublePrim (fromInteger i)
555 mk_double (HsFrac f) = HsDoublePrim f
556 mk_double l@(HsLitLit s) = l
558 null_str_lit (HsString s) = _NULL_ s
559 null_str_lit other_lit = False
561 -- and everything else goes through unchanged...
563 tidy1 v non_interesting_pat match_result
564 = returnDs (non_interesting_pat, match_result)
567 PREVIOUS matchTwiddled STUFF:
569 Now we get to the only interesting part; note: there are choices for
570 translation [from Simon's notes]; translation~1:
577 s = case w of [s,t] -> s
578 t = case w of [s,t] -> t
582 Here \tr{w} is a fresh variable, and the \tr{w}-binding prevents multiple
583 evaluation of \tr{e}. An alternative translation (No.~2):
585 [ w = case e of [s,t] -> (s,t)
586 s = case w of (s,t) -> s
587 t = case w of (s,t) -> t
591 %************************************************************************
593 \subsubsection[improved-unmixing]{UNIMPLEMENTED idea for improved unmixing}
595 %************************************************************************
597 We might be able to optimise unmixing when confronted by
598 only-one-constructor-possible, of which tuples are the most notable
606 This definition would normally be unmixed into four equation blocks,
607 one per equation. But it could be unmixed into just one equation
608 block, because if the one equation matches (on the first column),
609 the others certainly will.
611 You have to be careful, though; the example
619 {\em must} be broken into two blocks at the line shown; otherwise, you
620 are forcing unnecessary evaluation. In any case, the top-left pattern
621 always gives the cue. You could then unmix blocks into groups of...
623 \item[all variables:]
625 \item[constructors or variables (mixed):]
626 Need to make sure the right names get bound for the variable patterns.
627 \item[literals or variables (mixed):]
628 Presumably just a variant on the constructor case (as it is now).
631 %************************************************************************
633 %* match on an unmixed block: the real business *
635 %************************************************************************
636 \subsection[matchUnmixedEqns]{@matchUnmixedEqns@: getting down to business}
638 The function @matchUnmixedEqns@ is where the matching stuff sets to
639 work a block of equations, to which the mixture rule has been applied.
640 Its arguments and results are the same as for the ``top-level'' @match@.
643 matchUnmixedEqns :: [Id]
647 matchUnmixedEqns [] _ = panic "matchUnmixedEqns: no names"
649 matchUnmixedEqns all_vars@(var:vars) eqns_info
650 | irrefutablePat first_pat
651 = ASSERT( irrefutablePats column_1_pats ) -- Sanity check
652 -- Real true variables, just like in matchVar, SLPJ p 94
653 match vars remaining_eqns_info
656 = ASSERT( patsAreAllCons column_1_pats )
657 matchConFamily all_vars eqns_info
660 = ASSERT( patsAreAllLits column_1_pats )
661 -- see notes in MatchLiteral
662 -- not worried about the same literal more than once in a column
663 -- (ToDo: sort this out later)
664 matchLiterals all_vars eqns_info
667 first_pat = head column_1_pats
668 column_1_pats = [pat | EqnInfo _ _ (pat:_) _ <- eqns_info]
669 remaining_eqns_info = [EqnInfo n ctx pats match_result | EqnInfo n ctx (_:pats) match_result <- eqns_info]
672 %************************************************************************
674 %* matchWrapper: a convenient way to call @match@ *
676 %************************************************************************
677 \subsection[matchWrapper]{@matchWrapper@: a convenient interface to @match@}
679 Calls to @match@ often involve similar (non-trivial) work; that work
680 is collected here, in @matchWrapper@. This function takes as
684 Typchecked @Matches@ (of a function definition, or a case or lambda
685 expression)---the main input;
687 An error message to be inserted into any (runtime) pattern-matching
691 As results, @matchWrapper@ produces:
694 A list of variables (@Locals@) that the caller must ``promise'' to
695 bind to appropriate values; and
697 a @CoreExpr@, the desugared output (main result).
700 The main actions of @matchWrapper@ include:
703 Flatten the @[TypecheckedMatch]@ into a suitable list of
706 Create as many new variables as there are patterns in a pattern-list
707 (in any one of the @EquationInfo@s).
709 Create a suitable ``if it fails'' expression---a call to @error@ using
710 the error-string input; the {\em type} of this fail value can be found
711 by examining one of the RHS expressions in one of the @EquationInfo@s.
713 Call @match@ with all of this information!
717 matchWrapper :: DsMatchKind -- For shadowing warning messages
718 -> [TypecheckedMatch] -- Matches being desugared
719 -> String -- Error message if the match fails
720 -> DsM ([Id], CoreExpr) -- Results
723 a special case for the common ...:
725 lots of (all?) unfailable pats
729 This special case have been ``undone'' due to problems with the new warnings
730 messages (Check.lhs.check). We need there the name of the variables to be able to
731 print later the equation. JJQC 30-11-97
734 matchWrapper kind [(PatMatch (VarPat var) match)] error_string
735 = matchWrapper kind [match] error_string `thenDs` \ (vars, core_expr) ->
736 returnDs (var:vars, core_expr)
738 matchWrapper kind [(PatMatch (WildPat ty) match)] error_string
739 = newSysLocalDs ty `thenDs` \ var ->
740 matchWrapper kind [match] error_string `thenDs` \ (vars, core_expr) ->
741 returnDs (var:vars, core_expr)
743 matchWrapper kind [(GRHSMatch
744 (GRHSsAndBindsOut [OtherwiseGRHS expr _] binds _))] error_string
745 = dsBinds False{-don't auto-scc-} binds `thenDs` \ core_binds ->
746 dsExpr expr `thenDs` \ core_expr ->
747 returnDs ([], mkCoLetsAny core_binds core_expr)
750 And all the rest... (general case)
753 There is one small problem with the Lambda Patterns, when somebody
754 writes something similar to:
756 he/she don't want a warning about incomplete patterns, that is done with
757 the flag opt_WarnSimplePatterns.
758 This problem also appears in the :
759 do patterns, but if the do can fail it creates another equation if the match can
760 fail (see DsExpr.doDo function)
761 let patterns, are treated by matchSimply
762 List Comprension Patterns, are treated by matchSimply also
764 We can't call matchSimply with Lambda patterns, due to lambda patterns can have more than
765 one pattern, and match simply only accepts one pattern.
771 matchWrapper kind matches error_string
772 = flattenMatches kind 1 matches `thenDs` \ eqns_info@(EqnInfo _ _ arg_pats (MatchResult _ result_ty _) : _) ->
774 selectMatchVars arg_pats `thenDs` \ new_vars ->
775 match_fun new_vars eqns_info `thenDs` \ match_result ->
777 mkErrorAppDs pAT_ERROR_ID result_ty error_string `thenDs` \ fail_expr ->
779 extractMatchResult match_result fail_expr `thenDs` \ result_expr ->
780 returnDs (new_vars, result_expr)
781 where match_fun = case kind of
782 LambdaMatch | opt_WarnSimplePatterns -> matchExport
787 %************************************************************************
789 \subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern}
791 %************************************************************************
793 @mkSimpleMatch@ is a wrapper for @match@ which deals with the
794 situation where we want to match a single expression against a single
795 pattern. It returns an expression.
798 matchSimply :: CoreExpr -- Scrutinee
799 -> DsMatchKind -- Match kind
800 -> TypecheckedPat -- Pattern it should match
801 -> Type -- Type of result
802 -> CoreExpr -- Return this if it matches
803 -> CoreExpr -- Return this if it does
806 matchSimply (Var var) kind pat result_ty result_expr fail_expr
807 = getSrcLocDs `thenDs` \ locn ->
809 ctx = DsMatchContext kind [pat] locn
810 eqn_info = EqnInfo 1 ctx [pat] initial_match_result
812 match_fun [var] [eqn_info] `thenDs` \ match_result ->
813 extractMatchResult match_result fail_expr
815 initial_match_result = MatchResult CantFail result_ty (\ ignore -> result_expr)
816 match_fun = if opt_WarnSimplePatterns
820 matchSimply scrut_expr kind pat result_ty result_expr msg
821 = newSysLocalDs (outPatType pat) `thenDs` \ scrut_var ->
822 matchSimply (Var scrut_var) kind pat result_ty result_expr msg `thenDs` \ expr ->
823 returnDs (Let (NonRec scrut_var scrut_expr) expr)
826 extractMatchResult (MatchResult CantFail _ match_fn) fail_expr
827 = returnDs (match_fn (error "It can't fail!"))
829 extractMatchResult (MatchResult CanFail result_ty match_fn) fail_expr
830 = mkFailurePair result_ty `thenDs` \ (fail_bind_fn, if_it_fails) ->
831 returnDs (Let (fail_bind_fn fail_expr) (match_fn if_it_fails))
834 %************************************************************************
836 %* flattenMatches : create a list of EquationInfo *
838 %************************************************************************
839 \subsection[flattenMatches]{@flattenMatches@: create @[EquationInfo]@}
841 This is actually local to @matchWrapper@.
847 -> [TypecheckedMatch]
848 -> DsM [EquationInfo]
850 flattenMatches kind n [] = returnDs []
852 flattenMatches kind n (match : matches)
853 = flatten_match [] n match `thenDs` \ eqn_info ->
854 flattenMatches kind (n+1) matches `thenDs` \ eqn_infos ->
855 returnDs (eqn_info : eqn_infos)
857 flatten_match :: [TypecheckedPat] -- Reversed list of patterns encountered so far
862 flatten_match pats_so_far n (PatMatch pat match)
863 = flatten_match (pat:pats_so_far) n match
865 flatten_match pats_so_far n (GRHSMatch (GRHSsAndBindsOut grhss binds ty))
866 = dsBinds False{-don't auto-scc-} binds `thenDs` \ core_binds ->
867 dsGRHSs ty kind pats grhss `thenDs` \ match_result ->
868 getSrcLocDs `thenDs` \ locn ->
869 returnDs (EqnInfo n (DsMatchContext kind pats locn) pats
870 (mkCoLetsMatchResult core_binds match_result))
872 pats = reverse pats_so_far -- They've accumulated in reverse order
874 flatten_match pats_so_far n (SimpleMatch expr)
875 = dsExpr expr `thenDs` \ core_expr ->
876 getSrcLocDs `thenDs` \ locn ->
877 returnDs (EqnInfo n (DsMatchContext kind pats locn) pats
878 (MatchResult CantFail (coreExprType core_expr)
879 (\ ignore -> core_expr)))
881 -- the matching can't fail, so we won't generate an error message.
883 pats = reverse pats_so_far -- They've accumulated in reverse order