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