Match.hs 42 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3 4
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

Simon Marlow's avatar
Simon Marlow committed
5 6

The @match@ function
Austin Seipp's avatar
Austin Seipp committed
7
-}
8

9 10
{-# LANGUAGE CPP #-}

11
module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat ) where
12

13
#include "HsVersions.h"
14

15
import {-#SOURCE#-} DsExpr (dsLExpr, dsExpr)
16

Simon Marlow's avatar
Simon Marlow committed
17
import DynFlags
18
import HsSyn
Simon Marlow's avatar
Simon Marlow committed
19
import TcHsSyn
20
import TcEvidence
21
import TcRnMonad
Simon Marlow's avatar
Simon Marlow committed
22
import Check
23
import CoreSyn
Simon Marlow's avatar
Simon Marlow committed
24 25
import Literal
import CoreUtils
26
import MkCore
27
import DsMonad
Simon Marlow's avatar
Simon Marlow committed
28 29
import DsBinds
import DsGRHSs
30
import DsUtils
Simon Marlow's avatar
Simon Marlow committed
31
import Id
cactus's avatar
cactus committed
32
import ConLike
Simon Marlow's avatar
Simon Marlow committed
33
import DataCon
cactus's avatar
cactus committed
34
import PatSyn
Simon Marlow's avatar
Simon Marlow committed
35 36 37
import MatchCon
import MatchLit
import Type
38
import TyCon( isNewTyCon )
Simon Marlow's avatar
Simon Marlow committed
39 40 41 42 43 44
import TysWiredIn
import ListSetOps
import SrcLoc
import Maybes
import Util
import Name
45
import Outputable
46
import BasicTypes ( isGenerated )
47
import FastString
48

49
import Control.Monad( when )
50
import qualified Data.Map as Map
51

Austin Seipp's avatar
Austin Seipp committed
52
{-
53
This function is a wrapper of @match@, it must be called from all the parts where
54
it was called match, but only substitutes the first call, ....
55 56 57 58
if the associated flags are declared, warnings will be issued.
It can not be called matchWrapper because this name already exists :-(

JJCQ 30-Nov-1997
Austin Seipp's avatar
Austin Seipp committed
59
-}
60

61
matchCheck ::  DsMatchContext
62
            -> [Id]             -- Vars rep'ing the exprs we're matching with
63
            -> Type             -- Type of the case expression
64 65 66
            -> [EquationInfo]   -- Info about patterns, etc. (type synonym below)
            -> DsM MatchResult  -- Desugared result!

67
matchCheck ctx vars ty qs
68
  = do { dflags <- getDynFlags
69
       ; matchCheck_really dflags ctx vars ty qs }
70

71 72 73 74 75 76
matchCheck_really :: DynFlags
                  -> DsMatchContext
                  -> [Id]
                  -> Type
                  -> [EquationInfo]
                  -> DsM MatchResult
77 78 79 80
matchCheck_really dflags ctx@(DsMatchContext hs_ctx _) vars ty qs
  = do { when shadow (dsShadowWarn ctx eqns_shadow)
       ; when incomplete (dsIncompleteWarn ctx pats)
       ; match vars ty qs }
81
  where
82
    (pats, eqns_shadow) = check qs
83
    incomplete = incomplete_flag hs_ctx && notNull pats
84
    shadow     = wopt Opt_WarnOverlappingPatterns dflags
85
              && notNull eqns_shadow
86 87

    incomplete_flag :: HsMatchContext id -> Bool
88 89
    incomplete_flag (FunRhs {})   = wopt Opt_WarnIncompletePatterns dflags
    incomplete_flag CaseAlt       = wopt Opt_WarnIncompletePatterns dflags
90
    incomplete_flag IfAlt         = False
91

92 93 94
    incomplete_flag LambdaExpr    = wopt Opt_WarnIncompleteUniPatterns dflags
    incomplete_flag PatBindRhs    = wopt Opt_WarnIncompleteUniPatterns dflags
    incomplete_flag ProcExpr      = wopt Opt_WarnIncompleteUniPatterns dflags
95

96
    incomplete_flag RecUpd        = wopt Opt_WarnIncompletePatternsRecUpd dflags
97

gmainland's avatar
gmainland committed
98
    incomplete_flag ThPatSplice   = False
cactus's avatar
cactus committed
99
    incomplete_flag PatSyn        = False
100 101
    incomplete_flag ThPatQuote    = False
    incomplete_flag (StmtCtxt {}) = False  -- Don't warn about incomplete patterns
102 103 104
                                           -- in list comprehensions, pattern guards
                                           -- etc.  They are often *supposed* to be
                                           -- incomplete
105

Austin Seipp's avatar
Austin Seipp committed
106
{-
107 108
This variable shows the maximum number of lines of output generated for warnings.
It will limit the number of patterns/equations displayed to@ maximum_output@.
109

sof's avatar
sof committed
110
(ToDo: add command-line option?)
Austin Seipp's avatar
Austin Seipp committed
111
-}
sof's avatar
sof committed
112

113
maximum_output :: Int
114 115
maximum_output = 4

Austin Seipp's avatar
Austin Seipp committed
116
-- The next two functions create the warning message.
117 118

dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM ()
119
dsShadowWarn ctx@(DsMatchContext kind loc) qs
120
  = putSrcSpanDs loc (warnDs warn)
121 122
  where
    warn | qs `lengthExceeds` maximum_output
Ian Lynagh's avatar
Ian Lynagh committed
123
         = pp_context ctx (ptext (sLit "are overlapped"))
124 125 126
                      (\ f -> vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$
                      ptext (sLit "..."))
         | otherwise
Ian Lynagh's avatar
Ian Lynagh committed
127
         = pp_context ctx (ptext (sLit "are overlapped"))
128
                      (\ f -> vcat $ map (ppr_eqn f kind) qs)
sof's avatar
sof committed
129

130 131

dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM ()
132
dsIncompleteWarn ctx@(DsMatchContext kind loc) pats
133
  = putSrcSpanDs loc (warnDs warn)
134 135
        where
          warn = pp_context ctx (ptext (sLit "are non-exhaustive"))
Ian Lynagh's avatar
Ian Lynagh committed
136
                            (\_ -> hang (ptext (sLit "Patterns not matched:"))
137 138 139
                                   4 ((vcat $ map (ppr_incomplete_pats kind)
                                                  (take maximum_output pats))
                                      $$ dots))
140

141 142
          dots | pats `lengthExceeds` maximum_output = ptext (sLit "...")
               | otherwise                           = empty
143

144
pp_context :: DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
145
pp_context (DsMatchContext kind _loc) msg rest_of_msg_fun
Ian Lynagh's avatar
Ian Lynagh committed
146
  = vcat [ptext (sLit "Pattern match(es)") <+> msg,
147
          sep [ptext (sLit "In") <+> ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]]
148 149
  where
    (ppr_match, pref)
150
        = case kind of
151 152
             FunRhs fun -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)
             _          -> (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
sof's avatar
sof committed
158
ppr_shadow_pats kind pats
Ian Lynagh's avatar
Ian Lynagh committed
159
  = sep [ppr_pats pats, matchSeparator kind, ptext (sLit "...")]
160 161 162 163

ppr_incomplete_pats :: HsMatchContext Name -> ExhaustivePat -> SDoc
ppr_incomplete_pats _ (pats,[]) = ppr_pats pats
ppr_incomplete_pats _ (pats,constraints) =
164 165
                         sep [ppr_pats pats, ptext (sLit "with"),
                              sep (map ppr_constraint constraints)]
166

167
ppr_constraint :: (Name,[HsLit]) -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
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

Austin Seipp's avatar
Austin Seipp committed
173 174 175
{-
************************************************************************
*                                                                      *
176
                The main matching function
Austin Seipp's avatar
Austin Seipp committed
177 178
*                                                                      *
************************************************************************
179

180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198
The function @match@ is basically the same as in the Wadler chapter,
except it is monadised, to carry around the name supply, info about
annotations, etc.

Notes on @match@'s arguments, assuming $m$ equations and $n$ patterns:
\begin{enumerate}
\item
A list of $n$ variable names, those variables presumably bound to the
$n$ expressions being matched against the $n$ patterns.  Using the
list of $n$ expressions as the first argument showed no benefit and
some inelegance.

\item
The second argument, a list giving the ``equation info'' for each of
the $m$ equations:
\begin{itemize}
\item
the $n$ patterns for that equation, and
\item
199
a list of Core bindings [@(Id, CoreExpr)@ pairs] to be ``stuck on
200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221
the front'' of the matching code, as in:
\begin{verbatim}
let <binds>
in  <matching-code>
\end{verbatim}
\item
and finally: (ToDo: fill in)

The right way to think about the ``after-match function'' is that it
is an embryonic @CoreExpr@ with a ``hole'' at the end for the
final ``else expression''.
\end{itemize}

There is a type synonym, @EquationInfo@, defined in module @DsUtils@.

An experiment with re-ordering this information about equations (in
particular, having the patterns available in column-major order)
showed no benefit.

\item
A default expression---what to evaluate if the overall pattern-match
fails.  This expression will (almost?) always be
222
a measly expression @Var@, unless we know it will only be used once
223 224 225
(as we do in @glue_success_exprs@).

Leaving out this third argument to @match@ (and slamming in lots of
226
@Var "fail"@s) is a positively {\em bad} idea, because it makes it
227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251
impossible to share the default expressions.  (Also, it stands no
chance of working in our post-upheaval world of @Locals@.)
\end{enumerate}

Note: @match@ is often called via @matchWrapper@ (end of this module),
a function that does much of the house-keeping that goes with a call
to @match@.

It is also worth mentioning the {\em typical} way a block of equations
is desugared with @match@.  At each stage, it is the first column of
patterns that is examined.  The steps carried out are roughly:
\begin{enumerate}
\item
Tidy the patterns in column~1 with @tidyEqnInfo@ (this may add
bindings to the second component of the equation-info):
\begin{itemize}
\item
Remove the `as' patterns from column~1.
\item
Make all constructor patterns in column~1 into @ConPats@, notably
@ListPats@ and @TuplePats@.
\item
Handle any irrefutable (or ``twiddle'') @LazyPats@.
\end{itemize}
\item
Ian Lynagh's avatar
Ian Lynagh committed
252
Now {\em unmix} the equations into {\em blocks} [w\/ local function
253 254 255 256
@unmix_eqns@], in which the equations in a block all have variable
patterns in column~1, or they all have constructor patterns in ...
(see ``the mixture rule'' in SLPJ).
\item
257
Call @matchEqnBlock@ on each block of equations; it will do the
258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275
appropriate thing for each kind of column-1 pattern, usually ending up
in a recursive call to @match@.
\end{enumerate}

We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87)
than the Wadler-chapter code for @match@ (p.~93, first @match@ clause).
And gluing the ``success expressions'' together isn't quite so pretty.

This (more interesting) clause of @match@ uses @tidy_and_unmix_eqns@
(a)~to get `as'- and `twiddle'-patterns out of the way (tidying), and
(b)~to do ``the mixture rule'' (SLPJ, p.~88) [which really {\em
un}mixes the equations], producing a list of equation-info
blocks, each block having as its first column of patterns either all
constructors, or all variables (or similar beasts), etc.

@match_unmixed_eqn_blks@ simply takes the place of the @foldr@ in the
Wadler-chapter @match@ (p.~93, last clause), and @match_unmixed_blk@
corresponds roughly to @matchVarCon@.
Austin Seipp's avatar
Austin Seipp committed
276
-}
277

278
match :: [Id]             -- Variables rep\'ing the exprs we\'re matching with
279
      -> Type             -- Type of the case expression
280
      -> [EquationInfo]   -- Info about patterns, etc. (type synonym below)
281 282 283
      -> DsM MatchResult  -- Desugared result!

match [] ty eqns
284
  = ASSERT2( not (null eqns), ppr ty )
285
    return (foldr1 combineMatchResults match_results)
286
  where
287 288 289
    match_results = [ ASSERT( null (eqn_pats eqn) )
                      eqn_rhs eqn
                    | eqn <- eqns ]
290

291
match vars@(v:_) ty eqns    -- Eqns *can* be empty
292
  = do  { dflags <- getDynFlags
293
                -- Tidy the first pattern, generating
294
                -- auxiliary bindings if necessary
295
        ; (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns
296

297
                -- Group the equations and match each group in turn
298
        ; let grouped = groupEquations dflags tidy_eqns
299 300

         -- print the view patterns that are commoned up to help debug
301
        ; whenDOptM Opt_D_dump_view_pattern_commoning (debug grouped)
302

303 304 305
        ; match_results <- match_groups grouped
        ; return (adjustMatchResult (foldr (.) id aux_binds) $
                  foldr1 combineMatchResults match_results) }
306 307 308 309
  where
    dropGroup :: [(PatGroup,EquationInfo)] -> [EquationInfo]
    dropGroup = map snd

310 311 312 313 314
    match_groups :: [[(PatGroup,EquationInfo)]] -> DsM [MatchResult]
    -- Result list of [MatchResult] is always non-empty
    match_groups [] = matchEmpty v ty
    match_groups gs = mapM match_group gs

315
    match_group :: [(PatGroup,EquationInfo)] -> DsM MatchResult
316
    match_group [] = panic "match_group"
317
    match_group eqns@((group,_) : _)
318
        = case group of
319
            PgCon _    -> matchConFamily  vars ty (subGroup [(c,e) | (PgCon c, e) <- eqns])
cactus's avatar
cactus committed
320
            PgSyn _    -> matchPatSyn     vars ty (dropGroup eqns)
321
            PgLit _    -> matchLiterals   vars ty (subGroup [(l,e) | (PgLit l, e) <- eqns])
322
            PgAny      -> matchVariables  vars ty (dropGroup eqns)
323
            PgN _      -> matchNPats      vars ty (dropGroup eqns)
324
            PgNpK _    -> matchNPlusKPats vars ty (dropGroup eqns)
325 326 327
            PgBang     -> matchBangs      vars ty (dropGroup eqns)
            PgCo _     -> matchCoercion   vars ty (dropGroup eqns)
            PgView _ _ -> matchView       vars ty (dropGroup eqns)
328
            PgOverloadedList -> matchOverloadedList vars ty (dropGroup eqns)
329

330 331 332 333
    -- FIXME: we should also warn about view patterns that should be
    -- commoned up but are not

    -- print some stuff to see what's getting grouped
334
    -- use -dppr-debug to see the resolution of overloaded literals
335 336 337
    debug eqns =
        let gs = map (\group -> foldr (\ (p,_) -> \acc ->
                                           case p of PgView e _ -> e:acc
338 339 340
                                                     _ -> acc) [] group) eqns
            maybeWarn [] = return ()
            maybeWarn l = warnDs (vcat l)
341
        in
342 343
          maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g))
                       (filter (not . null) gs))
344

345 346 347 348 349
matchEmpty :: Id -> Type -> DsM [MatchResult]
-- See Note [Empty case expressions]
matchEmpty var res_ty
  = return [MatchResult CanFail mk_seq]
  where
350
    mk_seq fail = return $ mkWildCase (Var var) (idType var) res_ty
351 352
                                      [(DEFAULT, [], fail)]

353 354 355
matchVariables :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
-- Real true variables, just like in matchVar, SLPJ p 94
-- No binding to do: they'll all be wildcards by now (done in tidy)
356
matchVariables (_:vars) ty eqns = match vars ty (shiftEqns eqns)
357
matchVariables [] _ _ = panic "matchVariables"
358

359 360
matchBangs :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
matchBangs (var:vars) ty eqns
361
  = do  { match_result <- match (var:vars) ty $
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
362
                          map (decomposeFirstPat getBangPat) eqns
363
        ; return (mkEvalMatchResult var ty match_result) }
364
matchBangs [] _ _ = panic "matchBangs"
365 366 367

matchCoercion :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
-- Apply the coercion to the match variable and then match that
368
matchCoercion (var:vars) ty (eqns@(eqn1:_))
369 370 371
  = do  { let CoPat co pat _ = firstPat eqn1
        ; var' <- newUniqueId var (hsPatType pat)
        ; match_result <- match (var':vars) ty $
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
372
                          map (decomposeFirstPat getCoPat) eqns
373
        ; rhs' <- dsHsWrapper co (Var var)
374
        ; return (mkCoLetMatchResult (NonRec var' rhs') match_result) }
375
matchCoercion _ _ _ = panic "matchCoercion"
376 377 378 379

matchView :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
-- Apply the view function to the match variable and then match that
matchView (var:vars) ty (eqns@(eqn1:_))
380 381
  = do  { -- we could pass in the expr from the PgView,
         -- but this needs to extract the pat anyway
382 383
         -- to figure out the type of the fresh variable
         let ViewPat viewExpr (L _ pat) _ = firstPat eqn1
384 385 386
         -- do the rest of the compilation
        ; var' <- newUniqueId var (hsPatType pat)
        ; match_result <- match (var':vars) ty $
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
387
                          map (decomposeFirstPat getViewPat) eqns
388
         -- compile the view expressions
389
        ; viewExpr' <- dsLExpr viewExpr
390
        ; return (mkViewMatchResult var' viewExpr' var match_result) }
391
matchView _ _ _ = panic "matchView"
392

393 394
matchOverloadedList :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
matchOverloadedList (var:vars) ty (eqns@(eqn1:_))
395
-- Since overloaded list patterns are treated as view patterns,
396
-- the code is roughly the same as for matchView
397
  = do { let ListPat _ elt_ty (Just (_,e)) = firstPat eqn1
398
       ; var' <- newUniqueId var (mkListTy elt_ty)  -- we construct the overall type by hand
399
       ; match_result <- match (var':vars) ty $
400 401 402 403 404
                            map (decomposeFirstPat getOLPat) eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern
       ; e' <- dsExpr e
       ; return (mkViewMatchResult var' e' var match_result) }
matchOverloadedList _ _ _ = panic "matchOverloadedList"

405
-- decompose the first pattern and leave the rest alone
406
decomposeFirstPat :: (Pat Id -> Pat Id) -> EquationInfo -> EquationInfo
407
decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))
408
        = eqn { eqn_pats = extractpat pat : pats}
409
decomposeFirstPat _ _ = panic "decomposeFirstPat"
410

411
getCoPat, getBangPat, getViewPat, getOLPat :: Pat Id -> Pat Id
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
412 413 414 415 416
getCoPat (CoPat _ pat _)     = pat
getCoPat _                   = panic "getCoPat"
getBangPat (BangPat pat  )   = unLoc pat
getBangPat _                 = panic "getBangPat"
getViewPat (ViewPat _ pat _) = unLoc pat
417 418 419
getViewPat _                 = panic "getViewPat"
getOLPat (ListPat pats ty (Just _)) = ListPat pats ty Nothing
getOLPat _                   = panic "getOLPat"
420

Austin Seipp's avatar
Austin Seipp committed
421
{-
422 423 424 425 426 427 428 429 430 431 432
Note [Empty case alternatives]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The list of EquationInfo can be empty, arising from
    case x of {}   or    \case {}
In that situation we desugar to
    case x of { _ -> error "pattern match failure" }
The *desugarer* isn't certain whether there really should be no
alternatives, so it adds a default case, as it always does.  A later
pass may remove it if it's inaccessible.  (See also Note [Empty case
alternatives] in CoreSyn.)

