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

-}

{-# LANGUAGE RankNTypes, TupleSections #-}
{-# LANGUAGE TypeFamilies #-}

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

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

import GHC.Prelude

import {-# SOURCE #-}   GHC.Tc.Gen.Expr( tcLExpr, tcInferRho, tcSyntaxOp, tcCheckId, tcCheckExpr )

import GHC.Hs
import GHC.Tc.Gen.Match
import GHC.Tc.Utils.Zonk( hsLPatType )
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.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.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 GhcTcId, TcCoercion)

tcProc :: LPat GhcRn
-> LHsCmdTop GhcRn
-> ExpRhoType
-> TcM (LPat GhcTc, LHsCmdTop GhcTc, TcCoercion)
tcProc LPat GhcRn
pat LHsCmdTop GhcRn
cmd ExpRhoType
exp_ty
  = TcM (Located (Pat GhcTc), LHsCmdTop GhcTc, TcCoercion)
-> TcM (Located (Pat GhcTc), LHsCmdTop GhcTc, TcCoercion)
forall a. TcM a -> TcM a
newArrowScope (TcM (Located (Pat GhcTc), LHsCmdTop GhcTc, TcCoercion)
 -> TcM (Located (Pat GhcTc), LHsCmdTop GhcTc, TcCoercion))
-> TcM (Located (Pat GhcTc), LHsCmdTop GhcTc, TcCoercion)
-> TcM (Located (Pat GhcTc), LHsCmdTop GhcTc, TcCoercion)
forall a b. (a -> b) -> a -> b
$
    do  { TcType
exp_ty <- ExpRhoType -> TcM TcType
expTypeToType ExpRhoType
exp_ty  -- no higher-rank stuff with arrows
        ; (TcCoercion
co, (TcType
exp_ty1, TcType
res_ty)) <- TcType -> TcM (TcCoercion, (TcType, TcType))
matchExpectedAppTy TcType
exp_ty
        ; (TcCoercion
co1, (TcType
arr_ty, TcType
arg_ty)) <- TcType -> TcM (TcCoercion, (TcType, TcType))
matchExpectedAppTy TcType
exp_ty1
        ; let cmd_env :: CmdEnv
cmd_env = CmdEnv :: TcType -> CmdEnv
CmdEnv { cmd_arr :: TcType
cmd_arr = TcType
arr_ty }
        ; (Located (Pat GhcTc)
pat', LHsCmdTop GhcTc
cmd') <- HsMatchContext GhcRn
-> LPat GhcRn
-> TcType
-> TcM (LHsCmdTop GhcTc)
-> TcM (LPat GhcTc, LHsCmdTop GhcTc)
forall a.
HsMatchContext GhcRn
-> LPat GhcRn -> TcType -> TcM a -> TcM (LPat GhcTc, a)
tcCheckPat HsMatchContext GhcRn
forall p. HsMatchContext p
ProcExpr LPat GhcRn
pat TcType
arg_ty (TcM (LHsCmdTop GhcTc) -> TcM (LPat GhcTc, LHsCmdTop GhcTc))
-> TcM (LHsCmdTop GhcTc) -> TcM (LPat GhcTc, LHsCmdTop GhcTc)
forall a b. (a -> b) -> a -> b
$
                          CmdEnv
-> LHsCmdTop GhcRn -> (TcType, TcType) -> TcM (LHsCmdTop GhcTc)
tcCmdTop CmdEnv
cmd_env LHsCmdTop GhcRn
cmd (TcType
unitTy, TcType
res_ty)
        ; let res_co :: TcCoercion
res_co = TcCoercion -> TcCoercion -> TcCoercion
mkTcTransCo TcCoercion
co
                         (TcCoercion -> TcCoercion -> TcCoercion
mkTcAppCo TcCoercion
co1 (TcType -> TcCoercion
mkTcNomReflCo TcType
res_ty))
        ; (Located (Pat GhcTc), LHsCmdTop GhcTc, TcCoercion)
-> TcM (Located (Pat GhcTc), LHsCmdTop GhcTc, TcCoercion)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (Located (Pat GhcTc)
pat', LHsCmdTop GhcTc
cmd', TcCoercion
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
         -> LHsCmdTop GhcRn
         -> CmdType
         -> TcM (LHsCmdTop GhcTcId)

tcCmdTop :: CmdEnv
-> LHsCmdTop GhcRn -> (TcType, TcType) -> TcM (LHsCmdTop GhcTc)
tcCmdTop CmdEnv
env (L SrcSpan
loc (HsCmdTop XCmdTop GhcRn
names LHsCmd GhcRn
cmd)) cmd_ty :: (TcType, TcType)
cmd_ty@(TcType
cmd_stk, TcType
res_ty)
  = SrcSpan -> TcM (LHsCmdTop GhcTc) -> TcM (LHsCmdTop GhcTc)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM (LHsCmdTop GhcTc) -> TcM (LHsCmdTop GhcTc))
-> TcM (LHsCmdTop GhcTc) -> TcM (LHsCmdTop GhcTc)
forall a b. (a -> b) -> a -> b
$
    do  { LHsCmd GhcTc
cmd'   <- CmdEnv -> LHsCmd GhcRn -> (TcType, TcType) -> TcM (LHsCmd GhcTc)
tcCmd CmdEnv
env LHsCmd GhcRn
cmd (TcType, TcType)
cmd_ty
        ; [(Name, HsExpr GhcTc)]
names' <- ((Name, HsExpr GhcRn)
 -> IOEnv (Env TcGblEnv TcLclEnv) (Name, HsExpr GhcTc))
-> [(Name, HsExpr GhcRn)]
-> IOEnv (Env TcGblEnv TcLclEnv) [(Name, HsExpr GhcTc)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Traversable []
mapM (CtOrigin
-> TcType
-> (Name, HsExpr GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Name, HsExpr GhcTc)
tcSyntaxName CtOrigin
ProcOrigin (CmdEnv -> TcType
cmd_arr CmdEnv
env)) [(Name, HsExpr GhcRn)]
XCmdTop GhcRn
names
        ; LHsCmdTop GhcTc -> TcM (LHsCmdTop GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (SrcSpan -> HsCmdTop GhcTc -> LHsCmdTop GhcTc
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsCmdTop GhcTc -> LHsCmdTop GhcTc)
-> HsCmdTop GhcTc -> LHsCmdTop GhcTc
forall a b. (a -> b) -> a -> b
$ XCmdTop GhcTc -> LHsCmd GhcTc -> HsCmdTop GhcTc
forall p. XCmdTop p -> LHsCmd p -> HsCmdTop p
HsCmdTop (TcType -> TcType -> [(Name, HsExpr GhcTc)] -> CmdTopTc
CmdTopTc TcType
cmd_stk TcType
res_ty [(Name, HsExpr GhcTc)]
names') LHsCmd GhcTc
cmd') }

----------------------------------------
tcCmd  :: CmdEnv -> LHsCmd GhcRn -> CmdType -> TcM (LHsCmd GhcTcId)
        -- The main recursive function
tcCmd :: CmdEnv -> LHsCmd GhcRn -> (TcType, TcType) -> TcM (LHsCmd GhcTc)
tcCmd CmdEnv
env (L SrcSpan
loc HsCmd GhcRn
cmd) (TcType, TcType)
res_ty
  = SrcSpan -> TcM (LHsCmd GhcTc) -> TcM (LHsCmd GhcTc)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM (LHsCmd GhcTc) -> TcM (LHsCmd GhcTc))
-> TcM (LHsCmd GhcTc) -> TcM (LHsCmd GhcTc)
forall a b. (a -> b) -> a -> b
$ do
        { HsCmd GhcTc
cmd' <- CmdEnv -> HsCmd GhcRn -> (TcType, TcType) -> TcM (HsCmd GhcTc)
tc_cmd CmdEnv
env HsCmd GhcRn
cmd (TcType, TcType)
res_ty
        ; LHsCmd GhcTc -> TcM (LHsCmd GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (SrcSpan -> HsCmd GhcTc -> LHsCmd GhcTc
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc HsCmd GhcTc
cmd') }

tc_cmd :: CmdEnv -> HsCmd GhcRn  -> CmdType -> TcM (HsCmd GhcTcId)
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  { LHsCmd GhcTc
cmd' <- CmdEnv -> LHsCmd GhcRn -> (TcType, TcType) -> TcM (LHsCmd GhcTc)
tcCmd CmdEnv
env LHsCmd GhcRn
cmd (TcType, TcType)
res_ty
        ; HsCmd GhcTc -> TcM (HsCmd GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (XCmdPar GhcTc -> LHsCmd GhcTc -> HsCmd GhcTc
forall id. XCmdPar id -> LHsCmd id -> HsCmd id
HsCmdPar XCmdPar GhcRn
XCmdPar GhcTc
x LHsCmd GhcTc
cmd') }

tc_cmd CmdEnv
env (HsCmdLet XCmdLet GhcRn
x (L SrcSpan
l HsLocalBinds GhcRn
binds) (L SrcSpan
body_loc HsCmd GhcRn
body)) (TcType, TcType)
res_ty
  = do  { (HsLocalBinds GhcTc
binds', HsCmd GhcTc
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 SrcSpan
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
        ; HsCmd GhcTc -> TcM (HsCmd GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (XCmdLet GhcTc -> LHsLocalBinds GhcTc -> LHsCmd GhcTc -> HsCmd GhcTc
forall id. XCmdLet id -> LHsLocalBinds id -> LHsCmd id -> HsCmd id
HsCmdLet XCmdLet GhcRn
XCmdLet GhcTc
x (SrcSpan -> HsLocalBinds GhcTc -> LHsLocalBinds GhcTc
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsLocalBinds GhcTc
binds') (SrcSpan -> HsCmd GhcTc -> LHsCmd GhcTc
forall l e. l -> e -> GenLocated l e
L SrcSpan
body_loc HsCmd GhcTc
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)
  = MsgDoc -> TcM (HsCmd GhcTc) -> TcM (HsCmd GhcTc)
forall a. MsgDoc -> TcM a -> TcM a
addErrCtxt (HsCmd GhcRn -> MsgDoc
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
      (LHsExpr GhcTc
scrut', TcType
scrut_ty) <- LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcType)
tcInferRho LHsExpr GhcRn
scrut
      MatchGroup GhcTc (LHsCmd GhcTc)
matches' <- 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)
      HsCmd GhcTc -> TcM (HsCmd GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (XCmdCase GhcTc
-> LHsExpr GhcTc -> MatchGroup GhcTc (LHsCmd GhcTc) -> HsCmd GhcTc
forall id.
XCmdCase id -> LHsExpr id -> MatchGroup id (LHsCmd id) -> HsCmd id
HsCmdCase XCmdCase GhcRn
XCmdCase GhcTc
x LHsExpr GhcTc
scrut' MatchGroup GhcTc (LHsCmd GhcTc)
matches')

tc_cmd CmdEnv
env in_cmd :: HsCmd GhcRn
in_cmd@(HsCmdLamCase XCmdLamCase GhcRn
x MatchGroup GhcRn (LHsCmd GhcRn)
matches) (TcType
stk, TcType
res_ty)
  = MsgDoc -> TcM (HsCmd GhcTc) -> TcM (HsCmd GhcTc)
forall a. MsgDoc -> TcM a -> TcM a
addErrCtxt (HsCmd GhcRn -> MsgDoc
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
      (TcCoercion
co, [TcType
scrut_ty], TcType
stk') <- Arity -> TcType -> TcM (TcCoercion, [TcType], TcType)
matchExpectedCmdArgs Arity
1 TcType
stk
      MatchGroup GhcTc (LHsCmd GhcTc)
matches' <- 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)
      HsCmd GhcTc -> TcM (HsCmd GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (HsWrapper -> HsCmd GhcTc -> HsCmd GhcTc
mkHsCmdWrap (TcCoercion -> HsWrapper
mkWpCastN TcCoercion
co) (XCmdLamCase GhcTc -> MatchGroup GhcTc (LHsCmd GhcTc) -> HsCmd GhcTc
forall id. XCmdLamCase id -> MatchGroup id (LHsCmd id) -> HsCmd id
HsCmdLamCase XCmdLamCase GhcRn
XCmdLamCase GhcTc
x MatchGroup GhcTc (LHsCmd GhcTc)
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  { LHsExpr GhcTc
pred' <- LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcLExpr LHsExpr GhcRn
pred (TcType -> ExpRhoType
mkCheckExpType TcType
boolTy)
        ; LHsCmd GhcTc
b1'   <- CmdEnv -> LHsCmd GhcRn -> (TcType, TcType) -> TcM (LHsCmd GhcTc)
tcCmd CmdEnv
env LHsCmd GhcRn
b1 (TcType, TcType)
res_ty
        ; LHsCmd GhcTc
b2'   <- CmdEnv -> LHsCmd GhcRn -> (TcType, TcType) -> TcM (LHsCmd GhcTc)
tcCmd CmdEnv
env LHsCmd GhcRn
b2 (TcType, TcType)
res_ty
        ; HsCmd GhcTc -> TcM (HsCmd GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (XCmdIf GhcTc
-> SyntaxExpr GhcTc
-> LHsExpr GhcTc
-> LHsCmd GhcTc
-> LHsCmd GhcTc
-> HsCmd GhcTc
forall id.
XCmdIf id
-> SyntaxExpr id
-> LHsExpr id
-> LHsCmd id
-> LHsCmd id
-> HsCmd id
HsCmdIf XCmdIf GhcRn
XCmdIf GhcTc
x SyntaxExpr GhcTc
SyntaxExprTc
NoSyntaxExprTc LHsExpr GhcTc
pred' LHsCmd GhcTc
b1' LHsCmd GhcTc
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  { TcType
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.
        ; (TCvSubst
_, [TcTyVar
r_tv]) <- [TcTyVar] -> TcM (TCvSubst, [TcTyVar])
tcInstSkolTyVars [TcTyVar
alphaTyVar]
        ; let r_ty :: TcType
r_ty = TcTyVar -> TcType
mkTyVarTy TcTyVar
r_tv
        ; Bool -> MsgDoc -> TcM ()
checkTc (Bool -> Bool
not (TcTyVar
r_tv TcTyVar -> VarSet -> Bool
`elemVarSet` TcType -> VarSet
tyCoVarsOfType TcType
pred_ty))
                  (String -> MsgDoc
text String
"Predicate type of `ifThenElse' depends on result type")
        ; (LHsExpr GhcTc
pred', SyntaxExprTc
fun')
            <- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcType] -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc, SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcType] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
IfOrigin SyntaxExpr GhcRn
SyntaxExprRn
fun ((TcType -> SyntaxOpType) -> [TcType] -> [SyntaxOpType]
forall a b. (a -> b) -> [a] -> [b]
map TcType -> SyntaxOpType
synKnownType [TcType
pred_ty, TcType
r_ty, TcType
r_ty])
                                       (TcType -> ExpRhoType
mkCheckExpType TcType
r_ty) (([TcType] -> TcM (LHsExpr GhcTc))
 -> TcM (LHsExpr GhcTc, SyntaxExprTc))
-> ([TcType] -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc, SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$ \ [TcType]
_ ->
               LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcLExpr LHsExpr GhcRn
pred (TcType -> ExpRhoType
mkCheckExpType TcType
pred_ty)

        ; LHsCmd GhcTc
b1'   <- CmdEnv -> LHsCmd GhcRn -> (TcType, TcType) -> TcM (LHsCmd GhcTc)
tcCmd CmdEnv
env LHsCmd GhcRn
b1 (TcType, TcType)
res_ty
        ; LHsCmd GhcTc
b2'   <- CmdEnv -> LHsCmd GhcRn -> (TcType, TcType) -> TcM (LHsCmd GhcTc)
tcCmd CmdEnv
env LHsCmd GhcRn
b2 (TcType, TcType)
res_ty
        ; HsCmd GhcTc -> TcM (HsCmd GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (XCmdIf GhcTc
-> SyntaxExpr GhcTc
-> LHsExpr GhcTc
-> LHsCmd GhcTc
-> LHsCmd GhcTc
-> HsCmd GhcTc
forall id.
XCmdIf id
-> SyntaxExpr id
-> LHsExpr id
-> LHsCmd id
-> LHsCmd id
-> HsCmd id
HsCmdIf XCmdIf GhcRn
XCmdIf GhcTc
x SyntaxExpr GhcTc
SyntaxExprTc
fun' LHsExpr GhcTc
pred' LHsCmd GhcTc
b1' LHsCmd GhcTc
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)
  = MsgDoc -> TcM (HsCmd GhcTc) -> TcM (HsCmd GhcTc)
forall a. MsgDoc -> TcM a -> TcM a
addErrCtxt (HsCmd GhcRn -> MsgDoc
cmdCtxt HsCmd GhcRn
cmd)    (TcM (HsCmd GhcTc) -> TcM (HsCmd GhcTc))
-> TcM (HsCmd GhcTc) -> TcM (HsCmd GhcTc)
forall a b. (a -> b) -> a -> b
$
    do  { TcType
arg_ty <- TcM TcType
newOpenFlexiTyVarTy
        ; let fun_ty :: TcType
fun_ty = CmdEnv -> TcType -> TcType -> TcType
mkCmdArrTy CmdEnv
env TcType
arg_ty TcType
res_ty
        ; LHsExpr GhcTc
fun' <- TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
select_arrow_scope (LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcLExpr LHsExpr GhcRn
fun (TcType -> ExpRhoType
mkCheckExpType TcType
fun_ty))

        ; LHsExpr GhcTc
arg' <- LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcLExpr LHsExpr GhcRn
arg (TcType -> ExpRhoType
mkCheckExpType TcType
arg_ty)

        ; HsCmd GhcTc -> TcM (HsCmd GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (XCmdArrApp GhcTc
-> LHsExpr GhcTc
-> LHsExpr GhcTc
-> HsArrAppType
-> Bool
-> HsCmd GhcTc
forall id.
XCmdArrApp id
-> LHsExpr id -> LHsExpr id -> HsArrAppType -> Bool -> HsCmd id
HsCmdArrApp TcType
XCmdArrApp GhcTc
fun_ty LHsExpr GhcTc
fun' LHsExpr GhcTc
arg' HsArrAppType
ho_app Bool
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 :: TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
select_arrow_scope TcM (LHsExpr GhcTc)
tc = case HsArrAppType
ho_app of
        HsArrAppType
HsHigherOrderApp -> TcM (LHsExpr GhcTc)
tc
        HsArrAppType
HsFirstOrderApp  -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. TcM a -> TcM a
escapeArrowScope TcM (LHsExpr 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)
  = MsgDoc -> TcM (HsCmd GhcTc) -> TcM (HsCmd GhcTc)
forall a. MsgDoc -> TcM a -> TcM a
addErrCtxt (HsCmd GhcRn -> MsgDoc
cmdCtxt HsCmd GhcRn
cmd)    (TcM (HsCmd GhcTc) -> TcM (HsCmd GhcTc))
-> TcM (HsCmd GhcTc) -> TcM (HsCmd GhcTc)
forall a b. (a -> b) -> a -> b
$
    do  { TcType
arg_ty <- TcM TcType
newOpenFlexiTyVarTy
        ; LHsCmd GhcTc
fun'   <- CmdEnv -> LHsCmd GhcRn -> (TcType, TcType) -> TcM (LHsCmd GhcTc)
tcCmd CmdEnv
env LHsCmd GhcRn
fun (TcType -> TcType -> TcType
mkPairTy TcType
arg_ty TcType
cmd_stk, TcType
res_ty)
        ; LHsExpr GhcTc
arg'   <- LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcLExpr LHsExpr GhcRn
arg (TcType -> ExpRhoType
mkCheckExpType TcType
arg_ty)
        ; HsCmd GhcTc -> TcM (HsCmd GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (XCmdApp GhcTc -> LHsCmd GhcTc -> LHsExpr GhcTc -> HsCmd GhcTc
forall id. XCmdApp id -> LHsCmd id -> LHsExpr id -> HsCmd id
HsCmdApp XCmdApp GhcRn
XCmdApp GhcTc
x LHsCmd GhcTc
fun' LHsExpr GhcTc
arg') }

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

tc_cmd CmdEnv
env
       (HsCmdLam XCmdLam GhcRn
x (MG { mg_alts :: forall p body. MatchGroup p body -> Located [LMatch p body]
mg_alts = L SrcSpan
l [L SrcSpan
mtch_loc
                                   (match :: Match GhcRn (LHsCmd GhcRn)
match@(Match { m_pats :: forall p body. Match p body -> [LPat p]
m_pats = [LPat GhcRn]
pats, m_grhss :: forall p body. Match p body -> GRHSs p body
m_grhss = GRHSs GhcRn (LHsCmd GhcRn)
grhss }))],
                         mg_origin :: forall p body. MatchGroup p body -> Origin
mg_origin = Origin
origin }))
       (TcType
cmd_stk, TcType
res_ty)
  = MsgDoc -> TcM (HsCmd GhcTc) -> TcM (HsCmd GhcTc)
forall a. MsgDoc -> TcM a -> TcM a
addErrCtxt (Match GhcRn (LHsCmd GhcRn) -> MsgDoc
forall (idR :: Pass) body.
(OutputableBndrId idR, Outputable body) =>
Match (GhcPass idR) body -> MsgDoc
External instance of the constraint type forall l e.
(Outputable l, Outputable e) =>
Outputable (GenLocated l e)
External instance of the constraint type Outputable SrcSpan
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsCmd (GhcPass p))
External instance of the constraint type OutputableBndr Name
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
External instance of the constraint type OutputableBndr Name
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
pprMatchInCtxt Match GhcRn (LHsCmd GhcRn)
match)        (TcM (HsCmd GhcTc) -> TcM (HsCmd GhcTc))
-> TcM (HsCmd GhcTc) -> TcM (HsCmd GhcTc)
forall a b. (a -> b) -> a -> b
$
    do  { (TcCoercion
co, [TcType]
arg_tys, TcType
cmd_stk') <- Arity -> TcType -> TcM (TcCoercion, [TcType], TcType)
matchExpectedCmdArgs Arity
n_pats TcType
cmd_stk

                -- Check the patterns, and the GRHSs inside
        ; ([Located (Pat GhcTc)]
pats', GRHSs GhcTc (LHsCmd GhcTc)
grhss') <- SrcSpan
-> TcRn ([Located (Pat GhcTc)], GRHSs GhcTc (LHsCmd GhcTc))
-> TcRn ([Located (Pat GhcTc)], GRHSs GhcTc (LHsCmd GhcTc))
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
mtch_loc                                 (TcRn ([Located (Pat GhcTc)], GRHSs GhcTc (LHsCmd GhcTc))
 -> TcRn ([Located (Pat GhcTc)], GRHSs GhcTc (LHsCmd GhcTc)))
-> TcRn ([Located (Pat GhcTc)], GRHSs GhcTc (LHsCmd GhcTc))
-> TcRn ([Located (Pat GhcTc)], GRHSs GhcTc (LHsCmd GhcTc))
forall a b. (a -> b) -> a -> b
$
                             HsMatchContext GhcRn
-> [LPat GhcRn]
-> [ExpRhoType]
-> TcM (GRHSs GhcTc (LHsCmd GhcTc))
-> TcM ([LPat GhcTc], GRHSs GhcTc (LHsCmd GhcTc))
forall a.
HsMatchContext GhcRn
-> [LPat GhcRn] -> [ExpRhoType] -> TcM a -> TcM ([LPat GhcTc], a)
tcPats HsMatchContext GhcRn
forall p. HsMatchContext p
LambdaExpr [LPat GhcRn]
pats ((TcType -> ExpRhoType) -> [TcType] -> [ExpRhoType]
forall a b. (a -> b) -> [a] -> [b]
map TcType -> ExpRhoType
mkCheckExpType [TcType]
arg_tys) (TcM (GRHSs GhcTc (LHsCmd GhcTc))
 -> TcM ([LPat GhcTc], GRHSs GhcTc (LHsCmd GhcTc)))
-> TcM (GRHSs GhcTc (LHsCmd GhcTc))
-> TcM ([LPat GhcTc], GRHSs GhcTc (LHsCmd GhcTc))
forall a b. (a -> b) -> a -> b
$
                             GRHSs GhcRn (LHsCmd GhcRn)
-> TcType -> ExpRhoType -> TcM (GRHSs GhcTc (LHsCmd GhcTc))
tc_grhss GRHSs GhcRn (LHsCmd GhcRn)
grhss TcType
cmd_stk' (TcType -> ExpRhoType
mkCheckExpType TcType
res_ty)

        ; let match' :: GenLocated SrcSpan (Match GhcTc (LHsCmd GhcTc))
match' = SrcSpan
-> Match GhcTc (LHsCmd GhcTc)
-> GenLocated SrcSpan (Match GhcTc (LHsCmd GhcTc))
forall l e. l -> e -> GenLocated l e
L SrcSpan
mtch_loc (Match :: forall p body.
XCMatch p body
-> HsMatchContext (NoGhcTc p)
-> [LPat p]
-> GRHSs p body
-> Match p body
Match { m_ext :: XCMatch GhcTc (LHsCmd GhcTc)
m_ext = XCMatch GhcTc (LHsCmd GhcTc)
NoExtField
noExtField
                                         , m_ctxt :: HsMatchContext (NoGhcTc GhcTc)
m_ctxt = HsMatchContext (NoGhcTc GhcTc)
forall p. HsMatchContext p
LambdaExpr, m_pats :: [LPat GhcTc]
m_pats = [Located (Pat GhcTc)]
[LPat GhcTc]
pats'
                                         , m_grhss :: GRHSs GhcTc (LHsCmd GhcTc)
m_grhss = GRHSs GhcTc (LHsCmd GhcTc)
grhss' })
              arg_tys :: [TcType]
arg_tys = (Located (Pat GhcTc) -> TcType)
-> [Located (Pat GhcTc)] -> [TcType]
forall a b. (a -> b) -> [a] -> [b]
map Located (Pat GhcTc) -> TcType
LPat GhcTc -> TcType
hsLPatType [Located (Pat GhcTc)]
pats'
              cmd' :: HsCmd GhcTc
cmd' = XCmdLam GhcTc -> MatchGroup GhcTc (LHsCmd GhcTc) -> HsCmd GhcTc
forall id. XCmdLam id -> MatchGroup id (LHsCmd id) -> HsCmd id
HsCmdLam XCmdLam GhcRn
XCmdLam GhcTc
x (MG :: forall p body.
XMG p body
-> Located [LMatch p body] -> Origin -> MatchGroup p body
MG { mg_alts :: Located [GenLocated SrcSpan (Match GhcTc (LHsCmd GhcTc))]
mg_alts = SrcSpan
-> [GenLocated SrcSpan (Match GhcTc (LHsCmd GhcTc))]
-> Located [GenLocated SrcSpan (Match GhcTc (LHsCmd GhcTc))]
forall l e. l -> e -> GenLocated l e
L SrcSpan
l [GenLocated SrcSpan (Match GhcTc (LHsCmd GhcTc))
match']
                                    , mg_ext :: XMG GhcTc (LHsCmd GhcTc)
mg_ext = [TcType] -> TcType -> MatchGroupTc
MatchGroupTc [TcType]
arg_tys TcType
res_ty
                                    , mg_origin :: Origin
mg_origin = Origin
origin })
        ; HsCmd GhcTc -> TcM (HsCmd GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (HsWrapper -> HsCmd GhcTc -> HsCmd GhcTc
mkHsCmdWrap (TcCoercion -> HsWrapper
mkWpCastN TcCoercion
co) HsCmd GhcTc
cmd') }
  where
    n_pats :: Arity
n_pats     = [Located (Pat GhcRn)] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
External instance of the constraint type Foldable []
length [Located (Pat GhcRn)]
[LPat GhcRn]
pats
    match_ctxt :: HsMatchContext GhcRn
match_ctxt = (HsMatchContext GhcRn
forall p. HsMatchContext p
LambdaExpr :: HsMatchContext GhcRn)    -- Maybe KappaExpr?
    pg_ctxt :: HsStmtContext GhcRn
pg_ctxt    = HsMatchContext GhcRn -> HsStmtContext GhcRn
forall p. HsMatchContext p -> HsStmtContext p
PatGuard HsMatchContext GhcRn
match_ctxt

    tc_grhss :: GRHSs GhcRn (LHsCmd GhcRn)
-> TcType -> ExpRhoType -> TcM (GRHSs GhcTc (LHsCmd GhcTc))
tc_grhss (GRHSs XCGRHSs GhcRn (LHsCmd GhcRn)
x [LGRHS GhcRn (LHsCmd GhcRn)]
grhss (L SrcSpan
l HsLocalBinds GhcRn
binds)) TcType
stk_ty ExpRhoType
res_ty
        = do { (HsLocalBinds GhcTc
binds', [Located (GRHS GhcTc (LHsCmd GhcTc))]
grhss') <- HsLocalBinds GhcRn
-> TcM [Located (GRHS GhcTc (LHsCmd GhcTc))]
-> TcM (HsLocalBinds GhcTc, [Located (GRHS GhcTc (LHsCmd GhcTc))])
forall thing.
HsLocalBinds GhcRn -> TcM thing -> TcM (HsLocalBinds GhcTc, thing)
tcLocalBinds HsLocalBinds GhcRn
binds (TcM [Located (GRHS GhcTc (LHsCmd GhcTc))]
 -> TcM (HsLocalBinds GhcTc, [Located (GRHS GhcTc (LHsCmd GhcTc))]))
-> TcM [Located (GRHS GhcTc (LHsCmd GhcTc))]
-> TcM (HsLocalBinds GhcTc, [Located (GRHS GhcTc (LHsCmd GhcTc))])
forall a b. (a -> b) -> a -> b
$
                                   (LGRHS GhcRn (LHsCmd GhcRn)
 -> IOEnv
      (Env TcGblEnv TcLclEnv) (Located (GRHS GhcTc (LHsCmd GhcTc))))
-> [LGRHS GhcRn (LHsCmd GhcRn)]
-> TcM [Located (GRHS GhcTc (LHsCmd GhcTc))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Traversable []
mapM ((GRHS GhcRn (LHsCmd GhcRn) -> TcM (GRHS GhcTc (LHsCmd GhcTc)))
-> LGRHS GhcRn (LHsCmd GhcRn)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (Located (GRHS GhcTc (LHsCmd GhcTc)))
forall a b. (a -> TcM b) -> Located a -> TcM (Located b)
wrapLocM (TcType
-> ExpRhoType
-> GRHS GhcRn (LHsCmd GhcRn)
-> TcM (GRHS GhcTc (LHsCmd GhcTc))
tc_grhs TcType
stk_ty ExpRhoType
res_ty)) [LGRHS GhcRn (LHsCmd GhcRn)]
grhss
             ; GRHSs GhcTc (LHsCmd GhcTc) -> TcM (GRHSs GhcTc (LHsCmd GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (XCGRHSs GhcTc (LHsCmd GhcTc)
-> [Located (GRHS GhcTc (LHsCmd GhcTc))]
-> LHsLocalBinds GhcTc
-> GRHSs GhcTc (LHsCmd GhcTc)
forall p body.
XCGRHSs p body -> [LGRHS p body] -> LHsLocalBinds p -> GRHSs p body
GRHSs XCGRHSs GhcRn (LHsCmd GhcRn)
XCGRHSs GhcTc (LHsCmd GhcTc)
x [Located (GRHS GhcTc (LHsCmd GhcTc))]
grhss' (SrcSpan -> HsLocalBinds GhcTc -> LHsLocalBinds GhcTc
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsLocalBinds GhcTc
binds')) }

    tc_grhs :: TcType
-> ExpRhoType
-> GRHS GhcRn (LHsCmd GhcRn)
-> TcM (GRHS GhcTc (LHsCmd GhcTc))
tc_grhs TcType
stk_ty ExpRhoType
res_ty (GRHS XCGRHS GhcRn (LHsCmd GhcRn)
x [GuardLStmt GhcRn]
guards LHsCmd GhcRn
body)
        = do { ([LStmt GhcTc (LHsExpr GhcTc)]
guards', LHsCmd GhcTc
rhs') <- HsStmtContext GhcRn
-> TcStmtChecker HsExpr ExpRhoType
-> [GuardLStmt GhcRn]
-> ExpRhoType
-> (ExpRhoType -> TcM (LHsCmd GhcTc))
-> TcM ([LStmt GhcTc (LHsExpr GhcTc)], LHsCmd GhcTc)
forall (body :: * -> *) rho_type thing.
Outputable (body GhcRn) =>
HsStmtContext GhcRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (Located (body GhcTc))], thing)
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsExpr (GhcPass p))
External instance of the constraint type OutputableBndr Name
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
tcStmtsAndThen HsStmtContext GhcRn
pg_ctxt TcStmtChecker HsExpr ExpRhoType
tcGuardStmt [GuardLStmt GhcRn]
guards ExpRhoType
res_ty ((ExpRhoType -> TcM (LHsCmd GhcTc))
 -> TcM ([LStmt GhcTc (LHsExpr GhcTc)], LHsCmd GhcTc))
-> (ExpRhoType -> TcM (LHsCmd GhcTc))
-> TcM ([LStmt GhcTc (LHsExpr GhcTc)], LHsCmd GhcTc)
forall a b. (a -> b) -> a -> b
$
                                  \ ExpRhoType
res_ty -> CmdEnv -> LHsCmd GhcRn -> (TcType, TcType) -> TcM (LHsCmd GhcTc)
tcCmd CmdEnv
env LHsCmd GhcRn
body
                                                (TcType
stk_ty, String -> ExpRhoType -> TcType
checkingExpType String
"tc_grhs" ExpRhoType
res_ty)
             ; GRHS GhcTc (LHsCmd GhcTc) -> TcM (GRHS GhcTc (LHsCmd GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (XCGRHS GhcTc (LHsCmd GhcTc)
-> [LStmt GhcTc (LHsExpr GhcTc)]
-> LHsCmd GhcTc
-> GRHS GhcTc (LHsCmd GhcTc)
forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS XCGRHS GhcRn (LHsCmd GhcRn)
XCGRHS GhcTc (LHsCmd GhcTc)
x [LStmt GhcTc (LHsExpr GhcTc)]
guards' LHsCmd GhcTc
rhs') }

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

tc_cmd CmdEnv
env (HsCmdDo XCmdDo GhcRn
_ (L SrcSpan
l [CmdLStmt GhcRn]
stmts) ) (TcType
cmd_stk, TcType
res_ty)
  = do  { TcCoercion
co <- Maybe (HsExpr GhcRn) -> TcType -> TcType -> TcM TcCoercion
unifyType Maybe (HsExpr GhcRn)
forall a. Maybe a
Nothing TcType
unitTy TcType
cmd_stk  -- Expecting empty argument stack
        ; [LStmt GhcTc (LHsCmd GhcTc)]
stmts' <- HsStmtContext GhcRn
-> TcStmtChecker HsCmd TcType
-> [CmdLStmt GhcRn]
-> TcType
-> TcM [LStmt GhcTc (LHsCmd GhcTc)]
forall (body :: * -> *) rho_type.
Outputable (body GhcRn) =>
HsStmtContext GhcRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> TcM [LStmt GhcTc (Located (body GhcTc))]
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsCmd (GhcPass p))
External instance of the constraint type OutputableBndr Name
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
tcStmts HsStmtContext GhcRn
forall p. HsStmtContext p
ArrowExpr (CmdEnv -> TcStmtChecker HsCmd TcType
tcArrDoStmt CmdEnv
env) [CmdLStmt GhcRn]
stmts TcType
res_ty
        ; HsCmd GhcTc -> TcM (HsCmd GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (HsWrapper -> HsCmd GhcTc -> HsCmd GhcTc
mkHsCmdWrap (TcCoercion -> HsWrapper
mkWpCastN TcCoercion
co) (XCmdDo GhcTc -> Located [LStmt GhcTc (LHsCmd GhcTc)] -> HsCmd GhcTc
forall id. XCmdDo id -> Located [CmdLStmt id] -> HsCmd id
HsCmdDo TcType
XCmdDo GhcTc
res_ty (SrcSpan
-> [LStmt GhcTc (LHsCmd GhcTc)]
-> Located [LStmt GhcTc (LHsCmd GhcTc)]
forall l e. l -> e -> GenLocated l e
L SrcSpan
l [LStmt GhcTc (LHsCmd GhcTc)]
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
x LHsExpr GhcRn
expr LexicalFixity
f Maybe Fixity
fixity [LHsCmdTop GhcRn]
cmd_args) (TcType
cmd_stk, TcType
res_ty)
  = MsgDoc -> TcM (HsCmd GhcTc) -> TcM (HsCmd GhcTc)
forall a. MsgDoc -> TcM a -> TcM a
addErrCtxt (HsCmd GhcRn -> MsgDoc
cmdCtxt HsCmd GhcRn
cmd)    (TcM (HsCmd GhcTc) -> TcM (HsCmd GhcTc))
-> TcM (HsCmd GhcTc) -> TcM (HsCmd GhcTc)
forall a b. (a -> b) -> a -> b
$
    do  { ([LHsCmdTop GhcTc]
cmd_args', [TcType]
cmd_tys) <- (LHsCmdTop GhcRn
 -> IOEnv (Env TcGblEnv TcLclEnv) (LHsCmdTop GhcTc, TcType))
-> [LHsCmdTop GhcRn]
-> IOEnv (Env TcGblEnv TcLclEnv) ([LHsCmdTop GhcTc], [TcType])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
External instance of the constraint type forall m. Applicative (IOEnv m)
mapAndUnzipM LHsCmdTop GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (LHsCmdTop GhcTc, TcType)
tc_cmd_arg [LHsCmdTop GhcRn]
cmd_args
                              -- We use alphaTyVar for 'w'
        ; let e_ty :: TcType
e_ty = TcTyVar -> TcType -> TcType
mkInfForAllTy TcTyVar
alphaTyVar (TcType -> TcType) -> TcType -> TcType
forall a b. (a -> b) -> a -> b
$
                     [TcType] -> TcType -> TcType
mkVisFunTys [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
        ; LHsExpr GhcTc
expr' <- LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckExpr LHsExpr GhcRn
expr TcType
e_ty
        ; HsCmd GhcTc -> TcM (HsCmd GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (XCmdArrForm GhcTc
-> LHsExpr GhcTc
-> LexicalFixity
-> Maybe Fixity
-> [LHsCmdTop GhcTc]
-> HsCmd GhcTc
forall id.
XCmdArrForm id
-> LHsExpr id
-> LexicalFixity
-> Maybe Fixity
-> [LHsCmdTop id]
-> HsCmd id
HsCmdArrForm XCmdArrForm GhcRn
XCmdArrForm GhcTc
x LHsExpr GhcTc
expr' LexicalFixity
f Maybe Fixity
fixity [LHsCmdTop GhcTc]
cmd_args') }

  where
    tc_cmd_arg :: LHsCmdTop GhcRn -> TcM (LHsCmdTop GhcTcId, TcType)
    tc_cmd_arg :: LHsCmdTop GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (LHsCmdTop GhcTc, TcType)
tc_cmd_arg LHsCmdTop GhcRn
cmd
       = do { TcType
arr_ty <- TcType -> TcM TcType
newFlexiTyVarTy TcType
arrowTyConKind
            ; TcType
stk_ty <- TcType -> TcM TcType
newFlexiTyVarTy TcType
liftedTypeKind
            ; TcType
res_ty <- TcType -> TcM TcType
newFlexiTyVarTy TcType
liftedTypeKind
            ; let env' :: CmdEnv
env' = CmdEnv
env { cmd_arr :: TcType
cmd_arr = TcType
arr_ty }
            ; LHsCmdTop GhcTc
cmd' <- CmdEnv
-> LHsCmdTop GhcRn -> (TcType, TcType) -> TcM (LHsCmdTop GhcTc)
tcCmdTop CmdEnv
env' LHsCmdTop GhcRn
cmd (TcType
stk_ty, TcType
res_ty)
            ; (LHsCmdTop GhcTc, TcType)
-> IOEnv (Env TcGblEnv TcLclEnv) (LHsCmdTop GhcTc, TcType)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (LHsCmdTop GhcTc
cmd',  CmdEnv -> TcType -> TcType -> TcType
mkCmdArrTy CmdEnv
env' (TcType -> TcType -> TcType
mkPairTy TcType
alphaTy TcType
stk_ty) TcType
res_ty) }

-----------------------------------------------------------------
--              Base case for illegal commands
-- This is where expressions that aren't commands get rejected

tc_cmd CmdEnv
_ HsCmd GhcRn
cmd (TcType, TcType)
_
  = MsgDoc -> TcM (HsCmd GhcTc)
forall a. MsgDoc -> TcM a
failWithTc ([MsgDoc] -> MsgDoc
vcat [String -> MsgDoc
text String
"The expression", Arity -> MsgDoc -> MsgDoc
nest Arity
2 (HsCmd GhcRn -> MsgDoc
forall a. Outputable a => a -> MsgDoc
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsCmd (GhcPass p))
External instance of the constraint type OutputableBndr Name
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
ppr HsCmd GhcRn
cmd),
                      String -> MsgDoc
text String
"was found where an arrow command was expected"])

-- | Typechecking for case command alternatives. Used for both
-- 'HsCmdCase' and 'HsCmdLamCase'.
tcCmdMatches :: CmdEnv
             -> TcType                           -- ^ type of the scrutinee
             -> MatchGroup GhcRn (LHsCmd GhcRn)  -- ^ case alternatives
             -> CmdType
             -> TcM (MatchGroup GhcTcId (LHsCmd GhcTcId))
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)
  = TcMatchCtxt HsCmd
-> TcType
-> MatchGroup GhcRn (LHsCmd GhcRn)
-> ExpRhoType
-> TcM (MatchGroup GhcTc (LHsCmd GhcTc))
forall (body :: * -> *).
Outputable (body GhcRn) =>
TcMatchCtxt body
-> TcType
-> MatchGroup GhcRn (Located (body GhcRn))
-> ExpRhoType
-> TcM (MatchGroup GhcTc (Located (body GhcTc)))
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsCmd (GhcPass p))
External instance of the constraint type OutputableBndr Name
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
tcMatchesCase TcMatchCtxt HsCmd
match_ctxt TcType
scrut_ty MatchGroup GhcRn (LHsCmd GhcRn)
matches (TcType -> ExpRhoType
mkCheckExpType TcType
res_ty)
  where
    match_ctxt :: TcMatchCtxt HsCmd
match_ctxt = MC :: forall (body :: * -> *).
HsMatchContext GhcRn
-> (Located (body GhcRn)
    -> ExpRhoType -> TcM (Located (body GhcTc)))
-> TcMatchCtxt body
MC { mc_what :: HsMatchContext GhcRn
mc_what = HsMatchContext GhcRn
forall p. HsMatchContext p
CaseAlt,
                      mc_body :: LHsCmd GhcRn -> ExpRhoType -> TcM (LHsCmd GhcTc)
mc_body = LHsCmd GhcRn -> ExpRhoType -> TcM (LHsCmd GhcTc)
mc_body }
    mc_body :: LHsCmd GhcRn -> ExpRhoType -> TcM (LHsCmd GhcTc)
mc_body LHsCmd GhcRn
body ExpRhoType
res_ty' = do { TcType
res_ty' <- ExpRhoType -> TcM TcType
expTypeToType ExpRhoType
res_ty'
                              ; CmdEnv -> LHsCmd GhcRn -> (TcType, TcType) -> TcM (LHsCmd GhcTc)
tcCmd CmdEnv
env LHsCmd GhcRn
body (TcType
stk, TcType
res_ty') }

matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercionN, [TcType], TcType)
matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercion, [TcType], TcType)
matchExpectedCmdArgs Arity
0 TcType
ty
  = (TcCoercion, [TcType], TcType)
-> TcM (TcCoercion, [TcType], TcType)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (TcType -> TcCoercion
mkTcNomReflCo TcType
ty, [], TcType
ty)
matchExpectedCmdArgs Arity
n TcType
ty
  = do { (TcCoercion
co1, [TcType
ty1, TcType
ty2]) <- TyCon -> TcType -> TcM (TcCoercion, [TcType])
matchExpectedTyConApp TyCon
pairTyCon TcType
ty
       ; (TcCoercion
co2, [TcType]
tys, TcType
res_ty) <- Arity -> TcType -> TcM (TcCoercion, [TcType], TcType)
matchExpectedCmdArgs (Arity
nArity -> Arity -> Arity
forall a. Num a => a -> a -> a
External instance of the constraint type Num Arity
-Arity
1) TcType
ty2
       ; (TcCoercion, [TcType], TcType)
-> TcM (TcCoercion, [TcType], TcType)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (Role -> TyCon -> [TcCoercion] -> TcCoercion
mkTcTyConAppCo Role
Nominal TyCon
pairTyCon [TcCoercion
co1, TcCoercion
co2], TcType
ty1TcType -> [TcType] -> [TcType]
forall a. a -> [a] -> [a]
:[TcType]
tys, TcType
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 HsStmtContext GhcRn
_ (LastStmt XLastStmt GhcRn GhcRn (LHsCmd GhcRn)
x LHsCmd GhcRn
rhs Maybe Bool
noret SyntaxExpr GhcRn
_) TcType
res_ty TcType -> TcM thing
thing_inside
  = do  { LHsCmd GhcTc
rhs' <- CmdEnv -> LHsCmd GhcRn -> (TcType, TcType) -> TcM (LHsCmd GhcTc)
tcCmd CmdEnv
env LHsCmd GhcRn
rhs (TcType
unitTy, TcType
res_ty)
        ; thing
thing <- TcType -> TcM thing
thing_inside (String -> TcType
forall a. String -> a
panic String
"tcArrDoStmt")
        ; (Stmt GhcTc (LHsCmd GhcTc), thing)
-> TcM (Stmt GhcTc (LHsCmd GhcTc), thing)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (XLastStmt GhcTc GhcTc (LHsCmd GhcTc)
-> LHsCmd GhcTc
-> Maybe Bool
-> SyntaxExpr GhcTc
-> Stmt GhcTc (LHsCmd GhcTc)
forall idL idR body.
XLastStmt idL idR body
-> body -> Maybe Bool -> SyntaxExpr idR -> StmtLR idL idR body
LastStmt XLastStmt GhcRn GhcRn (LHsCmd GhcRn)
XLastStmt GhcTc GhcTc (LHsCmd GhcTc)
x LHsCmd GhcTc
rhs' Maybe Bool
noret SyntaxExpr GhcTc
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
External instance of the constraint type IsPass 'Typechecked
noSyntaxExpr, thing
thing) }

tcArrDoStmt CmdEnv
env HsStmtContext GhcRn
_ (BodyStmt XBodyStmt GhcRn GhcRn (LHsCmd GhcRn)
_ LHsCmd GhcRn
rhs SyntaxExpr GhcRn
_ SyntaxExpr GhcRn
_) TcType
res_ty TcType -> TcM thing
thing_inside
  = do  { (LHsCmd GhcTc
rhs', TcType
elt_ty) <- CmdEnv -> LHsCmd GhcRn -> TcM (LHsCmd GhcTc, TcType)
tc_arr_rhs CmdEnv
env LHsCmd GhcRn
rhs
        ; thing
thing          <- TcType -> TcM thing
thing_inside TcType
res_ty
        ; (Stmt GhcTc (LHsCmd GhcTc), thing)
-> TcM (Stmt GhcTc (LHsCmd GhcTc), thing)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (XBodyStmt GhcTc GhcTc (LHsCmd GhcTc)
-> LHsCmd GhcTc
-> SyntaxExpr GhcTc
-> SyntaxExpr GhcTc
-> Stmt GhcTc (LHsCmd GhcTc)
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt TcType
XBodyStmt GhcTc GhcTc (LHsCmd GhcTc)
elt_ty LHsCmd GhcTc
rhs' SyntaxExpr GhcTc
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
External instance of the constraint type IsPass 'Typechecked
noSyntaxExpr SyntaxExpr GhcTc
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
External instance of the constraint type IsPass 'Typechecked
noSyntaxExpr, thing
thing) }

tcArrDoStmt CmdEnv
env HsStmtContext GhcRn
ctxt (BindStmt XBindStmt GhcRn GhcRn (LHsCmd GhcRn)
_ LPat GhcRn
pat LHsCmd GhcRn
rhs) TcType
res_ty TcType -> TcM thing
thing_inside
  = do  { (LHsCmd GhcTc
rhs', TcType
pat_ty) <- CmdEnv -> LHsCmd GhcRn -> TcM (LHsCmd GhcTc, TcType)
tc_arr_rhs CmdEnv
env LHsCmd GhcRn
rhs
        ; (Located (Pat GhcTc)
pat', thing
thing)  <- HsMatchContext GhcRn
-> LPat GhcRn -> TcType -> TcM thing -> TcM (LPat GhcTc, thing)
forall a.
HsMatchContext GhcRn
-> LPat GhcRn -> TcType -> TcM a -> TcM (LPat GhcTc, a)
tcCheckPat (HsStmtContext GhcRn -> HsMatchContext GhcRn
forall p. HsStmtContext p -> HsMatchContext p
StmtCtxt HsStmtContext GhcRn
ctxt) LPat GhcRn
pat TcType
pat_ty (TcM thing -> TcM (LPat GhcTc, thing))
-> TcM thing -> TcM (LPat GhcTc, thing)
forall a b. (a -> b) -> a -> b
$
                            TcType -> TcM thing
thing_inside TcType
res_ty
        ; (Stmt GhcTc (LHsCmd GhcTc), thing)
-> TcM (Stmt GhcTc (LHsCmd GhcTc), thing)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (LPat GhcTc -> LHsCmd GhcTc -> Stmt GhcTc (LHsCmd GhcTc)
forall (bodyR :: * -> *).
LPat GhcTc
-> Located (bodyR GhcTc)
-> StmtLR GhcTc GhcTc (Located (bodyR GhcTc))
mkTcBindStmt Located (Pat GhcTc)
LPat GhcTc
pat' LHsCmd GhcTc
rhs', thing
thing) }

tcArrDoStmt CmdEnv
env HsStmtContext GhcRn
ctxt (RecStmt { recS_stmts :: forall idL idR body. StmtLR idL idR body -> [LStmtLR idL idR body]
recS_stmts = [CmdLStmt 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 :: [Name]
tup_names = [Name]
[IdP GhcRn]
rec_names [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filterOut (Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
External instance of the constraint type Eq Name
External instance of the constraint type Foldable []
`elem` [Name]
[IdP GhcRn]
rec_names) [Name]
[IdP GhcRn]
later_names
        ; [TcType]
tup_elt_tys <- Arity -> TcType -> TcM [TcType]
newFlexiTyVarTys ([Name] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
External instance of the constraint type Foldable []
length [Name]
tup_names) TcType
liftedTypeKind
        ; let tup_ids :: [TcTyVar]
tup_ids = (Name -> TcType -> TcTyVar) -> [Name] -> [TcType] -> [TcTyVar]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith HasDebugCallStack => Name -> TcType -> TcTyVar
Name -> TcType -> TcTyVar
External instance of the constraint type HasDebugCallStack
mkLocalId [Name]
tup_names [TcType]
tup_elt_tys
        ; [TcTyVar]
-> TcM (Stmt GhcTc (LHsCmd GhcTc), thing)
-> TcM (Stmt GhcTc (LHsCmd GhcTc), thing)
forall a. [TcTyVar] -> TcM a -> TcM a
tcExtendIdEnv [TcTyVar]
tup_ids (TcM (Stmt GhcTc (LHsCmd GhcTc), thing)
 -> TcM (Stmt GhcTc (LHsCmd GhcTc), thing))
-> TcM (Stmt GhcTc (LHsCmd GhcTc), thing)
-> TcM (Stmt GhcTc (LHsCmd GhcTc), thing)
forall a b. (a -> b) -> a -> b
$ do
        { ([LStmt GhcTc (LHsCmd GhcTc)]
stmts', [HsExpr GhcTc]
tup_rets)
                <- HsStmtContext GhcRn
-> TcStmtChecker HsCmd TcType
-> [CmdLStmt GhcRn]
-> TcType
-> (TcType -> TcM [HsExpr GhcTc])
-> TcM ([LStmt GhcTc (LHsCmd GhcTc)], [HsExpr GhcTc])
forall (body :: * -> *) rho_type thing.
Outputable (body GhcRn) =>
HsStmtContext GhcRn
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (Located (body GhcTc))], thing)
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsCmd (GhcPass p))
External instance of the constraint type OutputableBndr Name
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
tcStmtsAndThen HsStmtContext GhcRn
ctxt (CmdEnv -> TcStmtChecker HsCmd TcType
tcArrDoStmt CmdEnv
env) [CmdLStmt GhcRn]
stmts TcType
res_ty   ((TcType -> TcM [HsExpr GhcTc])
 -> TcM ([LStmt GhcTc (LHsCmd GhcTc)], [HsExpr GhcTc]))
-> (TcType -> TcM [HsExpr GhcTc])
-> TcM ([LStmt GhcTc (LHsCmd GhcTc)], [HsExpr GhcTc])
forall a b. (a -> b) -> a -> b
$ \ 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]
External instance of the constraint type forall m. Applicative (IOEnv m)
zipWithM Name -> ExpRhoType -> IOEnv (Env TcGblEnv TcLclEnv) (HsExpr GhcTc)
tcCheckId [Name]
tup_names ((TcType -> ExpRhoType) -> [TcType] -> [ExpRhoType]
forall a b. (a -> b) -> [a] -> [b]
map TcType -> ExpRhoType
mkCheckExpType [TcType]
tup_elt_tys)

        ; thing
thing <- TcType -> TcM thing
thing_inside TcType
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 [RecStmt] in GHC.Hs.Expr)

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

        ; let rec_rets :: [HsExpr GhcTc]
rec_rets = [Name] -> [HsExpr GhcTc] -> [HsExpr GhcTc]
forall b a. [b] -> [a] -> [a]
takeList [Name]
[IdP GhcRn]
rec_names [HsExpr GhcTc]
tup_rets
        ; let ret_table :: [(TcTyVar, HsExpr GhcTc)]
ret_table = [TcTyVar] -> [HsExpr GhcTc] -> [(TcTyVar, HsExpr GhcTc)]
forall a b. [a] -> [b] -> [(a, b)]
zip [TcTyVar]
tup_ids [HsExpr GhcTc]
tup_rets
        ; let later_rets :: [HsExpr GhcTc]
later_rets = [HsExpr GhcTc
r | TcTyVar
i <- [TcTyVar]
later_ids, (TcTyVar
j, HsExpr GhcTc
r) <- [(TcTyVar, HsExpr GhcTc)]
ret_table, TcTyVar
i TcTyVar -> TcTyVar -> Bool
forall a. Eq a => a -> a -> Bool
External instance of the constraint type Eq TcTyVar
== TcTyVar
j]

        ; (Stmt GhcTc (LHsCmd GhcTc), thing)
-> TcM (Stmt GhcTc (LHsCmd GhcTc), thing)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (StmtLR GhcTc GhcTc Any
forall bodyR. StmtLR GhcTc GhcTc bodyR
emptyRecStmtId { recS_stmts :: [LStmt GhcTc (LHsCmd GhcTc)]
recS_stmts = [LStmt GhcTc (LHsCmd GhcTc)]
stmts'
                                 , recS_later_ids :: [IdP GhcTc]
recS_later_ids = [TcTyVar]
[IdP GhcTc]
later_ids
                                 , recS_rec_ids :: [IdP GhcTc]
recS_rec_ids = [TcTyVar]
[IdP GhcTc]
rec_ids
                                 , recS_ext :: XRecStmt GhcTc GhcTc (LHsCmd GhcTc)
recS_ext = RecStmtTc
unitRecStmtTc
                                     { recS_later_rets :: [HsExpr GhcTc]
recS_later_rets = [HsExpr GhcTc]
later_rets
                                     , recS_rec_rets :: [HsExpr GhcTc]
recS_rec_rets = [HsExpr GhcTc]
rec_rets
                                     , recS_ret_ty :: TcType
recS_ret_ty = TcType
res_ty} }, thing
thing)
        }}

tcArrDoStmt CmdEnv
_ HsStmtContext GhcRn
_ Stmt GhcRn (LHsCmd GhcRn)
stmt TcType
_ TcType -> TcM thing
_
  = String -> MsgDoc -> TcM (Stmt GhcTc (LHsCmd GhcTc), thing)
forall a. HasCallStack => String -> MsgDoc -> a
pprPanic String
"tcArrDoStmt: unexpected Stmt" (Stmt GhcRn (LHsCmd GhcRn) -> MsgDoc
forall a. Outputable a => a -> MsgDoc
External instance of the constraint type forall (pl :: Pass) (pr :: Pass) body.
(OutputableBndrId pl, OutputableBndrId pr, Outputable body) =>
Outputable (StmtLR (GhcPass pl) (GhcPass pr) body)
External instance of the constraint type OutputableBndr Name
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
External instance of the constraint type OutputableBndr Name
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
External instance of the constraint type forall l e.
(Outputable l, Outputable e) =>
Outputable (GenLocated l e)
External instance of the constraint type Outputable SrcSpan
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsCmd (GhcPass p))
External instance of the constraint type OutputableBndr Name
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
ppr Stmt GhcRn (LHsCmd GhcRn)
stmt)

tc_arr_rhs :: CmdEnv -> LHsCmd GhcRn -> TcM (LHsCmd GhcTcId, TcType)
tc_arr_rhs :: CmdEnv -> LHsCmd GhcRn -> TcM (LHsCmd GhcTc, TcType)
tc_arr_rhs CmdEnv
env LHsCmd GhcRn
rhs = do { TcType
ty <- TcType -> TcM TcType
newFlexiTyVarTy TcType
liftedTypeKind
                        ; LHsCmd GhcTc
rhs' <- CmdEnv -> LHsCmd GhcRn -> (TcType, TcType) -> TcM (LHsCmd GhcTc)
tcCmd CmdEnv
env LHsCmd GhcRn
rhs (TcType
unitTy, TcType
ty)
                        ; (LHsCmd GhcTc, TcType) -> TcM (LHsCmd GhcTc, TcType)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (LHsCmd GhcTc
rhs', TcType
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
mkVisFunTys [TcType
liftedTypeKind, TcType
liftedTypeKind] TcType
liftedTypeKind

{-
************************************************************************
*                                                                      *
                Errors
*                                                                      *
************************************************************************
-}

cmdCtxt :: HsCmd GhcRn -> SDoc
cmdCtxt :: HsCmd GhcRn -> MsgDoc
cmdCtxt HsCmd GhcRn
cmd = String -> MsgDoc
text String
"In the command:" MsgDoc -> MsgDoc -> MsgDoc
<+> HsCmd GhcRn -> MsgDoc
forall a. Outputable a => a -> MsgDoc
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsCmd (GhcPass p))
External instance of the constraint type OutputableBndr Name
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
ppr HsCmd GhcRn
cmd