Match.hs 43.4 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
{-# LANGUAGE CPP #-}
10
{-# LANGUAGE TypeFamilies #-}
11

12 13
module Match ( match, matchEquations, matchWrapper, matchSimply
             , matchSinglePat, matchSinglePatVar ) where
14

15
#include "HsVersions.h"
16

17 18
import GhcPrelude

19
import {-#SOURCE#-} DsExpr (dsLExpr, dsSyntaxExpr)
20

Simon Marlow's avatar
Simon Marlow committed
21
import DynFlags
22
import HsSyn
Simon Marlow's avatar
Simon Marlow committed
23
import TcHsSyn
24
import TcEvidence
25
import TcRnMonad
Simon Marlow's avatar
Simon Marlow committed
26
import Check
27
import CoreSyn
Simon Marlow's avatar
Simon Marlow committed
28 29
import Literal
import CoreUtils
30
import MkCore
31
import DsMonad
Simon Marlow's avatar
Simon Marlow committed
32 33
import DsBinds
import DsGRHSs
34
import DsUtils
Simon Marlow's avatar
Simon Marlow committed
35
import Id
Gergő Érdi's avatar
Gergő Érdi committed
36
import ConLike
Simon Marlow's avatar
Simon Marlow committed
37
import DataCon
Gergő Érdi's avatar
Gergő Érdi committed
38
import PatSyn
Simon Marlow's avatar
Simon Marlow committed
39 40 41
import MatchCon
import MatchLit
import Type
42
import Coercion ( eqCoercion )
43
import TyCon( isNewTyCon )
Simon Marlow's avatar
Simon Marlow committed
44 45 46 47 48
import TysWiredIn
import SrcLoc
import Maybes
import Util
import Name
49
import Outputable
50
import BasicTypes ( isGenerated, il_value, fl_value )
51
import FastString
52 53
import Unique
import UniqDFM
54

55
import Control.Monad( when, unless )
56
import Data.List ( groupBy )
57
import qualified Data.Map as Map
58

Austin Seipp's avatar
Austin Seipp committed
59 60 61
{-
************************************************************************
*                                                                      *
62
                The main matching function
Austin Seipp's avatar
Austin Seipp committed
63 64
*                                                                      *
************************************************************************
65

66 67
The function @match@ is basically the same as in the Wadler chapter
from "The Implementation of Functional Programming Languages",
68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85
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
86
a list of Core bindings [@(Id, CoreExpr)@ pairs] to be ``stuck on
87 88 89 90 91 92 93 94 95 96 97 98 99
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}

100
There is a data type, @EquationInfo@, defined in module @DsMonad@.
101 102 103 104 105 106 107 108

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
109
a measly expression @Var@, unless we know it will only be used once
110 111 112
(as we do in @glue_success_exprs@).

Leaving out this third argument to @match@ (and slamming in lots of
113
@Var "fail"@s) is a positively {\em bad} idea, because it makes it
114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129
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):
\item
Ian Lynagh's avatar
Ian Lynagh committed
130
Now {\em unmix} the equations into {\em blocks} [w\/ local function
131 132
@match_groups@], in which the equations in a block all have the same
 match group.
133 134
(see ``the mixture rule'' in SLPJ).
\item
135 136
Call the right match variant on each block of equations; it will do the
appropriate thing for each kind of column-1 pattern.
137 138 139 140 141 142
\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.

143 144 145
This  @match@ uses @tidyEqnInfo@
to get `as'- and `twiddle'-patterns out of the way (tidying), before
applying ``the mixture rule'' (SLPJ, p.~88) [which really {\em
146
un}mixes the equations], producing a list of equation-info
147
blocks, each block having as its first column patterns compatible with each other.
148 149 150

Note [Match Ids]
~~~~~~~~~~~~~~~~
Gabor Greif's avatar
Gabor Greif committed
151
Most of the matching functions take an Id or [Id] as argument.  This Id
152 153 154 155
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).
156 157

See also Note [Localise pattern binders] in DsUtils
Austin Seipp's avatar
Austin Seipp committed
158
-}
159

160 161 162 163
type MatchId = Id   -- See Note [Match Ids]

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

