compiler/deSugar/DsArrows.lhs

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