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