    {-# LANGUAGE RankNTypes     #-}
    {-# LANGUAGE TypeFamilies   #-}
    {-# LANGUAGE BlockArguments #-}

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

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

    -}

    -- | Typecheck arrow notation
    module GHC.Tc.Gen.Arrow ( tcProc ) where

    import GHC.Prelude

    import {-# SOURCE #-}   GHC.Tc.Gen.Expr( tcCheckMonoExpr, tcInferRho, tcSyntaxOp
                                           , tcCheckPolyExpr )

    import GHC.Hs
    import GHC.Tc.Errors.Types
    import GHC.Tc.Gen.Match
    import GHC.Tc.Gen.Head( tcCheckId )
    import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic )
    import GHC.Tc.Utils.TcType
    import GHC.Tc.Utils.TcMType
    import GHC.Tc.Gen.Bind
    import GHC.Tc.Gen.Pat
    import GHC.Tc.Utils.Unify
    import GHC.Tc.Utils.Monad
    import GHC.Tc.Utils.Env
    import GHC.Tc.Types.Origin
    import GHC.Tc.Types.Evidence
    import GHC.Core.Multiplicity
    import GHC.Core.Coercion
    import GHC.Types.Id( mkLocalId )
    import GHC.Tc.Utils.Instantiate
    import GHC.Builtin.Types
    import GHC.Types.Var.Set
    import GHC.Builtin.Types.Prim
    import GHC.Types.Basic( Arity )
    import GHC.Types.SrcLoc
    import GHC.Utils.Outputable
    import GHC.Utils.Panic
    import GHC.Utils.Misc

    import Control.Monad

    {-
    Note [Arrow overview]
    ~~~~~~~~~~~~~~~~~~~~~
    Here's a summary of arrows and how they typecheck.  First, here's
    a cut-down syntax:

      expr ::= ....
            |  proc pat cmd

      cmd ::= cmd exp                    -- Arrow application
           |  \pat -> cmd                -- Arrow abstraction
           |  (| exp cmd1 ... cmdn |)    -- Arrow form, n>=0
           |  ... -- If, case in the usual way

      cmd_type ::= carg_type --> type

      carg_type ::= ()
                 |  (type, carg_type)

    Note that
     * The 'exp' in an arrow form can mention only
       "arrow-local" variables

     * An "arrow-local" variable is bound by an enclosing
       cmd binding form (eg arrow abstraction)

     * A cmd_type is here written with a funny arrow "-->",
       The bit on the left is a carg_type (command argument type)
       which itself is a nested tuple, finishing with ()

     * The arrow-tail operator (e1 -< e2) means
           (| e1 <<< arr snd |) e2

    ************************************************************************
    *                                                                      *
                    Proc
    *                                                                      *
    ************************************************************************
    -}

    tcProc :: LPat GhcRn -> LHsCmdTop GhcRn         -- proc pat -> expr
           -> ExpRhoType                            -- Expected type of whole proc expression
           -> TcM (LPat GhcTc, LHsCmdTop GhcTc, TcCoercion)

    tcProc :: LPat GhcRn
    -> LHsCmdTop GhcRn
    -> ExpRhoType
    -> TcM (LPat GhcTc, LHsCmdTop GhcTc, TcCoercion)
    tcProc LPat GhcRn
    pat cmd :: LHsCmdTop GhcRn
    cmd@(L EpAnnCO
    loc (HsCmdTop XCmdTop GhcRn
    names LHsCmd GhcRn
    _)) ExpRhoType
    exp_ty
      = do  { exp_ty <- ExpRhoType -> TcM TcType
    expTypeToType ExpRhoType
    exp_ty  -- no higher-rank stuff with arrows
            ; (co, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty
            ; (co1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1
            -- start with the names as they are used to desugar the proc itself
            -- See #17423
            ; names' <- setSrcSpanA loc $
                mapM (tcSyntaxName ProcOrigin arr_ty) names
            ; let cmd_env = CmdEnv { cmd_arr :: TcType
    cmd_arr = TcType
    arr_ty }
            ; (pat', cmd') <- newArrowScope
                              $ tcCheckPat (ArrowMatchCtxt ProcExpr) pat (unrestricted arg_ty)
                              $ tcCmdTop cmd_env names' cmd (unitTy, res_ty)
            ; let res_co = TcCoercion
    co HasDebugCallStack => TcCoercion -> TcCoercion -> TcCoercion
    TcCoercion -> TcCoercion -> TcCoercion
    `mkTransCo` TcCoercion -> TcCoercion -> TcCoercion
    mkAppCo TcCoercion
    co1 (TcType -> TcCoercion
    mkNomReflCo TcType
    res_ty)
            ; return (pat', cmd', res_co) }

    {-
    ************************************************************************
    *                                                                      *
                    Commands
    *                                                                      *
    ************************************************************************
    -}

    -- See Note [Arrow overview]
    type CmdType    = (CmdArgType, TcTauType)    -- cmd_type
    type CmdArgType = TcTauType                  -- carg_type, a nested tuple

    data CmdEnv
      = CmdEnv {
            CmdEnv -> TcType
    cmd_arr :: TcType -- ^ Arrow type constructor, of kind *->*->*
        }

    mkCmdArrTy :: CmdEnv -> TcTauType -> TcTauType -> TcTauType
    mkCmdArrTy :: CmdEnv -> TcType -> TcType -> TcType
    mkCmdArrTy CmdEnv
    env TcType
    t1 TcType
    t2 = TcType -> [TcType] -> TcType
    mkAppTys (CmdEnv -> TcType
    cmd_arr CmdEnv
    env) [TcType
    t1, TcType
    t2]

    ---------------------------------------
    tcCmdTop :: CmdEnv
             -> CmdSyntaxTable GhcTc -- ^ Type-checked Arrow class methods (arr, (>>>), ...)
             -> LHsCmdTop GhcRn
             -> CmdType
             -> TcM (LHsCmdTop GhcTc)

    tcCmdTop :: CmdEnv
    -> [(Name, HsExpr GhcTc)]
    -> LHsCmdTop GhcRn
    -> (TcType, TcType)
    -> TcM (LHsCmdTop GhcTc)
    tcCmdTop CmdEnv
    env [(Name, HsExpr GhcTc)]
    names (L EpAnnCO
    loc (HsCmdTop XCmdTop GhcRn
    _names LHsCmd GhcRn
    cmd)) cmd_ty :: (TcType, TcType)
    cmd_ty@(TcType
    cmd_stk, TcType
    res_ty)
      = EpAnnCO -> TcM (LHsCmdTop GhcTc) -> TcM (LHsCmdTop GhcTc)
    forall ann a. EpAnn ann -> TcRn a -> TcRn a
    setSrcSpanA EpAnnCO
    loc (TcM (LHsCmdTop GhcTc) -> TcM (LHsCmdTop GhcTc))
    -> TcM (LHsCmdTop GhcTc) -> TcM (LHsCmdTop GhcTc)
    forall a b. (a -> b) -> a -> b
    $
        do  { cmd' <- CmdEnv -> LHsCmd GhcRn -> (TcType, TcType) -> TcM (LHsCmd GhcTc)
    tcCmd CmdEnv
    env LHsCmd GhcRn
    cmd (TcType, TcType)
    cmd_ty
            ; return (L loc $ HsCmdTop (CmdTopTc cmd_stk res_ty names) cmd') }

    ----------------------------------------
    tcCmd  :: CmdEnv -> LHsCmd GhcRn -> CmdType -> TcM (LHsCmd GhcTc)
            -- The main recursive function
    tcCmd :: CmdEnv -> LHsCmd GhcRn -> (TcType, TcType) -> TcM (LHsCmd GhcTc)
    tcCmd CmdEnv
    env (L EpAnn AnnListItem
    loc HsCmd GhcRn
    cmd) cmd_ty :: (TcType, TcType)
    cmd_ty@(TcType
    _, TcType
    res_ty)
      = SrcSpan -> TcM (LHsCmd GhcTc) -> TcM (LHsCmd GhcTc)
    forall a. SrcSpan -> TcRn a -> TcRn a
    setSrcSpan (EpAnn AnnListItem -> SrcSpan
    forall a. HasLoc a => a -> SrcSpan
    locA EpAnn AnnListItem
    loc) (TcM (LHsCmd GhcTc) -> TcM (LHsCmd GhcTc))
    -> TcM (LHsCmd GhcTc) -> TcM (LHsCmd GhcTc)
    forall a b. (a -> b) -> a -> b
    $ do
            { cmd' <- CmdEnv -> HsCmd GhcRn -> (TcType, TcType) -> TcM (HsCmd GhcTc)
    tc_cmd CmdEnv
    env HsCmd GhcRn
    cmd (TcType, TcType)
    cmd_ty
            ; hasFixedRuntimeRep_syntactic (FRRArrow $ ArrowCmdResTy cmd) res_ty
            ; return (L loc cmd') }

    tc_cmd :: CmdEnv -> HsCmd GhcRn  -> CmdType -> TcM (HsCmd GhcTc)
    tc_cmd :: CmdEnv -> HsCmd GhcRn -> (TcType, TcType) -> TcM (HsCmd GhcTc)
    tc_cmd CmdEnv
    env (HsCmdPar XCmdPar GhcRn
    x LHsCmd GhcRn
    cmd) (TcType, TcType)
    res_ty
      = do  { cmd' <- CmdEnv -> LHsCmd GhcRn -> (TcType, TcType) -> TcM (LHsCmd GhcTc)
    tcCmd CmdEnv
    env LHsCmd GhcRn
    cmd (TcType, TcType)
    res_ty
            ; return (HsCmdPar x cmd') }

    tc_cmd CmdEnv
    env (HsCmdLet XCmdLet GhcRn
    x HsLocalBinds GhcRn
    binds (L EpAnn AnnListItem
    body_loc HsCmd GhcRn
    body)) (TcType, TcType)
    res_ty
      = do  { (binds', body') <- HsLocalBinds GhcRn
    -> TcM (HsCmd GhcTc) -> TcM (HsLocalBinds GhcTc, HsCmd GhcTc)
    forall thing.
    HsLocalBinds GhcRn -> TcM thing -> TcM (HsLocalBinds GhcTc, thing)
    tcLocalBinds HsLocalBinds GhcRn
    binds         (TcM (HsCmd GhcTc) -> TcM (HsLocalBinds GhcTc, HsCmd GhcTc))
    -> TcM (HsCmd GhcTc) -> TcM (HsLocalBinds GhcTc, HsCmd GhcTc)
    forall a b. (a -> b) -> a -> b
    $
                                 SrcSpan -> TcM (HsCmd GhcTc) -> TcM (HsCmd GhcTc)
    forall a. SrcSpan -> TcRn a -> TcRn a
    setSrcSpan (EpAnn AnnListItem -> SrcSpan
    forall a. HasLoc a => a -> SrcSpan
    locA EpAnn AnnListItem
    body_loc) (TcM (HsCmd GhcTc) -> TcM (HsCmd GhcTc))
    -> TcM (HsCmd GhcTc) -> TcM (HsCmd GhcTc)
    forall a b. (a -> b) -> a -> b
    $
                                 CmdEnv -> HsCmd GhcRn -> (TcType, TcType) -> TcM (HsCmd GhcTc)
    tc_cmd CmdEnv
    env HsCmd GhcRn
    body (TcType, TcType)
    res_ty
            ; return (HsCmdLet x binds' (L body_loc body')) }

    tc_cmd CmdEnv
    env in_cmd :: HsCmd GhcRn
    in_cmd@(HsCmdCase XCmdCase GhcRn
    x LHsExpr GhcRn
    scrut MatchGroup GhcRn (LHsCmd GhcRn)
    matches) (TcType
    stk, TcType
    res_ty)
      = ErrCtxtMsg -> TcM (HsCmd GhcTc) -> TcM (HsCmd GhcTc)
    forall a. ErrCtxtMsg -> TcM a -> TcM a
    addErrCtxt (HsCmd GhcRn -> ErrCtxtMsg
    CmdCtxt HsCmd GhcRn
    in_cmd) (TcM (HsCmd GhcTc) -> TcM (HsCmd GhcTc))
    -> TcM (HsCmd GhcTc) -> TcM (HsCmd GhcTc)
    forall a b. (a -> b) -> a -> b
    $ do
        do { (scrut', scrut_ty) <- LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcType)
    tcInferRho LHsExpr GhcRn
    scrut
           ; hasFixedRuntimeRep_syntactic (FRRArrow $ ArrowCmdCase) scrut_ty
           ; matches' <- tcCmdMatches env scrut_ty matches (stk, res_ty)
           ; return (HsCmdCase x scrut' matches') }

    tc_cmd CmdEnv
    env (HsCmdIf XCmdIf GhcRn
    x SyntaxExpr GhcRn
    SyntaxExprRn
    NoSyntaxExprRn LHsExpr GhcRn
    pred LHsCmd GhcRn
    b1 LHsCmd GhcRn
    b2) (TcType, TcType)
    res_ty    -- Ordinary 'if'
      = do  { pred' <- LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
    tcCheckMonoExpr LHsExpr GhcRn
    pred TcType
    boolTy
            ; b1'   <- tcCmd env b1 res_ty
            ; b2'   <- tcCmd env b2 res_ty
            ; return (HsCmdIf x NoSyntaxExprTc pred' b1' b2')
        }

    tc_cmd CmdEnv
    env (HsCmdIf XCmdIf GhcRn
    x fun :: SyntaxExpr GhcRn
    fun@(SyntaxExprRn {}) LHsExpr GhcRn
    pred LHsCmd GhcRn
    b1 LHsCmd GhcRn
    b2) (TcType, TcType)
    res_ty -- Rebindable syntax for if
      = do  { pred_ty <- TcM TcType
    newOpenFlexiTyVarTy
            -- For arrows, need ifThenElse :: forall r. T -> r -> r -> r
            -- because we're going to apply it to the environment, not
            -- the return value.
            ; skol_info <- mkSkolemInfo ArrowReboundIfSkol
            ; (_, [r_tv]) <- tcInstSkolTyVars skol_info [alphaTyVar]
            ; let r_ty = Id -> TcType
    mkTyVarTy Id
    r_tv
            ; checkTc (not (r_tv `elemVarSet` tyCoVarsOfType pred_ty))
                      TcRnArrowIfThenElsePredDependsOnResultTy
            ; (pred', fun') <- tcSyntaxOp IfThenElseOrigin fun
                                  (map synKnownType [pred_ty, r_ty, r_ty])
                                  (mkCheckExpType r_ty) $ \ [TcType]
    _ [TcType]
    _ ->
                               LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
    tcCheckMonoExpr LHsExpr GhcRn
    pred TcType
    pred_ty

            ; b1'   <- tcCmd env b1 res_ty
            ; b2'   <- tcCmd env b2 res_ty
            ; return (HsCmdIf x fun' pred' b1' b2')
        }

    -------------------------------------------
    --              Arrow application
    --          (f -< a)   or   (f -<< a)
    --
    --   D   |- fun :: a t1 t2
    --   D,G |- arg :: t1
    --  ------------------------
    --   D;G |-a  fun -< arg :: stk --> t2
    --
    --   D,G |- fun :: a t1 t2
    --   D,G |- arg :: t1
    --  ------------------------
    --   D;G |-a  fun -<< arg :: stk --> t2
    --
    -- (plus -<< requires ArrowApply)

    tc_cmd CmdEnv
    env cmd :: HsCmd GhcRn
    cmd@(HsCmdArrApp XCmdArrApp GhcRn
    _ LHsExpr GhcRn
    fun LHsExpr GhcRn
    arg HsArrAppType
    ho_app Bool
    lr) (TcType
    _, TcType
    res_ty)
      = ErrCtxtMsg -> TcM (HsCmd GhcTc) -> TcM (HsCmd GhcTc)
    forall a. ErrCtxtMsg -> TcM a -> TcM a
    addErrCtxt (HsCmd GhcRn -> ErrCtxtMsg
    CmdCtxt HsCmd GhcRn
    cmd)    (TcM (HsCmd GhcTc) -> TcM (HsCmd GhcTc))
    -> TcM (HsCmd GhcTc) -> TcM (HsCmd GhcTc)
    forall a b. (a -> b) -> a -> b
    $
        do  { arg_ty <- TcM TcType
    newOpenFlexiTyVarTy
            ; let fun_ty = CmdEnv -> TcType -> TcType -> TcType
    mkCmdArrTy CmdEnv
    env TcType
    arg_ty TcType
    res_ty
            ; fun' <- select_arrow_scope (tcCheckMonoExpr fun fun_ty)

            ; arg' <- tcCheckMonoExpr arg arg_ty

            ; hasFixedRuntimeRep_syntactic
                (FRRArrow $ ArrowCmdArrApp (unLoc fun) (unLoc arg) ho_app)
                fun_ty

            ; return (HsCmdArrApp fun_ty fun' arg' ho_app lr) }
      where
           -- Before type-checking f, use the environment of the enclosing
           -- proc for the (-<) case.
           -- Local bindings, inside the enclosing proc, are not in scope
           -- inside f.  In the higher-order case (-<<), they are.
           -- See Note [Escaping the arrow scope] in GHC.Tc.Types
        select_arrow_scope :: IOEnv
      (Env TcGblEnv TcLclEnv)
      (GenLocated (EpAnn AnnListItem) (HsExpr GhcTc))
    -> IOEnv
         (Env TcGblEnv TcLclEnv)
         (GenLocated (EpAnn AnnListItem) (HsExpr GhcTc))
    select_arrow_scope IOEnv
      (Env TcGblEnv TcLclEnv)
      (GenLocated (EpAnn AnnListItem) (HsExpr GhcTc))
    tc = case HsArrAppType
    ho_app of
            HsArrAppType
    HsHigherOrderApp -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (GenLocated (EpAnn AnnListItem) (HsExpr GhcTc))
    tc
            HsArrAppType
    HsFirstOrderApp  -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (GenLocated (EpAnn AnnListItem) (HsExpr GhcTc))
    -> IOEnv
         (Env TcGblEnv TcLclEnv)
         (GenLocated (EpAnn AnnListItem) (HsExpr GhcTc))
    forall a. TcM a -> TcM a
    escapeArrowScope IOEnv
      (Env TcGblEnv TcLclEnv)
      (GenLocated (EpAnn AnnListItem) (HsExpr GhcTc))
    tc

    -------------------------------------------
    --              Command application
    --
    -- D,G |-  exp : t
    -- D;G |-a cmd : (t,stk) --> res
    -- -----------------------------
    -- D;G |-a cmd exp : stk --> res

    tc_cmd CmdEnv
    env cmd :: HsCmd GhcRn
    cmd@(HsCmdApp XCmdApp GhcRn
    x LHsCmd GhcRn
    fun LHsExpr GhcRn
    arg) (TcType
    cmd_stk, TcType
    res_ty)
      = ErrCtxtMsg -> TcM (HsCmd GhcTc) -> TcM (HsCmd GhcTc)
    forall a. ErrCtxtMsg -> TcM a -> TcM a
    addErrCtxt (HsCmd GhcRn -> ErrCtxtMsg
    CmdCtxt HsCmd GhcRn
    cmd)    (TcM (HsCmd GhcTc) -> TcM (HsCmd GhcTc))
    -> TcM (HsCmd GhcTc) -> TcM (HsCmd GhcTc)
    forall a b. (a -> b) -> a -> b
    $
        do  { arg_ty <- TcM TcType
    newOpenFlexiTyVarTy
            ; fun'   <- tcCmd env fun (mkPairTy arg_ty cmd_stk, res_ty)
            ; arg'   <- tcCheckMonoExpr arg arg_ty
            ; hasFixedRuntimeRep_syntactic
                (FRRArrow $ ArrowCmdApp (unLoc fun) (unLoc arg))
                arg_ty
            ; return (HsCmdApp x fun' arg') }

    -------------------------------------------
    --              Lambda
    --
    -- D;G,x:t |-a cmd : stk --> res
    -- ------------------------------
    -- D;G |-a (\x.cmd) : (t,stk) --> res

    tc_cmd CmdEnv
    env cmd :: HsCmd GhcRn
    cmd@(HsCmdLam XCmdLamCase GhcRn
    x HsLamVariant
    lam_variant MatchGroup GhcRn (LHsCmd GhcRn)
    match) (TcType, TcType)
    cmd_ty
      = (case HsLamVariant
    lam_variant of   -- Add context only for \case and \cases
            HsLamVariant
    LamSingle -> TcM (HsCmd GhcTc) -> TcM (HsCmd GhcTc)
    forall a. a -> a
    id    -- Avoids clutter in the vanilla-lambda form
            HsLamVariant
    _         -> ErrCtxtMsg -> TcM (HsCmd GhcTc) -> TcM (HsCmd GhcTc)
    forall a. ErrCtxtMsg -> TcM a -> TcM a
    addErrCtxt (HsCmd GhcRn -> ErrCtxtMsg
    CmdCtxt HsCmd GhcRn
    cmd)) (TcM (HsCmd GhcTc) -> TcM (HsCmd GhcTc))
    -> TcM (HsCmd GhcTc) -> TcM (HsCmd GhcTc)
    forall a b. (a -> b) -> a -> b
    $
        do { let match_ctxt :: HsArrowMatchContext
    match_ctxt = HsLamVariant -> HsArrowMatchContext
    ArrowLamAlt HsLamVariant
    lam_variant
           ; arity <- MatchGroup GhcRn (GenLocated (EpAnn AnnListItem) (HsCmd GhcRn))
    -> TcM Arity
    forall (body :: * -> *).
    AnnoBody body =>
    MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcM Arity
    checkArgCounts MatchGroup GhcRn (LHsCmd GhcRn)
    MatchGroup GhcRn (GenLocated (EpAnn AnnListItem) (HsCmd GhcRn))
    match
           ; (wrap, match') <- tcCmdMatchLambda env match_ctxt arity match cmd_ty
           ; return (mkHsCmdWrap wrap (HsCmdLam x lam_variant match')) }

    -------------------------------------------
    --              Do notation

    tc_cmd CmdEnv
    env (HsCmdDo XCmdDo GhcRn
    _ (L SrcSpanAnnLW
    l [GenLocated
       (EpAnn AnnListItem)
       (StmtLR
          GhcRn GhcRn (GenLocated (EpAnn AnnListItem) (HsCmd GhcRn)))]
    stmts) ) (TcType
    cmd_stk, TcType
    res_ty)
      = do  { co <- Maybe TypedThing -> TcType -> TcType -> TcM TcCoercion
    unifyType Maybe TypedThing
    forall a. Maybe a
    Nothing TcType
    unitTy TcType
    cmd_stk  -- Expecting empty argument stack
            ; stmts' <- tcStmts ArrowExpr (tcArrDoStmt env) stmts res_ty
            ; return (mkHsCmdWrap (mkWpCastN co) (HsCmdDo res_ty (L l stmts') )) }

    -----------------------------------------------------------------
    --      Arrow ``forms''       (| e c1 .. cn |)
    --
    --      D; G |-a1 c1 : stk1 --> r1
    --      ...
    --      D; G |-an cn : stkn --> rn
    --      D |-  e :: forall e. a1 (e, stk1) t1
    --                                ...
    --                        -> an (e, stkn) tn
    --                        -> a  (e, stk) t
    --      e \not\in (stk, stk1, ..., stkm, t, t1, ..., tn)
    --      ----------------------------------------------
    --      D; G |-a  (| e c1 ... cn |)  :  stk --> t

    tc_cmd CmdEnv
    env cmd :: HsCmd GhcRn
    cmd@(HsCmdArrForm XCmdArrForm GhcRn
    fixity LHsExpr GhcRn
    expr LexicalFixity
    f [LHsCmdTop GhcRn]
    cmd_args) (TcType
    cmd_stk, TcType
    res_ty)
      = ErrCtxtMsg -> TcM (HsCmd GhcTc) -> TcM (HsCmd GhcTc)
    forall a. ErrCtxtMsg -> TcM a -> TcM a
    addErrCtxt (HsCmd GhcRn -> ErrCtxtMsg
    CmdCtxt HsCmd GhcRn
    cmd)
        do  { (cmd_args', cmd_tys) <- (GenLocated EpAnnCO (HsCmdTop GhcRn)
     -> IOEnv
          (Env TcGblEnv TcLclEnv)
          (GenLocated EpAnnCO (HsCmdTop GhcTc), TcType))
    -> [GenLocated EpAnnCO (HsCmdTop GhcRn)]
    -> IOEnv
         (Env TcGblEnv TcLclEnv)
         ([GenLocated EpAnnCO (HsCmdTop GhcTc)], [TcType])
    forall (m :: * -> *) a b c.
    Applicative m =>
    (a -> m (b, c)) -> [a] -> m ([b], [c])
    mapAndUnzipM LHsCmdTop GhcRn -> TcM (LHsCmdTop GhcTc, TcType)
    GenLocated EpAnnCO (HsCmdTop GhcRn)
    -> IOEnv
         (Env TcGblEnv TcLclEnv)
         (GenLocated EpAnnCO (HsCmdTop GhcTc), TcType)
    tc_cmd_arg [LHsCmdTop GhcRn]
    [GenLocated EpAnnCO (HsCmdTop GhcRn)]
    cmd_args
                                  -- We use alphaTyVar for 'w'
            ; let e_ty = Id -> TcType -> TcType
    mkInfForAllTy Id
    alphaTyVar (TcType -> TcType) -> TcType -> TcType
    forall a b. (a -> b) -> a -> b
    $
                         [TcType] -> TcType -> TcType
    mkVisFunTysMany [TcType]
    cmd_tys (TcType -> TcType) -> TcType -> TcType
    forall a b. (a -> b) -> a -> b
    $
                         CmdEnv -> TcType -> TcType -> TcType
    mkCmdArrTy CmdEnv
    env (TcType -> TcType -> TcType
    mkPairTy TcType
    alphaTy TcType
    cmd_stk) TcType
    res_ty
            ; expr' <- tcCheckPolyExpr expr e_ty
            ; return (HsCmdArrForm fixity expr' f cmd_args') }

      where
        tc_cmd_arg :: LHsCmdTop GhcRn -> TcM (LHsCmdTop GhcTc, TcType)
        tc_cmd_arg :: LHsCmdTop GhcRn -> TcM (LHsCmdTop GhcTc, TcType)
    tc_cmd_arg cmd :: LHsCmdTop GhcRn
    cmd@(L EpAnnCO
    loc (HsCmdTop XCmdTop GhcRn
    names LHsCmd GhcRn
    _))
           = do { arr_ty <- TcType -> TcM TcType
    newFlexiTyVarTy TcType
    arrowTyConKind
                ; stk_ty <- newFlexiTyVarTy liftedTypeKind
                ; res_ty <- newFlexiTyVarTy liftedTypeKind
                ; names' <- setSrcSpanA loc $
                    mapM (tcSyntaxName ArrowCmdOrigin arr_ty) names
                ; let env' = CmdEnv
    env { cmd_arr = arr_ty }
                ; cmd' <- tcCmdTop env' names' cmd (stk_ty, res_ty)
                ; return (cmd',  mkCmdArrTy env' (mkPairTy alphaTy stk_ty) res_ty) }

    -- | Typechecking for case command alternatives. Used for 'HsCmdCase'.
    tcCmdMatches :: CmdEnv
                 -> TcTypeFRR -- ^ Type of the scrutinee.
                 -> MatchGroup GhcRn (LHsCmd GhcRn)  -- ^ case alternatives
                 -> CmdType
                 -> TcM (MatchGroup GhcTc (LHsCmd GhcTc))
    tcCmdMatches :: CmdEnv
    -> TcType
    -> MatchGroup GhcRn (LHsCmd GhcRn)
    -> (TcType, TcType)
    -> TcM (MatchGroup GhcTc (LHsCmd GhcTc))
    tcCmdMatches CmdEnv
    env TcType
    scrut_ty MatchGroup GhcRn (LHsCmd GhcRn)
    matches (TcType
    stk, TcType
    res_ty)
      = HsMatchContextRn
    -> TcMatchAltChecker HsCmd
    -> Scaled TcType
    -> MatchGroup GhcRn (GenLocated (EpAnn AnnListItem) (HsCmd GhcRn))
    -> ExpRhoType
    -> IOEnv
         (Env TcGblEnv TcLclEnv)
         (MatchGroup GhcTc (GenLocated (EpAnn AnnListItem) (HsCmd GhcTc)))
    forall (body :: * -> *).
    (AnnoBody body, Outputable (body GhcTc)) =>
    HsMatchContextRn
    -> TcMatchAltChecker body
    -> Scaled TcType
    -> MatchGroup GhcRn (LocatedA (body GhcRn))
    -> ExpRhoType
    -> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
    tcCaseMatches HsMatchContextRn
    HsMatchContext (GenLocated SrcSpanAnnN Name)
    forall {fn}. HsMatchContext fn
    ctxt TcMatchAltChecker HsCmd
    tc_body (TcType -> Scaled TcType
    forall a. a -> Scaled a
    unrestricted TcType
    scrut_ty) MatchGroup GhcRn (LHsCmd GhcRn)
    MatchGroup GhcRn (GenLocated (EpAnn AnnListItem) (HsCmd GhcRn))
    matches (TcType -> ExpRhoType
    mkCheckExpType TcType
    res_ty)
      where
        ctxt :: HsMatchContext fn
    ctxt = HsArrowMatchContext -> HsMatchContext fn
    forall fn. HsArrowMatchContext -> HsMatchContext fn
    ArrowMatchCtxt HsArrowMatchContext
    ArrowCaseAlt
        tc_body :: TcMatchAltChecker HsCmd
    tc_body GenLocated (EpAnn AnnListItem) (HsCmd GhcRn)
    body ExpRhoType
    res_ty' = do { res_ty' <- ExpRhoType -> TcM TcType
    expTypeToType ExpRhoType
    res_ty'
                                  ; tcCmd env body (stk, res_ty') }

    -- | Typechecking for 'HsCmdLam' and 'HsCmdLamCase'.
    tcCmdMatchLambda :: CmdEnv
                     -> HsArrowMatchContext
                     -> Arity
                     -> MatchGroup GhcRn (LHsCmd GhcRn)
                     -> CmdType
                     -> TcM (HsWrapper, MatchGroup GhcTc (LHsCmd GhcTc))
    tcCmdMatchLambda :: CmdEnv
    -> HsArrowMatchContext
    -> Arity
    -> MatchGroup GhcRn (LHsCmd GhcRn)
    -> (TcType, TcType)
    -> TcM (HsWrapper, MatchGroup GhcTc (LHsCmd GhcTc))
    tcCmdMatchLambda CmdEnv
    env HsArrowMatchContext
    ctxt Arity
    arity
                     mg :: MatchGroup GhcRn (LHsCmd GhcRn)
    mg@MG { mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
    mg_alts = L SrcSpanAnnLW
    l [GenLocated
       (EpAnn AnnListItem)
       (Match GhcRn (GenLocated (EpAnn AnnListItem) (HsCmd GhcRn)))]
    matches, mg_ext :: forall p body. MatchGroup p body -> XMG p body
    mg_ext = XMG GhcRn (LHsCmd GhcRn)
    origin }
                     (TcType
    cmd_stk, TcType
    res_ty)
      = do { (co, arg_tys, cmd_stk') <- Arity -> TcType -> TcM (TcCoercion, [TcType], TcType)
    matchExpectedCmdArgs Arity
    arity TcType
    cmd_stk

           ; let check_arg_tys = (TcType -> Scaled ExpRhoType) -> [TcType] -> [Scaled ExpRhoType]
    forall a b. (a -> b) -> [a] -> [b]
    map (ExpRhoType -> Scaled ExpRhoType
    forall a. a -> Scaled a
    unrestricted (ExpRhoType -> Scaled ExpRhoType)
    -> (TcType -> ExpRhoType) -> TcType -> Scaled ExpRhoType
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . TcType -> ExpRhoType
    mkCheckExpType) [TcType]
    arg_tys
           ; matches' <- forM matches $
               addErrCtxt . MatchInCtxt . unLoc <*> tc_match check_arg_tys cmd_stk'

           ; let arg_tys' = (TcType -> Scaled TcType) -> [TcType] -> [Scaled TcType]
    forall a b. (a -> b) -> [a] -> [b]
    map TcType -> Scaled TcType
    forall a. a -> Scaled a
    unrestricted [TcType]
    arg_tys
                 mg' = MatchGroup GhcRn (LHsCmd GhcRn)
    mg { mg_alts = L l matches'
                          , mg_ext = MatchGroupTc arg_tys' res_ty origin }

           ; return (mkWpCastN co, mg') }
      where
        -- Check the patterns, and the GRHSs inside
        tc_match :: [Scaled ExpRhoType]
    -> TcType
    -> GenLocated
         (EpAnn AnnListItem)
         (Match GhcRn (GenLocated (EpAnn AnnListItem) (HsCmd GhcRn)))
    -> IOEnv
         (Env TcGblEnv TcLclEnv)
         (GenLocated
            (EpAnn AnnListItem)
            (Match GhcTc (GenLocated (EpAnn AnnListItem) (HsCmd GhcTc))))
    tc_match [Scaled ExpRhoType]
    arg_tys TcType
    cmd_stk' (L EpAnn AnnListItem
    mtch_loc (Match { m_pats :: forall p body. Match p body -> XRec p [LPat p]
    m_pats = L EpaLocation
    l [GenLocated (EpAnn AnnListItem) (Pat GhcRn)]
    pats, m_grhss :: forall p body. Match p body -> GRHSs p body
    m_grhss = GRHSs GhcRn (GenLocated (EpAnn AnnListItem) (HsCmd GhcRn))
    grhss }))
          = do { (pats', grhss') <- EpAnn AnnListItem
    -> TcRn
         ([LPat GhcTc],
          GRHSs GhcTc (GenLocated (EpAnn AnnListItem) (HsCmd GhcTc)))
    -> TcRn
         ([LPat GhcTc],
          GRHSs GhcTc (GenLocated (EpAnn AnnListItem) (HsCmd GhcTc)))
    forall ann a. EpAnn ann -> TcRn a -> TcRn a
    setSrcSpanA EpAnn AnnListItem
    mtch_loc           (TcRn
       ([LPat GhcTc],
        GRHSs GhcTc (GenLocated (EpAnn AnnListItem) (HsCmd GhcTc)))
     -> TcRn
          ([LPat GhcTc],
           GRHSs GhcTc (GenLocated (EpAnn AnnListItem) (HsCmd GhcTc))))
    -> TcRn
         ([LPat GhcTc],
          GRHSs GhcTc (GenLocated (EpAnn AnnListItem) (HsCmd GhcTc)))
    -> TcRn
         ([LPat GhcTc],
          GRHSs GhcTc (GenLocated (EpAnn AnnListItem) (HsCmd GhcTc)))
    forall a b. (a -> b) -> a -> b
    $
                                    HsMatchContextRn
    -> [LPat GhcRn]
    -> [ExpPatType]
    -> TcM (GRHSs GhcTc (GenLocated (EpAnn AnnListItem) (HsCmd GhcTc)))
    -> TcRn
         ([LPat GhcTc],
          GRHSs GhcTc (GenLocated (EpAnn AnnListItem) (HsCmd GhcTc)))
    forall a.
    HsMatchContextRn
    -> [LPat GhcRn] -> [ExpPatType] -> TcM a -> TcM ([LPat GhcTc], a)
    tcMatchPats HsMatchContextRn
    HsMatchContext (GenLocated SrcSpanAnnN Name)
    match_ctxt [LPat GhcRn]
    [GenLocated (EpAnn AnnListItem) (Pat GhcRn)]
    pats ((Scaled ExpRhoType -> ExpPatType)
    -> [Scaled ExpRhoType] -> [ExpPatType]
    forall a b. (a -> b) -> [a] -> [b]
    map Scaled ExpRhoType -> ExpPatType
    ExpFunPatTy [Scaled ExpRhoType]
    arg_tys) (TcM (GRHSs GhcTc (GenLocated (EpAnn AnnListItem) (HsCmd GhcTc)))
     -> TcRn
          ([LPat GhcTc],
           GRHSs GhcTc (GenLocated (EpAnn AnnListItem) (HsCmd GhcTc))))
    -> TcM (GRHSs GhcTc (GenLocated (EpAnn AnnListItem) (HsCmd GhcTc)))
    -> TcRn
         ([LPat GhcTc],
          GRHSs GhcTc (GenLocated (EpAnn AnnListItem) (HsCmd GhcTc)))
    forall a b. (a -> b) -> a -> b
    $
                                    GRHSs GhcRn (GenLocated (EpAnn AnnListItem) (HsCmd GhcRn))
    -> TcType
    -> ExpRhoType
    -> TcM (GRHSs GhcTc (GenLocated (EpAnn AnnListItem) (HsCmd GhcTc)))
    tc_grhss GRHSs GhcRn (GenLocated (EpAnn AnnListItem) (HsCmd GhcRn))
    grhss TcType
    cmd_stk' (TcType -> ExpRhoType
    mkCheckExpType TcType
    res_ty)

               ; return $ L mtch_loc (Match { m_ext = noExtField
                                            , m_ctxt = match_ctxt
                                            , m_pats = L l pats'
                                            , m_grhss = grhss' }) }

        match_ctxt :: HsMatchContext (GenLocated SrcSpanAnnN Name)
    match_ctxt = HsArrowMatchContext -> HsMatchContext (GenLocated SrcSpanAnnN Name)
    forall fn. HsArrowMatchContext -> HsMatchContext fn
    ArrowMatchCtxt HsArrowMatchContext
    ctxt
        pg_ctxt :: HsStmtContext (GenLocated SrcSpanAnnN Name)
    pg_ctxt    = HsMatchContext (GenLocated SrcSpanAnnN Name)
    -> HsStmtContext (GenLocated SrcSpanAnnN Name)
    forall fn. HsMatchContext fn -> HsStmtContext fn
    PatGuard HsMatchContext (GenLocated SrcSpanAnnN Name)
    match_ctxt

        tc_grhss :: GRHSs GhcRn (GenLocated (EpAnn AnnListItem) (HsCmd GhcRn))
    -> TcType
    -> ExpRhoType
    -> TcM (GRHSs GhcTc (GenLocated (EpAnn AnnListItem) (HsCmd GhcTc)))
    tc_grhss (GRHSs XCGRHSs GhcRn (GenLocated (EpAnn AnnListItem) (HsCmd GhcRn))
    x NonEmpty
      (LGRHS GhcRn (GenLocated (EpAnn AnnListItem) (HsCmd GhcRn)))
    grhss HsLocalBinds GhcRn
    binds) TcType
    stk_ty ExpRhoType
    res_ty
            = do { (binds',grhss') <- HsLocalBinds GhcRn
    -> TcM
         (NonEmpty
            (GenLocated
               EpAnnCO
               (GRHS GhcTc (GenLocated (EpAnn AnnListItem) (HsCmd GhcTc)))))
    -> TcM
         (HsLocalBinds GhcTc,
          NonEmpty
            (GenLocated
               EpAnnCO
               (GRHS GhcTc (GenLocated (EpAnn AnnListItem) (HsCmd GhcTc)))))
    forall thing.
    HsLocalBinds GhcRn -> TcM thing -> TcM (HsLocalBinds GhcTc, thing)
    tcLocalBinds HsLocalBinds GhcRn
    binds (TcM
       (NonEmpty
          (GenLocated
             EpAnnCO
             (GRHS GhcTc (GenLocated (EpAnn AnnListItem) (HsCmd GhcTc)))))
     -> TcM
          (HsLocalBinds GhcTc,
           NonEmpty
             (GenLocated
                EpAnnCO
                (GRHS GhcTc (GenLocated (EpAnn AnnListItem) (HsCmd GhcTc))))))
    -> TcM
         (NonEmpty
            (GenLocated
               EpAnnCO
               (GRHS GhcTc (GenLocated (EpAnn AnnListItem) (HsCmd GhcTc)))))
    -> TcM
         (HsLocalBinds GhcTc,
          NonEmpty
            (GenLocated
               EpAnnCO
               (GRHS GhcTc (GenLocated (EpAnn AnnListItem) (HsCmd GhcTc)))))
    forall a b. (a -> b) -> a -> b
    $
                                      (GenLocated
       EpAnnCO (GRHS GhcRn (GenLocated (EpAnn AnnListItem) (HsCmd GhcRn)))
     -> IOEnv
          (Env TcGblEnv TcLclEnv)
          (GenLocated
             EpAnnCO
             (GRHS GhcTc (GenLocated (EpAnn AnnListItem) (HsCmd GhcTc)))))
    -> NonEmpty
         (GenLocated
            EpAnnCO
            (GRHS GhcRn (GenLocated (EpAnn AnnListItem) (HsCmd GhcRn))))
    -> TcM
         (NonEmpty
            (GenLocated
               EpAnnCO
               (GRHS GhcTc (GenLocated (EpAnn AnnListItem) (HsCmd GhcTc)))))
    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) -> NonEmpty a -> m (NonEmpty b)
    mapM ((GRHS GhcRn (GenLocated (EpAnn AnnListItem) (HsCmd GhcRn))
     -> TcM (GRHS GhcTc (GenLocated (EpAnn AnnListItem) (HsCmd GhcTc))))
    -> GenLocated
         EpAnnCO (GRHS GhcRn (GenLocated (EpAnn AnnListItem) (HsCmd GhcRn)))
    -> IOEnv
         (Env TcGblEnv TcLclEnv)
         (GenLocated
            EpAnnCO
            (GRHS GhcTc (GenLocated (EpAnn AnnListItem) (HsCmd GhcTc))))
    forall a b ann.
    (a -> TcM b)
    -> GenLocated (EpAnn ann) a -> TcRn (GenLocated (EpAnn ann) b)
    wrapLocMA (TcType
    -> ExpRhoType
    -> GRHS GhcRn (GenLocated (EpAnn AnnListItem) (HsCmd GhcRn))
    -> TcM (GRHS GhcTc (GenLocated (EpAnn AnnListItem) (HsCmd GhcTc)))
    tc_grhs TcType
    stk_ty ExpRhoType
    res_ty)) NonEmpty
      (LGRHS GhcRn (GenLocated (EpAnn AnnListItem) (HsCmd GhcRn)))
    NonEmpty
      (GenLocated
         EpAnnCO
         (GRHS GhcRn (GenLocated (EpAnn AnnListItem) (HsCmd GhcRn))))
    grhss
                 ; return (GRHSs x grhss' binds') }

        tc_grhs :: TcType
    -> ExpRhoType
    -> GRHS GhcRn (GenLocated (EpAnn AnnListItem) (HsCmd GhcRn))
    -> TcM (GRHS GhcTc (GenLocated (EpAnn AnnListItem) (HsCmd GhcTc)))
    tc_grhs TcType
    stk_ty ExpRhoType
    res_ty (GRHS XCGRHS GhcRn (GenLocated (EpAnn AnnListItem) (HsCmd GhcRn))
    x [GuardLStmt GhcRn]
    guards GenLocated (EpAnn AnnListItem) (HsCmd GhcRn)
    body)
            = do { (guards', rhs') <- HsStmtContextRn
    -> TcStmtChecker HsExpr ExpRhoType
    -> [LStmt GhcRn (GenLocated (EpAnn AnnListItem) (HsExpr GhcRn))]
    -> ExpRhoType
    -> (ExpRhoType
        -> IOEnv
             (Env TcGblEnv TcLclEnv)
             (GenLocated (EpAnn AnnListItem) (HsCmd GhcTc)))
    -> TcM
         ([LStmt GhcTc (GenLocated (EpAnn AnnListItem) (HsExpr GhcTc))],
          GenLocated (EpAnn AnnListItem) (HsCmd GhcTc))
    forall (body :: * -> *) rho_type thing.
    AnnoBody body =>
    HsStmtContextRn
    -> TcStmtChecker body rho_type
    -> [LStmt GhcRn (LocatedA (body GhcRn))]
    -> rho_type
    -> (rho_type -> TcM thing)
    -> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
    tcStmtsAndThen HsStmtContextRn
    HsStmtContext (GenLocated SrcSpanAnnN Name)
    pg_ctxt HsStmtContextRn
    -> Stmt GhcRn (GenLocated (EpAnn AnnListItem) (HsExpr GhcRn))
    -> ExpRhoType
    -> (ExpRhoType -> TcM thing)
    -> TcM
         (StmtLR
            GhcTc GhcTc (GenLocated (EpAnn AnnListItem) (HsExpr GhcTc)),
          thing)
    TcStmtChecker HsExpr ExpRhoType
    tcGuardStmt [GuardLStmt GhcRn]
    [LStmt GhcRn (GenLocated (EpAnn AnnListItem) (HsExpr GhcRn))]
    guards ExpRhoType
    res_ty ((ExpRhoType
      -> IOEnv
           (Env TcGblEnv TcLclEnv)
           (GenLocated (EpAnn AnnListItem) (HsCmd GhcTc)))
     -> TcM
          ([LStmt GhcTc (GenLocated (EpAnn AnnListItem) (HsExpr GhcTc))],
           GenLocated (EpAnn AnnListItem) (HsCmd GhcTc)))
    -> (ExpRhoType
        -> IOEnv
             (Env TcGblEnv TcLclEnv)
             (GenLocated (EpAnn AnnListItem) (HsCmd GhcTc)))
    -> TcM
         ([LStmt GhcTc (GenLocated (EpAnn AnnListItem) (HsExpr GhcTc))],
          GenLocated (EpAnn AnnListItem) (HsCmd GhcTc))
    forall a b. (a -> b) -> a -> b
    $
                                      \ ExpRhoType
    res_ty -> CmdEnv -> LHsCmd GhcRn -> (TcType, TcType) -> TcM (LHsCmd GhcTc)
    tcCmd CmdEnv
    env LHsCmd GhcRn
    GenLocated (EpAnn AnnListItem) (HsCmd GhcRn)
    body
                                                    (TcType
    stk_ty, ExpRhoType -> TcType
    checkingExpType ExpRhoType
    res_ty)
                 ; return (GRHS x guards' rhs') }

    matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercionN, [TcTypeFRR], TcType)
    matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercion, [TcType], TcType)
    matchExpectedCmdArgs Arity
    0 TcType
    ty
      = (TcCoercion, [TcType], TcType)
    -> TcM (TcCoercion, [TcType], TcType)
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (TcType -> TcCoercion
    mkNomReflCo TcType
    ty, [], TcType
    ty)
    matchExpectedCmdArgs Arity
    n TcType
    ty
      = do { (co1, [ty1, ty2]) <- TyCon -> TcType -> TcM (TcCoercion, [TcType])
    matchExpectedTyConApp TyCon
    pairTyCon TcType
    ty
           ; (co2, tys, res_ty) <- matchExpectedCmdArgs (n-1) ty2
           ; return (mkTyConAppCo Nominal pairTyCon [co1, co2], ty1:tys, res_ty) }

    {-
    ************************************************************************
    *                                                                      *
                    Stmts
    *                                                                      *
    ************************************************************************
    -}

    --------------------------------
    --      Mdo-notation
    -- The distinctive features here are
    --      (a) RecStmts, and
    --      (b) no rebindable syntax

    tcArrDoStmt :: CmdEnv -> TcCmdStmtChecker
    tcArrDoStmt :: CmdEnv -> TcStmtChecker HsCmd TcType
    tcArrDoStmt CmdEnv
    env HsStmtContextRn
    _ (LastStmt XLastStmt
      GhcRn GhcRn (GenLocated (EpAnn AnnListItem) (HsCmd GhcRn))
    x GenLocated (EpAnn AnnListItem) (HsCmd GhcRn)
    rhs Maybe Bool
    noret SyntaxExpr GhcRn
    _) TcType
    res_ty TcType -> TcM thing
    thing_inside
      = do  { rhs' <- CmdEnv -> LHsCmd GhcRn -> (TcType, TcType) -> TcM (LHsCmd GhcTc)
    tcCmd CmdEnv
    env LHsCmd GhcRn
    GenLocated (EpAnn AnnListItem) (HsCmd GhcRn)
    rhs (TcType
    unitTy, TcType
    res_ty)
            ; thing <- thing_inside (panic "tcArrDoStmt")
            ; return (LastStmt x rhs' noret noSyntaxExpr, thing) }

    tcArrDoStmt CmdEnv
    env HsStmtContextRn
    _ (BodyStmt XBodyStmt
      GhcRn GhcRn (GenLocated (EpAnn AnnListItem) (HsCmd GhcRn))
    _ GenLocated (EpAnn AnnListItem) (HsCmd GhcRn)
    rhs SyntaxExpr GhcRn
    _ SyntaxExpr GhcRn
    _) TcType
    res_ty TcType -> TcM thing
    thing_inside
      = do  { (rhs', elt_ty) <- CmdEnv -> LHsCmd GhcRn -> TcM (LHsCmd GhcTc, TcType)
    tc_arr_rhs CmdEnv
    env LHsCmd GhcRn
    GenLocated (EpAnn AnnListItem) (HsCmd GhcRn)
    rhs
            ; thing          <- thing_inside res_ty
            ; return (BodyStmt elt_ty rhs' noSyntaxExpr noSyntaxExpr, thing) }

    tcArrDoStmt CmdEnv
    env HsStmtContextRn
    ctxt (BindStmt XBindStmt
      GhcRn GhcRn (GenLocated (EpAnn AnnListItem) (HsCmd GhcRn))
    _ LPat GhcRn
    pat GenLocated (EpAnn AnnListItem) (HsCmd GhcRn)
    rhs) TcType
    res_ty TcType -> TcM thing
    thing_inside
      = do  { (rhs', pat_ty) <- CmdEnv -> LHsCmd GhcRn -> TcM (LHsCmd GhcTc, TcType)
    tc_arr_rhs CmdEnv
    env LHsCmd GhcRn
    GenLocated (EpAnn AnnListItem) (HsCmd GhcRn)
    rhs
            ; (pat', thing)  <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted pat_ty) $
                                thing_inside res_ty
            ; return (mkTcBindStmt pat' rhs', thing) }

    tcArrDoStmt CmdEnv
    env HsStmtContextRn
    ctxt (RecStmt { recS_stmts :: forall idL idR body.
    StmtLR idL idR body -> XRec idR [LStmtLR idL idR body]
    recS_stmts = L SrcSpanAnnLW
    l [GenLocated
       (EpAnn AnnListItem)
       (StmtLR
          GhcRn GhcRn (GenLocated (EpAnn AnnListItem) (HsCmd GhcRn)))]
    stmts, recS_later_ids :: forall idL idR body. StmtLR idL idR body -> [IdP idR]
    recS_later_ids = [IdP GhcRn]
    later_names
                                , recS_rec_ids :: forall idL idR body. StmtLR idL idR body -> [IdP idR]
    recS_rec_ids = [IdP GhcRn]
    rec_names }) TcType
    res_ty TcType -> TcM thing
    thing_inside
      = do  { let tup_names :: [IdP GhcRn]
    tup_names = [IdP GhcRn]
    rec_names [IdP GhcRn] -> [IdP GhcRn] -> [IdP GhcRn]
    forall a. [a] -> [a] -> [a]
    ++ (IdP GhcRn -> Bool) -> [IdP GhcRn] -> [IdP GhcRn]
    forall a. (a -> Bool) -> [a] -> [a]
    filterOut (IdP GhcRn -> [IdP GhcRn] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [IdP GhcRn]
    rec_names) [IdP GhcRn]
    later_names
            ; tup_elt_tys <- Arity -> TcType -> TcM [TcType]
    newFlexiTyVarTys ([Name] -> Arity
    forall a. [a] -> Arity
    forall (t :: * -> *) a. Foldable t => t a -> Arity
    length [IdP GhcRn]
    [Name]
    tup_names) TcType
    liftedTypeKind
            ; let tup_ids = (Name -> TcType -> Id) -> [Name] -> [TcType] -> [Id]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith (\Name
    n TcType
    p -> HasDebugCallStack => Name -> TcType -> TcType -> Id
    Name -> TcType -> TcType -> Id
    mkLocalId Name
    n TcType
    ManyTy TcType
    p) [IdP GhcRn]
    [Name]
    tup_names [TcType]
    tup_elt_tys
                            -- Many because it's a recursive definition
            ; tcExtendIdEnv tup_ids $ do
            { (stmts', tup_rets)
                    <- tcStmtsAndThen ctxt (tcArrDoStmt env) stmts res_ty   $ \ TcType
    _res_ty' ->
                            -- ToDo: res_ty not really right
                       (Name
     -> ExpRhoType -> IOEnv (Env TcGblEnv TcLclEnv) (HsExpr GhcTc))
    -> [Name] -> [ExpRhoType] -> TcM [HsExpr GhcTc]
    forall (m :: * -> *) a b c.
    Applicative m =>
    (a -> b -> m c) -> [a] -> [b] -> m [c]
    zipWithM Name -> ExpRhoType -> IOEnv (Env TcGblEnv TcLclEnv) (HsExpr GhcTc)
    tcCheckId [IdP GhcRn]
    [Name]
    tup_names ((TcType -> ExpRhoType) -> [TcType] -> [ExpRhoType]
    forall a b. (a -> b) -> [a] -> [b]
    map TcType -> ExpRhoType
    mkCheckExpType [TcType]
    tup_elt_tys)

            ; thing <- thing_inside res_ty
                    -- NB:  The rec_ids for the recursive things
                    --      already scope over this part. This binding may shadow
                    --      some of them with polymorphic things with the same Name
                    --      (see Note [How RecStmt works] in Language.Haskell.Syntax.Expr)

            ; let rec_ids = [Name] -> [Id] -> [Id]
    forall b a. [b] -> [a] -> [a]
    takeList [IdP GhcRn]
    [Name]
    rec_names [Id]
    tup_ids
            ; later_ids <- tcLookupLocalIds later_names

            ; let rec_rets = [Name] -> [HsExpr GhcTc] -> [HsExpr GhcTc]
    forall b a. [b] -> [a] -> [a]
    takeList [IdP GhcRn]
    [Name]
    rec_names [HsExpr GhcTc]
    tup_rets
            ; let ret_table = [Id] -> [HsExpr GhcTc] -> [(Id, HsExpr GhcTc)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Id]
    tup_ids [HsExpr GhcTc]
    tup_rets
            ; let later_rets = [HsExpr GhcTc
    r | Id
    i <- [Id]
    later_ids, (Id
    j, HsExpr GhcTc
    r) <- [(Id, HsExpr GhcTc)]
    ret_table, Id
    i Id -> Id -> Bool
    forall a. Eq a => a -> a -> Bool
    == Id
    j]

            ; let
                stmt :: Stmt GhcTc (LocatedA (HsCmd GhcTc))
                stmt = StmtLR GhcTc GhcTc (GenLocated (EpAnn AnnListItem) (HsCmd GhcTc))
    emptyRecStmtId
                                     { recS_stmts = L l stmts'
                                     -- { recS_stmts = _ stmts'
                                     , recS_later_ids = later_ids
                                     , recS_rec_ids = rec_ids
                                     , recS_ext = unitRecStmtTc
                                         { recS_later_rets = later_rets
                                         , recS_rec_rets = rec_rets
                                         , recS_ret_ty = res_ty} }
            ; return (stmt, thing)
            }}

    tcArrDoStmt CmdEnv
    _ HsStmtContextRn
    _ StmtLR GhcRn GhcRn (GenLocated (EpAnn AnnListItem) (HsCmd GhcRn))
    stmt TcType
    _ TcType -> TcM thing
    _
      = String
    -> SDoc
    -> IOEnv
         (Env TcGblEnv TcLclEnv)
         (StmtLR GhcTc GhcTc (GenLocated (EpAnn AnnListItem) (HsCmd GhcTc)),
          thing)
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "tcArrDoStmt: unexpected Stmt" (StmtLR GhcRn GhcRn (GenLocated (EpAnn AnnListItem) (HsCmd GhcRn))
    -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr StmtLR GhcRn GhcRn (GenLocated (EpAnn AnnListItem) (HsCmd GhcRn))
    stmt)

    tc_arr_rhs :: CmdEnv -> LHsCmd GhcRn -> TcM (LHsCmd GhcTc, TcType)
    tc_arr_rhs :: CmdEnv -> LHsCmd GhcRn -> TcM (LHsCmd GhcTc, TcType)
    tc_arr_rhs CmdEnv
    env LHsCmd GhcRn
    rhs = do { ty <- TcType -> TcM TcType
    newFlexiTyVarTy TcType
    liftedTypeKind
                            ; rhs' <- tcCmd env rhs (unitTy, ty)
                            ; return (rhs', ty) }

    {-
    ************************************************************************
    *                                                                      *
                    Helpers
    *                                                                      *
    ************************************************************************
    -}

    mkPairTy :: Type -> Type -> Type
    mkPairTy :: TcType -> TcType -> TcType
    mkPairTy TcType
    t1 TcType
    t2 = TyCon -> [TcType] -> TcType
    mkTyConApp TyCon
    pairTyCon [TcType
    t1,TcType
    t2]

    arrowTyConKind :: Kind          --  *->*->*
    arrowTyConKind :: TcType
    arrowTyConKind = [TcType] -> TcType -> TcType
    mkVisFunTysMany [TcType
    liftedTypeKind, TcType
    liftedTypeKind] TcType
    liftedTypeKind