ghc/compiler/deSugar/Match.lhs

   1
   2 %
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   4 %
   5 \section[Main_match]{The @match@ function}
   6
   7 \begin{code}
   8 #include "HsVersions.h"
   9
  10 module Match ( matchExport, match, matchWrapper, matchSimply ) where
  11
  12 IMP_Ubiq()
  13 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
  14 IMPORT_DELOOPER(DsLoop) -- here for paranoia-checking reasons
  15                         -- and to break dsExpr/dsBinds-ish loop
  16 #else
  17 import {-# SOURCE #-} DsExpr  ( dsExpr  )
  18 import {-# SOURCE #-} DsBinds ( dsBinds )
  19 #endif
  20
  21 import CmdLineOpts      ( opt_WarnIncompletePatterns, opt_WarnOverlappedPatterns,
  22                           opt_PprUserLength,opt_WarnSimplePatterns
  23                         )
  24 import HsSyn
  25 import TcHsSyn          ( SYN_IE(TypecheckedPat), SYN_IE(TypecheckedMatch),
  26                           SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr) )
  27 import DsHsSyn          ( outPatType, collectTypedPatBinders )
  28 import Check            ( check, SYN_IE(ExhaustivePat), SYN_IE(WarningPat), BoxedString )
  29 import CoreSyn
  30 import CoreUtils        ( coreExprType )
  31 import DsMonad
  32 import DsGRHSs          ( dsGRHSs )
  33 import DsUtils
  34 import ErrUtils         ( SYN_IE(Warning) )
  35 import FieldLabel       ( FieldLabel {- Eq instance -} )
  36 import Id               ( idType, dataConFieldLabels,
  37                           dataConArgTys, recordSelectorFieldLabel,
  38                           GenId{-instance-}, SYN_IE(Id)
  39                         )
  40 import MatchCon         ( matchConFamily )
  41 import MatchLit         ( matchLiterals )
  42 import Name             ( Name {--O only-} )
  43 import Outputable       ( PprStyle(..), Outputable(..), pprQuote )
  44 import PprType          ( GenType{-instance-}, GenTyVar{-ditto-} )
  45 import Pretty
  46 import PrelVals         ( pAT_ERROR_ID )
  47 import SrcLoc           ( noSrcLoc, SrcLoc )
  48 import Type             ( isPrimType, eqTy, getAppDataTyConExpandingDicts,
  49                           instantiateTauTy, SYN_IE(Type)
  50                         )
  51 import TyVar            ( GenTyVar{-instance Eq-}, SYN_IE(TyVar) )
  52 import TysPrim          ( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy,
  53                           addrPrimTy, wordPrimTy
  54                         )
  55 import TysWiredIn       ( nilDataCon, consDataCon, mkTupleTy, mkListTy,
  56                           charTy, charDataCon, intTy, intDataCon,
  57                           floatTy, floatDataCon, doubleTy, tupleCon,
  58                           doubleDataCon, stringTy, addrTy,
  59                           addrDataCon, wordTy, wordDataCon
  60                         )
  61 import Unique           ( Unique{-instance Eq-} )
  62 import UniqSet
  63 import Util             ( panic, pprPanic, assertPanic )
  64 \end{code}
  65
  66 This function is a wrapper of @match@, it must be called from all the parts where
  67 it was called match, but only substitutes the firs call, ....
  68 if the associated flags are declared, warnings will be issued.
  69 It can not be called matchWrapper because this name already exists :-(
  70
  71 JJCQ 30-Nov-1997
  72
  73 \begin{code}
  74 matchExport :: [Id]             -- Vars rep'ing the exprs we're matching with
  75             -> [EquationInfo]   -- Info about patterns, etc. (type synonym below)
  76             -> DsM MatchResult  -- Desugared result!
  77
  78 matchExport vars qs@((EqnInfo _ ctx _ (MatchResult _ _ _)) : _)
  79   | incomplete && shadow =
  80       dsShadowWarn ctx eqns_shadow              `thenDs`   \ () ->
  81       dsIncompleteWarn ctx pats                 `thenDs`   \ () ->
  82       match vars qs
  83   | incomplete            =
  84       dsIncompleteWarn ctx pats                 `thenDs`   \ () ->
  85       match vars qs
  86   | shadow                =
  87       dsShadowWarn ctx eqns_shadow              `thenDs`   \ () ->
  88       match vars qs
  89   | otherwise             =
  90       match vars qs
  91   where (pats,indexs) = check qs
  92         incomplete    = opt_WarnIncompletePatterns && (length pats /= 0)
  93         shadow        = opt_WarnOverlappedPatterns && sizeUniqSet indexs < no_eqns
  94         no_eqns       = length qs
  95         unused_eqns   = uniqSetToList (mkUniqSet [1..no_eqns] `minusUniqSet` indexs)
  96         eqns_shadow   = map (\n -> qs!!(n - 1)) unused_eqns
  97 \end{code}
  98
  99 This variable shows the maximun number of lines of output generated for warnings.
 100 It will limit the number of patterns/equations displayed to maximum_output.
 101
 102 \begin{code}
 103 maximum_output = 4
 104 \end{code}
 105
 106 The next two functions creates the warning message.
 107
 108 \begin{code}
 109 dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM ()
 110 dsShadowWarn ctx@(DsMatchContext kind _ _) qs = dsWarn warn
 111         where
 112           warn sty | length qs > maximum_output =
 113                hang (pp_context sty ctx (ptext SLIT("are overlapped")))
 114                     12 ((vcat $ map (ppr_eqn kind sty) (take maximum_output qs))
 115                         $$ ptext SLIT("..."))
 116           warn sty =
 117                hang (pp_context sty ctx (ptext SLIT("are overlapped")))
 118                     12 (vcat $ map (ppr_eqn kind sty) qs)
 119
 120 dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM ()
 121 dsIncompleteWarn ctx@(DsMatchContext kind _ _) pats = dsWarn warn
 122         where
 123           warn sty | length pats > maximum_output =
 124                hang (pp_context sty ctx (ptext SLIT("are non-exhaustive")))
 125                     12 (hang (ptext SLIT("Patterns not recognized:"))
 126                        4 ((vcat $ map (ppr_incomplete_pats kind sty) (take maximum_output pats))
 127                           $$ ptext SLIT("...")))
 128           warn sty =
 129                hang (pp_context sty ctx (ptext SLIT("are non-exhaustive")))
 130                     12 (hang (ptext SLIT("Patterns not recognized:"))
 131                        4 (vcat $ map (ppr_incomplete_pats kind sty) pats))
 132
 133 pp_context sty NoMatchContext msg = ptext SLIT("Warning: Some match(es)") <+> msg
 134
 135 pp_context sty (DsMatchContext kind pats loc) msg
 136   = hang (hcat [ppr (PprForUser opt_PprUserLength) loc, ptext SLIT(": ")])
 137              4 (hang message
 138                      4 (pp_match kind pats))
 139  where
 140     message = ptext SLIT("Warning: Pattern match(es)") <+> msg
 141
 142     pp_match (FunMatch fun) pats
 143       = hsep [ptext SLIT("in the definition of function"), ppr sty fun]
 144
 145     pp_match CaseMatch pats
 146       = hang (ptext SLIT("in a group of case alternatives beginning:"))
 147         4 (ppr_pats sty pats)
 148
 149     pp_match PatBindMatch pats
 150       = hang (ptext SLIT("in a pattern binding:"))
 151         4 (ppr_pats sty pats)
 152
 153     pp_match LambdaMatch pats
 154       = hang (ptext SLIT("in a lambda abstraction:"))
 155         4 (ppr_pats sty pats)
 156
 157     pp_match DoBindMatch pats
 158       = hang (ptext SLIT("in a `do' pattern binding:"))
 159         4 (ppr_pats sty pats)
 160
 161     pp_match ListCompMatch pats
 162       = hang (ptext SLIT("in a `list comprension' pattern binding:"))
 163         4 (ppr_pats sty pats)
 164
 165     pp_match LetMatch pats
 166       = hang (ptext SLIT("in a `let' pattern binding:"))
 167         4 (ppr_pats sty pats)
 168
 169 ppr_pats sty pats = pprQuote sty $ \ sty -> sep (map (ppr sty) pats)
 170
 171 separator (FunMatch _)    = SLIT("=")
 172 separator (CaseMatch)     = SLIT("->")
 173 separator (LambdaMatch)   = SLIT("->")
 174 separator (PatBindMatch)  = panic "When is this used?"
 175 separator (DoBindMatch)   = SLIT("<-")
 176 separator (ListCompMatch) = SLIT("<-")
 177 separator (LetMatch)      = SLIT("=")
 178
 179 ppr_shadow_pats kind sty pats = pprQuote sty $ \ sty ->
 180                          sep [sep (map (ppr sty) pats), ptext (separator kind), ptext SLIT("...")]
 181
 182 ppr_incomplete_pats kind sty (pats,[]) = pprQuote sty $ \ sty ->
 183                          sep [sep (map (ppr sty) pats)]
 184 ppr_incomplete_pats kind sty (pats,constraints) = pprQuote sty $ \ sty ->
 185                          sep [sep (map (ppr sty) pats), ptext SLIT("with"),
 186                          sep (map (ppr_constraint sty) constraints)]
 187
 188
 189 ppr_constraint sty (var,pats) = sep [ppr sty var, ptext SLIT("`not_elem`"),ppr sty pats]
 190
 191 ppr_eqn kind sty (EqnInfo _ _ pats _) = ppr_shadow_pats kind sty pats
 192
 193 \end{code}
 194
 195
 196 The function @match@ is basically the same as in the Wadler chapter,
 197 except it is monadised, to carry around the name supply, info about
 198 annotations, etc.
 199
 200 Notes on @match@'s arguments, assuming $m$ equations and $n$ patterns:
 201 \begin{enumerate}
 202 \item
 203 A list of $n$ variable names, those variables presumably bound to the
 204 $n$ expressions being matched against the $n$ patterns.  Using the
 205 list of $n$ expressions as the first argument showed no benefit and
 206 some inelegance.
 207
 208 \item
 209 The second argument, a list giving the ``equation info'' for each of
 210 the $m$ equations:
 211 \begin{itemize}
 212 \item
 213 the $n$ patterns for that equation, and
 214 \item
 215 a list of Core bindings [@(Id, CoreExpr)@ pairs] to be ``stuck on
 216 the front'' of the matching code, as in:
 217 \begin{verbatim}
 218 let <binds>
 219 in  <matching-code>
 220 \end{verbatim}
 221 \item
 222 and finally: (ToDo: fill in)
 223
 224 The right way to think about the ``after-match function'' is that it
 225 is an embryonic @CoreExpr@ with a ``hole'' at the end for the
 226 final ``else expression''.
 227 \end{itemize}
 228
 229 There is a type synonym, @EquationInfo@, defined in module @DsUtils@.
 230
 231 An experiment with re-ordering this information about equations (in
 232 particular, having the patterns available in column-major order)
 233 showed no benefit.
 234
 235 \item
 236 A default expression---what to evaluate if the overall pattern-match
 237 fails.  This expression will (almost?) always be
 238 a measly expression @Var@, unless we know it will only be used once
 239 (as we do in @glue_success_exprs@).
 240
 241 Leaving out this third argument to @match@ (and slamming in lots of
 242 @Var "fail"@s) is a positively {\em bad} idea, because it makes it
 243 impossible to share the default expressions.  (Also, it stands no
 244 chance of working in our post-upheaval world of @Locals@.)
 245 \end{enumerate}
 246 So, the full type signature:
 247 \begin{code}
 248 match :: [Id]             -- Variables rep'ing the exprs we're matching with
 249       -> [EquationInfo]   -- Info about patterns, etc. (type synonym below)
 250       -> DsM MatchResult  -- Desugared result!
 251 \end{code}
 252
 253 Note: @match@ is often called via @matchWrapper@ (end of this module),
 254 a function that does much of the house-keeping that goes with a call
 255 to @match@.
 256
 257 It is also worth mentioning the {\em typical} way a block of equations
 258 is desugared with @match@.  At each stage, it is the first column of
 259 patterns that is examined.  The steps carried out are roughly:
 260 \begin{enumerate}
 261 \item
 262 Tidy the patterns in column~1 with @tidyEqnInfo@ (this may add
 263 bindings to the second component of the equation-info):
 264 \begin{itemize}
 265 \item
 266 Remove the `as' patterns from column~1.
 267 \item
 268 Make all constructor patterns in column~1 into @ConPats@, notably
 269 @ListPats@ and @TuplePats@.
 270 \item
 271 Handle any irrefutable (or ``twiddle'') @LazyPats@.
 272 \end{itemize}
 273 \item
 274 Now {\em unmix} the equations into {\em blocks} [w/ local function
 275 @unmix_eqns@], in which the equations in a block all have variable
 276 patterns in column~1, or they all have constructor patterns in ...
 277 (see ``the mixture rule'' in SLPJ).
 278 \item
 279 Call @matchUnmixedEqns@ on each block of equations; it will do the
 280 appropriate thing for each kind of column-1 pattern, usually ending up
 281 in a recursive call to @match@.
 282 \end{enumerate}
 283
 284 %************************************************************************
 285 %*                                                                      *
 286 %*  match: empty rule                                                   *
 287 %*                                                                      *
 288 %************************************************************************
 289 \subsection[Match-empty-rule]{The ``empty rule''}
 290
 291 We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87)
 292 than the Wadler-chapter code for @match@ (p.~93, first @match@ clause).
 293 And gluing the ``success expressions'' together isn't quite so pretty.
 294
 295 \begin{code}
 296 match [] eqns_info
 297   = complete_matches eqns_info
 298   where
 299     complete_matches [eqn]
 300         = complete_match eqn
 301
 302     complete_matches (eqn:eqns)
 303         = complete_match eqn            `thenDs` \ match_result1 ->
 304           complete_matches eqns         `thenDs` \ match_result2 ->
 305           combineMatchResults match_result1 match_result2
 306
 307     complete_match (EqnInfo _ _ [] match_result@(MatchResult _ _ _))
 308         = returnDs match_result
 309 \end{code}
 310
 311 %************************************************************************
 312 %*                                                                      *
 313 %*  match: non-empty rule                                               *
 314 %*                                                                      *
 315 %************************************************************************
 316 \subsection[Match-nonempty]{@match@ when non-empty: unmixing}
 317
 318 This (more interesting) clause of @match@ uses @tidy_and_unmix_eqns@
 319 (a)~to get `as'- and `twiddle'-patterns out of the way (tidying), and
 320 (b)~to do ``the mixture rule'' (SLPJ, p.~88) [which really {\em
 321 un}mixes the equations], producing a list of equation-info
 322 blocks, each block having as its first column of patterns either all
 323 constructors, or all variables (or similar beasts), etc.
 324
 325 @match_unmixed_eqn_blks@ simply takes the place of the @foldr@ in the
 326 Wadler-chapter @match@ (p.~93, last clause), and @match_unmixed_blk@
 327 corresponds roughly to @matchVarCon@.
 328
 329 \begin{code}
 330 match vars@(v:vs) eqns_info
 331   = mapDs (tidyEqnInfo v) eqns_info     `thenDs` \ tidy_eqns_info ->
 332     let
 333         tidy_eqns_blks = unmix_eqns tidy_eqns_info
 334     in
 335     match_unmixed_eqn_blks vars tidy_eqns_blks
 336   where
 337     unmix_eqns []    = []
 338     unmix_eqns [eqn] = [ [eqn] ]
 339     unmix_eqns (eq1@(EqnInfo _ _ (p1:p1s) _) : eq2@(EqnInfo _ _ (p2:p2s) _) : eqs)
 340       = if (  (irrefutablePat p1 && irrefutablePat p2)
 341            || (isConPat       p1 && isConPat       p2)
 342            || (isLitPat       p1 && isLitPat       p2) ) then
 343             eq1 `tack_onto` unmixed_rest
 344         else
 345             [ eq1 ] : unmixed_rest
 346       where
 347         unmixed_rest = unmix_eqns (eq2:eqs)
 348
 349         x `tack_onto` xss   = ( x : head xss) : tail xss
 350
 351     -----------------------------------------------------------------------
 352     -- loop through the blocks:
 353     -- subsequent blocks create a "fail expr" for the first one...
 354     match_unmixed_eqn_blks :: [Id]
 355                            -> [ [EquationInfo] ]        -- List of eqn BLOCKS
 356                            -> DsM MatchResult
 357
 358     match_unmixed_eqn_blks vars [] = panic "match_unmixed_eqn_blks"
 359
 360     match_unmixed_eqn_blks vars [eqn_blk] = matchUnmixedEqns vars eqn_blk
 361
 362     match_unmixed_eqn_blks vars (eqn_blk:eqn_blks)
 363       = matchUnmixedEqns vars eqn_blk           `thenDs` \ match_result1 ->  -- try to match with first blk
 364         match_unmixed_eqn_blks vars eqn_blks    `thenDs` \ match_result2 ->
 365         combineMatchResults match_result1 match_result2
 366 \end{code}
 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- and list-pats into ordinary @ConPats@.
 380 \item
 381 Convert the literal pat "" to [].
 382 \end{itemize}
 383
 384 The result of this tidying is that the column of patterns will include
 385 {\em only}:
 386 \begin{description}
 387 \item[@WildPats@:]
 388 The @VarPat@ information isn't needed any more after this.
 389
 390 \item[@ConPats@:]
 391 @ListPats@, @TuplePats@, etc., are all converted into @ConPats@.
 392
 393 \item[@LitPats@ and @NPats@:]
 394 @LitPats@/@NPats@ of ``known friendly types'' (Int, Char,
 395 Float,  Double, at least) are converted to unboxed form; e.g.,
 396 \tr{(NPat (HsInt i) _ _)} is converted to:
 397 \begin{verbatim}
 398 (ConPat I# _ _ [LitPat (HsIntPrim i) _])
 399 \end{verbatim}
 400 \end{description}
 401
 402 \begin{code}
 403 tidyEqnInfo :: Id -> EquationInfo -> DsM EquationInfo
 404         -- DsM'd because of internal call to "match".
 405         -- "tidy1" does the interesting stuff, looking at
 406         -- one pattern and fiddling the list of bindings.
 407 tidyEqnInfo v (EqnInfo n ctx (pat : pats) match_result)
 408   = tidy1 v pat match_result    `thenDs` \ (pat', match_result') ->
 409     returnDs (EqnInfo n ctx (pat' : pats) match_result')
 410
 411 tidy1 :: Id                                     -- The Id being scrutinised
 412       -> TypecheckedPat                         -- The pattern against which it is to be matched
 413       -> MatchResult                            -- Current thing do do after matching
 414       -> DsM (TypecheckedPat,                   -- Equivalent pattern
 415               MatchResult)                      -- Augmented thing to do afterwards
 416                                                 -- The augmentation usually takes the form
 417                                                 -- of new bindings to be added to the front
 418
 419 tidy1 v (VarPat var) match_result
 420   = returnDs (WildPat (idType var),
 421               mkCoLetsMatchResult extra_binds match_result)
 422   where
 423     extra_binds | v == var  = []
 424                 | otherwise = [NonRec var (Var v)]
 425
 426 tidy1 v (AsPat var pat) match_result
 427   = tidy1 v pat (mkCoLetsMatchResult extra_binds match_result)
 428   where
 429     extra_binds | v == var  = []
 430                 | otherwise = [NonRec var (Var v)]
 431
 432 tidy1 v (WildPat ty) match_result
 433   = returnDs (WildPat ty, match_result)
 434
 435 {- now, here we handle lazy patterns:
 436     tidy1 v ~p bs = (v, v1 = case v of p -> v1 :
 437                         v2 = case v of p -> v2 : ... : bs )
 438
 439     where the v_i's are the binders in the pattern.
 440
 441     ToDo: in "v_i = ... -> v_i", are the v_i's really the same thing?
 442
 443     The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr
 444 -}
 445
 446 tidy1 v (LazyPat pat) match_result
 447   = mkSelectorBinds pat (Var v)         `thenDs` \ sel_binds ->
 448     returnDs (WildPat (idType v),
 449               mkCoLetsMatchResult [NonRec b rhs | (b,rhs) <- sel_binds] match_result)
 450
 451 -- re-express <con-something> as (ConPat ...) [directly]
 452
 453 tidy1 v (ConOpPat pat1 id pat2 ty) match_result
 454   = returnDs (ConPat id ty [pat1, pat2], match_result)
 455
 456 tidy1 v (RecPat con_id pat_ty rpats) match_result
 457   = returnDs (ConPat con_id pat_ty pats, match_result)
 458   where
 459     pats             = map mk_pat tagged_arg_tys
 460
 461         -- Boring stuff to find the arg-tys of the constructor
 462     (_, inst_tys, _) = getAppDataTyConExpandingDicts pat_ty
 463     con_arg_tys'     = dataConArgTys con_id inst_tys
 464     tagged_arg_tys   = con_arg_tys' `zip` (dataConFieldLabels con_id)
 465
 466         -- mk_pat picks a WildPat of the appropriate type for absent fields,
 467         -- and the specified pattern for present fields
 468     mk_pat (arg_ty, lbl) = case [pat | (sel_id,pat,_) <- rpats,
 469                                         recordSelectorFieldLabel sel_id == lbl
 470                                 ] of
 471                                 (pat:pats) -> ASSERT( null pats )
 472                                               pat
 473                                 []         -> WildPat arg_ty
 474
 475 tidy1 v (ListPat ty pats) match_result
 476   = returnDs (list_ConPat, match_result)
 477   where
 478     list_ty = mkListTy ty
 479     list_ConPat
 480       = foldr (\ x -> \y -> ConPat consDataCon list_ty [x, y])
 481               (ConPat nilDataCon  list_ty [])
 482               pats
 483
 484 tidy1 v (TuplePat pats) match_result
 485   = returnDs (tuple_ConPat, match_result)
 486   where
 487     arity = length pats
 488     tuple_ConPat
 489       = ConPat (tupleCon arity)
 490                (mkTupleTy arity (map outPatType pats))
 491                pats
 492
 493 tidy1 v (DictPat dicts methods) match_result
 494   = case num_of_d_and_ms of
 495         0 -> tidy1 v (TuplePat []) match_result
 496         1 -> tidy1 v (head dict_and_method_pats) match_result
 497         _ -> tidy1 v (TuplePat dict_and_method_pats) match_result
 498   where
 499     num_of_d_and_ms      = length dicts + length methods
 500     dict_and_method_pats = map VarPat (dicts ++ methods)
 501
 502
 503 -- deeply ugly mangling for some (common) NPats/LitPats
 504
 505 -- LitPats: the desugarer only sees these at well-known types
 506
 507 tidy1 v pat@(LitPat lit lit_ty) match_result
 508   | isPrimType lit_ty
 509   = returnDs (pat, match_result)
 510
 511   | lit_ty `eqTy` charTy
 512   = returnDs (ConPat charDataCon charTy [LitPat (mk_char lit) charPrimTy],
 513               match_result)
 514
 515   | otherwise = pprPanic "tidy1:LitPat:" (ppr PprDebug pat)
 516   where
 517     mk_char (HsChar c)    = HsCharPrim c
 518
 519 -- NPats: we *might* be able to replace these w/ a simpler form
 520
 521
 522 tidy1 v pat@(NPat lit lit_ty _) match_result
 523   = returnDs (better_pat, match_result)
 524   where
 525     better_pat
 526       | lit_ty `eqTy` charTy   = ConPat charDataCon   lit_ty [LitPat (mk_char lit)   charPrimTy]
 527       | lit_ty `eqTy` intTy    = ConPat intDataCon    lit_ty [LitPat (mk_int lit)    intPrimTy]
 528       | lit_ty `eqTy` wordTy   = ConPat wordDataCon   lit_ty [LitPat (mk_word lit)   wordPrimTy]
 529       | lit_ty `eqTy` addrTy   = ConPat addrDataCon   lit_ty [LitPat (mk_addr lit)   addrPrimTy]
 530       | lit_ty `eqTy` floatTy  = ConPat floatDataCon  lit_ty [LitPat (mk_float lit)  floatPrimTy]
 531       | lit_ty `eqTy` doubleTy = ConPat doubleDataCon lit_ty [LitPat (mk_double lit) doublePrimTy]
 532
 533                 -- Convert the literal pattern "" to the constructor pattern [].
 534       | null_str_lit lit       = ConPat nilDataCon    lit_ty []
 535
 536       | otherwise          = pat
 537
 538     mk_int    (HsInt i)      = HsIntPrim i
 539     mk_int    l@(HsLitLit s) = l
 540
 541     mk_char   (HsChar c)     = HsCharPrim c
 542     mk_char   l@(HsLitLit s) = l
 543
 544     mk_word   l@(HsLitLit s) = l
 545
 546     mk_addr   l@(HsLitLit s) = l
 547
 548     mk_float  (HsInt i)      = HsFloatPrim (fromInteger i)
 549     mk_float  (HsFrac f)     = HsFloatPrim f
 550     mk_float  l@(HsLitLit s) = l
 551
 552     mk_double (HsInt i)      = HsDoublePrim (fromInteger i)
 553     mk_double (HsFrac f)     = HsDoublePrim f
 554     mk_double l@(HsLitLit s) = l
 555
 556     null_str_lit (HsString s) = _NULL_ s
 557     null_str_lit other_lit    = False
 558
 559 -- and everything else goes through unchanged...
 560
 561 tidy1 v non_interesting_pat match_result
 562   = returnDs (non_interesting_pat, match_result)
 563 \end{code}
 564
 565 PREVIOUS matchTwiddled STUFF:
 566
 567 Now we get to the only interesting part; note: there are choices for
 568 translation [from Simon's notes]; translation~1:
 569 \begin{verbatim}
 570 deTwiddle [s,t] e
 571 \end{verbatim}
 572 returns
 573 \begin{verbatim}
 574 [ w = e,
 575   s = case w of [s,t] -> s
 576   t = case w of [s,t] -> t
 577 ]
 578 \end{verbatim}
 579
 580 Here \tr{w} is a fresh variable, and the \tr{w}-binding prevents multiple
 581 evaluation of \tr{e}.  An alternative translation (No.~2):
 582 \begin{verbatim}
 583 [ w = case e of [s,t] -> (s,t)
 584   s = case w of (s,t) -> s
 585   t = case w of (s,t) -> t
 586 ]
 587 \end{verbatim}
 588
 589 %************************************************************************
 590 %*                                                                      *
 591 \subsubsection[improved-unmixing]{UNIMPLEMENTED idea for improved unmixing}
 592 %*                                                                      *
 593 %************************************************************************
 594
 595 We might be able to optimise unmixing when confronted by
 596 only-one-constructor-possible, of which tuples are the most notable
 597 examples.  Consider:
 598 \begin{verbatim}
 599 f (a,b,c) ... = ...
 600 f d ... (e:f) = ...
 601 f (g,h,i) ... = ...
 602 f j ...       = ...
 603 \end{verbatim}
 604 This definition would normally be unmixed into four equation blocks,
 605 one per equation.  But it could be unmixed into just one equation
 606 block, because if the one equation matches (on the first column),
 607 the others certainly will.
 608
 609 You have to be careful, though; the example
 610 \begin{verbatim}
 611 f j ...       = ...
 612 -------------------
 613 f (a,b,c) ... = ...
 614 f d ... (e:f) = ...
 615 f (g,h,i) ... = ...
 616 \end{verbatim}
 617 {\em must} be broken into two blocks at the line shown; otherwise, you
 618 are forcing unnecessary evaluation.  In any case, the top-left pattern
 619 always gives the cue.  You could then unmix blocks into groups of...
 620 \begin{description}
 621 \item[all variables:]
 622 As it is now.
 623 \item[constructors or variables (mixed):]
 624 Need to make sure the right names get bound for the variable patterns.
 625 \item[literals or variables (mixed):]
 626 Presumably just a variant on the constructor case (as it is now).
 627 \end{description}
 628
 629 %************************************************************************
 630 %*                                                                      *
 631 %* match on an unmixed block: the real business                         *
 632 %*                                                                      *
 633 %************************************************************************
 634 \subsection[matchUnmixedEqns]{@matchUnmixedEqns@: getting down to business}
 635
 636 The function @matchUnmixedEqns@ is where the matching stuff sets to
 637 work a block of equations, to which the mixture rule has been applied.
 638 Its arguments and results are the same as for the ``top-level'' @match@.
 639
 640 \begin{code}
 641 matchUnmixedEqns :: [Id]
 642                   -> [EquationInfo]
 643                   -> DsM MatchResult
 644
 645 matchUnmixedEqns [] _ = panic "matchUnmixedEqns: no names"
 646
 647 matchUnmixedEqns all_vars@(var:vars) eqns_info
 648   | irrefutablePat first_pat
 649   = ASSERT( irrefutablePats column_1_pats )     -- Sanity check
 650         -- Real true variables, just like in matchVar, SLPJ p 94
 651     match vars remaining_eqns_info
 652
 653   | isConPat first_pat
 654   = ASSERT( patsAreAllCons column_1_pats )
 655     matchConFamily all_vars eqns_info
 656
 657   | isLitPat first_pat
 658   = ASSERT( patsAreAllLits column_1_pats )
 659         -- see notes in MatchLiteral
 660         -- not worried about the same literal more than once in a column
 661         -- (ToDo: sort this out later)
 662     matchLiterals all_vars eqns_info
 663
 664   where
 665     first_pat           = head column_1_pats
 666     column_1_pats       = [pat                       | EqnInfo _ _ (pat:_)  _            <- eqns_info]
 667     remaining_eqns_info = [EqnInfo n ctx pats match_result | EqnInfo n ctx (_:pats) match_result <- eqns_info]
 668 \end{code}
 669
 670 %************************************************************************
 671 %*                                                                      *
 672 %*  matchWrapper: a convenient way to call @match@                      *
 673 %*                                                                      *
 674 %************************************************************************
 675 \subsection[matchWrapper]{@matchWrapper@: a convenient interface to @match@}
 676
 677 Calls to @match@ often involve similar (non-trivial) work; that work
 678 is collected here, in @matchWrapper@.  This function takes as
 679 arguments:
 680 \begin{itemize}
 681 \item
 682 Typchecked @Matches@ (of a function definition, or a case or lambda
 683 expression)---the main input;
 684 \item
 685 An error message to be inserted into any (runtime) pattern-matching
 686 failure messages.
 687 \end{itemize}
 688
 689 As results, @matchWrapper@ produces:
 690 \begin{itemize}
 691 \item
 692 A list of variables (@Locals@) that the caller must ``promise'' to
 693 bind to appropriate values; and
 694 \item
 695 a @CoreExpr@, the desugared output (main result).
 696 \end{itemize}
 697
 698 The main actions of @matchWrapper@ include:
 699 \begin{enumerate}
 700 \item
 701 Flatten the @[TypecheckedMatch]@ into a suitable list of
 702 @EquationInfo@s.
 703 \item
 704 Create as many new variables as there are patterns in a pattern-list
 705 (in any one of the @EquationInfo@s).
 706 \item
 707 Create a suitable ``if it fails'' expression---a call to @error@ using
 708 the error-string input; the {\em type} of this fail value can be found
 709 by examining one of the RHS expressions in one of the @EquationInfo@s.
 710 \item
 711 Call @match@ with all of this information!
 712 \end{enumerate}
 713
 714 \begin{code}
 715 matchWrapper :: DsMatchKind                     -- For shadowing warning messages
 716              -> [TypecheckedMatch]              -- Matches being desugared
 717              -> String                          -- Error message if the match fails
 718              -> DsM ([Id], CoreExpr)    -- Results
 719 \end{code}
 720
 721  a special case for the common ...:
 722         just one Match
 723         lots of (all?) unfailable pats
 724   e.g.,
 725         f x y z = ....
 726
 727  This special case have been ``undone'' due to problems with the new warnings
 728  messages (Check.lhs.check). We need there the name of the variables to be able to
 729  print later the equation. JJQC 30-11-97
 730
 731 \begin{old_code}
 732 matchWrapper kind [(PatMatch (VarPat var) match)] error_string
 733   = matchWrapper kind [match] error_string `thenDs` \ (vars, core_expr) ->
 734     returnDs (var:vars, core_expr)
 735
 736 matchWrapper kind [(PatMatch (WildPat ty) match)] error_string
 737   = newSysLocalDs ty                       `thenDs` \ var ->
 738     matchWrapper kind [match] error_string `thenDs` \ (vars, core_expr) ->
 739     returnDs (var:vars, core_expr)
 740
 741 matchWrapper kind [(GRHSMatch
 742                      (GRHSsAndBindsOut [OtherwiseGRHS expr _] binds _))] error_string
 743   = dsBinds False{-don't auto-scc-} binds            `thenDs` \ core_binds ->
 744     dsExpr  expr                                     `thenDs` \ core_expr ->
 745     returnDs ([], mkCoLetsAny core_binds core_expr)
 746 \end{old_code}
 747
 748  And all the rest... (general case)
 749
 750
 751  There is one small problem with the Lambda Patterns, when somebody
 752  writes something similar to:
 753     (\ (x:xs) -> ...)
 754  he/she don't want a warning about incomplete patterns, that is done with
 755  the flag opt_WarnSimplePatterns.
 756  This problem also appears in the :
 757    do patterns, but if the do can fail it creates another equation if the match can
 758                 fail (see DsExpr.doDo function)
 759    let patterns, are treated by matchSimply
 760    List Comprension Patterns, are treated by matchSimply also
 761
 762 We can't call matchSimply with Lambda patterns, due to lambda patterns can have more than
 763 one pattern, and match simply only accepts one pattern.
 764
 765 JJQC 30-Nov-1997
 766
 767 \begin{code}
 768
 769 matchWrapper kind matches error_string
 770   = flattenMatches kind 1 matches       `thenDs` \ eqns_info@(EqnInfo _ _ arg_pats (MatchResult _ result_ty _) : _) ->
 771
 772     selectMatchVars arg_pats                            `thenDs` \ new_vars ->
 773     match_fun new_vars eqns_info                        `thenDs` \ match_result ->
 774
 775     mkErrorAppDs pAT_ERROR_ID result_ty error_string    `thenDs` \ fail_expr ->
 776
 777     extractMatchResult match_result fail_expr           `thenDs` \ result_expr ->
 778     returnDs (new_vars, result_expr)
 779   where match_fun = case kind of
 780                       LambdaMatch | opt_WarnSimplePatterns -> matchExport
 781                                   | otherwise              -> match
 782                       _                                    -> matchExport
 783 \end{code}
 784
 785 %************************************************************************
 786 %*                                                                      *
 787 \subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern}
 788 %*                                                                      *
 789 %************************************************************************
 790
 791 @mkSimpleMatch@ is a wrapper for @match@ which deals with the
 792 situation where we want to match a single expression against a single
 793 pattern. It returns an expression.
 794
 795 \begin{code}
 796 matchSimply :: CoreExpr                 -- Scrutinee
 797             -> DsMatchKind              -- Match kind
 798             -> TypecheckedPat           -- Pattern it should match
 799             -> Type                     -- Type of result
 800             -> CoreExpr                 -- Return this if it matches
 801             -> CoreExpr                 -- Return this if it does
 802             -> DsM CoreExpr
 803
 804 matchSimply (Var var) kind pat result_ty result_expr fail_expr
 805   = getSrcLocDs                                 `thenDs` \ locn ->
 806     let
 807       ctx = DsMatchContext kind [pat] locn
 808       eqn_info = EqnInfo 1 ctx [pat] initial_match_result
 809     in
 810       match_fun [var] [eqn_info]                `thenDs` \ match_result ->
 811       extractMatchResult match_result fail_expr
 812   where
 813     initial_match_result = MatchResult CantFail result_ty (\ ignore -> result_expr)
 814     match_fun = if opt_WarnSimplePatterns
 815                   then matchExport
 816                   else match
 817
 818 matchSimply scrut_expr kind pat result_ty result_expr msg
 819   = newSysLocalDs (outPatType pat)                                      `thenDs` \ scrut_var ->
 820     matchSimply (Var scrut_var) kind pat result_ty result_expr msg      `thenDs` \ expr ->
 821     returnDs (Let (NonRec scrut_var scrut_expr) expr)
 822
 823
 824 extractMatchResult (MatchResult CantFail _ match_fn) fail_expr
 825   = returnDs (match_fn (error "It can't fail!"))
 826
 827 extractMatchResult (MatchResult CanFail result_ty match_fn) fail_expr
 828   = mkFailurePair result_ty             `thenDs` \ (fail_bind_fn, if_it_fails) ->
 829     returnDs (Let (fail_bind_fn fail_expr) (match_fn if_it_fails))
 830 \end{code}
 831
 832 %************************************************************************
 833 %*                                                                      *
 834 %*  flattenMatches : create a list of EquationInfo                      *
 835 %*                                                                      *
 836 %************************************************************************
 837 \subsection[flattenMatches]{@flattenMatches@: create @[EquationInfo]@}
 838
 839 This is actually local to @matchWrapper@.
 840
 841 \begin{code}
 842 flattenMatches
 843         :: DsMatchKind
 844         -> EqnNo
 845         -> [TypecheckedMatch]
 846         -> DsM [EquationInfo]
 847
 848 flattenMatches kind n [] = returnDs []
 849
 850 flattenMatches kind n (match : matches)
 851   = flatten_match [] n match    `thenDs` \ eqn_info ->
 852     flattenMatches kind (n+1) matches   `thenDs` \ eqn_infos ->
 853     returnDs (eqn_info : eqn_infos)
 854   where
 855     flatten_match :: [TypecheckedPat]           -- Reversed list of patterns encountered so far
 856                   -> EqnNo
 857                   -> TypecheckedMatch
 858                   -> DsM EquationInfo
 859
 860     flatten_match pats_so_far n (PatMatch pat match)
 861       = flatten_match (pat:pats_so_far) n match
 862
 863     flatten_match pats_so_far n (GRHSMatch (GRHSsAndBindsOut grhss binds ty))
 864       = dsBinds False{-don't auto-scc-} binds   `thenDs` \ core_binds ->
 865         dsGRHSs ty kind pats grhss              `thenDs` \ match_result ->
 866         getSrcLocDs                             `thenDs` \ locn ->
 867         returnDs (EqnInfo n (DsMatchContext kind pats locn) pats
 868                   (mkCoLetsMatchResult core_binds match_result))
 869       where
 870         pats = reverse pats_so_far      -- They've accumulated in reverse order
 871
 872     flatten_match pats_so_far n (SimpleMatch expr)
 873       = dsExpr expr             `thenDs` \ core_expr ->
 874         getSrcLocDs             `thenDs` \ locn ->
 875         returnDs (EqnInfo n (DsMatchContext kind pats locn) pats
 876                     (MatchResult CantFail (coreExprType core_expr)
 877                               (\ ignore -> core_expr)))
 878
 879          -- the matching can't fail, so we won't generate an error message.
 880         where
 881          pats = reverse pats_so_far     -- They've accumulated in reverse order
 882
 883 \end{code}
 884