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