match [] ty eqns
169
  = ASSERT2( not (null eqns), ppr ty )
170
    return (foldr1 combineMatchResults match_results)
171
  where
172 173 174
    match_results = [ ASSERT( null (eqn_pats eqn) )
                      eqn_rhs eqn
                    | eqn <- eqns ]
175

176
match vars@(v:_) ty eqns    -- Eqns *can* be empty
177 178
  = ASSERT2( all (isInternalName . idName) vars, ppr vars )
    do  { dflags <- getDynFlags
179
                -- Tidy the first pattern, generating
180
                -- auxiliary bindings if necessary
181
        ; (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns
182

183
                -- Group the equations and match each group in turn
184
        ; let grouped = groupEquations dflags tidy_eqns
185 186

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

189 190 191
        ; match_results <- match_groups grouped
        ; return (adjustMatchResult (foldr (.) id aux_binds) $
                  foldr1 combineMatchResults match_results) }
192 193 194 195
  where
    dropGroup :: [(PatGroup,EquationInfo)] -> [EquationInfo]
    dropGroup = map snd

196 197 198 199 200
    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

201
    match_group :: [(PatGroup,EquationInfo)] -> DsM MatchResult
202
    match_group [] = panic "match_group"
203
    match_group eqns@((group,_) : _)
204
        = case group of
205
            PgCon {}  -> matchConFamily  vars ty (subGroupUniq [(c,e) | (PgCon c, e) <- eqns])
206
            PgSyn {}  -> matchPatSyn     vars ty (dropGroup eqns)
207
            PgLit {}  -> matchLiterals   vars ty (subGroupOrd [(l,e) | (PgLit l, e) <- eqns])
208 209
            PgAny     -> matchVariables  vars ty (dropGroup eqns)
            PgN {}    -> matchNPats      vars ty (dropGroup eqns)
210
            PgOverS {}-> matchNPats      vars ty (dropGroup eqns)
211 212 213 214
            PgNpK {}  -> matchNPlusKPats vars ty (dropGroup eqns)
            PgBang    -> matchBangs      vars ty (dropGroup eqns)
            PgCo {}   -> matchCoercion   vars ty (dropGroup eqns)
            PgView {} -> matchView       vars ty (dropGroup eqns)
215
            PgOverloadedList -> matchOverloadedList vars ty (dropGroup eqns)
216

217 218 219 220
    -- 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
221
    -- use -dppr-debug to see the resolution of overloaded literals
222 223 224
    debug eqns =
        let gs = map (\group -> foldr (\ (p,_) -> \acc ->
                                           case p of PgView e _ -> e:acc
225 226
                                                     _ -> acc) [] group) eqns
            maybeWarn [] = return ()
227
            maybeWarn l = warnDs NoReason (vcat l)
228
        in
229 230
          maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g))
                       (filter (not . null) gs))
231

232
matchEmpty :: MatchId -> Type -> DsM [MatchResult]
233 234 235 236
-- See Note [Empty case expressions]
matchEmpty var res_ty
  = return [MatchResult CanFail mk_seq]
  where
237
    mk_seq fail = return $ mkWildCase (Var var) (idType var) res_ty
238 239
                                      [(DEFAULT, [], fail)]

240
matchVariables :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
241 242
-- Real true variables, just like in matchVar, SLPJ p 94
-- No binding to do: they'll all be wildcards by now (done in tidy)
243
matchVariables (_:vars) ty eqns = match vars ty (shiftEqns eqns)
244
matchVariables [] _ _ = panic "matchVariables"
245

246
matchBangs :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
247
matchBangs (var:vars) ty eqns
248
  = do  { match_result <- match (var:vars) ty $
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
249
                          map (decomposeFirstPat getBangPat) eqns
250
        ; return (mkEvalMatchResult var ty match_result) }
251
matchBangs [] _ _ = panic "matchBangs"
252

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

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

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

297
-- decompose the first pattern and leave the rest alone
298
decomposeFirstPat :: (Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo
299
decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))
300
        = eqn { eqn_pats = extractpat pat : pats}
301
decomposeFirstPat _ _ = panic "decomposeFirstPat"
302

