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