compiler/deSugar/Match.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 The @match@ function
   7
   8 \begin{code}
   9 {-# OPTIONS -fno-warn-incomplete-patterns #-}
  10 -- The above warning supression flag is a temporary kludge.
  11 -- While working on this module you are encouraged to remove it and fix
  12 -- any warnings in the module. See
  13 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  14 -- for details
  15
  16 module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat ) where
  17
  18 #include "HsVersions.h"
  19
  20 import {-#SOURCE#-} DsExpr (dsLExpr)
  21
  22 import DynFlags
  23 import HsSyn
  24 import TcHsSyn
  25 import Check
  26 import CoreSyn
  27 import Literal
  28 import CoreUtils
  29 import MkCore
  30 import DsMonad
  31 import DsBinds
  32 import DsGRHSs
  33 import DsUtils
  34 import Id
  35 import DataCon
  36 import MatchCon
  37 import MatchLit
  38 import PrelInfo
  39 import Type
  40 import TysWiredIn
  41 import ListSetOps
  42 import SrcLoc
  43 import Maybes
  44 import Util
  45 import Name
  46 import Outputable
  47 import FastString
  48 \end{code}
  49
  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 firs call, ....
  52 if the associated flags are declared, warnings will be issued.
  53 It can not be called matchWrapper because this name already exists :-(
  54
  55 JJCQ 30-Nov-1997
  56
  57 \begin{code}
  58 matchCheck ::  DsMatchContext
  59             -> [Id]             -- Vars rep'ing the exprs we're matching with
  60             -> Type             -- Type of the case expression
  61             -> [EquationInfo]   -- Info about patterns, etc. (type synonym below)
  62             -> DsM MatchResult  -- Desugared result!
  63
  64 matchCheck ctx vars ty qs = do
  65     dflags <- getDOptsDs
  66     matchCheck_really dflags ctx vars ty qs
  67
  68 matchCheck_really :: DynFlags
  69                   -> DsMatchContext
  70                   -> [Id]
  71                   -> Type
  72                   -> [EquationInfo]
  73                   -> DsM MatchResult
  74 matchCheck_really dflags ctx vars ty qs
  75   | incomplete && shadow  = do
  76       dsShadowWarn ctx eqns_shadow
  77       dsIncompleteWarn ctx pats
  78       match vars ty qs
  79   | incomplete            = do
  80       dsIncompleteWarn ctx pats
  81       match vars ty qs
  82   | shadow                = do
  83       dsShadowWarn ctx eqns_shadow
  84       match vars ty qs
  85   | otherwise             =
  86       match vars ty qs
  87   where (pats, eqns_shadow) = check qs
  88         incomplete    = want_incomplete && (notNull pats)
  89         want_incomplete = case ctx of
  90                               DsMatchContext RecUpd _ ->
  91                                   dopt Opt_WarnIncompletePatternsRecUpd dflags
  92                               _ ->
  93                                   dopt Opt_WarnIncompletePatterns       dflags
  94         shadow        = dopt Opt_WarnOverlappingPatterns dflags
  95                         && not (null eqns_shadow)
  96 \end{code}
  97
  98 This variable shows the maximum number of lines of output generated for warnings.
  99 It will limit the number of patterns/equations displayed to@ maximum_output@.
 100
 101 (ToDo: add command-line option?)
 102
 103 \begin{code}
 104 maximum_output :: Int
 105 maximum_output = 4
 106 \end{code}
 107
 108 The next two functions create the warning message.
 109
 110 \begin{code}
 111 dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM ()
 112 dsShadowWarn ctx@(DsMatchContext kind loc) qs
 113   = putSrcSpanDs loc (warnDs warn)
 114   where
 115     warn | qs `lengthExceeds` maximum_output
 116          = pp_context ctx (ptext (sLit "are overlapped"))
 117                       (\ f -> vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$
 118                       ptext (sLit "..."))
 119          | otherwise
 120          = pp_context ctx (ptext (sLit "are overlapped"))
 121                       (\ f -> vcat $ map (ppr_eqn f kind) qs)
 122
 123
 124 dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM ()
 125 dsIncompleteWarn ctx@(DsMatchContext kind loc) pats
 126   = putSrcSpanDs loc (warnDs warn)
 127         where
 128           warn = pp_context ctx (ptext (sLit "are non-exhaustive"))
 129                             (\_ -> hang (ptext (sLit "Patterns not matched:"))
 130                                    4 ((vcat $ map (ppr_incomplete_pats kind)
 131                                                   (take maximum_output pats))
 132                                       $$ dots))
 133
 134           dots | pats `lengthExceeds` maximum_output = ptext (sLit "...")
 135                | otherwise                           = empty
 136
 137 pp_context :: DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
 138 pp_context (DsMatchContext kind _loc) msg rest_of_msg_fun
 139   = vcat [ptext (sLit "Pattern match(es)") <+> msg,
 140           sep [ptext (sLit "In") <+> ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]]
 141   where
 142     (ppr_match, pref)
 143         = case kind of
 144              FunRhs fun _ -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)
 145              _            -> (pprMatchContext kind, \ pp -> pp)
 146
 147 ppr_pats :: Outputable a => [a] -> SDoc
 148 ppr_pats pats = sep (map ppr pats)
 149
 150 ppr_shadow_pats :: HsMatchContext Name -> [Pat Id] -> SDoc
 151 ppr_shadow_pats kind pats
 152   = sep [ppr_pats pats, matchSeparator kind, ptext (sLit "...")]
 153
 154 ppr_incomplete_pats :: HsMatchContext Name -> ExhaustivePat -> SDoc
 155 ppr_incomplete_pats _ (pats,[]) = ppr_pats pats
 156 ppr_incomplete_pats _ (pats,constraints) =
 157                          sep [ppr_pats pats, ptext (sLit "with"),
 158                               sep (map ppr_constraint constraints)]
 159
 160 ppr_constraint :: (Name,[HsLit]) -> SDoc
 161 ppr_constraint (var,pats) = sep [ppr var, ptext (sLit "`notElem`"), ppr pats]
 162
 163 ppr_eqn :: (SDoc -> SDoc) -> HsMatchContext Name -> EquationInfo -> SDoc
 164 ppr_eqn prefixF kind eqn = prefixF (ppr_shadow_pats kind (eqn_pats eqn))
 165 \end{code}
 166
 167
 168 %************************************************************************
 169 %*                                                                      *
 170                 The main matching function
 171 %*                                                                      *
 172 %************************************************************************
 173
 174 The function @match@ is basically the same as in the Wadler chapter,
 175 except it is monadised, to carry around the name supply, info about
 176 annotations, etc.
 177
 178 Notes on @match@'s arguments, assuming $m$ equations and $n$ patterns:
 179 \begin{enumerate}
 180 \item
 181 A list of $n$ variable names, those variables presumably bound to the
 182 $n$ expressions being matched against the $n$ patterns.  Using the
 183 list of $n$ expressions as the first argument showed no benefit and
 184 some inelegance.
 185
 186 \item
 187 The second argument, a list giving the ``equation info'' for each of
 188 the $m$ equations:
 189 \begin{itemize}
 190 \item
 191 the $n$ patterns for that equation, and
 192 \item
 193 a list of Core bindings [@(Id, CoreExpr)@ pairs] to be ``stuck on
 194 the front'' of the matching code, as in:
 195 \begin{verbatim}
 196 let <binds>
 197 in  <matching-code>
 198 \end{verbatim}
 199 \item
 200 and finally: (ToDo: fill in)
 201
 202 The right way to think about the ``after-match function'' is that it
 203 is an embryonic @CoreExpr@ with a ``hole'' at the end for the
 204 final ``else expression''.
 205 \end{itemize}
 206
 207 There is a type synonym, @EquationInfo@, defined in module @DsUtils@.
 208
 209 An experiment with re-ordering this information about equations (in
 210 particular, having the patterns available in column-major order)
 211 showed no benefit.
 212
 213 \item
 214 A default expression---what to evaluate if the overall pattern-match
 215 fails.  This expression will (almost?) always be
 216 a measly expression @Var@, unless we know it will only be used once
 217 (as we do in @glue_success_exprs@).
 218
 219 Leaving out this third argument to @match@ (and slamming in lots of
 220 @Var "fail"@s) is a positively {\em bad} idea, because it makes it
 221 impossible to share the default expressions.  (Also, it stands no
 222 chance of working in our post-upheaval world of @Locals@.)
 223 \end{enumerate}
 224
 225 Note: @match@ is often called via @matchWrapper@ (end of this module),
 226 a function that does much of the house-keeping that goes with a call
 227 to @match@.
 228
 229 It is also worth mentioning the {\em typical} way a block of equations
 230 is desugared with @match@.  At each stage, it is the first column of
 231 patterns that is examined.  The steps carried out are roughly:
 232 \begin{enumerate}
 233 \item
 234 Tidy the patterns in column~1 with @tidyEqnInfo@ (this may add
 235 bindings to the second component of the equation-info):
 236 \begin{itemize}
 237 \item
 238 Remove the `as' patterns from column~1.
 239 \item
 240 Make all constructor patterns in column~1 into @ConPats@, notably
 241 @ListPats@ and @TuplePats@.
 242 \item
 243 Handle any irrefutable (or ``twiddle'') @LazyPats@.
 244 \end{itemize}
 245 \item
 246 Now {\em unmix} the equations into {\em blocks} [w\/ local function
 247 @unmix_eqns@], in which the equations in a block all have variable
 248 patterns in column~1, or they all have constructor patterns in ...
 249 (see ``the mixture rule'' in SLPJ).
 250 \item
 251 Call @matchEqnBlock@ on each block of equations; it will do the
 252 appropriate thing for each kind of column-1 pattern, usually ending up
 253 in a recursive call to @match@.
 254 \end{enumerate}
 255
 256 We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87)
 257 than the Wadler-chapter code for @match@ (p.~93, first @match@ clause).
 258 And gluing the ``success expressions'' together isn't quite so pretty.
 259
 260 This (more interesting) clause of @match@ uses @tidy_and_unmix_eqns@
 261 (a)~to get `as'- and `twiddle'-patterns out of the way (tidying), and
 262 (b)~to do ``the mixture rule'' (SLPJ, p.~88) [which really {\em
 263 un}mixes the equations], producing a list of equation-info
 264 blocks, each block having as its first column of patterns either all
 265 constructors, or all variables (or similar beasts), etc.
 266
 267 @match_unmixed_eqn_blks@ simply takes the place of the @foldr@ in the
 268 Wadler-chapter @match@ (p.~93, last clause), and @match_unmixed_blk@
 269 corresponds roughly to @matchVarCon@.
 270
 271 \begin{code}
 272 match :: [Id]             -- Variables rep\'ing the exprs we\'re matching with
 273       -> Type             -- Type of the case expression
 274       -> [EquationInfo]   -- Info about patterns, etc. (type synonym below)
 275       -> DsM MatchResult  -- Desugared result!
 276
 277 match [] ty eqns
 278   = ASSERT2( not (null eqns), ppr ty )
 279     return (foldr1 combineMatchResults match_results)
 280   where
 281     match_results = [ ASSERT( null (eqn_pats eqn) )
 282                       eqn_rhs eqn
 283                     | eqn <- eqns ]
 284
 285 match vars@(v:_) ty eqns
 286   = ASSERT( not (null eqns ) )
 287     do  {       -- Tidy the first pattern, generating
 288                 -- auxiliary bindings if necessary
 289           (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns
 290
 291                 -- Group the equations and match each group in turn
 292
 293        ; let grouped = (groupEquations tidy_eqns)
 294
 295          -- print the view patterns that are commoned up to help debug
 296        ; ifOptM Opt_D_dump_view_pattern_commoning (debug grouped)
 297
 298         ; match_results <- mapM match_group grouped
 299         ; return (adjustMatchResult (foldr1 (.) aux_binds) $
 300                   foldr1 combineMatchResults match_results) }
 301   where
 302     dropGroup :: [(PatGroup,EquationInfo)] -> [EquationInfo]
 303     dropGroup = map snd
 304
 305     match_group :: [(PatGroup,EquationInfo)] -> DsM MatchResult
 306     match_group eqns@((group,_) : _)
 307         = case group of
 308             PgAny      -> matchVariables  vars ty (dropGroup eqns)
 309             PgCon _    -> matchConFamily  vars ty (subGroups eqns)
 310             PgLit _    -> matchLiterals   vars ty (subGroups eqns)
 311             PgN _      -> matchNPats      vars ty (subGroups eqns)
 312             PgNpK _    -> matchNPlusKPats vars ty (dropGroup eqns)
 313             PgBang     -> matchBangs      vars ty (dropGroup eqns)
 314             PgCo _     -> matchCoercion   vars ty (dropGroup eqns)
 315             PgView _ _ -> matchView       vars ty (dropGroup eqns)
 316
 317     -- FIXME: we should also warn about view patterns that should be
 318     -- commoned up but are not
 319
 320     -- print some stuff to see what's getting grouped
 321     -- use -dppr-debug to see the resolution of overloaded lits
 322     debug eqns =
 323         let gs = map (\group -> foldr (\ (p,_) -> \acc ->
 324                                            case p of PgView e _ -> e:acc
 325                                                      _ -> acc) [] group) eqns
 326             maybeWarn [] = return ()
 327             maybeWarn l = warnDs (vcat l)
 328         in
 329           maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g))
 330                        (filter (not . null) gs))
 331
 332 matchVariables :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
 333 -- Real true variables, just like in matchVar, SLPJ p 94
 334 -- No binding to do: they'll all be wildcards by now (done in tidy)
 335 matchVariables (_:vars) ty eqns = match vars ty (shiftEqns eqns)
 336
 337 matchBangs :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
 338 matchBangs (var:vars) ty eqns
 339   = do  { match_result <- match (var:vars) ty (map decomposeFirst_Bang eqns)
 340         ; return (mkEvalMatchResult var ty match_result) }
 341
 342 matchCoercion :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
 343 -- Apply the coercion to the match variable and then match that
 344 matchCoercion (var:vars) ty (eqns@(eqn1:_))
 345   = do  { let CoPat co pat _ = firstPat eqn1
 346         ; var' <- newUniqueId (idName var) (hsPatType pat)
 347         ; match_result <- match (var':vars) ty (map decomposeFirst_Coercion eqns)
 348         ; rhs <- dsCoercion co (return (Var var))
 349         ; return (mkCoLetMatchResult (NonRec var' rhs) match_result) }
 350
 351 matchView :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
 352 -- Apply the view function to the match variable and then match that
 353 matchView (var:vars) ty (eqns@(eqn1:_))
 354   = do  { -- we could pass in the expr from the PgView,
 355          -- but this needs to extract the pat anyway
 356          -- to figure out the type of the fresh variable
 357          let ViewPat viewExpr (L _ pat) _ = firstPat eqn1
 358          -- do the rest of the compilation
 359         ; var' <- newUniqueId (idName var) (hsPatType pat)
 360         ; match_result <- match (var':vars) ty (map decomposeFirst_View eqns)
 361          -- compile the view expressions
 362        ; viewExpr' <- dsLExpr viewExpr
 363         ; return (mkViewMatchResult var' viewExpr' var match_result) }
 364
 365 -- decompose the first pattern and leave the rest alone
 366 decomposeFirstPat :: (Pat Id -> Pat Id) -> EquationInfo -> EquationInfo
 367 decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))
 368         = eqn { eqn_pats = extractpat pat : pats}
 369
 370 decomposeFirst_Coercion, decomposeFirst_Bang, decomposeFirst_View :: EquationInfo -> EquationInfo
 371
 372 decomposeFirst_Coercion = decomposeFirstPat (\ (CoPat _ pat _) -> pat)
 373 decomposeFirst_Bang     = decomposeFirstPat (\ (BangPat pat  ) -> unLoc pat)
 374 decomposeFirst_View     = decomposeFirstPat (\ (ViewPat _ pat _) -> unLoc pat)
 375
 376 \end{code}
 377
 378 %************************************************************************
 379 %*                                                                      *
 380                 Tidying patterns
 381 %*                                                                      *
 382 %************************************************************************
 383
 384 Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@
 385 which will be scrutinised.  This means:
 386 \begin{itemize}
 387 \item
 388 Replace variable patterns @x@ (@x /= v@) with the pattern @_@,
 389 together with the binding @x = v@.
 390 \item
 391 Replace the `as' pattern @x@@p@ with the pattern p and a binding @x = v@.
 392 \item
 393 Removing lazy (irrefutable) patterns (you don't want to know...).
 394 \item
 395 Converting explicit tuple-, list-, and parallel-array-pats into ordinary
 396 @ConPats@.
 397 \item
 398 Convert the literal pat "" to [].
 399 \end{itemize}
 400
 401 The result of this tidying is that the column of patterns will include
 402 {\em only}:
 403 \begin{description}
 404 \item[@WildPats@:]
 405 The @VarPat@ information isn't needed any more after this.
 406
 407 \item[@ConPats@:]
 408 @ListPats@, @TuplePats@, etc., are all converted into @ConPats@.
 409
 410 \item[@LitPats@ and @NPats@:]
 411 @LitPats@/@NPats@ of ``known friendly types'' (Int, Char,
 412 Float,  Double, at least) are converted to unboxed form; e.g.,
 413 \tr{(NPat (HsInt i) _ _)} is converted to:
 414 \begin{verbatim}
 415 (ConPat I# _ _ [LitPat (HsIntPrim i)])
 416 \end{verbatim}
 417 \end{description}
 418
 419 \begin{code}
 420 tidyEqnInfo :: Id -> EquationInfo
 421             -> DsM (DsWrapper, EquationInfo)
 422         -- DsM'd because of internal call to dsLHsBinds
 423         --      and mkSelectorBinds.
 424         -- "tidy1" does the interesting stuff, looking at
 425         -- one pattern and fiddling the list of bindings.
 426         --
 427         -- POST CONDITION: head pattern in the EqnInfo is
 428         --      WildPat
 429         --      ConPat
 430         --      NPat
 431         --      LitPat
 432         --      NPlusKPat
 433         -- but no other
 434
 435 tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats }) = do
 436     (wrap, pat') <- tidy1 v pat
 437     return (wrap, eqn { eqn_pats = do pat' : pats })
 438
 439 tidy1 :: Id                     -- The Id being scrutinised
 440       -> Pat Id                 -- The pattern against which it is to be matched
 441       -> DsM (DsWrapper,        -- Extra bindings to do before the match
 442               Pat Id)           -- Equivalent pattern
 443
 444 -------------------------------------------------------
 445 --      (pat', mr') = tidy1 v pat mr
 446 -- tidies the *outer level only* of pat, giving pat'
 447 -- It eliminates many pattern forms (as-patterns, variable patterns,
 448 -- list patterns, etc) yielding one of:
 449 --      WildPat
 450 --      ConPatOut
 451 --      LitPat
 452 --      NPat
 453 --      NPlusKPat
 454
 455 tidy1 v (ParPat pat)      = tidy1 v (unLoc pat)
 456 tidy1 v (SigPatOut pat _) = tidy1 v (unLoc pat)
 457 tidy1 _ (WildPat ty)      = return (idDsWrapper, WildPat ty)
 458
 459         -- case v of { x -> mr[] }
 460         -- = case v of { _ -> let x=v in mr[] }
 461 tidy1 v (VarPat var)
 462   = return (wrapBind var v, WildPat (idType var))
 463
 464 tidy1 v (VarPatOut var binds)
 465   = do  { prs <- dsLHsBinds binds
 466         ; return (wrapBind var v . mkCoreLet (Rec prs),
 467                   WildPat (idType var)) }
 468
 469         -- case v of { x@p -> mr[] }
 470         -- = case v of { p -> let x=v in mr[] }
 471 tidy1 v (AsPat (L _ var) pat)
 472   = do  { (wrap, pat') <- tidy1 v (unLoc pat)
 473         ; return (wrapBind var v . wrap, pat') }
 474
 475 {- now, here we handle lazy patterns:
 476     tidy1 v ~p bs = (v, v1 = case v of p -> v1 :
 477                         v2 = case v of p -> v2 : ... : bs )
 478
 479     where the v_i's are the binders in the pattern.
 480
 481     ToDo: in "v_i = ... -> v_i", are the v_i's really the same thing?
 482
 483     The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr
 484 -}
 485
 486 tidy1 v (LazyPat pat)
 487   = do  { sel_prs <- mkSelectorBinds pat (Var v)
 488         ; let sel_binds =  [NonRec b rhs | (b,rhs) <- sel_prs]
 489         ; return (mkCoreLets sel_binds, WildPat (idType v)) }
 490
 491 tidy1 _ (ListPat pats ty)
 492   = return (idDsWrapper, unLoc list_ConPat)
 493   where
 494     list_ty     = mkListTy ty
 495     list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] list_ty)
 496                         (mkNilPat list_ty)
 497                         pats
 498
 499 -- Introduce fake parallel array constructors to be able to handle parallel
 500 -- arrays with the existing machinery for constructor pattern
 501 tidy1 _ (PArrPat pats ty)
 502   = return (idDsWrapper, unLoc parrConPat)
 503   where
 504     arity      = length pats
 505     parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty)
 506
 507 tidy1 _ (TuplePat pats boxity ty)
 508   = return (idDsWrapper, unLoc tuple_ConPat)
 509   where
 510     arity = length pats
 511     tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats ty
 512
 513 -- LitPats: we *might* be able to replace these w/ a simpler form
 514 tidy1 _ (LitPat lit)
 515   = return (idDsWrapper, tidyLitPat lit)
 516
 517 -- NPats: we *might* be able to replace these w/ a simpler form
 518 tidy1 _ (NPat lit mb_neg eq)
 519   = return (idDsWrapper, tidyNPat lit mb_neg eq)
 520
 521 -- Everything else goes through unchanged...
 522
 523 tidy1 _ non_interesting_pat
 524   = return (idDsWrapper, non_interesting_pat)
 525 \end{code}
 526
 527 \noindent
 528 {\bf Previous @matchTwiddled@ stuff:}
 529
 530 Now we get to the only interesting part; note: there are choices for
 531 translation [from Simon's notes]; translation~1:
 532 \begin{verbatim}
 533 deTwiddle [s,t] e
 534 \end{verbatim}
 535 returns
 536 \begin{verbatim}
 537 [ w = e,
 538   s = case w of [s,t] -> s
 539   t = case w of [s,t] -> t
 540 ]
 541 \end{verbatim}
 542
 543 Here \tr{w} is a fresh variable, and the \tr{w}-binding prevents multiple
 544 evaluation of \tr{e}.  An alternative translation (No.~2):
 545 \begin{verbatim}
 546 [ w = case e of [s,t] -> (s,t)
 547   s = case w of (s,t) -> s
 548   t = case w of (s,t) -> t
 549 ]
 550 \end{verbatim}
 551
 552 %************************************************************************
 553 %*                                                                      *
 554 \subsubsection[improved-unmixing]{UNIMPLEMENTED idea for improved unmixing}
 555 %*                                                                      *
 556 %************************************************************************
 557
 558 We might be able to optimise unmixing when confronted by
 559 only-one-constructor-possible, of which tuples are the most notable
 560 examples.  Consider:
 561 \begin{verbatim}
 562 f (a,b,c) ... = ...
 563 f d ... (e:f) = ...
 564 f (g,h,i) ... = ...
 565 f j ...       = ...
 566 \end{verbatim}
 567 This definition would normally be unmixed into four equation blocks,
 568 one per equation.  But it could be unmixed into just one equation
 569 block, because if the one equation matches (on the first column),
 570 the others certainly will.
 571
 572 You have to be careful, though; the example
 573 \begin{verbatim}
 574 f j ...       = ...
 575 -------------------
 576 f (a,b,c) ... = ...
 577 f d ... (e:f) = ...
 578 f (g,h,i) ... = ...
 579 \end{verbatim}
 580 {\em must} be broken into two blocks at the line shown; otherwise, you
 581 are forcing unnecessary evaluation.  In any case, the top-left pattern
 582 always gives the cue.  You could then unmix blocks into groups of...
 583 \begin{description}
 584 \item[all variables:]
 585 As it is now.
 586 \item[constructors or variables (mixed):]
 587 Need to make sure the right names get bound for the variable patterns.
 588 \item[literals or variables (mixed):]
 589 Presumably just a variant on the constructor case (as it is now).
 590 \end{description}
 591
 592 %************************************************************************
 593 %*                                                                      *
 594 %*  matchWrapper: a convenient way to call @match@                      *
 595 %*                                                                      *
 596 %************************************************************************
 597 \subsection[matchWrapper]{@matchWrapper@: a convenient interface to @match@}
 598
 599 Calls to @match@ often involve similar (non-trivial) work; that work
 600 is collected here, in @matchWrapper@.  This function takes as
 601 arguments:
 602 \begin{itemize}
 603 \item
 604 Typchecked @Matches@ (of a function definition, or a case or lambda
 605 expression)---the main input;
 606 \item
 607 An error message to be inserted into any (runtime) pattern-matching
 608 failure messages.
 609 \end{itemize}
 610
 611 As results, @matchWrapper@ produces:
 612 \begin{itemize}
 613 \item
 614 A list of variables (@Locals@) that the caller must ``promise'' to
 615 bind to appropriate values; and
 616 \item
 617 a @CoreExpr@, the desugared output (main result).
 618 \end{itemize}
 619
 620 The main actions of @matchWrapper@ include:
 621 \begin{enumerate}
 622 \item
 623 Flatten the @[TypecheckedMatch]@ into a suitable list of
 624 @EquationInfo@s.
 625 \item
 626 Create as many new variables as there are patterns in a pattern-list
 627 (in any one of the @EquationInfo@s).
 628 \item
 629 Create a suitable ``if it fails'' expression---a call to @error@ using
 630 the error-string input; the {\em type} of this fail value can be found
 631 by examining one of the RHS expressions in one of the @EquationInfo@s.
 632 \item
 633 Call @match@ with all of this information!
 634 \end{enumerate}
 635
 636 \begin{code}
 637 matchWrapper :: HsMatchContext Name     -- For shadowing warning messages
 638              -> MatchGroup Id           -- Matches being desugared
 639              -> DsM ([Id], CoreExpr)    -- Results
 640 \end{code}
 641
 642  There is one small problem with the Lambda Patterns, when somebody
 643  writes something similar to:
 644 \begin{verbatim}
 645     (\ (x:xs) -> ...)
 646 \end{verbatim}
 647  he/she don't want a warning about incomplete patterns, that is done with
 648  the flag @opt_WarnSimplePatterns@.
 649  This problem also appears in the:
 650 \begin{itemize}
 651 \item @do@ patterns, but if the @do@ can fail
 652       it creates another equation if the match can fail
 653       (see @DsExpr.doDo@ function)
 654 \item @let@ patterns, are treated by @matchSimply@
 655    List Comprension Patterns, are treated by @matchSimply@ also
 656 \end{itemize}
 657
 658 We can't call @matchSimply@ with Lambda patterns,
 659 due to the fact that lambda patterns can have more than
 660 one pattern, and match simply only accepts one pattern.
 661
 662 JJQC 30-Nov-1997
 663
 664 \begin{code}
 665 matchWrapper ctxt (MatchGroup matches match_ty)
 666   = ASSERT( notNull matches )
 667     do  { eqns_info   <- mapM mk_eqn_info matches
 668         ; new_vars    <- selectMatchVars arg_pats
 669         ; result_expr <- matchEquations ctxt new_vars eqns_info rhs_ty
 670         ; return (new_vars, result_expr) }
 671   where
 672     arg_pats    = map unLoc (hsLMatchPats (head matches))
 673     n_pats      = length arg_pats
 674     (_, rhs_ty) = splitFunTysN n_pats match_ty
 675
 676     mk_eqn_info (L _ (Match pats _ grhss))
 677       = do { let upats = map unLoc pats
 678            ; match_result <- dsGRHSs ctxt upats grhss rhs_ty
 679            ; return (EqnInfo { eqn_pats = upats, eqn_rhs  = match_result}) }
 680
 681
 682 matchEquations  :: HsMatchContext Name
 683                 -> [Id] -> [EquationInfo] -> Type
 684                 -> DsM CoreExpr
 685 matchEquations ctxt vars eqns_info rhs_ty
 686   = do  { dflags <- getDOptsDs
 687         ; locn   <- getSrcSpanDs
 688         ; let   ds_ctxt      = DsMatchContext ctxt locn
 689                 error_string = matchContextErrString ctxt
 690
 691         ; match_result <- match_fun dflags ds_ctxt vars rhs_ty eqns_info
 692
 693         ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_string
 694         ; extractMatchResult match_result fail_expr }
 695   where
 696     match_fun dflags ds_ctxt
 697        = case ctxt of
 698            LambdaExpr | dopt Opt_WarnSimplePatterns dflags -> matchCheck ds_ctxt
 699                       | otherwise                          -> match
 700            _                                               -> matchCheck ds_ctxt
 701 \end{code}
 702
 703 %************************************************************************
 704 %*                                                                      *
 705 \subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern}
 706 %*                                                                      *
 707 %************************************************************************
 708
 709 @mkSimpleMatch@ is a wrapper for @match@ which deals with the
 710 situation where we want to match a single expression against a single
 711 pattern. It returns an expression.
 712
 713 \begin{code}
 714 matchSimply :: CoreExpr                 -- Scrutinee
 715             -> HsMatchContext Name      -- Match kind
 716             -> LPat Id                  -- Pattern it should match
 717             -> CoreExpr                 -- Return this if it matches
 718             -> CoreExpr                 -- Return this if it doesn't
 719             -> DsM CoreExpr
 720
 721 matchSimply scrut hs_ctx pat result_expr fail_expr = do
 722     let
 723       match_result = cantFailMatchResult result_expr
 724       rhs_ty       = exprType fail_expr
 725         -- Use exprType of fail_expr, because won't refine in the case of failure!
 726     match_result' <- matchSinglePat scrut hs_ctx pat rhs_ty match_result
 727     extractMatchResult match_result' fail_expr
 728
 729
 730 matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat Id
 731                -> Type -> MatchResult -> DsM MatchResult
 732 matchSinglePat (Var var) hs_ctx (L _ pat) ty match_result = do
 733     dflags <- getDOptsDs
 734     locn <- getSrcSpanDs
 735     let
 736         match_fn dflags
 737            | dopt Opt_WarnSimplePatterns dflags = matchCheck ds_ctx
 738            | otherwise                          = match
 739            where
 740              ds_ctx = DsMatchContext hs_ctx locn
 741     match_fn dflags [var] ty [EqnInfo { eqn_pats = [pat], eqn_rhs  = match_result }]
 742
 743 matchSinglePat scrut hs_ctx pat ty match_result = do
 744     var <- selectSimpleMatchVarL pat
 745     match_result' <- matchSinglePat (Var var) hs_ctx pat ty match_result
 746     return (adjustMatchResult (bindNonRec var scrut) match_result')
 747 \end{code}
 748
 749
 750 %************************************************************************
 751 %*                                                                      *
 752                 Pattern classification
 753 %*                                                                      *
 754 %************************************************************************
 755
 756 \begin{code}
 757 data PatGroup
 758   = PgAny               -- Immediate match: variables, wildcards,
 759                         --                  lazy patterns
 760   | PgCon DataCon       -- Constructor patterns (incl list, tuple)
 761   | PgLit Literal       -- Literal patterns
 762   | PgN   Literal       -- Overloaded literals
 763   | PgNpK Literal       -- n+k patterns
 764   | PgBang              -- Bang patterns
 765   | PgCo Type           -- Coercion patterns; the type is the type
 766                         --      of the pattern *inside*
 767   | PgView (LHsExpr Id) -- view pattern (e -> p):
 768                         -- the LHsExpr is the expression e
 769            Type         -- the Type is the type of p (equivalently, the result type of e)
 770
 771 groupEquations :: [EquationInfo] -> [[(PatGroup, EquationInfo)]]
 772 -- If the result is of form [g1, g2, g3],
 773 -- (a) all the (pg,eq) pairs in g1 have the same pg
 774 -- (b) none of the gi are empty
 775 groupEquations eqns
 776   = runs same_gp [(patGroup (firstPat eqn), eqn) | eqn <- eqns]
 777   where
 778     same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool
 779     (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2
 780
 781 subGroups :: [(PatGroup, EquationInfo)] -> [[EquationInfo]]
 782 -- Input is a particular group.  The result sub-groups the
 783 -- equations by with particular constructor, literal etc they match.
 784 -- The order may be swizzled, so the matching should be order-independent
 785 subGroups groups = map (map snd) (equivClasses cmp groups)
 786   where
 787     (pg1, _) `cmp` (pg2, _) = pg1 `cmp_pg` pg2
 788     (PgCon c1) `cmp_pg` (PgCon c2) = c1 `compare` c2
 789     (PgLit l1) `cmp_pg` (PgLit l2) = l1 `compare` l2
 790     (PgN   l1) `cmp_pg` (PgN   l2) = l1 `compare` l2
 791         -- These are the only cases that are every sub-grouped
 792
 793 sameGroup :: PatGroup -> PatGroup -> Bool
 794 -- Same group means that a single case expression
 795 -- or test will suffice to match both, *and* the order
 796 -- of testing within the group is insignificant.
 797 sameGroup PgAny      PgAny      = True
 798 sameGroup PgBang     PgBang     = True
 799 sameGroup (PgCon _)  (PgCon _)  = True          -- One case expression
 800 sameGroup (PgLit _)  (PgLit _)  = True          -- One case expression
 801 sameGroup (PgN _)    (PgN _)    = True          -- Needs conditionals
 802 sameGroup (PgNpK l1) (PgNpK l2) = l1==l2        -- Order is significant
 803                                                 -- See Note [Order of n+k]
 804 sameGroup (PgCo t1)  (PgCo t2)  = t1 `coreEqType` t2
 805         -- CoPats are in the same goup only if the type of the
 806         -- enclosed pattern is the same. The patterns outside the CoPat
 807         -- always have the same type, so this boils down to saying that
 808         -- the two coercions are identical.
 809 sameGroup (PgView e1 t1) (PgView e2 t2) = viewLExprEq (e1,t1) (e2,t2)
 810        -- ViewPats are in the same gorup iff the expressions
 811        -- are "equal"---conservatively, we use syntactic equality
 812 sameGroup _          _          = False
 813
 814 -- an approximation of syntactic equality used for determining when view
 815 -- exprs are in the same group.
 816 -- this function can always safely return false;
 817 -- but doing so will result in the application of the view function being repeated.
 818 --
 819 -- currently: compare applications of literals and variables
 820 --            and anything else that we can do without involving other
 821 --            HsSyn types in the recursion
 822 --
 823 -- NB we can't assume that the two view expressions have the same type.  Consider
 824 --   f (e1 -> True) = ...
 825 --   f (e2 -> "hi") = ...
 826 viewLExprEq :: (LHsExpr Id,Type) -> (LHsExpr Id,Type) -> Bool
 827 viewLExprEq (e1,_) (e2,_) =
 828     let
 829         -- short name for recursive call on unLoc
 830         lexp e e' = exp (unLoc e) (unLoc e')
 831
 832         -- check that two lists have the same length
 833         -- and that they match up pairwise
 834         lexps [] [] = True
 835         lexps [] (_:_) = False
 836         lexps (_:_) [] = False
 837         lexps (x:xs) (y:ys) = lexp x y && lexps xs ys
 838
 839         -- conservative, in that it demands that wrappers be
 840         -- syntactically identical and doesn't look under binders
 841         --
 842         -- coarser notions of equality are possible
 843         -- (e.g., reassociating compositions,
 844         --        equating different ways of writing a coercion)
 845         wrap WpHole WpHole = True
 846         wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2'
 847         wrap (WpCast c)  (WpCast c')  = tcEqType c c'
 848         wrap (WpApp d)   (WpApp d')   = d == d'
 849         wrap (WpTyApp t) (WpTyApp t') = tcEqType t t'
 850         -- Enhancement: could implement equality for more wrappers
 851         --   if it seems useful (lams and lets)
 852         wrap _ _ = False
 853
 854         -- real comparison is on HsExpr's
 855         -- strip parens
 856         exp (HsPar (L _ e)) e'   = exp e e'
 857         exp e (HsPar (L _ e'))   = exp e e'
 858         -- because the expressions do not necessarily have the same type,
 859         -- we have to compare the wrappers
 860         exp (HsWrap h e) (HsWrap h' e') = wrap h h' && exp e e'
 861         exp (HsVar i) (HsVar i') =  i == i'
 862         -- the instance for IPName derives using the id, so this works if the
 863         -- above does
 864         exp (HsIPVar i) (HsIPVar i') = i == i'
 865         exp (HsOverLit l) (HsOverLit l') =
 866             -- overloaded lits are equal if they have the same type
 867             -- and the data is the same.
 868             -- this is coarser than comparing the SyntaxExpr's in l and l',
 869             -- which resolve the overloading (e.g., fromInteger 1),
 870             -- because these expressions get written as a bunch of different variables
 871             -- (presumably to improve sharing)
 872             tcEqType (overLitType l) (overLitType l') && l == l'
 873         -- comparing the constants seems right
 874         exp (HsLit l) (HsLit l') = l == l'
 875         exp (HsApp e1 e2) (HsApp e1' e2') = lexp e1 e1' && lexp e2 e2'
 876         -- the fixities have been straightened out by now, so it's safe
 877         -- to ignore them?
 878         exp (OpApp l o _ ri) (OpApp l' o' _ ri') =
 879             lexp l l' && lexp o o' && lexp ri ri'
 880         exp (NegApp e n) (NegApp e' n') = lexp e e' && exp n n'
 881         exp (SectionL e1 e2) (SectionL e1' e2') =
 882             lexp e1 e1' && lexp e2 e2'
 883         exp (SectionR e1 e2) (SectionR e1' e2') =
 884             lexp e1 e1' && lexp e2 e2'
 885         exp (HsIf e e1 e2) (HsIf e' e1' e2') =
 886             lexp e e' && lexp e1 e1' && lexp e2 e2'
 887         exp (ExplicitList _ ls) (ExplicitList _ ls') = lexps ls ls'
 888         exp (ExplicitPArr _ ls) (ExplicitPArr _ ls') = lexps ls ls'
 889         exp (ExplicitTuple ls _) (ExplicitTuple ls' _) = lexps ls ls'
 890         -- Enhancement: could implement equality for more expressions
 891         --   if it seems useful
 892         exp _ _  = False
 893     in
 894       lexp e1 e2
 895
 896 patGroup :: Pat Id -> PatGroup
 897 patGroup (WildPat {})                 = PgAny
 898 patGroup (BangPat {})                 = PgBang
 899 patGroup (ConPatOut { pat_con = dc }) = PgCon (unLoc dc)
 900 patGroup (LitPat lit)                 = PgLit (hsLitKey lit)
 901 patGroup (NPat olit mb_neg _)         = PgN   (hsOverLitKey olit (isJust mb_neg))
 902 patGroup (NPlusKPat _ olit _ _)       = PgNpK (hsOverLitKey olit False)
 903 patGroup (CoPat _ p _)                = PgCo  (hsPatType p)     -- Type of innelexp pattern
 904 patGroup (ViewPat expr p _)               = PgView expr (hsPatType (unLoc p))
 905 patGroup pat = pprPanic "patGroup" (ppr pat)
 906 \end{code}
 907
 908 Note [Order of n+k]
 909 ~~~~~~~~~~~~~~~~~~~
 910 WATCH OUT!  Consider
 911
 912         f (n+1) = ...
 913         f (n+2) = ...
 914         f (n+1) = ...
 915
 916 We can't group the first and third together, because the second may match
 917 the same thing as the first.  Contrast
 918         f 1 = ...
 919         f 2 = ...
 920         f 1 = ...
 921 where we can group the first and third.  Hence we don't regard (n+1) and
 922 (n+2) as part of the same group.