Match.lhs 40.5 KB
Newer Older
1
%
Simon Marlow's avatar
Simon Marlow committed
2
% (c) The University of Glasgow 2006
3
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
%
Simon Marlow's avatar
Simon Marlow committed
5 6

The @match@ function
7 8

\begin{code}
9
module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat ) where
10

11
#include "HsVersions.h"
12

13
import {-#SOURCE#-} DsExpr (dsLExpr, dsExpr)
14

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

46
import Control.Monad( when )
47
import qualified Data.Map as Map
48 49
\end{code}

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

JJCQ 30-Nov-1997

\begin{code}
58
matchCheck ::  DsMatchContext
59
            -> [Id]             -- Vars rep'ing the exprs we're matching with
60
            -> Type             -- Type of the case expression
61 62 63
            -> [EquationInfo]   -- Info about patterns, etc. (type synonym below)
            -> DsM MatchResult  -- Desugared result!

64
matchCheck ctx vars ty qs
65
  = do { dflags <- getDynFlags
66
       ; matchCheck_really dflags ctx vars ty qs }
67

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

    incomplete_flag :: HsMatchContext id -> Bool
85 86
    incomplete_flag (FunRhs {})   = wopt Opt_WarnIncompletePatterns dflags
    incomplete_flag CaseAlt       = wopt Opt_WarnIncompletePatterns dflags
87
    incomplete_flag IfAlt         = False
88

89 90 91
    incomplete_flag LambdaExpr    = wopt Opt_WarnIncompleteUniPatterns dflags
    incomplete_flag PatBindRhs    = wopt Opt_WarnIncompleteUniPatterns dflags
    incomplete_flag ProcExpr      = wopt Opt_WarnIncompleteUniPatterns dflags
92

93
    incomplete_flag RecUpd        = wopt Opt_WarnIncompletePatternsRecUpd dflags
94

gmainland's avatar
gmainland committed
95
    incomplete_flag ThPatSplice   = False
Gergő Érdi's avatar
Gergő Érdi committed
96
    incomplete_flag PatSyn        = False
97 98
    incomplete_flag ThPatQuote    = False
    incomplete_flag (StmtCtxt {}) = False  -- Don't warn about incomplete patterns
99 100 101
                                           -- in list comprehensions, pattern guards
                                           -- etc.  They are often *supposed* to be
                                           -- incomplete
102 103
\end{code}

104 105
This variable shows the maximum number of lines of output generated for warnings.
It will limit the number of patterns/equations displayed to@ maximum_output@.
106

sof's avatar
sof committed
107 108
(ToDo: add command-line option?)

109
\begin{code}
110
maximum_output :: Int
111 112 113
maximum_output = 4
\end{code}

114
The next two functions create the warning message.
115 116 117

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

129 130

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

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

143
pp_context :: DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
144
pp_context (DsMatchContext kind _loc) msg rest_of_msg_fun
Ian Lynagh's avatar
Ian Lynagh committed
145
  = vcat [ptext (sLit "Pattern match(es)") <+> msg,
146
          sep [ptext (sLit "In") <+> ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]]
147 148
  where
    (ppr_match, pref)
149 150
        = case kind of
             FunRhs fun _ -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)
151
             _            -> (pprMatchContext kind, \ pp -> pp)
152

153
ppr_pats :: Outputable a => [a] -> SDoc
154
ppr_pats pats = sep (map ppr pats)
155

156
ppr_shadow_pats :: HsMatchContext Name -> [Pat Id] -> SDoc
sof's avatar
sof committed
157
ppr_shadow_pats kind pats
Ian Lynagh's avatar
Ian Lynagh committed
158
  = sep [ppr_pats pats, matchSeparator kind, ptext (sLit "...")]
159 160 161 162

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

166
ppr_constraint :: (Name,[HsLit]) -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
167
ppr_constraint (var,pats) = sep [ppr var, ptext (sLit "`notElem`"), ppr pats]
168

