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