    {-
    (c) The University of Glasgow 2006
    (c) The GRASP/AQUA Project, Glasgow University, 1992-1998

    Desugaring arrow commands
    -}

    {-# LANGUAGE CPP #-}
    {-# LANGUAGE TypeFamilies #-}
    {-# LANGUAGE ViewPatterns #-}

    {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}

    module GHC.HsToCore.Arrows ( dsProcExpr ) where

    #include "HsVersions.h"

    import GHC.Prelude

    import GHC.HsToCore.Match
    import GHC.HsToCore.Utils
    import GHC.HsToCore.Monad

    import GHC.Hs   hiding (collectPatBinders, collectPatsBinders,
                            collectLStmtsBinders, collectLStmtBinders,
                            collectStmtBinders )
    import GHC.Tc.Utils.Zonk
    import qualified GHC.Hs.Utils as HsUtils

    -- NB: The desugarer, which straddles the source and Core worlds, sometimes
    --     needs to see source types (newtypes etc), and sometimes not
    --     So WATCH OUT; check each use of split*Ty functions.
    -- Sigh.  This is a pain.

    import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds,
                                              dsSyntaxExpr )

    import GHC.Tc.Utils.TcType
    import GHC.Core.Type( splitPiTy )
    import GHC.Core.Multiplicity
    import GHC.Tc.Types.Evidence
    import GHC.Core
    import GHC.Core.FVs
    import GHC.Core.Utils
    import GHC.Core.Make
    import GHC.HsToCore.Binds (dsHsWrapper)

    import GHC.Types.Id
    import GHC.Core.ConLike
    import GHC.Builtin.Types
    import GHC.Types.Basic
    import GHC.Builtin.Names
    import GHC.Utils.Outputable
    import GHC.Types.Var.Set
    import GHC.Types.SrcLoc
    import GHC.Data.List.SetOps( assocMaybe )
    import Data.List
    import GHC.Utils.Misc
    import GHC.Types.Unique.DSet

    data DsCmdEnv = DsCmdEnv {
            DsCmdEnv -> CoreExpr
    arr_id, DsCmdEnv -> CoreExpr
    compose_id, DsCmdEnv -> CoreExpr
    first_id, DsCmdEnv -> CoreExpr
    app_id, DsCmdEnv -> CoreExpr
    choice_id, DsCmdEnv -> CoreExpr
    loop_id :: CoreExpr
        }

    mkCmdEnv :: CmdSyntaxTable GhcTc -> DsM ([CoreBind], DsCmdEnv)
    -- See Note [CmdSyntaxTable] in GHC.Hs.Expr
    mkCmdEnv :: CmdSyntaxTable (GhcPass 'Typechecked) -> DsM ([CoreBind], DsCmdEnv)
    mkCmdEnv CmdSyntaxTable (GhcPass 'Typechecked)
    tc_meths
      = do { ([CoreBind]
    meth_binds, [(Name, Id)]
    prs) <- ((Name, HsExpr (GhcPass 'Typechecked))
     -> IOEnv (Env DsGblEnv DsLclEnv) (CoreBind, (Name, Id)))
    -> CmdSyntaxTable (GhcPass 'Typechecked)
    -> IOEnv (Env DsGblEnv DsLclEnv) ([CoreBind], [(Name, Id)])
    forall (m :: * -> *) a b c.
    Applicative m =>
    (a -> m (b, c)) -> [a] -> m ([b], [c])
    mapAndUnzipM (Name, HsExpr (GhcPass 'Typechecked))
    -> IOEnv (Env DsGblEnv DsLclEnv) (CoreBind, (Name, Id))
    forall {a}.
    (a, HsExpr (GhcPass 'Typechecked))
    -> IOEnv (Env DsGblEnv DsLclEnv) (CoreBind, (a, Id))
    mk_bind CmdSyntaxTable (GhcPass 'Typechecked)
    tc_meths

           -- NB: Some of these lookups might fail, but that's OK if the
           -- symbol is never used. That's why we use Maybe first and then
           -- panic. An eager panic caused trouble in typecheck/should_compile/tc192
           ; let the_arr_id :: Maybe Id
    the_arr_id     = [(Name, Id)] -> Name -> Maybe Id
    forall a b. Eq a => Assoc a b -> a -> Maybe b
    assocMaybe [(Name, Id)]
    prs Name
    arrAName
                 the_compose_id :: Maybe Id
    the_compose_id = [(Name, Id)] -> Name -> Maybe Id
    forall a b. Eq a => Assoc a b -> a -> Maybe b
    assocMaybe [(Name, Id)]
    prs Name
    composeAName
                 the_first_id :: Maybe Id
    the_first_id   = [(Name, Id)] -> Name -> Maybe Id
    forall a b. Eq a => Assoc a b -> a -> Maybe b
    assocMaybe [(Name, Id)]
    prs Name
    firstAName
                 the_app_id :: Maybe Id
    the_app_id     = [(Name, Id)] -> Name -> Maybe Id
    forall a b. Eq a => Assoc a b -> a -> Maybe b
    assocMaybe [(Name, Id)]
    prs Name
    appAName
                 the_choice_id :: Maybe Id
    the_choice_id  = [(Name, Id)] -> Name -> Maybe Id
    forall a b. Eq a => Assoc a b -> a -> Maybe b
    assocMaybe [(Name, Id)]
    prs Name
    choiceAName
                 the_loop_id :: Maybe Id
    the_loop_id    = [(Name, Id)] -> Name -> Maybe Id
    forall a b. Eq a => Assoc a b -> a -> Maybe b
    assocMaybe [(Name, Id)]
    prs Name
    loopAName

               -- used as an argument in, e.g., do_premap
           ; Int -> Maybe Id -> DsM ()
    check_lev_poly Int
    3 Maybe Id
    the_arr_id

               -- used as an argument in, e.g., dsCmdStmt/BodyStmt
           ; Int -> Maybe Id -> DsM ()
    check_lev_poly Int
    5 Maybe Id
    the_compose_id

               -- used as an argument in, e.g., dsCmdStmt/BodyStmt
           ; Int -> Maybe Id -> DsM ()
    check_lev_poly Int
    4 Maybe Id
    the_first_id

               -- the result of the_app_id is used as an argument in, e.g.,
               -- dsCmd/HsCmdArrApp/HsHigherOrderApp
           ; Int -> Maybe Id -> DsM ()
    check_lev_poly Int
    2 Maybe Id
    the_app_id

               -- used as an argument in, e.g., HsCmdIf
           ; Int -> Maybe Id -> DsM ()
    check_lev_poly Int
    5 Maybe Id
    the_choice_id

               -- used as an argument in, e.g., RecStmt
           ; Int -> Maybe Id -> DsM ()
    check_lev_poly Int
    4 Maybe Id
    the_loop_id

           ; ([CoreBind], DsCmdEnv) -> DsM ([CoreBind], DsCmdEnv)
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([CoreBind]
    meth_binds, DsCmdEnv :: CoreExpr
    -> CoreExpr
    -> CoreExpr
    -> CoreExpr
    -> CoreExpr
    -> CoreExpr
    -> DsCmdEnv
    DsCmdEnv {
                   arr_id :: CoreExpr
    arr_id     = Id -> CoreExpr
    forall b. Id -> Expr b
    Var (Maybe Id -> Name -> Id
    forall {a} {a}. Outputable a => Maybe a -> a -> a
    unmaybe Maybe Id
    the_arr_id Name
    arrAName),
                   compose_id :: CoreExpr
    compose_id = Id -> CoreExpr
    forall b. Id -> Expr b
    Var (Maybe Id -> Name -> Id
    forall {a} {a}. Outputable a => Maybe a -> a -> a
    unmaybe Maybe Id
    the_compose_id Name
    composeAName),
                   first_id :: CoreExpr
    first_id   = Id -> CoreExpr
    forall b. Id -> Expr b
    Var (Maybe Id -> Name -> Id
    forall {a} {a}. Outputable a => Maybe a -> a -> a
    unmaybe Maybe Id
    the_first_id Name
    firstAName),
                   app_id :: CoreExpr
    app_id     = Id -> CoreExpr
    forall b. Id -> Expr b
    Var (Maybe Id -> Name -> Id
    forall {a} {a}. Outputable a => Maybe a -> a -> a
    unmaybe Maybe Id
    the_app_id Name
    appAName),
                   choice_id :: CoreExpr
    choice_id  = Id -> CoreExpr
    forall b. Id -> Expr b
    Var (Maybe Id -> Name -> Id
    forall {a} {a}. Outputable a => Maybe a -> a -> a
    unmaybe Maybe Id
    the_choice_id Name
    choiceAName),
                   loop_id :: CoreExpr
    loop_id    = Id -> CoreExpr
    forall b. Id -> Expr b
    Var (Maybe Id -> Name -> Id
    forall {a} {a}. Outputable a => Maybe a -> a -> a
    unmaybe Maybe Id
    the_loop_id Name
    loopAName)
                 }) }
      where
        mk_bind :: (a, HsExpr (GhcPass 'Typechecked))
    -> IOEnv (Env DsGblEnv DsLclEnv) (CoreBind, (a, Id))
    mk_bind (a
    std_name, HsExpr (GhcPass 'Typechecked)
    expr)
          = do { CoreExpr
    rhs <- HsExpr (GhcPass 'Typechecked) -> DsM CoreExpr
    dsExpr HsExpr (GhcPass 'Typechecked)
    expr
               ; Id
    id <- Type -> Type -> DsM Id
    newSysLocalDs Type
    Many (CoreExpr -> Type
    exprType CoreExpr
    rhs)
               -- no check needed; these are functions
               ; (CoreBind, (a, Id))
    -> IOEnv (Env DsGblEnv DsLclEnv) (CoreBind, (a, Id))
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Id -> CoreExpr -> CoreBind
    forall b. b -> Expr b -> Bind b
    NonRec Id
    id CoreExpr
    rhs, (a
    std_name, Id
    id)) }

        unmaybe :: Maybe a -> a -> a
    unmaybe Maybe a
    Nothing a
    name = String -> SDoc -> a
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "mkCmdEnv" (String -> SDoc
    text String
    "Not found:" SDoc -> SDoc -> SDoc
    <+> a -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr a
    name)
        unmaybe (Just a
    id) a
    _  = a
    id

          -- returns the result type of a pi-type (that is, a forall or a function)
          -- Note that this result type may be ill-scoped.
        res_type :: Type -> Type
        res_type :: Type -> Type
    res_type Type
    ty = Type
    res_ty
          where
            (TyCoBinder
    _, Type
    res_ty) = Type -> (TyCoBinder, Type)
    splitPiTy Type
    ty

        check_lev_poly :: Int -- arity
                       -> Maybe Id -> DsM ()
        check_lev_poly :: Int -> Maybe Id -> DsM ()
    check_lev_poly Int
    _     Maybe Id
    Nothing = () -> DsM ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
        check_lev_poly Int
    arity (Just Id
    id)
          = Type -> SDoc -> DsM ()
    dsNoLevPoly (Int -> (Type -> Type) -> Type -> Type
    forall a. Int -> (a -> a) -> a -> a
    nTimes Int
    arity Type -> Type
    res_type (Id -> Type
    idType Id
    id))
              (String -> SDoc
    text String
    "In the result of the function" SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    quotes (Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Id
    id))

    -- arr :: forall b c. (b -> c) -> a b c
    do_arr :: DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr
    do_arr :: DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr
    do_arr DsCmdEnv
    ids Type
    b_ty Type
    c_ty CoreExpr
    f = CoreExpr -> [CoreExpr] -> CoreExpr
    forall b. Expr b -> [Expr b] -> Expr b
    mkApps (DsCmdEnv -> CoreExpr
    arr_id DsCmdEnv
    ids) [Type -> CoreExpr
    forall b. Type -> Expr b
    Type Type
    b_ty, Type -> CoreExpr
    forall b. Type -> Expr b
    Type Type
    c_ty, CoreExpr
    f]

    -- (>>>) :: forall b c d. a b c -> a c d -> a b d
    do_compose :: DsCmdEnv -> Type -> Type -> Type ->
                    CoreExpr -> CoreExpr -> CoreExpr
    do_compose :: DsCmdEnv
    -> Type -> Type -> Type -> CoreExpr -> CoreExpr -> CoreExpr
    do_compose DsCmdEnv
    ids Type
    b_ty Type
    c_ty Type
    d_ty CoreExpr
    f CoreExpr
    g
      = CoreExpr -> [CoreExpr] -> CoreExpr
    forall b. Expr b -> [Expr b] -> Expr b
    mkApps (DsCmdEnv -> CoreExpr
    compose_id DsCmdEnv
    ids) [Type -> CoreExpr
    forall b. Type -> Expr b
    Type Type
    b_ty, Type -> CoreExpr
    forall b. Type -> Expr b
    Type Type
    c_ty, Type -> CoreExpr
    forall b. Type -> Expr b
    Type Type
    d_ty, CoreExpr
    f, CoreExpr
    g]

    -- first :: forall b c d. a b c -> a (b,d) (c,d)
    do_first :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr
    do_first :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr
    do_first DsCmdEnv
    ids Type
    b_ty Type
    c_ty Type
    d_ty CoreExpr
    f
      = CoreExpr -> [CoreExpr] -> CoreExpr
    forall b. Expr b -> [Expr b] -> Expr b
    mkApps (DsCmdEnv -> CoreExpr
    first_id DsCmdEnv
    ids) [Type -> CoreExpr
    forall b. Type -> Expr b
    Type Type
    b_ty, Type -> CoreExpr
    forall b. Type -> Expr b
    Type Type
    c_ty, Type -> CoreExpr
    forall b. Type -> Expr b
    Type Type
    d_ty, CoreExpr
    f]

    -- app :: forall b c. a (a b c, b) c
    do_app :: DsCmdEnv -> Type -> Type -> CoreExpr
    do_app :: DsCmdEnv -> Type -> Type -> CoreExpr
    do_app DsCmdEnv
    ids Type
    b_ty Type
    c_ty = CoreExpr -> [CoreExpr] -> CoreExpr
    forall b. Expr b -> [Expr b] -> Expr b
    mkApps (DsCmdEnv -> CoreExpr
    app_id DsCmdEnv
    ids) [Type -> CoreExpr
    forall b. Type -> Expr b
    Type Type
    b_ty, Type -> CoreExpr
    forall b. Type -> Expr b
    Type Type
    c_ty]

    -- (|||) :: forall b d c. a b d -> a c d -> a (Either b c) d
    -- note the swapping of d and c
    do_choice :: DsCmdEnv -> Type -> Type -> Type ->
                    CoreExpr -> CoreExpr -> CoreExpr
    do_choice :: DsCmdEnv
    -> Type -> Type -> Type -> CoreExpr -> CoreExpr -> CoreExpr
    do_choice DsCmdEnv
    ids Type
    b_ty Type
    c_ty Type
    d_ty CoreExpr
    f CoreExpr
    g
      = CoreExpr -> [CoreExpr] -> CoreExpr
    forall b. Expr b -> [Expr b] -> Expr b
    mkApps (DsCmdEnv -> CoreExpr
    choice_id DsCmdEnv
    ids) [Type -> CoreExpr
    forall b. Type -> Expr b
    Type Type
    b_ty, Type -> CoreExpr
    forall b. Type -> Expr b
    Type Type
    d_ty, Type -> CoreExpr
    forall b. Type -> Expr b
    Type Type
    c_ty, CoreExpr
    f, CoreExpr
    g]

    -- loop :: forall b d c. a (b,d) (c,d) -> a b c
    -- note the swapping of d and c
    do_loop :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr
    do_loop :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr
    do_loop DsCmdEnv
    ids Type
    b_ty Type
    c_ty Type
    d_ty CoreExpr
    f
      = CoreExpr -> [CoreExpr] -> CoreExpr
    forall b. Expr b -> [Expr b] -> Expr b
    mkApps (DsCmdEnv -> CoreExpr
    loop_id DsCmdEnv
    ids) [Type -> CoreExpr
    forall b. Type -> Expr b
    Type Type
    b_ty, Type -> CoreExpr
    forall b. Type -> Expr b
    Type Type
    d_ty, Type -> CoreExpr
    forall b. Type -> Expr b
    Type Type
    c_ty, CoreExpr
    f]

    -- premap :: forall b c d. (b -> c) -> a c d -> a b d
    -- premap f g = arr f >>> g
    do_premap :: DsCmdEnv -> Type -> Type -> Type ->
                    CoreExpr -> CoreExpr -> CoreExpr
    do_premap :: DsCmdEnv
    -> Type -> Type -> Type -> CoreExpr -> CoreExpr -> CoreExpr
    do_premap DsCmdEnv
    ids Type
    b_ty Type
    c_ty Type
    d_ty CoreExpr
    f CoreExpr
    g
       = DsCmdEnv
    -> Type -> Type -> Type -> CoreExpr -> CoreExpr -> CoreExpr
    do_compose DsCmdEnv
    ids Type
    b_ty Type
    c_ty Type
    d_ty (DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr
    do_arr DsCmdEnv
    ids Type
    b_ty Type
    c_ty CoreExpr
    f) CoreExpr
    g

    mkFailExpr :: HsMatchContext GhcRn -> Type -> DsM CoreExpr
    mkFailExpr :: HsMatchContext GhcRn -> Type -> DsM CoreExpr
    mkFailExpr HsMatchContext GhcRn
    ctxt Type
    ty
      = Id -> Type -> SDoc -> DsM CoreExpr
    mkErrorAppDs Id
    pAT_ERROR_ID Type
    ty (HsMatchContext GhcRn -> SDoc
    forall (p :: Pass).
    OutputableBndrId p =>
    HsMatchContext (GhcPass p) -> SDoc
    matchContextErrString HsMatchContext GhcRn
    ctxt)

    -- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> a
    mkFstExpr :: Type -> Type -> DsM CoreExpr
    mkFstExpr :: Type -> Type -> DsM CoreExpr
    mkFstExpr Type
    a_ty Type
    b_ty = do
        Id
    a_var <- Type -> Type -> DsM Id
    newSysLocalDs Type
    Many Type
    a_ty
        Id
    b_var <- Type -> Type -> DsM Id
    newSysLocalDs Type
    Many Type
    b_ty
        Id
    pair_var <- Type -> Type -> DsM Id
    newSysLocalDs Type
    Many (Type -> Type -> Type
    mkCorePairTy Type
    a_ty Type
    b_ty)
        CoreExpr -> DsM CoreExpr
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Id -> CoreExpr -> CoreExpr
    forall b. b -> Expr b -> Expr b
    Lam Id
    pair_var
                   (Id -> Id -> Id -> CoreExpr -> CoreExpr
    coreCasePair Id
    pair_var Id
    a_var Id
    b_var (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    a_var)))

    -- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> b
    mkSndExpr :: Type -> Type -> DsM CoreExpr
    mkSndExpr :: Type -> Type -> DsM CoreExpr
    mkSndExpr Type
    a_ty Type
    b_ty = do
        Id
    a_var <- Type -> Type -> DsM Id
    newSysLocalDs Type
    Many Type
    a_ty
        Id
    b_var <- Type -> Type -> DsM Id
    newSysLocalDs Type
    Many Type
    b_ty
        Id
    pair_var <- Type -> Type -> DsM Id
    newSysLocalDs Type
    Many (Type -> Type -> Type
    mkCorePairTy Type
    a_ty Type
    b_ty)
        CoreExpr -> DsM CoreExpr
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Id -> CoreExpr -> CoreExpr
    forall b. b -> Expr b -> Expr b
    Lam Id
    pair_var
                   (Id -> Id -> Id -> CoreExpr -> CoreExpr
    coreCasePair Id
    pair_var Id
    a_var Id
    b_var (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    b_var)))

    {-
    Build case analysis of a tuple.  This cannot be done in the DsM monad,
    because the list of variables is typically not yet defined.
    -}

    -- coreCaseTuple [u1..] v [x1..xn] body
    --      = case v of v { (x1, .., xn) -> body }
    -- But the matching may be nested if the tuple is very big

    coreCaseTuple :: UniqSupply -> Id -> [Id] -> CoreExpr -> CoreExpr
    coreCaseTuple :: UniqSupply -> Id -> [Id] -> CoreExpr -> CoreExpr
    coreCaseTuple UniqSupply
    uniqs Id
    scrut_var [Id]
    vars CoreExpr
    body
      = UniqSupply -> [Id] -> CoreExpr -> Id -> CoreExpr -> CoreExpr
    mkTupleCase UniqSupply
    uniqs [Id]
    vars CoreExpr
    body Id
    scrut_var (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    scrut_var)

    coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr
    coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr
    coreCasePair Id
    scrut_var Id
    var1 Id
    var2 CoreExpr
    body
      = CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
    forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
    Case (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    scrut_var) Id
    scrut_var (CoreExpr -> Type
    exprType CoreExpr
    body)
             [(DataCon -> AltCon
    DataAlt (Boxity -> Int -> DataCon
    tupleDataCon Boxity
    Boxed Int
    2), [Id
    var1, Id
    var2], CoreExpr
    body)]

    mkCorePairTy :: Type -> Type -> Type
    mkCorePairTy :: Type -> Type -> Type
    mkCorePairTy Type
    t1 Type
    t2 = [Type] -> Type
    mkBoxedTupleTy [Type
    t1, Type
    t2]

    mkCorePairExpr :: CoreExpr -> CoreExpr -> CoreExpr
    mkCorePairExpr :: CoreExpr -> CoreExpr -> CoreExpr
    mkCorePairExpr CoreExpr
    e1 CoreExpr
    e2 = [CoreExpr] -> CoreExpr
    mkCoreTup [CoreExpr
    e1, CoreExpr
    e2]

    mkCoreUnitExpr :: CoreExpr
    mkCoreUnitExpr :: CoreExpr
    mkCoreUnitExpr = [CoreExpr] -> CoreExpr
    mkCoreTup []

    {-
    The input is divided into a local environment, which is a flat tuple
    (unless it's too big), and a stack, which is a right-nested pair.
    In general, the input has the form

            ((x1,...,xn), (s1,...(sk,())...))

    where xi are the environment values, and si the ones on the stack,
    with s1 being the "top", the first one to be matched with a lambda.
    -}

    envStackType :: [Id] -> Type -> Type
    envStackType :: [Id] -> Type -> Type
    envStackType [Id]
    ids Type
    stack_ty = Type -> Type -> Type
    mkCorePairTy ([Id] -> Type
    mkBigCoreVarTupTy [Id]
    ids) Type
    stack_ty

    -- splitTypeAt n (t1,... (tn,t)...) = ([t1, ..., tn], t)
    splitTypeAt :: Int -> Type -> ([Type], Type)
    splitTypeAt :: Int -> Type -> ([Type], Type)
    splitTypeAt Int
    n Type
    ty
      | Int
    n Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    0 = ([], Type
    ty)
      | Bool
    otherwise = case Type -> [Type]
    tcTyConAppArgs Type
    ty of
          [Type
    t, Type
    ty'] -> let ([Type]
    ts, Type
    ty_r) = Int -> Type -> ([Type], Type)
    splitTypeAt (Int
    nInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -Int
    1) Type
    ty' in (Type
    tType -> [Type] -> [Type]
    forall a. a -> [a] -> [a]
    :[Type]
    ts, Type
    ty_r)
          [Type]
    _ -> String -> SDoc -> ([Type], Type)
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "splitTypeAt" (Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    ty)

    ----------------------------------------------
    --              buildEnvStack
    --
    --      ((x1,...,xn),stk)

    buildEnvStack :: [Id] -> Id -> CoreExpr
    buildEnvStack :: [Id] -> Id -> CoreExpr
    buildEnvStack [Id]
    env_ids Id
    stack_id
      = CoreExpr -> CoreExpr -> CoreExpr
    mkCorePairExpr ([Id] -> CoreExpr
    mkBigCoreVarTup [Id]
    env_ids) (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    stack_id)

    ----------------------------------------------
    --              matchEnvStack
    --
    --      \ ((x1,...,xn),stk) -> body
    --      =>
    --      \ pair ->
    --      case pair of (tup,stk) ->
    --      case tup of (x1,...,xn) ->
    --      body

    matchEnvStack   :: [Id]         -- x1..xn
                    -> Id           -- stk
                    -> CoreExpr     -- e
                    -> DsM CoreExpr
    matchEnvStack :: [Id] -> Id -> CoreExpr -> DsM CoreExpr
    matchEnvStack [Id]
    env_ids Id
    stack_id CoreExpr
    body = do
        UniqSupply
    uniqs <- TcRnIf DsGblEnv DsLclEnv UniqSupply
    forall gbl lcl. TcRnIf gbl lcl UniqSupply
    newUniqueSupply
        Id
    tup_var <- Type -> Type -> DsM Id
    newSysLocalDs Type
    Many ([Id] -> Type
    mkBigCoreVarTupTy [Id]
    env_ids)
        let match_env :: CoreExpr
    match_env = UniqSupply -> Id -> [Id] -> CoreExpr -> CoreExpr
    coreCaseTuple UniqSupply
    uniqs Id
    tup_var [Id]
    env_ids CoreExpr
    body
        Id
    pair_id <- Type -> Type -> DsM Id
    newSysLocalDs Type
    Many (Type -> Type -> Type
    mkCorePairTy (Id -> Type
    idType Id
    tup_var) (Id -> Type
    idType Id
    stack_id))
        CoreExpr -> DsM CoreExpr
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Id -> CoreExpr -> CoreExpr
    forall b. b -> Expr b -> Expr b
    Lam Id
    pair_id (Id -> Id -> Id -> CoreExpr -> CoreExpr
    coreCasePair Id
    pair_id Id
    tup_var Id
    stack_id CoreExpr
    match_env))

    ----------------------------------------------
    --              matchEnv
    --
    --      \ (x1,...,xn) -> body
    --      =>
    --      \ tup ->
    --      case tup of (x1,...,xn) ->
    --      body

    matchEnv :: [Id]        -- x1..xn
             -> CoreExpr    -- e
             -> DsM CoreExpr
    matchEnv :: [Id] -> CoreExpr -> DsM CoreExpr
    matchEnv [Id]
    env_ids CoreExpr
    body = do
        UniqSupply
    uniqs <- TcRnIf DsGblEnv DsLclEnv UniqSupply
    forall gbl lcl. TcRnIf gbl lcl UniqSupply
    newUniqueSupply
        Id
    tup_id <- Type -> Type -> DsM Id
    newSysLocalDs Type
    Many ([Id] -> Type
    mkBigCoreVarTupTy [Id]
    env_ids)
        CoreExpr -> DsM CoreExpr
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Id -> CoreExpr -> CoreExpr
    forall b. b -> Expr b -> Expr b
    Lam Id
    tup_id (UniqSupply -> Id -> [Id] -> CoreExpr -> CoreExpr
    coreCaseTuple UniqSupply
    uniqs Id
    tup_id [Id]
    env_ids CoreExpr
    body))

    ----------------------------------------------
    --              matchVarStack
    --
    --      case (x1, ...(xn, s)...) -> e
    --      =>
    --      case z0 of (x1,z1) ->
    --      case zn-1 of (xn,s) ->
    --      e
    matchVarStack :: [Id] -> Id -> CoreExpr -> DsM (Id, CoreExpr)
    matchVarStack :: [Id] -> Id -> CoreExpr -> DsM (Id, CoreExpr)
    matchVarStack [] Id
    stack_id CoreExpr
    body = (Id, CoreExpr) -> DsM (Id, CoreExpr)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Id
    stack_id, CoreExpr
    body)
    matchVarStack (Id
    param_id:[Id]
    param_ids) Id
    stack_id CoreExpr
    body = do
        (Id
    tail_id, CoreExpr
    tail_code) <- [Id] -> Id -> CoreExpr -> DsM (Id, CoreExpr)
    matchVarStack [Id]
    param_ids Id
    stack_id CoreExpr
    body
        Id
    pair_id <- Type -> Type -> DsM Id
    newSysLocalDs Type
    Many (Type -> Type -> Type
    mkCorePairTy (Id -> Type
    idType Id
    param_id) (Id -> Type
    idType Id
    tail_id))
        (Id, CoreExpr) -> DsM (Id, CoreExpr)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Id
    pair_id, Id -> Id -> Id -> CoreExpr -> CoreExpr
    coreCasePair Id
    pair_id Id
    param_id Id
    tail_id CoreExpr
    tail_code)

    mkHsEnvStackExpr :: [Id] -> Id -> LHsExpr GhcTc
    mkHsEnvStackExpr :: [Id] -> Id -> LHsExpr (GhcPass 'Typechecked)
    mkHsEnvStackExpr [Id]
    env_ids Id
    stack_id
      = [LHsExpr (GhcPass 'Typechecked)] -> LHsExpr (GhcPass 'Typechecked)
    forall (a :: Pass). [LHsExpr (GhcPass a)] -> LHsExpr (GhcPass a)
    mkLHsTupleExpr [[IdP (GhcPass 'Typechecked)] -> LHsExpr (GhcPass 'Typechecked)
    forall (a :: Pass). [IdP (GhcPass a)] -> LHsExpr (GhcPass a)
    mkLHsVarTuple [Id]
    [IdP (GhcPass 'Typechecked)]
    env_ids, IdP (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
    forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
    nlHsVar Id
    IdP (GhcPass 'Typechecked)
    stack_id]

    -- Translation of arrow abstraction

    -- D; xs |-a c : () --> t'      ---> c'
    -- --------------------------
    -- D |- proc p -> c :: a t t'   ---> premap (\ p -> ((xs),())) c'
    --
    --              where (xs) is the tuple of variables bound by p

    dsProcExpr
            :: LPat GhcTc
            -> LHsCmdTop GhcTc
            -> DsM CoreExpr
    dsProcExpr :: LPat (GhcPass 'Typechecked)
    -> LHsCmdTop (GhcPass 'Typechecked) -> DsM CoreExpr
    dsProcExpr LPat (GhcPass 'Typechecked)
    pat (L SrcSpan
    _ (HsCmdTop (CmdTopTc Type
    _unitTy Type
    cmd_ty CmdSyntaxTable (GhcPass 'Typechecked)
    ids) LHsCmd (GhcPass 'Typechecked)
    cmd)) = do
        ([CoreBind]
    meth_binds, DsCmdEnv
    meth_ids) <- CmdSyntaxTable (GhcPass 'Typechecked) -> DsM ([CoreBind], DsCmdEnv)
    mkCmdEnv CmdSyntaxTable (GhcPass 'Typechecked)
    ids
        let locals :: VarSet
    locals = [Id] -> VarSet
    mkVarSet (LPat (GhcPass 'Typechecked) -> [Id]
    collectPatBinders LPat (GhcPass 'Typechecked)
    pat)
        (CoreExpr
    core_cmd, DIdSet
    _free_vars, [Id]
    env_ids)
           <- DsCmdEnv
    -> VarSet
    -> Type
    -> Type
    -> LHsCmd (GhcPass 'Typechecked)
    -> DsM (CoreExpr, DIdSet, [Id])
    dsfixCmd DsCmdEnv
    meth_ids VarSet
    locals Type
    unitTy Type
    cmd_ty LHsCmd (GhcPass 'Typechecked)
    cmd
        let env_ty :: Type
    env_ty = [Id] -> Type
    mkBigCoreVarTupTy [Id]
    env_ids
        let env_stk_ty :: Type
    env_stk_ty = Type -> Type -> Type
    mkCorePairTy Type
    env_ty Type
    unitTy
        let env_stk_expr :: CoreExpr
    env_stk_expr = CoreExpr -> CoreExpr -> CoreExpr
    mkCorePairExpr ([Id] -> CoreExpr
    mkBigCoreVarTup [Id]
    env_ids) CoreExpr
    mkCoreUnitExpr
        CoreExpr
    fail_expr <- HsMatchContext GhcRn -> Type -> DsM CoreExpr
    mkFailExpr HsMatchContext GhcRn
    forall p. HsMatchContext p
    ProcExpr Type
    env_stk_ty
        Id
    var <- Type -> LPat (GhcPass 'Typechecked) -> DsM Id
    selectSimpleMatchVarL Type
    Many LPat (GhcPass 'Typechecked)
    pat
        CoreExpr
    match_code <- CoreExpr
    -> HsMatchContext GhcRn
    -> LPat (GhcPass 'Typechecked)
    -> CoreExpr
    -> CoreExpr
    -> DsM CoreExpr
    matchSimply (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    var) HsMatchContext GhcRn
    forall p. HsMatchContext p
    ProcExpr LPat (GhcPass 'Typechecked)
    pat CoreExpr
    env_stk_expr CoreExpr
    fail_expr
        let pat_ty :: Type
    pat_ty = LPat (GhcPass 'Typechecked) -> Type
    hsLPatType LPat (GhcPass 'Typechecked)
    pat
        let proc_code :: CoreExpr
    proc_code = DsCmdEnv
    -> Type -> Type -> Type -> CoreExpr -> CoreExpr -> CoreExpr
    do_premap DsCmdEnv
    meth_ids Type
    pat_ty Type
    env_stk_ty Type
    cmd_ty
                        (Id -> CoreExpr -> CoreExpr
    forall b. b -> Expr b -> Expr b
    Lam Id
    var CoreExpr
    match_code)
                        CoreExpr
    core_cmd
        CoreExpr -> DsM CoreExpr
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([CoreBind] -> CoreExpr -> CoreExpr
    forall b. [Bind b] -> Expr b -> Expr b
    mkLets [CoreBind]
    meth_binds CoreExpr
    proc_code)

    {-
    Translation of a command judgement of the form

            D; xs |-a c : stk --> t

    to an expression e such that

            D |- e :: a (xs, stk) t
    -}

    dsLCmd :: DsCmdEnv -> IdSet -> Type -> Type -> LHsCmd GhcTc -> [Id]
           -> DsM (CoreExpr, DIdSet)
    dsLCmd :: DsCmdEnv
    -> VarSet
    -> Type
    -> Type
    -> LHsCmd (GhcPass 'Typechecked)
    -> [Id]
    -> DsM (CoreExpr, DIdSet)
    dsLCmd DsCmdEnv
    ids VarSet
    local_vars Type
    stk_ty Type
    res_ty LHsCmd (GhcPass 'Typechecked)
    cmd [Id]
    env_ids
      = DsCmdEnv
    -> VarSet
    -> Type
    -> Type
    -> HsCmd (GhcPass 'Typechecked)
    -> [Id]
    -> DsM (CoreExpr, DIdSet)
    dsCmd DsCmdEnv
    ids VarSet
    local_vars Type
    stk_ty Type
    res_ty (LHsCmd (GhcPass 'Typechecked) -> HsCmd (GhcPass 'Typechecked)
    forall l e. GenLocated l e -> e
    unLoc LHsCmd (GhcPass 'Typechecked)
    cmd) [Id]
    env_ids

    dsCmd   :: DsCmdEnv             -- arrow combinators
            -> IdSet                -- set of local vars available to this command
            -> Type                 -- type of the stack (right-nested tuple)
            -> Type                 -- return type of the command
            -> HsCmd GhcTc           -- command to desugar
            -> [Id]           -- list of vars in the input to this command
                                    -- This is typically fed back,
                                    -- so don't pull on it too early
            -> DsM (CoreExpr,       -- desugared expression
                    DIdSet)         -- subset of local vars that occur free

    -- D |- fun :: a t1 t2
    -- D, xs |- arg :: t1
    -- -----------------------------
    -- D; xs |-a fun -< arg : stk --> t2
    --
    --              ---> premap (\ ((xs), _stk) -> arg) fun

    dsCmd :: DsCmdEnv
    -> VarSet
    -> Type
    -> Type
    -> HsCmd (GhcPass 'Typechecked)
    -> [Id]
    -> DsM (CoreExpr, DIdSet)
    dsCmd DsCmdEnv
    ids VarSet
    local_vars Type
    stack_ty Type
    res_ty
            (HsCmdArrApp XCmdArrApp (GhcPass 'Typechecked)
    arrow_ty LHsExpr (GhcPass 'Typechecked)
    arrow LHsExpr (GhcPass 'Typechecked)
    arg HsArrAppType
    HsFirstOrderApp Bool
    _)
            [Id]
    env_ids = do
        let
            (Type
    a_arg_ty, Type
    _res_ty') = Type -> (Type, Type)
    tcSplitAppTy Type
    XCmdArrApp (GhcPass 'Typechecked)
    arrow_ty
            (Type
    _a_ty, Type
    arg_ty) = Type -> (Type, Type)
    tcSplitAppTy Type
    a_arg_ty
        CoreExpr
    core_arrow <- LHsExpr (GhcPass 'Typechecked) -> DsM CoreExpr
    dsLExprNoLP LHsExpr (GhcPass 'Typechecked)
    arrow
        CoreExpr
    core_arg   <- LHsExpr (GhcPass 'Typechecked) -> DsM CoreExpr
    dsLExpr LHsExpr (GhcPass 'Typechecked)
    arg
        Id
    stack_id   <- Type -> Type -> DsM Id
    newSysLocalDs Type
    Many Type
    stack_ty
        CoreExpr
    core_make_arg <- [Id] -> Id -> CoreExpr -> DsM CoreExpr
    matchEnvStack [Id]
    env_ids Id
    stack_id CoreExpr
    core_arg
        (CoreExpr, DIdSet) -> DsM (CoreExpr, DIdSet)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (DsCmdEnv
    -> Type -> Type -> Type -> CoreExpr -> CoreExpr -> CoreExpr
    do_premap DsCmdEnv
    ids
                  ([Id] -> Type -> Type
    envStackType [Id]
    env_ids Type
    stack_ty)
                  Type
    arg_ty
                  Type
    res_ty
                  CoreExpr
    core_make_arg
                  CoreExpr
    core_arrow,
                CoreExpr -> DIdSet
    exprFreeIdsDSet CoreExpr
    core_arg DIdSet -> VarSet -> DIdSet
    forall a. UniqDSet a -> UniqSet a -> UniqDSet a
    `uniqDSetIntersectUniqSet` VarSet
    local_vars)

    -- D, xs |- fun :: a t1 t2
    -- D, xs |- arg :: t1
    -- ------------------------------
    -- D; xs |-a fun -<< arg : stk --> t2
    --
    --              ---> premap (\ ((xs), _stk) -> (fun, arg)) app

    dsCmd DsCmdEnv
    ids VarSet
    local_vars Type
    stack_ty Type
    res_ty
            (HsCmdArrApp XCmdArrApp (GhcPass 'Typechecked)
    arrow_ty LHsExpr (GhcPass 'Typechecked)
    arrow LHsExpr (GhcPass 'Typechecked)
    arg HsArrAppType
    HsHigherOrderApp Bool
    _)
            [Id]
    env_ids = do
        let
            (Type
    a_arg_ty, Type
    _res_ty') = Type -> (Type, Type)
    tcSplitAppTy Type
    XCmdArrApp (GhcPass 'Typechecked)
    arrow_ty
            (Type
    _a_ty, Type
    arg_ty) = Type -> (Type, Type)
    tcSplitAppTy Type
    a_arg_ty

        CoreExpr
    core_arrow <- LHsExpr (GhcPass 'Typechecked) -> DsM CoreExpr
    dsLExpr LHsExpr (GhcPass 'Typechecked)
    arrow
        CoreExpr
    core_arg   <- LHsExpr (GhcPass 'Typechecked) -> DsM CoreExpr
    dsLExpr LHsExpr (GhcPass 'Typechecked)
    arg
        Id
    stack_id   <- Type -> Type -> DsM Id
    newSysLocalDs Type
    Many Type
    stack_ty
        CoreExpr
    core_make_pair <- [Id] -> Id -> CoreExpr -> DsM CoreExpr
    matchEnvStack [Id]
    env_ids Id
    stack_id
              (CoreExpr -> CoreExpr -> CoreExpr
    mkCorePairExpr CoreExpr
    core_arrow CoreExpr
    core_arg)

        (CoreExpr, DIdSet) -> DsM (CoreExpr, DIdSet)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (DsCmdEnv
    -> Type -> Type -> Type -> CoreExpr -> CoreExpr -> CoreExpr
    do_premap DsCmdEnv
    ids
                  ([Id] -> Type -> Type
    envStackType [Id]
    env_ids Type
    stack_ty)
                  (Type -> Type -> Type
    mkCorePairTy Type
    XCmdArrApp (GhcPass 'Typechecked)
    arrow_ty Type
    arg_ty)
                  Type
    res_ty
                  CoreExpr
    core_make_pair
                  (DsCmdEnv -> Type -> Type -> CoreExpr
    do_app DsCmdEnv
    ids Type
    arg_ty Type
    res_ty),
                ([CoreExpr] -> DIdSet
    exprsFreeIdsDSet [CoreExpr
    core_arrow, CoreExpr
    core_arg])
                  DIdSet -> VarSet -> DIdSet
    forall a. UniqDSet a -> UniqSet a -> UniqDSet a
    `uniqDSetIntersectUniqSet` VarSet
    local_vars)

    -- D; ys |-a cmd : (t,stk) --> t'
    -- D, xs |-  exp :: t
    -- ------------------------
    -- D; xs |-a cmd exp : stk --> t'
    --
    --              ---> premap (\ ((xs),stk) -> ((ys),(e,stk))) cmd

    dsCmd DsCmdEnv
    ids VarSet
    local_vars Type
    stack_ty Type
    res_ty (HsCmdApp XCmdApp (GhcPass 'Typechecked)
    _ LHsCmd (GhcPass 'Typechecked)
    cmd LHsExpr (GhcPass 'Typechecked)
    arg) [Id]
    env_ids = do
        CoreExpr
    core_arg <- LHsExpr (GhcPass 'Typechecked) -> DsM CoreExpr
    dsLExpr LHsExpr (GhcPass 'Typechecked)
    arg
        let
            arg_ty :: Type
    arg_ty = CoreExpr -> Type
    exprType CoreExpr
    core_arg
            stack_ty' :: Type
    stack_ty' = Type -> Type -> Type
    mkCorePairTy Type
    arg_ty Type
    stack_ty
        (CoreExpr
    core_cmd, DIdSet
    free_vars, [Id]
    env_ids')
                 <- DsCmdEnv
    -> VarSet
    -> Type
    -> Type
    -> LHsCmd (GhcPass 'Typechecked)
    -> DsM (CoreExpr, DIdSet, [Id])
    dsfixCmd DsCmdEnv
    ids VarSet
    local_vars Type
    stack_ty' Type
    res_ty LHsCmd (GhcPass 'Typechecked)
    cmd
        Id
    stack_id <- Type -> Type -> DsM Id
    newSysLocalDs Type
    Many Type
    stack_ty
        Id
    arg_id <- Type -> Type -> DsM Id
    newSysLocalDsNoLP Type
    Many Type
    arg_ty
        -- push the argument expression onto the stack
        let
            stack' :: CoreExpr
    stack' = CoreExpr -> CoreExpr -> CoreExpr
    mkCorePairExpr (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    arg_id) (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    stack_id)
            core_body :: CoreExpr
    core_body = Id -> CoreExpr -> CoreExpr -> CoreExpr
    bindNonRec Id
    arg_id CoreExpr
    core_arg
                            (CoreExpr -> CoreExpr -> CoreExpr
    mkCorePairExpr ([Id] -> CoreExpr
    mkBigCoreVarTup [Id]
    env_ids') CoreExpr
    stack')

        -- match the environment and stack against the input
        CoreExpr
    core_map <- [Id] -> Id -> CoreExpr -> DsM CoreExpr
    matchEnvStack [Id]
    env_ids Id
    stack_id CoreExpr
    core_body
        (CoreExpr, DIdSet) -> DsM (CoreExpr, DIdSet)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (DsCmdEnv
    -> Type -> Type -> Type -> CoreExpr -> CoreExpr -> CoreExpr
    do_premap DsCmdEnv
    ids
                          ([Id] -> Type -> Type
    envStackType [Id]
    env_ids Type
    stack_ty)
                          ([Id] -> Type -> Type
    envStackType [Id]
    env_ids' Type
    stack_ty')
                          Type
    res_ty
                          CoreExpr
    core_map
                          CoreExpr
    core_cmd,
                DIdSet
    free_vars DIdSet -> DIdSet -> DIdSet
    `unionDVarSet`
                  (CoreExpr -> DIdSet
    exprFreeIdsDSet CoreExpr
    core_arg DIdSet -> VarSet -> DIdSet
    forall a. UniqDSet a -> UniqSet a -> UniqDSet a
    `uniqDSetIntersectUniqSet` VarSet
    local_vars))

    dsCmd DsCmdEnv
    ids VarSet
    local_vars Type
    stack_ty Type
    res_ty
            (HsCmdLam XCmdLam (GhcPass 'Typechecked)
    _ (MG { mg_alts :: forall p body. MatchGroup p body -> Located [LMatch p body]
    mg_alts
              = (L SrcSpan
    _ [L SrcSpan
    _ (Match { m_pats :: forall p body. Match p body -> [LPat p]
    m_pats  = [LPat (GhcPass 'Typechecked)]
    pats
                                 , m_grhss :: forall p body. Match p body -> GRHSs p body
    m_grhss = GRHSs XCGRHSs (GhcPass 'Typechecked) (LHsCmd (GhcPass 'Typechecked))
    _ [L SrcSpan
    _ (GRHS XCGRHS (GhcPass 'Typechecked) (LHsCmd (GhcPass 'Typechecked))
    _ [] LHsCmd (GhcPass 'Typechecked)
    body)] LHsLocalBinds (GhcPass 'Typechecked)
    _ })]) }))
            [Id]
    env_ids
      = DsCmdEnv
    -> VarSet
    -> Type
    -> Type
    -> [LPat (GhcPass 'Typechecked)]
    -> LHsCmd (GhcPass 'Typechecked)
    -> [Id]
    -> DsM (CoreExpr, DIdSet)
    dsCmdLam DsCmdEnv
    ids VarSet
    local_vars Type
    stack_ty Type
    res_ty [LPat (GhcPass 'Typechecked)]
    pats LHsCmd (GhcPass 'Typechecked)
    body [Id]
    env_ids

    dsCmd DsCmdEnv
    ids VarSet
    local_vars Type
    stack_ty Type
    res_ty (HsCmdPar XCmdPar (GhcPass 'Typechecked)
    _ LHsCmd (GhcPass 'Typechecked)
    cmd) [Id]
    env_ids
      = DsCmdEnv
    -> VarSet
    -> Type
    -> Type
    -> LHsCmd (GhcPass 'Typechecked)
    -> [Id]
    -> DsM (CoreExpr, DIdSet)
    dsLCmd DsCmdEnv
    ids VarSet
    local_vars Type
    stack_ty Type
    res_ty LHsCmd (GhcPass 'Typechecked)
    cmd [Id]
    env_ids

    -- D, xs |- e :: Bool
    -- D; xs1 |-a c1 : stk --> t
    -- D; xs2 |-a c2 : stk --> t
    -- ----------------------------------------
    -- D; xs |-a if e then c1 else c2 : stk --> t
    --
    --              ---> premap (\ ((xs),stk) ->
    --                       if e then Left ((xs1),stk) else Right ((xs2),stk))
    --                     (c1 ||| c2)

    dsCmd DsCmdEnv
    ids VarSet
    local_vars Type
    stack_ty Type
    res_ty (HsCmdIf XCmdIf (GhcPass 'Typechecked)
    _ SyntaxExpr (GhcPass 'Typechecked)
    mb_fun LHsExpr (GhcPass 'Typechecked)
    cond LHsCmd (GhcPass 'Typechecked)
    then_cmd LHsCmd (GhcPass 'Typechecked)
    else_cmd)
            [Id]
    env_ids = do
        CoreExpr
    core_cond <- LHsExpr (GhcPass 'Typechecked) -> DsM CoreExpr
    dsLExpr LHsExpr (GhcPass 'Typechecked)
    cond
        (CoreExpr
    core_then, DIdSet
    fvs_then, [Id]
    then_ids)
           <- DsCmdEnv
    -> VarSet
    -> Type
    -> Type
    -> LHsCmd (GhcPass 'Typechecked)
    -> DsM (CoreExpr, DIdSet, [Id])
    dsfixCmd DsCmdEnv
    ids VarSet
    local_vars Type
    stack_ty Type
    res_ty LHsCmd (GhcPass 'Typechecked)
    then_cmd
        (CoreExpr
    core_else, DIdSet
    fvs_else, [Id]
    else_ids)
           <- DsCmdEnv
    -> VarSet
    -> Type
    -> Type
    -> LHsCmd (GhcPass 'Typechecked)
    -> DsM (CoreExpr, DIdSet, [Id])
    dsfixCmd DsCmdEnv
    ids VarSet
    local_vars Type
    stack_ty Type
    res_ty LHsCmd (GhcPass 'Typechecked)
    else_cmd
        Id
    stack_id   <- Type -> Type -> DsM Id
    newSysLocalDs Type
    Many Type
    stack_ty
        TyCon
    either_con <- Name -> DsM TyCon
    dsLookupTyCon Name
    eitherTyConName
        DataCon
    left_con   <- Name -> DsM DataCon
    dsLookupDataCon Name
    leftDataConName
        DataCon
    right_con  <- Name -> DsM DataCon
    dsLookupDataCon Name
    rightDataConName

        let mk_left_expr :: Type -> Type -> CoreExpr -> CoreExpr
    mk_left_expr Type
    ty1 Type
    ty2 CoreExpr
    e = DataCon -> [CoreExpr] -> CoreExpr
    mkCoreConApps DataCon
    left_con   [Type -> CoreExpr
    forall b. Type -> Expr b
    Type Type
    ty1,Type -> CoreExpr
    forall b. Type -> Expr b
    Type Type
    ty2, CoreExpr
    e]
            mk_right_expr :: Type -> Type -> CoreExpr -> CoreExpr
    mk_right_expr Type
    ty1 Type
    ty2 CoreExpr
    e = DataCon -> [CoreExpr] -> CoreExpr
    mkCoreConApps DataCon
    right_con [Type -> CoreExpr
    forall b. Type -> Expr b
    Type Type
    ty1,Type -> CoreExpr
    forall b. Type -> Expr b
    Type Type
    ty2, CoreExpr
    e]

            in_ty :: Type
    in_ty = [Id] -> Type -> Type
    envStackType [Id]
    env_ids Type
    stack_ty
            then_ty :: Type
    then_ty = [Id] -> Type -> Type
    envStackType [Id]
    then_ids Type
    stack_ty
            else_ty :: Type
    else_ty = [Id] -> Type -> Type
    envStackType [Id]
    else_ids Type
    stack_ty
            sum_ty :: Type
    sum_ty = TyCon -> [Type] -> Type
    mkTyConApp TyCon
    either_con [Type
    then_ty, Type
    else_ty]
            fvs_cond :: DIdSet
    fvs_cond = CoreExpr -> DIdSet
    exprFreeIdsDSet CoreExpr
    core_cond
                       DIdSet -> VarSet -> DIdSet
    forall a. UniqDSet a -> UniqSet a -> UniqDSet a
    `uniqDSetIntersectUniqSet` VarSet
    local_vars

            core_left :: CoreExpr
    core_left  = Type -> Type -> CoreExpr -> CoreExpr
    mk_left_expr  Type
    then_ty Type
    else_ty
                           ([Id] -> Id -> CoreExpr
    buildEnvStack [Id]
    then_ids Id
    stack_id)
            core_right :: CoreExpr
    core_right = Type -> Type -> CoreExpr -> CoreExpr
    mk_right_expr Type
    then_ty Type
    else_ty
                           ([Id] -> Id -> CoreExpr
    buildEnvStack [Id]
    else_ids Id
    stack_id)

        CoreExpr
    core_if <- case SyntaxExpr (GhcPass 'Typechecked)
    mb_fun of
           SyntaxExpr (GhcPass 'Typechecked)
    SyntaxExprTc
    NoSyntaxExprTc  -> [Id] -> Id -> CoreExpr -> DsM CoreExpr
    matchEnvStack [Id]
    env_ids Id
    stack_id (CoreExpr -> DsM CoreExpr) -> CoreExpr -> DsM CoreExpr
    forall a b. (a -> b) -> a -> b
    $
                              CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
    mkIfThenElse CoreExpr
    core_cond CoreExpr
    core_left CoreExpr
    core_right
           SyntaxExpr (GhcPass 'Typechecked)
    _ -> do { CoreExpr
    fun_apps <- SyntaxExpr (GhcPass 'Typechecked) -> [CoreExpr] -> DsM CoreExpr
    dsSyntaxExpr SyntaxExpr (GhcPass 'Typechecked)
    mb_fun
                                          [CoreExpr
    core_cond, CoreExpr
    core_left, CoreExpr
    core_right]
                   ; [Id] -> Id -> CoreExpr -> DsM CoreExpr
    matchEnvStack [Id]
    env_ids Id
    stack_id CoreExpr
    fun_apps }

        (CoreExpr, DIdSet) -> DsM (CoreExpr, DIdSet)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (DsCmdEnv
    -> Type -> Type -> Type -> CoreExpr -> CoreExpr -> CoreExpr
    do_premap DsCmdEnv
    ids Type
    in_ty Type
    sum_ty Type
    res_ty
                    CoreExpr
    core_if
                    (DsCmdEnv
    -> Type -> Type -> Type -> CoreExpr -> CoreExpr -> CoreExpr
    do_choice DsCmdEnv
    ids Type
    then_ty Type
    else_ty Type
    res_ty CoreExpr
    core_then CoreExpr
    core_else),
            DIdSet
    fvs_cond DIdSet -> DIdSet -> DIdSet
    `unionDVarSet` DIdSet
    fvs_then DIdSet -> DIdSet -> DIdSet
    `unionDVarSet` DIdSet
    fvs_else)

    {-
    Case commands are treated in much the same way as if commands
    (see above) except that there are more alternatives.  For example

            case e of { p1 -> c1; p2 -> c2; p3 -> c3 }

    is translated to

            premap (\ ((xs)*ts) -> case e of
                    p1 -> (Left (Left (xs1)*ts))
                    p2 -> Left ((Right (xs2)*ts))
                    p3 -> Right ((xs3)*ts))
            ((c1 ||| c2) ||| c3)

    The idea is to extract the commands from the case, build a balanced tree
    of choices, and replace the commands with expressions that build tagged
    tuples, obtaining a case expression that can be desugared normally.
    To build all this, we use triples describing segments of the list of
    case bodies, containing the following fields:
     * a list of expressions of the form (Left|Right)* ((xs)*ts), to be put
       into the case replacing the commands
     * a sum type that is the common type of these expressions, and also the
       input type of the arrow
     * a CoreExpr for an arrow built by combining the translated command
       bodies with |||.
    -}

    dsCmd DsCmdEnv
    ids VarSet
    local_vars Type
    stack_ty Type
    res_ty
          (HsCmdCase XCmdCase (GhcPass 'Typechecked)
    _ LHsExpr (GhcPass 'Typechecked)
    exp (MG { mg_alts :: forall p body. MatchGroup p body -> Located [LMatch p body]
    mg_alts = L SrcSpan
    l [LMatch (GhcPass 'Typechecked) (LHsCmd (GhcPass 'Typechecked))]
    matches
                               , mg_ext :: forall p body. MatchGroup p body -> XMG p body
    mg_ext = MatchGroupTc [Scaled Type]
    arg_tys Type
    _
                               , mg_origin :: forall p body. MatchGroup p body -> Origin
    mg_origin = Origin
    origin }))
          [Id]
    env_ids = do
        Id
    stack_id <- Type -> Type -> DsM Id
    newSysLocalDs Type
    Many Type
    stack_ty

        -- Extract and desugar the leaf commands in the case, building tuple
        -- expressions that will (after tagging) replace these leaves

        let
            leaves :: [(LHsCmd (GhcPass 'Typechecked), VarSet)]
    leaves = (LMatch (GhcPass 'Typechecked) (LHsCmd (GhcPass 'Typechecked))
     -> [(LHsCmd (GhcPass 'Typechecked), VarSet)])
    -> [LMatch (GhcPass 'Typechecked) (LHsCmd (GhcPass 'Typechecked))]
    -> [(LHsCmd (GhcPass 'Typechecked), VarSet)]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap LMatch (GhcPass 'Typechecked) (LHsCmd (GhcPass 'Typechecked))
    -> [(LHsCmd (GhcPass 'Typechecked), VarSet)]
    forall (body :: * -> *).
    LMatch
      (GhcPass 'Typechecked) (Located (body (GhcPass 'Typechecked)))
    -> [(Located (body (GhcPass 'Typechecked)), VarSet)]
    leavesMatch [LMatch (GhcPass 'Typechecked) (LHsCmd (GhcPass 'Typechecked))]
    matches
            make_branch :: (LHsCmd (GhcPass 'Typechecked), VarSet)
    -> IOEnv
         (Env DsGblEnv DsLclEnv)
         ([LHsExpr (GhcPass 'Typechecked)], Type, CoreExpr)
    make_branch (LHsCmd (GhcPass 'Typechecked)
    leaf, VarSet
    bound_vars) = do
                (CoreExpr
    core_leaf, DIdSet
    _fvs, [Id]
    leaf_ids)
                   <- DsCmdEnv
    -> VarSet
    -> Type
    -> Type
    -> LHsCmd (GhcPass 'Typechecked)
    -> DsM (CoreExpr, DIdSet, [Id])
    dsfixCmd DsCmdEnv
    ids (VarSet
    bound_vars VarSet -> VarSet -> VarSet
    `unionVarSet` VarSet
    local_vars) Type
    stack_ty
                        Type
    res_ty LHsCmd (GhcPass 'Typechecked)
    leaf
                ([LHsExpr (GhcPass 'Typechecked)], Type, CoreExpr)
    -> IOEnv
         (Env DsGblEnv DsLclEnv)
         ([LHsExpr (GhcPass 'Typechecked)], Type, CoreExpr)
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([[Id] -> Id -> LHsExpr (GhcPass 'Typechecked)
    mkHsEnvStackExpr [Id]
    leaf_ids Id
    stack_id],
                        [Id] -> Type -> Type
    envStackType [Id]
    leaf_ids Type
    stack_ty,
                        CoreExpr
    core_leaf)

        [([LHsExpr (GhcPass 'Typechecked)], Type, CoreExpr)]
    branches <- ((LHsCmd (GhcPass 'Typechecked), VarSet)
     -> IOEnv
          (Env DsGblEnv DsLclEnv)
          ([LHsExpr (GhcPass 'Typechecked)], Type, CoreExpr))
    -> [(LHsCmd (GhcPass 'Typechecked), VarSet)]
    -> IOEnv
         (Env DsGblEnv DsLclEnv)
         [([LHsExpr (GhcPass 'Typechecked)], Type, CoreExpr)]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM (LHsCmd (GhcPass 'Typechecked), VarSet)
    -> IOEnv
         (Env DsGblEnv DsLclEnv)
         ([LHsExpr (GhcPass 'Typechecked)], Type, CoreExpr)
    make_branch [(LHsCmd (GhcPass 'Typechecked), VarSet)]
    leaves
        TyCon
    either_con <- Name -> DsM TyCon
    dsLookupTyCon Name
    eitherTyConName
        DataCon
    left_con <- Name -> DsM DataCon
    dsLookupDataCon Name
    leftDataConName
        DataCon
    right_con <- Name -> DsM DataCon
    dsLookupDataCon Name
    rightDataConName
        let
            left_id :: HsExpr (GhcPass 'Typechecked)
    left_id  = XConLikeOut (GhcPass 'Typechecked)
    -> ConLike -> HsExpr (GhcPass 'Typechecked)
    forall p. XConLikeOut p -> ConLike -> HsExpr p
    HsConLikeOut NoExtField
    XConLikeOut (GhcPass 'Typechecked)
    noExtField (DataCon -> ConLike
    RealDataCon DataCon
    left_con)
            right_id :: HsExpr (GhcPass 'Typechecked)
    right_id = XConLikeOut (GhcPass 'Typechecked)
    -> ConLike -> HsExpr (GhcPass 'Typechecked)
    forall p. XConLikeOut p -> ConLike -> HsExpr p
    HsConLikeOut NoExtField
    XConLikeOut (GhcPass 'Typechecked)
    noExtField (DataCon -> ConLike
    RealDataCon DataCon
    right_con)
            left_expr :: Type
    -> Type
    -> LHsExpr (GhcPass 'Typechecked)
    -> LHsExpr (GhcPass 'Typechecked)
    left_expr  Type
    ty1 Type
    ty2 LHsExpr (GhcPass 'Typechecked)
    e = HsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
    forall e. e -> Located e
    noLoc (HsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked))
    -> HsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
    forall a b. (a -> b) -> a -> b
    $ XApp (GhcPass 'Typechecked)
    -> LHsExpr (GhcPass 'Typechecked)
    -> LHsExpr (GhcPass 'Typechecked)
    -> HsExpr (GhcPass 'Typechecked)
    forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
    HsApp NoExtField
    XApp (GhcPass 'Typechecked)
    noExtField
                               (HsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
    forall e. e -> Located e
    noLoc (HsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked))
    -> HsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
    forall a b. (a -> b) -> a -> b
    $ HsWrapper
    -> HsExpr (GhcPass 'Typechecked) -> HsExpr (GhcPass 'Typechecked)
    mkHsWrap ([Type] -> HsWrapper
    mkWpTyApps [Type
    ty1, Type
    ty2]) HsExpr (GhcPass 'Typechecked)
    left_id ) LHsExpr (GhcPass 'Typechecked)
    e
            right_expr :: Type
    -> Type
    -> LHsExpr (GhcPass 'Typechecked)
    -> LHsExpr (GhcPass 'Typechecked)
    right_expr Type
    ty1 Type
    ty2 LHsExpr (GhcPass 'Typechecked)
    e = HsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
    forall e. e -> Located e
    noLoc (HsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked))
    -> HsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
    forall a b. (a -> b) -> a -> b
    $ XApp (GhcPass 'Typechecked)
    -> LHsExpr (GhcPass 'Typechecked)
    -> LHsExpr (GhcPass 'Typechecked)
    -> HsExpr (GhcPass 'Typechecked)
    forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
    HsApp NoExtField
    XApp (GhcPass 'Typechecked)
    noExtField
                               (HsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
    forall e. e -> Located e
    noLoc (HsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked))
    -> HsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
    forall a b. (a -> b) -> a -> b
    $ HsWrapper
    -> HsExpr (GhcPass 'Typechecked) -> HsExpr (GhcPass 'Typechecked)
    mkHsWrap ([Type] -> HsWrapper
    mkWpTyApps [Type
    ty1, Type
    ty2]) HsExpr (GhcPass 'Typechecked)
    right_id) LHsExpr (GhcPass 'Typechecked)
    e

            -- Prefix each tuple with a distinct series of Left's and Right's,
            -- in a balanced way, keeping track of the types.

            merge_branches :: ([LHsExpr (GhcPass 'Typechecked)], Type, CoreExpr)
    -> ([LHsExpr (GhcPass 'Typechecked)], Type, CoreExpr)
    -> ([LHsExpr (GhcPass 'Typechecked)], Type, CoreExpr)
    merge_branches ([LHsExpr (GhcPass 'Typechecked)]
    builds1, Type
    in_ty1, CoreExpr
    core_exp1)
                           ([LHsExpr (GhcPass 'Typechecked)]
    builds2, Type
    in_ty2, CoreExpr
    core_exp2)
              = ((LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked))
    -> [LHsExpr (GhcPass 'Typechecked)]
    -> [LHsExpr (GhcPass 'Typechecked)]
    forall a b. (a -> b) -> [a] -> [b]
    map (Type
    -> Type
    -> LHsExpr (GhcPass 'Typechecked)
    -> LHsExpr (GhcPass 'Typechecked)
    left_expr Type
    in_ty1 Type
    in_ty2) [LHsExpr (GhcPass 'Typechecked)]
    builds1 [LHsExpr (GhcPass 'Typechecked)]
    -> [LHsExpr (GhcPass 'Typechecked)]
    -> [LHsExpr (GhcPass 'Typechecked)]
    forall a. [a] -> [a] -> [a]
    ++
                    (LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked))
    -> [LHsExpr (GhcPass 'Typechecked)]
    -> [LHsExpr (GhcPass 'Typechecked)]
    forall a b. (a -> b) -> [a] -> [b]
    map (Type
    -> Type
    -> LHsExpr (GhcPass 'Typechecked)
    -> LHsExpr (GhcPass 'Typechecked)
    right_expr Type
    in_ty1 Type
    in_ty2) [LHsExpr (GhcPass 'Typechecked)]
    builds2,
                 TyCon -> [Type] -> Type
    mkTyConApp TyCon
    either_con [Type
    in_ty1, Type
    in_ty2],
                 DsCmdEnv
    -> Type -> Type -> Type -> CoreExpr -> CoreExpr -> CoreExpr
    do_choice DsCmdEnv
    ids Type
    in_ty1 Type
    in_ty2 Type
    res_ty CoreExpr
    core_exp1 CoreExpr
    core_exp2)
            ([LHsExpr (GhcPass 'Typechecked)]
    leaves', Type
    sum_ty, CoreExpr
    core_choices) = (([LHsExpr (GhcPass 'Typechecked)], Type, CoreExpr)
     -> ([LHsExpr (GhcPass 'Typechecked)], Type, CoreExpr)
     -> ([LHsExpr (GhcPass 'Typechecked)], Type, CoreExpr))
    -> [([LHsExpr (GhcPass 'Typechecked)], Type, CoreExpr)]
    -> ([LHsExpr (GhcPass 'Typechecked)], Type, CoreExpr)
    forall a. (a -> a -> a) -> [a] -> a
    foldb ([LHsExpr (GhcPass 'Typechecked)], Type, CoreExpr)
    -> ([LHsExpr (GhcPass 'Typechecked)], Type, CoreExpr)
    -> ([LHsExpr (GhcPass 'Typechecked)], Type, CoreExpr)
    merge_branches [([LHsExpr (GhcPass 'Typechecked)], Type, CoreExpr)]
    branches

            -- Replace the commands in the case with these tagged tuples,
            -- yielding a HsExpr Id we can feed to dsExpr.

            ([LHsExpr (GhcPass 'Typechecked)]
    _, [LMatch (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked))]
    matches') = ([LHsExpr (GhcPass 'Typechecked)]
     -> LMatch (GhcPass 'Typechecked) (LHsCmd (GhcPass 'Typechecked))
     -> ([LHsExpr (GhcPass 'Typechecked)],
         LMatch (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked))))
    -> [LHsExpr (GhcPass 'Typechecked)]
    -> [LMatch (GhcPass 'Typechecked) (LHsCmd (GhcPass 'Typechecked))]
    -> ([LHsExpr (GhcPass 'Typechecked)],
        [LMatch (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked))])
    forall (t :: * -> *) s a b.
    Traversable t =>
    (s -> a -> (s, b)) -> s -> t a -> (s, t b)
    mapAccumL (Type
    -> [LHsExpr (GhcPass 'Typechecked)]
    -> LMatch (GhcPass 'Typechecked) (LHsCmd (GhcPass 'Typechecked))
    -> ([LHsExpr (GhcPass 'Typechecked)],
        LMatch (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked)))
    forall (body' :: * -> *) (body :: * -> *).
    Type
    -> [Located (body' (GhcPass 'Typechecked))]
    -> LMatch
         (GhcPass 'Typechecked) (Located (body (GhcPass 'Typechecked)))
    -> ([Located (body' (GhcPass 'Typechecked))],
        LMatch
          (GhcPass 'Typechecked) (Located (body' (GhcPass 'Typechecked))))
    replaceLeavesMatch Type
    res_ty) [LHsExpr (GhcPass 'Typechecked)]
    leaves' [LMatch (GhcPass 'Typechecked) (LHsCmd (GhcPass 'Typechecked))]
    matches
            in_ty :: Type
    in_ty = [Id] -> Type -> Type
    envStackType [Id]
    env_ids Type
    stack_ty

        CoreExpr
    core_body <- HsExpr (GhcPass 'Typechecked) -> DsM CoreExpr
    dsExpr (XCase (GhcPass 'Typechecked)
    -> LHsExpr (GhcPass 'Typechecked)
    -> MatchGroup
         (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked))
    -> HsExpr (GhcPass 'Typechecked)
    forall p.
    XCase p -> LHsExpr p -> MatchGroup p (LHsExpr p) -> HsExpr p
    HsCase NoExtField
    XCase (GhcPass 'Typechecked)
    noExtField LHsExpr (GhcPass 'Typechecked)
    exp
                             (MG :: forall p body.
    XMG p body
    -> Located [LMatch p body] -> Origin -> MatchGroup p body
    MG { mg_alts :: Located
      [LMatch (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked))]
    mg_alts = SrcSpan
    -> [LMatch (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked))]
    -> Located
         [LMatch (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked))]
    forall l e. l -> e -> GenLocated l e
    L SrcSpan
    l [LMatch (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked))]
    matches'
                                 , mg_ext :: XMG (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked))
    mg_ext = [Scaled Type] -> Type -> MatchGroupTc
    MatchGroupTc [Scaled Type]
    arg_tys Type
    sum_ty
                                 , mg_origin :: Origin
    mg_origin = Origin
    origin }))
            -- Note that we replace the HsCase result type by sum_ty,
            -- which is the type of matches'

        CoreExpr
    core_matches <- [Id] -> Id -> CoreExpr -> DsM CoreExpr
    matchEnvStack [Id]
    env_ids Id
    stack_id CoreExpr
    core_body
        (CoreExpr, DIdSet) -> DsM (CoreExpr, DIdSet)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (DsCmdEnv
    -> Type -> Type -> Type -> CoreExpr -> CoreExpr -> CoreExpr
    do_premap DsCmdEnv
    ids Type
    in_ty Type
    sum_ty Type
    res_ty CoreExpr
    core_matches CoreExpr
    core_choices,
                CoreExpr -> DIdSet
    exprFreeIdsDSet CoreExpr
    core_body DIdSet -> VarSet -> DIdSet
    forall a. UniqDSet a -> UniqSet a -> UniqDSet a
    `uniqDSetIntersectUniqSet` VarSet
    local_vars)

    dsCmd DsCmdEnv
    ids VarSet
    local_vars Type
    stack_ty Type
    res_ty
          (HsCmdLamCase XCmdLamCase (GhcPass 'Typechecked)
    _ mg :: MatchGroup (GhcPass 'Typechecked) (LHsCmd (GhcPass 'Typechecked))
    mg@MG { mg_ext :: forall p body. MatchGroup p body -> XMG p body
    mg_ext = MatchGroupTc [Scaled Type
    arg_mult Type
    arg_ty] Type
    _ }) [Id]
    env_ids = do
      Id
    arg_id <- Type -> Type -> DsM Id
    newSysLocalDs Type
    arg_mult Type
    arg_ty
      let case_cmd :: LHsCmd (GhcPass 'Typechecked)
    case_cmd  = HsCmd (GhcPass 'Typechecked) -> LHsCmd (GhcPass 'Typechecked)
    forall e. e -> Located e
    noLoc (HsCmd (GhcPass 'Typechecked) -> LHsCmd (GhcPass 'Typechecked))
    -> HsCmd (GhcPass 'Typechecked) -> LHsCmd (GhcPass 'Typechecked)
    forall a b. (a -> b) -> a -> b
    $ XCmdCase (GhcPass 'Typechecked)
    -> LHsExpr (GhcPass 'Typechecked)
    -> MatchGroup
         (GhcPass 'Typechecked) (LHsCmd (GhcPass 'Typechecked))
    -> HsCmd (GhcPass 'Typechecked)
    forall id.
    XCmdCase id -> LHsExpr id -> MatchGroup id (LHsCmd id) -> HsCmd id
    HsCmdCase NoExtField
    XCmdCase (GhcPass 'Typechecked)
    noExtField (IdP (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
    forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
    nlHsVar Id
    IdP (GhcPass 'Typechecked)
    arg_id) MatchGroup (GhcPass 'Typechecked) (LHsCmd (GhcPass 'Typechecked))
    mg
      DsCmdEnv
    -> VarSet
    -> Type
    -> Type
    -> [LPat (GhcPass 'Typechecked)]
    -> LHsCmd (GhcPass 'Typechecked)
    -> [Id]
    -> DsM (CoreExpr, DIdSet)
    dsCmdLam DsCmdEnv
    ids VarSet
    local_vars Type
    stack_ty Type
    res_ty [IdP (GhcPass 'Typechecked) -> LPat (GhcPass 'Typechecked)
    forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
    nlVarPat Id
    IdP (GhcPass 'Typechecked)
    arg_id] LHsCmd (GhcPass 'Typechecked)
    case_cmd [Id]
    env_ids

    -- D; ys |-a cmd : stk --> t
    -- ----------------------------------
    -- D; xs |-a let binds in cmd : stk --> t
    --
    --              ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c

    dsCmd DsCmdEnv
    ids VarSet
    local_vars Type
    stack_ty Type
    res_ty (HsCmdLet XCmdLet (GhcPass 'Typechecked)
    _ lbinds :: LHsLocalBinds (GhcPass 'Typechecked)
    lbinds@(L SrcSpan
    _ HsLocalBinds (GhcPass 'Typechecked)
    binds) LHsCmd (GhcPass 'Typechecked)
    body)
                                                                        [Id]
    env_ids = do
        let
            defined_vars :: VarSet
    defined_vars = [Id] -> VarSet
    mkVarSet (HsLocalBinds (GhcPass 'Typechecked) -> [IdP (GhcPass 'Typechecked)]
    forall (idL :: Pass) (idR :: Pass).
    CollectPass (GhcPass idL) =>
    HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)]
    collectLocalBinders HsLocalBinds (GhcPass 'Typechecked)
    binds)
            local_vars' :: VarSet
    local_vars' = VarSet
    defined_vars VarSet -> VarSet -> VarSet
    `unionVarSet` VarSet
    local_vars

        (CoreExpr
    core_body, DIdSet
    _free_vars, [Id]
    env_ids')
           <- DsCmdEnv
    -> VarSet
    -> Type
    -> Type
    -> LHsCmd (GhcPass 'Typechecked)
    -> DsM (CoreExpr, DIdSet, [Id])
    dsfixCmd DsCmdEnv
    ids VarSet
    local_vars' Type
    stack_ty Type
    res_ty LHsCmd (GhcPass 'Typechecked)
    body
        Id
    stack_id <- Type -> Type -> DsM Id
    newSysLocalDs Type
    Many Type
    stack_ty
        -- build a new environment, plus the stack, using the let bindings
        CoreExpr
    core_binds <- LHsLocalBinds (GhcPass 'Typechecked) -> CoreExpr -> DsM CoreExpr
    dsLocalBinds LHsLocalBinds (GhcPass 'Typechecked)
    lbinds ([Id] -> Id -> CoreExpr
    buildEnvStack [Id]
    env_ids' Id
    stack_id)
        -- match the old environment and stack against the input
        CoreExpr
    core_map <- [Id] -> Id -> CoreExpr -> DsM CoreExpr
    matchEnvStack [Id]
    env_ids Id
    stack_id CoreExpr
    core_binds
        (CoreExpr, DIdSet) -> DsM (CoreExpr, DIdSet)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (DsCmdEnv
    -> Type -> Type -> Type -> CoreExpr -> CoreExpr -> CoreExpr
    do_premap DsCmdEnv
    ids
                            ([Id] -> Type -> Type
    envStackType [Id]
    env_ids Type
    stack_ty)
                            ([Id] -> Type -> Type
    envStackType [Id]
    env_ids' Type
    stack_ty)
                            Type
    res_ty
                            CoreExpr
    core_map
                            CoreExpr
    core_body,
            CoreExpr -> DIdSet
    exprFreeIdsDSet CoreExpr
    core_binds DIdSet -> VarSet -> DIdSet
    forall a. UniqDSet a -> UniqSet a -> UniqDSet a
    `uniqDSetIntersectUniqSet` VarSet
    local_vars)

    -- D; xs |-a ss : t
    -- ----------------------------------
    -- D; xs |-a do { ss } : () --> t
    --
    --              ---> premap (\ (env,stk) -> env) c

    dsCmd DsCmdEnv
    ids VarSet
    local_vars Type
    stack_ty Type
    res_ty do_block :: HsCmd (GhcPass 'Typechecked)
    do_block@(HsCmdDo XCmdDo (GhcPass 'Typechecked)
    stmts_ty
                                                   (L SrcSpan
    loc [CmdLStmt (GhcPass 'Typechecked)]
    stmts))
                                                                       [Id]
    env_ids = do
        SrcSpan -> DsM () -> DsM ()
    forall a. SrcSpan -> DsM a -> DsM a
    putSrcSpanDs SrcSpan
    loc (DsM () -> DsM ()) -> DsM () -> DsM ()
    forall a b. (a -> b) -> a -> b
    $
          Type -> SDoc -> DsM ()
    dsNoLevPoly Type
    XCmdDo (GhcPass 'Typechecked)
    stmts_ty
            (String -> SDoc
    text String
    "In the do-command:" SDoc -> SDoc -> SDoc
    <+> HsCmd (GhcPass 'Typechecked) -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr HsCmd (GhcPass 'Typechecked)
    do_block)
        (CoreExpr
    core_stmts, DIdSet
    env_ids') <- DsCmdEnv
    -> VarSet
    -> Type
    -> [CmdLStmt (GhcPass 'Typechecked)]
    -> [Id]
    -> DsM (CoreExpr, DIdSet)
    dsCmdDo DsCmdEnv
    ids VarSet
    local_vars Type
    res_ty [CmdLStmt (GhcPass 'Typechecked)]
    stmts [Id]
    env_ids
        let env_ty :: Type
    env_ty = [Id] -> Type
    mkBigCoreVarTupTy [Id]
    env_ids
        CoreExpr
    core_fst <- Type -> Type -> DsM CoreExpr
    mkFstExpr Type
    env_ty Type
    stack_ty
        (CoreExpr, DIdSet) -> DsM (CoreExpr, DIdSet)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (DsCmdEnv
    -> Type -> Type -> Type -> CoreExpr -> CoreExpr -> CoreExpr
    do_premap DsCmdEnv
    ids
                    (Type -> Type -> Type
    mkCorePairTy Type
    env_ty Type
    stack_ty)
                    Type
    env_ty
                    Type
    res_ty
                    CoreExpr
    core_fst
                    CoreExpr
    core_stmts,
            DIdSet
    env_ids')

    -- D |- e :: forall e. a1 (e,stk1) t1 -> ... an (e,stkn) tn -> a (e,stk) t
    -- D; xs |-a ci :: stki --> ti
    -- -----------------------------------
    -- D; xs |-a (|e c1 ... cn|) :: stk --> t       ---> e [t_xs] c1 ... cn

    dsCmd DsCmdEnv
    _ VarSet
    local_vars Type
    _stack_ty Type
    _res_ty (HsCmdArrForm XCmdArrForm (GhcPass 'Typechecked)
    _ LHsExpr (GhcPass 'Typechecked)
    op LexicalFixity
    _ Maybe Fixity
    _ [LHsCmdTop (GhcPass 'Typechecked)]
    args) [Id]
    env_ids = do
        let env_ty :: Type
    env_ty = [Id] -> Type
    mkBigCoreVarTupTy [Id]
    env_ids
        CoreExpr
    core_op <- LHsExpr (GhcPass 'Typechecked) -> DsM CoreExpr
    dsLExpr LHsExpr (GhcPass 'Typechecked)
    op
        ([CoreExpr]
    core_args, [DIdSet]
    fv_sets) <- (LHsCmdTop (GhcPass 'Typechecked) -> DsM (CoreExpr, DIdSet))
    -> [LHsCmdTop (GhcPass 'Typechecked)]
    -> IOEnv (Env DsGblEnv DsLclEnv) ([CoreExpr], [DIdSet])
    forall (m :: * -> *) a b c.
    Applicative m =>
    (a -> m (b, c)) -> [a] -> m ([b], [c])
    mapAndUnzipM (VarSet
    -> [Id]
    -> LHsCmdTop (GhcPass 'Typechecked)
    -> DsM (CoreExpr, DIdSet)
    dsTrimCmdArg VarSet
    local_vars [Id]
    env_ids) [LHsCmdTop (GhcPass 'Typechecked)]
    args
        (CoreExpr, DIdSet) -> DsM (CoreExpr, DIdSet)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CoreExpr -> [CoreExpr] -> CoreExpr
    forall b. Expr b -> [Expr b] -> Expr b
    mkApps (CoreExpr -> CoreExpr -> CoreExpr
    forall b. Expr b -> Expr b -> Expr b
    App CoreExpr
    core_op (Type -> CoreExpr
    forall b. Type -> Expr b
    Type Type
    env_ty)) [CoreExpr]
    core_args,
                [DIdSet] -> DIdSet
    unionDVarSets [DIdSet]
    fv_sets)

    dsCmd DsCmdEnv
    ids VarSet
    local_vars Type
    stack_ty Type
    res_ty (XCmd (HsWrap HsWrapper
    wrap HsCmd (GhcPass 'Typechecked)
    cmd)) [Id]
    env_ids = do
        (CoreExpr
    core_cmd, DIdSet
    env_ids') <- DsCmdEnv
    -> VarSet
    -> Type
    -> Type
    -> HsCmd (GhcPass 'Typechecked)
    -> [Id]
    -> DsM (CoreExpr, DIdSet)
    dsCmd DsCmdEnv
    ids VarSet
    local_vars Type
    stack_ty Type
    res_ty HsCmd (GhcPass 'Typechecked)
    cmd [Id]
    env_ids
        CoreExpr -> CoreExpr
    core_wrap <- HsWrapper -> DsM (CoreExpr -> CoreExpr)
    dsHsWrapper HsWrapper
    wrap
        (CoreExpr, DIdSet) -> DsM (CoreExpr, DIdSet)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CoreExpr -> CoreExpr
    core_wrap CoreExpr
    core_cmd, DIdSet
    env_ids')

    dsCmd DsCmdEnv
    _ VarSet
    _ Type
    _ Type
    _ HsCmd (GhcPass 'Typechecked)
    c [Id]
    _ = String -> SDoc -> DsM (CoreExpr, DIdSet)
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "dsCmd" (HsCmd (GhcPass 'Typechecked) -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr HsCmd (GhcPass 'Typechecked)
    c)

    -- D; ys |-a c : stk --> t      (ys <= xs)
    -- ---------------------
    -- D; xs |-a c : stk --> t      ---> premap (\ ((xs),stk) -> ((ys),stk)) c

    dsTrimCmdArg
            :: IdSet                -- set of local vars available to this command
            -> [Id]           -- list of vars in the input to this command
            -> LHsCmdTop GhcTc       -- command argument to desugar
            -> DsM (CoreExpr,       -- desugared expression
                    DIdSet)         -- subset of local vars that occur free
    dsTrimCmdArg :: VarSet
    -> [Id]
    -> LHsCmdTop (GhcPass 'Typechecked)
    -> DsM (CoreExpr, DIdSet)
    dsTrimCmdArg VarSet
    local_vars [Id]
    env_ids
                           (L SrcSpan
    _ (HsCmdTop
                                     (CmdTopTc Type
    stack_ty Type
    cmd_ty CmdSyntaxTable (GhcPass 'Typechecked)
    ids) LHsCmd (GhcPass 'Typechecked)
    cmd )) = do
        ([CoreBind]
    meth_binds, DsCmdEnv
    meth_ids) <- CmdSyntaxTable (GhcPass 'Typechecked) -> DsM ([CoreBind], DsCmdEnv)
    mkCmdEnv CmdSyntaxTable (GhcPass 'Typechecked)
    ids
        (CoreExpr
    core_cmd, DIdSet
    free_vars, [Id]
    env_ids')
           <- DsCmdEnv
    -> VarSet
    -> Type
    -> Type
    -> LHsCmd (GhcPass 'Typechecked)
    -> DsM (CoreExpr, DIdSet, [Id])
    dsfixCmd DsCmdEnv
    meth_ids VarSet
    local_vars Type
    stack_ty Type
    cmd_ty LHsCmd (GhcPass 'Typechecked)
    cmd
        Id
    stack_id <- Type -> Type -> DsM Id
    newSysLocalDs Type
    Many Type
    stack_ty
        CoreExpr
    trim_code
          <- [Id] -> Id -> CoreExpr -> DsM CoreExpr
    matchEnvStack [Id]
    env_ids Id
    stack_id ([Id] -> Id -> CoreExpr
    buildEnvStack [Id]
    env_ids' Id
    stack_id)
        let
            in_ty :: Type
    in_ty = [Id] -> Type -> Type
    envStackType [Id]
    env_ids Type
    stack_ty
            in_ty' :: Type
    in_ty' = [Id] -> Type -> Type
    envStackType [Id]
    env_ids' Type
    stack_ty
            arg_code :: CoreExpr
    arg_code = if [Id]
    env_ids' [Id] -> [Id] -> Bool
    forall a. Eq a => a -> a -> Bool
    == [Id]
    env_ids then CoreExpr
    core_cmd else
                    DsCmdEnv
    -> Type -> Type -> Type -> CoreExpr -> CoreExpr -> CoreExpr
    do_premap DsCmdEnv
    meth_ids Type
    in_ty Type
    in_ty' Type
    cmd_ty CoreExpr
    trim_code CoreExpr
    core_cmd
        (CoreExpr, DIdSet) -> DsM (CoreExpr, DIdSet)
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([CoreBind] -> CoreExpr -> CoreExpr
    forall b. [Bind b] -> Expr b -> Expr b
    mkLets [CoreBind]
    meth_binds CoreExpr
    arg_code, DIdSet
    free_vars)

    -- Given D; xs |-a c : stk --> t, builds c with xs fed back.
    -- Typically needs to be prefixed with arr (\(p, stk) -> ((xs),stk))

    dsfixCmd
            :: DsCmdEnv             -- arrow combinators
            -> IdSet                -- set of local vars available to this command
            -> Type                 -- type of the stack (right-nested tuple)
            -> Type                 -- return type of the command
            -> LHsCmd GhcTc         -- command to desugar
            -> DsM (CoreExpr,       -- desugared expression
                    DIdSet,         -- subset of local vars that occur free
                    [Id])           -- the same local vars as a list, fed back
    dsfixCmd :: DsCmdEnv
    -> VarSet
    -> Type
    -> Type
    -> LHsCmd (GhcPass 'Typechecked)
    -> DsM (CoreExpr, DIdSet, [Id])
    dsfixCmd DsCmdEnv
    ids VarSet
    local_vars Type
    stk_ty Type
    cmd_ty LHsCmd (GhcPass 'Typechecked)
    cmd
      = do { SrcSpan -> DsM () -> DsM ()
    forall a. SrcSpan -> DsM a -> DsM a
    putSrcSpanDs (LHsCmd (GhcPass 'Typechecked) -> SrcSpan
    forall l e. GenLocated l e -> l
    getLoc LHsCmd (GhcPass 'Typechecked)
    cmd) (DsM () -> DsM ()) -> DsM () -> DsM ()
    forall a b. (a -> b) -> a -> b
    $ Type -> SDoc -> DsM ()
    dsNoLevPoly Type
    cmd_ty
               (String -> SDoc
    text String
    "When desugaring the command:" SDoc -> SDoc -> SDoc
    <+> LHsCmd (GhcPass 'Typechecked) -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LHsCmd (GhcPass 'Typechecked)
    cmd)
           ; ([Id] -> DsM (CoreExpr, DIdSet)) -> DsM (CoreExpr, DIdSet, [Id])
    trimInput (DsCmdEnv
    -> VarSet
    -> Type
    -> Type
    -> LHsCmd (GhcPass 'Typechecked)
    -> [Id]
    -> DsM (CoreExpr, DIdSet)
    dsLCmd DsCmdEnv
    ids VarSet
    local_vars Type
    stk_ty Type
    cmd_ty LHsCmd (GhcPass 'Typechecked)
    cmd) }

    -- Feed back the list of local variables actually used a command,
    -- for use as the input tuple of the generated arrow.

    trimInput
            :: ([Id] -> DsM (CoreExpr, DIdSet))
            -> DsM (CoreExpr,       -- desugared expression
                    DIdSet,         -- subset of local vars that occur free
                    [Id])           -- same local vars as a list, fed back to
                                    -- the inner function to form the tuple of
                                    -- inputs to the arrow.
    trimInput :: ([Id] -> DsM (CoreExpr, DIdSet)) -> DsM (CoreExpr, DIdSet, [Id])
    trimInput [Id] -> DsM (CoreExpr, DIdSet)
    build_arrow
      = ((CoreExpr, DIdSet, [Id]) -> DsM (CoreExpr, DIdSet, [Id]))
    -> DsM (CoreExpr, DIdSet, [Id])
    forall a. (a -> DsM a) -> DsM a
    fixDs (\ ~(CoreExpr
    _,DIdSet
    _,[Id]
    env_ids) -> do
            (CoreExpr
    core_cmd, DIdSet
    free_vars) <- [Id] -> DsM (CoreExpr, DIdSet)
    build_arrow [Id]
    env_ids
            (CoreExpr, DIdSet, [Id]) -> DsM (CoreExpr, DIdSet, [Id])
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CoreExpr
    core_cmd, DIdSet
    free_vars, DIdSet -> [Id]
    dVarSetElems DIdSet
    free_vars))

    -- Desugaring for both HsCmdLam and HsCmdLamCase.
    --
    -- D; ys |-a cmd : stk t'
    -- -----------------------------------------------
    -- D; xs |-a \ p1 ... pk -> cmd : (t1,...(tk,stk)...) t'
    --
    --              ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd
    dsCmdLam :: DsCmdEnv            -- arrow combinators
             -> IdSet               -- set of local vars available to this command
             -> Type                -- type of the stack (right-nested tuple)
             -> Type                -- return type of the command
             -> [LPat GhcTc]        -- argument patterns to desugar
             -> LHsCmd GhcTc        -- body to desugar
             -> [Id]                -- list of vars in the input to this command
                                    -- This is typically fed back,
                                    -- so don't pull on it too early
             -> DsM (CoreExpr,      -- desugared expression
                     DIdSet)        -- subset of local vars that occur free
    dsCmdLam :: DsCmdEnv
    -> VarSet
    -> Type
    -> Type
    -> [LPat (GhcPass 'Typechecked)]
    -> LHsCmd (GhcPass 'Typechecked)
    -> [Id]
    -> DsM (CoreExpr, DIdSet)
    dsCmdLam DsCmdEnv
    ids VarSet
    local_vars Type
    stack_ty Type
    res_ty [LPat (GhcPass 'Typechecked)]
    pats LHsCmd (GhcPass 'Typechecked)
    body [Id]
    env_ids = do
        let pat_vars :: VarSet
    pat_vars = [Id] -> VarSet
    mkVarSet ([LPat (GhcPass 'Typechecked)] -> [Id]
    collectPatsBinders [LPat (GhcPass 'Typechecked)]
    pats)
        let local_vars' :: VarSet
    local_vars' = VarSet
    pat_vars VarSet -> VarSet -> VarSet
    `unionVarSet` VarSet
    local_vars
            ([Type]
    pat_tys, Type
    stack_ty') = Int -> Type -> ([Type], Type)
    splitTypeAt ([Located (Pat (GhcPass 'Typechecked))] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Located (Pat (GhcPass 'Typechecked))]
    [LPat (GhcPass 'Typechecked)]
    pats) Type
    stack_ty
        (CoreExpr
    core_body, DIdSet
    free_vars, [Id]
    env_ids')
           <- DsCmdEnv
    -> VarSet
    -> Type
    -> Type
    -> LHsCmd (GhcPass 'Typechecked)
    -> DsM (CoreExpr, DIdSet, [Id])
    dsfixCmd DsCmdEnv
    ids VarSet
    local_vars' Type
    stack_ty' Type
    res_ty LHsCmd (GhcPass 'Typechecked)
    body
        [Id]
    param_ids <- (Type -> DsM Id) -> [Type] -> IOEnv (Env DsGblEnv DsLclEnv) [Id]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM (Type -> Type -> DsM Id
    newSysLocalDsNoLP Type
    Many) [Type]
    pat_tys
        Id
    stack_id' <- Type -> Type -> DsM Id
    newSysLocalDs Type
    Many Type
    stack_ty'

        -- the expression is built from the inside out, so the actions
        -- are presented in reverse order

        let -- build a new environment, plus what's left of the stack
            core_expr :: CoreExpr
    core_expr = [Id] -> Id -> CoreExpr
    buildEnvStack [Id]
    env_ids' Id
    stack_id'
            in_ty :: Type
    in_ty = [Id] -> Type -> Type
    envStackType [Id]
    env_ids Type
    stack_ty
            in_ty' :: Type
    in_ty' = [Id] -> Type -> Type
    envStackType [Id]
    env_ids' Type
    stack_ty'

        CoreExpr
    fail_expr <- HsMatchContext GhcRn -> Type -> DsM CoreExpr
    mkFailExpr HsMatchContext GhcRn
    forall p. HsMatchContext p
    LambdaExpr Type
    in_ty'
        -- match the patterns against the parameters
        CoreExpr
    match_code <- [CoreExpr]
    -> HsMatchContext GhcRn
    -> [LPat (GhcPass 'Typechecked)]
    -> CoreExpr
    -> CoreExpr
    -> DsM CoreExpr
    matchSimplys ((Id -> CoreExpr) -> [Id] -> [CoreExpr]
    forall a b. (a -> b) -> [a] -> [b]
    map Id -> CoreExpr
    forall b. Id -> Expr b
    Var [Id]
    param_ids) HsMatchContext GhcRn
    forall p. HsMatchContext p
    LambdaExpr [LPat (GhcPass 'Typechecked)]
    pats CoreExpr
    core_expr
                        CoreExpr
    fail_expr
        -- match the parameters against the top of the old stack
        (Id
    stack_id, CoreExpr
    param_code) <- [Id] -> Id -> CoreExpr -> DsM (Id, CoreExpr)
    matchVarStack [Id]
    param_ids Id
    stack_id' CoreExpr
    match_code
        -- match the old environment and stack against the input
        CoreExpr
    select_code <- [Id] -> Id -> CoreExpr -> DsM CoreExpr
    matchEnvStack [Id]
    env_ids Id
    stack_id CoreExpr
    param_code
        (CoreExpr, DIdSet) -> DsM (CoreExpr, DIdSet)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (DsCmdEnv
    -> Type -> Type -> Type -> CoreExpr -> CoreExpr -> CoreExpr
    do_premap DsCmdEnv
    ids Type
    in_ty Type
    in_ty' Type
    res_ty CoreExpr
    select_code CoreExpr
    core_body,
                DIdSet
    free_vars DIdSet -> VarSet -> DIdSet
    forall a. UniqDSet a -> UniqSet a -> UniqDSet a
    `uniqDSetMinusUniqSet` VarSet
    pat_vars)

    {-
    Translation of command judgements of the form

            D |-a do { ss } : t
    -}

    dsCmdDo :: DsCmdEnv             -- arrow combinators
            -> IdSet                -- set of local vars available to this statement
            -> Type                 -- return type of the statement
            -> [CmdLStmt GhcTc]     -- statements to desugar
            -> [Id]                 -- list of vars in the input to this statement
                                    -- This is typically fed back,
                                    -- so don't pull on it too early
            -> DsM (CoreExpr,       -- desugared expression
                    DIdSet)         -- subset of local vars that occur free

    dsCmdDo :: DsCmdEnv
    -> VarSet
    -> Type
    -> [CmdLStmt (GhcPass 'Typechecked)]
    -> [Id]
    -> DsM (CoreExpr, DIdSet)
    dsCmdDo DsCmdEnv
    _ VarSet
    _ Type
    _ [] [Id]
    _ = String -> DsM (CoreExpr, DIdSet)
    forall a. String -> a
    panic String
    "dsCmdDo"

    -- D; xs |-a c : () --> t
    -- --------------------------
    -- D; xs |-a do { c } : t
    --
    --              ---> premap (\ (xs) -> ((xs), ())) c

    dsCmdDo DsCmdEnv
    ids VarSet
    local_vars Type
    res_ty [L SrcSpan
    loc (LastStmt XLastStmt
      (GhcPass 'Typechecked)
      (GhcPass 'Typechecked)
      (LHsCmd (GhcPass 'Typechecked))
    _ LHsCmd (GhcPass 'Typechecked)
    body Maybe Bool
    _ SyntaxExpr (GhcPass 'Typechecked)
    _)] [Id]
    env_ids = do
        SrcSpan -> DsM () -> DsM ()
    forall a. SrcSpan -> DsM a -> DsM a
    putSrcSpanDs SrcSpan
    loc (DsM () -> DsM ()) -> DsM () -> DsM ()
    forall a b. (a -> b) -> a -> b
    $ Type -> SDoc -> DsM ()
    dsNoLevPoly Type
    res_ty
                             (String -> SDoc
    text String
    "In the command:" SDoc -> SDoc -> SDoc
    <+> LHsCmd (GhcPass 'Typechecked) -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LHsCmd (GhcPass 'Typechecked)
    body)
        (CoreExpr
    core_body, DIdSet
    env_ids') <- DsCmdEnv
    -> VarSet
    -> Type
    -> Type
    -> LHsCmd (GhcPass 'Typechecked)
    -> [Id]
    -> DsM (CoreExpr, DIdSet)
    dsLCmd DsCmdEnv
    ids VarSet
    local_vars Type
    unitTy Type
    res_ty LHsCmd (GhcPass 'Typechecked)
    body [Id]
    env_ids
        let env_ty :: Type
    env_ty = [Id] -> Type
    mkBigCoreVarTupTy [Id]
    env_ids
        Id
    env_var <- Type -> Type -> DsM Id
    newSysLocalDs Type
    Many Type
    env_ty
        let core_map :: CoreExpr
    core_map = Id -> CoreExpr -> CoreExpr
    forall b. b -> Expr b -> Expr b
    Lam Id
    env_var (CoreExpr -> CoreExpr -> CoreExpr
    mkCorePairExpr (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    env_var) CoreExpr
    mkCoreUnitExpr)
        (CoreExpr, DIdSet) -> DsM (CoreExpr, DIdSet)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (DsCmdEnv
    -> Type -> Type -> Type -> CoreExpr -> CoreExpr -> CoreExpr
    do_premap DsCmdEnv
    ids
                            Type
    env_ty
                            (Type -> Type -> Type
    mkCorePairTy Type
    env_ty Type
    unitTy)
                            Type
    res_ty
                            CoreExpr
    core_map
                            CoreExpr
    core_body,
            DIdSet
    env_ids')

    dsCmdDo DsCmdEnv
    ids VarSet
    local_vars Type
    res_ty (CmdLStmt (GhcPass 'Typechecked)
    stmt:[CmdLStmt (GhcPass 'Typechecked)]
    stmts) [Id]
    env_ids = do
        let bound_vars :: VarSet
    bound_vars  = [Id] -> VarSet
    mkVarSet (CmdLStmt (GhcPass 'Typechecked) -> [Id]
    forall body. LStmt (GhcPass 'Typechecked) body -> [Id]
    collectLStmtBinders CmdLStmt (GhcPass 'Typechecked)
    stmt)
        let local_vars' :: VarSet
    local_vars' = VarSet
    bound_vars VarSet -> VarSet -> VarSet
    `unionVarSet` VarSet
    local_vars
        (CoreExpr
    core_stmts, DIdSet
    _, [Id]
    env_ids') <- ([Id] -> DsM (CoreExpr, DIdSet)) -> DsM (CoreExpr, DIdSet, [Id])
    trimInput (DsCmdEnv
    -> VarSet
    -> Type
    -> [CmdLStmt (GhcPass 'Typechecked)]
    -> [Id]
    -> DsM (CoreExpr, DIdSet)
    dsCmdDo DsCmdEnv
    ids VarSet
    local_vars' Type
    res_ty [CmdLStmt (GhcPass 'Typechecked)]
    stmts)
        (CoreExpr
    core_stmt, DIdSet
    fv_stmt) <- DsCmdEnv
    -> VarSet
    -> [Id]
    -> CmdLStmt (GhcPass 'Typechecked)
    -> [Id]
    -> DsM (CoreExpr, DIdSet)
    dsCmdLStmt DsCmdEnv
    ids VarSet
    local_vars [Id]
    env_ids' CmdLStmt (GhcPass 'Typechecked)
    stmt [Id]
    env_ids
        (CoreExpr, DIdSet) -> DsM (CoreExpr, DIdSet)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (DsCmdEnv
    -> Type -> Type -> Type -> CoreExpr -> CoreExpr -> CoreExpr
    do_compose DsCmdEnv
    ids
                    ([Id] -> Type
    mkBigCoreVarTupTy [Id]
    env_ids)
                    ([Id] -> Type
    mkBigCoreVarTupTy [Id]
    env_ids')
                    Type
    res_ty
                    CoreExpr
    core_stmt
                    CoreExpr
    core_stmts,
                  DIdSet
    fv_stmt)

    {-
    A statement maps one local environment to another, and is represented
    as an arrow from one tuple type to another.  A statement sequence is
    translated to a composition of such arrows.
    -}

    dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> CmdLStmt GhcTc -> [Id]
               -> DsM (CoreExpr, DIdSet)
    dsCmdLStmt :: DsCmdEnv
    -> VarSet
    -> [Id]
    -> CmdLStmt (GhcPass 'Typechecked)
    -> [Id]
    -> DsM (CoreExpr, DIdSet)
    dsCmdLStmt DsCmdEnv
    ids VarSet
    local_vars [Id]
    out_ids CmdLStmt (GhcPass 'Typechecked)
    cmd [Id]
    env_ids
      = DsCmdEnv
    -> VarSet
    -> [Id]
    -> StmtLR
         (GhcPass 'Typechecked)
         (GhcPass 'Typechecked)
         (LHsCmd (GhcPass 'Typechecked))
    -> [Id]
    -> DsM (CoreExpr, DIdSet)
    dsCmdStmt DsCmdEnv
    ids VarSet
    local_vars [Id]
    out_ids (CmdLStmt (GhcPass 'Typechecked)
    -> StmtLR
         (GhcPass 'Typechecked)
         (GhcPass 'Typechecked)
         (LHsCmd (GhcPass 'Typechecked))
    forall l e. GenLocated l e -> e
    unLoc CmdLStmt (GhcPass 'Typechecked)
    cmd) [Id]
    env_ids

    dsCmdStmt
            :: DsCmdEnv             -- arrow combinators
            -> IdSet                -- set of local vars available to this statement
            -> [Id]                 -- list of vars in the output of this statement
            -> CmdStmt GhcTc        -- statement to desugar
            -> [Id]                 -- list of vars in the input to this statement
                                    -- This is typically fed back,
                                    -- so don't pull on it too early
            -> DsM (CoreExpr,       -- desugared expression
                    DIdSet)         -- subset of local vars that occur free

    -- D; xs1 |-a c : () --> t
    -- D; xs' |-a do { ss } : t'
    -- ------------------------------
    -- D; xs  |-a do { c; ss } : t'
    --
    --              ---> premap (\ ((xs)) -> (((xs1),()),(xs')))
    --                      (first c >>> arr snd) >>> ss

    dsCmdStmt :: DsCmdEnv
    -> VarSet
    -> [Id]
    -> StmtLR
         (GhcPass 'Typechecked)
         (GhcPass 'Typechecked)
         (LHsCmd (GhcPass 'Typechecked))
    -> [Id]
    -> DsM (CoreExpr, DIdSet)
    dsCmdStmt DsCmdEnv
    ids VarSet
    local_vars [Id]
    out_ids (BodyStmt XBodyStmt
      (GhcPass 'Typechecked)
      (GhcPass 'Typechecked)
      (LHsCmd (GhcPass 'Typechecked))
    c_ty LHsCmd (GhcPass 'Typechecked)
    cmd SyntaxExpr (GhcPass 'Typechecked)
    _ SyntaxExpr (GhcPass 'Typechecked)
    _) [Id]
    env_ids = do
        (CoreExpr
    core_cmd, DIdSet
    fv_cmd, [Id]
    env_ids1) <- DsCmdEnv
    -> VarSet
    -> Type
    -> Type
    -> LHsCmd (GhcPass 'Typechecked)
    -> DsM (CoreExpr, DIdSet, [Id])
    dsfixCmd DsCmdEnv
    ids VarSet
    local_vars Type
    unitTy Type
    XBodyStmt
      (GhcPass 'Typechecked)
      (GhcPass 'Typechecked)
      (LHsCmd (GhcPass 'Typechecked))
    c_ty LHsCmd (GhcPass 'Typechecked)
    cmd
        CoreExpr
    core_mux <- [Id] -> CoreExpr -> DsM CoreExpr
    matchEnv [Id]
    env_ids
            (CoreExpr -> CoreExpr -> CoreExpr
    mkCorePairExpr
                (CoreExpr -> CoreExpr -> CoreExpr
    mkCorePairExpr ([Id] -> CoreExpr
    mkBigCoreVarTup [Id]
    env_ids1) CoreExpr
    mkCoreUnitExpr)
                ([Id] -> CoreExpr
    mkBigCoreVarTup [Id]
    out_ids))
        let
            in_ty :: Type
    in_ty = [Id] -> Type
    mkBigCoreVarTupTy [Id]
    env_ids
            in_ty1 :: Type
    in_ty1 = Type -> Type -> Type
    mkCorePairTy ([Id] -> Type
    mkBigCoreVarTupTy [Id]
    env_ids1) Type
    unitTy
            out_ty :: Type
    out_ty = [Id] -> Type
    mkBigCoreVarTupTy [Id]
    out_ids
            before_c_ty :: Type
    before_c_ty = Type -> Type -> Type
    mkCorePairTy Type
    in_ty1 Type
    out_ty
            after_c_ty :: Type
    after_c_ty = Type -> Type -> Type
    mkCorePairTy Type
    XBodyStmt
      (GhcPass 'Typechecked)
      (GhcPass 'Typechecked)
      (LHsCmd (GhcPass 'Typechecked))
    c_ty Type
    out_ty
        Type -> SDoc -> DsM ()
    dsNoLevPoly Type
    XBodyStmt
      (GhcPass 'Typechecked)
      (GhcPass 'Typechecked)
      (LHsCmd (GhcPass 'Typechecked))
    c_ty SDoc
    empty -- I (Richard E, Dec '16) have no idea what to say here
        CoreExpr
    snd_fn <- Type -> Type -> DsM CoreExpr
    mkSndExpr Type
    XBodyStmt
      (GhcPass 'Typechecked)
      (GhcPass 'Typechecked)
      (LHsCmd (GhcPass 'Typechecked))
    c_ty Type
    out_ty
        (CoreExpr, DIdSet) -> DsM (CoreExpr, DIdSet)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (DsCmdEnv
    -> Type -> Type -> Type -> CoreExpr -> CoreExpr -> CoreExpr
    do_premap DsCmdEnv
    ids Type
    in_ty Type
    before_c_ty Type
    out_ty CoreExpr
    core_mux (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $
                    DsCmdEnv
    -> Type -> Type -> Type -> CoreExpr -> CoreExpr -> CoreExpr
    do_compose DsCmdEnv
    ids Type
    before_c_ty Type
    after_c_ty Type
    out_ty
                            (DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr
    do_first DsCmdEnv
    ids Type
    in_ty1 Type
    XBodyStmt
      (GhcPass 'Typechecked)
      (GhcPass 'Typechecked)
      (LHsCmd (GhcPass 'Typechecked))
    c_ty Type
    out_ty CoreExpr
    core_cmd) (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $
                    DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr
    do_arr DsCmdEnv
    ids Type
    after_c_ty Type
    out_ty CoreExpr
    snd_fn,
                  DIdSet -> [Id] -> DIdSet
    extendDVarSetList DIdSet
    fv_cmd [Id]
    out_ids)

    -- D; xs1 |-a c : () --> t
    -- D; xs' |-a do { ss } : t'            xs2 = xs' - defs(p)
    -- -----------------------------------
    -- D; xs  |-a do { p <- c; ss } : t'
    --
    --              ---> premap (\ (xs) -> (((xs1),()),(xs2)))
    --                      (first c >>> arr (\ (p, (xs2)) -> (xs'))) >>> ss
    --
    -- It would be simpler and more consistent to do this using second,
    -- but that's likely to be defined in terms of first.

    dsCmdStmt DsCmdEnv
    ids VarSet
    local_vars [Id]
    out_ids (BindStmt XBindStmt
      (GhcPass 'Typechecked)
      (GhcPass 'Typechecked)
      (LHsCmd (GhcPass 'Typechecked))
    _ LPat (GhcPass 'Typechecked)
    pat LHsCmd (GhcPass 'Typechecked)
    cmd) [Id]
    env_ids = do
        let pat_ty :: Type
    pat_ty = LPat (GhcPass 'Typechecked) -> Type
    hsLPatType LPat (GhcPass 'Typechecked)
    pat
        (CoreExpr
    core_cmd, DIdSet
    fv_cmd, [Id]
    env_ids1) <- DsCmdEnv
    -> VarSet
    -> Type
    -> Type
    -> LHsCmd (GhcPass 'Typechecked)
    -> DsM (CoreExpr, DIdSet, [Id])
    dsfixCmd DsCmdEnv
    ids VarSet
    local_vars Type
    unitTy Type
    pat_ty LHsCmd (GhcPass 'Typechecked)
    cmd
        let pat_vars :: VarSet
    pat_vars = [Id] -> VarSet
    mkVarSet (LPat (GhcPass 'Typechecked) -> [Id]
    collectPatBinders LPat (GhcPass 'Typechecked)
    pat)
        let
            env_ids2 :: [Id]
    env_ids2 = (Id -> Bool) -> [Id] -> [Id]
    forall a. (a -> Bool) -> [a] -> [a]
    filterOut (Id -> VarSet -> Bool
    `elemVarSet` VarSet
    pat_vars) [Id]
    out_ids
            env_ty2 :: Type
    env_ty2 = [Id] -> Type
    mkBigCoreVarTupTy [Id]
    env_ids2

        -- multiplexing function
        --          \ (xs) -> (((xs1),()),(xs2))

        CoreExpr
    core_mux <- [Id] -> CoreExpr -> DsM CoreExpr
    matchEnv [Id]
    env_ids
            (CoreExpr -> CoreExpr -> CoreExpr
    mkCorePairExpr
                (CoreExpr -> CoreExpr -> CoreExpr
    mkCorePairExpr ([Id] -> CoreExpr
    mkBigCoreVarTup [Id]
    env_ids1) CoreExpr
    mkCoreUnitExpr)
                ([Id] -> CoreExpr
    mkBigCoreVarTup [Id]
    env_ids2))

        -- projection function
        --          \ (p, (xs2)) -> (zs)

        Id
    env_id <- Type -> Type -> DsM Id
    newSysLocalDs Type
    Many Type
    env_ty2
        UniqSupply
    uniqs <- TcRnIf DsGblEnv DsLclEnv UniqSupply
    forall gbl lcl. TcRnIf gbl lcl UniqSupply
    newUniqueSupply
        let
           after_c_ty :: Type
    after_c_ty = Type -> Type -> Type
    mkCorePairTy Type
    pat_ty Type
    env_ty2
           out_ty :: Type
    out_ty = [Id] -> Type
    mkBigCoreVarTupTy [Id]
    out_ids
           body_expr :: CoreExpr
    body_expr = UniqSupply -> Id -> [Id] -> CoreExpr -> CoreExpr
    coreCaseTuple UniqSupply
    uniqs Id
    env_id [Id]
    env_ids2 ([Id] -> CoreExpr
    mkBigCoreVarTup [Id]
    out_ids)

        CoreExpr
    fail_expr <- HsMatchContext GhcRn -> Type -> DsM CoreExpr
    mkFailExpr (HsStmtContext GhcRn -> HsMatchContext GhcRn
    forall p. HsStmtContext p -> HsMatchContext p
    StmtCtxt (Maybe ModuleName -> HsStmtContext GhcRn
    forall p. Maybe ModuleName -> HsStmtContext p
    DoExpr Maybe ModuleName
    forall a. Maybe a
    Nothing)) Type
    out_ty
        Id
    pat_id    <- Type -> LPat (GhcPass 'Typechecked) -> DsM Id
    selectSimpleMatchVarL Type
    Many LPat (GhcPass 'Typechecked)
    pat
        CoreExpr
    match_code
          <- CoreExpr
    -> HsMatchContext GhcRn
    -> LPat (GhcPass 'Typechecked)
    -> CoreExpr
    -> CoreExpr
    -> DsM CoreExpr
    matchSimply (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    pat_id) (HsStmtContext GhcRn -> HsMatchContext GhcRn
    forall p. HsStmtContext p -> HsMatchContext p
    StmtCtxt (Maybe ModuleName -> HsStmtContext GhcRn
    forall p. Maybe ModuleName -> HsStmtContext p
    DoExpr Maybe ModuleName
    forall a. Maybe a
    Nothing)) LPat (GhcPass 'Typechecked)
    pat CoreExpr
    body_expr CoreExpr
    fail_expr
        Id
    pair_id   <- Type -> Type -> DsM Id
    newSysLocalDs Type
    Many Type
    after_c_ty
        let
            proj_expr :: CoreExpr
    proj_expr = Id -> CoreExpr -> CoreExpr
    forall b. b -> Expr b -> Expr b
    Lam Id
    pair_id (Id -> Id -> Id -> CoreExpr -> CoreExpr
    coreCasePair Id
    pair_id Id
    pat_id Id
    env_id CoreExpr
    match_code)

        -- put it all together
        let
            in_ty :: Type
    in_ty = [Id] -> Type
    mkBigCoreVarTupTy [Id]
    env_ids
            in_ty1 :: Type
    in_ty1 = Type -> Type -> Type
    mkCorePairTy ([Id] -> Type
    mkBigCoreVarTupTy [Id]
    env_ids1) Type
    unitTy
            in_ty2 :: Type
    in_ty2 = [Id] -> Type
    mkBigCoreVarTupTy [Id]
    env_ids2
            before_c_ty :: Type
    before_c_ty = Type -> Type -> Type
    mkCorePairTy Type
    in_ty1 Type
    in_ty2
        (CoreExpr, DIdSet) -> DsM (CoreExpr, DIdSet)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (DsCmdEnv
    -> Type -> Type -> Type -> CoreExpr -> CoreExpr -> CoreExpr
    do_premap DsCmdEnv
    ids Type
    in_ty Type
    before_c_ty Type
    out_ty CoreExpr
    core_mux (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $
                    DsCmdEnv
    -> Type -> Type -> Type -> CoreExpr -> CoreExpr -> CoreExpr
    do_compose DsCmdEnv
    ids Type
    before_c_ty Type
    after_c_ty Type
    out_ty
                            (DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr
    do_first DsCmdEnv
    ids Type
    in_ty1 Type
    pat_ty Type
    in_ty2 CoreExpr
    core_cmd) (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $
                    DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr
    do_arr DsCmdEnv
    ids Type
    after_c_ty Type
    out_ty CoreExpr
    proj_expr,
                  DIdSet
    fv_cmd DIdSet -> DIdSet -> DIdSet
    `unionDVarSet` ([Id] -> DIdSet
    mkDVarSet [Id]
    out_ids
                                         DIdSet -> VarSet -> DIdSet
    forall a. UniqDSet a -> UniqSet a -> UniqDSet a
    `uniqDSetMinusUniqSet` VarSet
    pat_vars))

    -- D; xs' |-a do { ss } : t
    -- --------------------------------------
    -- D; xs  |-a do { let binds; ss } : t
    --
    --              ---> arr (\ (xs) -> let binds in (xs')) >>> ss

    dsCmdStmt DsCmdEnv
    ids VarSet
    local_vars [Id]
    out_ids (LetStmt XLetStmt
      (GhcPass 'Typechecked)
      (GhcPass 'Typechecked)
      (LHsCmd (GhcPass 'Typechecked))
    _ LHsLocalBinds (GhcPass 'Typechecked)
    binds) [Id]
    env_ids = do
        -- build a new environment using the let bindings
        CoreExpr
    core_binds <- LHsLocalBinds (GhcPass 'Typechecked) -> CoreExpr -> DsM CoreExpr
    dsLocalBinds LHsLocalBinds (GhcPass 'Typechecked)
    binds ([Id] -> CoreExpr
    mkBigCoreVarTup [Id]
    out_ids)
        -- match the old environment against the input
        CoreExpr
    core_map <- [Id] -> CoreExpr -> DsM CoreExpr
    matchEnv [Id]
    env_ids CoreExpr
    core_binds
        (CoreExpr, DIdSet) -> DsM (CoreExpr, DIdSet)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr
    do_arr DsCmdEnv
    ids
                            ([Id] -> Type
    mkBigCoreVarTupTy [Id]
    env_ids)
                            ([Id] -> Type
    mkBigCoreVarTupTy [Id]
    out_ids)
                            CoreExpr
    core_map,
                CoreExpr -> DIdSet
    exprFreeIdsDSet CoreExpr
    core_binds DIdSet -> VarSet -> DIdSet
    forall a. UniqDSet a -> UniqSet a -> UniqDSet a
    `uniqDSetIntersectUniqSet` VarSet
    local_vars)

    -- D; ys  |-a do { ss; returnA -< ((xs1), (ys2)) } : ...
    -- D; xs' |-a do { ss' } : t
    -- ------------------------------------
    -- D; xs  |-a do { rec ss; ss' } : t
    --
    --                      xs1 = xs' /\ defs(ss)
    --                      xs2 = xs' - defs(ss)
    --                      ys1 = ys - defs(ss)
    --                      ys2 = ys /\ defs(ss)
    --
    --              ---> arr (\(xs) -> ((ys1),(xs2))) >>>
    --                      first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>>
    --                      arr (\((xs1),(xs2)) -> (xs')) >>> ss'

    dsCmdStmt DsCmdEnv
    ids VarSet
    local_vars [Id]
    out_ids
            (RecStmt { recS_stmts :: forall idL idR body. StmtLR idL idR body -> [LStmtLR idL idR body]
    recS_stmts = [CmdLStmt (GhcPass 'Typechecked)]
    stmts
                     , recS_later_ids :: forall idL idR body. StmtLR idL idR body -> [IdP idR]
    recS_later_ids = [IdP (GhcPass 'Typechecked)]
    later_ids, recS_rec_ids :: forall idL idR body. StmtLR idL idR body -> [IdP idR]
    recS_rec_ids = [IdP (GhcPass 'Typechecked)]
    rec_ids
                     , recS_ext :: forall idL idR body. StmtLR idL idR body -> XRecStmt idL idR body
    recS_ext = RecStmtTc { recS_later_rets :: RecStmtTc -> [HsExpr (GhcPass 'Typechecked)]
    recS_later_rets = [HsExpr (GhcPass 'Typechecked)]
    later_rets
                                            , recS_rec_rets :: RecStmtTc -> [HsExpr (GhcPass 'Typechecked)]
    recS_rec_rets = [HsExpr (GhcPass 'Typechecked)]
    rec_rets } })
            [Id]
    env_ids = do
        let
            later_ids_set :: VarSet
    later_ids_set = [Id] -> VarSet
    mkVarSet [Id]
    [IdP (GhcPass 'Typechecked)]
    later_ids
            env2_ids :: [Id]
    env2_ids = (Id -> Bool) -> [Id] -> [Id]
    forall a. (a -> Bool) -> [a] -> [a]
    filterOut (Id -> VarSet -> Bool
    `elemVarSet` VarSet
    later_ids_set) [Id]
    out_ids
            env2_id_set :: DIdSet
    env2_id_set = [Id] -> DIdSet
    mkDVarSet [Id]
    env2_ids
            env2_ty :: Type
    env2_ty = [Id] -> Type
    mkBigCoreVarTupTy [Id]
    env2_ids

        -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids)

        UniqSupply
    uniqs <- TcRnIf DsGblEnv DsLclEnv UniqSupply
    forall gbl lcl. TcRnIf gbl lcl UniqSupply
    newUniqueSupply
        Id
    env2_id <- Type -> Type -> DsM Id
    newSysLocalDs Type
    Many Type
    env2_ty
        let
            later_ty :: Type
    later_ty = [Id] -> Type
    mkBigCoreVarTupTy [Id]
    [IdP (GhcPass 'Typechecked)]
    later_ids
            post_pair_ty :: Type
    post_pair_ty = Type -> Type -> Type
    mkCorePairTy Type
    later_ty Type
    env2_ty
            post_loop_body :: CoreExpr
    post_loop_body = UniqSupply -> Id -> [Id] -> CoreExpr -> CoreExpr
    coreCaseTuple UniqSupply
    uniqs Id
    env2_id [Id]
    env2_ids ([Id] -> CoreExpr
    mkBigCoreVarTup [Id]
    out_ids)

        CoreExpr
    post_loop_fn <- [Id] -> Id -> CoreExpr -> DsM CoreExpr
    matchEnvStack [Id]
    [IdP (GhcPass 'Typechecked)]
    later_ids Id
    env2_id CoreExpr
    post_loop_body

        --- loop (...)

        (CoreExpr
    core_loop, DIdSet
    env1_id_set, [Id]
    env1_ids)
                   <- DsCmdEnv
    -> VarSet
    -> [CmdLStmt (GhcPass 'Typechecked)]
    -> [Id]
    -> [HsExpr (GhcPass 'Typechecked)]
    -> [Id]
    -> [HsExpr (GhcPass 'Typechecked)]
    -> DsM (CoreExpr, DIdSet, [Id])
    dsRecCmd DsCmdEnv
    ids VarSet
    local_vars [CmdLStmt (GhcPass 'Typechecked)]
    stmts [Id]
    [IdP (GhcPass 'Typechecked)]
    later_ids [HsExpr (GhcPass 'Typechecked)]
    later_rets [Id]
    [IdP (GhcPass 'Typechecked)]
    rec_ids [HsExpr (GhcPass 'Typechecked)]
    rec_rets

        -- pre_loop_fn = \(env_ids) -> ((env1_ids),(env2_ids))

        let
            env1_ty :: Type
    env1_ty = [Id] -> Type
    mkBigCoreVarTupTy [Id]
    env1_ids
            pre_pair_ty :: Type
    pre_pair_ty = Type -> Type -> Type
    mkCorePairTy Type
    env1_ty Type
    env2_ty
            pre_loop_body :: CoreExpr
    pre_loop_body = CoreExpr -> CoreExpr -> CoreExpr
    mkCorePairExpr ([Id] -> CoreExpr
    mkBigCoreVarTup [Id]
    env1_ids)
                                            ([Id] -> CoreExpr
    mkBigCoreVarTup [Id]
    env2_ids)

        CoreExpr
    pre_loop_fn <- [Id] -> CoreExpr -> DsM CoreExpr
    matchEnv [Id]
    env_ids CoreExpr
    pre_loop_body

        -- arr pre_loop_fn >>> first (loop (...)) >>> arr post_loop_fn

        let
            env_ty :: Type
    env_ty = [Id] -> Type
    mkBigCoreVarTupTy [Id]
    env_ids
            out_ty :: Type
    out_ty = [Id] -> Type
    mkBigCoreVarTupTy [Id]
    out_ids
            core_body :: CoreExpr
    core_body = DsCmdEnv
    -> Type -> Type -> Type -> CoreExpr -> CoreExpr -> CoreExpr
    do_premap DsCmdEnv
    ids Type
    env_ty Type
    pre_pair_ty Type
    out_ty
                    CoreExpr
    pre_loop_fn
                    (DsCmdEnv
    -> Type -> Type -> Type -> CoreExpr -> CoreExpr -> CoreExpr
    do_compose DsCmdEnv
    ids Type
    pre_pair_ty Type
    post_pair_ty Type
    out_ty
                            (DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr
    do_first DsCmdEnv
    ids Type
    env1_ty Type
    later_ty Type
    env2_ty
                                    CoreExpr
    core_loop)
                            (DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr
    do_arr DsCmdEnv
    ids Type
    post_pair_ty Type
    out_ty
                                    CoreExpr
    post_loop_fn))

        (CoreExpr, DIdSet) -> DsM (CoreExpr, DIdSet)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CoreExpr
    core_body, DIdSet
    env1_id_set DIdSet -> DIdSet -> DIdSet
    `unionDVarSet` DIdSet
    env2_id_set)

    dsCmdStmt DsCmdEnv
    _ VarSet
    _ [Id]
    _ StmtLR
      (GhcPass 'Typechecked)
      (GhcPass 'Typechecked)
      (LHsCmd (GhcPass 'Typechecked))
    _ [Id]
    s = String -> SDoc -> DsM (CoreExpr, DIdSet)
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "dsCmdStmt" ([Id] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [Id]
    s)

    --      loop (premap (\ ((env1_ids), ~(rec_ids)) -> (env_ids))
    --            (ss >>> arr (\ (out_ids) -> ((later_rets),(rec_rets))))) >>>

    dsRecCmd
            :: DsCmdEnv             -- arrow combinators
            -> IdSet                -- set of local vars available to this statement
            -> [CmdLStmt GhcTc]     -- list of statements inside the RecCmd
            -> [Id]                 -- list of vars defined here and used later
            -> [HsExpr GhcTc]       -- expressions corresponding to later_ids
            -> [Id]                 -- list of vars fed back through the loop
            -> [HsExpr GhcTc]       -- expressions corresponding to rec_ids
            -> DsM (CoreExpr,       -- desugared statement
                    DIdSet,         -- subset of local vars that occur free
                    [Id])           -- same local vars as a list

    dsRecCmd :: DsCmdEnv
    -> VarSet
    -> [CmdLStmt (GhcPass 'Typechecked)]
    -> [Id]
    -> [HsExpr (GhcPass 'Typechecked)]
    -> [Id]
    -> [HsExpr (GhcPass 'Typechecked)]
    -> DsM (CoreExpr, DIdSet, [Id])
    dsRecCmd DsCmdEnv
    ids VarSet
    local_vars [CmdLStmt (GhcPass 'Typechecked)]
    stmts [Id]
    later_ids [HsExpr (GhcPass 'Typechecked)]
    later_rets [Id]
    rec_ids [HsExpr (GhcPass 'Typechecked)]
    rec_rets = do
        let
            later_id_set :: VarSet
    later_id_set = [Id] -> VarSet
    mkVarSet [Id]
    later_ids
            rec_id_set :: VarSet
    rec_id_set = [Id] -> VarSet
    mkVarSet [Id]
    rec_ids
            local_vars' :: VarSet
    local_vars' = VarSet
    rec_id_set VarSet -> VarSet -> VarSet
    `unionVarSet` VarSet
    later_id_set VarSet -> VarSet -> VarSet
    `unionVarSet` VarSet
    local_vars

        -- mk_pair_fn = \ (out_ids) -> ((later_rets),(rec_rets))

        [CoreExpr]
    core_later_rets <- (HsExpr (GhcPass 'Typechecked) -> DsM CoreExpr)
    -> [HsExpr (GhcPass 'Typechecked)]
    -> IOEnv (Env DsGblEnv DsLclEnv) [CoreExpr]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM HsExpr (GhcPass 'Typechecked) -> DsM CoreExpr
    dsExpr [HsExpr (GhcPass 'Typechecked)]
    later_rets
        [CoreExpr]
    core_rec_rets <- (HsExpr (GhcPass 'Typechecked) -> DsM CoreExpr)
    -> [HsExpr (GhcPass 'Typechecked)]
    -> IOEnv (Env DsGblEnv DsLclEnv) [CoreExpr]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM HsExpr (GhcPass 'Typechecked) -> DsM CoreExpr
    dsExpr [HsExpr (GhcPass 'Typechecked)]
    rec_rets
        let
            -- possibly polymorphic version of vars of later_ids and rec_ids
            out_ids :: [Id]
    out_ids = [CoreExpr] -> [Id]
    exprsFreeIdsList ([CoreExpr]
    core_later_rets [CoreExpr] -> [CoreExpr] -> [CoreExpr]
    forall a. [a] -> [a] -> [a]
    ++ [CoreExpr]
    core_rec_rets)
            out_ty :: Type
    out_ty = [Id] -> Type
    mkBigCoreVarTupTy [Id]
    out_ids

            later_tuple :: CoreExpr
    later_tuple = [CoreExpr] -> CoreExpr
    mkBigCoreTup [CoreExpr]
    core_later_rets
            later_ty :: Type
    later_ty = [Id] -> Type
    mkBigCoreVarTupTy [Id]
    later_ids

            rec_tuple :: CoreExpr
    rec_tuple = [CoreExpr] -> CoreExpr
    mkBigCoreTup [CoreExpr]
    core_rec_rets
            rec_ty :: Type
    rec_ty = [Id] -> Type
    mkBigCoreVarTupTy [Id]
    rec_ids

            out_pair :: CoreExpr
    out_pair = CoreExpr -> CoreExpr -> CoreExpr
    mkCorePairExpr CoreExpr
    later_tuple CoreExpr
    rec_tuple
            out_pair_ty :: Type
    out_pair_ty = Type -> Type -> Type
    mkCorePairTy Type
    later_ty Type
    rec_ty

        CoreExpr
    mk_pair_fn <- [Id] -> CoreExpr -> DsM CoreExpr
    matchEnv [Id]
    out_ids CoreExpr
    out_pair

        -- ss

        (CoreExpr
    core_stmts, DIdSet
    fv_stmts, [Id]
    env_ids) <- DsCmdEnv
    -> VarSet
    -> [Id]
    -> [CmdLStmt (GhcPass 'Typechecked)]
    -> DsM (CoreExpr, DIdSet, [Id])
    dsfixCmdStmts DsCmdEnv
    ids VarSet
    local_vars' [Id]
    out_ids [CmdLStmt (GhcPass 'Typechecked)]
    stmts

        -- squash_pair_fn = \ ((env1_ids), ~(rec_ids)) -> (env_ids)

        Id
    rec_id <- Type -> Type -> DsM Id
    newSysLocalDs Type
    Many Type
    rec_ty
        let
            env1_id_set :: DIdSet
    env1_id_set = DIdSet
    fv_stmts DIdSet -> VarSet -> DIdSet
    forall a. UniqDSet a -> UniqSet a -> UniqDSet a
    `uniqDSetMinusUniqSet` VarSet
    rec_id_set
            env1_ids :: [Id]
    env1_ids = DIdSet -> [Id]
    dVarSetElems DIdSet
    env1_id_set
            env1_ty :: Type
    env1_ty = [Id] -> Type
    mkBigCoreVarTupTy [Id]
    env1_ids
            in_pair_ty :: Type
    in_pair_ty = Type -> Type -> Type
    mkCorePairTy Type
    env1_ty Type
    rec_ty
            core_body :: CoreExpr
    core_body = [CoreExpr] -> CoreExpr
    mkBigCoreTup ((Id -> CoreExpr) -> [Id] -> [CoreExpr]
    forall a b. (a -> b) -> [a] -> [b]
    map Id -> CoreExpr
    selectVar [Id]
    env_ids)
              where
                selectVar :: Id -> CoreExpr
    selectVar Id
    v
                    | Id
    v Id -> VarSet -> Bool
    `elemVarSet` VarSet
    rec_id_set
                      = [Id] -> Id -> Id -> CoreExpr -> CoreExpr
    mkTupleSelector [Id]
    rec_ids Id
    v Id
    rec_id (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    rec_id)
                    | Bool
    otherwise = Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    v

        CoreExpr
    squash_pair_fn <- [Id] -> Id -> CoreExpr -> DsM CoreExpr
    matchEnvStack [Id]
    env1_ids Id
    rec_id CoreExpr
    core_body

        -- loop (premap squash_pair_fn (ss >>> arr mk_pair_fn))

        let
            env_ty :: Type
    env_ty = [Id] -> Type
    mkBigCoreVarTupTy [Id]
    env_ids
            core_loop :: CoreExpr
    core_loop = DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr
    do_loop DsCmdEnv
    ids Type
    env1_ty Type
    later_ty Type
    rec_ty
                    (DsCmdEnv
    -> Type -> Type -> Type -> CoreExpr -> CoreExpr -> CoreExpr
    do_premap DsCmdEnv
    ids Type
    in_pair_ty Type
    env_ty Type
    out_pair_ty
                            CoreExpr
    squash_pair_fn
                            (DsCmdEnv
    -> Type -> Type -> Type -> CoreExpr -> CoreExpr -> CoreExpr
    do_compose DsCmdEnv
    ids Type
    env_ty Type
    out_ty Type
    out_pair_ty
                                    CoreExpr
    core_stmts
                                    (DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr
    do_arr DsCmdEnv
    ids Type
    out_ty Type
    out_pair_ty CoreExpr
    mk_pair_fn)))

        (CoreExpr, DIdSet, [Id]) -> DsM (CoreExpr, DIdSet, [Id])
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CoreExpr
    core_loop, DIdSet
    env1_id_set, [Id]
    env1_ids)

    {-
    A sequence of statements (as in a rec) is desugared to an arrow between
    two environments (no stack)
    -}

    dsfixCmdStmts
            :: DsCmdEnv             -- arrow combinators
            -> IdSet                -- set of local vars available to this statement
            -> [Id]                 -- output vars of these statements
            -> [CmdLStmt GhcTc]     -- statements to desugar
            -> DsM (CoreExpr,       -- desugared expression
                    DIdSet,         -- subset of local vars that occur free
                    [Id])           -- same local vars as a list

    dsfixCmdStmts :: DsCmdEnv
    -> VarSet
    -> [Id]
    -> [CmdLStmt (GhcPass 'Typechecked)]
    -> DsM (CoreExpr, DIdSet, [Id])
    dsfixCmdStmts DsCmdEnv
    ids VarSet
    local_vars [Id]
    out_ids [CmdLStmt (GhcPass 'Typechecked)]
    stmts
      = ([Id] -> DsM (CoreExpr, DIdSet)) -> DsM (CoreExpr, DIdSet, [Id])
    trimInput (DsCmdEnv
    -> VarSet
    -> [Id]
    -> [CmdLStmt (GhcPass 'Typechecked)]
    -> [Id]
    -> DsM (CoreExpr, DIdSet)
    dsCmdStmts DsCmdEnv
    ids VarSet
    local_vars [Id]
    out_ids [CmdLStmt (GhcPass 'Typechecked)]
    stmts)
       -- TODO: Add levity polymorphism check for the resulting expression.
       -- But I (Richard E.) don't know enough about arrows to do so.

    dsCmdStmts
            :: DsCmdEnv             -- arrow combinators
            -> IdSet                -- set of local vars available to this statement
            -> [Id]                 -- output vars of these statements
            -> [CmdLStmt GhcTc]     -- statements to desugar
            -> [Id]                 -- list of vars in the input to these statements
            -> DsM (CoreExpr,       -- desugared expression
                    DIdSet)         -- subset of local vars that occur free

    dsCmdStmts :: DsCmdEnv
    -> VarSet
    -> [Id]
    -> [CmdLStmt (GhcPass 'Typechecked)]
    -> [Id]
    -> DsM (CoreExpr, DIdSet)
    dsCmdStmts DsCmdEnv
    ids VarSet
    local_vars [Id]
    out_ids [CmdLStmt (GhcPass 'Typechecked)
    stmt] [Id]
    env_ids
      = DsCmdEnv
    -> VarSet
    -> [Id]
    -> CmdLStmt (GhcPass 'Typechecked)
    -> [Id]
    -> DsM (CoreExpr, DIdSet)
    dsCmdLStmt DsCmdEnv
    ids VarSet
    local_vars [Id]
    out_ids CmdLStmt (GhcPass 'Typechecked)
    stmt [Id]
    env_ids

    dsCmdStmts DsCmdEnv
    ids VarSet
    local_vars [Id]
    out_ids (CmdLStmt (GhcPass 'Typechecked)
    stmt:[CmdLStmt (GhcPass 'Typechecked)]
    stmts) [Id]
    env_ids = do
        let bound_vars :: VarSet
    bound_vars  = [Id] -> VarSet
    mkVarSet (CmdLStmt (GhcPass 'Typechecked) -> [Id]
    forall body. LStmt (GhcPass 'Typechecked) body -> [Id]
    collectLStmtBinders CmdLStmt (GhcPass 'Typechecked)
    stmt)
        let local_vars' :: VarSet
    local_vars' = VarSet
    bound_vars VarSet -> VarSet -> VarSet
    `unionVarSet` VarSet
    local_vars
        (CoreExpr
    core_stmts, DIdSet
    _fv_stmts, [Id]
    env_ids') <- DsCmdEnv
    -> VarSet
    -> [Id]
    -> [CmdLStmt (GhcPass 'Typechecked)]
    -> DsM (CoreExpr, DIdSet, [Id])
    dsfixCmdStmts DsCmdEnv
    ids VarSet
    local_vars' [Id]
    out_ids [CmdLStmt (GhcPass 'Typechecked)]
    stmts
        (CoreExpr
    core_stmt, DIdSet
    fv_stmt) <- DsCmdEnv
    -> VarSet
    -> [Id]
    -> CmdLStmt (GhcPass 'Typechecked)
    -> [Id]
    -> DsM (CoreExpr, DIdSet)
    dsCmdLStmt DsCmdEnv
    ids VarSet
    local_vars [Id]
    env_ids' CmdLStmt (GhcPass 'Typechecked)
    stmt [Id]
    env_ids
        (CoreExpr, DIdSet) -> DsM (CoreExpr, DIdSet)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (DsCmdEnv
    -> Type -> Type -> Type -> CoreExpr -> CoreExpr -> CoreExpr
    do_compose DsCmdEnv
    ids
                    ([Id] -> Type
    mkBigCoreVarTupTy [Id]
    env_ids)
                    ([Id] -> Type
    mkBigCoreVarTupTy [Id]
    env_ids')
                    ([Id] -> Type
    mkBigCoreVarTupTy [Id]
    out_ids)
                    CoreExpr
    core_stmt
                    CoreExpr
    core_stmts,
                  DIdSet
    fv_stmt)

    dsCmdStmts DsCmdEnv
    _ VarSet
    _ [Id]
    _ [] [Id]
    _ = String -> DsM (CoreExpr, DIdSet)
    forall a. String -> a
    panic String
    "dsCmdStmts []"

    -- Match a list of expressions against a list of patterns, left-to-right.

    matchSimplys :: [CoreExpr]              -- Scrutinees
                 -> HsMatchContext GhcRn    -- Match kind
                 -> [LPat GhcTc]            -- Patterns they should match
                 -> CoreExpr                -- Return this if they all match
                 -> CoreExpr                -- Return this if they don't
                 -> DsM CoreExpr
    matchSimplys :: [CoreExpr]
    -> HsMatchContext GhcRn
    -> [LPat (GhcPass 'Typechecked)]
    -> CoreExpr
    -> CoreExpr
    -> DsM CoreExpr
    matchSimplys [] HsMatchContext GhcRn
    _ctxt [] CoreExpr
    result_expr CoreExpr
    _fail_expr = CoreExpr -> DsM CoreExpr
    forall (m :: * -> *) a. Monad m => a -> m a
    return CoreExpr
    result_expr
    matchSimplys (CoreExpr
    exp:[CoreExpr]
    exps) HsMatchContext GhcRn
    ctxt (LPat (GhcPass 'Typechecked)
    pat:[LPat (GhcPass 'Typechecked)]
    pats) CoreExpr
    result_expr CoreExpr
    fail_expr = do
        CoreExpr
    match_code <- [CoreExpr]
    -> HsMatchContext GhcRn
    -> [LPat (GhcPass 'Typechecked)]
    -> CoreExpr
    -> CoreExpr
    -> DsM CoreExpr
    matchSimplys [CoreExpr]
    exps HsMatchContext GhcRn
    ctxt [LPat (GhcPass 'Typechecked)]
    pats CoreExpr
    result_expr CoreExpr
    fail_expr
        CoreExpr
    -> HsMatchContext GhcRn
    -> LPat (GhcPass 'Typechecked)
    -> CoreExpr
    -> CoreExpr
    -> DsM CoreExpr
    matchSimply CoreExpr
    exp HsMatchContext GhcRn
    ctxt LPat (GhcPass 'Typechecked)
    pat CoreExpr
    match_code CoreExpr
    fail_expr
    matchSimplys [CoreExpr]
    _ HsMatchContext GhcRn
    _ [LPat (GhcPass 'Typechecked)]
    _ CoreExpr
    _ CoreExpr
    _ = String -> DsM CoreExpr
    forall a. String -> a
    panic String
    "matchSimplys"

    -- List of leaf expressions, with set of variables bound in each

    leavesMatch :: LMatch GhcTc (Located (body GhcTc))
                -> [(Located (body GhcTc), IdSet)]
    leavesMatch :: forall (body :: * -> *).
    LMatch
      (GhcPass 'Typechecked) (Located (body (GhcPass 'Typechecked)))
    -> [(Located (body (GhcPass 'Typechecked)), VarSet)]
    leavesMatch (L SrcSpan
    _ (Match { m_pats :: forall p body. Match p body -> [LPat p]
    m_pats = [LPat (GhcPass 'Typechecked)]
    pats
                            , m_grhss :: forall p body. Match p body -> GRHSs p body
    m_grhss = GRHSs XCGRHSs
      (GhcPass 'Typechecked) (Located (body (GhcPass 'Typechecked)))
    _ [LGRHS
       (GhcPass 'Typechecked) (Located (body (GhcPass 'Typechecked)))]
    grhss (L SrcSpan
    _ HsLocalBinds (GhcPass 'Typechecked)
    binds) }))
      = let
            defined_vars :: VarSet
    defined_vars = [Id] -> VarSet
    mkVarSet ([LPat (GhcPass 'Typechecked)] -> [Id]
    collectPatsBinders [LPat (GhcPass 'Typechecked)]
    pats)
                            VarSet -> VarSet -> VarSet
    `unionVarSet`
                           [Id] -> VarSet
    mkVarSet (HsLocalBinds (GhcPass 'Typechecked) -> [IdP (GhcPass 'Typechecked)]
    forall (idL :: Pass) (idR :: Pass).
    CollectPass (GhcPass idL) =>
    HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)]
    collectLocalBinders HsLocalBinds (GhcPass 'Typechecked)
    binds)
        in
        [(Located (body (GhcPass 'Typechecked))
    body,
          [Id] -> VarSet
    mkVarSet ([GuardLStmt (GhcPass 'Typechecked)] -> [Id]
    forall body. [LStmt (GhcPass 'Typechecked) body] -> [Id]
    collectLStmtsBinders [GuardLStmt (GhcPass 'Typechecked)]
    stmts)
            VarSet -> VarSet -> VarSet
    `unionVarSet` VarSet
    defined_vars)
        | L SrcSpan
    _ (GRHS XCGRHS
      (GhcPass 'Typechecked) (Located (body (GhcPass 'Typechecked)))
    _ [GuardLStmt (GhcPass 'Typechecked)]
    stmts Located (body (GhcPass 'Typechecked))
    body) <- [LGRHS
       (GhcPass 'Typechecked) (Located (body (GhcPass 'Typechecked)))]
    grhss]

    -- Replace the leaf commands in a match

    replaceLeavesMatch
            :: Type                                 -- new result type
            -> [Located (body' GhcTc)] -- replacement leaf expressions of that type
            -> LMatch GhcTc (Located (body GhcTc))  -- the matches of a case command
            -> ([Located (body' GhcTc)],            -- remaining leaf expressions
                LMatch GhcTc (Located (body' GhcTc))) -- updated match
    replaceLeavesMatch :: forall (body' :: * -> *) (body :: * -> *).
    Type
    -> [Located (body' (GhcPass 'Typechecked))]
    -> LMatch
         (GhcPass 'Typechecked) (Located (body (GhcPass 'Typechecked)))
    -> ([Located (body' (GhcPass 'Typechecked))],
        LMatch
          (GhcPass 'Typechecked) (Located (body' (GhcPass 'Typechecked))))
    replaceLeavesMatch Type
    _res_ty [Located (body' (GhcPass 'Typechecked))]
    leaves
                            (L SrcSpan
    loc
                              match :: Match
      (GhcPass 'Typechecked) (Located (body (GhcPass 'Typechecked)))
    match@(Match { m_grhss :: forall p body. Match p body -> GRHSs p body
    m_grhss = GRHSs XCGRHSs
      (GhcPass 'Typechecked) (Located (body (GhcPass 'Typechecked)))
    x [LGRHS
       (GhcPass 'Typechecked) (Located (body (GhcPass 'Typechecked)))]
    grhss LHsLocalBinds (GhcPass 'Typechecked)
    binds }))
      = let
            ([Located (body' (GhcPass 'Typechecked))]
    leaves', [LGRHS
       (GhcPass 'Typechecked) (Located (body' (GhcPass 'Typechecked)))]
    grhss') = ([Located (body' (GhcPass 'Typechecked))]
     -> LGRHS
          (GhcPass 'Typechecked) (Located (body (GhcPass 'Typechecked)))
     -> ([Located (body' (GhcPass 'Typechecked))],
         LGRHS
           (GhcPass 'Typechecked) (Located (body' (GhcPass 'Typechecked)))))
    -> [Located (body' (GhcPass 'Typechecked))]
    -> [LGRHS
          (GhcPass 'Typechecked) (Located (body (GhcPass 'Typechecked)))]
    -> ([Located (body' (GhcPass 'Typechecked))],
        [LGRHS
           (GhcPass 'Typechecked) (Located (body' (GhcPass 'Typechecked)))])
    forall (t :: * -> *) s a b.
    Traversable t =>
    (s -> a -> (s, b)) -> s -> t a -> (s, t b)
    mapAccumL [Located (body' (GhcPass 'Typechecked))]
    -> LGRHS
         (GhcPass 'Typechecked) (Located (body (GhcPass 'Typechecked)))
    -> ([Located (body' (GhcPass 'Typechecked))],
        LGRHS
          (GhcPass 'Typechecked) (Located (body' (GhcPass 'Typechecked))))
    forall (body' :: * -> *) (body :: * -> *).
    [Located (body' (GhcPass 'Typechecked))]
    -> LGRHS
         (GhcPass 'Typechecked) (Located (body (GhcPass 'Typechecked)))
    -> ([Located (body' (GhcPass 'Typechecked))],
        LGRHS
          (GhcPass 'Typechecked) (Located (body' (GhcPass 'Typechecked))))
    replaceLeavesGRHS [Located (body' (GhcPass 'Typechecked))]
    leaves [LGRHS
       (GhcPass 'Typechecked) (Located (body (GhcPass 'Typechecked)))]
    grhss
        in
        ([Located (body' (GhcPass 'Typechecked))]
    leaves', SrcSpan
    -> Match
         (GhcPass 'Typechecked) (Located (body' (GhcPass 'Typechecked)))
    -> GenLocated
         SrcSpan
         (Match
            (GhcPass 'Typechecked) (Located (body' (GhcPass 'Typechecked))))
    forall l e. l -> e -> GenLocated l e
    L SrcSpan
    loc (Match
      (GhcPass 'Typechecked) (Located (body (GhcPass 'Typechecked)))
    match { m_ext :: XCMatch
      (GhcPass 'Typechecked) (Located (body' (GhcPass 'Typechecked)))
    m_ext = NoExtField
    XCMatch
      (GhcPass 'Typechecked) (Located (body' (GhcPass 'Typechecked)))
    noExtField, m_grhss :: GRHSs
      (GhcPass 'Typechecked) (Located (body' (GhcPass 'Typechecked)))
    m_grhss = XCGRHSs
      (GhcPass 'Typechecked) (Located (body' (GhcPass 'Typechecked)))
    -> [LGRHS
          (GhcPass 'Typechecked) (Located (body' (GhcPass 'Typechecked)))]
    -> LHsLocalBinds (GhcPass 'Typechecked)
    -> GRHSs
         (GhcPass 'Typechecked) (Located (body' (GhcPass 'Typechecked)))
    forall p body.
    XCGRHSs p body -> [LGRHS p body] -> LHsLocalBinds p -> GRHSs p body
    GRHSs XCGRHSs
      (GhcPass 'Typechecked) (Located (body' (GhcPass 'Typechecked)))
    XCGRHSs
      (GhcPass 'Typechecked) (Located (body (GhcPass 'Typechecked)))
    x [LGRHS
       (GhcPass 'Typechecked) (Located (body' (GhcPass 'Typechecked)))]
    grhss' LHsLocalBinds (GhcPass 'Typechecked)
    binds }))

    replaceLeavesGRHS
            :: [Located (body' GhcTc)]  -- replacement leaf expressions of that type
            -> LGRHS GhcTc (Located (body GhcTc))     -- rhss of a case command
            -> ([Located (body' GhcTc)],              -- remaining leaf expressions
                LGRHS GhcTc (Located (body' GhcTc)))  -- updated GRHS
    replaceLeavesGRHS :: forall (body' :: * -> *) (body :: * -> *).
    [Located (body' (GhcPass 'Typechecked))]
    -> LGRHS
         (GhcPass 'Typechecked) (Located (body (GhcPass 'Typechecked)))
    -> ([Located (body' (GhcPass 'Typechecked))],
        LGRHS
          (GhcPass 'Typechecked) (Located (body' (GhcPass 'Typechecked))))
    replaceLeavesGRHS (Located (body' (GhcPass 'Typechecked))
    leaf:[Located (body' (GhcPass 'Typechecked))]
    leaves) (L SrcSpan
    loc (GRHS XCGRHS
      (GhcPass 'Typechecked) (Located (body (GhcPass 'Typechecked)))
    x [GuardLStmt (GhcPass 'Typechecked)]
    stmts Located (body (GhcPass 'Typechecked))
    _))
      = ([Located (body' (GhcPass 'Typechecked))]
    leaves, SrcSpan
    -> GRHS
         (GhcPass 'Typechecked) (Located (body' (GhcPass 'Typechecked)))
    -> GenLocated
         SrcSpan
         (GRHS
            (GhcPass 'Typechecked) (Located (body' (GhcPass 'Typechecked))))
    forall l e. l -> e -> GenLocated l e
    L SrcSpan
    loc (XCGRHS
      (GhcPass 'Typechecked) (Located (body' (GhcPass 'Typechecked)))
    -> [GuardLStmt (GhcPass 'Typechecked)]
    -> Located (body' (GhcPass 'Typechecked))
    -> GRHS
         (GhcPass 'Typechecked) (Located (body' (GhcPass 'Typechecked)))
    forall p body.
    XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
    GRHS XCGRHS
      (GhcPass 'Typechecked) (Located (body' (GhcPass 'Typechecked)))
    XCGRHS
      (GhcPass 'Typechecked) (Located (body (GhcPass 'Typechecked)))
    x [GuardLStmt (GhcPass 'Typechecked)]
    stmts Located (body' (GhcPass 'Typechecked))
    leaf))
    replaceLeavesGRHS [] GenLocated
      SrcSpan
      (GRHS
         (GhcPass 'Typechecked) (Located (body (GhcPass 'Typechecked))))
    _ = String
    -> ([Located (body' (GhcPass 'Typechecked))],
        GenLocated
          SrcSpan
          (GRHS
             (GhcPass 'Typechecked) (Located (body' (GhcPass 'Typechecked)))))
    forall a. String -> a
    panic String
    "replaceLeavesGRHS []"

    -- Balanced fold of a non-empty list.

    foldb :: (a -> a -> a) -> [a] -> a
    foldb :: forall a. (a -> a -> a) -> [a] -> a
    foldb a -> a -> a
    _ [] = String -> a
    forall a. HasCallStack => String -> a
    error String
    "foldb of empty list"
    foldb a -> a -> a
    _ [a
    x] = a
    x
    foldb a -> a -> a
    f [a]
    xs = (a -> a -> a) -> [a] -> a
    forall a. (a -> a -> a) -> [a] -> a
    foldb a -> a -> a
    f ([a] -> [a]
    fold_pairs [a]
    xs)
      where
        fold_pairs :: [a] -> [a]
    fold_pairs [] = []
        fold_pairs [a
    x] = [a
    x]
        fold_pairs (a
    x1:a
    x2:[a]
    xs) = a -> a -> a
    f a
    x1 a
    x2a -> [a] -> [a]
    forall a. a -> [a] -> [a]
    :[a] -> [a]
    fold_pairs [a]
    xs

    {-
    Note [Dictionary binders in ConPatOut] See also same Note in GHC.Hs.Utils
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    The following functions to collect value variables from patterns are
    copied from GHC.Hs.Utils, with one change: we also collect the dictionary
    bindings (cpt_binds) from ConPatOut.  We need them for cases like

    h :: Arrow a => Int -> a (Int,Int) Int
    h x = proc (y,z) -> case compare x y of
                    GT -> returnA -< z+x

    The type checker turns the case into

                    case compare x y of
                      GT { p77 = plusInt } -> returnA -< p77 z x

    Here p77 is a local binding for the (+) operation.

    See comments in GHC.Hs.Utils for why the other version does not include
    these bindings.
    -}

    collectPatBinders :: LPat GhcTc -> [Id]
    collectPatBinders :: LPat (GhcPass 'Typechecked) -> [Id]
    collectPatBinders LPat (GhcPass 'Typechecked)
    pat = LPat (GhcPass 'Typechecked) -> [Id] -> [Id]
    collectl LPat (GhcPass 'Typechecked)
    pat []

    collectPatsBinders :: [LPat GhcTc] -> [Id]
    collectPatsBinders :: [LPat (GhcPass 'Typechecked)] -> [Id]
    collectPatsBinders [LPat (GhcPass 'Typechecked)]
    pats = (Located (Pat (GhcPass 'Typechecked)) -> [Id] -> [Id])
    -> [Id] -> [Located (Pat (GhcPass 'Typechecked))] -> [Id]
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr Located (Pat (GhcPass 'Typechecked)) -> [Id] -> [Id]
    LPat (GhcPass 'Typechecked) -> [Id] -> [Id]
    collectl [] [Located (Pat (GhcPass 'Typechecked))]
    [LPat (GhcPass 'Typechecked)]
    pats

    ---------------------
    collectl :: LPat GhcTc -> [Id] -> [Id]
    -- See Note [Dictionary binders in ConPatOut]
    collectl :: LPat (GhcPass 'Typechecked) -> [Id] -> [Id]
    collectl (L SrcSpan
    _ Pat (GhcPass 'Typechecked)
    pat) [Id]
    bndrs
      = Pat (GhcPass 'Typechecked) -> [Id]
    go Pat (GhcPass 'Typechecked)
    pat
      where
        go :: Pat (GhcPass 'Typechecked) -> [Id]
    go (VarPat XVarPat (GhcPass 'Typechecked)
    _ (L SrcSpan
    _ IdP (GhcPass 'Typechecked)
    var))       = Id
    IdP (GhcPass 'Typechecked)
    var Id -> [Id] -> [Id]
    forall a. a -> [a] -> [a]
    : [Id]
    bndrs
        go (WildPat XWildPat (GhcPass 'Typechecked)
    _)                = [Id]
    bndrs
        go (LazyPat XLazyPat (GhcPass 'Typechecked)
    _ LPat (GhcPass 'Typechecked)
    pat)            = LPat (GhcPass 'Typechecked) -> [Id] -> [Id]
    collectl LPat (GhcPass 'Typechecked)
    pat [Id]
    bndrs
        go (BangPat XBangPat (GhcPass 'Typechecked)
    _ LPat (GhcPass 'Typechecked)
    pat)            = LPat (GhcPass 'Typechecked) -> [Id] -> [Id]
    collectl LPat (GhcPass 'Typechecked)
    pat [Id]
    bndrs
        go (AsPat XAsPat (GhcPass 'Typechecked)
    _ (L SrcSpan
    _ IdP (GhcPass 'Typechecked)
    a) LPat (GhcPass 'Typechecked)
    pat)      = Id
    IdP (GhcPass 'Typechecked)
    a Id -> [Id] -> [Id]
    forall a. a -> [a] -> [a]
    : LPat (GhcPass 'Typechecked) -> [Id] -> [Id]
    collectl LPat (GhcPass 'Typechecked)
    pat [Id]
    bndrs
        go (ParPat XParPat (GhcPass 'Typechecked)
    _ LPat (GhcPass 'Typechecked)
    pat)             = LPat (GhcPass 'Typechecked) -> [Id] -> [Id]
    collectl LPat (GhcPass 'Typechecked)
    pat [Id]
    bndrs

        go (ListPat XListPat (GhcPass 'Typechecked)
    _ [LPat (GhcPass 'Typechecked)]
    pats)           = (Located (Pat (GhcPass 'Typechecked)) -> [Id] -> [Id])
    -> [Id] -> [Located (Pat (GhcPass 'Typechecked))] -> [Id]
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr Located (Pat (GhcPass 'Typechecked)) -> [Id] -> [Id]
    LPat (GhcPass 'Typechecked) -> [Id] -> [Id]
    collectl [Id]
    bndrs [Located (Pat (GhcPass 'Typechecked))]
    [LPat (GhcPass 'Typechecked)]
    pats
        go (TuplePat XTuplePat (GhcPass 'Typechecked)
    _ [LPat (GhcPass 'Typechecked)]
    pats Boxity
    _)        = (Located (Pat (GhcPass 'Typechecked)) -> [Id] -> [Id])
    -> [Id] -> [Located (Pat (GhcPass 'Typechecked))] -> [Id]
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr Located (Pat (GhcPass 'Typechecked)) -> [Id] -> [Id]
    LPat (GhcPass 'Typechecked) -> [Id] -> [Id]
    collectl [Id]
    bndrs [Located (Pat (GhcPass 'Typechecked))]
    [LPat (GhcPass 'Typechecked)]
    pats
        go (SumPat XSumPat (GhcPass 'Typechecked)
    _ LPat (GhcPass 'Typechecked)
    pat Int
    _ Int
    _)         = LPat (GhcPass 'Typechecked) -> [Id] -> [Id]
    collectl LPat (GhcPass 'Typechecked)
    pat [Id]
    bndrs

        go (ConPat { pat_args :: forall p. Pat p -> HsConPatDetails p
    pat_args = HsConPatDetails (GhcPass 'Typechecked)
    ps
                   , pat_con_ext :: forall p. Pat p -> XConPat p
    pat_con_ext = ConPatTc { cpt_binds :: ConPatTc -> TcEvBinds
    cpt_binds = TcEvBinds
    ds }}) =
                                        TcEvBinds -> [Id]
    collectEvBinders TcEvBinds
    ds
                                        [Id] -> [Id] -> [Id]
    forall a. [a] -> [a] -> [a]
    ++ (Located (Pat (GhcPass 'Typechecked)) -> [Id] -> [Id])
    -> [Id] -> [Located (Pat (GhcPass 'Typechecked))] -> [Id]
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr Located (Pat (GhcPass 'Typechecked)) -> [Id] -> [Id]
    LPat (GhcPass 'Typechecked) -> [Id] -> [Id]
    collectl [Id]
    bndrs (HsConPatDetails (GhcPass 'Typechecked)
    -> [LPat (GhcPass 'Typechecked)]
    forall p. HsConPatDetails p -> [LPat p]
    hsConPatArgs HsConPatDetails (GhcPass 'Typechecked)
    ps)
        go (LitPat XLitPat (GhcPass 'Typechecked)
    _ HsLit (GhcPass 'Typechecked)
    _)               = [Id]
    bndrs
        go (NPat {})                  = [Id]
    bndrs
        go (NPlusKPat XNPlusKPat (GhcPass 'Typechecked)
    _ (L SrcSpan
    _ IdP (GhcPass 'Typechecked)
    n) Located (HsOverLit (GhcPass 'Typechecked))
    _ HsOverLit (GhcPass 'Typechecked)
    _ SyntaxExpr (GhcPass 'Typechecked)
    _ SyntaxExpr (GhcPass 'Typechecked)
    _) = Id
    IdP (GhcPass 'Typechecked)
    n Id -> [Id] -> [Id]
    forall a. a -> [a] -> [a]
    : [Id]
    bndrs

        go (SigPat XSigPat (GhcPass 'Typechecked)
    _ LPat (GhcPass 'Typechecked)
    pat HsPatSigType (NoGhcTc (GhcPass 'Typechecked))
    _)           = LPat (GhcPass 'Typechecked) -> [Id] -> [Id]
    collectl LPat (GhcPass 'Typechecked)
    pat [Id]
    bndrs
        go (XPat (CoPat HsWrapper
    _ Pat (GhcPass 'Typechecked)
    pat Type
    _))     = LPat (GhcPass 'Typechecked) -> [Id] -> [Id]
    collectl (Pat (GhcPass 'Typechecked) -> Located (Pat (GhcPass 'Typechecked))
    forall e. e -> Located e
    noLoc Pat (GhcPass 'Typechecked)
    pat) [Id]
    bndrs
        go (ViewPat XViewPat (GhcPass 'Typechecked)
    _ LHsExpr (GhcPass 'Typechecked)
    _ LPat (GhcPass 'Typechecked)
    pat)          = LPat (GhcPass 'Typechecked) -> [Id] -> [Id]
    collectl LPat (GhcPass 'Typechecked)
    pat [Id]
    bndrs
        go p :: Pat (GhcPass 'Typechecked)
    p@(SplicePat {})           = String -> SDoc -> [Id]
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "collectl/go" (Pat (GhcPass 'Typechecked) -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Pat (GhcPass 'Typechecked)
    p)

    collectEvBinders :: TcEvBinds -> [Id]
    collectEvBinders :: TcEvBinds -> [Id]
    collectEvBinders (EvBinds Bag EvBind
    bs)   = (EvBind -> [Id] -> [Id]) -> [Id] -> Bag EvBind -> [Id]
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr EvBind -> [Id] -> [Id]
    add_ev_bndr [] Bag EvBind
    bs
    collectEvBinders (TcEvBinds {}) = String -> [Id]
    forall a. String -> a
    panic String
    "ToDo: collectEvBinders"

    add_ev_bndr :: EvBind -> [Id] -> [Id]
    add_ev_bndr :: EvBind -> [Id] -> [Id]
    add_ev_bndr (EvBind { eb_lhs :: EvBind -> Id
    eb_lhs = Id
    b }) [Id]
    bs | Id -> Bool
    isId Id
    b    = Id
    bId -> [Id] -> [Id]
    forall a. a -> [a] -> [a]
    :[Id]
    bs
                                           | Bool
    otherwise = [Id]
    bs
      -- A worry: what about coercion variable binders??

    collectLStmtsBinders :: [LStmt GhcTc body] -> [Id]
    collectLStmtsBinders :: forall body. [LStmt (GhcPass 'Typechecked) body] -> [Id]
    collectLStmtsBinders = (LStmt (GhcPass 'Typechecked) body -> [Id])
    -> [LStmt (GhcPass 'Typechecked) body] -> [Id]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap LStmt (GhcPass 'Typechecked) body -> [Id]
    forall body. LStmt (GhcPass 'Typechecked) body -> [Id]
    collectLStmtBinders

    collectLStmtBinders :: LStmt GhcTc body -> [Id]
    collectLStmtBinders :: forall body. LStmt (GhcPass 'Typechecked) body -> [Id]
    collectLStmtBinders = Stmt (GhcPass 'Typechecked) body -> [Id]
    forall body. Stmt (GhcPass 'Typechecked) body -> [Id]
    collectStmtBinders (Stmt (GhcPass 'Typechecked) body -> [Id])
    -> (GenLocated SrcSpan (Stmt (GhcPass 'Typechecked) body)
        -> Stmt (GhcPass 'Typechecked) body)
    -> GenLocated SrcSpan (Stmt (GhcPass 'Typechecked) body)
    -> [Id]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . GenLocated SrcSpan (Stmt (GhcPass 'Typechecked) body)
    -> Stmt (GhcPass 'Typechecked) body
    forall l e. GenLocated l e -> e
    unLoc

    collectStmtBinders :: Stmt GhcTc body -> [Id]
    collectStmtBinders :: forall body. Stmt (GhcPass 'Typechecked) body -> [Id]
    collectStmtBinders (RecStmt { recS_later_ids :: forall idL idR body. StmtLR idL idR body -> [IdP idR]
    recS_later_ids = [IdP (GhcPass 'Typechecked)]
    later_ids }) = [Id]
    [IdP (GhcPass 'Typechecked)]
    later_ids
    collectStmtBinders StmtLR (GhcPass 'Typechecked) (GhcPass 'Typechecked) body
    stmt = StmtLR (GhcPass 'Typechecked) (GhcPass 'Typechecked) body
    -> [IdP (GhcPass 'Typechecked)]
    forall (idL :: Pass) (idR :: Pass) body.
    CollectPass (GhcPass idL) =>
    StmtLR (GhcPass idL) (GhcPass idR) body -> [IdP (GhcPass idL)]
    HsUtils.collectStmtBinders StmtLR (GhcPass 'Typechecked) (GhcPass 'Typechecked) body
    stmt