ghc/compiler/deSugar/Match.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[Main_match]{The @match@ function}
   5
   6 \begin{code}
   7 module Match ( match, matchExport, matchWrapper, matchSimply, matchSinglePat ) where
   8
   9 #include "HsVersions.h"
  10
  11 import {-# SOURCE #-} DsExpr( dsExpr )
  12 import CmdLineOpts      ( DynFlag(..), dopt )
  13 import HsSyn
  14 import TcHsSyn          ( TypecheckedPat, TypecheckedMatch, TypecheckedMatchContext, outPatType )
  15 import Check            ( check, ExhaustivePat )
  16 import CoreSyn
  17 import CoreUtils        ( bindNonRec )
  18 import DsMonad
  19 import DsGRHSs          ( dsGRHSs )
  20 import DsUtils
  21 import Id               ( idType, recordSelectorFieldLabel, Id )
  22 import DataCon          ( dataConFieldLabels, dataConInstOrigArgTys )
  23 import MatchCon         ( matchConFamily )
  24 import MatchLit         ( matchLiterals )
  25 import PrelInfo         ( pAT_ERROR_ID )
  26 import TcType           ( mkTyVarTys, Type, tcTyConAppArgs, tcEqType )
  27 import TysWiredIn       ( nilDataCon, consDataCon, mkTupleTy, mkListTy,
  28                           tupleCon, parrFakeCon, mkPArrTy )
  29 import BasicTypes       ( Boxity(..) )
  30 import UniqSet
  31 import ErrUtils         ( addWarnLocHdrLine, dontAddErrLoc )
  32 import Util             ( lengthExceeds, isSingleton, notNull )
  33 import Outputable
  34 \end{code}
  35
  36 This function is a wrapper of @match@, it must be called from all the parts where
  37 it was called match, but only substitutes the firs call, ....
  38 if the associated flags are declared, warnings will be issued.
  39 It can not be called matchWrapper because this name already exists :-(
  40
  41 JJCQ 30-Nov-1997
  42
  43 \begin{code}
  44 matchExport :: [Id]             -- Vars rep'ing the exprs we're matching with
  45             -> [EquationInfo]   -- Info about patterns, etc. (type synonym below)
  46             -> DsM MatchResult  -- Desugared result!
  47
  48
  49 matchExport vars qs
  50    = getDOptsDs                                 `thenDs` \ dflags ->
  51      matchExport_really dflags vars qs
  52
  53 matchExport_really dflags vars qs@((EqnInfo _ ctx _ (MatchResult _ _)) : _)
  54   | incomplete && shadow =
  55       dsShadowWarn ctx eqns_shadow              `thenDs`   \ () ->
  56       dsIncompleteWarn ctx pats                 `thenDs`   \ () ->
  57       match vars qs
  58   | incomplete            =
  59       dsIncompleteWarn ctx pats                 `thenDs`   \ () ->
  60       match vars qs
  61   | shadow                =
  62       dsShadowWarn ctx eqns_shadow              `thenDs`   \ () ->
  63       match vars qs
  64   | otherwise             =
  65       match vars qs
  66   where (pats,indexs) = check qs
  67         incomplete    = dopt Opt_WarnIncompletePatterns dflags
  68                         && (notNull pats)
  69         shadow        = dopt Opt_WarnOverlappingPatterns dflags
  70                         && sizeUniqSet indexs < no_eqns
  71         no_eqns       = length qs
  72         unused_eqns   = uniqSetToList (mkUniqSet [1..no_eqns] `minusUniqSet` indexs)
  73         eqns_shadow   = map (\n -> qs!!(n - 1)) unused_eqns
  74 \end{code}
  75
  76 This variable shows the maximum number of lines of output generated for warnings.
  77 It will limit the number of patterns/equations displayed to@ maximum_output@.
  78
  79 (ToDo: add command-line option?)
  80
  81 \begin{code}
  82 maximum_output = 4
  83 \end{code}
  84
  85 The next two functions create the warning message.
  86
  87 \begin{code}
  88 dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM ()
  89 dsShadowWarn ctx@(DsMatchContext kind _ _) qs = dsWarn warn
  90         where
  91           warn | qs `lengthExceeds` maximum_output
  92                = pp_context ctx (ptext SLIT("are overlapped"))
  93                             (\ f -> vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$
  94                             ptext SLIT("..."))
  95                | otherwise
  96                = pp_context ctx (ptext SLIT("are overlapped"))
  97                             (\ f -> vcat $ map (ppr_eqn f kind) qs)
  98
  99
 100 dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM ()
 101 dsIncompleteWarn ctx@(DsMatchContext kind _ _) pats = dsWarn warn
 102         where
 103           warn = pp_context ctx (ptext SLIT("are non-exhaustive"))
 104                             (\f -> hang (ptext SLIT("Patterns not matched:"))
 105                                    4 ((vcat $ map (ppr_incomplete_pats kind)
 106                                                   (take maximum_output pats))
 107                                       $$ dots))
 108
 109           dots | pats `lengthExceeds` maximum_output = ptext SLIT("...")
 110                | otherwise                           = empty
 111
 112 pp_context NoMatchContext msg rest_of_msg_fun
 113   = dontAddErrLoc (ptext SLIT("Some match(es)") <+> hang msg 8 (rest_of_msg_fun id))
 114
 115 pp_context (DsMatchContext kind pats loc) msg rest_of_msg_fun
 116   = addWarnLocHdrLine loc
 117         (ptext SLIT("Pattern match(es)") <+> msg)
 118         (sep [ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)])
 119   where
 120     (ppr_match, pref)
 121         = case kind of
 122              FunRhs fun -> (pprMatchContext kind,                   \ pp -> ppr fun <+> pp)
 123              other      -> (pprMatchContext kind <+> ppr_pats pats, \ pp -> pp)
 124
 125 ppr_pats pats = sep (map ppr pats)
 126
 127 ppr_shadow_pats kind pats
 128   = sep [ppr_pats pats, matchSeparator kind, ptext SLIT("...")]
 129
 130 ppr_incomplete_pats kind (pats,[]) = ppr_pats pats
 131 ppr_incomplete_pats kind (pats,constraints) =
 132                          sep [ppr_pats pats, ptext SLIT("with"),
 133                               sep (map ppr_constraint constraints)]
 134
 135
 136 ppr_constraint (var,pats) = sep [ppr var, ptext SLIT("`notElem`"), ppr pats]
 137
 138 ppr_eqn prefixF kind (EqnInfo _ _ pats _) = prefixF (ppr_shadow_pats kind pats)
 139 \end{code}
 140
 141
 142 The function @match@ is basically the same as in the Wadler chapter,
 143 except it is monadised, to carry around the name supply, info about
 144 annotations, etc.
 145
 146 Notes on @match@'s arguments, assuming $m$ equations and $n$ patterns:
 147 \begin{enumerate}
 148 \item
 149 A list of $n$ variable names, those variables presumably bound to the
 150 $n$ expressions being matched against the $n$ patterns.  Using the
 151 list of $n$ expressions as the first argument showed no benefit and
 152 some inelegance.
 153
 154 \item
 155 The second argument, a list giving the ``equation info'' for each of
 156 the $m$ equations:
 157 \begin{itemize}
 158 \item
 159 the $n$ patterns for that equation, and
 160 \item
 161 a list of Core bindings [@(Id, CoreExpr)@ pairs] to be ``stuck on
 162 the front'' of the matching code, as in:
 163 \begin{verbatim}
 164 let <binds>
 165 in  <matching-code>
 166 \end{verbatim}
 167 \item
 168 and finally: (ToDo: fill in)
 169
 170 The right way to think about the ``after-match function'' is that it
 171 is an embryonic @CoreExpr@ with a ``hole'' at the end for the
 172 final ``else expression''.
 173 \end{itemize}
 174
 175 There is a type synonym, @EquationInfo@, defined in module @DsUtils@.
 176
 177 An experiment with re-ordering this information about equations (in
 178 particular, having the patterns available in column-major order)
 179 showed no benefit.
 180
 181 \item
 182 A default expression---what to evaluate if the overall pattern-match
 183 fails.  This expression will (almost?) always be
 184 a measly expression @Var@, unless we know it will only be used once
 185 (as we do in @glue_success_exprs@).
 186
 187 Leaving out this third argument to @match@ (and slamming in lots of
 188 @Var "fail"@s) is a positively {\em bad} idea, because it makes it
 189 impossible to share the default expressions.  (Also, it stands no
 190 chance of working in our post-upheaval world of @Locals@.)
 191 \end{enumerate}
 192 So, the full type signature:
 193 \begin{code}
 194 match :: [Id]             -- Variables rep'ing the exprs we're matching with
 195       -> [EquationInfo]   -- Info about patterns, etc. (type synonym below)
 196       -> DsM MatchResult  -- Desugared result!
 197 \end{code}
 198
 199 Note: @match@ is often called via @matchWrapper@ (end of this module),
 200 a function that does much of the house-keeping that goes with a call
 201 to @match@.
 202
 203 It is also worth mentioning the {\em typical} way a block of equations
 204 is desugared with @match@.  At each stage, it is the first column of
 205 patterns that is examined.  The steps carried out are roughly:
 206 \begin{enumerate}
 207 \item
 208 Tidy the patterns in column~1 with @tidyEqnInfo@ (this may add
 209 bindings to the second component of the equation-info):
 210 \begin{itemize}
 211 \item
 212 Remove the `as' patterns from column~1.
 213 \item
 214 Make all constructor patterns in column~1 into @ConPats@, notably
 215 @ListPats@ and @TuplePats@.
 216 \item
 217 Handle any irrefutable (or ``twiddle'') @LazyPats@.
 218 \end{itemize}
 219 \item
 220 Now {\em unmix} the equations into {\em blocks} [w/ local function
 221 @unmix_eqns@], in which the equations in a block all have variable
 222 patterns in column~1, or they all have constructor patterns in ...
 223 (see ``the mixture rule'' in SLPJ).
 224 \item
 225 Call @matchEqnBlock@ on each block of equations; it will do the
 226 appropriate thing for each kind of column-1 pattern, usually ending up
 227 in a recursive call to @match@.
 228 \end{enumerate}
 229
 230 %************************************************************************
 231 %*                                                                      *
 232 %*  match: empty rule                                                   *
 233 %*                                                                      *
 234 %************************************************************************
 235 \subsection[Match-empty-rule]{The ``empty rule''}
 236
 237 We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87)
 238 than the Wadler-chapter code for @match@ (p.~93, first @match@ clause).
 239 And gluing the ``success expressions'' together isn't quite so pretty.
 240
 241 \begin{code}
 242 match [] eqns_info
 243   = returnDs (foldr1 combineMatchResults match_results)
 244   where
 245     match_results = [ ASSERT( null pats) mr
 246                     | EqnInfo _ _ pats mr <- eqns_info ]
 247 \end{code}
 248
 249
 250 %************************************************************************
 251 %*                                                                      *
 252 %*  match: non-empty rule                                               *
 253 %*                                                                      *
 254 %************************************************************************
 255 \subsection[Match-nonempty]{@match@ when non-empty: unmixing}
 256
 257 This (more interesting) clause of @match@ uses @tidy_and_unmix_eqns@
 258 (a)~to get `as'- and `twiddle'-patterns out of the way (tidying), and
 259 (b)~to do ``the mixture rule'' (SLPJ, p.~88) [which really {\em
 260 un}mixes the equations], producing a list of equation-info
 261 blocks, each block having as its first column of patterns either all
 262 constructors, or all variables (or similar beasts), etc.
 263
 264 @match_unmixed_eqn_blks@ simply takes the place of the @foldr@ in the
 265 Wadler-chapter @match@ (p.~93, last clause), and @match_unmixed_blk@
 266 corresponds roughly to @matchVarCon@.
 267
 268 \begin{code}
 269 match vars@(v:vs) eqns_info
 270   = mapDs (tidyEqnInfo v) eqns_info     `thenDs` \ tidy_eqns_info ->
 271     let
 272         tidy_eqns_blks = unmix_eqns tidy_eqns_info
 273     in
 274     mapDs (matchEqnBlock vars) tidy_eqns_blks   `thenDs` \ match_results ->
 275     returnDs (foldr1 combineMatchResults match_results)
 276   where
 277     unmix_eqns []    = []
 278     unmix_eqns [eqn] = [ [eqn] ]
 279     unmix_eqns (eq1@(EqnInfo _ _ (p1:p1s) _) : eq2@(EqnInfo _ _ (p2:p2s) _) : eqs)
 280       = if (  (isWildPat p1 && isWildPat p2)
 281            || (isConPat  p1 && isConPat  p2)
 282            || (isLitPat  p1 && isLitPat  p2) ) then
 283             eq1 `tack_onto` unmixed_rest
 284         else
 285             [ eq1 ] : unmixed_rest
 286       where
 287         unmixed_rest = unmix_eqns (eq2:eqs)
 288
 289         x `tack_onto` xss   = ( x : head xss) : tail xss
 290 \end{code}
 291
 292 Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@
 293 which will be scrutinised.  This means:
 294 \begin{itemize}
 295 \item
 296 Replace variable patterns @x@ (@x /= v@) with the pattern @_@,
 297 together with the binding @x = v@.
 298 \item
 299 Replace the `as' pattern @x@@p@ with the pattern p and a binding @x = v@.
 300 \item
 301 Removing lazy (irrefutable) patterns (you don't want to know...).
 302 \item
 303 Converting explicit tuple-, list-, and parallel-array-pats into ordinary
 304 @ConPats@.
 305 \item
 306 Convert the literal pat "" to [].
 307 \end{itemize}
 308
 309 The result of this tidying is that the column of patterns will include
 310 {\em only}:
 311 \begin{description}
 312 \item[@WildPats@:]
 313 The @VarPat@ information isn't needed any more after this.
 314
 315 \item[@ConPats@:]
 316 @ListPats@, @TuplePats@, etc., are all converted into @ConPats@.
 317
 318 \item[@LitPats@ and @NPats@:]
 319 @LitPats@/@NPats@ of ``known friendly types'' (Int, Char,
 320 Float,  Double, at least) are converted to unboxed form; e.g.,
 321 \tr{(NPat (HsInt i) _ _)} is converted to:
 322 \begin{verbatim}
 323 (ConPat I# _ _ [LitPat (HsIntPrim i) _])
 324 \end{verbatim}
 325 \end{description}
 326
 327 \begin{code}
 328 tidyEqnInfo :: Id -> EquationInfo -> DsM EquationInfo
 329         -- DsM'd because of internal call to "match".
 330         -- "tidy1" does the interesting stuff, looking at
 331         -- one pattern and fiddling the list of bindings.
 332         --
 333         -- POST CONDITION: head pattern in the EqnInfo is
 334         --      WildPat
 335         --      ConPat
 336         --      NPat
 337         --      LitPat
 338         --      NPlusKPat
 339         --      SigPat
 340         -- but no other
 341
 342 tidyEqnInfo v (EqnInfo n ctx (pat : pats) match_result)
 343   = tidy1 v pat match_result    `thenDs` \ (pat', match_result') ->
 344     returnDs (EqnInfo n ctx (pat' : pats) match_result')
 345
 346 -------------------------------------------------------
 347 --      (pat', mr') = tidy1 v pat mr
 348 -- tidies the *outer level only* of pat, giving pat'
 349 -- It eliminates many pattern forms (as-patterns, variable patterns,
 350 -- list patterns, etc) yielding one of:
 351 --      WildPat
 352 --      ConPat
 353 --      LitPat
 354 --      NPat
 355 --      NPlusKPat
 356 --
 357
 358
 359 tidy1 :: Id                     -- The Id being scrutinised
 360       -> TypecheckedPat         -- The pattern against which it is to be matched
 361       -> MatchResult            -- Current thing do do after matching
 362       -> DsM (TypecheckedPat,   -- Equivalent pattern
 363               MatchResult)      -- Augmented thing to do afterwards
 364                                 -- The augmentation usually takes the form
 365                                 -- of new bindings to be added to the front
 366
 367         -- case v of { x -> mr[] }
 368         -- = case v of { _ -> let x=v in mr[] }
 369 tidy1 v (VarPat var) match_result
 370   = returnDs (WildPat (idType var), match_result')
 371   where
 372     match_result' | v == var  = match_result
 373                   | otherwise = adjustMatchResult (bindNonRec var (Var v)) match_result
 374
 375         -- case v of { x@p -> mr[] }
 376         -- = case v of { p -> let x=v in mr[] }
 377 tidy1 v (AsPat var pat) match_result
 378   = tidy1 v pat match_result'
 379   where
 380     match_result' | v == var  = match_result
 381                   | otherwise = adjustMatchResult (bindNonRec var (Var v)) match_result
 382
 383 tidy1 v (WildPat ty) match_result
 384   = returnDs (WildPat ty, match_result)
 385
 386 {- now, here we handle lazy patterns:
 387     tidy1 v ~p bs = (v, v1 = case v of p -> v1 :
 388                         v2 = case v of p -> v2 : ... : bs )
 389
 390     where the v_i's are the binders in the pattern.
 391
 392     ToDo: in "v_i = ... -> v_i", are the v_i's really the same thing?
 393
 394     The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr
 395 -}
 396
 397 tidy1 v (LazyPat pat) match_result
 398   = mkSelectorBinds pat (Var v)         `thenDs` \ sel_binds ->
 399     returnDs (WildPat (idType v),
 400               mkCoLetsMatchResult [NonRec b rhs | (b,rhs) <- sel_binds] match_result)
 401
 402 -- re-express <con-something> as (ConPat ...) [directly]
 403
 404 tidy1 v (RecPat data_con pat_ty ex_tvs dicts rpats) match_result
 405   | null rpats
 406   =     -- Special case for C {}, which can be used for
 407         -- a constructor that isn't declared to have
 408         -- fields at all
 409     returnDs (ConPat data_con pat_ty ex_tvs dicts (map WildPat con_arg_tys'), match_result)
 410
 411   | otherwise
 412   = returnDs (ConPat data_con pat_ty ex_tvs dicts pats, match_result)
 413   where
 414     pats             = map mk_pat tagged_arg_tys
 415
 416         -- Boring stuff to find the arg-tys of the constructor
 417     inst_tys         = tcTyConAppArgs pat_ty    -- Newtypes must be opaque
 418     con_arg_tys'     = dataConInstOrigArgTys data_con (inst_tys ++ mkTyVarTys ex_tvs)
 419     tagged_arg_tys   = con_arg_tys' `zip` (dataConFieldLabels data_con)
 420
 421         -- mk_pat picks a WildPat of the appropriate type for absent fields,
 422         -- and the specified pattern for present fields
 423     mk_pat (arg_ty, lbl) = case [pat | (sel_id,pat,_) <- rpats,
 424                                         recordSelectorFieldLabel sel_id == lbl
 425                                 ] of
 426                                 (pat:pats) -> ASSERT( null pats )
 427                                               pat
 428                                 []         -> WildPat arg_ty
 429
 430 tidy1 v (ListPat ty pats) match_result
 431   = returnDs (list_ConPat, match_result)
 432   where
 433     list_ty = mkListTy ty
 434     list_ConPat
 435       = foldr (\ x -> \y -> ConPat consDataCon list_ty [] [] [x, y])
 436               (ConPat nilDataCon  list_ty [] [] [])
 437               pats
 438
 439 -- introduce fake parallel array constructors to be able to handle parallel
 440 -- arrays with the existing machinery for constructor pattern
 441 --
 442 tidy1 v (PArrPat ty pats) match_result
 443   = returnDs (parrConPat, match_result)
 444   where
 445     arity      = length pats
 446     parrConPat = ConPat (parrFakeCon arity) (mkPArrTy ty) [] [] pats
 447
 448 tidy1 v (TuplePat pats boxity) match_result
 449   = returnDs (tuple_ConPat, match_result)
 450   where
 451     arity = length pats
 452     tuple_ConPat
 453       = ConPat (tupleCon boxity arity)
 454                (mkTupleTy boxity arity (map outPatType pats)) [] []
 455                pats
 456
 457 tidy1 v (DictPat dicts methods) match_result
 458   = case num_of_d_and_ms of
 459         0 -> tidy1 v (TuplePat [] Boxed) match_result
 460         1 -> tidy1 v (head dict_and_method_pats) match_result
 461         _ -> tidy1 v (TuplePat dict_and_method_pats Boxed) match_result
 462   where
 463     num_of_d_and_ms      = length dicts + length methods
 464     dict_and_method_pats = map VarPat (dicts ++ methods)
 465
 466 -- LitPats: we *might* be able to replace these w/ a simpler form
 467 tidy1 v pat@(LitPat lit lit_ty) match_result
 468   = returnDs (tidyLitPat lit pat, match_result)
 469
 470 -- NPats: we *might* be able to replace these w/ a simpler form
 471 tidy1 v pat@(NPat lit lit_ty _) match_result
 472   = returnDs (tidyNPat lit lit_ty pat, match_result)
 473
 474 -- and everything else goes through unchanged...
 475
 476 tidy1 v non_interesting_pat match_result
 477   = returnDs (non_interesting_pat, match_result)
 478 \end{code}
 479
 480 \noindent
 481 {\bf Previous @matchTwiddled@ stuff:}
 482
 483 Now we get to the only interesting part; note: there are choices for
 484 translation [from Simon's notes]; translation~1:
 485 \begin{verbatim}
 486 deTwiddle [s,t] e
 487 \end{verbatim}
 488 returns
 489 \begin{verbatim}
 490 [ w = e,
 491   s = case w of [s,t] -> s
 492   t = case w of [s,t] -> t
 493 ]
 494 \end{verbatim}
 495
 496 Here \tr{w} is a fresh variable, and the \tr{w}-binding prevents multiple
 497 evaluation of \tr{e}.  An alternative translation (No.~2):
 498 \begin{verbatim}
 499 [ w = case e of [s,t] -> (s,t)
 500   s = case w of (s,t) -> s
 501   t = case w of (s,t) -> t
 502 ]
 503 \end{verbatim}
 504
 505 %************************************************************************
 506 %*                                                                      *
 507 \subsubsection[improved-unmixing]{UNIMPLEMENTED idea for improved unmixing}
 508 %*                                                                      *
 509 %************************************************************************
 510
 511 We might be able to optimise unmixing when confronted by
 512 only-one-constructor-possible, of which tuples are the most notable
 513 examples.  Consider:
 514 \begin{verbatim}
 515 f (a,b,c) ... = ...
 516 f d ... (e:f) = ...
 517 f (g,h,i) ... = ...
 518 f j ...       = ...
 519 \end{verbatim}
 520 This definition would normally be unmixed into four equation blocks,
 521 one per equation.  But it could be unmixed into just one equation
 522 block, because if the one equation matches (on the first column),
 523 the others certainly will.
 524
 525 You have to be careful, though; the example
 526 \begin{verbatim}
 527 f j ...       = ...
 528 -------------------
 529 f (a,b,c) ... = ...
 530 f d ... (e:f) = ...
 531 f (g,h,i) ... = ...
 532 \end{verbatim}
 533 {\em must} be broken into two blocks at the line shown; otherwise, you
 534 are forcing unnecessary evaluation.  In any case, the top-left pattern
 535 always gives the cue.  You could then unmix blocks into groups of...
 536 \begin{description}
 537 \item[all variables:]
 538 As it is now.
 539 \item[constructors or variables (mixed):]
 540 Need to make sure the right names get bound for the variable patterns.
 541 \item[literals or variables (mixed):]
 542 Presumably just a variant on the constructor case (as it is now).
 543 \end{description}
 544
 545 %************************************************************************
 546 %*                                                                      *
 547 %* match on an unmixed block: the real business                         *
 548 %*                                                                      *
 549 %************************************************************************
 550 \subsection[matchEqnBlock]{@matchEqnBlock@: getting down to business}
 551
 552 The function @matchEqnBlock@ is where the matching stuff sets to
 553 work a block of equations, to which the mixture rule has been applied.
 554 Its arguments and results are the same as for the ``top-level'' @match@.
 555
 556 \begin{code}
 557 matchEqnBlock :: [Id]
 558               -> [EquationInfo]
 559               -> DsM MatchResult
 560
 561 matchEqnBlock [] _ = panic "matchEqnBlock: no names"
 562
 563 matchEqnBlock all_vars@(var:vars) eqns_info
 564   | isWildPat first_pat
 565   = ASSERT( all isWildPat column_1_pats )       -- Sanity check
 566         -- Real true variables, just like in matchVar, SLPJ p 94
 567         -- No binding to do: they'll all be wildcards by now (done in tidy)
 568     match vars remaining_eqns_info
 569
 570   | isConPat first_pat
 571   = ASSERT( patsAreAllCons column_1_pats )
 572     matchConFamily all_vars eqns_info
 573
 574   | isLitPat first_pat
 575   = ASSERT( patsAreAllLits column_1_pats )
 576         -- see notes in MatchLiteral
 577         -- not worried about the same literal more than once in a column
 578         -- (ToDo: sort this out later)
 579     matchLiterals all_vars eqns_info
 580
 581   | isSigPat first_pat
 582   = ASSERT( isSingleton eqns_info )
 583     matchSigPat all_vars (head eqns_info)
 584   where
 585     first_pat           = head column_1_pats
 586     column_1_pats       = [pat                             | EqnInfo _ _   (pat:_)  _            <- eqns_info]
 587     remaining_eqns_info = [EqnInfo n ctx pats match_result | EqnInfo n ctx (_:pats) match_result <- eqns_info]
 588 \end{code}
 589
 590 A SigPat is a type coercion and must be handled one at at time.  We can't
 591 combine them unless the type of the pattern inside is identical, and we don't
 592 bother to check for that.  For example:
 593
 594         data T = T1 Int | T2 Bool
 595         f :: (forall a. a -> a) -> T -> t
 596         f (g::Int->Int)   (T1 i) = T1 (g i)
 597         f (g::Bool->Bool) (T2 b) = T2 (g b)
 598
 599 We desugar this as follows:
 600
 601         f = \ g::(forall a. a->a) t::T ->
 602             let gi = g Int
 603             in case t of { T1 i -> T1 (gi i)
 604                            other ->
 605             let gb = g Bool
 606             in case t of { T2 b -> T2 (gb b)
 607                            other -> fail }}
 608
 609 Note that we do not treat the first column of patterns as a
 610 column of variables, because the coerced variables (gi, gb)
 611 would be of different types.  So we get rather grotty code.
 612 But I don't think this is a common case, and if it was we could
 613 doubtless improve it.
 614
 615 Meanwhile, the strategy is:
 616         * treat each SigPat coercion (always non-identity coercions)
 617                 as a separate block
 618         * deal with the stuff inside, and then wrap a binding round
 619                 the result to bind the new variable (gi, gb, etc)
 620
 621 \begin{code}
 622 matchSigPat :: [Id] -> EquationInfo -> DsM MatchResult
 623 matchSigPat (var:vars) (EqnInfo n ctx (SigPat pat ty co_fn : pats) result)
 624   = selectMatchVar pat                                          `thenDs` \ new_var ->
 625     dsExpr (HsApp co_fn (HsVar var))                            `thenDs` \ rhs ->
 626     match (new_var:vars) [EqnInfo n ctx (pat:pats) result]      `thenDs` \ result' ->
 627     returnDs (adjustMatchResult (bindNonRec new_var rhs) result')
 628 \end{code}
 629
 630 %************************************************************************
 631 %*                                                                      *
 632 %*  matchWrapper: a convenient way to call @match@                      *
 633 %*                                                                      *
 634 %************************************************************************
 635 \subsection[matchWrapper]{@matchWrapper@: a convenient interface to @match@}
 636
 637 Calls to @match@ often involve similar (non-trivial) work; that work
 638 is collected here, in @matchWrapper@.  This function takes as
 639 arguments:
 640 \begin{itemize}
 641 \item
 642 Typchecked @Matches@ (of a function definition, or a case or lambda
 643 expression)---the main input;
 644 \item
 645 An error message to be inserted into any (runtime) pattern-matching
 646 failure messages.
 647 \end{itemize}
 648
 649 As results, @matchWrapper@ produces:
 650 \begin{itemize}
 651 \item
 652 A list of variables (@Locals@) that the caller must ``promise'' to
 653 bind to appropriate values; and
 654 \item
 655 a @CoreExpr@, the desugared output (main result).
 656 \end{itemize}
 657
 658 The main actions of @matchWrapper@ include:
 659 \begin{enumerate}
 660 \item
 661 Flatten the @[TypecheckedMatch]@ into a suitable list of
 662 @EquationInfo@s.
 663 \item
 664 Create as many new variables as there are patterns in a pattern-list
 665 (in any one of the @EquationInfo@s).
 666 \item
 667 Create a suitable ``if it fails'' expression---a call to @error@ using
 668 the error-string input; the {\em type} of this fail value can be found
 669 by examining one of the RHS expressions in one of the @EquationInfo@s.
 670 \item
 671 Call @match@ with all of this information!
 672 \end{enumerate}
 673
 674 \begin{code}
 675 matchWrapper :: TypecheckedMatchContext -- For shadowing warning messages
 676              -> [TypecheckedMatch]      -- Matches being desugared
 677              -> DsM ([Id], CoreExpr)    -- Results
 678 \end{code}
 679
 680  There is one small problem with the Lambda Patterns, when somebody
 681  writes something similar to:
 682 \begin{verbatim}
 683     (\ (x:xs) -> ...)
 684 \end{verbatim}
 685  he/she don't want a warning about incomplete patterns, that is done with
 686  the flag @opt_WarnSimplePatterns@.
 687  This problem also appears in the:
 688 \begin{itemize}
 689 \item @do@ patterns, but if the @do@ can fail
 690       it creates another equation if the match can fail
 691       (see @DsExpr.doDo@ function)
 692 \item @let@ patterns, are treated by @matchSimply@
 693    List Comprension Patterns, are treated by @matchSimply@ also
 694 \end{itemize}
 695
 696 We can't call @matchSimply@ with Lambda patterns,
 697 due to the fact that lambda patterns can have more than
 698 one pattern, and match simply only accepts one pattern.
 699
 700 JJQC 30-Nov-1997
 701
 702 \begin{code}
 703 matchWrapper ctxt matches
 704   = getDOptsDs                                  `thenDs` \ dflags ->
 705     flattenMatches ctxt matches                 `thenDs` \ (result_ty, eqns_info) ->
 706     let
 707         EqnInfo _ _ arg_pats _ : _ = eqns_info
 708         error_string = matchContextErrString ctxt
 709     in
 710     mapDs selectMatchVar arg_pats               `thenDs` \ new_vars ->
 711     match_fun dflags new_vars eqns_info         `thenDs` \ match_result ->
 712
 713     mkErrorAppDs pAT_ERROR_ID result_ty error_string    `thenDs` \ fail_expr ->
 714     extractMatchResult match_result fail_expr           `thenDs` \ result_expr ->
 715     returnDs (new_vars, result_expr)
 716   where match_fun dflags
 717            = case ctxt of
 718                 LambdaExpr | dopt Opt_WarnSimplePatterns dflags -> matchExport
 719                            | otherwise                          -> match
 720                 _                                               -> matchExport
 721 \end{code}
 722
 723 %************************************************************************
 724 %*                                                                      *
 725 \subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern}
 726 %*                                                                      *
 727 %************************************************************************
 728
 729 @mkSimpleMatch@ is a wrapper for @match@ which deals with the
 730 situation where we want to match a single expression against a single
 731 pattern. It returns an expression.
 732
 733 \begin{code}
 734 matchSimply :: CoreExpr                 -- Scrutinee
 735             -> TypecheckedMatchContext  -- Match kind
 736             -> TypecheckedPat           -- Pattern it should match
 737             -> CoreExpr                 -- Return this if it matches
 738             -> CoreExpr                 -- Return this if it doesn't
 739             -> DsM CoreExpr
 740
 741 matchSimply scrut kind pat result_expr fail_expr
 742   = getSrcLocDs                                 `thenDs` \ locn ->
 743     let
 744       ctx          = DsMatchContext kind [pat] locn
 745       match_result = cantFailMatchResult result_expr
 746     in
 747     matchSinglePat scrut ctx pat match_result   `thenDs` \ match_result' ->
 748     extractMatchResult match_result' fail_expr
 749
 750
 751 matchSinglePat :: CoreExpr -> DsMatchContext -> TypecheckedPat
 752                -> MatchResult -> DsM MatchResult
 753
 754 matchSinglePat (Var var) ctx pat match_result
 755   = getDOptsDs                                  `thenDs` \ dflags ->
 756     match_fn dflags [var] [EqnInfo 1 ctx [pat] match_result]
 757   where
 758     match_fn dflags
 759        | dopt Opt_WarnSimplePatterns dflags = matchExport
 760        | otherwise                          = match
 761
 762 matchSinglePat scrut ctx pat match_result
 763   = selectMatchVar pat                                  `thenDs` \ var ->
 764     matchSinglePat (Var var) ctx pat match_result       `thenDs` \ match_result' ->
 765     returnDs (adjustMatchResult (bindNonRec var scrut) match_result')
 766 \end{code}
 767
 768 %************************************************************************
 769 %*                                                                      *
 770 %*  flattenMatches : create a list of EquationInfo                      *
 771 %*                                                                      *
 772 %************************************************************************
 773
 774 \subsection[flattenMatches]{@flattenMatches@: create @[EquationInfo]@}
 775
 776 This is actually local to @matchWrapper@.
 777
 778 \begin{code}
 779 flattenMatches :: TypecheckedMatchContext
 780                -> [TypecheckedMatch]
 781                -> DsM (Type, [EquationInfo])
 782
 783 flattenMatches kind matches
 784   = mapAndUnzipDs flatten_match (matches `zip` [1..])   `thenDs` \ (result_tys, eqn_infos) ->
 785     let
 786         result_ty = head result_tys
 787     in
 788     ASSERT( all (tcEqType result_ty) result_tys )
 789     returnDs (result_ty, eqn_infos)
 790   where
 791     flatten_match (Match pats _ grhss, n)
 792       = dsGRHSs kind pats grhss                 `thenDs` \ (ty, match_result) ->
 793         getSrcLocDs                             `thenDs` \ locn ->
 794         returnDs (ty, EqnInfo n (DsMatchContext kind pats locn) pats match_result)
 795 \end{code}