ghc/compiler/deSugar/DsBinds.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[DsBinds]{Pattern-matching bindings (HsBinds and MonoBinds)}
   5
   6 Handles @HsBinds@; those at the top level require different handling,
   7 in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at
   8 lower levels it is preserved with @let@/@letrec@s).
   9
  10 \begin{code}
  11 #include "HsVersions.h"
  12
  13 module DsBinds ( dsBinds, dsInstBinds ) where
  14
  15 IMP_Ubiq()
  16 IMPORT_DELOOPER(DsLoop)         -- break dsExpr-ish loop
  17
  18 import HsSyn            -- lots of things
  19                         hiding ( collectBinders{-also in CoreSyn-} )
  20 import CoreSyn          -- lots of things
  21 import TcHsSyn          ( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr),
  22                           SYN_IE(TypecheckedBind), SYN_IE(TypecheckedMonoBinds),
  23                           SYN_IE(TypecheckedPat)
  24                         )
  25 import DsHsSyn          ( collectTypedBinders, collectTypedPatBinders )
  26
  27 import DsMonad
  28 import DsGRHSs          ( dsGuarded )
  29 import DsUtils
  30 import Match            ( matchWrapper )
  31
  32 import CmdLineOpts      ( opt_SccProfilingOn, opt_AutoSccsOnAllToplevs,
  33                           opt_AutoSccsOnExportedToplevs, opt_CompilingGhcInternals )
  34 import CostCentre       ( mkAutoCC, IsCafCC(..), mkAllDictsCC, preludeDictsCostCentre )
  35 import Id               ( idType, SYN_IE(DictVar), GenId )
  36 import ListSetOps       ( minusList, intersectLists )
  37 import Name             ( isExported )
  38 import PprType          ( GenType )
  39 import PprStyle         ( PprStyle(..) )
  40 import Pretty           ( ppShow )
  41 import Type             ( mkTyVarTys, mkForAllTys, splitSigmaTy,
  42                           tyVarsOfType, tyVarsOfTypes, isDictTy
  43                         )
  44 import TyVar            ( tyVarSetToList, GenTyVar{-instance Eq-} )
  45 import Util             ( isIn, panic{-, pprTrace ToDo:rm-} )
  46 --import PprCore--ToDo:rm
  47 --import PprType                ( GenTyVar ) --ToDo:rm
  48 --import Usage--ToDo:rm
  49 --import Unique--ToDo:rm
  50 \end{code}
  51
  52 %************************************************************************
  53 %*                                                                      *
  54 \subsection[toplevel-and-regular-DsBinds]{Regular and top-level @dsBinds@}
  55 %*                                                                      *
  56 %************************************************************************
  57
  58 Like @dsBinds@, @dsBind@ returns a @[CoreBinding]@, but it may be
  59 that some of the binders are of unboxed type.  This is sorted out when
  60 the caller wraps the bindings round an expression.
  61
  62 \begin{code}
  63 dsBinds :: TypecheckedHsBinds -> DsM [CoreBinding]
  64 \end{code}
  65
  66 All ``real'' bindings are expressed in terms of the
  67 @AbsBinds@ construct, which is a massively-complicated ``shorthand'',
  68 and its desugaring is the subject of section~9.1 in the static
  69 semantics paper.
  70
  71 (ToDo)  For:
  72 \begin{verbatim}
  73 AbsBinds [a1, ... ,aj]  -- type variables
  74          [d1, ... ,dk]  -- dict variables
  75          [(l1,g1), ..., (lm,gm)]        -- overloaded equivs [Id pairs] (later...)
  76          [db1=..., ..., dbn=...]        -- dict binds
  77          [vb1=..., ..., vbm=...]        -- val binds; note: vb_i = l_i
  78 \end{verbatim}
  79 we want to make, in the general case (non-Fozzie translation):
  80 \begin{verbatim}
  81    -- tupler-upper:
  82    tup a1...aj d1...dk =
  83       let <dict-binds>     in
  84       let(rec) <val-binds> in (vb1,...,vbm)    -- NB: == ... in (l1,...,lm)
  85
  86    -- a bunch of selectors:
  87    g1 a1...aj d1...dk = case (_tup a1...aj d1...dk) of (x1,x2,...,xm) -> x1
  88    ...
  89    gm a1...aj d1...dk = case (_tup a1...aj d1...dk) of (x1,x2,...,xm) -> xm
  90 \end{verbatim}
  91 But there are lots of special cases.
  92
  93
  94 %==============================================
  95 \subsubsection{Structure cases}
  96 %==============================================
  97
  98 \begin{code}
  99 dsBinds (BindWith _ _)     = panic "dsBinds:BindWith"
 100 dsBinds EmptyBinds         = returnDs []
 101 dsBinds (SingleBind bind) = dsBind [] [] id [] bind
 102
 103 dsBinds (ThenBinds  binds_1 binds_2)
 104   = andDs (++) (dsBinds binds_1) (dsBinds binds_2)
 105 \end{code}
 106
 107
 108 %==============================================
 109 \subsubsection{AbsBind case: no overloading}
 110 %==============================================
 111
 112 Special case: no overloading.
 113 \begin{verbatim}
 114         x1 = e1
 115         x2 = e2
 116 \end{verbatim}
 117 We abstract each wrt the type variables, giving
 118 \begin{verbatim}
 119         x1' = /\tyvars -> e1[x1' tyvars/x1, x2' tyvars/x2]
 120         x2' = /\tyvars -> e2[x1' tyvars/x1, x2' tyvars/x2]
 121 \end{verbatim}
 122 There are some complications.
 123
 124 (i) The @val_binds@ might mention variable not in @local_global_prs@.
 125 In this case we need to make up new polymorphic versions of them.
 126
 127 (ii) Exactly the same applies to any @inst_binds@ which may be
 128 present.  However, here we expect that mostly they will be simple constant
 129 definitions, which don't mention the type variables at all, so making them
 130 polymorphic is really overkill.  @dsInstBinds@ deals with this case.
 131
 132 \begin{code}
 133 dsBinds (AbsBinds tyvars [] local_global_prs inst_binds val_binds)
 134   = mapDs mk_poly_private_binder private_binders
 135                                         `thenDs` \ poly_private_binders ->
 136     let
 137         full_local_global_prs = (private_binders `zip` poly_private_binders)
 138                                 ++ local_global_prs
 139     in
 140     listDs [ mkSatTyApp global tyvar_tys `thenDs` \ app ->
 141              returnDs (local, app)
 142            | (local,global) <- full_local_global_prs
 143            ]                             `thenDs` \ env ->
 144
 145 --    pprTrace "AbsBinds1:" (ppr PprDebug env) $
 146
 147     extendEnvDs env (
 148
 149     dsInstBinds tyvars inst_binds       `thenDs` \ (inst_bind_pairs, inst_env) ->
 150     extendEnvDs inst_env                         (
 151
 152     dsBind tyvars [] (lookupId full_local_global_prs) inst_bind_pairs val_binds
 153     ))
 154   where
 155         -- "private_binders" is the list of binders in val_binds
 156         -- which don't appear in the local_global_prs list
 157         -- These only really show up in stuff produced from compiling
 158         -- class and instance declarations.
 159         -- We need to add suitable polymorphic versions of them to the
 160         -- local_global_prs.
 161     private_binders = binders `minusList` [local | (local,_) <- local_global_prs]
 162     binders         = collectTypedBinders val_binds
 163     mk_poly_private_binder id = newSysLocalDs (mkForAllTys tyvars (idType id))
 164
 165     tyvar_tys = mkTyVarTys tyvars
 166 \end{code}
 167
 168
 169 %==============================================
 170 \subsubsection{AbsBind case: overloading}
 171 %==============================================
 172
 173 If there is overloading we go for the general case.
 174
 175 We want the global identifiers to be abstracted wrt all types and
 176 dictionaries; and the local identifiers wrt the non-overloaded types.
 177 That is, we try to avoid global scoping of type abstraction. Example
 178
 179         f :: Eq a => a -> [(a,b)] -> b
 180         f = ...f...
 181
 182 Here, f is fully polymorphic in b.  So we generate
 183
 184         f ab d = let    ...dict defns...
 185                  in
 186                  letrec f' b = ...(f' b)...
 187                  in f' b
 188
 189 *Notice* that we don't clone type variables, and *do* make use of
 190 shadowing.  It is possible to do cloning, but it makes the code quite
 191 a bit more complicated, and the simplifier will clone it all anyway.
 192
 193 Why bother with this gloss?  Because it makes it more likely that
 194 the defn of f' can get floated out, notably if f gets specialised
 195 to a particular type for a.
 196
 197 \begin{code}
 198 dsBinds (AbsBinds all_tyvars dicts local_global_prs dict_binds val_binds)
 199   =     -- If there is any non-overloaded polymorphism, make new locals with
 200         -- appropriate polymorphism
 201     (if null non_overloaded_tyvars
 202      then
 203         -- No non-overloaded polymorphism, so stay with current envt
 204         returnDs (id, [], [])
 205      else
 206         -- Some local, non-overloaded polymorphism
 207         cloneTyVarsDs non_overloaded_tyvars     `thenDs` \ local_tyvars ->
 208
 209         mapDs mk_binder binders                 `thenDs` \ new_binders ->
 210         let
 211             old_new_pairs   = binders `zip` new_binders
 212         in
 213
 214         listDs  [ mkSatTyApp new non_ov_tyvar_tys `thenDs` \ app ->
 215                   returnDs (old, app)
 216                 | (old,new) <- old_new_pairs
 217                 ]                                       `thenDs` \ extra_env ->
 218         let
 219           local_binds = [NonRec old app | (old,app) <- extra_env, old `is_elem` locals]
 220           is_elem     = isIn "dsBinds"
 221         in
 222         returnDs (lookupId old_new_pairs, extra_env, local_binds)
 223     )
 224                 `thenDs` \ (binder_subst_fn, local_env, local_binds) ->
 225
 226 --    pprTrace "AbsBinds:all:" (ppAbove (ppr PprDebug local_binds) (ppr PprDebug local_env)) $
 227
 228     extendEnvDs local_env (
 229
 230       dsInstBinds non_overloaded_tyvars dict_binds      `thenDs` \ (inst_bind_pairs, inst_env) ->
 231
 232       extendEnvDs inst_env               (
 233
 234         dsBind non_overloaded_tyvars [] binder_subst_fn inst_bind_pairs val_binds
 235     ))                                                  `thenDs` \ core_binds ->
 236
 237     let
 238         tuple_rhs = mkCoLetsAny core_binds  (
 239                     mkCoLetsAny local_binds (
 240                     mkTupleExpr locals   ))
 241     in
 242     mkTupleBind all_tyvars dicts local_global_prs tuple_rhs  `thenDs` \ core_bind_prs ->
 243
 244     returnDs (mk_result_bind core_bind_prs)
 245   where
 246     locals = [local | (local,global) <- local_global_prs]
 247     non_ov_tyvar_tys = mkTyVarTys non_overloaded_tyvars
 248
 249     overloaded_tyvars     = tyVarsOfTypes (map idType dicts)
 250     non_overloaded_tyvars = all_tyvars `minusList` (tyVarSetToList{-????-} overloaded_tyvars)
 251
 252     binders      = collectTypedBinders val_binds
 253     mk_binder id = newSysLocalDs (mkForAllTys non_overloaded_tyvars (idType id))
 254
 255     is_rec_bind = case val_binds of
 256                         RecBind _    -> True
 257                         NonRecBind _ -> False
 258
 259         -- Recursion can still be needed if there are type signatures
 260     mk_result_bind prs | is_rec_bind = [Rec prs]
 261                        | otherwise   = [NonRec binder rhs | (binder,rhs) <- prs]
 262 \end{code}
 263
 264 @mkSatTyApp id tys@ constructs an expression whose value is (id tys).
 265 However, sometimes id takes more type args than are in tys, and the
 266 specialiser hates that, so we have to eta expand, to
 267 @(/\ a b -> id tys a b)@.
 268
 269 \begin{code}
 270 mkSatTyApp :: Id                -- Id to apply to the types
 271            -> [Type]            -- Types to apply it to
 272            -> DsM CoreExpr
 273
 274 mkSatTyApp id [] = returnDs (Var id)
 275
 276 mkSatTyApp id tys
 277   | null tvs
 278   = returnDs ty_app     -- Common case
 279   | otherwise
 280   = newTyVarsDs (drop (length tys) tvs) `thenDs` \ tyvars ->
 281     returnDs (mkTyLam tyvars (mkTyApp ty_app (mkTyVarTys tyvars)))
 282   where
 283     (tvs, theta, tau_ty) = splitSigmaTy (idType id)
 284     ty_app = mkTyApp (Var id) tys
 285 \end{code}
 286
 287 There are several places where we encounter ``inst binds,''
 288 @(Id, TypecheckedHsExpr)@ pairs.  Many of these are ``trivial'' binds
 289 (a var to a var or literal), which we want to substitute away; so we
 290 return both some desugared bindings {\em and} a substitution
 291 environment for the subbed-away ones.
 292
 293 These dictionary bindings are non-recursive, and ordered, so that
 294 later ones may mention earlier ones, but not vice versa.
 295
 296 \begin{code}
 297 dsInstBinds :: [TyVar]                          -- Abstract wrt these
 298             -> [(Id, TypecheckedHsExpr)]        -- From AbsBinds
 299             -> DsM ([(Id,CoreExpr)],    -- Non-trivial bindings
 300                     [(Id,CoreExpr)])    -- Trivial ones to be substituted away
 301
 302 do_nothing    = ([], []) -- out here to avoid dsInstBinds CAF (sigh)
 303 prel_dicts_cc = preludeDictsCostCentre False{-not dupd-} -- ditto
 304
 305 dsInstBinds tyvars [] = returnDs do_nothing
 306
 307 dsInstBinds tyvars ((inst, expr@(HsVar _)) : bs)
 308   = dsExpr expr                         `thenDs` \ rhs ->
 309     let -- Need to apply dsExpr to the variable in case it
 310         -- has a substitution in the current environment
 311         subst_item = (inst, rhs)
 312     in
 313     extendEnvDs [subst_item] (
 314         dsInstBinds tyvars bs
 315     )                                   `thenDs` \ (binds, subst_env) ->
 316     returnDs (binds, subst_item : subst_env)
 317
 318 dsInstBinds tyvars ((inst, expr@(HsLit _)) : bs)
 319   = dsExpr expr                         `thenDs` \ core_lit ->
 320     let
 321         subst_item = (inst, core_lit)
 322     in
 323     extendEnvDs [subst_item]     (
 324         dsInstBinds tyvars bs
 325     )                                   `thenDs` \ (binds, subst_env) ->
 326     returnDs (binds, subst_item : subst_env)
 327
 328 dsInstBinds tyvars ((inst, expr) : bs)
 329   | null abs_tyvars
 330   = dsExpr expr                 `thenDs` \ core_expr ->
 331     ds_dict_cc core_expr        `thenDs` \ dict_expr ->
 332     dsInstBinds tyvars bs       `thenDs` \ (core_rest, subst_env) ->
 333     returnDs ((inst, dict_expr) : core_rest, subst_env)
 334
 335   | otherwise
 336   =     -- Obscure case.
 337         -- The inst mentions the type vars wrt which we are abstracting,
 338         -- so we have to invent a new polymorphic version, and substitute
 339         -- appropriately.
 340         -- This can occur in, for example:
 341         --      leftPoll :: [FeedBack a] -> FeedBack a
 342         --      leftPoll xs = take poll xs
 343         -- Here there is an instance of take at the type of elts of xs,
 344         -- as well as the type of poll.
 345
 346     dsExpr expr                 `thenDs` \ core_expr ->
 347     ds_dict_cc core_expr        `thenDs` \ dict_expr ->
 348     newSysLocalDs poly_inst_ty  `thenDs` \ poly_inst_id ->
 349     let
 350         subst_item = (inst, mkTyApp (Var poly_inst_id) abs_tys)
 351     in
 352     extendEnvDs [subst_item] (
 353         dsInstBinds tyvars bs
 354     )                           `thenDs` \ (core_rest, subst_env) ->
 355     returnDs ((poly_inst_id, mkTyLam abs_tyvars dict_expr) : core_rest,
 356               subst_item : subst_env)
 357   where
 358     inst_ty    = idType inst
 359     abs_tyvars = tyVarSetToList{-???sigh-} (tyVarsOfType inst_ty) `intersectLists` tyvars
 360     abs_tys      = mkTyVarTys  abs_tyvars
 361     poly_inst_ty = mkForAllTys abs_tyvars inst_ty
 362
 363     ------------------------
 364     -- Wrap a desugared expression in `_scc_ "DICT" <expr>' if
 365     -- appropriate.  Uses "inst"'s type.
 366
 367        -- if profiling, wrap the dict in "_scc_ DICT <dict>":
 368     ds_dict_cc expr
 369       | not ( opt_SccProfilingOn || opt_AutoSccsOnAllToplevs)
 370             -- the latter is so that -unprof-auto-scc-all adds dict sccs
 371       || not (isDictTy inst_ty)
 372       = returnDs expr   -- that's easy: do nothing
 373
 374       | opt_CompilingGhcInternals
 375       = returnDs (SCC prel_dicts_cc expr)
 376
 377       | otherwise
 378       = getModuleAndGroupDs     `thenDs` \ (mod, grp) ->
 379
 380         -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
 381
 382         returnDs (SCC (mkAllDictsCC mod grp False) expr)
 383 \end{code}
 384
 385 %************************************************************************
 386 %*                                                                      *
 387 \subsection[dsBind]{Desugaring a @Bind@}
 388 %*                                                                      *
 389 %************************************************************************
 390
 391 Like @dsBinds@, @dsBind@ returns a @[CoreBinding]@, but it may be that
 392 some of the binders are of unboxed type.
 393
 394 For an explanation of the first three args, see @dsMonoBinds@.
 395
 396 \begin{code}
 397 dsBind  :: [TyVar] -> [DictVar]         -- Abstract wrt these
 398         -> (Id -> Id)                   -- Binder substitution
 399         -> [(Id,CoreExpr)]              -- Inst bindings already dealt with
 400         -> TypecheckedBind
 401         -> DsM [CoreBinding]
 402
 403 dsBind tyvars dicts binder_subst inst_bind_pairs EmptyBind
 404   = returnDs [NonRec binder rhs | (binder,rhs) <- inst_bind_pairs]
 405
 406 dsBind tyvars dicts binder_subst inst_bind_pairs (NonRecBind monobinds)
 407   = dsMonoBinds False tyvars dicts binder_subst monobinds   `thenDs` \ val_bind_pairs ->
 408     returnDs [NonRec binder rhs | (binder,rhs) <- inst_bind_pairs ++ val_bind_pairs]
 409
 410 dsBind tyvars dicts binder_subst inst_bind_pairs (RecBind monobinds)
 411   = dsMonoBinds True tyvars dicts binder_subst monobinds   `thenDs` \ val_bind_pairs ->
 412     returnDs [Rec (inst_bind_pairs ++ val_bind_pairs)]
 413 \end{code}
 414
 415
 416 %************************************************************************
 417 %*                                                                      *
 418 \subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
 419 %*                                                                      *
 420 %************************************************************************
 421
 422 @dsMonoBinds@ transforms @TypecheckedMonoBinds@ into @CoreBinds@.
 423 In addition to desugaring pattern matching, @dsMonoBinds@ takes
 424 a list of type variables and dicts, and adds abstractions for these
 425 to the front of every binding.  That requires that the
 426 binders be altered too (their type has changed,
 427 so @dsMonoBinds@ also takes a function which maps binders into binders.
 428 This mapping gives the binder the correct new type.
 429
 430 Remember, there's also a substitution in the monad which maps occurrences
 431 of these binders into applications of the new binder to suitable type variables
 432 and dictionaries.
 433
 434 \begin{code}
 435 dsMonoBinds :: Bool                     -- True <=> recursive binding group
 436             -> [TyVar] -> [DictVar]     -- Abstract wrt these
 437             -> (Id -> Id)               -- Binder substitution
 438             -> TypecheckedMonoBinds
 439             -> DsM [(Id,CoreExpr)]
 440 \end{code}
 441
 442
 443
 444 %==============================================
 445 \subsubsection{Structure cases}
 446 %==============================================
 447
 448 \begin{code}
 449 dsMonoBinds is_rec tyvars dicts binder_subst EmptyMonoBinds = returnDs []
 450
 451 dsMonoBinds is_rec tyvars dicts binder_subst (AndMonoBinds  binds_1 binds_2)
 452   = andDs (++) (dsMonoBinds is_rec tyvars dicts binder_subst binds_1)
 453                (dsMonoBinds is_rec tyvars dicts binder_subst binds_2)
 454 \end{code}
 455
 456
 457 %==============================================
 458 \subsubsection{Simple base cases: function and variable bindings}
 459 %==============================================
 460
 461 \begin{code}
 462 dsMonoBinds is_rec tyvars dicts binder_subst (CoreMonoBind var core_expr)
 463   = returnDs [(binder_subst var, mkLam tyvars dicts core_expr)]
 464
 465 dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind var expr)
 466   = dsExpr expr         `thenDs` \ core_expr ->
 467     returnDs [(binder_subst var, mkLam tyvars dicts core_expr)]
 468
 469 dsMonoBinds is_rec tyvars dicts binder_subst (FunMonoBind fun _ matches locn)
 470   = putSrcLocDs locn    $
 471     let
 472         new_fun      = binder_subst fun
 473         error_string = "function " ++ showForErr fun
 474     in
 475     matchWrapper (FunMatch fun) matches error_string    `thenDs` \ (args, body) ->
 476     returnDs [(new_fun,
 477                mkLam tyvars (dicts ++ args) body)]
 478
 479 dsMonoBinds is_rec tyvars dicts binder_subst (PatMonoBind (VarPat v) grhss_and_binds locn)
 480   = putSrcLocDs locn    $
 481     dsGuarded grhss_and_binds           `thenDs` \ body_expr ->
 482     returnDs [(binder_subst v, mkLam tyvars dicts body_expr)]
 483 \end{code}
 484
 485 %==============================================
 486 \subsubsection{The general base case}
 487 %==============================================
 488
 489 Now the general case of a pattern binding.  The monomorphism restriction
 490 should ensure that if there is a non-simple pattern binding in the
 491 group, then there is no overloading involved, so the dictionaries should
 492 be empty.  (Simple pattern bindings were handled above.)
 493 First, the paranoia check.
 494
 495 \begin{code}
 496 dsMonoBinds is_rec tyvars (_:_) binder_subst (PatMonoBind pat grhss_and_binds locn)
 497   = panic "Non-empty dict list in for pattern binding"
 498 \end{code}
 499
 500 We handle three cases for the binding
 501         pat = rhs
 502
 503 \begin{description}
 504 \item[pat has no binders.]
 505 Then all this is dead code and we return an empty binding.
 506
 507 \item[pat has exactly one binder, v.]
 508 Then we can transform to:
 509 \begin{verbatim}
 510         v' = /\ tyvars -> case rhs of { pat -> v }
 511 \end{verbatim}
 512 where \tr{v'} is gotten by looking up \tr{v} in the \tr{binder_subst}.
 513
 514 \item[pat has more than one binder.]
 515 Then we transform to:
 516 \begin{verbatim}
 517         t  = /\ tyvars -> case rhs of { pat -> (v1, ..., vn) }
 518
 519         vi = /\ tyvars -> case (t tyvars) of { (v1, ..., vn) -> vi }
 520 \end{verbatim}
 521 \end{description}
 522
 523 \begin{code}
 524 dsMonoBinds is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_binds locn)
 525   = putSrcLocDs locn $
 526
 527     dsGuarded grhss_and_binds                   `thenDs` \ body_expr ->
 528
 529 {- KILLED by Sansom. 95/05
 530         -- make *sure* there are no primitive types in the pattern
 531     if any_con_w_prim_arg pat then
 532         error ( "ERROR: Pattern-bindings cannot involve unboxed/primitive types!\n\t"
 533              ++ (ppShow 80 (ppr PprForUser pat)) ++ "\n"
 534              ++ "(We apologise for not reporting this more `cleanly')\n" )
 535
 536         -- Check whether the pattern already is a simple tuple; if so,
 537         -- we can just use the rhs directly
 538     else
 539 -}
 540 --  pprTrace "dsMonoBinds:PatMonoBind:" (ppr PprDebug body_expr) $
 541
 542     mkSelectorBinds tyvars pat
 543         [(binder, binder_subst binder) | binder <- pat_binders]
 544         body_expr
 545   where
 546     pat_binders = collectTypedPatBinders pat
 547         -- NB For a simple tuple pattern, these binders
 548         -- will appear in the right order!
 549 \end{code}
 550
 551 Wild-card patterns could be made acceptable here, but it involves some
 552 extra work to benefit only rather unusual constructs like
 553 \begin{verbatim}
 554         let (_,a,b) = ... in ...
 555 \end{verbatim}
 556 Better to extend the whole thing for any irrefutable constructor, at least.