169
ppr_eqn :: (SDoc -> SDoc) -> HsMatchContext Name -> EquationInfo -> SDoc
170
ppr_eqn prefixF kind eqn = prefixF (ppr_shadow_pats kind (eqn_pats eqn))
171 172 173
\end{code}


174
%************************************************************************
175 176 177
%*                                                                      *
                The main matching function
%*                                                                      *
178 179
%************************************************************************

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


440
%************************************************************************
441 442 443
%*                                                                      *
                Tidying patterns
%*                                                                      *
444 445
%************************************************************************

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

568
tidy1 _ (TuplePat pats boxity ty)
569
  = return (idDsWrapper, unLoc tuple_ConPat)
570 571
  where
    arity = length pats
batterseapower's avatar
batterseapower committed
572
    tuple_ConPat = mkPrefixConPat (tupleCon (boxityNormalTupleSort boxity) arity) pats ty
573

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

-- NPats: we *might* be able to replace these w/ a simpler form
579
tidy1 _ (NPat lit mb_neg eq)
580
  = return (idDsWrapper, tidyNPat tidyLitPat lit mb_neg eq)
581

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

584
tidy1 _ non_interesting_pat
585
  = return (idDsWrapper, non_interesting_pat)
586 587 588 589 590 591 592 593 594 595 596

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

-- Discard bang around strict pattern
tidy_bang_pat v _ p@(ListPat {})   = tidy1 v p
tidy_bang_pat v _ p@(TuplePat {})  = tidy1 v p
tidy_bang_pat v _ p@(PArrPat {})   = tidy1 v p
tidy_bang_pat v _ p@(ConPatOut {}) = tidy1 v p
tidy_bang_pat v _ p@(LitPat {})    = tidy1 v p

597
-- Discard par/sig under a bang
598 599 600 601
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
602
-- it may disappear next time
603 604 605 606
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)

-- Default case, leave the bang there:
607 608 609 610
-- VarPat, LazyPat, WildPat, ViewPat, NPat, NPlusKPat
-- For LazyPat, remember that it's semantically like a VarPat
--  i.e.  !(~p) is not like ~p, or p!  (Trac #8952)

611 612
tidy_bang_pat _ l p = return (idDsWrapper, BangPat (L l p))
  -- NB: SigPatIn, ConPatIn should not happen
613 614
\end{code}

615 616
\noindent
{\bf Previous @matchTwiddled@ stuff:}
617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640

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}

%************************************************************************
641
%*                                                                      *
642
\subsubsection[improved-unmixing]{UNIMPLEMENTED idea for improved unmixing}
643
%*                                                                      *
644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680
%************************************************************************

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}

%************************************************************************
681 682 683
%*                                                                      *
%*  matchWrapper: a convenient way to call @match@                      *
%*                                                                      *
684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704
%************************************************************************
\subsection[matchWrapper]{@matchWrapper@: a convenient interface to @match@}

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

As results, @matchWrapper@ produces:
\begin{itemize}
\item
A list of variables (@Locals@) that the caller must ``promise'' to
bind to appropriate values; and
\item
705
a @CoreExpr@, the desugared output (main result).
706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724
\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}

\begin{code}
725 726 727
matchWrapper :: HsMatchContext Name         -- For shadowing warning messages
             -> MatchGroup Id (LHsExpr Id)  -- Matches being desugared
             -> DsM ([Id], CoreExpr)        -- Results
728
\end{code}
729

730 731
 There is one small problem with the Lambda Patterns, when somebody
 writes something similar to:
732
\begin{verbatim}
733
    (\ (x:xs) -> ...)
734
\end{verbatim}
735
 he/she don't want a warning about incomplete patterns, that is done with
736 737 738 739 740 741 742 743 744 745 746 747
 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
748 749 750
one pattern, and match simply only accepts one pattern.

JJQC 30-Nov-1997
751

