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