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