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