ebddac241335da5a708e12b26c06aa0f20f98d3a
[ghc-hetmet.git] / ghc / compiler / deSugar / Match.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
3 %
4 \section[Main_match]{The @match@ function}
5
6 \begin{code}
7 #include "HsVersions.h"
8
9 module Match ( match, matchWrapper, matchSimply ) where
10
11 import Ubiq
12 import DsLoop           -- here for paranoia-checking reasons
13                         -- and to break dsExpr/dsBinds-ish loop
14
15 import HsSyn            hiding ( collectBinders{-also from CoreSyn-} )
16 import TcHsSyn          ( TypecheckedPat(..), TypecheckedMatch(..),
17                           TypecheckedHsBinds(..), TypecheckedHsExpr(..) )
18 import DsHsSyn          ( outPatType, collectTypedPatBinders )
19 import CoreSyn
20
21 import CoreUtils        ( coreExprType )
22 import DsMonad
23 import DsGRHSs          ( dsGRHSs )
24 import DsUtils
25 import MatchCon         ( matchConFamily )
26 import MatchLit         ( matchLiterals )
27
28 import FieldLabel       ( allFieldLabelTags, fieldLabelTag )
29 import Id               ( idType, mkTupleCon, dataConSig,
30                           dataConArgTys, recordSelectorFieldLabel,
31                           GenId{-instance-}
32                         )
33 import PprStyle         ( PprStyle(..) )
34 import PprType          ( GenType{-instance-}, GenTyVar{-ditto-} )
35 import PrelInfo         ( nilDataCon, consDataCon, mkTupleTy, mkListTy,
36                           charTy, charDataCon, intTy, intDataCon,
37                           floatTy, floatDataCon, doubleTy, doubleDataCon,
38                           integerTy, intPrimTy, charPrimTy,
39                           floatPrimTy, doublePrimTy, stringTy,
40                           addrTy, addrPrimTy, addrDataCon,
41                           wordTy, wordPrimTy, wordDataCon,
42                           pAT_ERROR_ID
43                         )
44 import Type             ( isPrimType, eqTy, getAppDataTyConExpandingDicts,
45                           instantiateTauTy
46                         )
47 import TyVar            ( GenTyVar{-instance Eq-} )
48 import Unique           ( Unique{-instance Eq-} )
49 import Util             ( panic, pprPanic, assertPanic )
50 \end{code}
51
52 The function @match@ is basically the same as in the Wadler chapter,
53 except it is monadised, to carry around the name supply, info about
54 annotations, etc.
55
56 Notes on @match@'s arguments, assuming $m$ equations and $n$ patterns:
57 \begin{enumerate}
58 \item
59 A list of $n$ variable names, those variables presumably bound to the
60 $n$ expressions being matched against the $n$ patterns.  Using the
61 list of $n$ expressions as the first argument showed no benefit and
62 some inelegance.
63
64 \item
65 The second argument, a list giving the ``equation info'' for each of
66 the $m$ equations:
67 \begin{itemize}
68 \item
69 the $n$ patterns for that equation, and
70 \item
71 a list of Core bindings [@(Id, CoreExpr)@ pairs] to be ``stuck on
72 the front'' of the matching code, as in:
73 \begin{verbatim}
74 let <binds>
75 in  <matching-code>
76 \end{verbatim}
77 \item
78 and finally: (ToDo: fill in)
79
80 The right way to think about the ``after-match function'' is that it
81 is an embryonic @CoreExpr@ with a ``hole'' at the end for the
82 final ``else expression''.
83 \end{itemize}
84
85 There is a type synonym, @EquationInfo@, defined in module @DsUtils@.
86
87 An experiment with re-ordering this information about equations (in
88 particular, having the patterns available in column-major order)
89 showed no benefit.
90
91 \item
92 A default expression---what to evaluate if the overall pattern-match
93 fails.  This expression will (almost?) always be
94 a measly expression @Var@, unless we know it will only be used once
95 (as we do in @glue_success_exprs@).
96
97 Leaving out this third argument to @match@ (and slamming in lots of
98 @Var "fail"@s) is a positively {\em bad} idea, because it makes it
99 impossible to share the default expressions.  (Also, it stands no
100 chance of working in our post-upheaval world of @Locals@.)
101 \end{enumerate}
102 So, the full type signature:
103 \begin{code}
104 match :: [Id]             -- Variables rep'ing the exprs we're matching with
105       -> [EquationInfo]   -- Info about patterns, etc. (type synonym below)
106       -> [EquationInfo]   -- Potentially shadowing equations above this one
107       -> DsM MatchResult  -- Desugared result!
108 \end{code}
109
110 Note: @match@ is often called via @matchWrapper@ (end of this module),
111 a function that does much of the house-keeping that goes with a call
112 to @match@.
113
114 It is also worth mentioning the {\em typical} way a block of equations
115 is desugared with @match@.  At each stage, it is the first column of
116 patterns that is examined.  The steps carried out are roughly:
117 \begin{enumerate}
118 \item
119 Tidy the patterns in column~1 with @tidyEqnInfo@ (this may add
120 bindings to the second component of the equation-info):
121 \begin{itemize}
122 \item
123 Remove the `as' patterns from column~1.
124 \item
125 Make all constructor patterns in column~1 into @ConPats@, notably
126 @ListPats@ and @TuplePats@.
127 \item
128 Handle any irrefutable (or ``twiddle'') @LazyPats@.
129 \end{itemize}
130 \item
131 Now {\em unmix} the equations into {\em blocks} [w/ local function
132 @unmix_eqns@], in which the equations in a block all have variable
133 patterns in column~1, or they all have constructor patterns in ...
134 (see ``the mixture rule'' in SLPJ).
135 \item
136 Call @matchUnmixedEqns@ on each block of equations; it will do the
137 appropriate thing for each kind of column-1 pattern, usually ending up
138 in a recursive call to @match@.
139 \end{enumerate}
140
141 %************************************************************************
142 %*                                                                      *
143 %*  match: empty rule                                                   *
144 %*                                                                      *
145 %************************************************************************
146 \subsection[Match-empty-rule]{The ``empty rule''}
147
148 We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87)
149 than the Wadler-chapter code for @match@ (p.~93, first @match@ clause).
150 And gluing the ``success expressions'' together isn't quite so pretty.
151
152 \begin{code}
153 match [] eqns_info shadows
154   = pin_eqns eqns_info          `thenDs` \ match_result@(MatchResult _ _ _ cxt) ->
155
156         -- If at this stage we find that at least one of the shadowing
157         -- equations is guaranteed not to fail, then warn of an overlapping pattern
158     if not (all shadow_can_fail shadows) then
159         dsShadowError cxt       `thenDs` \ _ ->
160         returnDs match_result
161     else
162         returnDs match_result
163
164   where
165     pin_eqns [EqnInfo [] match_result] = returnDs match_result
166       -- Last eqn... can't have pats ...
167
168     pin_eqns (EqnInfo [] match_result1 : more_eqns)
169       = pin_eqns more_eqns                      `thenDs` \ match_result2 ->
170         combineMatchResults match_result1 match_result2
171
172     pin_eqns other_pat = panic "match: pin_eqns"
173
174     shadow_can_fail :: EquationInfo -> Bool
175
176     shadow_can_fail (EqnInfo [] (MatchResult CanFail  _ _ _)) = True
177     shadow_can_fail (EqnInfo [] (MatchResult CantFail _ _ _)) = False
178     shadow_can_fail other = panic "match:shadow_can_fail"
179 \end{code}
180
181 %************************************************************************
182 %*                                                                      *
183 %*  match: non-empty rule                                               *
184 %*                                                                      *
185 %************************************************************************
186 \subsection[Match-nonempty]{@match@ when non-empty: unmixing}
187
188 This (more interesting) clause of @match@ uses @tidy_and_unmix_eqns@
189 (a)~to get `as'- and `twiddle'-patterns out of the way (tidying), and
190 (b)~to do ``the mixture rule'' (SLPJ, p.~88) [which really {\em
191 un}mixes the equations], producing a list of equation-info
192 blocks, each block having as its first column of patterns either all
193 constructors, or all variables (or similar beasts), etc.
194
195 @match_unmixed_eqn_blks@ simply takes the place of the @foldr@ in the
196 Wadler-chapter @match@ (p.~93, last clause), and @match_unmixed_blk@
197 corresponds roughly to @matchVarCon@.
198
199 \begin{code}
200 match vars@(v:vs) eqns_info shadows
201   = mapDs (tidyEqnInfo v) eqns_info     `thenDs` \ tidy_eqns_info ->
202     mapDs (tidyEqnInfo v) shadows       `thenDs` \ tidy_shadows ->
203     let
204         tidy_eqns_blks = unmix_eqns tidy_eqns_info
205     in
206     match_unmixed_eqn_blks vars tidy_eqns_blks tidy_shadows
207   where
208     unmix_eqns []    = []
209     unmix_eqns [eqn] = [ [eqn] ]
210     unmix_eqns (eq1@(EqnInfo (p1:p1s) _) : eq2@(EqnInfo (p2:p2s) _) : eqs)
211       = if (  (unfailablePat p1 && unfailablePat p2)
212            || (isConPat      p1 && isConPat p2)
213            || (isLitPat      p1 && isLitPat p2) ) then
214             eq1 `tack_onto` unmixed_rest
215         else
216             [ eq1 ] : unmixed_rest
217       where
218         unmixed_rest = unmix_eqns (eq2:eqs)
219
220         x `tack_onto` xss   = ( x : head xss) : tail xss
221
222     -----------------------------------------------------------------------
223     -- loop through the blocks:
224     -- subsequent blocks create a "fail expr" for the first one...
225     match_unmixed_eqn_blks :: [Id]
226                            -> [ [EquationInfo] ]        -- List of eqn BLOCKS
227                            -> [EquationInfo]            -- Shadows
228                            -> DsM MatchResult
229
230     match_unmixed_eqn_blks vars [] shadows = panic "match_unmixed_eqn_blks"
231
232     match_unmixed_eqn_blks vars [eqn_blk] shadows = matchUnmixedEqns vars eqn_blk shadows
233
234     match_unmixed_eqn_blks vars (eqn_blk:eqn_blks) shadows
235       = matchUnmixedEqns vars eqn_blk shadows           `thenDs` \ match_result1 ->  -- try to match with first blk
236         match_unmixed_eqn_blks vars eqn_blks shadows'   `thenDs` \ match_result2 ->
237         combineMatchResults match_result1 match_result2
238       where
239         shadows' = eqn_blk ++ shadows
240 \end{code}
241
242 Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@
243 which will be scrutinised.  This means:
244 \begin{itemize}
245 \item
246 Replace variable patterns @x@ (@x /= v@) with the pattern @_@,
247 together with the binding @x = v@.
248 \item
249 Replace the `as' pattern @x@@p@ with the pattern p and a binding @x = v@.
250 \item
251 Removing lazy (irrefutable) patterns (you don't want to know...).
252 \item
253 Converting explicit tuple- and list-pats into ordinary @ConPats@.
254 \end{itemize}
255
256 The result of this tidying is that the column of patterns will include
257 {\em only}:
258 \begin{description}
259 \item[@WildPats@:]
260 The @VarPat@ information isn't needed any more after this.
261
262 \item[@ConPats@:]
263 @ListPats@, @TuplePats@, etc., are all converted into @ConPats@.
264
265 \item[@LitPats@ and @NPats@:]
266 @LitPats@/@NPats@ of ``known friendly types'' (Int, Char,
267 Float,  Double, at least) are converted to unboxed form; e.g.,
268 \tr{(NPat (HsInt i) _ _)} is converted to:
269 \begin{verbatim}
270 (ConPat I# _ _ [LitPat (HsIntPrim i) _])
271 \end{verbatim}
272 \end{description}
273
274 \begin{code}
275 tidyEqnInfo :: Id -> EquationInfo -> DsM EquationInfo
276         -- DsM'd because of internal call to "match".
277         -- "tidy1" does the interesting stuff, looking at
278         -- one pattern and fiddling the list of bindings.
279 tidyEqnInfo v (EqnInfo (pat : pats) match_result)
280   = tidy1 v pat match_result    `thenDs` \ (pat', match_result') ->
281     returnDs (EqnInfo (pat' : pats) match_result')
282
283 tidy1 :: Id                                     -- The Id being scrutinised
284       -> TypecheckedPat                         -- The pattern against which it is to be matched
285       -> MatchResult                            -- Current thing do do after matching
286       -> DsM (TypecheckedPat,                   -- Equivalent pattern
287               MatchResult)                      -- Augmented thing to do afterwards
288                                                 -- The augmentation usually takes the form
289                                                 -- of new bindings to be added to the front
290
291 tidy1 v (VarPat var) match_result
292   = returnDs (WildPat (idType var),
293               mkCoLetsMatchResult extra_binds match_result)
294   where
295     extra_binds | v == var  = []
296                 | otherwise = [NonRec var (Var v)]
297
298 tidy1 v (AsPat var pat) match_result
299   = tidy1 v pat (mkCoLetsMatchResult extra_binds match_result)
300   where
301     extra_binds | v == var  = []
302                 | otherwise = [NonRec var (Var v)]
303
304 tidy1 v (WildPat ty) match_result
305   = returnDs (WildPat ty, match_result)
306
307 {- now, here we handle lazy patterns:
308     tidy1 v ~p bs = (v, v1 = case v of p -> v1 :
309                         v2 = case v of p -> v2 : ... : bs )
310
311     where the v_i's are the binders in the pattern.
312
313     ToDo: in "v_i = ... -> v_i", are the v_i's really the same thing?
314
315     The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr
316 -}
317
318 tidy1 v (LazyPat pat) match_result
319   = mkSelectorBinds [] pat l_to_l (Var v)       `thenDs` \ sel_binds ->
320     returnDs (WildPat (idType v),
321               mkCoLetsMatchResult [NonRec b rhs | (b,rhs) <- sel_binds] match_result)
322   where
323     l_to_l = binders `zip` binders      -- Boring
324     binders = collectTypedPatBinders pat
325
326 -- re-express <con-something> as (ConPat ...) [directly]
327
328 tidy1 v (ConOpPat pat1 id pat2 ty) match_result
329   = returnDs (ConPat id ty [pat1, pat2], match_result)
330
331 tidy1 v (RecPat con_id pat_ty rpats) match_result
332   = returnDs (ConPat con_id pat_ty pats, match_result)
333   where
334     pats             = map mk_pat tagged_arg_tys
335
336         -- Boring stuff to find the arg-tys of the constructor
337     (_, inst_tys, _) = {-_trace "Match.getAppDataTyConExpandingDicts" $-} getAppDataTyConExpandingDicts pat_ty
338     con_arg_tys'     = dataConArgTys con_id inst_tys 
339     tagged_arg_tys   = con_arg_tys' `zip` allFieldLabelTags
340
341         -- mk_pat picks a WildPat of the appropriate type for absent fields,
342         -- and the specified pattern for present fields
343     mk_pat (arg_ty, tag) = case [pat | (sel_id,pat,_) <- rpats,
344                                         fieldLabelTag (recordSelectorFieldLabel sel_id) == tag 
345                                 ] of
346                                 (pat:pats) -> ASSERT( null pats )
347                                               pat
348                                 []         -> WildPat arg_ty
349
350 tidy1 v (ListPat ty pats) match_result
351   = returnDs (list_ConPat, match_result)
352   where
353     list_ty = mkListTy ty
354     list_ConPat
355       = foldr (\ x -> \y -> ConPat consDataCon list_ty [x, y])
356               (ConPat nilDataCon  list_ty [])
357               pats
358
359 tidy1 v (TuplePat pats) match_result
360   = returnDs (tuple_ConPat, match_result)
361   where
362     arity = length pats
363     tuple_ConPat
364       = ConPat (mkTupleCon arity)
365                (mkTupleTy arity (map outPatType pats))
366                pats
367
368 tidy1 v (DictPat dicts methods) match_result
369   = case num_of_d_and_ms of
370         0 -> tidy1 v (TuplePat []) match_result
371         1 -> tidy1 v (head dict_and_method_pats) match_result
372         _ -> tidy1 v (TuplePat dict_and_method_pats) match_result
373   where
374     num_of_d_and_ms      = length dicts + length methods
375     dict_and_method_pats = map VarPat (dicts ++ methods)
376
377
378 -- deeply ugly mangling for some (common) NPats/LitPats
379
380 -- LitPats: the desugarer only sees these at well-known types
381
382 tidy1 v pat@(LitPat lit lit_ty) match_result
383   | isPrimType lit_ty
384   = returnDs (pat, match_result)
385
386   | lit_ty `eqTy` charTy
387   = returnDs (ConPat charDataCon charTy [LitPat (mk_char lit) charPrimTy],
388               match_result)
389
390   | otherwise = pprPanic "tidy1:LitPat:" (ppr PprDebug pat)
391   where
392     mk_char (HsChar c)    = HsCharPrim c
393
394 -- NPats: we *might* be able to replace these w/ a simpler form
395
396 tidy1 v pat@(NPat lit lit_ty _) match_result
397   = returnDs (better_pat, match_result)
398   where
399     better_pat
400       | lit_ty `eqTy` charTy   = ConPat charDataCon   lit_ty [LitPat (mk_char lit)   charPrimTy]
401       | lit_ty `eqTy` intTy    = ConPat intDataCon    lit_ty [LitPat (mk_int lit)    intPrimTy]
402       | lit_ty `eqTy` wordTy   = ConPat wordDataCon   lit_ty [LitPat (mk_word lit)   wordPrimTy]
403       | lit_ty `eqTy` addrTy   = ConPat addrDataCon   lit_ty [LitPat (mk_addr lit)   addrPrimTy]
404       | lit_ty `eqTy` floatTy  = ConPat floatDataCon  lit_ty [LitPat (mk_float lit)  floatPrimTy]
405       | lit_ty `eqTy` doubleTy = ConPat doubleDataCon lit_ty [LitPat (mk_double lit) doublePrimTy]
406       | otherwise          = pat
407
408     mk_int    (HsInt i)      = HsIntPrim i
409     mk_int    l@(HsLitLit s) = l
410
411     mk_char   (HsChar c)     = HsCharPrim c
412     mk_char   l@(HsLitLit s) = l
413
414     mk_word   l@(HsLitLit s) = l
415
416     mk_addr   l@(HsLitLit s) = l
417
418     mk_float  (HsInt i)      = HsFloatPrim (fromInteger i)
419     mk_float  (HsFrac f)     = HsFloatPrim f
420     mk_float  l@(HsLitLit s) = l
421
422     mk_double (HsInt i)      = HsDoublePrim (fromInteger i)
423     mk_double (HsFrac f)     = HsDoublePrim f
424     mk_double l@(HsLitLit s) = l
425
426 -- and everything else goes through unchanged...
427
428 tidy1 v non_interesting_pat match_result
429   = returnDs (non_interesting_pat, match_result)
430 \end{code}
431
432 PREVIOUS matchTwiddled STUFF:
433
434 Now we get to the only interesting part; note: there are choices for
435 translation [from Simon's notes]; translation~1:
436 \begin{verbatim}
437 deTwiddle [s,t] e
438 \end{verbatim}
439 returns
440 \begin{verbatim}
441 [ w = e,
442   s = case w of [s,t] -> s
443   t = case w of [s,t] -> t
444 ]
445 \end{verbatim}
446
447 Here \tr{w} is a fresh variable, and the \tr{w}-binding prevents multiple
448 evaluation of \tr{e}.  An alternative translation (No.~2):
449 \begin{verbatim}
450 [ w = case e of [s,t] -> (s,t)
451   s = case w of (s,t) -> s
452   t = case w of (s,t) -> t
453 ]
454 \end{verbatim}
455
456 %************************************************************************
457 %*                                                                      *
458 \subsubsection[improved-unmixing]{UNIMPLEMENTED idea for improved unmixing}
459 %*                                                                      *
460 %************************************************************************
461
462 We might be able to optimise unmixing when confronted by
463 only-one-constructor-possible, of which tuples are the most notable
464 examples.  Consider:
465 \begin{verbatim}
466 f (a,b,c) ... = ...
467 f d ... (e:f) = ...
468 f (g,h,i) ... = ...
469 f j ...       = ...
470 \end{verbatim}
471 This definition would normally be unmixed into four equation blocks,
472 one per equation.  But it could be unmixed into just one equation
473 block, because if the one equation matches (on the first column),
474 the others certainly will.
475
476 You have to be careful, though; the example
477 \begin{verbatim}
478 f j ...       = ...
479 -------------------
480 f (a,b,c) ... = ...
481 f d ... (e:f) = ...
482 f (g,h,i) ... = ...
483 \end{verbatim}
484 {\em must} be broken into two blocks at the line shown; otherwise, you
485 are forcing unnecessary evaluation.  In any case, the top-left pattern
486 always gives the cue.  You could then unmix blocks into groups of...
487 \begin{description}
488 \item[all variables:]
489 As it is now.
490 \item[constructors or variables (mixed):]
491 Need to make sure the right names get bound for the variable patterns.
492 \item[literals or variables (mixed):]
493 Presumably just a variant on the constructor case (as it is now).
494 \end{description}
495
496 %************************************************************************
497 %*                                                                      *
498 %* match on an unmixed block: the real business                         *
499 %*                                                                      *
500 %************************************************************************
501 \subsection[matchUnmixedEqns]{@matchUnmixedEqns@: getting down to business}
502
503 The function @matchUnmixedEqns@ is where the matching stuff sets to
504 work a block of equations, to which the mixture rule has been applied.
505 Its arguments and results are the same as for the ``top-level'' @match@.
506
507 \begin{code}
508 matchUnmixedEqns :: [Id]
509                   -> [EquationInfo]
510                   -> [EquationInfo]             -- Shadows
511                   -> DsM MatchResult
512
513 matchUnmixedEqns [] _ _ = panic "matchUnmixedEqns: no names"
514
515 matchUnmixedEqns all_vars@(var:vars) eqns_info shadows
516   | unfailablePat first_pat
517   = ASSERT( unfailablePats column_1_pats )      -- Sanity check
518         -- Real true variables, just like in matchVar, SLPJ p 94
519     match vars remaining_eqns_info remaining_shadows
520
521   | isConPat first_pat
522   = ASSERT( patsAreAllCons column_1_pats )
523     matchConFamily all_vars eqns_info shadows
524
525   | isLitPat first_pat
526   = ASSERT( patsAreAllLits column_1_pats )
527         -- see notes in MatchLiteral
528         -- not worried about the same literal more than once in a column
529         -- (ToDo: sort this out later)
530     matchLiterals all_vars eqns_info shadows
531
532   where
533     first_pat           = head column_1_pats
534     column_1_pats       = [pat                       | EqnInfo (pat:_)  _            <- eqns_info]
535     remaining_eqns_info = [EqnInfo pats match_result | EqnInfo (_:pats) match_result <- eqns_info]
536     remaining_shadows   = [EqnInfo pats match_result | EqnInfo (pat:pats) match_result <- shadows,
537                                                        irrefutablePat pat ]
538         -- Discard shadows which can be refuted, since they don't shadow
539         -- a variable
540 \end{code}
541
542 %************************************************************************
543 %*                                                                      *
544 %*  matchWrapper: a convenient way to call @match@                      *
545 %*                                                                      *
546 %************************************************************************
547 \subsection[matchWrapper]{@matchWrapper@: a convenient interface to @match@}
548
549 Calls to @match@ often involve similar (non-trivial) work; that work
550 is collected here, in @matchWrapper@.  This function takes as
551 arguments:
552 \begin{itemize}
553 \item
554 Typchecked @Matches@ (of a function definition, or a case or lambda
555 expression)---the main input;
556 \item
557 An error message to be inserted into any (runtime) pattern-matching
558 failure messages.
559 \end{itemize}
560
561 As results, @matchWrapper@ produces:
562 \begin{itemize}
563 \item
564 A list of variables (@Locals@) that the caller must ``promise'' to
565 bind to appropriate values; and
566 \item
567 a @CoreExpr@, the desugared output (main result).
568 \end{itemize}
569
570 The main actions of @matchWrapper@ include:
571 \begin{enumerate}
572 \item
573 Flatten the @[TypecheckedMatch]@ into a suitable list of
574 @EquationInfo@s.
575 \item
576 Create as many new variables as there are patterns in a pattern-list
577 (in any one of the @EquationInfo@s).
578 \item
579 Create a suitable ``if it fails'' expression---a call to @error@ using
580 the error-string input; the {\em type} of this fail value can be found
581 by examining one of the RHS expressions in one of the @EquationInfo@s.
582 \item
583 Call @match@ with all of this information!
584 \end{enumerate}
585
586 \begin{code}
587 matchWrapper :: DsMatchKind                     -- For shadowing warning messages
588              -> [TypecheckedMatch]              -- Matches being desugared
589              -> String                          -- Error message if the match fails
590              -> DsM ([Id], CoreExpr)    -- Results
591
592 -- a special case for the common ...:
593 --      just one Match
594 --      lots of (all?) unfailable pats
595 --  e.g.,
596 --      f x y z = ....
597
598 matchWrapper kind [(PatMatch (VarPat var) match)] error_string
599   = matchWrapper kind [match] error_string `thenDs` \ (vars, core_expr) ->
600     returnDs (var:vars, core_expr)
601
602 matchWrapper kind [(PatMatch (WildPat ty) match)] error_string
603   = newSysLocalDs ty                  `thenDs` \ var ->
604     matchWrapper kind [match] error_string `thenDs` \ (vars, core_expr) ->
605     returnDs (var:vars, core_expr)
606
607 matchWrapper kind [(GRHSMatch
608                      (GRHSsAndBindsOut [OtherwiseGRHS expr _] binds _))] error_string
609   = dsBinds binds       `thenDs` \ core_binds ->
610     dsExpr  expr        `thenDs` \ core_expr ->
611     returnDs ([], mkCoLetsAny core_binds core_expr)
612
613 ----------------------------------------------------------------------------
614 -- and all the rest... (general case)
615
616 matchWrapper kind matches error_string
617   = flattenMatches kind matches `thenDs` \ eqns_info@(EqnInfo arg_pats (MatchResult _ result_ty _ _) : _) ->
618
619     selectMatchVars arg_pats                            `thenDs` \ new_vars ->
620     match new_vars eqns_info []                         `thenDs` \ match_result ->
621
622     mkErrorAppDs pAT_ERROR_ID result_ty error_string    `thenDs` \ fail_expr ->
623     extractMatchResult match_result fail_expr           `thenDs` \ result_expr ->
624
625     returnDs (new_vars, result_expr)
626 \end{code}
627
628 %************************************************************************
629 %*                                                                      *
630 \subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern}
631 %*                                                                      *
632 %************************************************************************
633
634 @mkSimpleMatch@ is a wrapper for @match@ which deals with the
635 situation where we want to match a single expression against a single
636 pattern. It returns an expression.
637
638 \begin{code}
639 matchSimply :: CoreExpr                 -- Scrutinee
640             -> TypecheckedPat                   -- Pattern it should match
641             -> Type                             -- Type of result
642             -> CoreExpr                 -- Return this if it matches
643             -> CoreExpr                 -- Return this if it does
644             -> DsM CoreExpr
645
646 matchSimply (Var var) pat result_ty result_expr fail_expr
647   = match [var] [eqn_info] []   `thenDs` \ match_result ->
648     extractMatchResult match_result fail_expr
649   where
650     eqn_info = EqnInfo [pat] initial_match_result
651     initial_match_result = MatchResult CantFail
652                                        result_ty
653                                        (\ ignore -> result_expr)
654                                        NoMatchContext
655
656 matchSimply scrut_expr pat result_ty result_expr msg
657   = newSysLocalDs (outPatType pat)                              `thenDs` \ scrut_var ->
658     matchSimply (Var scrut_var) pat result_ty result_expr msg   `thenDs` \ expr ->
659     returnDs (Let (NonRec scrut_var scrut_expr) expr)
660
661
662 extractMatchResult (MatchResult CantFail _ match_fn _) fail_expr
663   = returnDs (match_fn (error "It can't fail!"))
664
665 extractMatchResult (MatchResult CanFail result_ty match_fn _) fail_expr
666   = mkFailurePair result_ty     `thenDs` \ (fail_bind_fn, if_it_fails) ->
667     returnDs (Let (fail_bind_fn fail_expr) (match_fn if_it_fails))
668 \end{code}
669
670 %************************************************************************
671 %*                                                                      *
672 %*  flattenMatches : create a list of EquationInfo                      *
673 %*                                                                      *
674 %************************************************************************
675 \subsection[flattenMatches]{@flattenMatches@: create @[EquationInfo]@}
676
677 This is actually local to @matchWrapper@.
678
679 \begin{code}
680 flattenMatches
681         :: DsMatchKind
682         -> [TypecheckedMatch]
683         -> DsM [EquationInfo]
684
685 flattenMatches kind [] = returnDs []
686
687 flattenMatches kind (match : matches)
688   = flatten_match [] match      `thenDs` \ eqn_info ->
689     flattenMatches kind matches `thenDs` \ eqn_infos ->
690     returnDs (eqn_info : eqn_infos)
691   where
692     flatten_match :: [TypecheckedPat]           -- Reversed list of patterns encountered so far
693                   -> TypecheckedMatch
694                   -> DsM EquationInfo
695
696     flatten_match pats_so_far (PatMatch pat match)
697       = flatten_match (pat:pats_so_far) match
698
699     flatten_match pats_so_far (GRHSMatch (GRHSsAndBindsOut grhss binds ty))
700       = dsBinds binds                           `thenDs` \ core_binds ->
701         dsGRHSs ty kind pats grhss              `thenDs` \ match_result ->
702         returnDs (EqnInfo pats (mkCoLetsMatchResult core_binds match_result))
703       where
704         pats = reverse pats_so_far      -- They've accumulated in reverse order
705
706     flatten_match pats_so_far (SimpleMatch expr) 
707       = dsExpr expr             `thenDs` \ core_expr ->
708         returnDs (EqnInfo pats
709                     (MatchResult CantFail (coreExprType core_expr) 
710                               (\ ignore -> core_expr)
711                               NoMatchContext))
712         -- The NoMatchContext is just a place holder.  In a simple match,
713         -- the matching can't fail, so we won't generate an error message.
714       where
715         pats = reverse pats_so_far      -- They've accumulated in reverse order
716 \end{code}