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