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