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