303
getCoPat, getBangPat, getViewPat, getOLPat :: Pat GhcTc -> Pat GhcTc
304
getCoPat (CoPat _ _ pat _)   = pat
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
305
getCoPat _                   = panic "getCoPat"
306
getBangPat (BangPat _ pat  ) = unLoc pat
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
307
getBangPat _                 = panic "getBangPat"
308
getViewPat (ViewPat _ _ pat) = unLoc pat
309
getViewPat _                 = panic "getViewPat"
310 311
getOLPat (ListPat (ListPatTc ty (Just _)) pats)
        = ListPat (ListPatTc ty Nothing)  pats
312
getOLPat _                   = panic "getOLPat"
313

Austin Seipp's avatar
Austin Seipp committed
314
{-
315 316 317 318 319 320 321 322 323 324 325
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
326
We do *not* desugar simply to
327
   error "empty case"
328 329 330 331 332
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
333 334
************************************************************************
*                                                                      *
335
                Tidying patterns
Austin Seipp's avatar
Austin Seipp committed
336 337
*                                                                      *
************************************************************************
338

339
Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@
340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369
which will be scrutinised.

This makes desugaring the pattern match simpler by transforming some of
the patterns to simpler forms. (Tuples to Constructor Patterns)

Among other things in the resulting Pattern:
* Variables and irrefutable(lazy) patterns are replaced by Wildcards
* As patterns are replaced by the patterns they wrap.

The bindings created by the above patterns are put into the returned wrapper
instead.

This means a definition of the form:
  f x = rhs
when called with v get's desugared to the equivalent of:
  let x = v
  in
  f _ = rhs

The same principle holds for as patterns (@) and
irrefutable/lazy patterns (~).
In the case of irrefutable patterns the irrefutable pattern is pushed into
the binding.

Pattern Constructors which only represent syntactic sugar are converted into
their desugared representation.
This usually means converting them to Constructor patterns but for some
depends on enabled extensions. (Eg OverloadedLists)

GHC also tries to convert overloaded Literals into regular ones.
370 371

The result of this tidying is that the column of patterns will include
372 373
only these which can be assigned a PatternGroup (see patGroup).

Austin Seipp's avatar
Austin Seipp committed
374
-}
375

376
tidyEqnInfo :: Id -> EquationInfo
377 378 379 380 381 382 383
            -> 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
384
        --      one of these for which patGroup is defined.
385 386

tidyEqnInfo _ (EqnInfo { eqn_pats = [] })
387 388 389 390 391
  = panic "tidyEqnInfo"

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

393 394 395 396
tidy1 :: Id                  -- The Id being scrutinised
      -> Pat GhcTc           -- The pattern against which it is to be matched
      -> DsM (DsWrapper,     -- Extra bindings to do before the match
              Pat GhcTc)     -- Equivalent pattern
397

398
-------------------------------------------------------
399
--      (pat', mr') = tidy1 v pat mr
400 401
-- tidies the *outer level only* of pat, giving pat'
-- It eliminates many pattern forms (as-patterns, variable patterns,
402
-- list patterns, etc) and returns any created bindings in the wrapper.
403

404
tidy1 v (ParPat _ pat)      = tidy1 v (unLoc pat)
405
tidy1 v (SigPat _ pat _)    = tidy1 v (unLoc pat)
406 407
tidy1 _ (WildPat ty)        = return (idDsWrapper, WildPat ty)
tidy1 v (BangPat _ (L l p)) = tidy_bang_pat v l p
408

409 410
        -- case v of { x -> mr[] }
        -- = case v of { _ -> let x=v in mr[] }
411
tidy1 v (VarPat _ (L _ var))
412
  = return (wrapBind var v, WildPat (idType var))
413

414 415
        -- case v of { x@p -> mr[] }
        -- = case v of { p -> let x=v in mr[] }
