ghc/compiler/deSugar/DsArrows.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[DsArrows]{Desugaring arrow commands}
   5
   6 \begin{code}
   7 module DsArrows ( dsProcExpr ) where
   8
   9 #include "HsVersions.h"
  10
  11 import Match            ( matchSimply )
  12 import DsUtils          ( mkErrorAppDs,
  13                           mkCoreTupTy, mkCoreTup, selectMatchVarL,
  14                           mkTupleCase, mkBigCoreTup, mkTupleType,
  15                           mkTupleExpr, mkTupleSelector,
  16                           dsReboundNames, lookupReboundName )
  17 import DsMonad
  18
  19 import HsSyn
  20 import TcHsSyn          ( hsPatType )
  21
  22 -- NB: The desugarer, which straddles the source and Core worlds, sometimes
  23 --     needs to see source types (newtypes etc), and sometimes not
  24 --     So WATCH OUT; check each use of split*Ty functions.
  25 -- Sigh.  This is a pain.
  26
  27 import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLet )
  28
  29 import TcType           ( Type, tcSplitAppTy )
  30 import Type             ( mkTyConApp )
  31 import CoreSyn
  32 import CoreFVs          ( exprFreeVars )
  33 import CoreUtils        ( mkIfThenElse, bindNonRec, exprType )
  34
  35 import Id               ( Id, idType )
  36 import Name             ( Name )
  37 import PrelInfo         ( pAT_ERROR_ID )
  38 import DataCon          ( dataConWrapId )
  39 import TysWiredIn       ( tupleCon )
  40 import BasicTypes       ( Boxity(..) )
  41 import PrelNames        ( eitherTyConName, leftDataConName, rightDataConName,
  42                           arrAName, composeAName, firstAName,
  43                           appAName, choiceAName, loopAName )
  44 import Util             ( mapAccumL )
  45 import Outputable
  46
  47 import HsPat            ( collectPatBinders, collectPatsBinders )
  48 import VarSet           ( IdSet, mkVarSet, varSetElems,
  49                           intersectVarSet, minusVarSet, extendVarSetList,
  50                           unionVarSet, unionVarSets, elemVarSet )
  51 import SrcLoc           ( Located(..), unLoc, noLoc, getLoc )
  52 \end{code}
  53
  54 \begin{code}
  55 data DsCmdEnv = DsCmdEnv {
  56         meth_binds :: [CoreBind],
  57         arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr
  58     }
  59
  60 mkCmdEnv :: ReboundNames Id -> DsM DsCmdEnv
  61 mkCmdEnv ids
  62   = dsReboundNames ids                  `thenDs` \ (meth_binds, ds_meths) ->
  63     return $ DsCmdEnv {
  64                 meth_binds = meth_binds,
  65                 arr_id     = lookupReboundName ds_meths arrAName,
  66                 compose_id = lookupReboundName ds_meths composeAName,
  67                 first_id   = lookupReboundName ds_meths firstAName,
  68                 app_id     = lookupReboundName ds_meths appAName,
  69                 choice_id  = lookupReboundName ds_meths choiceAName,
  70                 loop_id    = lookupReboundName ds_meths loopAName
  71             }
  72
  73 bindCmdEnv :: DsCmdEnv -> CoreExpr -> CoreExpr
  74 bindCmdEnv ids body = foldr Let body (meth_binds ids)
  75
  76 -- arr :: forall b c. (b -> c) -> a b c
  77 do_arr :: DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr
  78 do_arr ids b_ty c_ty f = mkApps (arr_id ids) [Type b_ty, Type c_ty, f]
  79
  80 -- (>>>) :: forall b c d. a b c -> a c d -> a b d
  81 do_compose :: DsCmdEnv -> Type -> Type -> Type ->
  82                 CoreExpr -> CoreExpr -> CoreExpr
  83 do_compose ids b_ty c_ty d_ty f g
  84   = mkApps (compose_id ids) [Type b_ty, Type c_ty, Type d_ty, f, g]
  85
  86 -- first :: forall b c d. a b c -> a (b,d) (c,d)
  87 do_first :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr
  88 do_first ids b_ty c_ty d_ty f
  89   = mkApps (first_id ids) [Type b_ty, Type c_ty, Type d_ty, f]
  90
  91 -- app :: forall b c. a (a b c, b) c
  92 do_app :: DsCmdEnv -> Type -> Type -> CoreExpr
  93 do_app ids b_ty c_ty = mkApps (app_id ids) [Type b_ty, Type c_ty]
  94
  95 -- (|||) :: forall b d c. a b d -> a c d -> a (Either b c) d
  96 -- note the swapping of d and c
  97 do_choice :: DsCmdEnv -> Type -> Type -> Type ->
  98                 CoreExpr -> CoreExpr -> CoreExpr
  99 do_choice ids b_ty c_ty d_ty f g
 100   = mkApps (choice_id ids) [Type b_ty, Type d_ty, Type c_ty, f, g]
 101
 102 -- loop :: forall b d c. a (b,d) (c,d) -> a b c
 103 -- note the swapping of d and c
 104 do_loop :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr
 105 do_loop ids b_ty c_ty d_ty f
 106   = mkApps (loop_id ids) [Type b_ty, Type d_ty, Type c_ty, f]
 107
 108 -- map_arrow (f :: b -> c) (g :: a c d) = arr f >>> g :: a b d
 109 do_map_arrow :: DsCmdEnv -> Type -> Type -> Type ->
 110                 CoreExpr -> CoreExpr -> CoreExpr
 111 do_map_arrow ids b_ty c_ty d_ty f c
 112   = do_compose ids b_ty c_ty d_ty (do_arr ids b_ty c_ty f) c
 113
 114 mkFailExpr :: HsMatchContext Id -> Type -> DsM CoreExpr
 115 mkFailExpr ctxt ty
 116   = mkErrorAppDs pAT_ERROR_ID ty (matchContextErrString ctxt)
 117
 118 -- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> b
 119 mkSndExpr :: Type -> Type -> DsM CoreExpr
 120 mkSndExpr a_ty b_ty
 121   = newSysLocalDs a_ty                  `thenDs` \ a_var ->
 122     newSysLocalDs b_ty                  `thenDs` \ b_var ->
 123     newSysLocalDs (mkCorePairTy a_ty b_ty)      `thenDs` \ pair_var ->
 124     returnDs (Lam pair_var
 125                   (coreCasePair pair_var a_var b_var (Var b_var)))
 126 \end{code}
 127
 128 Build case analysis of a tuple.  This cannot be done in the DsM monad,
 129 because the list of variables is typically not yet defined.
 130
 131 \begin{code}
 132 -- coreCaseTuple [u1..] v [x1..xn] body
 133 --      = case v of v { (x1, .., xn) -> body }
 134 -- But the matching may be nested if the tuple is very big
 135
 136 coreCaseTuple :: UniqSupply -> Id -> [Id] -> CoreExpr -> CoreExpr
 137 coreCaseTuple uniqs scrut_var vars body
 138   = mkTupleCase uniqs vars body scrut_var (Var scrut_var)
 139
 140 coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr
 141 coreCasePair scrut_var var1 var2 body
 142   = Case (Var scrut_var) scrut_var
 143          [(DataAlt (tupleCon Boxed 2), [var1, var2], body)]
 144 \end{code}
 145
 146 \begin{code}
 147 mkCorePairTy :: Type -> Type -> Type
 148 mkCorePairTy t1 t2 = mkCoreTupTy [t1, t2]
 149
 150 mkCorePairExpr :: CoreExpr -> CoreExpr -> CoreExpr
 151 mkCorePairExpr e1 e2 = mkCoreTup [e1, e2]
 152 \end{code}
 153
 154 The input is divided into a local environment, which is a flat tuple
 155 (unless it's too big), and a stack, each element of which is paired
 156 with the stack in turn.  In general, the input has the form
 157
 158         (...((x1,...,xn),s1),...sk)
 159
 160 where xi are the environment values, and si the ones on the stack,
 161 with s1 being the "top", the first one to be matched with a lambda.
 162
 163 \begin{code}
 164 envStackType :: [Id] -> [Type] -> Type
 165 envStackType ids stack_tys = foldl mkCorePairTy (mkTupleType ids) stack_tys
 166
 167 ----------------------------------------------
 168 --              buildEnvStack
 169 --
 170 --      (...((x1,...,xn),s1),...sk)
 171
 172 buildEnvStack :: [Id] -> [Id] -> CoreExpr
 173 buildEnvStack env_ids stack_ids
 174   = foldl mkCorePairExpr (mkTupleExpr env_ids) (map Var stack_ids)
 175
 176 ----------------------------------------------
 177 --              matchEnvStack
 178 --
 179 --      \ (...((x1,...,xn),s1),...sk) -> e
 180 --      =>
 181 --      \ zk ->
 182 --      case zk of (zk-1,sk) ->
 183 --      ...
 184 --      case z1 of (z0,s1) ->
 185 --      case z0 of (x1,...,xn) ->
 186 --      e
 187
 188 matchEnvStack   :: [Id]         -- x1..xn
 189                 -> [Id]         -- s1..sk
 190                 -> CoreExpr     -- e
 191                 -> DsM CoreExpr
 192 matchEnvStack env_ids stack_ids body
 193   = newUniqueSupply                     `thenDs` \ uniqs ->
 194     newSysLocalDs (mkTupleType env_ids) `thenDs` \ tup_var ->
 195     matchVarStack tup_var stack_ids
 196                   (coreCaseTuple uniqs tup_var env_ids body)
 197
 198
 199 ----------------------------------------------
 200 --              matchVarStack
 201 --
 202 --      \ (...(z0,s1),...sk) -> e
 203 --      =>
 204 --      \ zk ->
 205 --      case zk of (zk-1,sk) ->
 206 --      ...
 207 --      case z1 of (z0,s1) ->
 208 --      e
 209
 210 matchVarStack :: Id             -- z0
 211               -> [Id]           -- s1..sk
 212               -> CoreExpr       -- e
 213               -> DsM CoreExpr
 214 matchVarStack env_id [] body
 215   = returnDs (Lam env_id body)
 216 matchVarStack env_id (stack_id:stack_ids) body
 217   = newSysLocalDs (mkCorePairTy (idType env_id) (idType stack_id))
 218                                         `thenDs` \ pair_id ->
 219     matchVarStack pair_id stack_ids
 220                   (coreCasePair pair_id env_id stack_id body)
 221 \end{code}
 222
 223 \begin{code}
 224 mkHsTupleExpr :: [HsExpr Id] -> HsExpr Id
 225 mkHsTupleExpr [e] = e
 226 mkHsTupleExpr es = ExplicitTuple (map noLoc es) Boxed
 227
 228 mkHsPairExpr :: HsExpr Id -> HsExpr Id -> HsExpr Id
 229 mkHsPairExpr e1 e2 = mkHsTupleExpr [e1, e2]
 230
 231 mkHsEnvStackExpr :: [Id] -> [Id] -> HsExpr Id
 232 mkHsEnvStackExpr env_ids stack_ids
 233   = foldl mkHsPairExpr (mkHsTupleExpr (map HsVar env_ids)) (map HsVar stack_ids)
 234 \end{code}
 235
 236 Translation of arrow abstraction
 237
 238 \begin{code}
 239
 240 --      A | xs |- c :: [] t'        ---> c'
 241 --      --------------------------
 242 --      A |- proc p -> c :: a t t'  ---> arr (\ p -> (xs)) >>> c'
 243 --
 244 --              where (xs) is the tuple of variables bound by p
 245
 246 dsProcExpr
 247         :: LPat Id
 248         -> LHsCmdTop Id
 249         -> DsM CoreExpr
 250 dsProcExpr pat (L _ (HsCmdTop cmd [] cmd_ty ids))
 251   = mkCmdEnv ids                        `thenDs` \ meth_ids ->
 252     let
 253         locals = mkVarSet (collectPatBinders pat)
 254     in
 255     dsfixCmd meth_ids locals [] cmd_ty cmd
 256                                 `thenDs` \ (core_cmd, free_vars, env_ids) ->
 257     let
 258         env_ty = mkTupleType env_ids
 259     in
 260     mkFailExpr ProcExpr env_ty          `thenDs` \ fail_expr ->
 261     selectMatchVarL pat                 `thenDs` \ var ->
 262     matchSimply (Var var) ProcExpr pat (mkTupleExpr env_ids) fail_expr
 263                                         `thenDs` \ match_code ->
 264     let
 265         pat_ty = hsPatType pat
 266         proc_code = do_map_arrow meth_ids pat_ty env_ty cmd_ty
 267                 (Lam var match_code)
 268                 core_cmd
 269     in
 270     returnDs (bindCmdEnv meth_ids proc_code)
 271 \end{code}
 272
 273 Translation of command judgements of the form
 274
 275         A | xs |- c :: [ts] t
 276
 277 \begin{code}
 278 dsLCmd ids local_vars env_ids stack res_ty cmd
 279   = dsCmd ids local_vars env_ids stack res_ty (unLoc cmd)
 280
 281 dsCmd   :: DsCmdEnv             -- arrow combinators
 282         -> IdSet                -- set of local vars available to this command
 283         -> [Id]                 -- list of vars in the input to this command
 284                                 -- This is typically fed back,
 285                                 -- so don't pull on it too early
 286         -> [Type]               -- type of the stack
 287         -> Type                 -- return type of the command
 288         -> HsCmd Id             -- command to desugar
 289         -> DsM (CoreExpr,       -- desugared expression
 290                 IdSet)          -- set of local vars that occur free
 291
 292 --      A |- f :: a t t'
 293 --      A, xs |- arg :: t
 294 --      ---------------------------
 295 --      A | xs |- f -< arg :: [] t'     ---> arr (\ (xs) -> arg) >>> f
 296
 297 dsCmd ids local_vars env_ids [] res_ty
 298         (HsArrApp arrow arg arrow_ty HsFirstOrderApp _)
 299   = let
 300         (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
 301         (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
 302         env_ty = mkTupleType env_ids
 303     in
 304     dsLExpr arrow                       `thenDs` \ core_arrow ->
 305     dsLExpr arg                         `thenDs` \ core_arg ->
 306     matchEnvStack env_ids [] core_arg   `thenDs` \ core_make_arg ->
 307     returnDs (do_map_arrow ids env_ty arg_ty res_ty
 308                 core_make_arg
 309                 core_arrow,
 310               exprFreeVars core_arg `intersectVarSet` local_vars)
 311
 312 --      A, xs |- f :: a t t'
 313 --      A, xs |- arg :: t
 314 --      ---------------------------
 315 --      A | xs |- f -<< arg :: [] t'    ---> arr (\ (xs) -> (f,arg)) >>> app
 316
 317 dsCmd ids local_vars env_ids [] res_ty
 318         (HsArrApp arrow arg arrow_ty HsHigherOrderApp _)
 319   = let
 320         (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
 321         (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
 322         env_ty = mkTupleType env_ids
 323     in
 324     dsLExpr arrow                       `thenDs` \ core_arrow ->
 325     dsLExpr arg                         `thenDs` \ core_arg ->
 326     matchEnvStack env_ids [] (mkCorePairExpr core_arrow core_arg)
 327                                         `thenDs` \ core_make_pair ->
 328     returnDs (do_map_arrow ids env_ty (mkCorePairTy arrow_ty arg_ty) res_ty
 329                 core_make_pair
 330                 (do_app ids arg_ty res_ty),
 331               (exprFreeVars core_arrow `unionVarSet` exprFreeVars core_arg)
 332                 `intersectVarSet` local_vars)
 333
 334 --      A | ys |- c :: [t:ts] t'
 335 --      A, xs  |- e :: t
 336 --      ------------------------
 337 --      A | xs |- c e :: [ts] t'
 338 --
 339 --              ---> arr (\ ((xs)*ts) -> let z = e in (((ys),z)*ts)) >>> c
 340
 341 dsCmd ids local_vars env_ids stack res_ty (HsApp cmd arg)
 342   = dsLExpr arg                 `thenDs` \ core_arg ->
 343     let
 344         arg_ty = exprType core_arg
 345         stack' = arg_ty:stack
 346     in
 347     dsfixCmd ids local_vars stack' res_ty cmd
 348                                 `thenDs` \ (core_cmd, free_vars, env_ids') ->
 349     mappM newSysLocalDs stack   `thenDs` \ stack_ids ->
 350     newSysLocalDs arg_ty        `thenDs` \ arg_id ->
 351     -- push the argument expression onto the stack
 352     let
 353         core_body = bindNonRec arg_id core_arg
 354                         (buildEnvStack env_ids' (arg_id:stack_ids))
 355     in
 356     -- match the environment and stack against the input
 357     matchEnvStack env_ids stack_ids core_body
 358                                 `thenDs` \ core_map ->
 359     returnDs (do_map_arrow ids
 360                         (envStackType env_ids stack)
 361                         (envStackType env_ids' stack')
 362                         res_ty
 363                         core_map
 364                         core_cmd,
 365         (exprFreeVars core_arg `intersectVarSet` local_vars)
 366                 `unionVarSet` free_vars)
 367
 368 --      A | ys |- c :: [ts] t'
 369 --      -----------------------------------------------
 370 --      A | xs |- \ p1 ... pk -> c :: [t1:...:tk:ts] t'
 371 --
 372 --              ---> arr (\ ((((xs), p1), ... pk)*ts) -> ((ys)*ts)) >>> c
 373
 374 dsCmd ids local_vars env_ids stack res_ty
 375     (HsLam (L _ (Match pats _ (GRHSs [L _ (GRHS [L _ (ResultStmt body)])] _ _cmd_ty))))
 376   = let
 377         pat_vars = mkVarSet (collectPatsBinders pats)
 378         local_vars' = local_vars `unionVarSet` pat_vars
 379         stack' = drop (length pats) stack
 380     in
 381     dsfixCmd ids local_vars' stack' res_ty body
 382                                 `thenDs` \ (core_body, free_vars, env_ids') ->
 383     mappM newSysLocalDs stack   `thenDs` \ stack_ids ->
 384
 385     -- the expression is built from the inside out, so the actions
 386     -- are presented in reverse order
 387
 388     let
 389         (actual_ids, stack_ids') = splitAt (length pats) stack_ids
 390         -- build a new environment, plus what's left of the stack
 391         core_expr = buildEnvStack env_ids' stack_ids'
 392         in_ty = envStackType env_ids stack
 393         in_ty' = envStackType env_ids' stack'
 394     in
 395     mkFailExpr LambdaExpr in_ty'        `thenDs` \ fail_expr ->
 396     -- match the patterns against the top of the old stack
 397     matchSimplys (map Var actual_ids) LambdaExpr pats core_expr fail_expr
 398                                         `thenDs` \ match_code ->
 399     -- match the old environment and stack against the input
 400     matchEnvStack env_ids stack_ids match_code
 401                                         `thenDs` \ select_code ->
 402     returnDs (do_map_arrow ids in_ty in_ty' res_ty select_code core_body,
 403              free_vars `minusVarSet` pat_vars)
 404
 405 dsCmd ids local_vars env_ids stack res_ty (HsPar cmd)
 406   = dsLCmd ids local_vars env_ids stack res_ty cmd
 407
 408 --      A, xs |- e :: Bool
 409 --      A | xs1 |- c1 :: [ts] t
 410 --      A | xs2 |- c2 :: [ts] t
 411 --      ----------------------------------------
 412 --      A | xs |- if e then c1 else c2 :: [ts] t
 413 --
 414 --              ---> arr (\ ((xs)*ts) ->
 415 --                      if e then Left ((xs1)*ts) else Right ((xs2)*ts)) >>>
 416 --                   c1 ||| c2
 417
 418 dsCmd ids local_vars env_ids stack res_ty (HsIf cond then_cmd else_cmd)
 419   = dsLExpr cond                        `thenDs` \ core_cond ->
 420     dsfixCmd ids local_vars stack res_ty then_cmd
 421                                 `thenDs` \ (core_then, fvs_then, then_ids) ->
 422     dsfixCmd ids local_vars stack res_ty else_cmd
 423                                 `thenDs` \ (core_else, fvs_else, else_ids) ->
 424     mappM newSysLocalDs stack           `thenDs` \ stack_ids ->
 425     dsLookupTyCon eitherTyConName       `thenDs` \ either_con ->
 426     dsLookupDataCon leftDataConName     `thenDs` \ left_con ->
 427     dsLookupDataCon rightDataConName    `thenDs` \ right_con ->
 428     let
 429         left_expr ty1 ty2 e = mkConApp left_con [Type ty1, Type ty2, e]
 430         right_expr ty1 ty2 e = mkConApp right_con [Type ty1, Type ty2, e]
 431
 432         in_ty = envStackType env_ids stack
 433         then_ty = envStackType then_ids stack
 434         else_ty = envStackType else_ids stack
 435         sum_ty = mkTyConApp either_con [then_ty, else_ty]
 436         fvs_cond = exprFreeVars core_cond `intersectVarSet` local_vars
 437     in
 438     matchEnvStack env_ids stack_ids
 439         (mkIfThenElse core_cond
 440             (left_expr then_ty else_ty (buildEnvStack then_ids stack_ids))
 441             (right_expr then_ty else_ty (buildEnvStack else_ids stack_ids)))
 442                                         `thenDs` \ core_if ->
 443     returnDs(do_map_arrow ids in_ty sum_ty res_ty
 444                 core_if
 445                 (do_choice ids then_ty else_ty res_ty core_then core_else),
 446         fvs_cond `unionVarSet` fvs_then `unionVarSet` fvs_else)
 447 \end{code}
 448
 449 Case commands are treated in much the same way as if commands
 450 (see above) except that there are more alternatives.  For example
 451
 452         case e of { p1 -> c1; p2 -> c2; p3 -> c3 }
 453
 454 is translated to
 455
 456         arr (\ ((xs)*ts) -> case e of
 457                 p1 -> (Left (Left (xs1)*ts))
 458                 p2 -> Left ((Right (xs2)*ts))
 459                 p3 -> Right ((xs3)*ts)) >>>
 460         (c1 ||| c2) ||| c3
 461
 462 The idea is to extract the commands from the case, build a balanced tree
 463 of choices, and replace the commands with expressions that build tagged
 464 tuples, obtaining a case expression that can be desugared normally.
 465 To build all this, we use quadruples decribing segments of the list of
 466 case bodies, containing the following fields:
 467 1. an IdSet containing the environment variables free in the case bodies
 468 2. a list of expressions of the form (Left|Right)* ((xs)*ts), to be put
 469    into the case replacing the commands
 470 3. a sum type that is the common type of these expressions, and also the
 471    input type of the arrow
 472 4. a CoreExpr for an arrow built by combining the translated command
 473    bodies with |||.
 474
 475 \begin{code}
 476 dsCmd ids local_vars env_ids stack res_ty (HsCase exp matches)
 477   = dsLExpr exp                         `thenDs` \ core_exp ->
 478     mappM newSysLocalDs stack           `thenDs` \ stack_ids ->
 479
 480     -- Extract and desugar the leaf commands in the case, building tuple
 481     -- expressions that will (after tagging) replace these leaves
 482
 483     let
 484         leaves = concatMap leavesMatch matches
 485         make_branch (leaf, bound_vars)
 486           = dsfixCmd ids (local_vars `unionVarSet` bound_vars) stack res_ty leaf
 487                            `thenDs` \ (core_leaf, fvs, leaf_ids) ->
 488             returnDs (fvs `minusVarSet` bound_vars,
 489                       [noLoc $ mkHsEnvStackExpr leaf_ids stack_ids],
 490                       envStackType leaf_ids stack,
 491                       core_leaf)
 492     in
 493     mappM make_branch leaves            `thenDs` \ branches ->
 494     dsLookupTyCon eitherTyConName       `thenDs` \ either_con ->
 495     dsLookupDataCon leftDataConName     `thenDs` \ left_con ->
 496     dsLookupDataCon rightDataConName    `thenDs` \ right_con ->
 497     let
 498         left_id = nlHsVar (dataConWrapId left_con)
 499         right_id = nlHsVar (dataConWrapId right_con)
 500         left_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ TyApp left_id [ty1, ty2]) e
 501         right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ TyApp right_id [ty1, ty2]) e
 502
 503         -- Prefix each tuple with a distinct series of Left's and Right's,
 504         -- in a balanced way, keeping track of the types.
 505
 506         merge_branches (fvs1, builds1, in_ty1, core_exp1)
 507                        (fvs2, builds2, in_ty2, core_exp2)
 508           = (fvs1 `unionVarSet` fvs2,
 509              map (left_expr in_ty1 in_ty2) builds1 ++
 510                 map (right_expr in_ty1 in_ty2) builds2,
 511              mkTyConApp either_con [in_ty1, in_ty2],
 512              do_choice ids in_ty1 in_ty2 res_ty core_exp1 core_exp2)
 513         (fvs_alts, leaves', sum_ty, core_choices)
 514           = foldb merge_branches branches
 515
 516         -- Replace the commands in the case with these tagged tuples,
 517         -- yielding a HsExpr Id we can feed to dsExpr.
 518
 519         (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches
 520         in_ty = envStackType env_ids stack
 521         fvs_exp = exprFreeVars core_exp `intersectVarSet` local_vars
 522     in
 523     dsExpr (HsCase exp matches') `thenDs` \ core_body ->
 524     matchEnvStack env_ids stack_ids core_body
 525                                         `thenDs` \ core_matches ->
 526     returnDs(do_map_arrow ids in_ty sum_ty res_ty core_matches core_choices,
 527              fvs_exp `unionVarSet` fvs_alts)
 528
 529 --      A | ys |- c :: [ts] t
 530 --      ----------------------------------
 531 --      A | xs |- let binds in c :: [ts] t
 532 --
 533 --              ---> arr (\ ((xs)*ts) -> let binds in ((ys)*ts)) >>> c
 534
 535 dsCmd ids local_vars env_ids stack res_ty (HsLet binds body)
 536   = let
 537         defined_vars = mkVarSet (map unLoc (collectGroupBinders binds))
 538         local_vars' = local_vars `unionVarSet` defined_vars
 539     in
 540     dsfixCmd ids local_vars' stack res_ty body
 541                                 `thenDs` \ (core_body, free_vars, env_ids') ->
 542     mappM newSysLocalDs stack           `thenDs` \ stack_ids ->
 543     -- build a new environment, plus the stack, using the let bindings
 544     dsLet binds (buildEnvStack env_ids' stack_ids)
 545                                         `thenDs` \ core_binds ->
 546     -- match the old environment and stack against the input
 547     matchEnvStack env_ids stack_ids core_binds
 548                                         `thenDs` \ core_map ->
 549     returnDs (do_map_arrow ids
 550                         (envStackType env_ids stack)
 551                         (envStackType env_ids' stack)
 552                         res_ty
 553                         core_map
 554                         core_body,
 555         exprFreeVars core_binds `intersectVarSet` local_vars)
 556
 557 dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts _ _)
 558   = dsCmdDo ids local_vars env_ids res_ty stmts
 559
 560 --      A |- e :: forall e. a1 (e*ts1) t1 -> ... an (e*tsn) tn -> a (e*ts) t
 561 --      A | xs |- ci :: [tsi] ti
 562 --      -----------------------------------
 563 --      A | xs |- (|e c1 ... cn|) :: [ts] t     ---> e [t_xs] c1 ... cn
 564
 565 dsCmd _ids local_vars env_ids _stack _res_ty (HsArrForm op _ args)
 566   = let
 567         env_ty = mkTupleType env_ids
 568     in
 569     dsLExpr op                          `thenDs` \ core_op ->
 570     mapAndUnzipDs (dsTrimCmdArg local_vars env_ids) args
 571                                         `thenDs` \ (core_args, fv_sets) ->
 572     returnDs (mkApps (App core_op (Type env_ty)) core_args,
 573               unionVarSets fv_sets)
 574
 575 --      A | ys |- c :: [ts] t   (ys <= xs)
 576 --      ---------------------
 577 --      A | xs |- c :: [ts] t   ---> arr_ts (\ (xs) -> (ys)) >>> c
 578
 579 dsTrimCmdArg
 580         :: IdSet                -- set of local vars available to this command
 581         -> [Id]                 -- list of vars in the input to this command
 582         -> LHsCmdTop Id -- command argument to desugar
 583         -> DsM (CoreExpr,       -- desugared expression
 584                 IdSet)          -- set of local vars that occur free
 585 dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack cmd_ty ids))
 586   = mkCmdEnv ids                        `thenDs` \ meth_ids ->
 587     dsfixCmd meth_ids local_vars stack cmd_ty cmd
 588                                 `thenDs` \ (core_cmd, free_vars, env_ids') ->
 589     mappM newSysLocalDs stack           `thenDs` \ stack_ids ->
 590     matchEnvStack env_ids stack_ids (buildEnvStack env_ids' stack_ids)
 591                                         `thenDs` \ trim_code ->
 592     let
 593         in_ty = envStackType env_ids stack
 594         in_ty' = envStackType env_ids' stack
 595         arg_code = if env_ids' == env_ids then core_cmd else
 596                 do_map_arrow meth_ids in_ty in_ty' cmd_ty trim_code core_cmd
 597     in
 598     returnDs (bindCmdEnv meth_ids arg_code, free_vars)
 599
 600 -- Given A | xs |- c :: [ts] t, builds c with xs fed back.
 601 -- Typically needs to be prefixed with arr (\p -> ((xs)*ts))
 602
 603 dsfixCmd
 604         :: DsCmdEnv             -- arrow combinators
 605         -> IdSet                -- set of local vars available to this command
 606         -> [Type]               -- type of the stack
 607         -> Type                 -- return type of the command
 608         -> LHsCmd Id            -- command to desugar
 609         -> DsM (CoreExpr,       -- desugared expression
 610                 IdSet,          -- set of local vars that occur free
 611                 [Id])           -- set as a list, fed back
 612 dsfixCmd ids local_vars stack cmd_ty cmd
 613   = fixDs (\ ~(_,_,env_ids') ->
 614         dsLCmd ids local_vars env_ids' stack cmd_ty cmd
 615                                         `thenDs` \ (core_cmd, free_vars) ->
 616         returnDs (core_cmd, free_vars, varSetElems free_vars))
 617
 618 \end{code}
 619
 620 Translation of command judgements of the form
 621
 622         A | xs |- do { ss } :: [] t
 623
 624 \begin{code}
 625
 626 dsCmdDo :: DsCmdEnv             -- arrow combinators
 627         -> IdSet                -- set of local vars available to this statement
 628         -> [Id]                 -- list of vars in the input to this statement
 629                                 -- This is typically fed back,
 630                                 -- so don't pull on it too early
 631         -> Type                 -- return type of the statement
 632         -> [LStmt Id]   -- statements to desugar
 633         -> DsM (CoreExpr,       -- desugared expression
 634                 IdSet)          -- set of local vars that occur free
 635
 636 --      A | xs |- c :: [] t
 637 --      --------------------------
 638 --      A | xs |- do { c } :: [] t
 639
 640 dsCmdDo ids local_vars env_ids res_ty [L _ (ResultStmt cmd)]
 641   = dsLCmd ids local_vars env_ids [] res_ty cmd
 642
 643 dsCmdDo ids local_vars env_ids res_ty (stmt:stmts)
 644   = let
 645         bound_vars = mkVarSet (map unLoc (collectLStmtBinders stmt))
 646         local_vars' = local_vars `unionVarSet` bound_vars
 647     in
 648     fixDs (\ ~(_,_,env_ids') ->
 649         dsCmdDo ids local_vars' env_ids' res_ty stmts
 650                                         `thenDs` \ (core_stmts, fv_stmts) ->
 651         returnDs (core_stmts, fv_stmts, varSetElems fv_stmts))
 652                                 `thenDs` \ (core_stmts, fv_stmts, env_ids') ->
 653     dsCmdLStmt ids local_vars env_ids env_ids' stmt
 654                                 `thenDs` \ (core_stmt, fv_stmt) ->
 655     returnDs (do_compose ids
 656                 (mkTupleType env_ids)
 657                 (mkTupleType env_ids')
 658                 res_ty
 659                 core_stmt
 660                 core_stmts,
 661               fv_stmt)
 662
 663 \end{code}
 664 A statement maps one local environment to another, and is represented
 665 as an arrow from one tuple type to another.  A statement sequence is
 666 translated to a composition of such arrows.
 667 \begin{code}
 668 dsCmdLStmt ids local_vars env_ids out_ids cmd
 669   = dsCmdStmt ids local_vars env_ids out_ids (unLoc cmd)
 670
 671 dsCmdStmt
 672         :: DsCmdEnv             -- arrow combinators
 673         -> IdSet                -- set of local vars available to this statement
 674         -> [Id]                 -- list of vars in the input to this statement
 675                                 -- This is typically fed back,
 676                                 -- so don't pull on it too early
 677         -> [Id]                 -- list of vars in the output of this statement
 678         -> Stmt Id      -- statement to desugar
 679         -> DsM (CoreExpr,       -- desugared expression
 680                 IdSet)          -- set of local vars that occur free
 681
 682 --      A | xs1 |- c :: [] t
 683 --      A | xs' |- do { ss } :: [] t'
 684 --      ------------------------------
 685 --      A | xs |- do { c; ss } :: [] t'
 686 --
 687 --              ---> arr (\ (xs) -> ((xs1),(xs'))) >>> first c >>>
 688 --                      arr snd >>> ss
 689
 690 dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd c_ty)
 691   = dsfixCmd ids local_vars [] c_ty cmd
 692                                 `thenDs` \ (core_cmd, fv_cmd, env_ids1) ->
 693     matchEnvStack env_ids []
 694         (mkCorePairExpr (mkTupleExpr env_ids1) (mkTupleExpr out_ids))
 695                                         `thenDs` \ core_mux ->
 696     let
 697         in_ty = mkTupleType env_ids
 698         in_ty1 = mkTupleType env_ids1
 699         out_ty = mkTupleType out_ids
 700         before_c_ty = mkCorePairTy in_ty1 out_ty
 701         after_c_ty = mkCorePairTy c_ty out_ty
 702     in
 703     mkSndExpr c_ty out_ty               `thenDs` \ snd_fn ->
 704     returnDs (do_map_arrow ids in_ty before_c_ty out_ty core_mux $
 705                 do_compose ids before_c_ty after_c_ty out_ty
 706                         (do_first ids in_ty1 c_ty out_ty core_cmd) $
 707                 do_arr ids after_c_ty out_ty snd_fn,
 708               extendVarSetList fv_cmd out_ids)
 709   where
 710
 711 --      A | xs1 |- c :: [] t
 712 --      A | xs' |- do { ss } :: [] t'           xs2 = xs' - defs(p)
 713 --      -----------------------------------
 714 --      A | xs |- do { p <- c; ss } :: [] t'
 715 --
 716 --              ---> arr (\ (xs) -> ((xs1),(xs2))) >>> first c >>>
 717 --                      arr (\ (p, (xs2)) -> (xs')) >>> ss
 718 --
 719 -- It would be simpler and more consistent to do this using second,
 720 -- but that's likely to be defined in terms of first.
 721
 722 dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd)
 723   = dsfixCmd ids local_vars [] (hsPatType pat) cmd
 724                                 `thenDs` \ (core_cmd, fv_cmd, env_ids1) ->
 725     let
 726         pat_ty = hsPatType pat
 727         pat_vars = mkVarSet (collectPatBinders pat)
 728         env_ids2 = varSetElems (mkVarSet out_ids `minusVarSet` pat_vars)
 729         env_ty2 = mkTupleType env_ids2
 730     in
 731
 732     -- multiplexing function
 733     --          \ (xs) -> ((xs1),(xs2))
 734
 735     matchEnvStack env_ids []
 736         (mkCorePairExpr (mkTupleExpr env_ids1) (mkTupleExpr env_ids2))
 737                                         `thenDs` \ core_mux ->
 738
 739     -- projection function
 740     --          \ (p, (xs2)) -> (zs)
 741
 742     selectMatchVarL pat                 `thenDs` \ pat_id ->
 743     newSysLocalDs env_ty2               `thenDs` \ env_id ->
 744     newUniqueSupply                     `thenDs` \ uniqs ->
 745     let
 746         after_c_ty = mkCorePairTy pat_ty env_ty2
 747         out_ty = mkTupleType out_ids
 748         body_expr = coreCaseTuple uniqs env_id env_ids2 (mkTupleExpr out_ids)
 749     in
 750     mkFailExpr (StmtCtxt DoExpr) out_ty `thenDs` \ fail_expr ->
 751     matchSimply (Var pat_id) (StmtCtxt DoExpr) pat body_expr fail_expr
 752                                         `thenDs` \ match_code ->
 753     newSysLocalDs after_c_ty            `thenDs` \ pair_id ->
 754     let
 755         proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code)
 756     in
 757
 758     -- put it all together
 759     let
 760         in_ty = mkTupleType env_ids
 761         in_ty1 = mkTupleType env_ids1
 762         in_ty2 = mkTupleType env_ids2
 763         before_c_ty = mkCorePairTy in_ty1 in_ty2
 764     in
 765     returnDs (do_map_arrow ids in_ty before_c_ty out_ty core_mux $
 766                 do_compose ids before_c_ty after_c_ty out_ty
 767                         (do_first ids in_ty1 pat_ty in_ty2 core_cmd) $
 768                 do_arr ids after_c_ty out_ty proj_expr,
 769               fv_cmd `unionVarSet` (mkVarSet out_ids `minusVarSet` pat_vars))
 770
 771 --      A | xs' |- do { ss } :: [] t
 772 --      --------------------------------------
 773 --      A | xs |- do { let binds; ss } :: [] t
 774 --
 775 --              ---> arr (\ (xs) -> let binds in (xs')) >>> ss
 776
 777 dsCmdStmt ids local_vars env_ids out_ids (LetStmt binds)
 778     -- build a new environment using the let bindings
 779   = dsLet binds (mkTupleExpr out_ids)   `thenDs` \ core_binds ->
 780     -- match the old environment against the input
 781     matchEnvStack env_ids [] core_binds `thenDs` \ core_map ->
 782     returnDs (do_arr ids
 783                         (mkTupleType env_ids)
 784                         (mkTupleType out_ids)
 785                         core_map,
 786         exprFreeVars core_binds `intersectVarSet` local_vars)
 787
 788 --      A | ys |- do { ss; returnA -< ((xs1), (ys2)) } :: [] ...
 789 --      A | xs' |- do { ss' } :: [] t
 790 --      ------------------------------------
 791 --      A | xs |- do { rec ss; ss' } :: [] t
 792 --
 793 --                      xs1 = xs' /\ defs(ss)
 794 --                      xs2 = xs' - defs(ss)
 795 --                      ys1 = ys - defs(ss)
 796 --                      ys2 = ys /\ defs(ss)
 797 --
 798 --              ---> arr (\(xs) -> ((ys1),(xs2))) >>>
 799 --                      first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>>
 800 --                      arr (\((xs1),(xs2)) -> (xs')) >>> ss'
 801
 802 dsCmdStmt ids local_vars env_ids out_ids (RecStmt stmts later_ids rec_ids rhss)
 803   = let
 804         env2_id_set = mkVarSet out_ids `minusVarSet` mkVarSet later_ids
 805         env2_ids = varSetElems env2_id_set
 806         env2_ty = mkTupleType env2_ids
 807     in
 808
 809     -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids)
 810
 811     newUniqueSupply             `thenDs` \ uniqs ->
 812     newSysLocalDs env2_ty       `thenDs` \ env2_id ->
 813     let
 814         later_ty = mkTupleType later_ids
 815         post_pair_ty = mkCorePairTy later_ty env2_ty
 816         post_loop_body = coreCaseTuple uniqs env2_id env2_ids (mkTupleExpr out_ids)
 817     in
 818     matchEnvStack later_ids [env2_id] post_loop_body
 819                                 `thenDs` \ post_loop_fn ->
 820
 821     --- loop (...)
 822
 823     dsRecCmd ids local_vars stmts later_ids rec_ids rhss
 824                                 `thenDs` \ (core_loop, env1_id_set, env1_ids) ->
 825
 826     -- pre_loop_fn = \(env_ids) -> ((env1_ids),(env2_ids))
 827
 828     let
 829         env1_ty = mkTupleType env1_ids
 830         pre_pair_ty = mkCorePairTy env1_ty env2_ty
 831         pre_loop_body = mkCorePairExpr (mkTupleExpr env1_ids)
 832                                         (mkTupleExpr env2_ids)
 833
 834     in
 835     matchEnvStack env_ids [] pre_loop_body
 836                                 `thenDs` \ pre_loop_fn ->
 837
 838     -- arr pre_loop_fn >>> first (loop (...)) >>> arr post_loop_fn
 839
 840     let
 841         env_ty = mkTupleType env_ids
 842         out_ty = mkTupleType out_ids
 843         core_body = do_map_arrow ids env_ty pre_pair_ty out_ty
 844                 pre_loop_fn
 845                 (do_compose ids pre_pair_ty post_pair_ty out_ty
 846                         (do_first ids env1_ty later_ty env2_ty
 847                                 core_loop)
 848                         (do_arr ids post_pair_ty out_ty
 849                                 post_loop_fn))
 850     in
 851     returnDs (core_body, env1_id_set `unionVarSet` env2_id_set)
 852
 853 --      loop (arr (\ ((env1_ids), ~(rec_ids)) -> (env_ids)) >>>
 854 --            ss >>>
 855 --            arr (\ (out_ids) -> ((later_ids),(rhss))) >>>
 856
 857 dsRecCmd ids local_vars stmts later_ids rec_ids rhss
 858   = let
 859         rec_id_set = mkVarSet rec_ids
 860         out_ids = varSetElems (mkVarSet later_ids `unionVarSet` rec_id_set)
 861         out_ty = mkTupleType out_ids
 862         local_vars' = local_vars `unionVarSet` rec_id_set
 863     in
 864
 865     -- mk_pair_fn = \ (out_ids) -> ((later_ids),(rhss))
 866
 867     mappM dsLExpr rhss          `thenDs` \ core_rhss ->
 868     let
 869         later_tuple = mkTupleExpr later_ids
 870         later_ty = mkTupleType later_ids
 871         rec_tuple = mkBigCoreTup core_rhss
 872         rec_ty = mkTupleType rec_ids
 873         out_pair = mkCorePairExpr later_tuple rec_tuple
 874         out_pair_ty = mkCorePairTy later_ty rec_ty
 875     in
 876         matchEnvStack out_ids [] out_pair
 877                                 `thenDs` \ mk_pair_fn ->
 878
 879     -- ss
 880
 881     dsfixCmdStmts ids local_vars' out_ids stmts
 882                                 `thenDs` \ (core_stmts, fv_stmts, env_ids) ->
 883
 884     -- squash_pair_fn = \ ((env1_ids), ~(rec_ids)) -> (env_ids)
 885
 886     newSysLocalDs rec_ty        `thenDs` \ rec_id ->
 887     let
 888         env1_id_set = fv_stmts `minusVarSet` rec_id_set
 889         env1_ids = varSetElems env1_id_set
 890         env1_ty = mkTupleType env1_ids
 891         in_pair_ty = mkCorePairTy env1_ty rec_ty
 892         core_body = mkBigCoreTup (map selectVar env_ids)
 893           where
 894             selectVar v
 895                 | v `elemVarSet` rec_id_set
 896                   = mkTupleSelector rec_ids v rec_id (Var rec_id)
 897                 | otherwise = Var v
 898     in
 899     matchEnvStack env1_ids [rec_id] core_body
 900                                 `thenDs` \ squash_pair_fn ->
 901
 902     -- loop (arr squash_pair_fn >>> ss >>> arr mk_pair_fn)
 903
 904     let
 905         env_ty = mkTupleType env_ids
 906         core_loop = do_loop ids env1_ty later_ty rec_ty
 907                 (do_map_arrow ids in_pair_ty env_ty out_pair_ty
 908                         squash_pair_fn
 909                         (do_compose ids env_ty out_ty out_pair_ty
 910                                 core_stmts
 911                                 (do_arr ids out_ty out_pair_ty mk_pair_fn)))
 912     in
 913     returnDs (core_loop, env1_id_set, env1_ids)
 914
 915 \end{code}
 916 A sequence of statements (as in a rec) is desugared to an arrow between
 917 two environments
 918 \begin{code}
 919
 920 dsfixCmdStmts
 921         :: DsCmdEnv             -- arrow combinators
 922         -> IdSet                -- set of local vars available to this statement
 923         -> [Id]                 -- output vars of these statements
 924         -> [LStmt Id]   -- statements to desugar
 925         -> DsM (CoreExpr,       -- desugared expression
 926                 IdSet,          -- set of local vars that occur free
 927                 [Id])           -- input vars
 928
 929 dsfixCmdStmts ids local_vars out_ids stmts
 930   = fixDs (\ ~(_,_,env_ids) ->
 931         dsCmdStmts ids local_vars env_ids out_ids stmts
 932                                         `thenDs` \ (core_stmts, fv_stmts) ->
 933         returnDs (core_stmts, fv_stmts, varSetElems fv_stmts))
 934
 935 dsCmdStmts
 936         :: DsCmdEnv             -- arrow combinators
 937         -> IdSet                -- set of local vars available to this statement
 938         -> [Id]                 -- list of vars in the input to these statements
 939         -> [Id]                 -- output vars of these statements
 940         -> [LStmt Id]   -- statements to desugar
 941         -> DsM (CoreExpr,       -- desugared expression
 942                 IdSet)          -- set of local vars that occur free
 943
 944 dsCmdStmts ids local_vars env_ids out_ids [stmt]
 945   = dsCmdLStmt ids local_vars env_ids out_ids stmt
 946
 947 dsCmdStmts ids local_vars env_ids out_ids (stmt:stmts)
 948   = let
 949         bound_vars = mkVarSet (map unLoc (collectLStmtBinders stmt))
 950         local_vars' = local_vars `unionVarSet` bound_vars
 951     in
 952     dsfixCmdStmts ids local_vars' out_ids stmts
 953                                 `thenDs` \ (core_stmts, fv_stmts, env_ids') ->
 954     dsCmdLStmt ids local_vars env_ids env_ids' stmt
 955                                 `thenDs` \ (core_stmt, fv_stmt) ->
 956     returnDs (do_compose ids
 957                 (mkTupleType env_ids)
 958                 (mkTupleType env_ids')
 959                 (mkTupleType out_ids)
 960                 core_stmt
 961                 core_stmts,
 962               fv_stmt)
 963
 964 \end{code}
 965
 966 Match a list of expressions against a list of patterns, left-to-right.
 967
 968 \begin{code}
 969 matchSimplys :: [CoreExpr]              -- Scrutinees
 970              -> HsMatchContext Name     -- Match kind
 971              -> [LPat Id]               -- Patterns they should match
 972              -> CoreExpr                -- Return this if they all match
 973              -> CoreExpr                -- Return this if they don't
 974              -> DsM CoreExpr
 975 matchSimplys [] _ctxt [] result_expr _fail_expr = returnDs result_expr
 976 matchSimplys (exp:exps) ctxt (pat:pats) result_expr fail_expr
 977   = matchSimplys exps ctxt pats result_expr fail_expr
 978                                         `thenDs` \ match_code ->
 979     matchSimply exp ctxt pat match_code fail_expr
 980 \end{code}
 981
 982 List of leaf expressions, with set of variables bound in each
 983
 984 \begin{code}
 985 leavesMatch :: LMatch Id -> [(LHsExpr Id, IdSet)]
 986 leavesMatch (L _ (Match pats _ (GRHSs grhss binds _ty)))
 987   = let
 988         defined_vars = mkVarSet (collectPatsBinders pats)
 989                         `unionVarSet`
 990                        mkVarSet (map unLoc (collectGroupBinders binds))
 991     in
 992     [(expr,
 993       mkVarSet (map unLoc (collectStmtsBinders stmts))
 994         `unionVarSet` defined_vars)
 995     | L _ (GRHS stmts) <- grhss,
 996       let L _ (ResultStmt expr) = last stmts]
 997 \end{code}
 998
 999 Replace the leaf commands in a match
1000
1001 \begin{code}
1002 replaceLeavesMatch
1003         :: Type                 -- new result type
1004         -> [LHsExpr Id] -- replacement leaf expressions of that type
1005         -> LMatch Id    -- the matches of a case command
1006         -> ([LHsExpr Id],-- remaining leaf expressions
1007             LMatch Id)  -- updated match
1008 replaceLeavesMatch res_ty leaves (L loc (Match pat mt (GRHSs grhss binds _ty)))
1009   = let
1010         (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss
1011     in
1012     (leaves', L loc (Match pat mt (GRHSs grhss' binds res_ty)))
1013
1014 replaceLeavesGRHS
1015         :: [LHsExpr Id] -- replacement leaf expressions of that type
1016         -> LGRHS Id     -- rhss of a case command
1017         -> ([LHsExpr Id],-- remaining leaf expressions
1018             LGRHS Id)   -- updated GRHS
1019 replaceLeavesGRHS (leaf:leaves) (L loc (GRHS stmts))
1020   = (leaves, L loc (GRHS (init stmts ++ [L (getLoc leaf) (ResultStmt leaf)])))
1021 \end{code}
1022
1023 Balanced fold of a non-empty list.
1024
1025 \begin{code}
1026 foldb :: (a -> a -> a) -> [a] -> a
1027 foldb _ [] = error "foldb of empty list"
1028 foldb _ [x] = x
1029 foldb f xs = foldb f (fold_pairs xs)
1030   where
1031     fold_pairs [] = []
1032     fold_pairs [x] = [x]
1033     fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs
1034 \end{code}