    {-# LANGUAGE TypeFamilies #-}
    {-# LANGUAGE BlockArguments #-}
    {-# LANGUAGE TupleSections #-}

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

    Desugaring arrow commands
    -}

    module GHC.HsToCore.Arrows ( dsProcExpr ) where

    import GHC.Prelude

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

    import GHC.Hs
    import GHC.Hs.Syn.Type

    -- 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, dsLocalBinds,
                                              dsSyntaxExpr )

    import GHC.Tc.Utils.TcType
    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.Utils.Panic
    import GHC.Types.Var.Set
    import GHC.Types.SrcLoc
    import GHC.Data.List.SetOps( assocMaybe )
    import Data.Foldable (toList)
    import Data.List (mapAccumL)
    import Data.List.NonEmpty (NonEmpty(..), nonEmpty)
    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 { (meth_binds, 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     = [(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 = [(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   = [(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     = [(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  = [(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    = [(Name, Id)] -> Name -> Maybe Id
    forall a b. Eq a => Assoc a b -> a -> Maybe b
    assocMaybe [(Name, Id)]
    prs Name
    loopAName

           ; return (meth_binds, DsCmdEnv {
                   arr_id     = Var (unmaybe the_arr_id arrAName),
                   compose_id = Var (unmaybe the_compose_id composeAName),
                   first_id   = Var (unmaybe the_first_id firstAName),
                   app_id     = Var (unmaybe the_app_id appAName),
                   choice_id  = Var (unmaybe the_choice_id choiceAName),
                   loop_id    = Var (unmaybe the_loop_id 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 { rhs <- HsExpr (GhcPass 'Typechecked) -> DsM CoreExpr
    dsExpr HsExpr (GhcPass 'Typechecked)
    expr
               ; id <- newSysLocalDs ManyTy (exprType rhs)
               -- no check needed; these are functions
               ; return (NonRec id rhs, (std_name, 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
    forall doc. IsLine doc => String -> doc
    text String
    "Not found:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> a -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr a
    name)
        unmaybe (Just a
    id) a
    _  = a
    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

    -- 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
        a_var <- Type -> Type -> DsM Id
    newSysLocalDs Type
    ManyTy Type
    a_ty
        b_var <- newSysLocalDs ManyTy b_ty
        pair_var <- newSysLocalDs ManyTy (mkCorePairTy a_ty b_ty)
        return (Lam pair_var
                   (coreCasePair pair_var a_var b_var (Var 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
        a_var <- Type -> Type -> DsM Id
    newSysLocalDs Type
    ManyTy Type
    a_ty
        b_var <- newSysLocalDs ManyTy b_ty
        pair_var <- newSysLocalDs ManyTy (mkCorePairTy a_ty b_ty)
        return (Lam pair_var
                   (coreCasePair pair_var a_var b_var (Var 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 :: Id -> [Id] -> CoreExpr -> DsM CoreExpr
    coreCaseTuple :: Id -> [Id] -> CoreExpr -> DsM CoreExpr
    coreCaseTuple Id
    scrut_var [Id]
    vars CoreExpr
    body
      = [Id] -> CoreExpr -> CoreExpr -> DsM CoreExpr
    forall (m :: * -> *).
    MonadUnique m =>
    [Id] -> CoreExpr -> CoreExpr -> m CoreExpr
    mkBigTupleCase [Id]
    vars CoreExpr
    body (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 (HasDebugCallStack => CoreExpr -> Type
    CoreExpr -> Type
    exprType CoreExpr
    body)
             [AltCon -> [Id] -> CoreExpr -> Alt Id
    forall b. AltCon -> [b] -> Expr b -> Alt b
    Alt (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 []

    {- Note [Environment and stack]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    The input is divided into

    * A local environment, which is a flat tuple (unless it's too big)
      The elements of the local environment can be
      - of kind Type (for ordinary variables), or
      - of kind Constraint (for dictionaries bound by patterns)

    * A stack, which is a right-nested pair.
      The elements on the stack are always of kind Type.

    So 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
    HasDebugCallStack => [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
        tup_var <- Type -> Type -> DsM Id
    newSysLocalDs Type
    ManyTy ([Id] -> Type
    HasDebugCallStack => [Id] -> Type
    mkBigCoreVarTupTy [Id]
    env_ids)
        match_env <- coreCaseTuple tup_var env_ids body
        pair_id <- newSysLocalDs ManyTy (mkCorePairTy (idType tup_var) (idType stack_id))
        return (Lam pair_id (coreCasePair pair_id tup_var stack_id 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
        tup_id <- Type -> Type -> DsM Id
    newSysLocalDs Type
    ManyTy ([Id] -> Type
    HasDebugCallStack => [Id] -> Type
    mkBigCoreVarTupTy [Id]
    env_ids)
        tup_case <- coreCaseTuple tup_id env_ids body
        return (Lam tup_id tup_case)

    ----------------------------------------------
    --              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 a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    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
        (tail_id, tail_code) <- [Id] -> Id -> CoreExpr -> DsM (Id, CoreExpr)
    matchVarStack [Id]
    param_ids Id
    stack_id CoreExpr
    body
        pair_id <- newSysLocalDs ManyTy (mkCorePairTy (idType param_id) (idType tail_id))
        return (pair_id, coreCasePair pair_id param_id tail_id tail_code)

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

    -- 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 EpAnnCO
    _ (HsCmdTop (CmdTopTc Type
    _unitTy Type
    cmd_ty CmdSyntaxTable (GhcPass 'Typechecked)
    ids) LHsCmd (GhcPass 'Typechecked)
    cmd)) = do
        (meth_binds, meth_ids) <- CmdSyntaxTable (GhcPass 'Typechecked) -> DsM ([CoreBind], DsCmdEnv)
    mkCmdEnv CmdSyntaxTable (GhcPass 'Typechecked)
    ids
        let locals = [Id] -> VarSet
    mkVarSet (CollectFlag (GhcPass 'Typechecked)
    -> LPat (GhcPass 'Typechecked) -> [IdP (GhcPass 'Typechecked)]
    forall p. CollectPass p => CollectFlag p -> LPat p -> [IdP p]
    collectPatBinders CollectFlag (GhcPass 'Typechecked)
    CollWithDictBinders LPat (GhcPass 'Typechecked)
    pat)
        (core_cmd, _free_vars, env_ids)
           <- dsfixCmd meth_ids locals unitTy cmd_ty cmd
        let env_ty = [Id] -> Type
    HasDebugCallStack => [Id] -> Type
    mkBigCoreVarTupTy [Id]
    env_ids
        let env_stk_ty = Type -> Type -> Type
    mkCorePairTy Type
    env_ty Type
    unitTy
        let env_stk_expr = CoreExpr -> CoreExpr -> CoreExpr
    mkCorePairExpr ([Id] -> CoreExpr
    mkBigCoreVarTup [Id]
    env_ids) CoreExpr
    mkCoreUnitExpr
        fail_expr <- mkFailExpr (ArrowMatchCtxt ProcExpr) env_stk_ty
        var <- selectSimpleMatchVarL ManyTy pat
        match_code <- matchSimply (Var var) (ArrowMatchCtxt ProcExpr) ManyTy pat env_stk_expr fail_expr
        let pat_ty = LPat (GhcPass 'Typechecked) -> Type
    hsLPatType LPat (GhcPass 'Typechecked)
    pat
        let 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
        return (mkLets meth_binds 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 (LocatedA (HsCmd (GhcPass 'Typechecked))
    -> HsCmd (GhcPass 'Typechecked)
    forall l e. GenLocated l e -> e
    unLoc LHsCmd (GhcPass 'Typechecked)
    LocatedA (HsCmd (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 XCmdArrApp (GhcPass 'Typechecked)
    Type
    arrow_ty
            (Type
    _a_ty, Type
    arg_ty) = Type -> (Type, Type)
    tcSplitAppTy Type
    a_arg_ty
        core_arrow <- LHsExpr (GhcPass 'Typechecked) -> DsM CoreExpr
    dsLExpr LHsExpr (GhcPass 'Typechecked)
    arrow
        core_arg   <- dsLExpr arg
        stack_id   <- newSysLocalDs ManyTy stack_ty
        core_make_arg <- matchEnvStack env_ids stack_id core_arg
        return (do_premap ids
                  (envStackType env_ids stack_ty)
                  arg_ty
                  res_ty
                  core_make_arg
                  core_arrow,
                exprFreeIdsDSet core_arg `uniqDSetIntersectUniqSet` 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 XCmdArrApp (GhcPass 'Typechecked)
    Type
    arrow_ty
            (Type
    _a_ty, Type
    arg_ty) = Type -> (Type, Type)
    tcSplitAppTy Type
    a_arg_ty

        core_arrow <- LHsExpr (GhcPass 'Typechecked) -> DsM CoreExpr
    dsLExpr LHsExpr (GhcPass 'Typechecked)
    arrow
        core_arg   <- dsLExpr arg
        stack_id   <- newSysLocalDs ManyTy stack_ty
        core_make_pair <- matchEnvStack env_ids stack_id
              (mkCorePairExpr core_arrow core_arg)

        return (do_premap ids
                  (envStackType env_ids stack_ty)
                  (mkCorePairTy arrow_ty arg_ty)
                  res_ty
                  core_make_pair
                  (do_app ids arg_ty res_ty),
                (exprsFreeIdsDSet [core_arrow, core_arg])
                  `uniqDSetIntersectUniqSet` 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
        core_arg <- LHsExpr (GhcPass 'Typechecked) -> DsM CoreExpr
    dsLExpr LHsExpr (GhcPass 'Typechecked)
    arg
        let
            arg_ty = HasDebugCallStack => CoreExpr -> Type
    CoreExpr -> Type
    exprType CoreExpr
    core_arg
            stack_ty' = Type -> Type -> Type
    mkCorePairTy Type
    arg_ty Type
    stack_ty
        (core_cmd, free_vars, env_ids')
                 <- dsfixCmd ids local_vars stack_ty' res_ty cmd
        stack_id <- newSysLocalDs ManyTy stack_ty
        arg_id <- newSysLocalDs ManyTy arg_ty
        -- push the argument expression onto the stack
        let
            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 = HasDebugCallStack => Id -> CoreExpr -> CoreExpr -> CoreExpr
    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
        core_map <- matchEnvStack env_ids stack_id core_body
        return (do_premap ids
                          (envStackType env_ids stack_ty)
                          (envStackType env_ids' stack_ty')
                          res_ty
                          core_map
                          core_cmd,
                free_vars `unionDVarSet`
                  (exprFreeIdsDSet core_arg `uniqDSetIntersectUniqSet` local_vars))

    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
        core_cond <- LHsExpr (GhcPass 'Typechecked) -> DsM CoreExpr
    dsLExpr LHsExpr (GhcPass 'Typechecked)
    cond
        (core_then, fvs_then, then_ids)
           <- dsfixCmd ids local_vars stack_ty res_ty then_cmd
        (core_else, fvs_else, else_ids)
           <- dsfixCmd ids local_vars stack_ty res_ty else_cmd
        stack_id   <- newSysLocalDs ManyTy stack_ty
        either_con <- dsLookupTyCon eitherTyConName
        left_con   <- dsLookupDataCon leftDataConName
        right_con  <- dsLookupDataCon rightDataConName

        let 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
    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 = [Id] -> Type -> Type
    envStackType [Id]
    env_ids Type
    stack_ty
            then_ty = [Id] -> Type -> Type
    envStackType [Id]
    then_ids Type
    stack_ty
            else_ty = [Id] -> Type -> Type
    envStackType [Id]
    else_ids Type
    stack_ty
            sum_ty = TyCon -> [Type] -> Type
    mkTyConApp TyCon
    either_con [Type
    then_ty, Type
    else_ty]
            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  = 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 = Type -> Type -> CoreExpr -> CoreExpr
    mk_right_expr Type
    then_ty Type
    else_ty
                           ([Id] -> Id -> CoreExpr
    buildEnvStack [Id]
    else_ids Id
    stack_id)

        core_if <- case 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 { fun_apps <- SyntaxExpr (GhcPass 'Typechecked) -> [CoreExpr] -> DsM CoreExpr
    dsSyntaxExpr SyntaxExpr (GhcPass 'Typechecked)
    mb_fun
                                          [CoreExpr
    core_cond, CoreExpr
    core_left, CoreExpr
    core_right]
                   ; matchEnvStack env_ids stack_id fun_apps }

        return (do_premap ids in_ty sum_ty res_ty
                    core_if
                    (do_choice ids then_ty else_ty res_ty core_then core_else),
            fvs_cond `unionDVarSet` fvs_then `unionDVarSet` fvs_else)

    {-
    Note [Desugaring HsCmdCase]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~
    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 MatchGroup (GhcPass 'Typechecked) (LHsCmd (GhcPass 'Typechecked))
    match) [Id]
    env_ids = do
        stack_id <- Type -> Type -> DsM Id
    newSysLocalDs Type
    ManyTy Type
    stack_ty
        (match', core_choices)
          <- dsCases ids local_vars stack_id stack_ty res_ty match
        let MG{ mg_ext = MatchGroupTc _ sum_ty _ } = match'
            in_ty = [Id] -> Type -> Type
    envStackType [Id]
    env_ids Type
    stack_ty

        core_body <- dsExpr (HsCase (ArrowMatchCtxt ArrowCaseAlt) exp match')

        core_matches <- matchEnvStack env_ids stack_id core_body
        return (do_premap ids in_ty sum_ty res_ty core_matches core_choices,
                exprFreeIdsDSet core_body `uniqDSetIntersectUniqSet` local_vars)

    {-
    \cases and \case are desugared analogously to a case command (see above).
    For example

            \cases {p1 q1 -> c1; p2 q2 -> c2; p3 q3 -> c3 }

    is translated to

            premap (\ ((xs), (e1, (e2,stk))) -> cases e1 e2 of
                      p1 q1 -> (Left (Left (xs1), stk))
                      p2 q2 -> Left ((Right (xs2), stk))
                      p3 q3 -> Right ((xs3), stk))
            ((c1 ||| c2) ||| c3)

    (cases...of is hypothetical notation that works like case...of but with
    multiple scrutinees)

    -}
    dsCmd DsCmdEnv
    ids VarSet
    local_vars Type
    stack_ty Type
    res_ty
            (HsCmdLam XCmdLamCase (GhcPass 'Typechecked)
    _ HsLamVariant
    LamSingle (MG { mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
    mg_alts
              = (L SrcSpanAnnL
    _ [L SrcSpanAnnA
    _ (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) (LocatedA (HsCmd (GhcPass 'Typechecked)))
    _ [L EpAnnCO
    _ (GRHS XCGRHS
      (GhcPass 'Typechecked) (LocatedA (HsCmd (GhcPass 'Typechecked)))
    _ [] LocatedA (HsCmd (GhcPass 'Typechecked))
    body)] HsLocalBinds (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)
    LocatedA (HsCmd (GhcPass 'Typechecked))
    body [Id]
    env_ids

    dsCmd DsCmdEnv
    ids VarSet
    local_vars Type
    stack_ty Type
    res_ty
          (HsCmdLam XCmdLamCase (GhcPass 'Typechecked)
    _ HsLamVariant
    lam_variant match :: MatchGroup (GhcPass 'Typechecked) (LHsCmd (GhcPass 'Typechecked))
    match@MG { mg_ext :: forall p body. MatchGroup p body -> XMG p body
    mg_ext = MatchGroupTc {mg_arg_tys :: MatchGroupTc -> [Scaled Type]
    mg_arg_tys = [Scaled Type]
    arg_tys} } )
          [Id]
    env_ids = do
        arg_ids <- [Scaled Type] -> DsM [Id]
    newSysLocalsDs [Scaled Type]
    arg_tys

        let match_ctxt = HsLamVariant -> HsArrowMatchContext
    ArrowLamAlt HsLamVariant
    lam_variant
            pat_vars = [Id] -> VarSet
    mkVarSet [Id]
    arg_ids
            local_vars' = VarSet
    pat_vars VarSet -> VarSet -> VarSet
    `unionVarSet` VarSet
    local_vars
            (pat_tys, stack_ty') = splitTypeAt (length arg_tys) stack_ty

        -- construct and desugar a case expression with multiple scrutinees
        (core_body, free_vars, env_ids') <- trimInput \[Id]
    env_ids -> do
          stack_id <- Type -> Type -> DsM Id
    newSysLocalDs Type
    ManyTy Type
    stack_ty'
          (match', core_choices)
            <- dsCases ids local_vars' stack_id stack_ty' res_ty match

          let MG{ mg_ext = MatchGroupTc _ sum_ty _ } = match'
              in_ty = [Id] -> Type -> Type
    envStackType [Id]
    env_ids Type
    stack_ty'
              discrims = (Id -> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
    -> [Id] -> [GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))]
    forall a b. (a -> b) -> [a] -> [b]
    map IdP (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
    Id -> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
    forall (p :: Pass) a.
    IsSrcSpanAnn p a =>
    IdP (GhcPass p) -> LHsExpr (GhcPass p)
    nlHsVar [Id]
    arg_ids
          (discrim_vars, matching_code)
            <- matchWrapper (ArrowMatchCtxt match_ctxt) (Just discrims) match'
          core_body <- flip (bind_vars discrim_vars) matching_code <$>
            traverse dsLExpr discrims

          core_matches <- matchEnvStack env_ids stack_id core_body
          return (do_premap ids in_ty sum_ty res_ty core_matches core_choices,
                  exprFreeIdsDSet core_body `uniqDSetIntersectUniqSet` local_vars')

        param_ids <- mapM (newSysLocalDs ManyTy) pat_tys
        stack_id' <- newSysLocalDs ManyTy 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 = [Id] -> Id -> CoreExpr
    buildEnvStack [Id]
    env_ids' Id
    stack_id'
            in_ty = [Id] -> Type -> Type
    envStackType [Id]
    env_ids Type
    stack_ty
            in_ty' = [Id] -> Type -> Type
    envStackType [Id]
    env_ids' Type
    stack_ty'

        -- bind the scrutinees to the parameters
        let match_code = [Id] -> [CoreExpr] -> CoreExpr -> CoreExpr
    bind_vars [Id]
    arg_ids ((Id -> CoreExpr) -> [Id] -> [CoreExpr]
    forall a b. (a -> b) -> [a] -> [b]
    map Id -> CoreExpr
    forall b. Id -> Expr b
    Var [Id]
    param_ids) CoreExpr
    core_expr

        -- match the parameters against the top of the old stack
        (stack_id, param_code) <- matchVarStack param_ids stack_id' match_code
        -- match the old environment and stack against the input
        select_code <- matchEnvStack env_ids stack_id param_code
        return (do_premap ids in_ty in_ty' res_ty select_code core_body,
                free_vars `uniqDSetMinusUniqSet` pat_vars)
        where
          bind_vars :: [Id] -> [CoreExpr] -> CoreExpr -> CoreExpr
    bind_vars [Id]
    vars [CoreExpr]
    exprs CoreExpr
    expr = ((Id, CoreExpr) -> CoreExpr -> CoreExpr)
    -> CoreExpr -> [(Id, CoreExpr)] -> CoreExpr
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr ((Id -> CoreExpr -> CoreExpr -> CoreExpr)
    -> (Id, CoreExpr) -> CoreExpr -> CoreExpr
    forall a b c. (a -> b -> c) -> (a, b) -> c
    uncurry HasDebugCallStack => Id -> CoreExpr -> CoreExpr -> CoreExpr
    Id -> CoreExpr -> CoreExpr -> CoreExpr
    bindNonRec) CoreExpr
    expr ([(Id, CoreExpr)] -> CoreExpr) -> [(Id, CoreExpr)] -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $ [Id] -> [CoreExpr] -> [(Id, CoreExpr)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Id]
    vars [CoreExpr]
    exprs

    -- 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 :: HsLocalBinds (GhcPass 'Typechecked)
    lbinds@HsLocalBinds (GhcPass 'Typechecked)
    binds LHsCmd (GhcPass 'Typechecked)
    body) [Id]
    env_ids = do
        let
            defined_vars :: VarSet
    defined_vars = [Id] -> VarSet
    mkVarSet (CollectFlag (GhcPass 'Typechecked)
    -> HsLocalBinds (GhcPass 'Typechecked)
    -> [IdP (GhcPass 'Typechecked)]
    forall (idL :: Pass) (idR :: Pass).
    CollectPass (GhcPass idL) =>
    CollectFlag (GhcPass idL)
    -> HsLocalBindsLR (GhcPass idL) (GhcPass idR)
    -> [IdP (GhcPass idL)]
    collectLocalBinders CollectFlag (GhcPass 'Typechecked)
    CollWithDictBinders HsLocalBinds (GhcPass 'Typechecked)
    binds)
            local_vars' :: VarSet
    local_vars' = VarSet
    defined_vars VarSet -> VarSet -> VarSet
    `unionVarSet` VarSet
    local_vars

        (core_body, _free_vars, 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
        stack_id <- newSysLocalDs ManyTy stack_ty
        -- build a new environment, plus the stack, using the let bindings
        core_binds <- dsLocalBinds lbinds (buildEnvStack env_ids' stack_id)
        -- match the old environment and stack against the input
        core_map <- matchEnvStack env_ids stack_id core_binds
        return (do_premap ids
                            (envStackType env_ids stack_ty)
                            (envStackType env_ids' stack_ty)
                            res_ty
                            core_map
                            core_body,
            exprFreeIdsDSet core_binds `uniqDSetIntersectUniqSet` 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 (HsCmdDo XCmdDo (GhcPass 'Typechecked)
    _ (L SrcSpanAnnL
    _ [GenLocated
       SrcSpanAnnA
       (StmtLR
          (GhcPass 'Typechecked)
          (GhcPass 'Typechecked)
          (LocatedA (HsCmd (GhcPass 'Typechecked))))]
    stmts)) [Id]
    env_ids = do
        (core_stmts, env_ids') <- DsCmdEnv
    -> VarSet
    -> Type
    -> [CmdLStmt (GhcPass 'Typechecked)]
    -> [Id]
    -> DsM (CoreExpr, DIdSet)
    dsCmdDo DsCmdEnv
    ids VarSet
    local_vars Type
    res_ty [CmdLStmt (GhcPass 'Typechecked)]
    [GenLocated
       SrcSpanAnnA
       (StmtLR
          (GhcPass 'Typechecked)
          (GhcPass 'Typechecked)
          (LocatedA (HsCmd (GhcPass 'Typechecked))))]
    stmts [Id]
    env_ids
        let env_ty = [Id] -> Type
    HasDebugCallStack => [Id] -> Type
    mkBigCoreVarTupTy [Id]
    env_ids
        core_fst <- mkFstExpr env_ty stack_ty
        return (do_premap ids
                    (mkCorePairTy env_ty stack_ty)
                    env_ty
                    res_ty
                    core_fst
                    core_stmts,
            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
    HasDebugCallStack => [Id] -> Type
    mkBigCoreVarTupTy [Id]
    env_ids
        core_op <- LHsExpr (GhcPass 'Typechecked) -> DsM CoreExpr
    dsLExpr LHsExpr (GhcPass 'Typechecked)
    op
        (core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args
        return (mkApps (App core_op (Type env_ty)) core_args,
                unionDVarSets 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
        (core_cmd, 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
        dsHsWrapper wrap $ \CoreExpr -> CoreExpr
    core_wrap ->
          (CoreExpr, DIdSet) -> DsM (CoreExpr, DIdSet)
    forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CoreExpr -> CoreExpr
    core_wrap CoreExpr
    core_cmd, DIdSet
    env_ids')

    -- 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 EpAnnCO
    _ (HsCmdTop
                                     (CmdTopTc Type
    stack_ty Type
    cmd_ty CmdSyntaxTable (GhcPass 'Typechecked)
    ids) LHsCmd (GhcPass 'Typechecked)
    cmd )) = do
        (meth_binds, meth_ids) <- CmdSyntaxTable (GhcPass 'Typechecked) -> DsM ([CoreBind], DsCmdEnv)
    mkCmdEnv CmdSyntaxTable (GhcPass 'Typechecked)
    ids
        (core_cmd, free_vars, env_ids')
           <- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd
        stack_id <- newSysLocalDs ManyTy stack_ty
        trim_code
          <- matchEnvStack env_ids stack_id (buildEnvStack env_ids' stack_id)
        let
            in_ty = [Id] -> Type -> Type
    envStackType [Id]
    env_ids Type
    stack_ty
            in_ty' = [Id] -> Type -> Type
    envStackType [Id]
    env_ids' Type
    stack_ty
            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
        return (mkLets meth_binds arg_code, 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
      = ([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
            (core_cmd, free_vars) <- [Id] -> DsM (CoreExpr, DIdSet)
    build_arrow [Id]
    env_ids
            return (core_cmd, free_vars, dVarSetElems free_vars))

    -- Desugaring for both HsCmdLam
    --
    -- 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 (CollectFlag (GhcPass 'Typechecked)
    -> [LPat (GhcPass 'Typechecked)] -> [IdP (GhcPass 'Typechecked)]
    forall p. CollectPass p => CollectFlag p -> [LPat p] -> [IdP p]
    collectPatsBinders CollectFlag (GhcPass 'Typechecked)
    CollWithDictBinders [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 ([GenLocated SrcSpanAnnA (Pat (GhcPass 'Typechecked))] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [LPat (GhcPass 'Typechecked)]
    [GenLocated SrcSpanAnnA (Pat (GhcPass 'Typechecked))]
    pats) Type
    stack_ty
        (core_body, free_vars, 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
        param_ids <- mapM (newSysLocalDs ManyTy) pat_tys
        stack_id' <- newSysLocalDs ManyTy 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 = [Id] -> Id -> CoreExpr
    buildEnvStack [Id]
    env_ids' Id
    stack_id'
            in_ty = [Id] -> Type -> Type
    envStackType [Id]
    env_ids Type
    stack_ty
            in_ty' = [Id] -> Type -> Type
    envStackType [Id]
    env_ids' Type
    stack_ty'
            lam_cxt = HsArrowMatchContext -> HsMatchContext fn
    forall fn. HsArrowMatchContext -> HsMatchContext fn
    ArrowMatchCtxt (HsLamVariant -> HsArrowMatchContext
    ArrowLamAlt HsLamVariant
    LamSingle)

        fail_expr <- mkFailExpr lam_cxt in_ty'
        -- match the patterns against the parameters
        match_code <- matchSimplys (map Var param_ids) lam_cxt pats core_expr
                        fail_expr
        -- match the parameters against the top of the old stack
        (stack_id, param_code) <- matchVarStack param_ids stack_id' match_code
        -- match the old environment and stack against the input
        select_code <- matchEnvStack env_ids stack_id param_code
        return (do_premap ids in_ty in_ty' res_ty select_code core_body,
                free_vars `uniqDSetMinusUniqSet` pat_vars)

    -- Used for case and \case(s)
    -- See Note [Desugaring HsCmdCase]
    dsCases :: DsCmdEnv                               -- arrow combinators
            -> IdSet                                  -- set of local vars available to this command
            -> Id                                     -- stack id
            -> Type                                   -- type of the stack (right-nested tuple)
            -> Type                                   -- return type of the command
            -> MatchGroup GhcTc (LHsCmd GhcTc)        -- match group to desugar
            -> DsM (MatchGroup GhcTc (LHsExpr GhcTc), -- match group with choice tree
                    CoreExpr)                         -- desugared choices
    dsCases :: DsCmdEnv
    -> VarSet
    -> Id
    -> Type
    -> Type
    -> MatchGroup
         (GhcPass 'Typechecked) (LHsCmd (GhcPass 'Typechecked))
    -> DsM
         (MatchGroup
            (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked)),
          CoreExpr)
    dsCases DsCmdEnv
    ids VarSet
    local_vars Id
    stack_id Type
    stack_ty Type
    res_ty
            (MG { mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
    mg_alts = L SrcSpanAnnL
    l [GenLocated
       SrcSpanAnnA
       (Match
          (GhcPass 'Typechecked) (LocatedA (HsCmd (GhcPass 'Typechecked))))]
    matches
                , mg_ext :: forall p body. MatchGroup p body -> XMG p body
    mg_ext = MatchGroupTc [Scaled Type]
    arg_tys Type
    _ Origin
    origin
                }) = do

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

      let leaves :: [(LocatedA (HsCmd (GhcPass 'Typechecked)), VarSet)]
    leaves = (GenLocated
       SrcSpanAnnA
       (Match
          (GhcPass 'Typechecked) (LocatedA (HsCmd (GhcPass 'Typechecked))))
     -> [(LocatedA (HsCmd (GhcPass 'Typechecked)), VarSet)])
    -> [GenLocated
          SrcSpanAnnA
          (Match
             (GhcPass 'Typechecked) (LocatedA (HsCmd (GhcPass 'Typechecked))))]
    -> [(LocatedA (HsCmd (GhcPass 'Typechecked)), VarSet)]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap LMatch
      (GhcPass 'Typechecked) (LocatedA (HsCmd (GhcPass 'Typechecked)))
    -> [(LocatedA (HsCmd (GhcPass 'Typechecked)), VarSet)]
    GenLocated
      SrcSpanAnnA
      (Match
         (GhcPass 'Typechecked) (LocatedA (HsCmd (GhcPass 'Typechecked))))
    -> [(LocatedA (HsCmd (GhcPass 'Typechecked)), VarSet)]
    forall (body :: * -> *).
    LMatch
      (GhcPass 'Typechecked) (LocatedA (body (GhcPass 'Typechecked)))
    -> [(LocatedA (body (GhcPass 'Typechecked)), VarSet)]
    leavesMatch [GenLocated
       SrcSpanAnnA
       (Match
          (GhcPass 'Typechecked) (LocatedA (HsCmd (GhcPass 'Typechecked))))]
    matches
          make_branch :: (LocatedA (HsCmd (GhcPass 'Typechecked)), VarSet)
    -> IOEnv
         (Env DsGblEnv DsLclEnv)
         ([GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))], Type,
          CoreExpr)
    make_branch (LocatedA (HsCmd (GhcPass 'Typechecked))
    leaf, VarSet
    bound_vars) = do
              (core_leaf, _fvs, 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)
    LocatedA (HsCmd (GhcPass 'Typechecked))
    leaf
              return ([mkHsEnvStackExpr leaf_ids stack_id],
                      envStackType leaf_ids stack_ty,
                      core_leaf)

      branches <- ((LocatedA (HsCmd (GhcPass 'Typechecked)), VarSet)
     -> IOEnv
          (Env DsGblEnv DsLclEnv)
          ([GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))], Type,
           CoreExpr))
    -> [(LocatedA (HsCmd (GhcPass 'Typechecked)), VarSet)]
    -> IOEnv
         (Env DsGblEnv DsLclEnv)
         [([GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))], Type,
           CoreExpr)]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM (LocatedA (HsCmd (GhcPass 'Typechecked)), VarSet)
    -> IOEnv
         (Env DsGblEnv DsLclEnv)
         ([GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))], Type,
          CoreExpr)
    make_branch [(LocatedA (HsCmd (GhcPass 'Typechecked)), VarSet)]
    leaves
      either_con <- dsLookupTyCon eitherTyConName
      left_con <- dsLookupDataCon leftDataConName
      right_con <- dsLookupDataCon rightDataConName
      void_ty <- mkTyConTy <$> dsLookupTyCon voidTyConName
      let
          left_id  = ConLike -> HsExpr (GhcPass 'Typechecked)
    mkConLikeTc (DataCon -> ConLike
    RealDataCon DataCon
    left_con)
          right_id = ConLike -> HsExpr (GhcPass 'Typechecked)
    mkConLikeTc (DataCon -> ConLike
    RealDataCon DataCon
    right_con)
          left_expr  Type
    ty1 Type
    ty2 GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
    e = HsExpr (GhcPass 'Typechecked)
    -> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
    forall e a. HasAnnotation e => a -> GenLocated e a
    noLocA (HsExpr (GhcPass 'Typechecked)
     -> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
    -> HsExpr (GhcPass 'Typechecked)
    -> GenLocated SrcSpanAnnA (HsExpr (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 XApp (GhcPass 'Typechecked)
    NoExtField
    noExtField
                             (HsExpr (GhcPass 'Typechecked)
    -> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
    forall e a. HasAnnotation e => a -> GenLocated e a
    noLocA (HsExpr (GhcPass 'Typechecked)
     -> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
    -> HsExpr (GhcPass 'Typechecked)
    -> GenLocated SrcSpanAnnA (HsExpr (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)
    GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
    e
          right_expr Type
    ty1 Type
    ty2 GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
    e = HsExpr (GhcPass 'Typechecked)
    -> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
    forall e a. HasAnnotation e => a -> GenLocated e a
    noLocA (HsExpr (GhcPass 'Typechecked)
     -> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
    -> HsExpr (GhcPass 'Typechecked)
    -> GenLocated SrcSpanAnnA (HsExpr (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 XApp (GhcPass 'Typechecked)
    NoExtField
    noExtField
                             (HsExpr (GhcPass 'Typechecked)
    -> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
    forall e a. HasAnnotation e => a -> GenLocated e a
    noLocA (HsExpr (GhcPass 'Typechecked)
     -> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
    -> HsExpr (GhcPass 'Typechecked)
    -> GenLocated SrcSpanAnnA (HsExpr (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)
    GenLocated SrcSpanAnnA (HsExpr (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 GhcTc], Type, CoreExpr)
                        -> ([LHsExpr GhcTc], Type, CoreExpr)
                        -> ([LHsExpr GhcTc], Type, CoreExpr) -- AZ
          merge_branches ([LHsExpr (GhcPass 'Typechecked)]
    builds1, Type
    in_ty1, CoreExpr
    core_exp1)
                         ([LHsExpr (GhcPass 'Typechecked)]
    builds2, Type
    in_ty2, CoreExpr
    core_exp2)
            = ((GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
     -> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
    -> [GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))]
    -> [GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))]
    forall a b. (a -> b) -> [a] -> [b]
    map (Type
    -> Type
    -> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
    -> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
    left_expr Type
    in_ty1 Type
    in_ty2) [LHsExpr (GhcPass 'Typechecked)]
    [GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))]
    builds1 [GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))]
    -> [GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))]
    -> [GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))]
    forall a. [a] -> [a] -> [a]
    ++
                  (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
     -> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
    -> [GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))]
    -> [GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))]
    forall a b. (a -> b) -> [a] -> [b]
    map (Type
    -> Type
    -> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
    -> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
    right_expr Type
    in_ty1 Type
    in_ty2) [LHsExpr (GhcPass 'Typechecked)]
    [GenLocated SrcSpanAnnA (HsExpr (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)
      (leaves', sum_ty, core_choices) <- case nonEmpty branches of
        Just NonEmpty
      ([GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))], Type,
       CoreExpr)
    bs -> ([GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))], Type,
     CoreExpr)
    -> IOEnv
         (Env DsGblEnv DsLclEnv)
         ([GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))], Type,
          CoreExpr)
    forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (([GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))], Type,
      CoreExpr)
     -> IOEnv
          (Env DsGblEnv DsLclEnv)
          ([GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))], Type,
           CoreExpr))
    -> ([GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))], Type,
        CoreExpr)
    -> IOEnv
         (Env DsGblEnv DsLclEnv)
         ([GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))], Type,
          CoreExpr)
    forall a b. (a -> b) -> a -> b
    $ (([GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))], Type,
      CoreExpr)
     -> ([GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))], Type,
         CoreExpr)
     -> ([GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))], Type,
         CoreExpr))
    -> NonEmpty
         ([GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))], Type,
          CoreExpr)
    -> ([GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))], Type,
        CoreExpr)
    forall a. (a -> a -> a) -> NonEmpty a -> a
    foldb ([LHsExpr (GhcPass 'Typechecked)], Type, CoreExpr)
    -> ([LHsExpr (GhcPass 'Typechecked)], Type, CoreExpr)
    -> ([LHsExpr (GhcPass 'Typechecked)], Type, CoreExpr)
    ([GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))], Type,
     CoreExpr)
    -> ([GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))], Type,
        CoreExpr)
    -> ([GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))], Type,
        CoreExpr)
    merge_branches NonEmpty
      ([GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))], Type,
       CoreExpr)
    bs
        -- when the case command has no alternatives, the sum type from
        -- Note [Desugaring HsCmdCase] becomes the empty sum type,
        -- i.e. Void. The choices then effectively become `arr absurd`,
        -- implemented as `arr \case {}`.
        Maybe
      (NonEmpty
         ([GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))], Type,
          CoreExpr))
    Nothing -> ([], Type
    void_ty,) (CoreExpr
     -> ([GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))], Type,
         CoreExpr))
    -> (CoreExpr -> CoreExpr)
    -> CoreExpr
    -> ([GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))], Type,
        CoreExpr)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr
    do_arr DsCmdEnv
    ids Type
    void_ty Type
    res_ty (CoreExpr
     -> ([GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))], Type,
         CoreExpr))
    -> DsM CoreExpr
    -> IOEnv
         (Env DsGblEnv DsLclEnv)
         ([GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))], Type,
          CoreExpr)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$>
          HsExpr (GhcPass 'Typechecked) -> DsM CoreExpr
    dsExpr (XLam (GhcPass 'Typechecked)
    -> HsLamVariant
    -> MatchGroup
         (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked))
    -> HsExpr (GhcPass 'Typechecked)
    forall p.
    XLam p -> HsLamVariant -> MatchGroup p (LHsExpr p) -> HsExpr p
    HsLam [AddEpAnn]
    XLam (GhcPass 'Typechecked)
    forall a. NoAnn a => a
    noAnn HsLamVariant
    LamCase
            (MG { mg_alts :: XRec
      (GhcPass 'Typechecked)
      [LMatch
         (GhcPass 'Typechecked)
         (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))]
    mg_alts = [GenLocated
       (Anno
          (Match
             (GhcPass 'Typechecked)
             (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))))
       (Match
          (GhcPass 'Typechecked)
          (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))]
    -> GenLocated
         (Anno
            [GenLocated
               (Anno
                  (Match
                     (GhcPass 'Typechecked)
                     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))))
               (Match
                  (GhcPass 'Typechecked)
                  (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))])
         [GenLocated
            (Anno
               (Match
                  (GhcPass 'Typechecked)
                  (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))))
            (Match
               (GhcPass 'Typechecked)
               (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))]
    forall e a. HasAnnotation e => a -> GenLocated e a
    noLocA []
                , mg_ext :: XMG
      (GhcPass 'Typechecked)
      (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
    mg_ext = [Scaled Type] -> Type -> Origin -> MatchGroupTc
    MatchGroupTc [Type -> Type -> Scaled Type
    forall a. Type -> a -> Scaled a
    Scaled Type
    ManyTy Type
    void_ty] Type
    res_ty (GenReason -> DoPmc -> Origin
    Generated GenReason
    OtherExpansion DoPmc
    SkipPmc)
                }))

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

      let (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches

      -- Note that we replace the MatchGroup result type by sum_ty,
      -- which is the type of matches'
      return (MG { mg_alts = L l matches'
                 , mg_ext = MatchGroupTc arg_tys sum_ty origin
                 },
              core_choices)

    {-
    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. HasCallStack => 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 SrcSpanAnnA
    _ (LastStmt XLastStmt
      (GhcPass 'Typechecked)
      (GhcPass 'Typechecked)
      (LocatedA (HsCmd (GhcPass 'Typechecked)))
    _ LocatedA (HsCmd (GhcPass 'Typechecked))
    body Maybe Bool
    _ SyntaxExpr (GhcPass 'Typechecked)
    _)] [Id]
    env_ids = do
        (core_body, 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)
    LocatedA (HsCmd (GhcPass 'Typechecked))
    body [Id]
    env_ids
        let env_ty = [Id] -> Type
    HasDebugCallStack => [Id] -> Type
    mkBigCoreVarTupTy [Id]
    env_ids
        env_var <- newSysLocalDs ManyTy env_ty
        let 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)
        return (do_premap ids
                            env_ty
                            (mkCorePairTy env_ty unitTy)
                            res_ty
                            core_map
                            core_body,
            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 (CollectFlag (GhcPass 'Typechecked)
    -> LStmtLR
         (GhcPass 'Typechecked)
         (GhcPass 'Typechecked)
         (LocatedA (HsCmd (GhcPass 'Typechecked)))
    -> [IdP (GhcPass 'Typechecked)]
    forall (idL :: Pass) (idR :: Pass) body.
    CollectPass (GhcPass idL) =>
    CollectFlag (GhcPass idL)
    -> LStmtLR (GhcPass idL) (GhcPass idR) body -> [IdP (GhcPass idL)]
    collectLStmtBinders CollectFlag (GhcPass 'Typechecked)
    CollWithDictBinders CmdLStmt (GhcPass 'Typechecked)
    LStmtLR
      (GhcPass 'Typechecked)
      (GhcPass 'Typechecked)
      (LocatedA (HsCmd (GhcPass 'Typechecked)))
    stmt)
        let local_vars' :: VarSet
    local_vars' = VarSet
    bound_vars VarSet -> VarSet -> VarSet
    `unionVarSet` VarSet
    local_vars
        (core_stmts, _, 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)
        (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids
        return (do_compose ids
                    (mkBigCoreVarTupTy env_ids)
                    (mkBigCoreVarTupTy env_ids')
                    res_ty
                    core_stmt
                    core_stmts,
                  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]
    -> CmdStmt (GhcPass 'Typechecked)
    -> [Id]
    -> DsM (CoreExpr, DIdSet)
    dsCmdStmt DsCmdEnv
    ids VarSet
    local_vars [Id]
    out_ids (GenLocated
      SrcSpanAnnA
      (StmtLR
         (GhcPass 'Typechecked)
         (GhcPass 'Typechecked)
         (LocatedA (HsCmd (GhcPass 'Typechecked))))
    -> StmtLR
         (GhcPass 'Typechecked)
         (GhcPass 'Typechecked)
         (LocatedA (HsCmd (GhcPass 'Typechecked)))
    forall l e. GenLocated l e -> e
    unLoc CmdLStmt (GhcPass 'Typechecked)
    GenLocated
      SrcSpanAnnA
      (StmtLR
         (GhcPass 'Typechecked)
         (GhcPass 'Typechecked)
         (LocatedA (HsCmd (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]
    -> CmdStmt (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
        (core_cmd, fv_cmd, env_ids1) <- DsCmdEnv
    -> VarSet
    -> Type
    -> Type
    -> LHsCmd (GhcPass 'Typechecked)
    -> DsM (CoreExpr, DIdSet, [Id])
    dsfixCmd DsCmdEnv
    ids VarSet
    local_vars Type
    unitTy XBodyStmt
      (GhcPass 'Typechecked)
      (GhcPass 'Typechecked)
      (LHsCmd (GhcPass 'Typechecked))
    Type
    c_ty LHsCmd (GhcPass 'Typechecked)
    cmd
        core_mux <- matchEnv env_ids
            (mkCorePairExpr
                (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr)
                (mkBigCoreVarTup out_ids))
        let
            in_ty = [Id] -> Type
    HasDebugCallStack => [Id] -> Type
    mkBigCoreVarTupTy [Id]
    env_ids
            in_ty1 = Type -> Type -> Type
    mkCorePairTy ([Id] -> Type
    HasDebugCallStack => [Id] -> Type
    mkBigCoreVarTupTy [Id]
    env_ids1) Type
    unitTy
            out_ty = [Id] -> Type
    HasDebugCallStack => [Id] -> Type
    mkBigCoreVarTupTy [Id]
    out_ids
            before_c_ty = Type -> Type -> Type
    mkCorePairTy Type
    in_ty1 Type
    out_ty
            after_c_ty = Type -> Type -> Type
    mkCorePairTy XBodyStmt
      (GhcPass 'Typechecked)
      (GhcPass 'Typechecked)
      (LHsCmd (GhcPass 'Typechecked))
    Type
    c_ty Type
    out_ty
        snd_fn <- mkSndExpr c_ty out_ty
        return (do_premap ids in_ty before_c_ty out_ty core_mux $
                    do_compose ids before_c_ty after_c_ty out_ty
                            (do_first ids in_ty1 c_ty out_ty core_cmd) $
                    do_arr ids after_c_ty out_ty snd_fn,
                  extendDVarSetList fv_cmd 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
        (core_cmd, fv_cmd, 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 = [Id] -> VarSet
    mkVarSet (CollectFlag (GhcPass 'Typechecked)
    -> LPat (GhcPass 'Typechecked) -> [IdP (GhcPass 'Typechecked)]
    forall p. CollectPass p => CollectFlag p -> LPat p -> [IdP p]
    collectPatBinders CollectFlag (GhcPass 'Typechecked)
    CollWithDictBinders LPat (GhcPass 'Typechecked)
    pat)
        let
            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 = [Id] -> Type
    HasDebugCallStack => [Id] -> Type
    mkBigCoreVarTupTy [Id]
    env_ids2

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

        core_mux <- matchEnv env_ids
            (mkCorePairExpr
                (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr)
                (mkBigCoreVarTup env_ids2))

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

        env_id <- newSysLocalDs ManyTy env_ty2
        let
           after_c_ty = Type -> Type -> Type
    mkCorePairTy Type
    pat_ty Type
    env_ty2
           out_ty = [Id] -> Type
    HasDebugCallStack => [Id] -> Type
    mkBigCoreVarTupTy [Id]
    out_ids
        body_expr <- coreCaseTuple env_id env_ids2 (mkBigCoreVarTup out_ids)

        fail_expr <- mkFailExpr (StmtCtxt (HsDoStmt (DoExpr Nothing))) out_ty
        pat_id    <- selectSimpleMatchVarL ManyTy pat
        match_code
          <- matchSimply (Var pat_id) (StmtCtxt (HsDoStmt (DoExpr Nothing))) ManyTy pat body_expr fail_expr
        pair_id   <- newSysLocalDs ManyTy after_c_ty
        let
            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 = [Id] -> Type
    HasDebugCallStack => [Id] -> Type
    mkBigCoreVarTupTy [Id]
    env_ids
            in_ty1 = Type -> Type -> Type
    mkCorePairTy ([Id] -> Type
    HasDebugCallStack => [Id] -> Type
    mkBigCoreVarTupTy [Id]
    env_ids1) Type
    unitTy
            in_ty2 = [Id] -> Type
    HasDebugCallStack => [Id] -> Type
    mkBigCoreVarTupTy [Id]
    env_ids2
            before_c_ty = Type -> Type -> Type
    mkCorePairTy Type
    in_ty1 Type
    in_ty2
        return (do_premap ids in_ty before_c_ty out_ty core_mux $
                    do_compose ids before_c_ty after_c_ty out_ty
                            (do_first ids in_ty1 pat_ty in_ty2 core_cmd) $
                    do_arr ids after_c_ty out_ty proj_expr,
                  fv_cmd `unionDVarSet` (mkDVarSet out_ids
                                         `uniqDSetMinusUniqSet` 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))
    _ HsLocalBinds (GhcPass 'Typechecked)
    binds) [Id]
    env_ids = do
        -- build a new environment using the let bindings
        core_binds <- HsLocalBinds (GhcPass 'Typechecked) -> CoreExpr -> DsM CoreExpr
    dsLocalBinds HsLocalBinds (GhcPass 'Typechecked)
    binds ([Id] -> CoreExpr
    mkBigCoreVarTup [Id]
    out_ids)
        -- match the old environment against the input
        core_map <- matchEnv env_ids core_binds
        return (do_arr ids
                            (mkBigCoreVarTupTy env_ids)
                            (mkBigCoreVarTupTy out_ids)
                            core_map,
                exprFreeIdsDSet core_binds `uniqDSetIntersectUniqSet` 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 -> XRec idR [LStmtLR idL idR body]
    recS_stmts = L SrcSpanAnnL
    _ [GenLocated
       SrcSpanAnnA
       (StmtLR
          (GhcPass 'Typechecked)
          (GhcPass 'Typechecked)
          (LocatedA (HsCmd (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 [IdP (GhcPass 'Typechecked)]
    [Id]
    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
    HasDebugCallStack => [Id] -> Type
    mkBigCoreVarTupTy [Id]
    env2_ids

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

        env2_id <- Type -> Type -> DsM Id
    newSysLocalDs Type
    ManyTy Type
    env2_ty
        let
            later_ty = [Id] -> Type
    HasDebugCallStack => [Id] -> Type
    mkBigCoreVarTupTy [IdP (GhcPass 'Typechecked)]
    [Id]
    later_ids
            post_pair_ty = Type -> Type -> Type
    mkCorePairTy Type
    later_ty Type
    env2_ty
        post_loop_body <- coreCaseTuple env2_id env2_ids (mkBigCoreVarTup out_ids)

        post_loop_fn <- matchEnvStack later_ids env2_id post_loop_body

        --- loop (...)

        (core_loop, env1_id_set, env1_ids)
                   <- dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets

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

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

        pre_loop_fn <- matchEnv env_ids pre_loop_body

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

        let
            env_ty = [Id] -> Type
    HasDebugCallStack => [Id] -> Type
    mkBigCoreVarTupTy [Id]
    env_ids
            out_ty = [Id] -> Type
    HasDebugCallStack => [Id] -> Type
    mkBigCoreVarTupTy [Id]
    out_ids
            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))

        return (core_body, env1_id_set `unionDVarSet` env2_id_set)

    dsCmdStmt DsCmdEnv
    _ VarSet
    _ [Id]
    _ CmdStmt (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))

        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)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM HsExpr (GhcPass 'Typechecked) -> DsM CoreExpr
    dsExpr [HsExpr (GhcPass 'Typechecked)]
    later_rets
        core_rec_rets <- mapM dsExpr rec_rets
        let
            -- possibly polymorphic version of vars of later_ids and rec_ids
            out_ids = [CoreExpr] -> [Id]
    exprsFreeIdsList ([CoreExpr]
    core_later_rets [CoreExpr] -> [CoreExpr] -> [CoreExpr]
    forall a. [a] -> [a] -> [a]
    ++ [CoreExpr]
    core_rec_rets)
            out_ty = [Id] -> Type
    HasDebugCallStack => [Id] -> Type
    mkBigCoreVarTupTy [Id]
    out_ids

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

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

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

        mk_pair_fn <- matchEnv out_ids out_pair

        -- ss

        (core_stmts, fv_stmts, env_ids) <- dsfixCmdStmts ids local_vars' out_ids stmts

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

        rec_id <- newSysLocalDs ManyTy rec_ty
        let
            env1_id_set = DIdSet
    fv_stmts DIdSet -> VarSet -> DIdSet
    forall a. UniqDSet a -> UniqSet a -> UniqDSet a
    `uniqDSetMinusUniqSet` VarSet
    rec_id_set
            env1_ids = DIdSet -> [Id]
    dVarSetElems DIdSet
    env1_id_set
            env1_ty = [Id] -> Type
    HasDebugCallStack => [Id] -> Type
    mkBigCoreVarTupTy [Id]
    env1_ids
            in_pair_ty = Type -> Type -> Type
    mkCorePairTy Type
    env1_ty Type
    rec_ty
            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
    mkBigTupleSelector [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

        squash_pair_fn <- matchEnvStack env1_ids rec_id core_body

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

        let
            env_ty = [Id] -> Type
    HasDebugCallStack => [Id] -> Type
    mkBigCoreVarTupTy [Id]
    env_ids
            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)))

        return (core_loop, env1_id_set, 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 representation 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 (CollectFlag (GhcPass 'Typechecked)
    -> LStmtLR
         (GhcPass 'Typechecked)
         (GhcPass 'Typechecked)
         (LocatedA (HsCmd (GhcPass 'Typechecked)))
    -> [IdP (GhcPass 'Typechecked)]
    forall (idL :: Pass) (idR :: Pass) body.
    CollectPass (GhcPass idL) =>
    CollectFlag (GhcPass idL)
    -> LStmtLR (GhcPass idL) (GhcPass idR) body -> [IdP (GhcPass idL)]
    collectLStmtBinders CollectFlag (GhcPass 'Typechecked)
    CollWithDictBinders CmdLStmt (GhcPass 'Typechecked)
    LStmtLR
      (GhcPass 'Typechecked)
      (GhcPass 'Typechecked)
      (LocatedA (HsCmd (GhcPass 'Typechecked)))
    stmt)
        let local_vars' :: VarSet
    local_vars' = VarSet
    bound_vars VarSet -> VarSet -> VarSet
    `unionVarSet` VarSet
    local_vars
        (core_stmts, _fv_stmts, 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
        (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids
        return (do_compose ids
                    (mkBigCoreVarTupTy env_ids)
                    (mkBigCoreVarTupTy env_ids')
                    (mkBigCoreVarTupTy out_ids)
                    core_stmt
                    core_stmts,
                  fv_stmt)

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

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

    matchSimplys :: [CoreExpr]              -- Scrutinees
                 -> HsMatchContextRn        -- 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]
    -> HsMatchContextRn
    -> [LPat (GhcPass 'Typechecked)]
    -> CoreExpr
    -> CoreExpr
    -> DsM CoreExpr
    matchSimplys [] HsMatchContextRn
    _ctxt [] CoreExpr
    result_expr CoreExpr
    _fail_expr = CoreExpr -> DsM CoreExpr
    forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return CoreExpr
    result_expr
    matchSimplys (CoreExpr
    exp:[CoreExpr]
    exps) HsMatchContextRn
    ctxt (LPat (GhcPass 'Typechecked)
    pat:[LPat (GhcPass 'Typechecked)]
    pats) CoreExpr
    result_expr CoreExpr
    fail_expr = do
        match_code <- [CoreExpr]
    -> HsMatchContextRn
    -> [LPat (GhcPass 'Typechecked)]
    -> CoreExpr
    -> CoreExpr
    -> DsM CoreExpr
    matchSimplys [CoreExpr]
    exps HsMatchContextRn
    ctxt [LPat (GhcPass 'Typechecked)]
    pats CoreExpr
    result_expr CoreExpr
    fail_expr
        matchSimply exp ctxt ManyTy pat match_code fail_expr
    matchSimplys [CoreExpr]
    _ HsMatchContextRn
    _ [LPat (GhcPass 'Typechecked)]
    _ CoreExpr
    _ CoreExpr
    _ = String -> DsM CoreExpr
    forall a. HasCallStack => String -> a
    panic String
    "matchSimplys"

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

    leavesMatch :: LMatch GhcTc (LocatedA (body GhcTc))
                -> [(LocatedA (body GhcTc), IdSet)]
    leavesMatch :: forall (body :: * -> *).
    LMatch
      (GhcPass 'Typechecked) (LocatedA (body (GhcPass 'Typechecked)))
    -> [(LocatedA (body (GhcPass 'Typechecked)), VarSet)]
    leavesMatch (L Anno
      (Match
         (GhcPass 'Typechecked) (LocatedA (body (GhcPass 'Typechecked))))
    _ (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) (LocatedA (body (GhcPass 'Typechecked)))
    _ [LGRHS
       (GhcPass 'Typechecked) (LocatedA (body (GhcPass 'Typechecked)))]
    grhss HsLocalBinds (GhcPass 'Typechecked)
    binds }))
      = let
            defined_vars :: VarSet
    defined_vars = [Id] -> VarSet
    mkVarSet (CollectFlag (GhcPass 'Typechecked)
    -> [LPat (GhcPass 'Typechecked)] -> [IdP (GhcPass 'Typechecked)]
    forall p. CollectPass p => CollectFlag p -> [LPat p] -> [IdP p]
    collectPatsBinders CollectFlag (GhcPass 'Typechecked)
    CollWithDictBinders [LPat (GhcPass 'Typechecked)]
    pats)
                            VarSet -> VarSet -> VarSet
    `unionVarSet`
                           [Id] -> VarSet
    mkVarSet (CollectFlag (GhcPass 'Typechecked)
    -> HsLocalBinds (GhcPass 'Typechecked)
    -> [IdP (GhcPass 'Typechecked)]
    forall (idL :: Pass) (idR :: Pass).
    CollectPass (GhcPass idL) =>
    CollectFlag (GhcPass idL)
    -> HsLocalBindsLR (GhcPass idL) (GhcPass idR)
    -> [IdP (GhcPass idL)]
    collectLocalBinders CollectFlag (GhcPass 'Typechecked)
    CollWithDictBinders HsLocalBinds (GhcPass 'Typechecked)
    binds)
        in
        [(LocatedA (body (GhcPass 'Typechecked))
    body,
          [Id] -> VarSet
    mkVarSet (CollectFlag (GhcPass 'Typechecked)
    -> [LStmtLR
          (GhcPass 'Typechecked)
          (GhcPass 'Typechecked)
          (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))]
    -> [IdP (GhcPass 'Typechecked)]
    forall (idL :: Pass) (idR :: Pass) body.
    CollectPass (GhcPass idL) =>
    CollectFlag (GhcPass idL)
    -> [LStmtLR (GhcPass idL) (GhcPass idR) body]
    -> [IdP (GhcPass idL)]
    collectLStmtsBinders CollectFlag (GhcPass 'Typechecked)
    CollWithDictBinders [GuardLStmt (GhcPass 'Typechecked)]
    [LStmtLR
       (GhcPass 'Typechecked)
       (GhcPass 'Typechecked)
       (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))]
    stmts)
            VarSet -> VarSet -> VarSet
    `unionVarSet` VarSet
    defined_vars)
        | L Anno
      (GRHS
         (GhcPass 'Typechecked) (LocatedA (body (GhcPass 'Typechecked))))
    _ (GRHS XCGRHS
      (GhcPass 'Typechecked) (LocatedA (body (GhcPass 'Typechecked)))
    _ [GuardLStmt (GhcPass 'Typechecked)]
    stmts LocatedA (body (GhcPass 'Typechecked))
    body) <- [LGRHS
       (GhcPass 'Typechecked) (LocatedA (body (GhcPass 'Typechecked)))]
    [GenLocated
       (Anno
          (GRHS
             (GhcPass 'Typechecked) (LocatedA (body (GhcPass 'Typechecked)))))
       (GRHS
          (GhcPass 'Typechecked) (LocatedA (body (GhcPass 'Typechecked))))]
    grhss]

    -- Replace the leaf commands in a match

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

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

    -- Balanced fold of a non-empty list.

    foldb :: (a -> a -> a) -> NonEmpty a -> a
    foldb :: forall a. (a -> a -> a) -> NonEmpty a -> a
    foldb a -> a -> a
    _ (a
    x:|[]) = a
    x
    foldb a -> a -> a
    f NonEmpty a
    xs = (a -> a -> a) -> NonEmpty a -> a
    forall a. (a -> a -> a) -> NonEmpty a -> a
    foldb a -> a -> a
    f (NonEmpty a -> NonEmpty a
    fold_pairs NonEmpty a
    xs)
      where
        fold_pairs :: NonEmpty a -> NonEmpty a
    fold_pairs (a
    x1:|a
    x2:[a]
    xs) = a -> a -> a
    f a
    x1 a
    x2 a -> [a] -> NonEmpty a
    forall a. a -> [a] -> NonEmpty a
    :| (NonEmpty a -> NonEmpty a) -> [a] -> [a]
    forall a. (NonEmpty a -> NonEmpty a) -> [a] -> [a]
    keep_empty NonEmpty a -> NonEmpty a
    fold_pairs [a]
    xs
        fold_pairs NonEmpty a
    xs          = NonEmpty a
    xs

        keep_empty :: (NonEmpty a -> NonEmpty a) -> [a] -> [a]
        keep_empty :: forall a. (NonEmpty a -> NonEmpty a) -> [a] -> [a]
    keep_empty NonEmpty a -> NonEmpty a
    f = [a] -> (NonEmpty a -> [a]) -> Maybe (NonEmpty a) -> [a]
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe [] (NonEmpty a -> [a]
    forall a. NonEmpty a -> [a]
    forall (t :: * -> *) a. Foldable t => t a -> [a]
    toList (NonEmpty a -> [a])
    -> (NonEmpty a -> NonEmpty a) -> NonEmpty a -> [a]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . NonEmpty a -> NonEmpty a
    f) (Maybe (NonEmpty a) -> [a])
    -> ([a] -> Maybe (NonEmpty a)) -> [a] -> [a]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [a] -> Maybe (NonEmpty a)
    forall a. [a] -> Maybe (NonEmpty a)
    nonEmpty