Gabor Greif's avatar
Gabor Greif committed
433
We do *not* desugar simply to
434
   error "empty case"
435 436 437 438 439
or some such, because 'x' might be bound to (error "hello"), in which
case we want to see that "hello" exception, not (error "empty case").
See also Note [Case elimination: lifted case] in Simplify.


Austin Seipp's avatar
Austin Seipp committed
440 441
************************************************************************
*                                                                      *
442
                Tidying patterns
Austin Seipp's avatar
Austin Seipp committed
443 444
*                                                                      *
************************************************************************
445

446 447 448 449 450 451 452
Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@
which will be scrutinised.  This means:
\begin{itemize}
\item
Replace variable patterns @x@ (@x /= v@) with the pattern @_@,
together with the binding @x = v@.
\item
453
Replace the `as' pattern @x@@p@ with the pattern p and a binding @x = v@.
454 455 456
\item
Removing lazy (irrefutable) patterns (you don't want to know...).
\item
457
Converting explicit tuple-, list-, and parallel-array-pats into ordinary
458
@ConPats@.
459 460
\item
Convert the literal pat "" to [].
461 462 463 464 465 466 467 468 469 470 471
\end{itemize}

The result of this tidying is that the column of patterns will include
{\em only}:
\begin{description}
\item[@WildPats@:]
The @VarPat@ information isn't needed any more after this.

\item[@ConPats@:]
@ListPats@, @TuplePats@, etc., are all converted into @ConPats@.

472 473
\item[@LitPats@ and @NPats@:]
@LitPats@/@NPats@ of ``known friendly types'' (Int, Char,
474
Float,  Double, at least) are converted to unboxed form; e.g.,
475
\tr{(NPat (HsInt i) _ _)} is converted to:
476
\begin{verbatim}
477
(ConPat I# _ _ [LitPat (HsIntPrim i)])
478 479
\end{verbatim}
\end{description}
Austin Seipp's avatar
Austin Seipp committed
480
-}
481

482
tidyEqnInfo :: Id -> EquationInfo
483 484 485 486 487 488 489 490 491 492 493 494 495 496 497
            -> DsM (DsWrapper, EquationInfo)
        -- DsM'd because of internal call to dsLHsBinds
        --      and mkSelectorBinds.
        -- "tidy1" does the interesting stuff, looking at
        -- one pattern and fiddling the list of bindings.
        --
        -- POST CONDITION: head pattern in the EqnInfo is
        --      WildPat
        --      ConPat
        --      NPat
        --      LitPat
        --      NPlusKPat
        -- but no other

tidyEqnInfo _ (EqnInfo { eqn_pats = [] })
498 499 500 501 502
  = panic "tidyEqnInfo"

tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats })
  = do { (wrap, pat') <- tidy1 v pat
       ; return (wrap, eqn { eqn_pats = do pat' : pats }) }
503

504 505 506 507
tidy1 :: Id               -- The Id being scrutinised
      -> Pat Id           -- The pattern against which it is to be matched
      -> DsM (DsWrapper,  -- Extra bindings to do before the match
              Pat Id)     -- Equivalent pattern
508

509
-------------------------------------------------------
510
--      (pat', mr') = tidy1 v pat mr
511 512 513
-- tidies the *outer level only* of pat, giving pat'
-- It eliminates many pattern forms (as-patterns, variable patterns,
-- list patterns, etc) yielding one of:
514 515 516 517 518 519 520 521
--      WildPat
--      ConPatOut
--      LitPat
--      NPat
--      NPlusKPat

tidy1 v (ParPat pat)      = tidy1 v (unLoc pat)
tidy1 v (SigPatOut pat _) = tidy1 v (unLoc pat)
522
tidy1 _ (WildPat ty)      = return (idDsWrapper, WildPat ty)
523
tidy1 v (BangPat (L l p)) = tidy_bang_pat v l p
524

525 526
        -- case v of { x -> mr[] }
        -- = case v of { _ -> let x=v in mr[] }
527
tidy1 v (VarPat var)
528
  = return (wrapBind var v, WildPat (idType var))
529

530 531
        -- case v of { x@p -> mr[] }
        -- = case v of { p -> let x=v in mr[] }
532
tidy1 v (AsPat (L _ var) pat)
533 534
  = do  { (wrap, pat') <- tidy1 v (unLoc pat)
        ; return (wrapBind var v . wrap, pat') }
535 536 537

{- now, here we handle lazy patterns:
    tidy1 v ~p bs = (v, v1 = case v of p -> v1 :
538
                        v2 = case v of p -> v2 : ... : bs )
539 540 541 542 543

    where the v_i's are the binders in the pattern.

    ToDo: in "v_i = ... -> v_i", are the v_i's really the same thing?

544
    The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr
545 546
-}

547
tidy1 v (LazyPat pat)
548
  = do  { (_,sel_prs) <- mkSelectorBinds False [] pat (Var v)
549 550
        ; let sel_binds =  [NonRec b rhs | (b,rhs) <- sel_prs]
        ; return (mkCoreLets sel_binds, WildPat (idType v)) }
551

552
tidy1 _ (ListPat pats ty Nothing)
553
  = return (idDsWrapper, unLoc list_ConPat)
554
  where
555 556
    list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty])
                        (mkNilPat ty)
557
                        pats
558

559
-- Introduce fake parallel array constructors to be able to handle parallel
560
-- arrays with the existing machinery for constructor pattern
561
tidy1 _ (PArrPat pats ty)
562
  = return (idDsWrapper, unLoc parrConPat)
563 564
  where
    arity      = length pats
565
    parrConPat = mkPrefixConPat (parrFakeCon arity) pats [ty]
566

567
tidy1 _ (TuplePat pats boxity tys)
568
  = return (idDsWrapper, unLoc tuple_ConPat)
569 570
  where
    arity = length pats
571
    tuple_ConPat = mkPrefixConPat (tupleDataCon boxity arity) pats tys
572

573
-- LitPats: we *might* be able to replace these w/ a simpler form
574
tidy1 _ (LitPat lit)
575
  = return (idDsWrapper, tidyLitPat lit)
576 577

-- NPats: we *might* be able to replace these w/ a simpler form
Alan Zimmerman's avatar
Alan Zimmerman committed
578
tidy1 _ (NPat (L _ lit) mb_neg eq)
579
  = return (idDsWrapper, tidyNPat tidyLitPat lit mb_neg eq)
580

581
-- Everything else goes through unchanged...
582

583
tidy1 _ non_interesting_pat
584
  = return (idDsWrapper, non_interesting_pat)
585 586 587 588

--------------------
tidy_bang_pat :: Id -> SrcSpan -> Pat Id -> DsM (DsWrapper, Pat Id)

589
-- Discard par/sig under a bang
590 591 592 593
tidy_bang_pat v _ (ParPat (L l p))      = tidy_bang_pat v l p
tidy_bang_pat v _ (SigPatOut (L l p) _) = tidy_bang_pat v l p

-- Push the bang-pattern inwards, in the hope that
594
-- it may disappear next time
595 596 597
tidy_bang_pat v l (AsPat v' p)  = tidy1 v (AsPat v' (L l (BangPat p)))
tidy_bang_pat v l (CoPat w p t) = tidy1 v (CoPat w (BangPat (L l p)) t)

598 599 600 601 602 603 604 605 606 607 608 609 610 611
-- Discard bang around strict pattern
tidy_bang_pat v _ p@(LitPat {})    = tidy1 v p
tidy_bang_pat v _ p@(ListPat {})   = tidy1 v p
tidy_bang_pat v _ p@(TuplePat {})  = tidy1 v p
tidy_bang_pat v _ p@(PArrPat {})   = tidy1 v p

-- Data/newtype constructors
tidy_bang_pat v l p@(ConPatOut { pat_con = L _ (RealDataCon dc), pat_args = args })
  | isNewTyCon (dataConTyCon dc)   -- Newtypes: push bang inwards (Trac #9844)
  = tidy1 v (p { pat_args = push_bang_into_newtype_arg l args })
  | otherwise                      -- Data types: discard the bang
  = tidy1 v p

-------------------
612
-- Default case, leave the bang there:
613 614 615 616 617 618 619 620
--    VarPat,
--    LazyPat,
--    WildPat,
--    ViewPat,
--    pattern synonyms (ConPatOut with PatSynCon)
--    NPat,
--    NPlusKPat
--
621 622
-- For LazyPat, remember that it's semantically like a VarPat
--  i.e.  !(~p) is not like ~p, or p!  (Trac #8952)
623 624
--
-- NB: SigPatIn, ConPatIn should not happen
625

626
tidy_bang_pat _ l p = return (idDsWrapper, BangPat (L l p))
627 628 629 630 631 632

-------------------
push_bang_into_newtype_arg :: SrcSpan -> HsConPatDetails Id -> HsConPatDetails Id
-- See Note [Bang patterns and newtypes]
-- We are transforming   !(N p)   into   (N !p)
push_bang_into_newtype_arg l (PrefixCon (arg:args))
Austin Seipp's avatar
Austin Seipp committed
633
  = ASSERT( null args)
634 635 636 637 638 639 640 641
    PrefixCon [L l (BangPat arg)]
push_bang_into_newtype_arg l (RecCon rf)
  | HsRecFields { rec_flds = L lf fld : flds } <- rf
  , HsRecField { hsRecFieldArg = arg } <- fld
  = ASSERT( null flds)
    RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg = L l (BangPat arg) })] })
push_bang_into_newtype_arg _ cd
  = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd)
642

Austin Seipp's avatar
Austin Seipp committed
643
{-
644 645 646 647 648 649 650 651 652 653 654 655
Note [Bang patterns and newtypes]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For the pattern  !(Just pat)  we can discard the bang, because
the pattern is strict anyway. But for !(N pat), where
  newtype NT = N Int
we definitely can't discard the bang.  Trac #9844.

So what we do is to push the bang inwards, in the hope that it will
get discarded there.  So we transform
   !(N pat)   into    (N !pat)


656 657
\noindent
{\bf Previous @matchTwiddled@ stuff:}
658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680

Now we get to the only interesting part; note: there are choices for
translation [from Simon's notes]; translation~1:
\begin{verbatim}
deTwiddle [s,t] e
\end{verbatim}
returns
\begin{verbatim}
[ w = e,
  s = case w of [s,t] -> s
  t = case w of [s,t] -> t
]
\end{verbatim}

Here \tr{w} is a fresh variable, and the \tr{w}-binding prevents multiple
evaluation of \tr{e}.  An alternative translation (No.~2):
\begin{verbatim}
[ w = case e of [s,t] -> (s,t)
  s = case w of (s,t) -> s
  t = case w of (s,t) -> t
]
\end{verbatim}

Austin Seipp's avatar
Austin Seipp committed
681 682
************************************************************************
*                                                                      *
683
\subsubsection[improved-unmixing]{UNIMPLEMENTED idea for improved unmixing}
Austin Seipp's avatar
Austin Seipp committed
684 685
*                                                                      *
************************************************************************
686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720

We might be able to optimise unmixing when confronted by
only-one-constructor-possible, of which tuples are the most notable
examples.  Consider:
\begin{verbatim}
f (a,b,c) ... = ...
f d ... (e:f) = ...
f (g,h,i) ... = ...
f j ...       = ...
\end{verbatim}
This definition would normally be unmixed into four equation blocks,
one per equation.  But it could be unmixed into just one equation
block, because if the one equation matches (on the first column),
the others certainly will.

You have to be careful, though; the example
\begin{verbatim}
f j ...       = ...
-------------------
f (a,b,c) ... = ...
f d ... (e:f) = ...
f (g,h,i) ... = ...
\end{verbatim}
{\em must} be broken into two blocks at the line shown; otherwise, you
are forcing unnecessary evaluation.  In any case, the top-left pattern
always gives the cue.  You could then unmix blocks into groups of...
\begin{description}
\item[all variables:]
As it is now.
\item[constructors or variables (mixed):]
Need to make sure the right names get bound for the variable patterns.
\item[literals or variables (mixed):]
Presumably just a variant on the constructor case (as it is now).
\end{description}

Austin Seipp's avatar
Austin Seipp committed
721 722 723 724 725
************************************************************************
*                                                                      *
*  matchWrapper: a convenient way to call @match@                      *
*                                                                      *
************************************************************************
726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745
\subsection[matchWrapper]{@matchWrapper@: a convenient interface to @match@}

Calls to @match@ often involve similar (non-trivial) work; that work
is collected here, in @matchWrapper@.  This function takes as
arguments:
\begin{itemize}
\item
Typchecked @Matches@ (of a function definition, or a case or lambda
expression)---the main input;
\item
An error message to be inserted into any (runtime) pattern-matching
failure messages.
\end{itemize}

As results, @matchWrapper@ produces:
\begin{itemize}
\item
A list of variables (@Locals@) that the caller must ``promise'' to
bind to appropriate values; and
\item
746
a @CoreExpr@, the desugared output (main result).
747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763
\end{itemize}

The main actions of @matchWrapper@ include:
\begin{enumerate}
\item
Flatten the @[TypecheckedMatch]@ into a suitable list of
@EquationInfo@s.
\item
Create as many new variables as there are patterns in a pattern-list
(in any one of the @EquationInfo@s).
\item
Create a suitable ``if it fails'' expression---a call to @error@ using
the error-string input; the {\em type} of this fail value can be found
by examining one of the RHS expressions in one of the @EquationInfo@s.
\item
Call @match@ with all of this information!
\end{enumerate}
Austin Seipp's avatar
Austin Seipp committed
764
-}
765

766 767 768
matchWrapper :: HsMatchContext Name         -- For shadowing warning messages
             -> MatchGroup Id (LHsExpr Id)  -- Matches being desugared
             -> DsM ([Id], CoreExpr)        -- Results
769

Austin Seipp's avatar
Austin Seipp committed
770
{-
771 772
 There is one small problem with the Lambda Patterns, when somebody
 writes something similar to:
773
\begin{verbatim}
774
    (\ (x:xs) -> ...)
775
\end{verbatim}
776
 he/she don't want a warning about incomplete patterns, that is done with
777 778 779 780 781 782 783 784 785 786 787 788
 the flag @opt_WarnSimplePatterns@.
 This problem also appears in the:
\begin{itemize}
\item @do@ patterns, but if the @do@ can fail
      it creates another equation if the match can fail
      (see @DsExpr.doDo@ function)
\item @let@ patterns, are treated by @matchSimply@
   List Comprension Patterns, are treated by @matchSimply@ also
\end{itemize}

We can't call @matchSimply@ with Lambda patterns,
due to the fact that lambda patterns can have more than
789 790 791
one pattern, and match simply only accepts one pattern.

JJQC 30-Nov-1997
Austin Seipp's avatar
Austin Seipp committed
792
-}
793

794
matchWrapper ctxt (MG { mg_alts = L _ matches
795
                      , mg_arg_tys = arg_tys
796 797
                      , mg_res_ty = rhs_ty
                      , mg_origin = origin })
798 799
  = do  { eqns_info   <- mapM mk_eqn_info matches
        ; new_vars    <- case matches of
800 801
                           []    -> mapM newSysLocalDs arg_tys
                           (m:_) -> selectMatchVars (map unLoc (hsLMatchPats m))
802 803
        ; result_expr <- handleWarnings $
                         matchEquations ctxt new_vars eqns_info rhs_ty
804
        ; return (new_vars, result_expr) }
805
  where
Alan Zimmerman's avatar
Alan Zimmerman committed
806
    mk_eqn_info (L _ (Match _ pats _ grhss))
807 808
      = do { dflags <- getDynFlags
           ; let upats = map (strictify dflags) pats
809 810
           ; match_result <- dsGRHSs ctxt upats grhss rhs_ty
           ; return (EqnInfo { eqn_pats = upats, eqn_rhs  = match_result}) }
811

812 813 814 815
    strictify dflags pat =
      let (is_strict, pat') = getUnBangedLPat dflags pat
      in if is_strict then BangPat pat' else unLoc pat'

816 817 818 819
    handleWarnings = if isGenerated origin
                     then discardWarningsDs
                     else id

820 821

matchEquations  :: HsMatchContext Name
822 823
                -> [Id] -> [EquationInfo] -> Type
                -> DsM CoreExpr
824
matchEquations ctxt vars eqns_info rhs_ty
825 826 827
  = do  { locn <- getSrcSpanDs
        ; let   ds_ctxt   = DsMatchContext ctxt locn
                error_doc = matchContextErrString ctxt
828

829
        ; match_result <- matchCheck ds_ctxt vars rhs_ty eqns_info
830

831 832
        ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_doc
        ; extractMatchResult match_result fail_expr }
833

Austin Seipp's avatar
Austin Seipp committed
834 835 836
{-
************************************************************************
*                                                                      *
837
\subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern}
Austin Seipp's avatar
Austin Seipp committed
838 839
*                                                                      *
************************************************************************
840 841 842 843

@mkSimpleMatch@ is a wrapper for @match@ which deals with the
situation where we want to match a single expression against a single
pattern. It returns an expression.
Austin Seipp's avatar
Austin Seipp committed
844
-}
845

846 847 848 849 850 851
matchSimply :: CoreExpr                 -- Scrutinee
            -> HsMatchContext Name      -- Match kind
            -> LPat Id                  -- Pattern it should match
            -> CoreExpr                 -- Return this if it matches
            -> CoreExpr                 -- Return this if it doesn't
            -> DsM CoreExpr
852
-- Do not warn about incomplete patterns; see matchSinglePat comments
853 854
matchSimply scrut hs_ctx pat result_expr fail_expr = do
    let
855
      match_result = cantFailMatchResult result_expr
856 857 858
      rhs_ty       = exprType fail_expr
        -- Use exprType of fail_expr, because won't refine in the case of failure!
    match_result' <- matchSinglePat scrut hs_ctx pat rhs_ty match_result
859
    extractMatchResult match_result' fail_expr
860

861
matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat Id
862
               -> Type -> MatchResult -> DsM MatchResult
863
-- Do not warn about incomplete patterns
864
-- Used for things like [ e | pat <- stuff ], where
865
-- incomplete patterns are just fine
866
matchSinglePat (Var var) ctx (L _ pat) ty match_result
867 868
  = do { locn <- getSrcSpanDs
       ; matchCheck (DsMatchContext ctx locn)
869
                    [var] ty
870 871 872 873 874 875
                    [EqnInfo { eqn_pats = [pat], eqn_rhs  = match_result }] }

matchSinglePat scrut hs_ctx pat ty match_result
  = do { var <- selectSimpleMatchVarL pat
       ; match_result' <- matchSinglePat (Var var) hs_ctx pat ty match_result
       ; return (adjustMatchResult (bindNonRec var scrut) match_result') }
876

Austin Seipp's avatar
Austin Seipp committed
877 878 879
{-
************************************************************************
*                                                                      *
880
                Pattern classification
Austin Seipp's avatar
Austin Seipp committed
881 882 883
*                                                                      *
************************************************************************
-}
884 885

data PatGroup
886 887 888
  = PgAny               -- Immediate match: variables, wildcards,
                        --                  lazy patterns
  | PgCon DataCon       -- Constructor patterns (incl list, tuple)
cactus's avatar
cactus committed
889
  | PgSyn PatSyn
890 891 892 893 894 895
  | PgLit Literal       -- Literal patterns
  | PgN   Literal       -- Overloaded literals
  | PgNpK Literal       -- n+k patterns
  | PgBang              -- Bang patterns
  | PgCo Type           -- Coercion patterns; the type is the type
                        --      of the pattern *inside*
896 897 898
  | PgView (LHsExpr Id) -- view pattern (e -> p):
                        -- the LHsExpr is the expression e
           Type         -- the Type is the type of p (equivalently, the result type of e)
899
  | PgOverloadedList
900

901
groupEquations :: DynFlags -> [EquationInfo] -> [[(PatGroup, EquationInfo)]]
902
-- If the result is of form [g1, g2, g3],
903 904
-- (a) all the (pg,eq) pairs in g1 have the same pg
-- (b) none of the gi are empty
905
-- The ordering of equations is unchanged
906 907
groupEquations dflags eqns
  = runs same_gp [(patGroup dflags (firstPat eqn), eqn) | eqn <- eqns]
908 909 910 911
  where
    same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool
    (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2

912
subGroup :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]]
913
-- Input is a particular group.  The result sub-groups the
914
-- equations by with particular constructor, literal etc they match.
915 916
-- Each sub-list in the result has the same PatGroup
-- See Note [Take care with pattern order]
917
subGroup group
918
    = map reverse $ Map.elems $ foldl accumulate Map.empty group
919
  where
920
    accumulate pg_map (pg, eqn)
921 922 923
      = case Map.lookup pg pg_map of
          Just eqns -> Map.insert pg (eqn:eqns) pg_map
          Nothing   -> Map.insert pg [eqn]      pg_map
924

925
    -- pg_map :: Map a [EquationInfo]
926
    -- Equations seen so far in reverse order of appearance
927

Austin Seipp's avatar
Austin Seipp committed
928
{-
929 930 931 932
Note [Take care with pattern order]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In the subGroup function we must be very careful about pattern re-ordering,
Consider the patterns [ (True, Nothing), (False, x), (True, y) ]
933
Then in bringing together the patterns for True, we must not
934
swap the Nothing and y!
Austin Seipp's avatar
Austin Seipp committed
935
-}
936

937
sameGroup :: PatGroup -> PatGroup -> Bool
938
-- Same group means that a single case expression
939 940 941 942
-- or test will suffice to match both, *and* the order
-- of testing within the group is insignificant.
sameGroup PgAny      PgAny      = True
sameGroup PgBang     PgBang     = True
943
sameGroup (PgCon _)  (PgCon _)  = True          -- One case expression
cactus's avatar
cactus committed
944
sameGroup (PgSyn p1) (PgSyn p2) = p1==p2
945 946 947 948 949 950 951 952 953
sameGroup (PgLit _)  (PgLit _)  = True          -- One case expression
sameGroup (PgN l1)   (PgN l2)   = l1==l2        -- Order is significant
sameGroup (PgNpK l1) (PgNpK l2) = l1==l2        -- See Note [Grouping overloaded literal patterns]
sameGroup (PgCo t1)  (PgCo t2)  = t1 `eqType` t2
        -- CoPats are in the same goup only if the type of the
        -- enclosed pattern is the same. The patterns outside the CoPat
        -- always have the same type, so this boils down to saying that
        -- the two coercions are identical.
sameGroup (PgView e1 t1) (PgView e2 t2) = viewLExprEq (e1,t1) (e2,t2)
954
       -- ViewPats are in the same group iff the expressions
955
       -- are "equal"---conservatively, we use syntactic equality
956
sameGroup _          _          = False
957

958
-- An approximation of syntactic equality used for determining when view
959
-- exprs are in the same group.
960
-- This function can always safely return false;
961 962
-- but doing so will result in the application of the view function being repeated.
--
963
-- Currently: compare applications of literals and variables
964 965 966 967 968 969 970
--            and anything else that we can do without involving other
--            HsSyn types in the recursion
--
-- NB we can't assume that the two view expressions have the same type.  Consider
--   f (e1 -> True) = ...
--   f (e2 -> "hi") = ...
viewLExprEq :: (LHsExpr Id,Type) -> (LHsExpr Id,Type) -> Bool
971 972 973 974 975 976 977 978
viewLExprEq (e1,_) (e2,_) = lexp e1 e2
  where
    lexp :: LHsExpr Id -> LHsExpr Id -> Bool
    lexp e e' = exp (unLoc e) (unLoc e')

    ---------
    exp :: HsExpr Id -> HsExpr Id -> Bool
    -- real comparison is on HsExpr's
979
    -- strip parens
980 981 982 983 984
    exp (HsPar (L _ e)) e'   = exp e e'
    exp e (HsPar (L _ e'))   = exp e e'
    -- because the expressions do not necessarily have the same type,
    -- we have to compare the wrappers
    exp (HsWrap h e) (HsWrap h' e') = wrap h h' && exp e e'
985
    exp (HsVar i) (HsVar i') =  i == i'
986 987
    -- the instance for IPName derives using the id, so this works if the
    -- above does
988
    exp (HsIPVar i) (HsIPVar i') = i == i'
Adam Gundry's avatar
Adam Gundry committed
989
    exp (HsOverLabel l) (HsOverLabel l') = l == l'
990
    exp (HsOverLit l) (HsOverLit l') =
991 992 993 994 995 996
        -- Overloaded lits are equal if they have the same type
        -- and the data is the same.
        -- this is coarser than comparing the SyntaxExpr's in l and l',
        -- which resolve the overloading (e.g., fromInteger 1),
        -- because these expressions get written as a bunch of different variables
        -- (presumably to improve sharing)
997
        eqType (overLitType l) (overLitType l') && l == l'
998 999 1000
    exp (HsApp e1 e2) (HsApp e1' e2') = lexp e1 e1' && lexp e2 e2'
    -- the fixities have been straightened out by now, so it's safe
    -- to ignore them?
1001
    exp (OpApp l o _ ri) (OpApp l' o' _ ri') =
1002 1003
        lexp l l' && lexp o o' && lexp ri ri'
    exp (NegApp e n) (NegApp e' n') = lexp e e' && exp n n'
1004
    exp (SectionL e1 e2) (SectionL e1' e2') =
1005
        lexp e1 e1' && lexp e2 e2'
1006
    exp (SectionR e1 e2) (SectionR e1' e2') =
1007 1008 1009
        lexp e1 e1' && lexp e2 e2'
    exp (ExplicitTuple es1 _) (ExplicitTuple es2 _) =
        eq_list tup_arg es1 es2
1010
    exp (HsIf _ e e1 e2) (HsIf _ e' e1' e2') =
1011 1012 1013 1014
        lexp e e' && lexp e1 e1' && lexp e2 e2'

    -- Enhancement: could implement equality for more expressions
    --   if it seems useful
1015
    -- But no need for HsLit, ExplicitList, ExplicitTuple,
1016