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