never executed always true always false
    1 
    2 {-# LANGUAGE TypeFamilies #-}
    3 
    4 {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
    5 
    6 {-
    7 (c) The University of Glasgow 2006
    8 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
    9 
   10 
   11 Desugaring arrow commands
   12 -}
   13 
   14 module GHC.HsToCore.Arrows ( dsProcExpr ) where
   15 
   16 import GHC.Prelude
   17 
   18 import GHC.HsToCore.Match
   19 import GHC.HsToCore.Utils
   20 import GHC.HsToCore.Monad
   21 
   22 import GHC.Hs
   23 import GHC.Hs.Syn.Type
   24 
   25 -- NB: The desugarer, which straddles the source and Core worlds, sometimes
   26 --     needs to see source types (newtypes etc), and sometimes not
   27 --     So WATCH OUT; check each use of split*Ty functions.
   28 -- Sigh.  This is a pain.
   29 
   30 import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsLExpr, dsLocalBinds,
   31                                           dsSyntaxExpr )
   32 
   33 import GHC.Tc.Utils.TcType
   34 import GHC.Core.Multiplicity
   35 import GHC.Tc.Types.Evidence
   36 import GHC.Core
   37 import GHC.Core.FVs
   38 import GHC.Core.Utils
   39 import GHC.Core.Make
   40 import GHC.HsToCore.Binds (dsHsWrapper)
   41 
   42 
   43 import GHC.Types.Id
   44 import GHC.Core.ConLike
   45 import GHC.Builtin.Types
   46 import GHC.Types.Basic
   47 import GHC.Builtin.Names
   48 import GHC.Utils.Outputable
   49 import GHC.Utils.Panic
   50 import GHC.Types.Var.Set
   51 import GHC.Types.SrcLoc
   52 import GHC.Data.List.SetOps( assocMaybe )
   53 import Data.List (mapAccumL)
   54 import GHC.Utils.Misc
   55 import GHC.Types.Unique.DSet
   56 
   57 data DsCmdEnv = DsCmdEnv {
   58         arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr
   59     }
   60 
   61 mkCmdEnv :: CmdSyntaxTable GhcTc -> DsM ([CoreBind], DsCmdEnv)
   62 -- See Note [CmdSyntaxTable] in GHC.Hs.Expr
   63 mkCmdEnv tc_meths
   64   = do { (meth_binds, prs) <- mapAndUnzipM mk_bind tc_meths
   65 
   66        -- NB: Some of these lookups might fail, but that's OK if the
   67        -- symbol is never used. That's why we use Maybe first and then
   68        -- panic. An eager panic caused trouble in typecheck/should_compile/tc192
   69        ; let the_arr_id     = assocMaybe prs arrAName
   70              the_compose_id = assocMaybe prs composeAName
   71              the_first_id   = assocMaybe prs firstAName
   72              the_app_id     = assocMaybe prs appAName
   73              the_choice_id  = assocMaybe prs choiceAName
   74              the_loop_id    = assocMaybe prs loopAName
   75 
   76        ; return (meth_binds, DsCmdEnv {
   77                arr_id     = Var (unmaybe the_arr_id arrAName),
   78                compose_id = Var (unmaybe the_compose_id composeAName),
   79                first_id   = Var (unmaybe the_first_id firstAName),
   80                app_id     = Var (unmaybe the_app_id appAName),
   81                choice_id  = Var (unmaybe the_choice_id choiceAName),
   82                loop_id    = Var (unmaybe the_loop_id loopAName)
   83              }) }
   84   where
   85     mk_bind (std_name, expr)
   86       = do { rhs <- dsExpr expr
   87            ; id <- newSysLocalDs Many (exprType rhs)
   88            -- no check needed; these are functions
   89            ; return (NonRec id rhs, (std_name, id)) }
   90 
   91     unmaybe Nothing name = pprPanic "mkCmdEnv" (text "Not found:" <+> ppr name)
   92     unmaybe (Just id) _  = id
   93 
   94 -- arr :: forall b c. (b -> c) -> a b c
   95 do_arr :: DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr
   96 do_arr ids b_ty c_ty f = mkApps (arr_id ids) [Type b_ty, Type c_ty, f]
   97 
   98 -- (>>>) :: forall b c d. a b c -> a c d -> a b d
   99 do_compose :: DsCmdEnv -> Type -> Type -> Type ->
  100                 CoreExpr -> CoreExpr -> CoreExpr
  101 do_compose ids b_ty c_ty d_ty f g
  102   = mkApps (compose_id ids) [Type b_ty, Type c_ty, Type d_ty, f, g]
  103 
  104 -- first :: forall b c d. a b c -> a (b,d) (c,d)
  105 do_first :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr
  106 do_first ids b_ty c_ty d_ty f
  107   = mkApps (first_id ids) [Type b_ty, Type c_ty, Type d_ty, f]
  108 
  109 -- app :: forall b c. a (a b c, b) c
  110 do_app :: DsCmdEnv -> Type -> Type -> CoreExpr
  111 do_app ids b_ty c_ty = mkApps (app_id ids) [Type b_ty, Type c_ty]
  112 
  113 -- (|||) :: forall b d c. a b d -> a c d -> a (Either b c) d
  114 -- note the swapping of d and c
  115 do_choice :: DsCmdEnv -> Type -> Type -> Type ->
  116                 CoreExpr -> CoreExpr -> CoreExpr
  117 do_choice ids b_ty c_ty d_ty f g
  118   = mkApps (choice_id ids) [Type b_ty, Type d_ty, Type c_ty, f, g]
  119 
  120 -- loop :: forall b d c. a (b,d) (c,d) -> a b c
  121 -- note the swapping of d and c
  122 do_loop :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr
  123 do_loop ids b_ty c_ty d_ty f
  124   = mkApps (loop_id ids) [Type b_ty, Type d_ty, Type c_ty, f]
  125 
  126 -- premap :: forall b c d. (b -> c) -> a c d -> a b d
  127 -- premap f g = arr f >>> g
  128 do_premap :: DsCmdEnv -> Type -> Type -> Type ->
  129                 CoreExpr -> CoreExpr -> CoreExpr
  130 do_premap ids b_ty c_ty d_ty f g
  131    = do_compose ids b_ty c_ty d_ty (do_arr ids b_ty c_ty f) g
  132 
  133 -- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> a
  134 mkFstExpr :: Type -> Type -> DsM CoreExpr
  135 mkFstExpr a_ty b_ty = do
  136     a_var <- newSysLocalDs Many a_ty
  137     b_var <- newSysLocalDs Many b_ty
  138     pair_var <- newSysLocalDs Many (mkCorePairTy a_ty b_ty)
  139     return (Lam pair_var
  140                (coreCasePair pair_var a_var b_var (Var a_var)))
  141 
  142 -- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> b
  143 mkSndExpr :: Type -> Type -> DsM CoreExpr
  144 mkSndExpr a_ty b_ty = do
  145     a_var <- newSysLocalDs Many a_ty
  146     b_var <- newSysLocalDs Many b_ty
  147     pair_var <- newSysLocalDs Many (mkCorePairTy a_ty b_ty)
  148     return (Lam pair_var
  149                (coreCasePair pair_var a_var b_var (Var b_var)))
  150 
  151 {-
  152 Build case analysis of a tuple.  This cannot be done in the DsM monad,
  153 because the list of variables is typically not yet defined.
  154 -}
  155 
  156 -- coreCaseTuple [u1..] v [x1..xn] body
  157 --      = case v of v { (x1, .., xn) -> body }
  158 -- But the matching may be nested if the tuple is very big
  159 
  160 coreCaseTuple :: UniqSupply -> Id -> [Id] -> CoreExpr -> CoreExpr
  161 coreCaseTuple uniqs scrut_var vars body
  162   = mkTupleCase uniqs vars body scrut_var (Var scrut_var)
  163 
  164 coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr
  165 coreCasePair scrut_var var1 var2 body
  166   = Case (Var scrut_var) scrut_var (exprType body)
  167          [Alt (DataAlt (tupleDataCon Boxed 2)) [var1, var2] body]
  168 
  169 mkCorePairTy :: Type -> Type -> Type
  170 mkCorePairTy t1 t2 = mkBoxedTupleTy [t1, t2]
  171 
  172 mkCorePairExpr :: CoreExpr -> CoreExpr -> CoreExpr
  173 mkCorePairExpr e1 e2 = mkCoreTup [e1, e2]
  174 
  175 mkCoreUnitExpr :: CoreExpr
  176 mkCoreUnitExpr = mkCoreTup []
  177 
  178 {-
  179 The input is divided into a local environment, which is a flat tuple
  180 (unless it's too big), and a stack, which is a right-nested pair.
  181 In general, the input has the form
  182 
  183         ((x1,...,xn), (s1,...(sk,())...))
  184 
  185 where xi are the environment values, and si the ones on the stack,
  186 with s1 being the "top", the first one to be matched with a lambda.
  187 -}
  188 
  189 envStackType :: [Id] -> Type -> Type
  190 envStackType ids stack_ty = mkCorePairTy (mkBigCoreVarTupTy ids) stack_ty
  191 
  192 -- splitTypeAt n (t1,... (tn,t)...) = ([t1, ..., tn], t)
  193 splitTypeAt :: Int -> Type -> ([Type], Type)
  194 splitTypeAt n ty
  195   | n == 0 = ([], ty)
  196   | otherwise = case tcTyConAppArgs ty of
  197       [t, ty'] -> let (ts, ty_r) = splitTypeAt (n-1) ty' in (t:ts, ty_r)
  198       _ -> pprPanic "splitTypeAt" (ppr ty)
  199 
  200 ----------------------------------------------
  201 --              buildEnvStack
  202 --
  203 --      ((x1,...,xn),stk)
  204 
  205 buildEnvStack :: [Id] -> Id -> CoreExpr
  206 buildEnvStack env_ids stack_id
  207   = mkCorePairExpr (mkBigCoreVarTup env_ids) (Var stack_id)
  208 
  209 ----------------------------------------------
  210 --              matchEnvStack
  211 --
  212 --      \ ((x1,...,xn),stk) -> body
  213 --      =>
  214 --      \ pair ->
  215 --      case pair of (tup,stk) ->
  216 --      case tup of (x1,...,xn) ->
  217 --      body
  218 
  219 matchEnvStack   :: [Id]         -- x1..xn
  220                 -> Id           -- stk
  221                 -> CoreExpr     -- e
  222                 -> DsM CoreExpr
  223 matchEnvStack env_ids stack_id body = do
  224     uniqs <- newUniqueSupply
  225     tup_var <- newSysLocalDs Many (mkBigCoreVarTupTy env_ids)
  226     let match_env = coreCaseTuple uniqs tup_var env_ids body
  227     pair_id <- newSysLocalDs Many (mkCorePairTy (idType tup_var) (idType stack_id))
  228     return (Lam pair_id (coreCasePair pair_id tup_var stack_id match_env))
  229 
  230 ----------------------------------------------
  231 --              matchEnv
  232 --
  233 --      \ (x1,...,xn) -> body
  234 --      =>
  235 --      \ tup ->
  236 --      case tup of (x1,...,xn) ->
  237 --      body
  238 
  239 matchEnv :: [Id]        -- x1..xn
  240          -> CoreExpr    -- e
  241          -> DsM CoreExpr
  242 matchEnv env_ids body = do
  243     uniqs <- newUniqueSupply
  244     tup_id <- newSysLocalDs Many (mkBigCoreVarTupTy env_ids)
  245     return (Lam tup_id (coreCaseTuple uniqs tup_id env_ids body))
  246 
  247 ----------------------------------------------
  248 --              matchVarStack
  249 --
  250 --      case (x1, ...(xn, s)...) -> e
  251 --      =>
  252 --      case z0 of (x1,z1) ->
  253 --      case zn-1 of (xn,s) ->
  254 --      e
  255 matchVarStack :: [Id] -> Id -> CoreExpr -> DsM (Id, CoreExpr)
  256 matchVarStack [] stack_id body = return (stack_id, body)
  257 matchVarStack (param_id:param_ids) stack_id body = do
  258     (tail_id, tail_code) <- matchVarStack param_ids stack_id body
  259     pair_id <- newSysLocalDs Many (mkCorePairTy (idType param_id) (idType tail_id))
  260     return (pair_id, coreCasePair pair_id param_id tail_id tail_code)
  261 
  262 mkHsEnvStackExpr :: [Id] -> Id -> LHsExpr GhcTc
  263 mkHsEnvStackExpr env_ids stack_id
  264   = mkLHsTupleExpr [mkLHsVarTuple env_ids noExtField, nlHsVar stack_id]
  265                    noExtField
  266 
  267 -- Translation of arrow abstraction
  268 
  269 -- D; xs |-a c : () --> t'      ---> c'
  270 -- --------------------------
  271 -- D |- proc p -> c :: a t t'   ---> premap (\ p -> ((xs),())) c'
  272 --
  273 --              where (xs) is the tuple of variables bound by p
  274 
  275 dsProcExpr
  276         :: LPat GhcTc
  277         -> LHsCmdTop GhcTc
  278         -> DsM CoreExpr
  279 dsProcExpr pat (L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do
  280     (meth_binds, meth_ids) <- mkCmdEnv ids
  281     let locals = mkVarSet (collectPatBinders CollWithDictBinders pat)
  282     (core_cmd, _free_vars, env_ids)
  283        <- dsfixCmd meth_ids locals unitTy cmd_ty cmd
  284     let env_ty = mkBigCoreVarTupTy env_ids
  285     let env_stk_ty = mkCorePairTy env_ty unitTy
  286     let env_stk_expr = mkCorePairExpr (mkBigCoreVarTup env_ids) mkCoreUnitExpr
  287     fail_expr <- mkFailExpr (ArrowMatchCtxt ProcExpr) env_stk_ty
  288     var <- selectSimpleMatchVarL Many pat
  289     match_code <- matchSimply (Var var) (ArrowMatchCtxt ProcExpr) pat env_stk_expr fail_expr
  290     let pat_ty = hsLPatType pat
  291     let proc_code = do_premap meth_ids pat_ty env_stk_ty cmd_ty
  292                     (Lam var match_code)
  293                     core_cmd
  294     return (mkLets meth_binds proc_code)
  295 
  296 {-
  297 Translation of a command judgement of the form
  298 
  299         D; xs |-a c : stk --> t
  300 
  301 to an expression e such that
  302 
  303         D |- e :: a (xs, stk) t
  304 -}
  305 
  306 dsLCmd :: DsCmdEnv -> IdSet -> Type -> Type -> LHsCmd GhcTc -> [Id]
  307        -> DsM (CoreExpr, DIdSet)
  308 dsLCmd ids local_vars stk_ty res_ty cmd env_ids
  309   = dsCmd ids local_vars stk_ty res_ty (unLoc cmd) env_ids
  310 
  311 dsCmd   :: DsCmdEnv             -- arrow combinators
  312         -> IdSet                -- set of local vars available to this command
  313         -> Type                 -- type of the stack (right-nested tuple)
  314         -> Type                 -- return type of the command
  315         -> HsCmd GhcTc           -- command to desugar
  316         -> [Id]           -- list of vars in the input to this command
  317                                 -- This is typically fed back,
  318                                 -- so don't pull on it too early
  319         -> DsM (CoreExpr,       -- desugared expression
  320                 DIdSet)         -- subset of local vars that occur free
  321 
  322 -- D |- fun :: a t1 t2
  323 -- D, xs |- arg :: t1
  324 -- -----------------------------
  325 -- D; xs |-a fun -< arg : stk --> t2
  326 --
  327 --              ---> premap (\ ((xs), _stk) -> arg) fun
  328 
  329 dsCmd ids local_vars stack_ty res_ty
  330         (HsCmdArrApp arrow_ty arrow arg HsFirstOrderApp _)
  331         env_ids = do
  332     let
  333         (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
  334         (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
  335     core_arrow <- dsLExpr arrow
  336     core_arg   <- dsLExpr arg
  337     stack_id   <- newSysLocalDs Many stack_ty
  338     core_make_arg <- matchEnvStack env_ids stack_id core_arg
  339     return (do_premap ids
  340               (envStackType env_ids stack_ty)
  341               arg_ty
  342               res_ty
  343               core_make_arg
  344               core_arrow,
  345             exprFreeIdsDSet core_arg `uniqDSetIntersectUniqSet` local_vars)
  346 
  347 -- D, xs |- fun :: a t1 t2
  348 -- D, xs |- arg :: t1
  349 -- ------------------------------
  350 -- D; xs |-a fun -<< arg : stk --> t2
  351 --
  352 --              ---> premap (\ ((xs), _stk) -> (fun, arg)) app
  353 
  354 dsCmd ids local_vars stack_ty res_ty
  355         (HsCmdArrApp arrow_ty arrow arg HsHigherOrderApp _)
  356         env_ids = do
  357     let
  358         (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
  359         (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
  360 
  361     core_arrow <- dsLExpr arrow
  362     core_arg   <- dsLExpr arg
  363     stack_id   <- newSysLocalDs Many stack_ty
  364     core_make_pair <- matchEnvStack env_ids stack_id
  365           (mkCorePairExpr core_arrow core_arg)
  366 
  367     return (do_premap ids
  368               (envStackType env_ids stack_ty)
  369               (mkCorePairTy arrow_ty arg_ty)
  370               res_ty
  371               core_make_pair
  372               (do_app ids arg_ty res_ty),
  373             (exprsFreeIdsDSet [core_arrow, core_arg])
  374               `uniqDSetIntersectUniqSet` local_vars)
  375 
  376 -- D; ys |-a cmd : (t,stk) --> t'
  377 -- D, xs |-  exp :: t
  378 -- ------------------------
  379 -- D; xs |-a cmd exp : stk --> t'
  380 --
  381 --              ---> premap (\ ((xs),stk) -> ((ys),(e,stk))) cmd
  382 
  383 dsCmd ids local_vars stack_ty res_ty (HsCmdApp _ cmd arg) env_ids = do
  384     core_arg <- dsLExpr arg
  385     let
  386         arg_ty = exprType core_arg
  387         stack_ty' = mkCorePairTy arg_ty stack_ty
  388     (core_cmd, free_vars, env_ids')
  389              <- dsfixCmd ids local_vars stack_ty' res_ty cmd
  390     stack_id <- newSysLocalDs Many stack_ty
  391     arg_id <- newSysLocalDs Many arg_ty
  392     -- push the argument expression onto the stack
  393     let
  394         stack' = mkCorePairExpr (Var arg_id) (Var stack_id)
  395         core_body = bindNonRec arg_id core_arg
  396                         (mkCorePairExpr (mkBigCoreVarTup env_ids') stack')
  397 
  398     -- match the environment and stack against the input
  399     core_map <- matchEnvStack env_ids stack_id core_body
  400     return (do_premap ids
  401                       (envStackType env_ids stack_ty)
  402                       (envStackType env_ids' stack_ty')
  403                       res_ty
  404                       core_map
  405                       core_cmd,
  406             free_vars `unionDVarSet`
  407               (exprFreeIdsDSet core_arg `uniqDSetIntersectUniqSet` local_vars))
  408 
  409 dsCmd ids local_vars stack_ty res_ty
  410         (HsCmdLam _ (MG { mg_alts
  411           = (L _ [L _ (Match { m_pats  = pats
  412                              , m_grhss = GRHSs _ [L _ (GRHS _ [] body)] _ })]) }))
  413         env_ids
  414   = dsCmdLam ids local_vars stack_ty res_ty pats body env_ids
  415 
  416 dsCmd ids local_vars stack_ty res_ty (HsCmdPar _ _ cmd _) env_ids
  417   = dsLCmd ids local_vars stack_ty res_ty cmd env_ids
  418 
  419 -- D, xs |- e :: Bool
  420 -- D; xs1 |-a c1 : stk --> t
  421 -- D; xs2 |-a c2 : stk --> t
  422 -- ----------------------------------------
  423 -- D; xs |-a if e then c1 else c2 : stk --> t
  424 --
  425 --              ---> premap (\ ((xs),stk) ->
  426 --                       if e then Left ((xs1),stk) else Right ((xs2),stk))
  427 --                     (c1 ||| c2)
  428 
  429 dsCmd ids local_vars stack_ty res_ty (HsCmdIf _ mb_fun cond then_cmd else_cmd)
  430         env_ids = do
  431     core_cond <- dsLExpr cond
  432     (core_then, fvs_then, then_ids)
  433        <- dsfixCmd ids local_vars stack_ty res_ty then_cmd
  434     (core_else, fvs_else, else_ids)
  435        <- dsfixCmd ids local_vars stack_ty res_ty else_cmd
  436     stack_id   <- newSysLocalDs Many stack_ty
  437     either_con <- dsLookupTyCon eitherTyConName
  438     left_con   <- dsLookupDataCon leftDataConName
  439     right_con  <- dsLookupDataCon rightDataConName
  440 
  441     let mk_left_expr ty1 ty2 e = mkCoreConApps left_con   [Type ty1,Type ty2, e]
  442         mk_right_expr ty1 ty2 e = mkCoreConApps right_con [Type ty1,Type ty2, e]
  443 
  444         in_ty = envStackType env_ids stack_ty
  445         then_ty = envStackType then_ids stack_ty
  446         else_ty = envStackType else_ids stack_ty
  447         sum_ty = mkTyConApp either_con [then_ty, else_ty]
  448         fvs_cond = exprFreeIdsDSet core_cond
  449                    `uniqDSetIntersectUniqSet` local_vars
  450 
  451         core_left  = mk_left_expr  then_ty else_ty
  452                        (buildEnvStack then_ids stack_id)
  453         core_right = mk_right_expr then_ty else_ty
  454                        (buildEnvStack else_ids stack_id)
  455 
  456     core_if <- case mb_fun of
  457        NoSyntaxExprTc  -> matchEnvStack env_ids stack_id $
  458                           mkIfThenElse core_cond core_left core_right
  459        _ -> do { fun_apps <- dsSyntaxExpr mb_fun
  460                                       [core_cond, core_left, core_right]
  461                ; matchEnvStack env_ids stack_id fun_apps }
  462 
  463     return (do_premap ids in_ty sum_ty res_ty
  464                 core_if
  465                 (do_choice ids then_ty else_ty res_ty core_then core_else),
  466         fvs_cond `unionDVarSet` fvs_then `unionDVarSet` fvs_else)
  467 
  468 {-
  469 Case commands are treated in much the same way as if commands
  470 (see above) except that there are more alternatives.  For example
  471 
  472         case e of { p1 -> c1; p2 -> c2; p3 -> c3 }
  473 
  474 is translated to
  475 
  476         premap (\ ((xs)*ts) -> case e of
  477                 p1 -> (Left (Left (xs1)*ts))
  478                 p2 -> Left ((Right (xs2)*ts))
  479                 p3 -> Right ((xs3)*ts))
  480         ((c1 ||| c2) ||| c3)
  481 
  482 The idea is to extract the commands from the case, build a balanced tree
  483 of choices, and replace the commands with expressions that build tagged
  484 tuples, obtaining a case expression that can be desugared normally.
  485 To build all this, we use triples describing segments of the list of
  486 case bodies, containing the following fields:
  487  * a list of expressions of the form (Left|Right)* ((xs)*ts), to be put
  488    into the case replacing the commands
  489  * a sum type that is the common type of these expressions, and also the
  490    input type of the arrow
  491  * a CoreExpr for an arrow built by combining the translated command
  492    bodies with |||.
  493 -}
  494 
  495 dsCmd ids local_vars stack_ty res_ty
  496       (HsCmdCase _ exp (MG { mg_alts = L l matches
  497                            , mg_ext = MatchGroupTc arg_tys _
  498                            , mg_origin = origin }))
  499       env_ids = do
  500     stack_id <- newSysLocalDs Many stack_ty
  501 
  502     -- Extract and desugar the leaf commands in the case, building tuple
  503     -- expressions that will (after tagging) replace these leaves
  504 
  505     let
  506         leaves = concatMap leavesMatch matches
  507         make_branch (leaf, bound_vars) = do
  508             (core_leaf, _fvs, leaf_ids)
  509                <- dsfixCmd ids (bound_vars `unionVarSet` local_vars) stack_ty
  510                     res_ty leaf
  511             return ([mkHsEnvStackExpr leaf_ids stack_id],
  512                     envStackType leaf_ids stack_ty,
  513                     core_leaf)
  514 
  515     branches <- mapM make_branch leaves
  516     either_con <- dsLookupTyCon eitherTyConName
  517     left_con <- dsLookupDataCon leftDataConName
  518     right_con <- dsLookupDataCon rightDataConName
  519     let
  520         left_id  = mkConLikeTc (RealDataCon left_con)
  521         right_id = mkConLikeTc (RealDataCon right_con)
  522         left_expr  ty1 ty2 e = noLocA $ HsApp noComments
  523                            (noLocA $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e
  524         right_expr ty1 ty2 e = noLocA $ HsApp noComments
  525                            (noLocA $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e
  526 
  527         -- Prefix each tuple with a distinct series of Left's and Right's,
  528         -- in a balanced way, keeping track of the types.
  529 
  530         merge_branches :: ([LHsExpr GhcTc], Type, CoreExpr)
  531                       -> ([LHsExpr GhcTc], Type, CoreExpr)
  532                       -> ([LHsExpr GhcTc], Type, CoreExpr) -- AZ
  533         merge_branches (builds1, in_ty1, core_exp1)
  534                        (builds2, in_ty2, core_exp2)
  535           = (map (left_expr in_ty1 in_ty2) builds1 ++
  536                 map (right_expr in_ty1 in_ty2) builds2,
  537              mkTyConApp either_con [in_ty1, in_ty2],
  538              do_choice ids in_ty1 in_ty2 res_ty core_exp1 core_exp2)
  539         (leaves', sum_ty, core_choices) = foldb merge_branches branches
  540 
  541         -- Replace the commands in the case with these tagged tuples,
  542         -- yielding a HsExpr Id we can feed to dsExpr.
  543 
  544         (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches
  545         in_ty = envStackType env_ids stack_ty
  546 
  547     core_body <- dsExpr (HsCase noExtField exp
  548                          (MG { mg_alts = L l matches'
  549                              , mg_ext = MatchGroupTc arg_tys sum_ty
  550                              , mg_origin = origin }))
  551         -- Note that we replace the HsCase result type by sum_ty,
  552         -- which is the type of matches'
  553 
  554     core_matches <- matchEnvStack env_ids stack_id core_body
  555     return (do_premap ids in_ty sum_ty res_ty core_matches core_choices,
  556             exprFreeIdsDSet core_body `uniqDSetIntersectUniqSet` local_vars)
  557 
  558 dsCmd ids local_vars stack_ty res_ty
  559       (HsCmdLamCase _ mg@MG { mg_ext = MatchGroupTc [Scaled arg_mult arg_ty] _ }) env_ids = do
  560   arg_id <- newSysLocalDs arg_mult arg_ty
  561   let case_cmd  = noLocA $ HsCmdCase noExtField (nlHsVar arg_id) mg
  562   dsCmdLam ids local_vars stack_ty res_ty [nlVarPat arg_id] case_cmd env_ids
  563 
  564 -- D; ys |-a cmd : stk --> t
  565 -- ----------------------------------
  566 -- D; xs |-a let binds in cmd : stk --> t
  567 --
  568 --              ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c
  569 
  570 dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ _ lbinds@binds _ body) env_ids = do
  571     let
  572         defined_vars = mkVarSet (collectLocalBinders CollWithDictBinders binds)
  573         local_vars' = defined_vars `unionVarSet` local_vars
  574 
  575     (core_body, _free_vars, env_ids')
  576        <- dsfixCmd ids local_vars' stack_ty res_ty body
  577     stack_id <- newSysLocalDs Many stack_ty
  578     -- build a new environment, plus the stack, using the let bindings
  579     core_binds <- dsLocalBinds lbinds (buildEnvStack env_ids' stack_id)
  580     -- match the old environment and stack against the input
  581     core_map <- matchEnvStack env_ids stack_id core_binds
  582     return (do_premap ids
  583                         (envStackType env_ids stack_ty)
  584                         (envStackType env_ids' stack_ty)
  585                         res_ty
  586                         core_map
  587                         core_body,
  588         exprFreeIdsDSet core_binds `uniqDSetIntersectUniqSet` local_vars)
  589 
  590 -- D; xs |-a ss : t
  591 -- ----------------------------------
  592 -- D; xs |-a do { ss } : () --> t
  593 --
  594 --              ---> premap (\ (env,stk) -> env) c
  595 
  596 dsCmd ids local_vars stack_ty res_ty (HsCmdDo _ (L _ stmts)) env_ids = do
  597     (core_stmts, env_ids') <- dsCmdDo ids local_vars res_ty stmts env_ids
  598     let env_ty = mkBigCoreVarTupTy env_ids
  599     core_fst <- mkFstExpr env_ty stack_ty
  600     return (do_premap ids
  601                 (mkCorePairTy env_ty stack_ty)
  602                 env_ty
  603                 res_ty
  604                 core_fst
  605                 core_stmts,
  606         env_ids')
  607 
  608 -- D |- e :: forall e. a1 (e,stk1) t1 -> ... an (e,stkn) tn -> a (e,stk) t
  609 -- D; xs |-a ci :: stki --> ti
  610 -- -----------------------------------
  611 -- D; xs |-a (|e c1 ... cn|) :: stk --> t       ---> e [t_xs] c1 ... cn
  612 
  613 dsCmd _ local_vars _stack_ty _res_ty (HsCmdArrForm _ op _ _ args) env_ids = do
  614     let env_ty = mkBigCoreVarTupTy env_ids
  615     core_op <- dsLExpr op
  616     (core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args
  617     return (mkApps (App core_op (Type env_ty)) core_args,
  618             unionDVarSets fv_sets)
  619 
  620 dsCmd ids local_vars stack_ty res_ty (XCmd (HsWrap wrap cmd)) env_ids = do
  621     (core_cmd, env_ids') <- dsCmd ids local_vars stack_ty res_ty cmd env_ids
  622     core_wrap <- dsHsWrapper wrap
  623     return (core_wrap core_cmd, env_ids')
  624 
  625 dsCmd _ _ _ _ c _ = pprPanic "dsCmd" (ppr c)
  626 
  627 -- D; ys |-a c : stk --> t      (ys <= xs)
  628 -- ---------------------
  629 -- D; xs |-a c : stk --> t      ---> premap (\ ((xs),stk) -> ((ys),stk)) c
  630 
  631 dsTrimCmdArg
  632         :: IdSet                -- set of local vars available to this command
  633         -> [Id]           -- list of vars in the input to this command
  634         -> LHsCmdTop GhcTc       -- command argument to desugar
  635         -> DsM (CoreExpr,       -- desugared expression
  636                 DIdSet)         -- subset of local vars that occur free
  637 dsTrimCmdArg local_vars env_ids
  638                        (L _ (HsCmdTop
  639                                  (CmdTopTc stack_ty cmd_ty ids) cmd )) = do
  640     (meth_binds, meth_ids) <- mkCmdEnv ids
  641     (core_cmd, free_vars, env_ids')
  642        <- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd
  643     stack_id <- newSysLocalDs Many stack_ty
  644     trim_code
  645       <- matchEnvStack env_ids stack_id (buildEnvStack env_ids' stack_id)
  646     let
  647         in_ty = envStackType env_ids stack_ty
  648         in_ty' = envStackType env_ids' stack_ty
  649         arg_code = if env_ids' == env_ids then core_cmd else
  650                 do_premap meth_ids in_ty in_ty' cmd_ty trim_code core_cmd
  651     return (mkLets meth_binds arg_code, free_vars)
  652 
  653 -- Given D; xs |-a c : stk --> t, builds c with xs fed back.
  654 -- Typically needs to be prefixed with arr (\(p, stk) -> ((xs),stk))
  655 
  656 dsfixCmd
  657         :: DsCmdEnv             -- arrow combinators
  658         -> IdSet                -- set of local vars available to this command
  659         -> Type                 -- type of the stack (right-nested tuple)
  660         -> Type                 -- return type of the command
  661         -> LHsCmd GhcTc         -- command to desugar
  662         -> DsM (CoreExpr,       -- desugared expression
  663                 DIdSet,         -- subset of local vars that occur free
  664                 [Id])           -- the same local vars as a list, fed back
  665 dsfixCmd ids local_vars stk_ty cmd_ty cmd
  666   = trimInput (dsLCmd ids local_vars stk_ty cmd_ty cmd)
  667 
  668 -- Feed back the list of local variables actually used a command,
  669 -- for use as the input tuple of the generated arrow.
  670 
  671 trimInput
  672         :: ([Id] -> DsM (CoreExpr, DIdSet))
  673         -> DsM (CoreExpr,       -- desugared expression
  674                 DIdSet,         -- subset of local vars that occur free
  675                 [Id])           -- same local vars as a list, fed back to
  676                                 -- the inner function to form the tuple of
  677                                 -- inputs to the arrow.
  678 trimInput build_arrow
  679   = fixDs (\ ~(_,_,env_ids) -> do
  680         (core_cmd, free_vars) <- build_arrow env_ids
  681         return (core_cmd, free_vars, dVarSetElems free_vars))
  682 
  683 -- Desugaring for both HsCmdLam and HsCmdLamCase.
  684 --
  685 -- D; ys |-a cmd : stk t'
  686 -- -----------------------------------------------
  687 -- D; xs |-a \ p1 ... pk -> cmd : (t1,...(tk,stk)...) t'
  688 --
  689 --              ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd
  690 dsCmdLam :: DsCmdEnv            -- arrow combinators
  691          -> IdSet               -- set of local vars available to this command
  692          -> Type                -- type of the stack (right-nested tuple)
  693          -> Type                -- return type of the command
  694          -> [LPat GhcTc]        -- argument patterns to desugar
  695          -> LHsCmd GhcTc        -- body to desugar
  696          -> [Id]                -- list of vars in the input to this command
  697                                 -- This is typically fed back,
  698                                 -- so don't pull on it too early
  699          -> DsM (CoreExpr,      -- desugared expression
  700                  DIdSet)        -- subset of local vars that occur free
  701 dsCmdLam ids local_vars stack_ty res_ty pats body env_ids = do
  702     let pat_vars = mkVarSet (collectPatsBinders CollWithDictBinders pats)
  703     let local_vars' = pat_vars `unionVarSet` local_vars
  704         (pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty
  705     (core_body, free_vars, env_ids')
  706        <- dsfixCmd ids local_vars' stack_ty' res_ty body
  707     param_ids <- mapM (newSysLocalDs Many) pat_tys
  708     stack_id' <- newSysLocalDs Many stack_ty'
  709 
  710     -- the expression is built from the inside out, so the actions
  711     -- are presented in reverse order
  712 
  713     let -- build a new environment, plus what's left of the stack
  714         core_expr = buildEnvStack env_ids' stack_id'
  715         in_ty = envStackType env_ids stack_ty
  716         in_ty' = envStackType env_ids' stack_ty'
  717 
  718     fail_expr <- mkFailExpr (ArrowMatchCtxt KappaExpr) in_ty'
  719     -- match the patterns against the parameters
  720     match_code <- matchSimplys (map Var param_ids) (ArrowMatchCtxt KappaExpr) pats core_expr
  721                     fail_expr
  722     -- match the parameters against the top of the old stack
  723     (stack_id, param_code) <- matchVarStack param_ids stack_id' match_code
  724     -- match the old environment and stack against the input
  725     select_code <- matchEnvStack env_ids stack_id param_code
  726     return (do_premap ids in_ty in_ty' res_ty select_code core_body,
  727             free_vars `uniqDSetMinusUniqSet` pat_vars)
  728 
  729 {-
  730 Translation of command judgements of the form
  731 
  732         D |-a do { ss } : t
  733 -}
  734 
  735 dsCmdDo :: DsCmdEnv             -- arrow combinators
  736         -> IdSet                -- set of local vars available to this statement
  737         -> Type                 -- return type of the statement
  738         -> [CmdLStmt GhcTc]     -- statements to desugar
  739         -> [Id]                 -- list of vars in the input to this statement
  740                                 -- This is typically fed back,
  741                                 -- so don't pull on it too early
  742         -> DsM (CoreExpr,       -- desugared expression
  743                 DIdSet)         -- subset of local vars that occur free
  744 
  745 dsCmdDo _ _ _ [] _ = panic "dsCmdDo"
  746 
  747 -- D; xs |-a c : () --> t
  748 -- --------------------------
  749 -- D; xs |-a do { c } : t
  750 --
  751 --              ---> premap (\ (xs) -> ((xs), ())) c
  752 
  753 dsCmdDo ids local_vars res_ty [L _ (LastStmt _ body _ _)] env_ids = do
  754     (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids
  755     let env_ty = mkBigCoreVarTupTy env_ids
  756     env_var <- newSysLocalDs Many env_ty
  757     let core_map = Lam env_var (mkCorePairExpr (Var env_var) mkCoreUnitExpr)
  758     return (do_premap ids
  759                         env_ty
  760                         (mkCorePairTy env_ty unitTy)
  761                         res_ty
  762                         core_map
  763                         core_body,
  764         env_ids')
  765 
  766 dsCmdDo ids local_vars res_ty (stmt:stmts) env_ids = do
  767     let bound_vars  = mkVarSet (collectLStmtBinders CollWithDictBinders stmt)
  768     let local_vars' = bound_vars `unionVarSet` local_vars
  769     (core_stmts, _, env_ids') <- trimInput (dsCmdDo ids local_vars' res_ty stmts)
  770     (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids
  771     return (do_compose ids
  772                 (mkBigCoreVarTupTy env_ids)
  773                 (mkBigCoreVarTupTy env_ids')
  774                 res_ty
  775                 core_stmt
  776                 core_stmts,
  777               fv_stmt)
  778 
  779 {-
  780 A statement maps one local environment to another, and is represented
  781 as an arrow from one tuple type to another.  A statement sequence is
  782 translated to a composition of such arrows.
  783 -}
  784 
  785 dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> CmdLStmt GhcTc -> [Id]
  786            -> DsM (CoreExpr, DIdSet)
  787 dsCmdLStmt ids local_vars out_ids cmd env_ids
  788   = dsCmdStmt ids local_vars out_ids (unLoc cmd) env_ids
  789 
  790 dsCmdStmt
  791         :: DsCmdEnv             -- arrow combinators
  792         -> IdSet                -- set of local vars available to this statement
  793         -> [Id]                 -- list of vars in the output of this statement
  794         -> CmdStmt GhcTc        -- statement to desugar
  795         -> [Id]                 -- list of vars in the input to this statement
  796                                 -- This is typically fed back,
  797                                 -- so don't pull on it too early
  798         -> DsM (CoreExpr,       -- desugared expression
  799                 DIdSet)         -- subset of local vars that occur free
  800 
  801 -- D; xs1 |-a c : () --> t
  802 -- D; xs' |-a do { ss } : t'
  803 -- ------------------------------
  804 -- D; xs  |-a do { c; ss } : t'
  805 --
  806 --              ---> premap (\ ((xs)) -> (((xs1),()),(xs')))
  807 --                      (first c >>> arr snd) >>> ss
  808 
  809 dsCmdStmt ids local_vars out_ids (BodyStmt c_ty cmd _ _) env_ids = do
  810     (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy c_ty cmd
  811     core_mux <- matchEnv env_ids
  812         (mkCorePairExpr
  813             (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr)
  814             (mkBigCoreVarTup out_ids))
  815     let
  816         in_ty = mkBigCoreVarTupTy env_ids
  817         in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy
  818         out_ty = mkBigCoreVarTupTy out_ids
  819         before_c_ty = mkCorePairTy in_ty1 out_ty
  820         after_c_ty = mkCorePairTy c_ty out_ty
  821     snd_fn <- mkSndExpr c_ty out_ty
  822     return (do_premap ids in_ty before_c_ty out_ty core_mux $
  823                 do_compose ids before_c_ty after_c_ty out_ty
  824                         (do_first ids in_ty1 c_ty out_ty core_cmd) $
  825                 do_arr ids after_c_ty out_ty snd_fn,
  826               extendDVarSetList fv_cmd out_ids)
  827 
  828 -- D; xs1 |-a c : () --> t
  829 -- D; xs' |-a do { ss } : t'            xs2 = xs' - defs(p)
  830 -- -----------------------------------
  831 -- D; xs  |-a do { p <- c; ss } : t'
  832 --
  833 --              ---> premap (\ (xs) -> (((xs1),()),(xs2)))
  834 --                      (first c >>> arr (\ (p, (xs2)) -> (xs'))) >>> ss
  835 --
  836 -- It would be simpler and more consistent to do this using second,
  837 -- but that's likely to be defined in terms of first.
  838 
  839 dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd) env_ids = do
  840     let pat_ty = hsLPatType pat
  841     (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy pat_ty cmd
  842     let pat_vars = mkVarSet (collectPatBinders CollWithDictBinders pat)
  843     let
  844         env_ids2 = filterOut (`elemVarSet` pat_vars) out_ids
  845         env_ty2 = mkBigCoreVarTupTy env_ids2
  846 
  847     -- multiplexing function
  848     --          \ (xs) -> (((xs1),()),(xs2))
  849 
  850     core_mux <- matchEnv env_ids
  851         (mkCorePairExpr
  852             (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr)
  853             (mkBigCoreVarTup env_ids2))
  854 
  855     -- projection function
  856     --          \ (p, (xs2)) -> (zs)
  857 
  858     env_id <- newSysLocalDs Many env_ty2
  859     uniqs <- newUniqueSupply
  860     let
  861        after_c_ty = mkCorePairTy pat_ty env_ty2
  862        out_ty = mkBigCoreVarTupTy out_ids
  863        body_expr = coreCaseTuple uniqs env_id env_ids2 (mkBigCoreVarTup out_ids)
  864 
  865     fail_expr <- mkFailExpr (StmtCtxt (HsDoStmt (DoExpr Nothing))) out_ty
  866     pat_id    <- selectSimpleMatchVarL Many pat
  867     match_code
  868       <- matchSimply (Var pat_id) (StmtCtxt (HsDoStmt (DoExpr Nothing))) pat body_expr fail_expr
  869     pair_id   <- newSysLocalDs Many after_c_ty
  870     let
  871         proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code)
  872 
  873     -- put it all together
  874     let
  875         in_ty = mkBigCoreVarTupTy env_ids
  876         in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy
  877         in_ty2 = mkBigCoreVarTupTy env_ids2
  878         before_c_ty = mkCorePairTy in_ty1 in_ty2
  879     return (do_premap ids in_ty before_c_ty out_ty core_mux $
  880                 do_compose ids before_c_ty after_c_ty out_ty
  881                         (do_first ids in_ty1 pat_ty in_ty2 core_cmd) $
  882                 do_arr ids after_c_ty out_ty proj_expr,
  883               fv_cmd `unionDVarSet` (mkDVarSet out_ids
  884                                      `uniqDSetMinusUniqSet` pat_vars))
  885 
  886 -- D; xs' |-a do { ss } : t
  887 -- --------------------------------------
  888 -- D; xs  |-a do { let binds; ss } : t
  889 --
  890 --              ---> arr (\ (xs) -> let binds in (xs')) >>> ss
  891 
  892 dsCmdStmt ids local_vars out_ids (LetStmt _ binds) env_ids = do
  893     -- build a new environment using the let bindings
  894     core_binds <- dsLocalBinds binds (mkBigCoreVarTup out_ids)
  895     -- match the old environment against the input
  896     core_map <- matchEnv env_ids core_binds
  897     return (do_arr ids
  898                         (mkBigCoreVarTupTy env_ids)
  899                         (mkBigCoreVarTupTy out_ids)
  900                         core_map,
  901             exprFreeIdsDSet core_binds `uniqDSetIntersectUniqSet` local_vars)
  902 
  903 -- D; ys  |-a do { ss; returnA -< ((xs1), (ys2)) } : ...
  904 -- D; xs' |-a do { ss' } : t
  905 -- ------------------------------------
  906 -- D; xs  |-a do { rec ss; ss' } : t
  907 --
  908 --                      xs1 = xs' /\ defs(ss)
  909 --                      xs2 = xs' - defs(ss)
  910 --                      ys1 = ys - defs(ss)
  911 --                      ys2 = ys /\ defs(ss)
  912 --
  913 --              ---> arr (\(xs) -> ((ys1),(xs2))) >>>
  914 --                      first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>>
  915 --                      arr (\((xs1),(xs2)) -> (xs')) >>> ss'
  916 
  917 dsCmdStmt ids local_vars out_ids
  918         (RecStmt { recS_stmts = L _ stmts
  919                  , recS_later_ids = later_ids, recS_rec_ids = rec_ids
  920                  , recS_ext = RecStmtTc { recS_later_rets = later_rets
  921                                         , recS_rec_rets = rec_rets } })
  922         env_ids = do
  923     let
  924         later_ids_set = mkVarSet later_ids
  925         env2_ids = filterOut (`elemVarSet` later_ids_set) out_ids
  926         env2_id_set = mkDVarSet env2_ids
  927         env2_ty = mkBigCoreVarTupTy env2_ids
  928 
  929     -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids)
  930 
  931     uniqs <- newUniqueSupply
  932     env2_id <- newSysLocalDs Many env2_ty
  933     let
  934         later_ty = mkBigCoreVarTupTy later_ids
  935         post_pair_ty = mkCorePairTy later_ty env2_ty
  936         post_loop_body = coreCaseTuple uniqs env2_id env2_ids (mkBigCoreVarTup out_ids)
  937 
  938     post_loop_fn <- matchEnvStack later_ids env2_id post_loop_body
  939 
  940     --- loop (...)
  941 
  942     (core_loop, env1_id_set, env1_ids)
  943                <- dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets
  944 
  945     -- pre_loop_fn = \(env_ids) -> ((env1_ids),(env2_ids))
  946 
  947     let
  948         env1_ty = mkBigCoreVarTupTy env1_ids
  949         pre_pair_ty = mkCorePairTy env1_ty env2_ty
  950         pre_loop_body = mkCorePairExpr (mkBigCoreVarTup env1_ids)
  951                                         (mkBigCoreVarTup env2_ids)
  952 
  953     pre_loop_fn <- matchEnv env_ids pre_loop_body
  954 
  955     -- arr pre_loop_fn >>> first (loop (...)) >>> arr post_loop_fn
  956 
  957     let
  958         env_ty = mkBigCoreVarTupTy env_ids
  959         out_ty = mkBigCoreVarTupTy out_ids
  960         core_body = do_premap ids env_ty pre_pair_ty out_ty
  961                 pre_loop_fn
  962                 (do_compose ids pre_pair_ty post_pair_ty out_ty
  963                         (do_first ids env1_ty later_ty env2_ty
  964                                 core_loop)
  965                         (do_arr ids post_pair_ty out_ty
  966                                 post_loop_fn))
  967 
  968     return (core_body, env1_id_set `unionDVarSet` env2_id_set)
  969 
  970 dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s)
  971 
  972 --      loop (premap (\ ((env1_ids), ~(rec_ids)) -> (env_ids))
  973 --            (ss >>> arr (\ (out_ids) -> ((later_rets),(rec_rets))))) >>>
  974 
  975 dsRecCmd
  976         :: DsCmdEnv             -- arrow combinators
  977         -> IdSet                -- set of local vars available to this statement
  978         -> [CmdLStmt GhcTc]     -- list of statements inside the RecCmd
  979         -> [Id]                 -- list of vars defined here and used later
  980         -> [HsExpr GhcTc]       -- expressions corresponding to later_ids
  981         -> [Id]                 -- list of vars fed back through the loop
  982         -> [HsExpr GhcTc]       -- expressions corresponding to rec_ids
  983         -> DsM (CoreExpr,       -- desugared statement
  984                 DIdSet,         -- subset of local vars that occur free
  985                 [Id])           -- same local vars as a list
  986 
  987 dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do
  988     let
  989         later_id_set = mkVarSet later_ids
  990         rec_id_set = mkVarSet rec_ids
  991         local_vars' = rec_id_set `unionVarSet` later_id_set `unionVarSet` local_vars
  992 
  993     -- mk_pair_fn = \ (out_ids) -> ((later_rets),(rec_rets))
  994 
  995     core_later_rets <- mapM dsExpr later_rets
  996     core_rec_rets <- mapM dsExpr rec_rets
  997     let
  998         -- possibly polymorphic version of vars of later_ids and rec_ids
  999         out_ids = exprsFreeIdsList (core_later_rets ++ core_rec_rets)
 1000         out_ty = mkBigCoreVarTupTy out_ids
 1001 
 1002         later_tuple = mkBigCoreTup core_later_rets
 1003         later_ty = mkBigCoreVarTupTy later_ids
 1004 
 1005         rec_tuple = mkBigCoreTup core_rec_rets
 1006         rec_ty = mkBigCoreVarTupTy rec_ids
 1007 
 1008         out_pair = mkCorePairExpr later_tuple rec_tuple
 1009         out_pair_ty = mkCorePairTy later_ty rec_ty
 1010 
 1011     mk_pair_fn <- matchEnv out_ids out_pair
 1012 
 1013     -- ss
 1014 
 1015     (core_stmts, fv_stmts, env_ids) <- dsfixCmdStmts ids local_vars' out_ids stmts
 1016 
 1017     -- squash_pair_fn = \ ((env1_ids), ~(rec_ids)) -> (env_ids)
 1018 
 1019     rec_id <- newSysLocalDs Many rec_ty
 1020     let
 1021         env1_id_set = fv_stmts `uniqDSetMinusUniqSet` rec_id_set
 1022         env1_ids = dVarSetElems env1_id_set
 1023         env1_ty = mkBigCoreVarTupTy env1_ids
 1024         in_pair_ty = mkCorePairTy env1_ty rec_ty
 1025         core_body = mkBigCoreTup (map selectVar env_ids)
 1026           where
 1027             selectVar v
 1028                 | v `elemVarSet` rec_id_set
 1029                   = mkTupleSelector rec_ids v rec_id (Var rec_id)
 1030                 | otherwise = Var v
 1031 
 1032     squash_pair_fn <- matchEnvStack env1_ids rec_id core_body
 1033 
 1034     -- loop (premap squash_pair_fn (ss >>> arr mk_pair_fn))
 1035 
 1036     let
 1037         env_ty = mkBigCoreVarTupTy env_ids
 1038         core_loop = do_loop ids env1_ty later_ty rec_ty
 1039                 (do_premap ids in_pair_ty env_ty out_pair_ty
 1040                         squash_pair_fn
 1041                         (do_compose ids env_ty out_ty out_pair_ty
 1042                                 core_stmts
 1043                                 (do_arr ids out_ty out_pair_ty mk_pair_fn)))
 1044 
 1045     return (core_loop, env1_id_set, env1_ids)
 1046 
 1047 {-
 1048 A sequence of statements (as in a rec) is desugared to an arrow between
 1049 two environments (no stack)
 1050 -}
 1051 
 1052 dsfixCmdStmts
 1053         :: DsCmdEnv             -- arrow combinators
 1054         -> IdSet                -- set of local vars available to this statement
 1055         -> [Id]                 -- output vars of these statements
 1056         -> [CmdLStmt GhcTc]     -- statements to desugar
 1057         -> DsM (CoreExpr,       -- desugared expression
 1058                 DIdSet,         -- subset of local vars that occur free
 1059                 [Id])           -- same local vars as a list
 1060 
 1061 dsfixCmdStmts ids local_vars out_ids stmts
 1062   = trimInput (dsCmdStmts ids local_vars out_ids stmts)
 1063    -- TODO: Add representation polymorphism check for the resulting expression.
 1064    -- But I (Richard E.) don't know enough about arrows to do so.
 1065 
 1066 dsCmdStmts
 1067         :: DsCmdEnv             -- arrow combinators
 1068         -> IdSet                -- set of local vars available to this statement
 1069         -> [Id]                 -- output vars of these statements
 1070         -> [CmdLStmt GhcTc]     -- statements to desugar
 1071         -> [Id]                 -- list of vars in the input to these statements
 1072         -> DsM (CoreExpr,       -- desugared expression
 1073                 DIdSet)         -- subset of local vars that occur free
 1074 
 1075 dsCmdStmts ids local_vars out_ids [stmt] env_ids
 1076   = dsCmdLStmt ids local_vars out_ids stmt env_ids
 1077 
 1078 dsCmdStmts ids local_vars out_ids (stmt:stmts) env_ids = do
 1079     let bound_vars  = mkVarSet (collectLStmtBinders CollWithDictBinders stmt)
 1080     let local_vars' = bound_vars `unionVarSet` local_vars
 1081     (core_stmts, _fv_stmts, env_ids') <- dsfixCmdStmts ids local_vars' out_ids stmts
 1082     (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids
 1083     return (do_compose ids
 1084                 (mkBigCoreVarTupTy env_ids)
 1085                 (mkBigCoreVarTupTy env_ids')
 1086                 (mkBigCoreVarTupTy out_ids)
 1087                 core_stmt
 1088                 core_stmts,
 1089               fv_stmt)
 1090 
 1091 dsCmdStmts _ _ _ [] _ = panic "dsCmdStmts []"
 1092 
 1093 -- Match a list of expressions against a list of patterns, left-to-right.
 1094 
 1095 matchSimplys :: [CoreExpr]              -- Scrutinees
 1096              -> HsMatchContext GhcRn    -- Match kind
 1097              -> [LPat GhcTc]            -- Patterns they should match
 1098              -> CoreExpr                -- Return this if they all match
 1099              -> CoreExpr                -- Return this if they don't
 1100              -> DsM CoreExpr
 1101 matchSimplys [] _ctxt [] result_expr _fail_expr = return result_expr
 1102 matchSimplys (exp:exps) ctxt (pat:pats) result_expr fail_expr = do
 1103     match_code <- matchSimplys exps ctxt pats result_expr fail_expr
 1104     matchSimply exp ctxt pat match_code fail_expr
 1105 matchSimplys _ _ _ _ _ = panic "matchSimplys"
 1106 
 1107 -- List of leaf expressions, with set of variables bound in each
 1108 
 1109 leavesMatch :: LMatch GhcTc (LocatedA (body GhcTc))
 1110             -> [(LocatedA (body GhcTc), IdSet)]
 1111 leavesMatch (L _ (Match { m_pats = pats
 1112                         , m_grhss = GRHSs _ grhss binds }))
 1113   = let
 1114         defined_vars = mkVarSet (collectPatsBinders CollWithDictBinders pats)
 1115                         `unionVarSet`
 1116                        mkVarSet (collectLocalBinders CollWithDictBinders binds)
 1117     in
 1118     [(body,
 1119       mkVarSet (collectLStmtsBinders CollWithDictBinders stmts)
 1120         `unionVarSet` defined_vars)
 1121     | L _ (GRHS _ stmts body) <- grhss]
 1122 
 1123 -- Replace the leaf commands in a match
 1124 
 1125 replaceLeavesMatch
 1126         :: ( Anno (Match GhcTc (LocatedA (body' GhcTc))) ~ Anno (Match GhcTc (LocatedA (body GhcTc)))
 1127            , Anno (GRHS GhcTc (LocatedA (body' GhcTc))) ~ Anno (GRHS GhcTc (LocatedA (body GhcTc))))
 1128         => Type                                 -- new result type
 1129         -> [LocatedA (body' GhcTc)] -- replacement leaf expressions of that type
 1130         -> LMatch GhcTc (LocatedA (body GhcTc))  -- the matches of a case command
 1131         -> ([LocatedA (body' GhcTc)],            -- remaining leaf expressions
 1132             LMatch GhcTc (LocatedA (body' GhcTc))) -- updated match
 1133 replaceLeavesMatch _res_ty leaves
 1134                         (L loc
 1135                           match@(Match { m_grhss = GRHSs x grhss binds }))
 1136   = let
 1137         (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss
 1138     in
 1139     (leaves', L loc (match { m_ext = noAnn, m_grhss = GRHSs x grhss' binds }))
 1140 
 1141 replaceLeavesGRHS
 1142         :: ( Anno (Match GhcTc (LocatedA (body' GhcTc))) ~ Anno (Match GhcTc (LocatedA (body GhcTc)))
 1143            , Anno (GRHS GhcTc (LocatedA (body' GhcTc))) ~ Anno (GRHS GhcTc (LocatedA (body GhcTc))))
 1144         => [LocatedA (body' GhcTc)]  -- replacement leaf expressions of that type
 1145         -> LGRHS GhcTc (LocatedA (body GhcTc))     -- rhss of a case command
 1146         -> ([LocatedA (body' GhcTc)],              -- remaining leaf expressions
 1147             LGRHS GhcTc (LocatedA (body' GhcTc)))  -- updated GRHS
 1148 replaceLeavesGRHS (leaf:leaves) (L loc (GRHS x stmts _))
 1149   = (leaves, L loc (GRHS x stmts leaf))
 1150 replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []"
 1151 
 1152 -- Balanced fold of a non-empty list.
 1153 
 1154 foldb :: (a -> a -> a) -> [a] -> a
 1155 foldb _ [] = error "foldb of empty list"
 1156 foldb _ [x] = x
 1157 foldb f xs = foldb f (fold_pairs xs)
 1158   where
 1159     fold_pairs [] = []
 1160     fold_pairs [x] = [x]
 1161     fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs