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