Add OverloadedLists, allowing list syntax to be overloaded
[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, dsExpr)
21
22 import DynFlags
23 import HsSyn            
24 import TcHsSyn
25 import TcEvidence
26 import TcRnMonad
27 import Check
28 import CoreSyn
29 import Literal
30 import CoreUtils
31 import MkCore
32 import DsMonad
33 import DsBinds
34 import DsGRHSs
35 import DsUtils
36 import Id
37 import DataCon
38 import MatchCon
39 import MatchLit
40 import Type
41 import TysWiredIn
42 import ListSetOps
43 import SrcLoc
44 import Maybes
45 import Util
46 import Name
47 import Outputable
48 import BasicTypes ( boxityNormalTupleSort )
49 import FastString
50
51 import Control.Monad( when )
52 import qualified Data.Map as Map
53 \end{code}
54
55 This function is a wrapper of @match@, it must be called from all the parts where 
56 it was called match, but only substitutes the first call, ....
57 if the associated flags are declared, warnings will be issued.
58 It can not be called matchWrapper because this name already exists :-(
59
60 JJCQ 30-Nov-1997
61
62 \begin{code}
63 matchCheck ::  DsMatchContext
64             -> [Id]             -- Vars rep'ing the exprs we're matching with
65             -> Type             -- Type of the case expression
66             -> [EquationInfo]   -- Info about patterns, etc. (type synonym below)
67             -> DsM MatchResult  -- Desugared result!
68
69 matchCheck ctx vars ty qs
70   = do { dflags <- getDynFlags
71        ; matchCheck_really dflags ctx vars ty qs }
72
73 matchCheck_really :: DynFlags
74                   -> DsMatchContext
75                   -> [Id]
76                   -> Type
77                   -> [EquationInfo]
78                   -> DsM MatchResult
79 matchCheck_really dflags ctx@(DsMatchContext hs_ctx _) vars ty qs
80   = do { when shadow (dsShadowWarn ctx eqns_shadow)
81        ; when incomplete (dsIncompleteWarn ctx pats)
82        ; match vars ty qs }
83   where 
84     (pats, eqns_shadow) = check qs
85     incomplete = incomplete_flag hs_ctx && (notNull pats)
86     shadow     = wopt Opt_WarnOverlappingPatterns dflags
87                  && notNull eqns_shadow
88
89     incomplete_flag :: HsMatchContext id -> Bool
90     incomplete_flag (FunRhs {})   = wopt Opt_WarnIncompletePatterns dflags
91     incomplete_flag CaseAlt       = wopt Opt_WarnIncompletePatterns dflags
92     incomplete_flag IfAlt         = False
93
94     incomplete_flag LambdaExpr    = wopt Opt_WarnIncompleteUniPatterns dflags
95     incomplete_flag PatBindRhs    = wopt Opt_WarnIncompleteUniPatterns dflags
96     incomplete_flag ProcExpr      = wopt Opt_WarnIncompleteUniPatterns dflags
97
98     incomplete_flag RecUpd        = wopt Opt_WarnIncompletePatternsRecUpd dflags
99
100     incomplete_flag ThPatQuote    = False
101     incomplete_flag (StmtCtxt {}) = False  -- Don't warn about incomplete patterns
102                                            -- in list comprehensions, pattern guards
103                                            -- etc.  They are often *supposed* to be
104                                            -- incomplete 
105 \end{code}
106
107 This variable shows the maximum number of lines of output generated for warnings.
108 It will limit the number of patterns/equations displayed to@ maximum_output@.
109
110 (ToDo: add command-line option?)
111
112 \begin{code}
113 maximum_output :: Int
114 maximum_output = 4
115 \end{code}
116
117 The next two functions create the warning message.
118
119 \begin{code}
120 dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM ()
121 dsShadowWarn ctx@(DsMatchContext kind loc) qs
122   = putSrcSpanDs loc (warnDs warn)
123   where
124     warn | qs `lengthExceeds` maximum_output
125          = pp_context ctx (ptext (sLit "are overlapped"))
126                       (\ f -> vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$
127                       ptext (sLit "..."))
128          | otherwise
129          = pp_context ctx (ptext (sLit "are overlapped"))
130                       (\ f -> vcat $ map (ppr_eqn f kind) qs)
131
132
133 dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM ()
134 dsIncompleteWarn ctx@(DsMatchContext kind loc) pats 
135   = putSrcSpanDs loc (warnDs warn)
136         where
137           warn = pp_context ctx (ptext (sLit "are non-exhaustive"))
138                             (\_ -> hang (ptext (sLit "Patterns not matched:"))
139                                    4 ((vcat $ map (ppr_incomplete_pats kind)
140                                                   (take maximum_output pats))
141                                       $$ dots))
142
143           dots | pats `lengthExceeds` maximum_output = ptext (sLit "...")
144                | otherwise                           = empty
145
146 pp_context :: DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
147 pp_context (DsMatchContext kind _loc) msg rest_of_msg_fun
148   = vcat [ptext (sLit "Pattern match(es)") <+> msg,
149           sep [ptext (sLit "In") <+> ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]]
150   where
151     (ppr_match, pref)
152         = case kind of
153              FunRhs fun _ -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)
154              _            -> (pprMatchContext kind, \ pp -> pp)
155
156 ppr_pats :: Outputable a => [a] -> SDoc
157 ppr_pats pats = sep (map ppr pats)
158
159 ppr_shadow_pats :: HsMatchContext Name -> [Pat Id] -> SDoc
160 ppr_shadow_pats kind pats
161   = sep [ppr_pats pats, matchSeparator kind, ptext (sLit "...")]
162
163 ppr_incomplete_pats :: HsMatchContext Name -> ExhaustivePat -> SDoc
164 ppr_incomplete_pats _ (pats,[]) = ppr_pats pats
165 ppr_incomplete_pats _ (pats,constraints) =
166                          sep [ppr_pats pats, ptext (sLit "with"), 
167                               sep (map ppr_constraint constraints)]
168
169 ppr_constraint :: (Name,[HsLit]) -> SDoc
170 ppr_constraint (var,pats) = sep [ppr var, ptext (sLit "`notElem`"), ppr pats]
171
172 ppr_eqn :: (SDoc -> SDoc) -> HsMatchContext Name -> EquationInfo -> SDoc
173 ppr_eqn prefixF kind eqn = prefixF (ppr_shadow_pats kind (eqn_pats eqn))
174 \end{code}
175
176
177 %************************************************************************
178 %*                                                                      *
179                 The main matching function
180 %*                                                                      *
181 %************************************************************************
182
183 The function @match@ is basically the same as in the Wadler chapter,
184 except it is monadised, to carry around the name supply, info about
185 annotations, etc.
186
187 Notes on @match@'s arguments, assuming $m$ equations and $n$ patterns:
188 \begin{enumerate}
189 \item
190 A list of $n$ variable names, those variables presumably bound to the
191 $n$ expressions being matched against the $n$ patterns.  Using the
192 list of $n$ expressions as the first argument showed no benefit and
193 some inelegance.
194
195 \item
196 The second argument, a list giving the ``equation info'' for each of
197 the $m$ equations:
198 \begin{itemize}
199 \item
200 the $n$ patterns for that equation, and
201 \item
202 a list of Core bindings [@(Id, CoreExpr)@ pairs] to be ``stuck on
203 the front'' of the matching code, as in:
204 \begin{verbatim}
205 let <binds>
206 in  <matching-code>
207 \end{verbatim}
208 \item
209 and finally: (ToDo: fill in)
210
211 The right way to think about the ``after-match function'' is that it
212 is an embryonic @CoreExpr@ with a ``hole'' at the end for the
213 final ``else expression''.
214 \end{itemize}
215
216 There is a type synonym, @EquationInfo@, defined in module @DsUtils@.
217
218 An experiment with re-ordering this information about equations (in
219 particular, having the patterns available in column-major order)
220 showed no benefit.
221
222 \item
223 A default expression---what to evaluate if the overall pattern-match
224 fails.  This expression will (almost?) always be
225 a measly expression @Var@, unless we know it will only be used once
226 (as we do in @glue_success_exprs@).
227
228 Leaving out this third argument to @match@ (and slamming in lots of
229 @Var "fail"@s) is a positively {\em bad} idea, because it makes it
230 impossible to share the default expressions.  (Also, it stands no
231 chance of working in our post-upheaval world of @Locals@.)
232 \end{enumerate}
233
234 Note: @match@ is often called via @matchWrapper@ (end of this module),
235 a function that does much of the house-keeping that goes with a call
236 to @match@.
237
238 It is also worth mentioning the {\em typical} way a block of equations
239 is desugared with @match@.  At each stage, it is the first column of
240 patterns that is examined.  The steps carried out are roughly:
241 \begin{enumerate}
242 \item
243 Tidy the patterns in column~1 with @tidyEqnInfo@ (this may add
244 bindings to the second component of the equation-info):
245 \begin{itemize}
246 \item
247 Remove the `as' patterns from column~1.
248 \item
249 Make all constructor patterns in column~1 into @ConPats@, notably
250 @ListPats@ and @TuplePats@.
251 \item
252 Handle any irrefutable (or ``twiddle'') @LazyPats@.
253 \end{itemize}
254 \item
255 Now {\em unmix} the equations into {\em blocks} [w\/ local function
256 @unmix_eqns@], in which the equations in a block all have variable
257 patterns in column~1, or they all have constructor patterns in ...
258 (see ``the mixture rule'' in SLPJ).
259 \item
260 Call @matchEqnBlock@ on each block of equations; it will do the
261 appropriate thing for each kind of column-1 pattern, usually ending up
262 in a recursive call to @match@.
263 \end{enumerate}
264
265 We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87)
266 than the Wadler-chapter code for @match@ (p.~93, first @match@ clause).
267 And gluing the ``success expressions'' together isn't quite so pretty.
268
269 This (more interesting) clause of @match@ uses @tidy_and_unmix_eqns@
270 (a)~to get `as'- and `twiddle'-patterns out of the way (tidying), and
271 (b)~to do ``the mixture rule'' (SLPJ, p.~88) [which really {\em
272 un}mixes the equations], producing a list of equation-info
273 blocks, each block having as its first column of patterns either all
274 constructors, or all variables (or similar beasts), etc.
275
276 @match_unmixed_eqn_blks@ simply takes the place of the @foldr@ in the
277 Wadler-chapter @match@ (p.~93, last clause), and @match_unmixed_blk@
278 corresponds roughly to @matchVarCon@.
279
280 \begin{code}
281 match :: [Id]             -- Variables rep\'ing the exprs we\'re matching with
282       -> Type             -- Type of the case expression
283       -> [EquationInfo]   -- Info about patterns, etc. (type synonym below)
284       -> DsM MatchResult  -- Desugared result!
285
286 match [] ty eqns
287   = ASSERT2( not (null eqns), ppr ty )
288     return (foldr1 combineMatchResults match_results)
289   where
290     match_results = [ ASSERT( null (eqn_pats eqn) ) 
291                       eqn_rhs eqn
292                     | eqn <- eqns ]
293
294 match vars@(v:_) ty eqns    -- Eqns *can* be empty
295   = do  { dflags <- getDynFlags
296         ;       -- Tidy the first pattern, generating
297                 -- auxiliary bindings if necessary
298           (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns
299
300                 -- Group the equations and match each group in turn
301         ; let grouped = groupEquations dflags tidy_eqns
302
303          -- print the view patterns that are commoned up to help debug
304         ; whenDOptM Opt_D_dump_view_pattern_commoning (debug grouped)
305
306         ; match_results <- match_groups grouped
307         ; return (adjustMatchResult (foldr (.) id aux_binds) $
308                   foldr1 combineMatchResults match_results) }
309   where
310     dropGroup :: [(PatGroup,EquationInfo)] -> [EquationInfo]
311     dropGroup = map snd
312
313     match_groups :: [[(PatGroup,EquationInfo)]] -> DsM [MatchResult]
314     -- Result list of [MatchResult] is always non-empty
315     match_groups [] = matchEmpty v ty
316     match_groups gs = mapM match_group gs
317
318     match_group :: [(PatGroup,EquationInfo)] -> DsM MatchResult
319     match_group [] = panic "match_group"
320     match_group eqns@((group,_) : _)
321         = case group of
322             PgCon _    -> matchConFamily  vars ty (subGroup [(c,e) | (PgCon c, e) <- 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* deugar 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_ty     = mkListTy ty
558     list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] list_ty)
559                         (mkNilPat list_ty)
560                         pats
561
562 -- Introduce fake parallel array constructors to be able to handle parallel
563 -- arrays with the existing machinery for constructor pattern
564 tidy1 _ (PArrPat pats ty)
565   = return (idDsWrapper, unLoc parrConPat)
566   where
567     arity      = length pats
568     parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty)
569
570 tidy1 _ (TuplePat pats boxity ty)
571   = return (idDsWrapper, unLoc tuple_ConPat)
572   where
573     arity = length pats
574     tuple_ConPat = mkPrefixConPat (tupleCon (boxityNormalTupleSort boxity) arity) pats ty
575
576 -- LitPats: we *might* be able to replace these w/ a simpler form
577 tidy1 _ (LitPat lit)
578   = return (idDsWrapper, tidyLitPat lit)
579
580 -- NPats: we *might* be able to replace these w/ a simpler form
581 tidy1 _ (NPat lit mb_neg eq)
582   = return (idDsWrapper, tidyNPat tidyLitPat lit mb_neg eq)
583
584 -- Everything else goes through unchanged...
585
586 tidy1 _ non_interesting_pat
587   = return (idDsWrapper, non_interesting_pat)
588
589 --------------------
590 tidy_bang_pat :: Id -> SrcSpan -> Pat Id -> DsM (DsWrapper, Pat Id)
591 -- BangPatterns: Pattern matching is already strict in constructors,
592 -- tuples etc, so the last case strips off the bang for those patterns.
593
594 -- Discard bang around strict pattern
595 tidy_bang_pat v _ p@(ListPat {})   = tidy1 v p
596 tidy_bang_pat v _ p@(TuplePat {})  = tidy1 v p
597 tidy_bang_pat v _ p@(PArrPat {})   = tidy1 v p
598 tidy_bang_pat v _ p@(ConPatOut {}) = tidy1 v p
599 tidy_bang_pat v _ p@(LitPat {})    = tidy1 v p
600
601 -- Discard lazy/par/sig under a bang
602 tidy_bang_pat v _ (LazyPat (L l p))     = tidy_bang_pat v l p
603 tidy_bang_pat v _ (ParPat (L l p))      = tidy_bang_pat v l p
604 tidy_bang_pat v _ (SigPatOut (L l p) _) = tidy_bang_pat v l p
605
606 -- Push the bang-pattern inwards, in the hope that
607 -- it may disappear next time 
608 tidy_bang_pat v l (AsPat v' p)  = tidy1 v (AsPat v' (L l (BangPat p)))
609 tidy_bang_pat v l (CoPat w p t) = tidy1 v (CoPat w (BangPat (L l p)) t)
610
611 -- Default case, leave the bang there:
612 -- VarPat, WildPat, ViewPat, NPat, NPlusKPat
613 tidy_bang_pat _ l p = return (idDsWrapper, BangPat (L l p))
614   -- NB: SigPatIn, ConPatIn should not happen
615 \end{code}
616
617 \noindent
618 {\bf Previous @matchTwiddled@ stuff:}
619
620 Now we get to the only interesting part; note: there are choices for
621 translation [from Simon's notes]; translation~1:
622 \begin{verbatim}
623 deTwiddle [s,t] e
624 \end{verbatim}
625 returns
626 \begin{verbatim}
627 [ w = e,
628   s = case w of [s,t] -> s
629   t = case w of [s,t] -> t
630 ]
631 \end{verbatim}
632
633 Here \tr{w} is a fresh variable, and the \tr{w}-binding prevents multiple
634 evaluation of \tr{e}.  An alternative translation (No.~2):
635 \begin{verbatim}
636 [ w = case e of [s,t] -> (s,t)
637   s = case w of (s,t) -> s
638   t = case w of (s,t) -> t
639 ]
640 \end{verbatim}
641
642 %************************************************************************
643 %*                                                                      *
644 \subsubsection[improved-unmixing]{UNIMPLEMENTED idea for improved unmixing}
645 %*                                                                      *
646 %************************************************************************
647
648 We might be able to optimise unmixing when confronted by
649 only-one-constructor-possible, of which tuples are the most notable
650 examples.  Consider:
651 \begin{verbatim}
652 f (a,b,c) ... = ...
653 f d ... (e:f) = ...
654 f (g,h,i) ... = ...
655 f j ...       = ...
656 \end{verbatim}
657 This definition would normally be unmixed into four equation blocks,
658 one per equation.  But it could be unmixed into just one equation
659 block, because if the one equation matches (on the first column),
660 the others certainly will.
661
662 You have to be careful, though; the example
663 \begin{verbatim}
664 f j ...       = ...
665 -------------------
666 f (a,b,c) ... = ...
667 f d ... (e:f) = ...
668 f (g,h,i) ... = ...
669 \end{verbatim}
670 {\em must} be broken into two blocks at the line shown; otherwise, you
671 are forcing unnecessary evaluation.  In any case, the top-left pattern
672 always gives the cue.  You could then unmix blocks into groups of...
673 \begin{description}
674 \item[all variables:]
675 As it is now.
676 \item[constructors or variables (mixed):]
677 Need to make sure the right names get bound for the variable patterns.
678 \item[literals or variables (mixed):]
679 Presumably just a variant on the constructor case (as it is now).
680 \end{description}
681
682 %************************************************************************
683 %*                                                                      *
684 %*  matchWrapper: a convenient way to call @match@                      *
685 %*                                                                      *
686 %************************************************************************
687 \subsection[matchWrapper]{@matchWrapper@: a convenient interface to @match@}
688
689 Calls to @match@ often involve similar (non-trivial) work; that work
690 is collected here, in @matchWrapper@.  This function takes as
691 arguments:
692 \begin{itemize}
693 \item
694 Typchecked @Matches@ (of a function definition, or a case or lambda
695 expression)---the main input;
696 \item
697 An error message to be inserted into any (runtime) pattern-matching
698 failure messages.
699 \end{itemize}
700
701 As results, @matchWrapper@ produces:
702 \begin{itemize}
703 \item
704 A list of variables (@Locals@) that the caller must ``promise'' to
705 bind to appropriate values; and
706 \item
707 a @CoreExpr@, the desugared output (main result).
708 \end{itemize}
709
710 The main actions of @matchWrapper@ include:
711 \begin{enumerate}
712 \item
713 Flatten the @[TypecheckedMatch]@ into a suitable list of
714 @EquationInfo@s.
715 \item
716 Create as many new variables as there are patterns in a pattern-list
717 (in any one of the @EquationInfo@s).
718 \item
719 Create a suitable ``if it fails'' expression---a call to @error@ using
720 the error-string input; the {\em type} of this fail value can be found
721 by examining one of the RHS expressions in one of the @EquationInfo@s.
722 \item
723 Call @match@ with all of this information!
724 \end{enumerate}
725
726 \begin{code}
727 matchWrapper :: HsMatchContext Name             -- For shadowing warning messages
728              -> MatchGroup Id (LHsExpr Id)      -- Matches being desugared
729              -> DsM ([Id], CoreExpr)            -- Results
730 \end{code}
731
732  There is one small problem with the Lambda Patterns, when somebody
733  writes something similar to:
734 \begin{verbatim}
735     (\ (x:xs) -> ...)
736 \end{verbatim}
737  he/she don't want a warning about incomplete patterns, that is done with 
738  the flag @opt_WarnSimplePatterns@.
739  This problem also appears in the:
740 \begin{itemize}
741 \item @do@ patterns, but if the @do@ can fail
742       it creates another equation if the match can fail
743       (see @DsExpr.doDo@ function)
744 \item @let@ patterns, are treated by @matchSimply@
745    List Comprension Patterns, are treated by @matchSimply@ also
746 \end{itemize}
747
748 We can't call @matchSimply@ with Lambda patterns,
749 due to the fact that lambda patterns can have more than
750 one pattern, and match simply only accepts one pattern.
751
752 JJQC 30-Nov-1997
753
754 \begin{code}
755 matchWrapper ctxt (MG { mg_alts = matches
756                       , mg_arg_tys = arg_tys
757                       , mg_res_ty = rhs_ty })
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 <- matchEquations ctxt new_vars eqns_info rhs_ty
763         ; return (new_vars, result_expr) }
764   where
765     mk_eqn_info (L _ (Match pats _ grhss))
766       = do { let upats = map unLoc pats
767            ; match_result <- dsGRHSs ctxt upats grhss rhs_ty
768            ; return (EqnInfo { eqn_pats = upats, eqn_rhs  = match_result}) }
769
770
771 matchEquations  :: HsMatchContext Name
772                 -> [Id] -> [EquationInfo] -> Type
773                 -> DsM CoreExpr
774 matchEquations ctxt vars eqns_info rhs_ty
775   = do  { locn <- getSrcSpanDs
776         ; let   ds_ctxt   = DsMatchContext ctxt locn
777                 error_doc = matchContextErrString ctxt
778
779         ; match_result <- matchCheck ds_ctxt vars rhs_ty eqns_info
780
781         ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_doc
782         ; extractMatchResult match_result fail_expr }
783 \end{code}
784
785 %************************************************************************
786 %*                                                                      *
787 \subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern}
788 %*                                                                      *
789 %************************************************************************
790
791 @mkSimpleMatch@ is a wrapper for @match@ which deals with the
792 situation where we want to match a single expression against a single
793 pattern. It returns an expression.
794
795 \begin{code}
796 matchSimply :: CoreExpr                 -- Scrutinee
797             -> HsMatchContext Name      -- Match kind
798             -> LPat Id                  -- Pattern it should match
799             -> CoreExpr                 -- Return this if it matches
800             -> CoreExpr                 -- Return this if it doesn't
801             -> DsM CoreExpr
802 -- Do not warn about incomplete patterns; see matchSinglePat comments
803 matchSimply scrut hs_ctx pat result_expr fail_expr = do
804     let
805       match_result = cantFailMatchResult result_expr
806       rhs_ty       = exprType fail_expr
807         -- Use exprType of fail_expr, because won't refine in the case of failure!
808     match_result' <- matchSinglePat scrut hs_ctx pat rhs_ty match_result
809     extractMatchResult match_result' fail_expr
810
811 matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat Id
812                -> Type -> MatchResult -> DsM MatchResult
813 -- Do not warn about incomplete patterns
814 -- Used for things like [ e | pat <- stuff ], where 
815 -- incomplete patterns are just fine
816 matchSinglePat (Var var) ctx (L _ pat) ty match_result 
817   = do { locn <- getSrcSpanDs
818        ; matchCheck (DsMatchContext ctx locn)
819                     [var] ty  
820                     [EqnInfo { eqn_pats = [pat], eqn_rhs  = match_result }] }
821
822 matchSinglePat scrut hs_ctx pat ty match_result
823   = do { var <- selectSimpleMatchVarL pat
824        ; match_result' <- matchSinglePat (Var var) hs_ctx pat ty match_result
825        ; return (adjustMatchResult (bindNonRec var scrut) match_result') }
826 \end{code}
827
828
829 %************************************************************************
830 %*                                                                      *
831                 Pattern classification
832 %*                                                                      *
833 %************************************************************************
834
835 \begin{code}
836 data PatGroup
837   = PgAny               -- Immediate match: variables, wildcards, 
838                         --                  lazy patterns
839   | PgCon DataCon       -- Constructor patterns (incl list, tuple)
840   | PgLit Literal       -- Literal patterns
841   | PgN   Literal       -- Overloaded literals
842   | PgNpK Literal       -- n+k patterns
843   | PgBang              -- Bang patterns
844   | PgCo Type           -- Coercion patterns; the type is the type
845                         --      of the pattern *inside*
846   | PgView (LHsExpr Id) -- view pattern (e -> p):
847                         -- the LHsExpr is the expression e
848            Type         -- the Type is the type of p (equivalently, the result type of e)
849   | PgOverloadedList
850   
851 groupEquations :: DynFlags -> [EquationInfo] -> [[(PatGroup, EquationInfo)]]
852 -- If the result is of form [g1, g2, g3], 
853 -- (a) all the (pg,eq) pairs in g1 have the same pg
854 -- (b) none of the gi are empty
855 -- The ordering of equations is unchanged
856 groupEquations dflags eqns
857   = runs same_gp [(patGroup dflags (firstPat eqn), eqn) | eqn <- eqns]
858   where
859     same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool
860     (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2
861
862 subGroup :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]]
863 -- Input is a particular group.  The result sub-groups the 
864 -- equations by with particular constructor, literal etc they match.
865 -- Each sub-list in the result has the same PatGroup
866 -- See Note [Take care with pattern order]
867 subGroup group 
868     = map reverse $ Map.elems $ foldl accumulate Map.empty group
869   where
870     accumulate pg_map (pg, eqn)
871       = case Map.lookup pg pg_map of
872           Just eqns -> Map.insert pg (eqn:eqns) pg_map
873           Nothing   -> Map.insert pg [eqn]      pg_map
874
875     -- pg_map :: Map a [EquationInfo]
876     -- Equations seen so far in reverse order of appearance
877 \end{code}
878
879 Note [Take care with pattern order]
880 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
881 In the subGroup function we must be very careful about pattern re-ordering,
882 Consider the patterns [ (True, Nothing), (False, x), (True, y) ]
883 Then in bringing together the patterns for True, we must not 
884 swap the Nothing and y!
885
886
887 \begin{code}
888 sameGroup :: PatGroup -> PatGroup -> Bool
889 -- Same group means that a single case expression 
890 -- or test will suffice to match both, *and* the order
891 -- of testing within the group is insignificant.
892 sameGroup PgAny      PgAny      = True
893 sameGroup PgBang     PgBang     = True
894 sameGroup (PgCon _)  (PgCon _)  = True          -- One case expression
895 sameGroup (PgLit _)  (PgLit _)  = True          -- One case expression
896 sameGroup (PgN l1)   (PgN l2)   = l1==l2        -- Order is significant
897 sameGroup (PgNpK l1) (PgNpK l2) = l1==l2        -- See Note [Grouping overloaded literal patterns]
898 sameGroup (PgCo t1)  (PgCo t2)  = t1 `eqType` t2
899         -- CoPats are in the same goup only if the type of the
900         -- enclosed pattern is the same. The patterns outside the CoPat
901         -- always have the same type, so this boils down to saying that
902         -- the two coercions are identical.
903 sameGroup (PgView e1 t1) (PgView e2 t2) = viewLExprEq (e1,t1) (e2,t2) 
904        -- ViewPats are in the same group iff the expressions
905        -- are "equal"---conservatively, we use syntactic equality
906 sameGroup _          _          = False
907
908 -- An approximation of syntactic equality used for determining when view
909 -- exprs are in the same group.
910 -- This function can always safely return false;
911 -- but doing so will result in the application of the view function being repeated.
912 --
913 -- Currently: compare applications of literals and variables
914 --            and anything else that we can do without involving other
915 --            HsSyn types in the recursion
916 --
917 -- NB we can't assume that the two view expressions have the same type.  Consider
918 --   f (e1 -> True) = ...
919 --   f (e2 -> "hi") = ...
920 viewLExprEq :: (LHsExpr Id,Type) -> (LHsExpr Id,Type) -> Bool
921 viewLExprEq (e1,_) (e2,_) = lexp e1 e2
922   where
923     lexp :: LHsExpr Id -> LHsExpr Id -> Bool
924     lexp e e' = exp (unLoc e) (unLoc e')
925
926     ---------
927     exp :: HsExpr Id -> HsExpr Id -> Bool
928     -- real comparison is on HsExpr's
929     -- strip parens 
930     exp (HsPar (L _ e)) e'   = exp e e'
931     exp e (HsPar (L _ e'))   = exp e e'
932     -- because the expressions do not necessarily have the same type,
933     -- we have to compare the wrappers
934     exp (HsWrap h e) (HsWrap h' e') = wrap h h' && exp e e'
935     exp (HsVar i) (HsVar i') =  i == i' 
936     -- the instance for IPName derives using the id, so this works if the
937     -- above does
938     exp (HsIPVar i) (HsIPVar i') = i == i' 
939     exp (HsOverLit l) (HsOverLit l') = 
940         -- Overloaded lits are equal if they have the same type
941         -- and the data is the same.
942         -- this is coarser than comparing the SyntaxExpr's in l and l',
943         -- which resolve the overloading (e.g., fromInteger 1),
944         -- because these expressions get written as a bunch of different variables
945         -- (presumably to improve sharing)
946         eqType (overLitType l) (overLitType l') && l == l'
947     exp (HsApp e1 e2) (HsApp e1' e2') = lexp e1 e1' && lexp e2 e2'
948     -- the fixities have been straightened out by now, so it's safe
949     -- to ignore them?
950     exp (OpApp l o _ ri) (OpApp l' o' _ ri') = 
951         lexp l l' && lexp o o' && lexp ri ri'
952     exp (NegApp e n) (NegApp e' n') = lexp e e' && exp n n'
953     exp (SectionL e1 e2) (SectionL e1' e2') = 
954         lexp e1 e1' && lexp e2 e2'
955     exp (SectionR e1 e2) (SectionR e1' e2') = 
956         lexp e1 e1' && lexp e2 e2'
957     exp (ExplicitTuple es1 _) (ExplicitTuple es2 _) =
958         eq_list tup_arg es1 es2
959     exp (HsIf _ e e1 e2) (HsIf _ e' e1' e2') =
960         lexp e e' && lexp e1 e1' && lexp e2 e2'
961
962     -- Enhancement: could implement equality for more expressions
963     --   if it seems useful
964     -- But no need for HsLit, ExplicitList, ExplicitTuple, 
965     -- because they cannot be functions
966     exp _ _  = False
967
968     ---------
969     tup_arg (Present e1) (Present e2) = lexp e1 e2
970     tup_arg (Missing t1) (Missing t2) = eqType t1 t2
971     tup_arg _ _ = False
972
973     ---------
974     wrap :: HsWrapper -> HsWrapper -> Bool
975     -- Conservative, in that it demands that wrappers be
976     -- syntactically identical and doesn't look under binders
977     --
978     -- Coarser notions of equality are possible
979     -- (e.g., reassociating compositions,
980     --        equating different ways of writing a coercion)
981     wrap WpHole WpHole = True
982     wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2'
983     wrap (WpCast co)       (WpCast co')        = co `eq_co` 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 `eq_co` 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     ---------
1004     eq_co :: TcCoercion -> TcCoercion -> Bool 
1005     -- Just some simple cases
1006     eq_co (TcRefl t1)             (TcRefl t2)             = eqType t1 t2
1007     eq_co (TcCoVarCo v1)          (TcCoVarCo v2)          = v1==v2
1008     eq_co (TcSymCo co1)           (TcSymCo co2)           = co1 `eq_co` co2
1009     eq_co (TcTyConAppCo tc1 cos1) (TcTyConAppCo tc2 cos2) = tc1==tc2 && eq_list eq_co cos1 cos2
1010     eq_co _ _ = False
1011
1012 patGroup :: DynFlags -> Pat Id -> PatGroup
1013 patGroup _      (WildPat {})                 = PgAny
1014 patGroup _      (BangPat {})                 = PgBang
1015 patGroup _      (ConPatOut { pat_con = dc }) = PgCon (unLoc dc)
1016 patGroup dflags (LitPat lit)                 = PgLit (hsLitKey dflags lit)
1017 patGroup _      (NPat olit mb_neg _)         = PgN   (hsOverLitKey olit (isJust mb_neg))
1018 patGroup _      (NPlusKPat _ olit _ _)       = PgNpK (hsOverLitKey olit False)
1019 patGroup _      (CoPat _ p _)                = PgCo  (hsPatType p) -- Type of innelexp pattern
1020 patGroup _      (ViewPat expr p _)           = PgView expr (hsPatType (unLoc p))
1021 patGroup _      (ListPat _ _ (Just _))       = PgOverloadedList
1022 patGroup _      pat = pprPanic "patGroup" (ppr pat)
1023 \end{code}
1024
1025 Note [Grouping overloaded literal patterns]
1026 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1027 WATCH OUT!  Consider
1028
1029         f (n+1) = ...
1030         f (n+2) = ...
1031         f (n+1) = ...
1032
1033 We can't group the first and third together, because the second may match 
1034 the same thing as the first.  Same goes for *overloaded* literal patterns
1035         f 1 True = ...
1036         f 2 False = ...
1037         f 1 False = ...
1038 If the first arg matches '1' but the second does not match 'True', we
1039 cannot jump to the third equation!  Because the same argument might
1040 match '2'!
1041 Hence we don't regard 1 and 2, or (n+1) and (n+2), as part of the same group.
1042