Match.hs 46.8 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 11
{-# LANGUAGE MonadComprehensions #-}
{-# LANGUAGE OverloadedLists #-}
12
{-# LANGUAGE TypeFamilies #-}
13
{-# LANGUAGE ViewPatterns #-}
14

15 16 17
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}

18 19 20 21 22
module GHC.HsToCore.Match
   ( match, matchEquations, matchWrapper, matchSimply
   , matchSinglePat, matchSinglePatVar
   )
where
23

24
#include "HsVersions.h"
25

26
import GhcPrelude
Sylvain Henry's avatar
Sylvain Henry committed
27
import GHC.Platform
28

29
import {-#SOURCE#-} GHC.HsToCore.Expr (dsLExpr, dsSyntaxExpr)
30

31
import BasicTypes ( Origin(..) )
Sylvain Henry's avatar
Sylvain Henry committed
32
import GHC.Driver.Session
33
import GHC.Hs
Simon Marlow's avatar
Simon Marlow committed
34
import TcHsSyn
35
import TcEvidence
36
import TcRnMonad
37
import GHC.HsToCore.PmCheck
Sylvain Henry's avatar
Sylvain Henry committed
38
import GHC.Core
Simon Marlow's avatar
Simon Marlow committed
39
import Literal
Sylvain Henry's avatar
Sylvain Henry committed
40 41
import GHC.Core.Utils
import GHC.Core.Make
42 43 44 45
import GHC.HsToCore.Monad
import GHC.HsToCore.Binds
import GHC.HsToCore.GuardedRHSs
import GHC.HsToCore.Utils
Simon Marlow's avatar
Simon Marlow committed
46
import Id
Sylvain Henry's avatar
Sylvain Henry committed
47 48 49
import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Core.PatSyn
50 51
import GHC.HsToCore.Match.Constructor
import GHC.HsToCore.Match.Literal
Sylvain Henry's avatar
Sylvain Henry committed
52 53 54
import GHC.Core.Type
import GHC.Core.Coercion ( eqCoercion )
import GHC.Core.TyCon    ( isNewTyCon )
Simon Marlow's avatar
Simon Marlow committed
55 56 57 58 59
import TysWiredIn
import SrcLoc
import Maybes
import Util
import Name
60
import Outputable
61
import BasicTypes ( isGenerated, il_value, fl_value )
62
import FastString
63 64
import Unique
import UniqDFM
65

66
import Control.Monad( unless )
67 68
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NEL
69
import qualified Data.Map as Map
70

Austin Seipp's avatar
Austin Seipp committed
71 72 73
{-
************************************************************************
*                                                                      *
74
                The main matching function
Austin Seipp's avatar
Austin Seipp committed
75 76
*                                                                      *
************************************************************************
77

78 79
The function @match@ is basically the same as in the Wadler chapter
from "The Implementation of Functional Programming Languages",
80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97
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
98
a list of Core bindings [@(Id, CoreExpr)@ pairs] to be ``stuck on
99 100 101 102 103 104 105 106 107 108 109 110 111
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}

112
There is a data type, @EquationInfo@, defined in module @GHC.HsToCore.Monad@.
113 114 115 116 117 118 119 120

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
121
a measly expression @Var@, unless we know it will only be used once
122 123 124
(as we do in @glue_success_exprs@).

Leaving out this third argument to @match@ (and slamming in lots of
125
@Var "fail"@s) is a positively {\em bad} idea, because it makes it
126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141
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
142
Now {\em unmix} the equations into {\em blocks} [w\/ local function
143 144
@match_groups@], in which the equations in a block all have the same
 match group.
145 146
(see ``the mixture rule'' in SLPJ).
\item
147 148
Call the right match variant on each block of equations; it will do the
appropriate thing for each kind of column-1 pattern.
149 150 151 152 153 154
\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.

155 156 157
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
158
un}mixes the equations], producing a list of equation-info
159
blocks, each block having as its first column patterns compatible with each other.
160 161 162

Note [Match Ids]
~~~~~~~~~~~~~~~~
Gabor Greif's avatar
Gabor Greif committed
163
Most of the matching functions take an Id or [Id] as argument.  This Id
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
167
with External names (#13043).
168

169
See also Note [Localise pattern binders] in GHC.HsToCore.Utils
Austin Seipp's avatar
Austin Seipp committed
170
-}
171

172 173
type MatchId = Id   -- See Note [Match Ids]

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

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

187
match (v:vs) ty eqns    -- Eqns *can* be empty
188 189
  = ASSERT2( all (isInternalName . idName) vars, ppr vars )
    do  { dflags <- getDynFlags
Sylvain Henry's avatar
Sylvain Henry committed
190
        ; let platform = targetPlatform dflags
191
                -- Tidy the first pattern, generating
192
                -- auxiliary bindings if necessary
193
        ; (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns
194
                -- Group the equations and match each group in turn
Sylvain Henry's avatar
Sylvain Henry committed
195
        ; let grouped = groupEquations platform tidy_eqns
196 197

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

200 201 202
        ; match_results <- match_groups grouped
        ; return (adjustMatchResult (foldr (.) id aux_binds) $
                  foldr1 combineMatchResults match_results) }
203
  where
204 205 206 207
    vars = v :| vs

    dropGroup :: Functor f => f (PatGroup,EquationInfo) -> f EquationInfo
    dropGroup = fmap snd
208

209
    match_groups :: [NonEmpty (PatGroup,EquationInfo)] -> DsM (NonEmpty MatchResult)
210 211
    -- Result list of [MatchResult] is always non-empty
    match_groups [] = matchEmpty v ty
212
    match_groups (g:gs) = mapM match_group $ g :| gs
213

214 215
    match_group :: NonEmpty (PatGroup,EquationInfo) -> DsM MatchResult
    match_group eqns@((group,_) :| _)
216
        = case group of
217
            PgCon {}  -> matchConFamily  vars ty (ne $ subGroupUniq [(c,e) | (PgCon c, e) <- eqns'])
218
            PgSyn {}  -> matchPatSyn     vars ty (dropGroup eqns)
219
            PgLit {}  -> matchLiterals   vars ty (ne $ subGroupOrd [(l,e) | (PgLit l, e) <- eqns'])
220 221
            PgAny     -> matchVariables  vars ty (dropGroup eqns)
            PgN {}    -> matchNPats      vars ty (dropGroup eqns)
222
            PgOverS {}-> matchNPats      vars ty (dropGroup eqns)
223 224 225 226
            PgNpK {}  -> matchNPlusKPats vars ty (dropGroup eqns)
            PgBang    -> matchBangs      vars ty (dropGroup eqns)
            PgCo {}   -> matchCoercion   vars ty (dropGroup eqns)
            PgView {} -> matchView       vars ty (dropGroup eqns)
227
            PgOverloadedList -> matchOverloadedList vars ty (dropGroup eqns)
228 229 230 231
      where eqns' = NEL.toList eqns
            ne l = case NEL.nonEmpty l of
              Just nel -> nel
              Nothing -> pprPanic "match match_group" $ text "Empty result should be impossible since input was non-empty"
232

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

248
matchEmpty :: MatchId -> Type -> DsM (NonEmpty MatchResult)
249 250 251 252
-- See Note [Empty case expressions]
matchEmpty var res_ty
  = return [MatchResult CanFail mk_seq]
  where
253
    mk_seq fail = return $ mkWildCase (Var var) (idType var) res_ty
254 255
                                      [(DEFAULT, [], fail)]

256
matchVariables :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult
257 258
-- Real true variables, just like in matchVar, SLPJ p 94
-- No binding to do: they'll all be wildcards by now (done in tidy)
259
matchVariables (_ :| vars) ty eqns = match vars ty $ NEL.toList $ shiftEqns eqns
260

261 262 263 264
matchBangs :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult
matchBangs (var :| vars) ty eqns
  = do  { match_result <- match (var:vars) ty $ NEL.toList $
            decomposeFirstPat getBangPat <$> eqns
265
        ; return (mkEvalMatchResult var ty match_result) }
266

267
matchCoercion :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult
268
-- Apply the coercion to the match variable and then match that
269
matchCoercion (var :| vars) ty (eqns@(eqn1 :| _))
270
  = do  { let CoPat _ co pat _ = firstPat eqn1
271 272
        ; let pat_ty' = hsPatType pat
        ; var' <- newUniqueId var pat_ty'
273 274
        ; match_result <- match (var':vars) ty $ NEL.toList $
            decomposeFirstPat getCoPat <$> eqns
275 276 277
        ; core_wrap <- dsHsWrapper co
        ; let bind = NonRec var' (core_wrap (Var var))
        ; return (mkCoLetMatchResult bind match_result) }
278

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

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

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

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

Austin Seipp's avatar
Austin Seipp committed
326
{-
327 328 329 330 331 332 333 334 335
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
Sylvain Henry's avatar
Sylvain Henry committed
336
alternatives] in GHC.Core.)
337

Gabor Greif's avatar
Gabor Greif committed
338
We do *not* desugar simply to
339
   error "empty case"
340 341
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").
342
See also Note [Case elimination: lifted case] in GHC.Core.Op.Simplify.
343 344


Austin Seipp's avatar
Austin Seipp committed
345 346
************************************************************************
*                                                                      *
347
                Tidying patterns
Austin Seipp's avatar
Austin Seipp committed
348 349
*                                                                      *
************************************************************************
350

351
Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@
352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381
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.
382 383

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

Austin Seipp's avatar
Austin Seipp committed
386
-}
387

388
tidyEqnInfo :: Id -> EquationInfo
389 390 391 392 393 394 395
            -> 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
396
        --      one of these for which patGroup is defined.
397 398

tidyEqnInfo _ (EqnInfo { eqn_pats = [] })
399 400
  = panic "tidyEqnInfo"

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

405
tidy1 :: Id                  -- The Id being scrutinised
406
      -> Origin              -- Was this a pattern the user wrote?
407 408 409
      -> Pat GhcTc           -- The pattern against which it is to be matched
      -> DsM (DsWrapper,     -- Extra bindings to do before the match
              Pat GhcTc)     -- Equivalent pattern
410

411
-------------------------------------------------------
412
--      (pat', mr') = tidy1 v pat mr
413 414
-- tidies the *outer level only* of pat, giving pat'
-- It eliminates many pattern forms (as-patterns, variable patterns,
415
-- list patterns, etc) and returns any created bindings in the wrapper.
416

417 418 419
tidy1 v o (ParPat _ pat)      = tidy1 v o (unLoc pat)
tidy1 v o (SigPat _ pat _)    = tidy1 v o (unLoc pat)
tidy1 _ _ (WildPat ty)        = return (idDsWrapper, WildPat ty)
420
tidy1 v o (BangPat _ (L l p)) = tidy_bang_pat v o l p
421

422 423
        -- case v of { x -> mr[] }
        -- = case v of { _ -> let x=v in mr[] }
424
tidy1 v _ (VarPat _ (L _ var))
425
  = return (wrapBind var v, WildPat (idType var))
426

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

{- now, here we handle lazy patterns:
    tidy1 v ~p bs = (v, v1 = case v of p -> v1 :
435
                        v2 = case v of p -> v2 : ... : bs )
436 437 438 439 440

    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?

441
    The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr
442 443
-}

444
tidy1 v _ (LazyPat _ pat)
445 446 447 448 449 450 451 452 453 454 455 456
    -- 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)
457 458
        ; let sel_binds =  [NonRec b rhs | (b,rhs) <- sel_prs]
        ; return (mkCoreLets sel_binds, WildPat (idType v)) }
459

460
tidy1 _ _ (ListPat (ListPatTc ty Nothing) pats )
461
  = return (idDsWrapper, unLoc list_ConPat)
462
  where
463 464
    list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty])
                        (mkNilPat ty)
465
                        pats
466

467
tidy1 _ _ (TuplePat tys pats boxity)
468
  = return (idDsWrapper, unLoc tuple_ConPat)
469 470
  where
    arity = length pats
471
    tuple_ConPat = mkPrefixConPat (tupleDataCon boxity arity) pats tys
472

473
tidy1 _ _ (SumPat tys pat alt arity)
474 475 476 477
  = return (idDsWrapper, unLoc sum_ConPat)
  where
    sum_ConPat = mkPrefixConPat (sumDataCon alt arity) [pat] tys

478
-- LitPats: we *might* be able to replace these w/ a simpler form
479 480 481 482
tidy1 _ o (LitPat _ lit)
  = do { unless (isGenerated o) $
           warnAboutOverflowedLit lit
       ; return (idDsWrapper, tidyLitPat lit) }
483 484

-- NPats: we *might* be able to replace these w/ a simpler form
485
tidy1 _ o (NPat ty (L _ lit@OverLit { ol_val = v }) mb_neg eq)
486 487 488 489 490 491 492
  = do { unless (isGenerated o) $
           let lit' | Just _ <- mb_neg = lit{ ol_val = negateOverLitVal v }
                    | otherwise = lit
           in warnAboutOverflowedOverLit lit'
       ; return (idDsWrapper, tidyNPat lit mb_neg eq ty) }

-- NPlusKPat: we may want to warn about the literals
493
tidy1 _ o n@(NPlusKPat _ _ (L _ lit1) lit2 _ _)
494 495 496 497
  = do { unless (isGenerated o) $ do
           warnAboutOverflowedOverLit lit1
           warnAboutOverflowedOverLit lit2
       ; return (idDsWrapper, n) }
498

499
-- Everything else goes through unchanged...
500
tidy1 _ _ non_interesting_pat
501
  = return (idDsWrapper, non_interesting_pat)
502 503

--------------------
504 505
tidy_bang_pat :: Id -> Origin -> SrcSpan -> Pat GhcTc
              -> DsM (DsWrapper, Pat GhcTc)
506

507
-- Discard par/sig under a bang
508 509
tidy_bang_pat v o _ (ParPat _ (L l p)) = tidy_bang_pat v o l p
tidy_bang_pat v o _ (SigPat _ (L l p) _) = tidy_bang_pat v o l p
510 511

-- Push the bang-pattern inwards, in the hope that
512
-- it may disappear next time
513
tidy_bang_pat v o l (AsPat x v' p)
514
  = tidy1 v o (AsPat x v' (L l (BangPat noExtField p)))
515
tidy_bang_pat v o l (CoPat x w p t)
516
  = tidy1 v o (CoPat x w (BangPat noExtField (L l p)) t)
517

518
-- Discard bang around strict pattern
519 520 521 522
tidy_bang_pat v o _ p@(LitPat {})    = tidy1 v o p
tidy_bang_pat v o _ p@(ListPat {})   = tidy1 v o p
tidy_bang_pat v o _ p@(TuplePat {})  = tidy1 v o p
tidy_bang_pat v o _ p@(SumPat {})    = tidy1 v o p
523 524

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

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

551
tidy_bang_pat _ _ l p = return (idDsWrapper, BangPat noExtField (L l p))
552 553

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

Austin Seipp's avatar
Austin Seipp committed
575
{-
576 577 578 579 580
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
581
we definitely can't discard the bang.  #9844.
582 583 584 585 586

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)

587 588 589
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

590

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

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
616 617
************************************************************************
*                                                                      *
618
\subsubsection[improved-unmixing]{UNIMPLEMENTED idea for improved unmixing}
Austin Seipp's avatar
Austin Seipp committed
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 653 654 655

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

701
matchWrapper
702
  :: HsMatchContext GhcRn              -- ^ For shadowing warning messages
703 704 705 706 707 708 709
  -> Maybe (LHsExpr GhcTc)             -- ^ Scrutinee. (Just scrut) for a case expr
                                       --      case scrut of { p1 -> e1 ... }
                                       --   (and in this case the MatchGroup will
                                       --    have all singleton patterns)
                                       --   Nothing for a function definition
                                       --      f p1 q1 = ...  -- No "scrutinee"
                                       --      f p2 q2 = ...  -- in this case
710 711
  -> MatchGroup GhcTc (LHsExpr GhcTc)  -- ^ Matches being desugared
  -> DsM ([Id], CoreExpr)              -- ^ Results (usually passed to 'match')
712

Austin Seipp's avatar
Austin Seipp committed
713
{-
714 715
 There is one small problem with the Lambda Patterns, when somebody
 writes something similar to:
716
\begin{verbatim}
717
    (\ (x:xs) -> ...)
718
\end{verbatim}
719
 he/she don't want a warning about incomplete patterns, that is done with
720 721 722 723 724
 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
725
      (see @GHC.HsToCore.Expr.doDo@ function)
726 727 728 729 730 731
\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
732 733 734
one pattern, and match simply only accepts one pattern.

JJQC 30-Nov-1997
Austin Seipp's avatar
Austin Seipp committed
735
-}
736

737
matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches
738
                             , mg_ext = MatchGroupTc arg_tys rhs_ty
739 740 741 742
                             , mg_origin = origin })
  = do  { dflags <- getDynFlags
        ; locn   <- getSrcSpanDs

743
        ; new_vars    <- case matches of
744
                           []    -> mapM newSysLocalDsNoLP arg_tys
745
                           (m:_) -> selectMatchVars (map unLoc (hsLMatchPats m))
746

747 748 749 750 751 752 753 754 755
        -- Pattern match check warnings for /this match-group/.
        -- @rhss_deltas@ is a flat list of covered Deltas for each RHS.
        -- Each Match will split off one Deltas for its RHSs from this.
        ; rhss_deltas <- if isMatchContextPmChecked dflags origin ctxt
            then addScrutTmCs mb_scr new_vars $
              -- See Note [Type and Term Equality Propagation]
              checkMatches (DsMatchContext ctxt locn) new_vars matches
            else pure [] -- Ultimately this will result in passing Nothing
                         -- to dsGRHSs as match_deltas
756

757
        ; eqns_info   <- mk_eqn_infos matches rhss_deltas
758

759 760
        ; result_expr <- handleWarnings $
                         matchEquations ctxt new_vars eqns_info rhs_ty
761
        ; return (new_vars, result_expr) }
762
  where
763 764 765 766 767 768 769 770
    -- rhss_deltas is a flat list, whereas there are multiple GRHSs per match.
    -- mk_eqn_infos will thread rhss_deltas as state through calls to
    -- mk_eqn_info, distributing each rhss_deltas to a GRHS.
    mk_eqn_infos (L _ match : matches) rhss_deltas
      = do { (info, rhss_deltas') <- mk_eqn_info  match   rhss_deltas
           ; infos                <- mk_eqn_infos matches rhss_deltas'
           ; return (info:infos) }
    mk_eqn_infos [] _ = return []
771
    -- Called once per equation in the match, or alternative in the case
772 773 774
    mk_eqn_info (Match { m_pats = pats, m_grhss = grhss }) rhss_deltas
      | XGRHSs nec <- grhss = noExtCon nec
      | GRHSs _ grhss' _  <- grhss, let n_grhss = length grhss'
775
      = do { dflags <- getDynFlags
Simon Peyton Jones's avatar
Simon Peyton Jones committed
776
           ; let upats = map (unLoc . decideBangHood dflags) pats
777 778 779 780 781 782 783 784 785 786 787 788 789
           -- Split off one Deltas for each GRHS of the current Match from the
           -- flat list of GRHS Deltas *for all matches* (see the call to
           -- checkMatches above).
           ; let (match_deltas, rhss_deltas') = splitAt n_grhss rhss_deltas
           -- The list of Deltas is empty iff we don't perform any coverage
           -- checking, in which case nonEmpty does the right thing by passing
           -- Nothing.
           ; match_result <- dsGRHSs ctxt grhss rhs_ty (NEL.nonEmpty match_deltas)
           ; return ( EqnInfo { eqn_pats = upats
                              , eqn_orig = FromSource
                              , eqn_rhs = match_result }
                    , rhss_deltas' ) }
    mk_eqn_info (XMatch nec) _ = noExtCon nec
790

791 792 793
    handleWarnings = if isGenerated origin
                     then discardWarningsDs
                     else id
794
matchWrapper _ _ (XMatchGroup nec) = noExtCon nec
795

796
matchEquations  :: HsMatchContext GhcRn
797
                -> [MatchId] -> [EquationInfo] -> Type
798
                -> DsM CoreExpr
799
matchEquations ctxt vars eqns_info rhs_ty
800
  = do  { let error_doc = matchContextErrString ctxt
801

802
        ; match_result <- match vars rhs_ty eqns_info
803

804 805
        ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_doc
        ; extractMatchResult match_result fail_expr }
806

Austin Seipp's avatar
Austin Seipp committed
807 808 809
{-
************************************************************************
*                                                                      *
810
\subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern}
Austin Seipp's avatar
Austin Seipp committed
811 812
*                                                                      *
************************************************************************
813 814 815 816

@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
817
-}
818

819
matchSimply :: CoreExpr                 -- ^ Scrutinee
820
            -> HsMatchContext GhcRn     -- ^ Match kind
821 822 823
            -> LPat GhcTc               -- ^ Pattern it should match
            -> CoreExpr                 -- ^ Return this if it matches
            -> CoreExpr                 -- ^ Return this if it doesn't
824
            -> DsM CoreExpr
825
-- Do not warn about incomplete patterns; see matchSinglePat comments
826 827
matchSimply scrut hs_ctx pat result_expr fail_expr = do
    let
828
      match_result = cantFailMatchResult result_expr
829 830 831
      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
832
    extractMatchResult match_result' fail_expr
833

834
matchSinglePat :: CoreExpr -> HsMatchContext GhcRn -> LPat GhcTc
835
               -> Type -> MatchResult -> DsM MatchResult
836
-- matchSinglePat ensures that the scrutinee is a variable
837
-- and then calls matchSinglePatVar
838
--
839
-- matchSinglePat does not warn about incomplete patterns
840
-- Used for things like [ e | pat <- stuff ], where
841
-- incomplete patterns are just fine
842

843
matchSinglePat (Var var) ctx pat ty match_result
844
  | not (isExternalName (idName var))
845
  = matchSinglePatVar var ctx pat ty match_result
846 847 848

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

852
matchSinglePatVar :: Id   -- See Note [Match Ids]
853
                  -> HsMatchContext GhcRn -> LPat GhcTc
854 855
                  -> Type -> MatchResult -> DsM MatchResult
matchSinglePatVar var ctx pat ty match_result
856 857
  = ASSERT2( isInternalName (idName var), ppr var )
    do { dflags <- getDynFlags
858
       ; locn   <- getSrcSpanDs
859

860 861
                    -- Pattern match check warnings
       ; checkSingle dflags (DsMatchContext ctx locn) var (unLoc pat)
862

863
       ; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideBangHood dflags pat)]
864
                                , eqn_orig = FromSource
865 866
                                , eqn_rhs  = match_result }
       ; match [var] ty [eqn_info] }
867

868

Austin Seipp's avatar
Austin Seipp committed
869 870 871
{-
************************************************************************
*                                                                      *
872
                Pattern classification
Austin Seipp's avatar
Austin Seipp committed
873 874 875
*                                                                      *
************************************************************************
-}
876 877

data PatGroup
878 879 880
  = PgAny               -- Immediate match: variables, wildcards,
                        --                  lazy patterns
  | PgCon DataCon       -- Constructor patterns (incl list, tuple)
881
  | PgSyn PatSyn [Type] -- See Note [Pattern synonym groups]
882
  | PgLit Literal       -- Literal patterns
883 884 885 886
  | PgN   Rational      -- Overloaded numeric literals;
                        -- see Note [Don't use Literal for PgN]
  | PgOverS FastString  -- Overloaded string literals
  | PgNpK Integer       -- n+k patterns
887 888 889
  | PgBang              -- Bang patterns
  | PgCo Type           -- Coercion patterns; the type is the type
                        --      of the pattern *inside*
890
  | PgView (LHsExpr GhcTc) -- view pattern (e -> p):
891 892
                        -- the LHsExpr is the expression e
           Type         -- the Type is the type of p (equivalently, the result type of e)
893
  | PgOverloadedList
894

895 896 897 898 899 900 901 902 903 904 905
{- 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
Sylvain Henry's avatar
Sylvain Henry committed
906 907
into a LitInt constructor. This didn't really make sense; and we now have
the invariant that value in a LitInt must be in the range of the target
908 909 910 911 912 913 914
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.
-}

Sylvain Henry's avatar
Sylvain Henry committed
915
groupEquations :: Platform -> [EquationInfo] -> [NonEmpty (PatGroup, EquationInfo)]
916
-- If the result is of form [g1, g2, g3],
917 918
-- (a) all the (pg,eq) pairs in g1 have the same pg
-- (b) none of the gi are empty
919
-- The ordering of equations is unchanged
Sylvain Henry's avatar
Sylvain Henry committed
920 921
groupEquations platform eqns
  = NEL.groupBy same_gp $ [(patGroup platform (firstPat eqn), eqn) | eqn <- eqns]
922
  -- comprehension on NonEmpty
923 924 925 926
  where
    same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool
    (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2

927 928
-- TODO Make subGroup1 using a NonEmptyMap
subGroup :: (m -> [NonEmpty EquationInfo]) -- Map.elems
929
         -> m -- Map.empty
930 931 932
         -> (a -> m -> Maybe (NonEmpty EquationInfo)) -- Map.lookup
         -> (a -> NonEmpty EquationInfo -> m -> m) -- Map.insert
         -> [(a, EquationInfo)] -> [NonEmpty EquationInfo]
933
-- Input is a particular group.  The result sub-groups the
934
-- equations by with particular constructor, literal etc they match.
935 936
-- Each sub-list in the result has the same PatGroup
-- See Note [Take care with pattern order]
937 938 939
-- Parameterized by map operations to allow different implementations
-- and constraints, eg. types without Ord instance.
subGroup elems empty lookup insert group
940
    = fmap NEL.reverse $ elems $ foldl' accumulate empty group
941
  where
942
    accumulate pg_map (pg, eqn)
943
      = case lookup pg pg_map of
944 945
          Just eqns -> insert pg (NEL.cons eqn eqns) pg_map
          Nothing   -> insert pg [eqn] pg_map
946
    -- pg_map :: Map a [EquationInfo]
947
    -- Equations seen so far in reverse order of appearance
948

949
subGroupOrd :: Ord a => [(a, EquationInfo)] -> [NonEmpty EquationInfo]
950 951
subGroupOrd = subGroup Map.elems Map.empty Map.lookup Map.insert

952
subGroupUniq :: Uniquable a => [(a, EquationInfo)] -> [NonEmpty EquationInfo]
953 954 955
subGroupUniq =
  subGroup eltsUDFM emptyUDFM (flip lookupUDFM) (\k v m -> addToUDFM m k v)

956 957 958 959 960 961 962 963
{- Note [Pattern synonym groups]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If we see
  f (P a) = e1
  f (P b) = e2
    ...
where P is a pattern synonym, can we put (P a -> e1) and (P b -> e2) in the
same group?  We can if P is a constructor, but /not/ if P is a pattern synonym.
964
Consider (#11224)
965 966 967 968 969 970 971 972 973 974 975
   -- readMaybe :: Read a => String -> Maybe a
   pattern PRead :: Read a => () => a -> String
   pattern PRead a <- (readMaybe -> Just a)

   f (PRead (x::Int))  = e1
   f (PRead (y::Bool)) = e2
This is all fine: we match the string by trying to read an Int; if that
fails we try to read a Bool. But clearly we can't combine the two into a single
match.

Conclusion: we can combine when we invoke PRead /at the same type/.  Hence
976
in PgSyn we record the instantiating types, and use them in sameGroup.
977

978 979 980 981
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) ]
982
Then in bringing together the patterns for True, we must not
983
swap the Nothing and y!
Austin Seipp's avatar
Austin Seipp committed
984
-}
985

986
sameGroup :: PatGroup -> PatGroup -> Bool
987
-- Same group means that a single case expression
988 989
-- or test will suffice to match both, *and* the order
-- of testing within the group is insignificant.
990 991 992 993 994 995 996
sameGroup PgAny         PgAny         = True
sameGroup PgBang        PgBang        = True
sameGroup (PgCon _)     (PgCon _)     = True    -- One case expression
sameGroup (PgSyn p1 t1) (PgSyn p2 t2) = p1==p2 && eqTypes t1 t2
                                                -- eqTypes: See Note [Pattern synonym groups]
sameGroup (PgLit _)     (PgLit _)     = True    -- One case expression
sameGroup (PgN l1)      (PgN l2)      = l1==l2  -- Order is significant
997
sameGroup (PgOverS s1)  (PgOverS s2)  = s1==s2
998 999
sameGroup (PgNpK l1)    (PgNpK l2)    = l1==l2  -- See Note [Grouping overloaded literal patterns]
sameGroup (PgCo t1)     (PgCo t2)     = t1 `eqType` t2
1000 1001 1002 1003 1004
        -- 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)
1005
       -- ViewPats are in the same group iff the expressions
1006
       -- are "equal"---conservatively, we use syntactic equality
chak@cse.unsw.edu.au.'s avatar