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