Match.hs 43.7 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, dsSyntaxExpr)
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 Coercion ( eqCoercion )
39
import TcType ( toTcTypeBag )
40
import TyCon( isNewTyCon )
Simon Marlow's avatar
Simon Marlow committed
41 42 43 44 45
import TysWiredIn
import SrcLoc
import Maybes
import Util
import Name
46
import Outputable
47
import BasicTypes ( isGenerated, il_value, fl_value )
48
import FastString
49 50
import Unique
import UniqDFM
51

52
import Control.Monad( when, unless )
53
import qualified Data.Map as Map
54
import Data.List (groupBy)
55

Austin Seipp's avatar
Austin Seipp committed
56 57 58
{-
************************************************************************
*                                                                      *
59
                The main matching function
Austin Seipp's avatar
Austin Seipp committed
60 61
*                                                                      *
************************************************************************
62

63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81
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
82
a list of Core bindings [@(Id, CoreExpr)@ pairs] to be ``stuck on
83 84 85 86 87 88 89 90 91 92 93 94 95
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}

96
There is a data type, @EquationInfo@, defined in module @DsMonad@.
97 98 99 100 101 102 103 104

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
105
a measly expression @Var@, unless we know it will only be used once
106 107 108
(as we do in @glue_success_exprs@).

Leaving out this third argument to @match@ (and slamming in lots of
109
@Var "fail"@s) is a positively {\em bad} idea, because it makes it
110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134
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
135
Now {\em unmix} the equations into {\em blocks} [w\/ local function
136 137 138 139
@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
140
Call @matchEqnBlock@ on each block of equations; it will do the
141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158
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@.
159 160 161

Note [Match Ids]
~~~~~~~~~~~~~~~~
Gabor Greif's avatar
Gabor Greif committed
162
Most of the matching functions take an Id or [Id] as argument.  This Id
163 164 165 166
is the scrutinee(s) of the match. The desugared expression may
sometimes use that Id in a local binding or as a case binder.  So it
should not have an External name; Lint rejects non-top-level binders
with External names (Trac #13043).
Austin Seipp's avatar
Austin Seipp committed
167
-}
168

169 170 171 172
type MatchId = Id   -- See Note [Match Ids]

match :: [MatchId]        -- Variables rep\'ing the exprs we\'re matching with
                          -- See Note [Match Ids]
173
      -> Type             -- Type of the case expression
174
      -> [EquationInfo]   -- Info about patterns, etc. (type synonym below)
175 176 177
      -> DsM MatchResult  -- Desugared result!

match [] ty eqns
178
  = ASSERT2( not (null eqns), ppr ty )
179
    return (foldr1 combineMatchResults match_results)
180
  where
181 182 183
    match_results = [ ASSERT( null (eqn_pats eqn) )
                      eqn_rhs eqn
                    | eqn <- eqns ]
184

185
match vars@(v:_) ty eqns    -- Eqns *can* be empty
186 187
  = ASSERT2( all (isInternalName . idName) vars, ppr vars )
    do  { dflags <- getDynFlags
188
                -- Tidy the first pattern, generating
189
                -- auxiliary bindings if necessary
190
        ; (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns
191

192
                -- Group the equations and match each group in turn
193
        ; let grouped = groupEquations dflags tidy_eqns
194 195

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

198 199 200
        ; match_results <- match_groups grouped
        ; return (adjustMatchResult (foldr (.) id aux_binds) $
                  foldr1 combineMatchResults match_results) }
201 202 203 204
  where
    dropGroup :: [(PatGroup,EquationInfo)] -> [EquationInfo]
    dropGroup = map snd

205 206 207 208 209
    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

210
    match_group :: [(PatGroup,EquationInfo)] -> DsM MatchResult
211
    match_group [] = panic "match_group"
212
    match_group eqns@((group,_) : _)
213
        = case group of
214
            PgCon {}  -> matchConFamily  vars ty (subGroupUniq [(c,e) | (PgCon c, e) <- eqns])
215
            PgSyn {}  -> matchPatSyn     vars ty (dropGroup eqns)
216
            PgLit {}  -> matchLiterals   vars ty (subGroupOrd [(l,e) | (PgLit l, e) <- eqns])
217 218
            PgAny     -> matchVariables  vars ty (dropGroup eqns)
            PgN {}    -> matchNPats      vars ty (dropGroup eqns)
219
            PgOverS {}-> matchNPats      vars ty (dropGroup eqns)
220 221 222 223
            PgNpK {}  -> matchNPlusKPats vars ty (dropGroup eqns)
            PgBang    -> matchBangs      vars ty (dropGroup eqns)
            PgCo {}   -> matchCoercion   vars ty (dropGroup eqns)
            PgView {} -> matchView       vars ty (dropGroup eqns)
224
            PgOverloadedList -> matchOverloadedList vars ty (dropGroup eqns)
225

226 227 228 229
    -- 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
230
    -- use -dppr-debug to see the resolution of overloaded literals
231 232 233
    debug eqns =
        let gs = map (\group -> foldr (\ (p,_) -> \acc ->
                                           case p of PgView e _ -> e:acc
234 235
                                                     _ -> acc) [] group) eqns
            maybeWarn [] = return ()
236
            maybeWarn l = warnDs NoReason (vcat l)
237
        in
238 239
          maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g))
                       (filter (not . null) gs))