752
\begin{code}
753 754
matchWrapper ctxt (MG { mg_alts = matches
                      , mg_arg_tys = arg_tys
755 756
                      , mg_res_ty = rhs_ty
                      , mg_origin = origin })
757 758
  = do  { eqns_info   <- mapM mk_eqn_info matches
        ; new_vars    <- case matches of
759 760
                           []    -> mapM newSysLocalDs arg_tys
                           (m:_) -> selectMatchVars (map unLoc (hsLMatchPats m))
761 762
        ; result_expr <- handleWarnings $
                         matchEquations ctxt new_vars eqns_info rhs_ty
763
        ; return (new_vars, result_expr) }
764
  where
765 766
    mk_eqn_info (L _ (Match pats _ grhss))
      = do { let upats = map unLoc pats
767 768
           ; match_result <- dsGRHSs ctxt upats grhss rhs_ty
           ; return (EqnInfo { eqn_pats = upats, eqn_rhs  = match_result}) }
769

770 771 772 773
    handleWarnings = if isGenerated origin
                     then discardWarningsDs
                     else id

774 775

matchEquations  :: HsMatchContext Name
776 777
                -> [Id] -> [EquationInfo] -> Type
                -> DsM CoreExpr
778
matchEquations ctxt vars eqns_info rhs_ty
779 780 781
  = do  { locn <- getSrcSpanDs
        ; let   ds_ctxt   = DsMatchContext ctxt locn
                error_doc = matchContextErrString ctxt
782

783
        ; match_result <- matchCheck ds_ctxt vars rhs_ty eqns_info
784

785 786
        ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_doc
        ; extractMatchResult match_result fail_expr }
787 788 789
\end{code}

%************************************************************************
790
%*                                                                      *
791
\subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern}
792
%*                                                                      *
793 794 795 796 797 798 799
%************************************************************************

@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.

\begin{code}
800 801 802 803 804 805
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
806
-- Do not warn about incomplete patterns; see matchSinglePat comments
807 808
matchSimply scrut hs_ctx pat result_expr fail_expr = do
    let
809
      match_result = cantFailMatchResult result_expr
810 811 812
      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
813
    extractMatchResult match_result' fail_expr
814

815
matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat Id
816
               -> Type -> MatchResult -> DsM MatchResult
817
-- Do not warn about incomplete patterns
818
-- Used for things like [ e | pat <- stuff ], where
819
-- incomplete patterns are just fine
820
matchSinglePat (Var var) ctx (L _ pat) ty match_result
821 822
  = do { locn <- getSrcSpanDs
       ; matchCheck (DsMatchContext ctx locn)
823
                    [var] ty
824 825 826 827 828 829
                    [EqnInfo { eqn_pats = [pat], eqn_rhs  = match_result }] }

matchSinglePat scrut hs_ctx pat ty match_result
  = do { var <- selectSimpleMatchVarL pat
       ; match_result' <- matchSinglePat (Var var) hs_ctx pat ty match_result
       ; return (adjustMatchResult (bindNonRec var scrut) match_result') }
830 831
\end{code}

832 833

%************************************************************************
834 835 836
%*                                                                      *
                Pattern classification
%*                                                                      *
837 838 839 840
%************************************************************************

\begin{code}
data PatGroup
841 842 843
  = PgAny               -- Immediate match: variables, wildcards,
                        --                  lazy patterns
  | PgCon DataCon       -- Constructor patterns (incl list, tuple)
Gergő Érdi's avatar
Gergő Érdi committed
844
  | PgSyn PatSyn
845 846 847 848 849 850
  | PgLit Literal       -- Literal patterns
  | PgN   Literal       -- Overloaded literals
  | PgNpK Literal       -- n+k patterns
  | PgBang              -- Bang patterns
  | PgCo Type           -- Coercion patterns; the type is the type
                        --      of the pattern *inside*
851 852 853
  | 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)
854
  | PgOverloadedList
855

856
groupEquations :: DynFlags -> [EquationInfo] -> [[(PatGroup, EquationInfo)]]
857
-- If the result is of form [g1, g2, g3],
858 859
-- (a) all the (pg,eq) pairs in g1 have the same pg
-- (b) none of the gi are empty
860
-- The ordering of equations is unchanged
861 862
groupEquations dflags eqns
  = runs same_gp [(patGroup dflags (firstPat eqn), eqn) | eqn <- eqns]
863 864 865 866
  where
    same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool
    (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2

867
subGroup :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]]
868
-- Input is a particular group.  The result sub-groups the
869
-- equations by with particular constructor, literal etc they match.
870 871
-- Each sub-list in the result has the same PatGroup
-- See Note [Take care with pattern order]
872
subGroup group
873
    = map reverse $ Map.elems $ foldl accumulate Map.empty group