416
tidy1 v (AsPat _ (L _ var) pat)
417 418
  = do  { (wrap, pat') <- tidy1 v (unLoc pat)
        ; return (wrapBind var v . wrap, pat') }
419 420 421

{- now, here we handle lazy patterns:
    tidy1 v ~p bs = (v, v1 = case v of p -> v1 :
422
                        v2 = case v of p -> v2 : ... : bs )
423 424 425 426 427

    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?

428
    The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr
429 430
-}

431
tidy1 v (LazyPat _ pat)
Richard Eisenberg's avatar
Richard Eisenberg committed
432 433 434 435 436 437 438 439 440 441 442 443
    -- 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)
444 445
        ; let sel_binds =  [NonRec b rhs | (b,rhs) <- sel_prs]
        ; return (mkCoreLets sel_binds, WildPat (idType v)) }
446

447
tidy1 _ (ListPat (ListPatTc ty Nothing) pats )
448
  = return (idDsWrapper, unLoc list_ConPat)
449
  where
450 451
    list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty])
                        (mkNilPat ty)
452
                        pats
453

454
tidy1 _ (TuplePat tys pats boxity)
455
  = return (idDsWrapper, unLoc tuple_ConPat)
456 457
  where
    arity = length pats
458
    tuple_ConPat = mkPrefixConPat (tupleDataCon boxity arity) pats tys
459

460
tidy1 _ (SumPat tys pat alt arity)
461 462 463 464
  = return (idDsWrapper, unLoc sum_ConPat)
  where
    sum_ConPat = mkPrefixConPat (sumDataCon alt arity) [pat] tys

465
-- LitPats: we *might* be able to replace these w/ a simpler form
466
tidy1 _ (LitPat _ lit)
467
  = return (idDsWrapper, tidyLitPat lit)
468 469

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

473
-- Everything else goes through unchanged...
474

475
tidy1 _ non_interesting_pat
476
  = return (idDsWrapper, non_interesting_pat)
477 478

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

481
-- Discard par/sig under a bang
482
tidy_bang_pat v _ (ParPat _ (L l p)) = tidy_bang_pat v l p
483
tidy_bang_pat v _ (SigPat _ (L l p) _) = tidy_bang_pat v l p
484 485

-- Push the bang-pattern inwards, in the hope that
486
-- it may disappear next time
487 488 489
tidy_bang_pat v l (AsPat x v' p) = tidy1 v (AsPat x v' (L l (BangPat noExt p)))
tidy_bang_pat v l (CoPat x w p t)
  = tidy1 v (CoPat x w (BangPat noExt (L l p)) t)
490

491 492 493 494
-- 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
495
tidy_bang_pat v _ p@(SumPat {})    = tidy1 v p
496 497

-- Data/newtype constructors
498 499 500 501 502 503 504 505 506 507
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
508 509

-------------------
510
-- Default case, leave the bang there:
511 512 513 514 515 516 517 518
--    VarPat,
--    LazyPat,
--    WildPat,
--    ViewPat,
--    pattern synonyms (ConPatOut with PatSynCon)
--    NPat,
--    NPlusKPat
--
519 520
-- For LazyPat, remember that it's semantically like a VarPat
--  i.e.  !(~p) is not like ~p, or p!  (Trac #8952)
521 522
--
-- NB: SigPatIn, ConPatIn should not happen
523

524
tidy_bang_pat _ l p = return (idDsWrapper, BangPat noExt (L l p))
525 526

-------------------
527 528 529
push_bang_into_newtype_arg :: SrcSpan
                           -> Type -- The type of the argument we are pushing
                                   -- onto
530
                           -> HsConPatDetails GhcTc -> HsConPatDetails GhcTc
531 532
-- See Note [Bang patterns and newtypes]
-- We are transforming   !(N p)   into   (N !p)
533
push_bang_into_newtype_arg l _ty (PrefixCon (arg:args))
Austin Seipp's avatar
Austin Seipp committed
534
  = ASSERT( null args)
535
    PrefixCon [L l (BangPat noExt arg)]
536
push_bang_into_newtype_arg l _ty (RecCon rf)
537 538 539
  | HsRecFields { rec_flds = L lf fld : flds } <- rf
  , HsRecField { hsRecFieldArg = arg } <- fld
  = ASSERT( null flds)
540 541
    RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg
                                           = L l (BangPat noExt arg) })] })
542 543
push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {})
  | HsRecFields { rec_flds = [] } <- rf
