ghc/compiler/deSugar/DsBinds.lhs

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