240

241
matchEmpty :: MatchId -> Type -> DsM [MatchResult]
242 243 244 245
-- See Note [Empty case expressions]
matchEmpty var res_ty
  = return [MatchResult CanFail mk_seq]
  where
246
    mk_seq fail = return $ mkWildCase (Var var) (idType var) res_ty
247 248
                                      [(DEFAULT, [], fail)]

249
matchVariables :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
250 251
-- Real true variables, just like in matchVar, SLPJ p 94
-- No binding to do: they'll all be wildcards by now (done in tidy)
252
matchVariables (_:vars) ty eqns = match vars ty (shiftEqns eqns)
253
matchVariables [] _ _ = panic "matchVariables"
254

255
matchBangs :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
256
matchBangs (var:vars) ty eqns
257
  = do  { match_result <- match (var:vars) ty $
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
258
                          map (decomposeFirstPat getBangPat) eqns
259
        ; return (mkEvalMatchResult var ty match_result) }
260
matchBangs [] _ _ = panic "matchBangs"
261

262
matchCoercion :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
263
-- Apply the coercion to the match variable and then match that
264
matchCoercion (var:vars) ty (eqns@(eqn1:_))
265
  = do  { let CoPat co pat _ = firstPat eqn1
266 267
        ; let pat_ty' = hsPatType pat
        ; var' <- newUniqueId var pat_ty'
268
        ; match_result <- match (var':vars) ty $
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
269
                          map (decomposeFirstPat getCoPat) eqns
Simon Peyton Jones's avatar
Simon Peyton Jones committed
270 271 272
        ; core_wrap <- dsHsWrapper co
        ; let bind = NonRec var' (core_wrap (Var var))
        ; return (mkCoLetMatchResult bind match_result) }
273
matchCoercion _ _ _ = panic "matchCoercion"
274

275
matchView :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
276 277
-- Apply the view function to the match variable and then match that
matchView (var:vars) ty (eqns@(eqn1:_))
278 279
  = do  { -- we could pass in the expr from the PgView,
         -- but this needs to extract the pat anyway
280 281
         -- to figure out the type of the fresh variable
         let ViewPat viewExpr (L _ pat) _ = firstPat eqn1
282
         -- do the rest of the compilation
283 284
        ; let pat_ty' = hsPatType pat
        ; var' <- newUniqueId var pat_ty'
285
        ; match_result <- match (var':vars) ty $
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
286
                          map (decomposeFirstPat getViewPat) eqns
287
         -- compile the view expressions
288
        ; viewExpr' <- dsLExpr viewExpr
289 290 291
        ; return (mkViewMatchResult var'
                    (mkCoreAppDs (text "matchView") viewExpr' (Var var))
                    match_result) }
292
matchView _ _ _ = panic "matchView"
293

294
matchOverloadedList :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
295
matchOverloadedList (var:vars) ty (eqns@(eqn1:_))
296
-- Since overloaded list patterns are treated as view patterns,
297
-- the code is roughly the same as for matchView
298
  = do { let ListPat _ elt_ty (Just (_,e)) = firstPat eqn1
299
       ; var' <- newUniqueId var (mkListTy elt_ty)  -- we construct the overall type by hand
300
       ; match_result <- match (var':vars) ty $
301
                            map (decomposeFirstPat getOLPat) eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern
302 303
       ; e' <- dsSyntaxExpr e [Var var]
       ; return (mkViewMatchResult var' e' match_result) }
304 305
matchOverloadedList _ _ _ = panic "matchOverloadedList"

306
-- decompose the first pattern and leave the rest alone
307
decomposeFirstPat :: (Pat Id -> Pat Id) -> EquationInfo -> EquationInfo
308
decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))
309
        = eqn { eqn_pats = extractpat pat : pats}
310
decomposeFirstPat _ _ = panic "decomposeFirstPat"
311

312
getCoPat, getBangPat, getViewPat, getOLPat :: Pat Id -> Pat Id
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
313 314 315 316 317
getCoPat (CoPat _ pat _)     = pat
getCoPat _                   = panic "getCoPat"
getBangPat (BangPat pat  )   = unLoc pat
getBangPat _                 = panic "getBangPat"
getViewPat (ViewPat _ pat _) = unLoc pat
318 319 320
getViewPat _                 = panic "getViewPat"
getOLPat (ListPat pats ty (Just _)) = ListPat pats ty Nothing
getOLPat _                   = panic "getOLPat"
321

Austin Seipp's avatar
Austin Seipp committed
322
{-
323 324 325 326 327 328 329 330 331 332 333
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
334
We do *not* desugar simply to
335
   error "empty case"
336 337 338 339 340
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
341 342
************************************************************************
*                                                                      *
343
                Tidying patterns
Austin Seipp's avatar
Austin Seipp committed
344 345
*                                                                      *
************************************************************************
346

347 348 349 350 351 352 353
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
354
Replace the `as' pattern @x@@p@ with the pattern p and a binding @x = v@.
355 356 357
\item
Removing lazy (irrefutable) patterns (you don't want to know...).
\item
chak's avatar
chak committed
358
Converting explicit tuple-, list-, and parallel-array-pats into ordinary
359
@ConPats@.
360 361
\item
Convert the literal pat "" to [].
362 363 364 365 366 367 368 369 370 371 372
\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@.

373 374
\item[@LitPats@ and @NPats@:]
@LitPats@/@NPats@ of ``known friendly types'' (Int, Char,
375
Float,  Double, at least) are converted to unboxed form; e.g.,
376
\tr{(NPat (HsInt i) _ _)} is converted to:
377
\begin{verbatim}
378
(ConPat I# _ _ [LitPat (HsIntPrim i)])
379 380
\end{verbatim}
\end{description}
Austin Seipp's avatar
Austin Seipp committed
381
-}
382

383
tidyEqnInfo :: Id -> EquationInfo
384 385 386 387 388 389 390 391 392 393 394 395 396 397 398
            -> 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 = [] })
399 400 401 402 403
  = panic "tidyEqnInfo"

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

405 406 407 408
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
409

410
-------------------------------------------------------
411
--      (pat', mr') = tidy1 v pat mr
412 413 414
-- tidies the *outer level only* of pat, giving pat'
-- It eliminates many pattern forms (as-patterns, variable patterns,
-- list patterns, etc) yielding one of:
415 416 417 418 419 420 421 422
--      WildPat
--      ConPatOut
--      LitPat
--      NPat
--      NPlusKPat

tidy1 v (ParPat pat)      = tidy1 v (unLoc pat)
tidy1 v (SigPatOut pat _) = tidy1 v (unLoc pat)
423
tidy1 _ (WildPat ty)      = return (idDsWrapper, WildPat ty)
424
tidy1 v (BangPat (L l p)) = tidy_bang_pat v l p
425

426 427
        -- case v of { x -> mr[] }
        -- = case v of { _ -> let x=v in mr[] }
428
tidy1 v (VarPat (L _ var))
429
  = return (wrapBind var v, WildPat (idType var))
430

431 432
        -- case v of { x@p -> mr[] }
        -- = case v of { p -> let x=v in mr[] }
433
tidy1 v (AsPat (L _ var) pat)
434 435
  = do  { (wrap, pat') <- tidy1 v (unLoc pat)
        ; return (wrapBind var v . wrap, pat') }
436 437 438

{- now, here we handle lazy patterns:
    tidy1 v ~p bs = (v, v1 = case v of p -> v1 :
439
                        v2 = case v of p -> v2 : ... : bs )
440 441 442 443 444

    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?

445
    The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr
446 447
-}

448
tidy1 v (LazyPat pat)
Richard Eisenberg's avatar
Richard Eisenberg committed
449 450 451 452 453 454 455 456 457 458 459 460
    -- This is a convenient place to check for unlifted types under a lazy pattern.
    -- Doing this check during type-checking is unsatisfactory because we may
    -- not fully know the zonked types yet. We sure do here.
  = do  { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders pat)
        ; unless (null unlifted_bndrs) $
          putSrcSpanDs (getLoc pat) $
          errDs (hang (text "A lazy (~) pattern cannot bind variables of unlifted type." $$
                       text "Unlifted variables:")
                    2 (vcat (map (\id -> ppr id <+> dcolon <+> ppr (idType id))
                                 unlifted_bndrs)))

        ; (_,sel_prs) <- mkSelectorBinds [] pat (Var v)
461 462
        ; let sel_binds =  [NonRec b rhs | (b,rhs) <- sel_prs]
        ; return (mkCoreLets sel_binds, WildPat (idType v)) }
463

464
tidy1 _ (ListPat pats ty Nothing)
465
  = return (idDsWrapper, unLoc list_ConPat)
466
  where
467 468
    list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty])
                        (mkNilPat ty)
469
                        pats
470

471
-- Introduce fake parallel array constructors to be able to handle parallel
chak's avatar
chak committed
472
-- arrays with the existing machinery for constructor pattern
473
tidy1 _ (PArrPat pats ty)
474
  = return (idDsWrapper, unLoc parrConPat)
chak's avatar
chak committed
475 476
  where
    arity      = length pats
477
    parrConPat = mkPrefixConPat (parrFakeCon arity) pats [ty]
chak's avatar
chak committed
478

479
tidy1 _ (TuplePat pats boxity tys)
480
  = return (idDsWrapper, unLoc tuple_ConPat)
481 482
  where
    arity = length pats
483
    tuple_ConPat = mkPrefixConPat (tupleDataCon boxity arity) pats tys
484

485 486 487 488 489
tidy1 _ (SumPat pat alt arity tys)
  = return (idDsWrapper, unLoc sum_ConPat)
  where
    sum_ConPat = mkPrefixConPat (sumDataCon alt arity) [pat] tys

490
-- LitPats: we *might* be able to replace these w/ a simpler form
491
tidy1 _ (LitPat lit)
492
  = return (idDsWrapper, tidyLitPat lit)
493 494

-- NPats: we *might* be able to replace these w/ a simpler form
495 496
tidy1 _ (NPat (L _ lit) mb_neg eq ty)
  = return (idDsWrapper, tidyNPat tidyLitPat lit mb_neg eq ty)
497

498
-- Everything else goes through unchanged...
499

500
tidy1 _ non_interesting_pat
501
  = return (idDsWrapper, non_interesting_pat)
502 503 504 505

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

506
-- Discard par/sig under a bang
507 508 509 510
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
511
-- it may disappear next time
512 513 514
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)

515 516 517 518
-- 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
519
tidy_bang_pat v _ p@(SumPat {})    = tidy1 v p
520 521 522
tidy_bang_pat v _ p@(PArrPat {})   = tidy1 v p

-- Data/newtype constructors
523 524 525 526 527 528 529 530 531 532
tidy_bang_pat v l p@(ConPatOut { pat_con = L _ (RealDataCon dc)
                               , pat_args = args
                               , pat_arg_tys = arg_tys })
  -- Newtypes: push bang inwards (Trac #9844)
  =
    if isNewTyCon (dataConTyCon dc)
      then tidy1 v (p { pat_args = push_bang_into_newtype_arg l ty args })
      else tidy1 v p  -- Data types: discard the bang
    where
      (ty:_) = dataConInstArgTys dc arg_tys
533 534

-------------------
535
-- Default case, leave the bang there:
536 537 538 539 540 541 542 543
--    VarPat,
--    LazyPat,
--    WildPat,
--    ViewPat,
--    pattern synonyms (ConPatOut with PatSynCon)
--    NPat,
--    NPlusKPat
--
544 545
-- For LazyPat, remember that it's semantically like a VarPat
--  i.e.  !(~p) is not like ~p, or p!  (Trac #8952)
546 547
--
-- NB: SigPatIn, ConPatIn should not happen
548

549
tidy_bang_pat _ l p = return (idDsWrapper, BangPat (L l p))
550 551

-------------------
552 553 554 555
push_bang_into_newtype_arg :: SrcSpan
                           -> Type -- The type of the argument we are pushing
                                   -- onto
                           -> HsConPatDetails Id -> HsConPatDetails Id
556 557
-- See Note [Bang patterns and newtypes]
-- We are transforming   !(N p)   into   (N !p)
558
push_bang_into_newtype_arg l _ty (PrefixCon (arg:args))
Austin Seipp's avatar
Austin Seipp committed
559
  = ASSERT( null args)
560
    PrefixCon [L l (BangPat arg)]
561
push_bang_into_newtype_arg l _ty (RecCon rf)
562 563 564 565
  | 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) })] })
566 567 568 569
push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {})
  | HsRecFields { rec_flds = [] } <- rf
  = PrefixCon [L l (BangPat (noLoc (WildPat ty)))]
push_bang_into_newtype_arg _ _ cd
570
  = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd)
571

Austin Seipp's avatar
Austin Seipp committed
572
{-
573 574 575 576 577 578 579 580 581 582 583
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)

584 585 586
But what if there is nothing to push the bang onto? In at least one instance
a user has written !(N {}) which we translate into (N !_). See #13215

587

588 589
\noindent
{\bf Previous @matchTwiddled@ stuff:}
590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612

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
613 614
************************************************************************
*                                                                      *
615
\subsubsection[improved-unmixing]{UNIMPLEMENTED idea for improved unmixing}
Austin Seipp's avatar
Austin Seipp committed
616 617
*                                                                      *
************************************************************************
618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652

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
653 654 655 656 657
************************************************************************
*                                                                      *
*  matchWrapper: a convenient way to call @match@                      *
*                                                                      *
************************************************************************
658 659 660 661 662 663 664
\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
Gabor Greif's avatar
Gabor Greif committed
665
Typechecked @Matches@ (of a function definition, or a case or lambda
666 667 668 669 670 671 672 673 674 675 676 677
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
678
a @CoreExpr@, the desugared output (main result).
679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695
\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
696
-}
697

698
matchWrapper :: HsMatchContext Name         -- For shadowing warning messages
699
             -> Maybe (LHsExpr Id)          -- The scrutinee, if we check a case expr
700 701
             -> MatchGroup Id (LHsExpr Id)  -- Matches being desugared
             -> DsM ([Id], CoreExpr)        -- Results
702

Austin Seipp's avatar
Austin Seipp committed
703
{-
704 705
 There is one small problem with the Lambda Patterns, when somebody
 writes something similar to:
706
\begin{verbatim}
707
    (\ (x:xs) -> ...)
708
\end{verbatim}
709
 he/she don't want a warning about incomplete patterns, that is done with
710 711 712 713 714 715 716 717 718 719 720 721
 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
722 723 724
one pattern, and match simply only accepts one pattern.

JJQC 30-Nov-1997
Austin Seipp's avatar
Austin Seipp committed
725
-}
726

727 728 729 730 731 732 733
matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches
                             , mg_arg_tys = arg_tys
                             , mg_res_ty = rhs_ty
                             , mg_origin = origin })
  = do  { dflags <- getDynFlags
        ; locn   <- getSrcSpanDs

734
        ; new_vars    <- case matches of
Richard Eisenberg's avatar
Richard Eisenberg committed
735
                           []    -> mapM newSysLocalDsNoLP arg_tys
736
                           (m:_) -> selectMatchVars (map unLoc (hsLMatchPats m))
737 738 739 740

        ; eqns_info   <- mapM (mk_eqn_info new_vars) matches

        -- pattern match check warnings
741 742 743
        ; unless (isGenerated origin) $
          when (isAnyPmCheckEnabled dflags (DsMatchContext ctxt locn)) $
          addTmCsDs (genCaseTmCs1 mb_scr new_vars) $
744
              -- See Note [Type and Term Equality Propagation]
745
          checkMatches dflags (DsMatchContext ctxt locn) new_vars matches
746

747 748
        ; result_expr <- handleWarnings $
                         matchEquations ctxt new_vars eqns_info rhs_ty
749
        ; return (new_vars, result_expr) }
750
  where
751
    mk_eqn_info vars (L _ (Match _ pats _ grhss))
752
      = do { dflags <- getDynFlags
753
           ; let upats = map (unLoc . decideBangHood dflags) pats
754 755
                 dicts = toTcTypeBag (collectEvVarsPats upats) -- Only TcTyVars
           ; tm_cs <- genCaseTmCs2 mb_scr upats vars
756 757
           ; match_result <- addDictsDs dicts $ -- See Note [Type and Term Equality Propagation]
                             addTmCsDs tm_cs  $ -- See Note [Type and Term Equality Propagation]
758
                             dsGRHSs ctxt grhss rhs_ty
759
           ; return (EqnInfo { eqn_pats = upats, eqn_rhs  = match_result}) }
760

761 762 763 764
    handleWarnings = if isGenerated origin
                     then discardWarningsDs
                     else id

765 766

matchEquations  :: HsMatchContext Name
767
                -> [MatchId] -> [EquationInfo] -> Type
768
                -> DsM CoreExpr
769
matchEquations ctxt vars eqns_info rhs_ty
770
  = do  { let error_doc = matchContextErrString ctxt
771

772
        ; match_result <- match vars rhs_ty eqns_info
773

774 775
        ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_doc
        ; extractMatchResult match_result fail_expr }
776

Austin Seipp's avatar
Austin Seipp committed
777 778 779
{-
************************************************************************
*                                                                      *
780
\subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern}
Austin Seipp's avatar
Austin Seipp committed
781 782
*                                                                      *
************************************************************************
783 784 785 786

@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
787
-}
788

789 790 791 792 793 794
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
795
-- Do not warn about incomplete patterns; see matchSinglePat comments
796 797
matchSimply scrut hs_ctx pat result_expr fail_expr = do
    let
798
      match_result = cantFailMatchResult result_expr
799 800 801
      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
802
    extractMatchResult match_result' fail_expr
803

804
matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat Id
805
               -> Type -> MatchResult -> DsM MatchResult
806 807 808
-- matchSinglePat ensures that the scrutinee is a variable
-- and then calls match_single_pat_var
--
809
-- matchSinglePat does not warn about incomplete patterns
810
-- Used for things like [ e | pat <- stuff ], where
811
-- incomplete patterns are just fine
812

813
matchSinglePat (Var var) ctx pat ty match_result
814
  | not (isExternalName (idName var))
815 816 817 818 819 820 821
  = match_single_pat_var var ctx pat ty match_result

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

822 823
match_single_pat_var :: Id   -- See Note [Match Ids]
                     -> HsMatchContext Name -> LPat Id
824 825
                     -> Type -> MatchResult -> DsM MatchResult
match_single_pat_var var ctx pat ty match_result
826 827
  = ASSERT2( isInternalName (idName var), ppr var )
    do { dflags <- getDynFlags
828
       ; locn   <- getSrcSpanDs
829

830 831
                    -- Pattern match check warnings
       ; checkSingle dflags (DsMatchContext ctx locn) var (unLoc pat)
832

833 834 835
       ; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideBangHood dflags pat)]
                                , eqn_rhs  = match_result }
       ; match [var] ty [eqn_info] }
836

837

Austin Seipp's avatar
Austin Seipp committed
838 839 840
{-
************************************************************************
*                                                                      *
841
                Pattern classification
Austin Seipp's avatar
Austin Seipp committed
842 843 844
*                                                                      *
************************************************************************
-}
845 846

data PatGroup
847 848 849
  = PgAny               -- Immediate match: variables, wildcards,
                        --                  lazy patterns
  | PgCon DataCon       -- Constructor patterns (incl list, tuple)
850
  | PgSyn PatSyn [Type] -- See Note [Pattern synonym groups]
851
  | PgLit Literal       -- Literal patterns
852 853 854 855
  | PgN   Rational      -- Overloaded numeric literals;
                        -- see Note [Don't use Literal for PgN]
  | PgOverS FastString  -- Overloaded string literals
  | PgNpK Integer       -- n+k patterns
856 857 858
  | PgBang              -- Bang patterns
  | PgCo Type           -- Coercion patterns; the type is the type
                        --      of the pattern *inside*
859 860 861
  | 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)
862
  | PgOverloadedList
863

864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883
{- Note [Don't use Literal for PgN]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Previously we had, as PatGroup constructors

  | ...
  | PgN   Literal       -- Overloaded literals
  | PgNpK Literal       -- n+k patterns
  | ...

But Literal is really supposed to represent an *unboxed* literal, like Int#.
We were sticking the literal from, say, an overloaded numeric literal pattern
into a MachInt constructor. This didn't really make sense; and we now have
the invariant that value in a MachInt must be in the range of the target
machine's Int# type, and an overloaded literal could meaningfully be larger.

Solution: For pattern grouping purposes, just store the literal directly in
the PgN constructor as a Rational if numeric, and add a PgOverStr constructor
for overloaded strings.
-}

884
groupEquations :: DynFlags -> [EquationInfo] -> [[(PatGroup, EquationInfo)]]
885
-- If the result is of form [g1, g2, g3],
886 887
-- (a) all the (pg,eq) pairs in g1 have the same pg
-- (b) none of the gi are empty
888
-- The ordering of equations is unchanged
889
groupEquations dflags eqns
890
  = groupBy same_gp [(patGroup dflags (firstPat eqn), eqn) | eqn <- eqns]
891 892 893 894
  where
    same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool
    (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2

895 896 897 898 899
subGroup :: (m -> [[EquationInfo]]) -- Map.elems
         -> m -- Map.empty
         -> (a -> m -> Maybe [EquationInfo]) -- Map.lookup
         -> (a -> [EquationInfo] -> m -> m) -- Map.insert
         -> [(a, EquationInfo)] -> [[EquationInfo]]
900
-- Input is a particular group.  The result sub-groups the
901
-- equations by with particular constructor, literal etc they match.
902 903
-- Each sub-list in the result has the same PatGroup
-- See Note [Take care with pattern order]
904 905 906 907
-- Parameterized by map operations to allow different implementations
-- and constraints, eg. types without Ord instance.
subGroup elems empty lookup insert group
    = map reverse $ elems $ foldl accumulate empty group
908
  where
909
    accumulate pg_map (pg, eqn)
910 911 912
      = case lookup pg pg_map of
          Just eqns -> insert pg (eqn:eqns) pg_map
          Nothing   -> insert pg [eqn]      pg_map
913
    -- pg_map :: Map a [EquationInfo]
914
    -- Equations seen so far in reverse order of appearance
915

916 917 918 919 920 921 922
subGroupOrd :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]]
subGroupOrd = subGroup Map.elems Map.empty Map.lookup Map.insert

subGroupUniq :: Uniquable a => [(a, EquationInfo)] -> [[EquationInfo]]
subGroupUniq =
  subGroup eltsUDFM