544
  = PrefixCon [L l (BangPat noExt (noLoc (WildPat ty)))]
545
push_bang_into_newtype_arg _ _ cd
546
  = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd)
547

Austin Seipp's avatar
Austin Seipp committed
548
{-
549 550 551 552 553 554 555 556 557 558 559
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)

560 561 562
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

563

564 565
\noindent
{\bf Previous @matchTwiddled@ stuff:}
566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588

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
589 590
************************************************************************
*                                                                      *
591
\subsubsection[improved-unmixing]{UNIMPLEMENTED idea for improved unmixing}
Austin Seipp's avatar
Austin Seipp committed
592 593
*                                                                      *
************************************************************************
594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628

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
629 630 631 632 633
************************************************************************
*                                                                      *
*  matchWrapper: a convenient way to call @match@                      *
*                                                                      *
************************************************************************
634 635 636 637 638 639 640
\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
641
Typechecked @Matches@ (of a function definition, or a case or lambda
642 643 644 645 646 647 648 649 650 651 652 653
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
654
a @CoreExpr@, the desugared output (main result).
655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671
\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
672
-}
673

674 675 676 677
matchWrapper :: HsMatchContext Name    -- For shadowing warning messages
             -> Maybe (LHsExpr GhcTc)  -- The scrutinee, if we check a case expr
             -> MatchGroup GhcTc (LHsExpr GhcTc)   -- Matches being desugared
             -> DsM ([Id], CoreExpr)   -- Results
678

Austin Seipp's avatar
Austin Seipp committed
679
{-
680 681
 There is one small problem with the Lambda Patterns, when somebody
 writes something similar to:
682
\begin{verbatim}
683
    (\ (x:xs) -> ...)
684
\end{verbatim}
685
 he/she don't want a warning about incomplete patterns, that is done with
686 687 688 689 690 691 692 693 694 695 696 697
 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
698 699 700
one pattern, and match simply only accepts one pattern.

JJQC 30-Nov-1997
Austin Seipp's avatar
Austin Seipp committed
701
-}
702

703
matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches
704
                             , mg_ext = MatchGroupTc arg_tys rhs_ty
705 706 707 708
                             , mg_origin = origin })
  = do  { dflags <- getDynFlags
        ; locn   <- getSrcSpanDs

709
        ; new_vars    <- case matches of
Richard Eisenberg's avatar
Richard Eisenberg committed
710
                           []    -> mapM newSysLocalDsNoLP arg_tys
711
                           (m:_) -> selectMatchVars (map unLoc (hsLMatchPats m))
712 713 714 715

        ; eqns_info   <- mapM (mk_eqn_info new_vars) matches

        -- pattern match check warnings
716 717 718
        ; unless (isGenerated origin) $
          when (isAnyPmCheckEnabled dflags (DsMatchContext ctxt locn)) $
          addTmCsDs (genCaseTmCs1 mb_scr new_vars) $
719
              -- See Note [Type and Term Equality Propagation]
720
          checkMatches dflags (DsMatchContext ctxt locn) new_vars matches
721

722 723
        ; result_expr <- handleWarnings $
                         matchEquations ctxt new_vars eqns_info rhs_ty
724
        ; return (new_vars, result_expr) }
725
  where
Simon Peyton Jones's avatar
Simon Peyton Jones committed
726
    mk_eqn_info vars (L _ (Match { m_pats = pats, m_grhss = grhss }))
727
      = do { dflags <- getDynFlags
Simon Peyton Jones's avatar
Simon Peyton Jones committed
728
           ; let upats = map (unLoc . decideBangHood dflags) pats
Simon Peyton Jones's avatar
Simon Peyton Jones committed
729
                 dicts = collectEvVarsPats upats
730
           ; tm_cs <- genCaseTmCs2 mb_scr upats vars
731 732
           ; match_result <- addDictsDs dicts $ -- See Note [Type and Term Equality Propagation]
                             addTmCsDs tm_cs  $ -- See Note [Type and Term Equality Propagation]
733
                             dsGRHSs ctxt grhss rhs_ty
734
           ; return (EqnInfo { eqn_pats = upats, eqn_rhs = match_result}) }
