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          ( TypecheckedHsBinds(..), TypecheckedHsExpr(..),
  22                           TypecheckedBind(..), TypecheckedMonoBinds(..),
  23                           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_CompilingPrelude )
  33 import CostCentre       ( mkAllDictsCC, preludeDictsCostCentre )
  34 import Id               ( idType, DictVar(..), GenId )
  35 import ListSetOps       ( minusList, intersectLists )
  36 import PprType          ( GenType )
  37 import PprStyle         ( PprStyle(..) )
  38 import Pretty           ( ppShow )
  39 import Type             ( mkTyVarTys, mkForAllTys, splitSigmaTy,
  40                           tyVarsOfType, tyVarsOfTypes
  41                         )
  42 import TyVar            ( tyVarSetToList, GenTyVar{-instance Eq-} )
  43 import Util             ( isIn, panic, pprTrace{-ToDo:rm-} )
  44 import PprCore--ToDo:rm
  45 import PprType          ( GenTyVar ) --ToDo:rm
  46 import Usage--ToDo:rm
  47 import Unique--ToDo:rm
  48
  49 isDictTy = panic "DsBinds.isDictTy"
  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 [ NonRec binder rhs | (binder,rhs) <- 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 \end{code}
 255
 256 @mkSatTyApp id tys@ constructs an expression whose value is (id tys).
 257 However, sometimes id takes more type args than are in tys, and the
 258 specialiser hates that, so we have to eta expand, to
 259 @(/\ a b -> id tys a b)@.
 260
 261 \begin{code}
 262 mkSatTyApp :: Id                -- Id to apply to the types
 263            -> [Type]            -- Types to apply it to
 264            -> DsM CoreExpr
 265
 266 mkSatTyApp id [] = returnDs (Var id)
 267
 268 mkSatTyApp id tys
 269   | null tvs
 270   = returnDs ty_app     -- Common case
 271   | otherwise
 272   = newTyVarsDs (drop (length tys) tvs) `thenDs` \ tyvars ->
 273     returnDs (mkTyLam tyvars (mkTyApp ty_app (mkTyVarTys tyvars)))
 274   where
 275     (tvs, theta, tau_ty) = splitSigmaTy (idType id)
 276     ty_app = mkTyApp (Var id) tys
 277 \end{code}
 278
 279 There are several places where we encounter ``inst binds,''
 280 @(Id, TypecheckedHsExpr)@ pairs.  Many of these are ``trivial'' binds
 281 (a var to a var or literal), which we want to substitute away; so we
 282 return both some desugared bindings {\em and} a substitution
 283 environment for the subbed-away ones.
 284
 285 These dictionary bindings are non-recursive, and ordered, so that
 286 later ones may mention earlier ones, but not vice versa.
 287
 288 \begin{code}
 289 dsInstBinds :: [TyVar]                          -- Abstract wrt these
 290             -> [(Id, TypecheckedHsExpr)]        -- From AbsBinds
 291             -> DsM ([(Id,CoreExpr)],    -- Non-trivial bindings
 292                     [(Id,CoreExpr)])    -- Trivial ones to be substituted away
 293
 294 do_nothing    = ([], []) -- out here to avoid dsInstBinds CAF (sigh)
 295 prel_dicts_cc = preludeDictsCostCentre False{-not dupd-} -- ditto
 296
 297 dsInstBinds tyvars [] = returnDs do_nothing
 298
 299 dsInstBinds tyvars ((inst, expr@(HsVar _)) : bs)
 300   = dsExpr expr                         `thenDs` \ rhs ->
 301     let -- Need to apply dsExpr to the variable in case it
 302         -- has a substitution in the current environment
 303         subst_item = (inst, rhs)
 304     in
 305     extendEnvDs [subst_item] (
 306         dsInstBinds tyvars bs
 307     )                                   `thenDs` \ (binds, subst_env) ->
 308     returnDs (binds, subst_item : subst_env)
 309
 310 dsInstBinds tyvars ((inst, expr@(HsLit _)) : bs)
 311   = dsExpr expr                         `thenDs` \ core_lit ->
 312     let
 313         subst_item = (inst, core_lit)
 314     in
 315     extendEnvDs [subst_item]     (
 316         dsInstBinds tyvars bs
 317     )                                   `thenDs` \ (binds, subst_env) ->
 318     returnDs (binds, subst_item : subst_env)
 319
 320 dsInstBinds tyvars ((inst, expr) : bs)
 321   | null abs_tyvars
 322   = dsExpr expr                 `thenDs` \ core_expr ->
 323     ds_dict_cc core_expr        `thenDs` \ dict_expr ->
 324     dsInstBinds tyvars bs       `thenDs` \ (core_rest, subst_env) ->
 325     returnDs ((inst, dict_expr) : core_rest, subst_env)
 326
 327   | otherwise
 328   =     -- Obscure case.
 329         -- The inst mentions the type vars wrt which we are abstracting,
 330         -- so we have to invent a new polymorphic version, and substitute
 331         -- appropriately.
 332         -- This can occur in, for example:
 333         --      leftPoll :: [FeedBack a] -> FeedBack a
 334         --      leftPoll xs = take poll xs
 335         -- Here there is an instance of take at the type of elts of xs,
 336         -- as well as the type of poll.
 337
 338     dsExpr expr                 `thenDs` \ core_expr ->
 339     ds_dict_cc core_expr        `thenDs` \ dict_expr ->
 340     newSysLocalDs poly_inst_ty  `thenDs` \ poly_inst_id ->
 341     let
 342         subst_item = (inst, mkTyApp (Var poly_inst_id) abs_tys)
 343     in
 344     extendEnvDs [subst_item] (
 345         dsInstBinds tyvars bs
 346     )                           `thenDs` \ (core_rest, subst_env) ->
 347     returnDs ((poly_inst_id, mkTyLam abs_tyvars dict_expr) : core_rest,
 348               subst_item : subst_env)
 349   where
 350     inst_ty    = idType inst
 351     abs_tyvars = tyVarSetToList{-???sigh-} (tyVarsOfType inst_ty) `intersectLists` tyvars
 352     abs_tys      = mkTyVarTys  abs_tyvars
 353     poly_inst_ty = mkForAllTys abs_tyvars inst_ty
 354
 355     ------------------------
 356     -- Wrap a desugared expression in `_scc_ "DICT" <expr>' if
 357     -- appropriate.  Uses "inst"'s type.
 358
 359        -- if profiling, wrap the dict in "_scc_ DICT <dict>":
 360     ds_dict_cc expr
 361       | not opt_SccProfilingOn ||
 362         not (isDictTy inst_ty)
 363       = returnDs expr   -- that's easy: do nothing
 364
 365       | opt_CompilingPrelude
 366       = returnDs (SCC prel_dicts_cc expr)
 367
 368       | otherwise
 369       = getModuleAndGroupDs     `thenDs` \ (mod_name, grp_name) ->
 370             -- ToDo: do -dicts-all flag (mark dict things
 371             -- with individual CCs)
 372         let
 373                 dict_cc = mkAllDictsCC mod_name grp_name False{-not dupd-}
 374         in
 375         returnDs (SCC dict_cc expr)
 376 \end{code}
 377
 378 %************************************************************************
 379 %*                                                                      *
 380 \subsection[dsBind]{Desugaring a @Bind@}
 381 %*                                                                      *
 382 %************************************************************************
 383
 384 Like @dsBinds@, @dsBind@ returns a @[CoreBinding]@, but it may be that
 385 some of the binders are of unboxed type.
 386
 387 For an explanation of the first three args, see @dsMonoBinds@.
 388
 389 \begin{code}
 390 dsBind  :: [TyVar] -> [DictVar]         -- Abstract wrt these
 391         -> (Id -> Id)                   -- Binder substitution
 392         -> [(Id,CoreExpr)]              -- Inst bindings already dealt with
 393         -> TypecheckedBind
 394         -> DsM [CoreBinding]
 395
 396 dsBind tyvars dicts binder_subst inst_bind_pairs EmptyBind
 397   = returnDs [NonRec binder rhs | (binder,rhs) <- inst_bind_pairs]
 398
 399 dsBind tyvars dicts binder_subst inst_bind_pairs (NonRecBind monobinds)
 400   = dsMonoBinds False tyvars dicts binder_subst monobinds   `thenDs` ( \ val_bind_pairs ->
 401     returnDs [NonRec binder rhs | (binder,rhs) <- inst_bind_pairs ++ val_bind_pairs] )
 402
 403 dsBind tyvars dicts binder_subst inst_bind_pairs (RecBind monobinds)
 404   = dsMonoBinds True tyvars dicts binder_subst monobinds   `thenDs` ( \ val_bind_pairs ->
 405     returnDs [Rec (inst_bind_pairs ++ val_bind_pairs)] )
 406 \end{code}
 407
 408
 409 %************************************************************************
 410 %*                                                                      *
 411 \subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
 412 %*                                                                      *
 413 %************************************************************************
 414
 415 @dsMonoBinds@ transforms @TypecheckedMonoBinds@ into @CoreBinds@.
 416 In addition to desugaring pattern matching, @dsMonoBinds@ takes
 417 a list of type variables and dicts, and adds abstractions for these
 418 to the front of every binding.  That requires that the
 419 binders be altered too (their type has changed,
 420 so @dsMonoBinds@ also takes a function which maps binders into binders.
 421 This mapping gives the binder the correct new type.
 422
 423 Remember, there's also a substitution in the monad which maps occurrences
 424 of these binders into applications of the new binder to suitable type variables
 425 and dictionaries.
 426
 427 \begin{code}
 428 dsMonoBinds :: Bool                     -- True <=> recursive binding group
 429             -> [TyVar] -> [DictVar]     -- Abstract wrt these
 430             -> (Id -> Id)               -- Binder substitution
 431             -> TypecheckedMonoBinds
 432             -> DsM [(Id,CoreExpr)]
 433 \end{code}
 434
 435
 436
 437 %==============================================
 438 \subsubsection{Structure cases}
 439 %==============================================
 440
 441 \begin{code}
 442 dsMonoBinds is_rec tyvars dicts binder_subst EmptyMonoBinds = returnDs []
 443
 444 dsMonoBinds is_rec tyvars dicts binder_subst (AndMonoBinds  binds_1 binds_2)
 445   = andDs (++) (dsMonoBinds is_rec tyvars dicts binder_subst binds_1)
 446                (dsMonoBinds is_rec tyvars dicts binder_subst binds_2)
 447 \end{code}
 448
 449
 450 %==============================================
 451 \subsubsection{Simple base cases: function and variable bindings}
 452 %==============================================
 453
 454 For the simplest bindings, we just heave them in the substitution env:
 455
 456 \begin{code}
 457 {-      THESE TWO ARE PLAIN WRONG.
 458         The extendEnvDs only scopes over the nested call!
 459         Let the simplifier do this.
 460
 461 dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind was_var (HsVar new_var))
 462   | not (is_rec || isExported was_var)
 463   = extendEnvDs [(was_var, Var new_var)] (
 464     returnDs [] )
 465
 466 dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind was_var expr@(Lit _))
 467   | not (isExported was_var)
 468   = dsExpr expr                 `thenDs` ( \ core_lit ->
 469     extendEnvDs [(was_var, core_lit)]    (
 470     returnDs [] ))
 471 -}
 472
 473 dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind var expr)
 474   = dsExpr expr         `thenDs` \ core_expr ->
 475     returnDs [(binder_subst var, mkLam tyvars dicts core_expr)]
 476 \end{code}
 477
 478 \begin{code}
 479 dsMonoBinds is_rec tyvars dicts binder_subst (FunMonoBind fun _ matches locn)
 480   = putSrcLocDs locn    $
 481     let
 482         new_fun      = binder_subst fun
 483         error_string = "function " ++ showForErr fun
 484     in
 485     matchWrapper (FunMatch fun) matches error_string    `thenDs` \ (args, body) ->
 486     returnDs [(new_fun,
 487                mkLam tyvars (dicts ++ args) body)]
 488
 489 dsMonoBinds is_rec tyvars dicts binder_subst (PatMonoBind (VarPat v) grhss_and_binds locn)
 490   = putSrcLocDs locn    $
 491     dsGuarded grhss_and_binds           `thenDs` \ body_expr ->
 492     returnDs [(binder_subst v, mkLam tyvars dicts body_expr)]
 493 \end{code}
 494
 495 %==============================================
 496 \subsubsection{The general base case}
 497 %==============================================
 498
 499 Now the general case of a pattern binding.  The monomorphism restriction
 500 should ensure that if there is a non-simple pattern binding in the
 501 group, then there is no overloading involved, so the dictionaries should
 502 be empty.  (Simple pattern bindings were handled above.)
 503 First, the paranoia check.
 504
 505 \begin{code}
 506 dsMonoBinds is_rec tyvars (_:_) binder_subst (PatMonoBind pat grhss_and_binds locn)
 507   = panic "Non-empty dict list in for pattern binding"
 508 \end{code}
 509
 510 We handle three cases for the binding
 511         pat = rhs
 512
 513 \begin{description}
 514 \item[pat has no binders.]
 515 Then all this is dead code and we return an empty binding.
 516
 517 \item[pat has exactly one binder, v.]
 518 Then we can transform to:
 519 \begin{verbatim}
 520         v' = /\ tyvars -> case rhs of { pat -> v }
 521 \end{verbatim}
 522 where \tr{v'} is gotten by looking up \tr{v} in the \tr{binder_subst}.
 523
 524 \item[pat has more than one binder.]
 525 Then we transform to:
 526 \begin{verbatim}
 527         t  = /\ tyvars -> case rhs of { pat -> (v1, ..., vn) }
 528
 529         vi = /\ tyvars -> case (t tyvars) of { (v1, ..., vn) -> vi }
 530 \end{verbatim}
 531 \end{description}
 532
 533 \begin{code}
 534 dsMonoBinds is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_binds locn)
 535   = putSrcLocDs locn $
 536
 537     dsGuarded grhss_and_binds           `thenDs` \ body_expr ->
 538
 539 {- KILLED by Sansom. 95/05
 540         -- make *sure* there are no primitive types in the pattern
 541     if any_con_w_prim_arg pat then
 542         error ( "ERROR: Pattern-bindings cannot involve unboxed/primitive types!\n\t"
 543              ++ (ppShow 80 (ppr PprForUser pat)) ++ "\n"
 544              ++ "(We apologise for not reporting this more `cleanly')\n" )
 545
 546         -- Check whether the pattern already is a simple tuple; if so,
 547         -- we can just use the rhs directly
 548     else
 549 -}
 550 --  pprTrace "dsMonoBinds:PatMonoBind:" (ppr PprDebug body_expr) $
 551
 552     mkSelectorBinds tyvars pat
 553         [(binder, binder_subst binder) | binder <- pat_binders]
 554         body_expr
 555   where
 556     pat_binders = collectTypedPatBinders pat
 557         -- NB For a simple tuple pattern, these binders
 558         -- will appear in the right order!
 559 \end{code}
 560
 561 Wild-card patterns could be made acceptable here, but it involves some
 562 extra work to benefit only rather unusual constructs like
 563 \begin{verbatim}
 564         let (_,a,b) = ... in ...
 565 \end{verbatim}
 566 Better to extend the whole thing for any irrefutable constructor, at least.
 567
 568