874
  where
875
    accumulate pg_map (pg, eqn)
876 877 878
      = case Map.lookup pg pg_map of
          Just eqns -> Map.insert pg (eqn:eqns) pg_map
          Nothing   -> Map.insert pg [eqn]      pg_map
879

880
    -- pg_map :: Map a [EquationInfo]
881 882
    -- Equations seen so far in reverse order of appearance
\end{code}
883

884 885 886 887
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) ]
888
Then in bringing together the patterns for True, we must not
889 890 891 892
swap the Nothing and y!


\begin{code}
893
sameGroup :: PatGroup -> PatGroup -> Bool
894
-- Same group means that a single case expression
895 896 897 898
-- or test will suffice to match both, *and* the order
-- of testing within the group is insignificant.
sameGroup PgAny      PgAny      = True
sameGroup PgBang     PgBang     = True
899
sameGroup (PgCon _)  (PgCon _)  = True          -- One case expression
Gergő Érdi's avatar
Gergő Érdi committed
900
sameGroup (PgSyn p1) (PgSyn p2) = p1==p2
901 902 903 904 905 906 907 908 909
sameGroup (PgLit _)  (PgLit _)  = True          -- One case expression
sameGroup (PgN l1)   (PgN l2)   = l1==l2        -- Order is significant
sameGroup (PgNpK l1) (PgNpK l2) = l1==l2        -- See Note [Grouping overloaded literal patterns]
sameGroup (PgCo t1)  (PgCo t2)  = t1 `eqType` t2
        -- CoPats are in the same goup only if the type of the
        -- enclosed pattern is the same. The patterns outside the CoPat
        -- always have the same type, so this boils down to saying that
        -- the two coercions are identical.
sameGroup (PgView e1 t1) (PgView e2 t2) = viewLExprEq (e1,t1) (e2,t2)
910
       -- ViewPats are in the same group iff the expressions
911
       -- are "equal"---conservatively, we use syntactic equality
912
sameGroup _          _          = False
913

914
-- An approximation of syntactic equality used for determining when view
915
-- exprs are in the same group.
916
-- This function can always safely return false;
917 918
-- but doing so will result in the application of the view function being repeated.
--
919
-- Currently: compare applications of literals and variables
920 921 922 923 924 925 926
--            and anything else that we can do without involving other
--            HsSyn types in the recursion
--
-- NB we can't assume that the two view expressions have the same type.  Consider
--   f (e1 -> True) = ...
--   f (e2 -> "hi") = ...
viewLExprEq :: (LHsExpr Id,Type) -> (LHsExpr Id,Type) -> Bool
927 928 929 930 931 932 933 934
viewLExprEq (e1,_) (e2,_) = lexp e1 e2
  where
    lexp :: LHsExpr Id -> LHsExpr Id -> Bool
    lexp e e' = exp (unLoc e) (unLoc e')

    ---------
    exp :: HsExpr Id -> HsExpr Id -> Bool
    -- real comparison is on HsExpr's
935
    -- strip parens
936 937 938 939 940
    exp (HsPar (L _ e)) e'   = exp e e'
    exp e (HsPar (L _ e'))   = exp e e'
    -- because the expres