735
    mk_eqn_info _ (L _ (XMatch _)) = panic "matchWrapper"
736

737 738 739
    handleWarnings = if isGenerated origin
                     then discardWarningsDs
                     else id
740
matchWrapper _ _ (XMatchGroup _) = panic "matchWrapper"
741 742

matchEquations  :: HsMatchContext Name
743
                -> [MatchId] -> [EquationInfo] -> Type
744
                -> DsM CoreExpr
745
matchEquations ctxt vars eqns_info rhs_ty
746
  = do  { let error_doc = matchContextErrString ctxt
747

748
        ; match_result <- match vars rhs_ty eqns_info
749

750 751
        ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_doc
        ; extractMatchResult match_result fail_expr }
752

Austin Seipp's avatar
Austin Seipp committed
753 754 755
{-
************************************************************************
*                                                                      *
756
\subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern}
Austin Seipp's avatar
Austin Seipp committed
757 758
*                                                                      *
************************************************************************
759 760 761 762

@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
763
-}
764

765 766
matchSimply :: CoreExpr                 -- Scrutinee
            -> HsMatchContext Name      -- Match kind
767
            -> LPat GhcTc               -- Pattern it should match
768 769 770
            -> CoreExpr                 -- Return this if it matches
            -> CoreExpr                 -- Return this if it doesn't
            -> DsM CoreExpr
771
-- Do not warn about incomplete patterns; see matchSinglePat comments
772 773
matchSimply scrut hs_ctx pat result_expr fail_expr = do
    let
774
      match_result = cantFailMatchResult result_expr
775 776 777
      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
778
    extractMatchResult match_result' fail_expr
779

780
matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat GhcTc
781
               -> Type -> MatchResult -> DsM MatchResult
782
-- matchSinglePat ensures that the scrutinee is a variable
783
-- and then calls matchSinglePatVar
784
--
785
-- matchSinglePat does not warn about incomplete patterns
786
-- Used for things like [ e | pat <- stuff ], where
787
-- incomplete patterns are just fine
788

789
matchSinglePat (Var var) ctx pat ty match_result
790
  | not (isExternalName (idName var))
791
  = matchSinglePatVar var ctx pat ty match_result
792 793 794

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

798 799 800 801
matchSinglePatVar :: Id   -- See Note [Match Ids]
                  -> HsMatchContext Name -> LPat GhcTc
                  -> Type -> MatchResult -> DsM MatchResult
matchSinglePatVar var ctx pat ty match_result
802 803
  = ASSERT2( isInternalName (idName var), ppr var )
    do { dflags <- getDynFlags
804
       ; locn   <- getSrcSpanDs
805

806 807
                    -- Pattern match check warnings
       ; checkSingle dflags (DsMatchContext ctx locn) var (unLoc pat)
808

809 810 811
       ; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideBangHood dflags pat)]
                                , eqn_rhs  = match_result }
       ; match [var] ty [eqn_info] }
812

813

Austin Seipp's avatar
Austin Seipp committed
814 815 816
{-
************************************************************************
*                                                                      *
817
                Pattern classification
Austin Seipp's avatar
Austin Seipp committed
818 819 820
*                                                                      *
************************************************************************
-}
821 822

data PatGroup
823 824 825
  = PgAny               -- Immediate match: variables, wildcards,
                        --                  lazy patterns
  | PgCon DataCon       -- Constructor patterns (incl list, tuple)
826
  | PgSyn PatSyn [Type] -- See Note [Pattern synonym groups]
827
  | PgLit Literal       -- Literal patterns
828 829 830 831
  | PgN   Rational      -- Overloaded numeric literals;
                        -- see Note [Don't use Literal for PgN]
  | PgOverS FastString  -- Overloaded string literals
  | PgNpK Integer       -- n+k patterns
832 833 834
  | PgBang              -- Bang patterns
  | PgCo Type           -- Coercion patterns; the type is the type
                        --      of the pattern *inside*
835
  | PgView (LHsExpr GhcTc) -- view pattern (e -> p):
836 837
                        -- the LHsExpr is the expression e
           Type         -- the Type is the type of p (equivalently, the result type of e)