Merge in changes from HEAD
[ghc.git] / compiler / deSugar / Match.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %
5
6 The @match@ function
7
8 \begin{code}
9 module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat ) where
10
11 #include "HsVersions.h"
12
13 import {-#SOURCE#-} DsExpr (dsLExpr)
14
15 import DynFlags
16 import HsSyn            
17 import TcHsSyn
18 import Check
19 import CoreSyn
20 import Literal
21 import CoreUtils
22 import MkCore
23 import DsMonad
24 import DsBinds
25 import DsGRHSs
26 import DsUtils
27 import Id
28 import DataCon
29 import MatchCon
30 import MatchLit
31 import Type
32 import Coercion
33 import TysWiredIn
34 import ListSetOps
35 import SrcLoc
36 import Maybes
37 import Util
38 import Name
39 import Outputable
40 import FastString
41
42 import Control.Monad( when )
43 import qualified Data.Map as Map
44 \end{code}
45
46 This function is a wrapper of @match@, it must be called from all the parts where 
47 it was called match, but only substitutes the firs call, ....
48 if the associated flags are declared, warnings will be issued.
49 It can not be called matchWrapper because this name already exists :-(
50
51 JJCQ 30-Nov-1997
52
53 \begin{code}
54 matchCheck ::  DsMatchContext
55             -> [Id]             -- Vars rep'ing the exprs we're matching with
56             -> Type             -- Type of the case expression
57             -> [EquationInfo]   -- Info about patterns, etc. (type synonym below)
58             -> DsM MatchResult  -- Desugared result!
59
60 matchCheck ctx vars ty qs
61   = do { dflags <- getDOptsDs
62        ; matchCheck_really dflags ctx vars ty qs }
63
64 matchCheck_really :: DynFlags
65                   -> DsMatchContext
66                   -> [Id]
67                   -> Type
68                   -> [EquationInfo]
69                   -> DsM MatchResult
70 matchCheck_really dflags ctx@(DsMatchContext hs_ctx _) vars ty qs
71   = do { when shadow (dsShadowWarn ctx eqns_shadow)
72        ; when incomplete (dsIncompleteWarn ctx pats)
73        ; match vars ty qs }
74   where 
75     (pats, eqns_shadow) = check qs
76     incomplete = incomplete_flag hs_ctx && (notNull pats)
77     shadow     = dopt Opt_WarnOverlappingPatterns dflags
78                  && notNull eqns_shadow
79
80     incomplete_flag :: HsMatchContext id -> Bool
81     incomplete_flag (FunRhs {})   = dopt Opt_WarnIncompletePatterns dflags
82     incomplete_flag CaseAlt       = dopt Opt_WarnIncompletePatterns dflags
83
84     incomplete_flag LambdaExpr    = dopt Opt_WarnIncompleteUniPatterns dflags
85     incomplete_flag PatBindRhs    = dopt Opt_WarnIncompleteUniPatterns dflags
86     incomplete_flag ProcExpr      = dopt Opt_WarnIncompleteUniPatterns dflags
87
88     incomplete_flag RecUpd        = dopt Opt_WarnIncompletePatternsRecUpd dflags
89
90     incomplete_flag ThPatQuote    = False
91     incomplete_flag (StmtCtxt {}) = False  -- Don't warn about incomplete patterns
92                                            -- in list comprehensions, pattern guards
93                                            -- etc.  They are often *supposed* to be
94                                            -- incomplete 
95 \end{code}
96
97 This variable shows the maximum number of lines of output generated for warnings.
98 It will limit the number of patterns/equations displayed to@ maximum_output@.
99
100 (ToDo: add command-line option?)
101
102 \begin{code}
103 maximum_output :: Int
104 maximum_output = 4
105 \end{code}
106
107 The next two functions create the warning message.
108
109 \begin{code}
110 dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM ()
111 dsShadowWarn ctx@(DsMatchContext kind loc) qs
112   = putSrcSpanDs loc (warnDs warn)
113   where
114     warn | qs `lengthExceeds` maximum_output
115          = pp_context ctx (ptext (sLit "are overlapped"))
116                       (\ f -> vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$
117                       ptext (sLit "..."))
118          | otherwise
119          = pp_context ctx (ptext (sLit "are overlapped"))
120                       (\ f -> vcat $ map (ppr_eqn f kind) qs)
121
122
123 dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM ()
124 dsIncompleteWarn ctx@(DsMatchContext kind loc) pats 
125   = putSrcSpanDs loc (warnDs warn)
126         where
127           warn = pp_context ctx (ptext (sLit "are non-exhaustive"))
128                             (\_ -> hang (ptext (sLit "Patterns not matched:"))
129                                    4 ((vcat $ map (ppr_incomplete_pats kind)
130                                                   (take maximum_output pats))
131                                       $$ dots))
132
133           dots | pats `lengthExceeds` maximum_output = ptext (sLit "...")
134                | otherwise                           = empty
135
136 pp_context :: DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
137 pp_context (DsMatchContext kind _loc) msg rest_of_msg_fun
138   = vcat [ptext (sLit "Pattern match(es)") <+> msg,
139           sep [ptext (sLit "In") <+> ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]]
140   where
141     (ppr_match, pref)
142         = case kind of
143              FunRhs fun _ -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)
144              _            -> (pprMatchContext kind, \ pp -> pp)
145
146 ppr_pats :: Outputable a => [a] -> SDoc
147 ppr_pats pats = sep (map ppr pats)
148
149 ppr_shadow_pats :: HsMatchContext Name -> [Pat Id] -> SDoc
150 ppr_shadow_pats kind pats
151   = sep [ppr_pats pats, matchSeparator kind, ptext (sLit "...")]
152
153 ppr_incomplete_pats :: HsMatchContext Name -> ExhaustivePat -> SDoc
154 ppr_incomplete_pats _ (pats,[]) = ppr_pats pats
155 ppr_incomplete_pats _ (pats,constraints) =
156                          sep [ppr_pats pats, ptext (sLit "with"), 
157                               sep (map ppr_constraint constraints)]
158
159 ppr_constraint :: (Name,[HsLit]) -> SDoc
160 ppr_constraint (var,pats) = sep [ppr var, ptext (sLit "`notElem`"), ppr pats]
161
162 ppr_eqn :: (SDoc -> SDoc) -> HsMatchContext Name -> EquationInfo -> SDoc
163 ppr_eqn prefixF kind eqn = prefixF (ppr_shadow_pats kind (eqn_pats eqn))
164 \end{code}
165
166
167 %************************************************************************
168 %*                                                                      *
169                 The main matching function
170 %*                                                                      *
171 %************************************************************************
172
173 The function @match@ is basically the same as in the Wadler chapter,
174 except it is monadised, to carry around the name supply, info about
175 annotations, etc.
176
177 Notes on @match@'s arguments, assuming $m$ equations and $n$ patterns:
178 \begin{enumerate}
179 \item
180 A list of $n$ variable names, those variables presumably bound to the
181 $n$ expressions being matched against the $n$ patterns.  Using the
182 list of $n$ expressions as the first argument showed no benefit and
183 some inelegance.
184
185 \item
186 The second argument, a list giving the ``equation info'' for each of
187 the $m$ equations:
188 \begin{itemize}
189 \item
190 the $n$ patterns for that equation, and
191 \item
192 a list of Core bindings [@(Id, CoreExpr)@ pairs] to be ``stuck on
193 the front'' of the matching code, as in:
194 \begin{verbatim}
195 let <binds>
196 in  <matching-code>
197 \end{verbatim}
198 \item
199 and finally: (ToDo: fill in)
200
201 The right way to think about the ``after-match function'' is that it
202 is an embryonic @CoreExpr@ with a ``hole'' at the end for the
203 final ``else expression''.
204 \end{itemize}
205
206 There is a type synonym, @EquationInfo@, defined in module @DsUtils@.
207
208 An experiment with re-ordering this information about equations (in
209 particular, having the patterns available in column-major order)
210 showed no benefit.
211
212 \item
213 A default expression---what to evaluate if the overall pattern-match
214 fails.  This expression will (almost?) always be
215 a measly expression @Var@, unless we know it will only be used once
216 (as we do in @glue_success_exprs@).
217
218 Leaving out this third argument to @match@ (and slamming in lots of
219 @Var "fail"@s) is a positively {\em bad} idea, because it makes it
220 impossible to share the default expressions.  (Also, it stands no
221 chance of working in our post-upheaval world of @Locals@.)
222 \end{enumerate}
223
224 Note: @match@ is often called via @matchWrapper@ (end of this module),
225 a function that does much of the house-keeping that goes with a call
226 to @match@.
227
228 It is also worth mentioning the {\em typical} way a block of equations
229 is desugared with @match@.  At each stage, it is the first column of
230 patterns that is examined.  The steps carried out are roughly:
231 \begin{enumerate}
232 \item
233 Tidy the patterns in column~1 with @tidyEqnInfo@ (this may add
234 bindings to the second component of the equation-info):
235 \begin{itemize}
236 \item
237 Remove the `as' patterns from column~1.
238 \item
239 Make all constructor patterns in column~1 into @ConPats@, notably
240 @ListPats@ and @TuplePats@.
241 \item
242 Handle any irrefutable (or ``twiddle'') @LazyPats@.
243 \end{itemize}
244 \item
245 Now {\em unmix} the equations into {\em blocks} [w\/ local function
246 @unmix_eqns@], in which the equations in a block all have variable
247 patterns in column~1, or they all have constructor patterns in ...
248 (see ``the mixture rule'' in SLPJ).
249 \item
250 Call @matchEqnBlock@ on each block of equations; it will do the
251 appropriate thing for each kind of column-1 pattern, usually ending up
252 in a recursive call to @match@.
253 \end{enumerate}
254
255 We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87)
256 than the Wadler-chapter code for @match@ (p.~93, first @match@ clause).
257 And gluing the ``success expressions'' together isn't quite so pretty.
258
259 This (more interesting) clause of @match@ uses @tidy_and_unmix_eqns@
260 (a)~to get `as'- and `twiddle'-patterns out of the way (tidying), and
261 (b)~to do ``the mixture rule'' (SLPJ, p.~88) [which really {\em
262 un}mixes the equations], producing a list of equation-info
263 blocks, each block having as its first column of patterns either all
264 constructors, or all variables (or similar beasts), etc.
265
266 @match_unmixed_eqn_blks@ simply takes the place of the @foldr@ in the
267 Wadler-chapter @match@ (p.~93, last clause), and @match_unmixed_blk@
268 corresponds roughly to @matchVarCon@.
269
270 \begin{code}
271 match :: [Id]             -- Variables rep\'ing the exprs we\'re matching with
272       -> Type             -- Type of the case expression
273       -> [EquationInfo]   -- Info about patterns, etc. (type synonym below)
274       -> DsM MatchResult  -- Desugared result!
275
276 match [] ty eqns
277   = ASSERT2( not (null eqns), ppr ty )
278     return (foldr1 combineMatchResults match_results)
279   where
280     match_results = [ ASSERT( null (eqn_pats eqn) ) 
281                       eqn_rhs eqn
282                     | eqn <- eqns ]
283
284 match vars@(v:_) ty eqns
285   = ASSERT( not (null eqns ) )
286     do  {       -- Tidy the first pattern, generating
287                 -- auxiliary bindings if necessary
288           (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns
289
290                 -- Group the equations and match each group in turn
291         ; let grouped = groupEquations tidy_eqns
292
293          -- print the view patterns that are commoned up to help debug
294         ; ifDOptM Opt_D_dump_view_pattern_commoning (debug grouped)
295
296         ; match_results <- mapM match_group grouped
297         ; return (adjustMatchResult (foldr1 (.) aux_binds) $
298                   foldr1 combineMatchResults match_results) }
299   where
300     dropGroup :: [(PatGroup,EquationInfo)] -> [EquationInfo]
301     dropGroup = map snd
302
303     match_group :: [(PatGroup,EquationInfo)] -> DsM MatchResult
304     match_group [] = panic "match_group"
305     match_group eqns@((group,_) : _)
306         = case group of
307             PgCon _    -> matchConFamily  vars ty (subGroup [(c,e) | (PgCon c, e) <- eqns])
308             PgLit _    -> matchLiterals   vars ty (subGroup [(l,e) | (PgLit l, e) <- eqns])
309             PgAny      -> matchVariables  vars ty (dropGroup eqns)
310             PgN _      -> matchNPats      vars ty (dropGroup eqns)
311             PgNpK _    -> matchNPlusKPats vars ty (dropGroup eqns)
312             PgBang     -> matchBangs      vars ty (dropGroup eqns)
313             PgCo _     -> matchCoercion   vars ty (dropGroup eqns)
314             PgView _ _ -> matchView       vars ty (dropGroup eqns)
315
316     -- FIXME: we should also warn about view patterns that should be
317     -- commoned up but are not
318
319     -- print some stuff to see what's getting grouped
320     -- use -dppr-debug to see the resolution of overloaded lits
321     debug eqns = 
322         let gs = map (\group -> foldr (\ (p,_) -> \acc -> 
323                                            case p of PgView e _ -> e:acc 
324                                                      _ -> acc) [] group) eqns
325             maybeWarn [] = return ()
326             maybeWarn l = warnDs (vcat l)
327         in 
328           maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g))
329                        (filter (not . null) gs))
330
331 matchVariables :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
332 -- Real true variables, just like in matchVar, SLPJ p 94
333 -- No binding to do: they'll all be wildcards by now (done in tidy)
334 matchVariables (_:vars) ty eqns = match vars ty (shiftEqns eqns)
335 matchVariables [] _ _ = panic "matchVariables"
336
337 matchBangs :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
338 matchBangs (var:vars) ty eqns
339   = do  { match_result <- match (var:vars) ty $
340                           map (decomposeFirstPat getBangPat) eqns
341         ; return (mkEvalMatchResult var ty match_result) }
342 matchBangs [] _ _ = panic "matchBangs"
343
344 matchCoercion :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
345 -- Apply the coercion to the match variable and then match that
346 matchCoercion (var:vars) ty (eqns@(eqn1:_))
347   = do  { let CoPat co pat _ = firstPat eqn1
348         ; var' <- newUniqueId var (hsPatType pat)
349         ; match_result <- match (var':vars) ty $
350                           map (decomposeFirstPat getCoPat) eqns
351         ; co' <- dsHsWrapper co
352         ; let rhs' = co' (Var var)
353         ; return (mkCoLetMatchResult (NonRec var' rhs') match_result) }
354 matchCoercion _ _ _ = panic "matchCoercion"
355
356 matchView :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
357 -- Apply the view function to the match variable and then match that
358 matchView (var:vars) ty (eqns@(eqn1:_))
359   = do  { -- we could pass in the expr from the PgView,
360          -- but this needs to extract the pat anyway 
361          -- to figure out the type of the fresh variable
362          let ViewPat viewExpr (L _ pat) _ = firstPat eqn1
363          -- do the rest of the compilation 
364         ; var' <- newUniqueId var (hsPatType pat)
365         ; match_result <- match (var':vars) ty $
366                           map (decomposeFirstPat getViewPat) eqns
367          -- compile the view expressions
368         ; viewExpr' <- dsLExpr viewExpr
369         ; return (mkViewMatchResult var' viewExpr' var match_result) }
370 matchView _ _ _ = panic "matchView"
371
372 -- decompose the first pattern and leave the rest alone
373 decomposeFirstPat :: (Pat Id -> Pat Id) -> EquationInfo -> EquationInfo
374 decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))
375         = eqn { eqn_pats = extractpat pat : pats}
376 decomposeFirstPat _ _ = panic "decomposeFirstPat"
377
378 getCoPat, getBangPat, getViewPat :: Pat Id -> Pat Id
379 getCoPat (CoPat _ pat _)     = pat
380 getCoPat _                   = panic "getCoPat"
381 getBangPat (BangPat pat  )   = unLoc pat
382 getBangPat _                 = panic "getBangPat"
383 getViewPat (ViewPat _ pat _) = unLoc pat
384 getViewPat _                 = panic "getBangPat"
385 \end{code}
386
387 %************************************************************************
388 %*                                                                      *
389                 Tidying patterns
390 %*                                                                      *
391 %************************************************************************
392
393 Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@
394 which will be scrutinised.  This means:
395 \begin{itemize}
396 \item
397 Replace variable patterns @x@ (@x /= v@) with the pattern @_@,
398 together with the binding @x = v@.
399 \item
400 Replace the `as' pattern @x@@p@ with the pattern p and a binding @x = v@.
401 \item
402 Removing lazy (irrefutable) patterns (you don't want to know...).
403 \item
404 Converting explicit tuple-, list-, and parallel-array-pats into ordinary
405 @ConPats@. 
406 \item
407 Convert the literal pat "" to [].
408 \end{itemize}
409
410 The result of this tidying is that the column of patterns will include
411 {\em only}:
412 \begin{description}
413 \item[@WildPats@:]
414 The @VarPat@ information isn't needed any more after this.
415
416 \item[@ConPats@:]
417 @ListPats@, @TuplePats@, etc., are all converted into @ConPats@.
418
419 \item[@LitPats@ and @NPats@:]
420 @LitPats@/@NPats@ of ``known friendly types'' (Int, Char,
421 Float,  Double, at least) are converted to unboxed form; e.g.,
422 \tr{(NPat (HsInt i) _ _)} is converted to:
423 \begin{verbatim}
424 (ConPat I# _ _ [LitPat (HsIntPrim i)])
425 \end{verbatim}
426 \end{description}
427
428 \begin{code}
429 tidyEqnInfo :: Id -> EquationInfo
430             -> DsM (DsWrapper, EquationInfo)
431         -- DsM'd because of internal call to dsLHsBinds
432         --      and mkSelectorBinds.
433         -- "tidy1" does the interesting stuff, looking at
434         -- one pattern and fiddling the list of bindings.
435         --
436         -- POST CONDITION: head pattern in the EqnInfo is
437         --      WildPat
438         --      ConPat
439         --      NPat
440         --      LitPat
441         --      NPlusKPat
442         -- but no other
443
444 tidyEqnInfo _ (EqnInfo { eqn_pats = [] }) 
445   = panic "tidyEqnInfo"
446
447 tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats })
448   = do { (wrap, pat') <- tidy1 v pat
449        ; return (wrap, eqn { eqn_pats = do pat' : pats }) }
450
451 tidy1 :: Id                     -- The Id being scrutinised
452       -> Pat Id                 -- The pattern against which it is to be matched
453       -> DsM (DsWrapper,        -- Extra bindings to do before the match
454               Pat Id)           -- Equivalent pattern
455
456 -------------------------------------------------------
457 --      (pat', mr') = tidy1 v pat mr
458 -- tidies the *outer level only* of pat, giving pat'
459 -- It eliminates many pattern forms (as-patterns, variable patterns,
460 -- list patterns, etc) yielding one of:
461 --      WildPat
462 --      ConPatOut
463 --      LitPat
464 --      NPat
465 --      NPlusKPat
466
467 tidy1 v (ParPat pat)      = tidy1 v (unLoc pat) 
468 tidy1 v (SigPatOut pat _) = tidy1 v (unLoc pat) 
469 tidy1 _ (WildPat ty)      = return (idDsWrapper, WildPat ty)
470
471         -- case v of { x -> mr[] }
472         -- = case v of { _ -> let x=v in mr[] }
473 tidy1 v (VarPat var)
474   = return (wrapBind var v, WildPat (idType var)) 
475
476         -- case v of { x@p -> mr[] }
477         -- = case v of { p -> let x=v in mr[] }
478 tidy1 v (AsPat (L _ var) pat)
479   = do  { (wrap, pat') <- tidy1 v (unLoc pat)
480         ; return (wrapBind var v . wrap, pat') }
481
482 {- now, here we handle lazy patterns:
483     tidy1 v ~p bs = (v, v1 = case v of p -> v1 :
484                         v2 = case v of p -> v2 : ... : bs )
485
486     where the v_i's are the binders in the pattern.
487
488     ToDo: in "v_i = ... -> v_i", are the v_i's really the same thing?
489
490     The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr
491 -}
492
493 tidy1 v (LazyPat pat)
494   = do  { sel_prs <- mkSelectorBinds pat (Var v)
495         ; let sel_binds =  [NonRec b rhs | (b,rhs) <- sel_prs]
496         ; return (mkCoreLets sel_binds, WildPat (idType v)) }
497
498 tidy1 _ (ListPat pats ty)
499   = return (idDsWrapper, unLoc list_ConPat)
500   where
501     list_ty     = mkListTy ty
502     list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] list_ty)
503                         (mkNilPat list_ty)
504                         pats
505
506 -- Introduce fake parallel array constructors to be able to handle parallel
507 -- arrays with the existing machinery for constructor pattern
508 tidy1 _ (PArrPat pats ty)
509   = return (idDsWrapper, unLoc parrConPat)
510   where
511     arity      = length pats
512     parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty)
513
514 tidy1 _ (TuplePat pats boxity ty)
515   = return (idDsWrapper, unLoc tuple_ConPat)
516   where
517     arity = length pats
518     tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats ty
519
520 -- LitPats: we *might* be able to replace these w/ a simpler form
521 tidy1 _ (LitPat lit)
522   = return (idDsWrapper, tidyLitPat lit)
523
524 -- NPats: we *might* be able to replace these w/ a simpler form
525 tidy1 _ (NPat lit mb_neg eq)
526   = return (idDsWrapper, tidyNPat lit mb_neg eq)
527
528 -- BangPatterns: Pattern matching is already strict in constructors,
529 -- tuples etc, so the last case strips off the bang for thoses patterns.
530 tidy1 v (BangPat (L _ (LazyPat p)))       = tidy1 v (BangPat p)
531 tidy1 v (BangPat (L _ (ParPat p)))        = tidy1 v (BangPat p)
532 tidy1 _ p@(BangPat (L _(VarPat _)))       = return (idDsWrapper, p)
533 tidy1 _ p@(BangPat (L _ (WildPat _)))     = return (idDsWrapper, p)
534 tidy1 _ p@(BangPat (L _ (CoPat _ _ _)))   = return (idDsWrapper, p)
535 tidy1 _ p@(BangPat (L _ (SigPatIn _ _)))  = return (idDsWrapper, p)
536 tidy1 _ p@(BangPat (L _ (SigPatOut _ _))) = return (idDsWrapper, p)
537 tidy1 v (BangPat (L _ (AsPat (L _ var) pat)))
538   = do  { (wrap, pat') <- tidy1 v (BangPat pat)
539         ; return (wrapBind var v . wrap, pat') }
540 tidy1 v (BangPat (L _ p))                   = tidy1 v p
541
542 -- Everything else goes through unchanged...
543
544 tidy1 _ non_interesting_pat
545   = return (idDsWrapper, non_interesting_pat)
546 \end{code}
547
548 \noindent
549 {\bf Previous @matchTwiddled@ stuff:}
550
551 Now we get to the only interesting part; note: there are choices for
552 translation [from Simon's notes]; translation~1:
553 \begin{verbatim}
554 deTwiddle [s,t] e
555 \end{verbatim}
556 returns
557 \begin{verbatim}
558 [ w = e,
559   s = case w of [s,t] -> s
560   t = case w of [s,t] -> t
561 ]
562 \end{verbatim}
563
564 Here \tr{w} is a fresh variable, and the \tr{w}-binding prevents multiple
565 evaluation of \tr{e}.  An alternative translation (No.~2):
566 \begin{verbatim}
567 [ w = case e of [s,t] -> (s,t)
568   s = case w of (s,t) -> s
569   t = case w of (s,t) -> t
570 ]
571 \end{verbatim}
572
573 %************************************************************************
574 %*                                                                      *
575 \subsubsection[improved-unmixing]{UNIMPLEMENTED idea for improved unmixing}
576 %*                                                                      *
577 %************************************************************************
578
579 We might be able to optimise unmixing when confronted by
580 only-one-constructor-possible, of which tuples are the most notable
581 examples.  Consider:
582 \begin{verbatim}
583 f (a,b,c) ... = ...
584 f d ... (e:f) = ...
585 f (g,h,i) ... = ...
586 f j ...       = ...
587 \end{verbatim}
588 This definition would normally be unmixed into four equation blocks,
589 one per equation.  But it could be unmixed into just one equation
590 block, because if the one equation matches (on the first column),
591 the others certainly will.
592
593 You have to be careful, though; the example
594 \begin{verbatim}
595 f j ...       = ...
596 -------------------
597 f (a,b,c) ... = ...
598 f d ... (e:f) = ...
599 f (g,h,i) ... = ...
600 \end{verbatim}
601 {\em must} be broken into two blocks at the line shown; otherwise, you
602 are forcing unnecessary evaluation.  In any case, the top-left pattern
603 always gives the cue.  You could then unmix blocks into groups of...
604 \begin{description}
605 \item[all variables:]
606 As it is now.
607 \item[constructors or variables (mixed):]
608 Need to make sure the right names get bound for the variable patterns.
609 \item[literals or variables (mixed):]
610 Presumably just a variant on the constructor case (as it is now).
611 \end{description}
612
613 %************************************************************************
614 %*                                                                      *
615 %*  matchWrapper: a convenient way to call @match@                      *
616 %*                                                                      *
617 %************************************************************************
618 \subsection[matchWrapper]{@matchWrapper@: a convenient interface to @match@}
619
620 Calls to @match@ often involve similar (non-trivial) work; that work
621 is collected here, in @matchWrapper@.  This function takes as
622 arguments:
623 \begin{itemize}
624 \item
625 Typchecked @Matches@ (of a function definition, or a case or lambda
626 expression)---the main input;
627 \item
628 An error message to be inserted into any (runtime) pattern-matching
629 failure messages.
630 \end{itemize}
631
632 As results, @matchWrapper@ produces:
633 \begin{itemize}
634 \item
635 A list of variables (@Locals@) that the caller must ``promise'' to
636 bind to appropriate values; and
637 \item
638 a @CoreExpr@, the desugared output (main result).
639 \end{itemize}
640
641 The main actions of @matchWrapper@ include:
642 \begin{enumerate}
643 \item
644 Flatten the @[TypecheckedMatch]@ into a suitable list of
645 @EquationInfo@s.
646 \item
647 Create as many new variables as there are patterns in a pattern-list
648 (in any one of the @EquationInfo@s).
649 \item
650 Create a suitable ``if it fails'' expression---a call to @error@ using
651 the error-string input; the {\em type} of this fail value can be found
652 by examining one of the RHS expressions in one of the @EquationInfo@s.
653 \item
654 Call @match@ with all of this information!
655 \end{enumerate}
656
657 \begin{code}
658 matchWrapper :: HsMatchContext Name     -- For shadowing warning messages
659              -> MatchGroup Id           -- Matches being desugared
660              -> DsM ([Id], CoreExpr)    -- Results
661 \end{code}
662
663  There is one small problem with the Lambda Patterns, when somebody
664  writes something similar to:
665 \begin{verbatim}
666     (\ (x:xs) -> ...)
667 \end{verbatim}
668  he/she don't want a warning about incomplete patterns, that is done with 
669  the flag @opt_WarnSimplePatterns@.
670  This problem also appears in the:
671 \begin{itemize}
672 \item @do@ patterns, but if the @do@ can fail
673       it creates another equation if the match can fail
674       (see @DsExpr.doDo@ function)
675 \item @let@ patterns, are treated by @matchSimply@
676    List Comprension Patterns, are treated by @matchSimply@ also
677 \end{itemize}
678
679 We can't call @matchSimply@ with Lambda patterns,
680 due to the fact that lambda patterns can have more than
681 one pattern, and match simply only accepts one pattern.
682
683 JJQC 30-Nov-1997
684
685 \begin{code}
686 matchWrapper ctxt (MatchGroup matches match_ty)
687   = ASSERT( notNull matches )
688     do  { eqns_info   <- mapM mk_eqn_info matches
689         ; new_vars    <- selectMatchVars arg_pats
690         ; result_expr <- matchEquations ctxt new_vars eqns_info rhs_ty
691         ; return (new_vars, result_expr) }
692   where
693     arg_pats    = map unLoc (hsLMatchPats (head matches))
694     n_pats      = length arg_pats
695     (_, rhs_ty) = splitFunTysN n_pats match_ty
696
697     mk_eqn_info (L _ (Match pats _ grhss))
698       = do { let upats = map unLoc pats
699            ; match_result <- dsGRHSs ctxt upats grhss rhs_ty
700            ; return (EqnInfo { eqn_pats = upats, eqn_rhs  = match_result}) }
701
702
703 matchEquations  :: HsMatchContext Name
704                 -> [Id] -> [EquationInfo] -> Type
705                 -> DsM CoreExpr
706 matchEquations ctxt vars eqns_info rhs_ty
707   = do  { locn <- getSrcSpanDs
708         ; let   ds_ctxt   = DsMatchContext ctxt locn
709                 error_doc = matchContextErrString ctxt
710
711         ; match_result <- matchCheck ds_ctxt vars rhs_ty eqns_info
712
713         ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_doc
714         ; extractMatchResult match_result fail_expr }
715 \end{code}
716
717 %************************************************************************
718 %*                                                                      *
719 \subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern}
720 %*                                                                      *
721 %************************************************************************
722
723 @mkSimpleMatch@ is a wrapper for @match@ which deals with the
724 situation where we want to match a single expression against a single
725 pattern. It returns an expression.
726
727 \begin{code}
728 matchSimply :: CoreExpr                 -- Scrutinee
729             -> HsMatchContext Name      -- Match kind
730             -> LPat Id                  -- Pattern it should match
731             -> CoreExpr                 -- Return this if it matches
732             -> CoreExpr                 -- Return this if it doesn't
733             -> DsM CoreExpr
734 -- Do not warn about incomplete patterns; see matchSinglePat comments
735 matchSimply scrut hs_ctx pat result_expr fail_expr = do
736     let
737       match_result = cantFailMatchResult result_expr
738       rhs_ty       = exprType fail_expr
739         -- Use exprType of fail_expr, because won't refine in the case of failure!
740     match_result' <- matchSinglePat scrut hs_ctx pat rhs_ty match_result
741     extractMatchResult match_result' fail_expr
742
743 matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat Id
744                -> Type -> MatchResult -> DsM MatchResult
745 -- Do not warn about incomplete patterns
746 -- Used for things like [ e | pat <- stuff ], where 
747 -- incomplete patterns are just fine
748 matchSinglePat (Var var) ctx (L _ pat) ty match_result 
749   = do { locn <- getSrcSpanDs
750        ; matchCheck (DsMatchContext ctx locn)
751                     [var] ty  
752                     [EqnInfo { eqn_pats = [pat], eqn_rhs  = match_result }] }
753
754 matchSinglePat scrut hs_ctx pat ty match_result
755   = do { var <- selectSimpleMatchVarL pat
756        ; match_result' <- matchSinglePat (Var var) hs_ctx pat ty match_result
757        ; return (adjustMatchResult (bindNonRec var scrut) match_result') }
758 \end{code}
759
760
761 %************************************************************************
762 %*                                                                      *
763                 Pattern classification
764 %*                                                                      *
765 %************************************************************************
766
767 \begin{code}
768 data PatGroup
769   = PgAny               -- Immediate match: variables, wildcards, 
770                         --                  lazy patterns
771   | PgCon DataCon       -- Constructor patterns (incl list, tuple)
772   | PgLit Literal       -- Literal patterns
773   | PgN   Literal       -- Overloaded literals
774   | PgNpK Literal       -- n+k patterns
775   | PgBang              -- Bang patterns
776   | PgCo Type           -- Coercion patterns; the type is the type
777                         --      of the pattern *inside*
778   | PgView (LHsExpr Id) -- view pattern (e -> p):
779                         -- the LHsExpr is the expression e
780            Type         -- the Type is the type of p (equivalently, the result type of e)
781
782 groupEquations :: [EquationInfo] -> [[(PatGroup, EquationInfo)]]
783 -- If the result is of form [g1, g2, g3], 
784 -- (a) all the (pg,eq) pairs in g1 have the same pg
785 -- (b) none of the gi are empty
786 -- The ordering of equations is unchanged
787 groupEquations eqns
788   = runs same_gp [(patGroup (firstPat eqn), eqn) | eqn <- eqns]
789   where
790     same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool
791     (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2
792
793 subGroup :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]]
794 -- Input is a particular group.  The result sub-groups the 
795 -- equations by with particular constructor, literal etc they match.
796 -- Each sub-list in the result has the same PatGroup
797 -- See Note [Take care with pattern order]
798 subGroup group 
799     = map reverse $ Map.elems $ foldl accumulate Map.empty group
800   where
801     accumulate pg_map (pg, eqn)
802       = case Map.lookup pg pg_map of
803           Just eqns -> Map.insert pg (eqn:eqns) pg_map
804           Nothing   -> Map.insert pg [eqn]      pg_map
805
806     -- pg_map :: Map a [EquationInfo]
807     -- Equations seen so far in reverse order of appearance
808 \end{code}
809
810 Note [Take care with pattern order]
811 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
812 In the subGroup function we must be very careful about pattern re-ordering,
813 Consider the patterns [ (True, Nothing), (False, x), (True, y) ]
814 Then in bringing together the patterns for True, we must not 
815 swap the Nothing and y!
816
817
818 \begin{code}
819 sameGroup :: PatGroup -> PatGroup -> Bool
820 -- Same group means that a single case expression 
821 -- or test will suffice to match both, *and* the order
822 -- of testing within the group is insignificant.
823 sameGroup PgAny      PgAny      = True
824 sameGroup PgBang     PgBang     = True
825 sameGroup (PgCon _)  (PgCon _)  = True          -- One case expression
826 sameGroup (PgLit _)  (PgLit _)  = True          -- One case expression
827 sameGroup (PgN l1)   (PgN l2)   = l1==l2        -- Order is significant
828 sameGroup (PgNpK l1) (PgNpK l2) = l1==l2        -- See Note [Grouping overloaded literal patterns]
829 sameGroup (PgCo t1)  (PgCo t2)  = t1 `eqType` t2
830         -- CoPats are in the same goup only if the type of the
831         -- enclosed pattern is the same. The patterns outside the CoPat
832         -- always have the same type, so this boils down to saying that
833         -- the two coercions are identical.
834 sameGroup (PgView e1 t1) (PgView e2 t2) = viewLExprEq (e1,t1) (e2,t2) 
835        -- ViewPats are in the same gorup iff the expressions
836        -- are "equal"---conservatively, we use syntactic equality
837 sameGroup _          _          = False
838
839 -- An approximation of syntactic equality used for determining when view
840 -- exprs are in the same group.
841 -- This function can always safely return false;
842 -- but doing so will result in the application of the view function being repeated.
843 --
844 -- Currently: compare applications of literals and variables
845 --            and anything else that we can do without involving other
846 --            HsSyn types in the recursion
847 --
848 -- NB we can't assume that the two view expressions have the same type.  Consider
849 --   f (e1 -> True) = ...
850 --   f (e2 -> "hi") = ...
851 viewLExprEq :: (LHsExpr Id,Type) -> (LHsExpr Id,Type) -> Bool
852 viewLExprEq (e1,_) (e2,_) = lexp e1 e2
853   where
854     lexp :: LHsExpr Id -> LHsExpr Id -> Bool
855     lexp e e' = exp (unLoc e) (unLoc e')
856
857     ---------
858     exp :: HsExpr Id -> HsExpr Id -> Bool
859     -- real comparison is on HsExpr's
860     -- strip parens 
861     exp (HsPar (L _ e)) e'   = exp e e'
862     exp e (HsPar (L _ e'))   = exp e e'
863     -- because the expressions do not necessarily have the same type,
864     -- we have to compare the wrappers
865     exp (HsWrap h e) (HsWrap h' e') = wrap h h' && exp e e'
866     exp (HsVar i) (HsVar i') =  i == i' 
867     -- the instance for IPName derives using the id, so this works if the
868     -- above does
869     exp (HsIPVar i) (HsIPVar i') = i == i' 
870     exp (HsOverLit l) (HsOverLit l') = 
871         -- Overloaded lits are equal if they have the same type
872         -- and the data is the same.
873         -- this is coarser than comparing the SyntaxExpr's in l and l',
874         -- which resolve the overloading (e.g., fromInteger 1),
875         -- because these expressions get written as a bunch of different variables
876         -- (presumably to improve sharing)
877         eqType (overLitType l) (overLitType l') && l == l'
878     exp (HsApp e1 e2) (HsApp e1' e2') = lexp e1 e1' && lexp e2 e2'
879     -- the fixities have been straightened out by now, so it's safe
880     -- to ignore them?
881     exp (OpApp l o _ ri) (OpApp l' o' _ ri') = 
882         lexp l l' && lexp o o' && lexp ri ri'
883     exp (NegApp e n) (NegApp e' n') = lexp e e' && exp n n'
884     exp (SectionL e1 e2) (SectionL e1' e2') = 
885         lexp e1 e1' && lexp e2 e2'
886     exp (SectionR e1 e2) (SectionR e1' e2') = 
887         lexp e1 e1' && lexp e2 e2'
888     exp (ExplicitTuple es1 _) (ExplicitTuple es2 _) =
889         eq_list tup_arg es1 es2
890     exp (HsIf _ e e1 e2) (HsIf _ e' e1' e2') =
891         lexp e e' && lexp e1 e1' && lexp e2 e2'
892
893     -- Enhancement: could implement equality for more expressions
894     --   if it seems useful
895     -- But no need for HsLit, ExplicitList, ExplicitTuple, 
896     -- because they cannot be functions
897     exp _ _  = False
898
899     ---------
900     tup_arg (Present e1) (Present e2) = lexp e1 e2
901     tup_arg (Missing t1) (Missing t2) = eqType t1 t2
902     tup_arg _ _ = False
903
904     ---------
905     wrap :: HsWrapper -> HsWrapper -> Bool
906     -- Conservative, in that it demands that wrappers be
907     -- syntactically identical and doesn't look under binders
908     --
909     -- Coarser notions of equality are possible
910     -- (e.g., reassociating compositions,
911     --        equating different ways of writing a coercion)
912     wrap WpHole WpHole = True
913     wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2'
914     wrap (WpCast c)  (WpCast c')     = coreEqCoercion c c'
915     wrap (WpEvApp et1) (WpEvApp et2) = ev_term et1 et2
916     wrap (WpTyApp t) (WpTyApp t')    = eqType t t'
917     -- Enhancement: could implement equality for more wrappers
918     --   if it seems useful (lams and lets)
919     wrap _ _ = False
920
921     ---------
922     ev_term :: EvTerm -> EvTerm -> Bool
923     ev_term (EvId a)       (EvId b)       = a==b
924     ev_term (EvCoercion a) (EvCoercion b) = coreEqCoercion a b
925     ev_term _ _ = False 
926
927     ---------
928     eq_list :: (a->a->Bool) -> [a] -> [a] -> Bool
929     eq_list _  []     []     = True
930     eq_list _  []     (_:_)  = False
931     eq_list _  (_:_)  []     = False
932     eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys
933
934 patGroup :: Pat Id -> PatGroup
935 patGroup (WildPat {})                 = PgAny
936 patGroup (BangPat {})                 = PgBang  
937 patGroup (ConPatOut { pat_con = dc }) = PgCon (unLoc dc)
938 patGroup (LitPat lit)                 = PgLit (hsLitKey lit)
939 patGroup (NPat olit mb_neg _)         = PgN   (hsOverLitKey olit (isJust mb_neg))
940 patGroup (NPlusKPat _ olit _ _)       = PgNpK (hsOverLitKey olit False)
941 patGroup (CoPat _ p _)                = PgCo  (hsPatType p)     -- Type of innelexp pattern
942 patGroup (ViewPat expr p _)               = PgView expr (hsPatType (unLoc p))
943 patGroup pat = pprPanic "patGroup" (ppr pat)
944 \end{code}
945
946 Note [Grouping overloaded literal patterns]
947 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
948 WATCH OUT!  Consider
949
950         f (n+1) = ...
951         f (n+2) = ...
952         f (n+1) = ...
953
954 We can't group the first and third together, because the second may match 
955 the same thing as the first.  Same goes for *overloaded* literal patterns
956         f 1 True = ...
957         f 2 False = ...
958         f 1 False = ...
959 If the first arg matches '1' but the second does not match 'True', we
960 cannot jump to the third equation!  Because the same argument might
961 match '2'!
962 Hence we don't regard 1 and 2, or (n+1) and (n+2), as part of the same group.
963