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

Typecheck arrow notation
-}

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

module TcArrows ( tcProc ) where

import GhcPrelude

import {-# SOURCE #-}   TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId, tcPolyExpr )

import HsSyn
import TcMatches
import TcHsSyn( hsLPatType )
import TcType
import TcMType
import TcBinds
import TcPat
import TcUnify
import TcRnMonad
import TcEnv
import TcEvidence
import Id( mkLocalId )
import Inst
import Name
import TysWiredIn
import VarSet
import TysPrim
import BasicTypes( Arity )
import SrcLoc
import Outputable
import Util

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 :: InPat GhcRn -> LHsCmdTop GhcRn        -- proc pat -> expr
       -> ExpRhoType                            -- Expected type of whole proc expression
       -> TcM (OutPat GhcTcId, LHsCmdTop GhcTcId, TcCoercion)

tcProc :: InPat GhcRn
-> LHsCmdTop GhcRn
-> ExpRhoType
-> TcM (OutPat GhcTcId, LHsCmdTop GhcTcId, TcCoercion)
tcProc pat :: InPat GhcRn
pat cmd :: LHsCmdTop GhcRn
cmd exp_ty :: ExpRhoType
exp_ty
  = TcM (OutPat GhcTcId, LHsCmdTop GhcTcId, TcCoercion)
-> TcM (OutPat GhcTcId, LHsCmdTop GhcTcId, TcCoercion)
forall a. TcM a -> TcM a
newArrowScope (TcM (OutPat GhcTcId, LHsCmdTop GhcTcId, TcCoercion)
 -> TcM (OutPat GhcTcId, LHsCmdTop GhcTcId, TcCoercion))
-> TcM (OutPat GhcTcId, LHsCmdTop GhcTcId, TcCoercion)
-> TcM (OutPat GhcTcId, LHsCmdTop GhcTcId, 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
        ; (co :: TcCoercion
co, (exp_ty1 :: TcType
exp_ty1, res_ty :: TcType
res_ty)) <- TcType -> TcM (TcCoercion, (TcType, TcType))
matchExpectedAppTy TcType
exp_ty
        ; (co1 :: TcCoercion
co1, (arr_ty :: TcType
arr_ty, arg_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 }
        ; (pat' :: OutPat GhcTcId
pat', cmd' :: LHsCmdTop GhcTcId
cmd') <- HsMatchContext Name
-> InPat GhcRn
-> ExpRhoType
-> TcM (LHsCmdTop GhcTcId)
-> TcM (OutPat GhcTcId, LHsCmdTop GhcTcId)
forall a.
HsMatchContext Name
-> InPat GhcRn -> ExpRhoType -> TcM a -> TcM (OutPat GhcTcId, a)
tcPat HsMatchContext Name
forall id. HsMatchContext id
ProcExpr InPat GhcRn
pat (TcType -> ExpRhoType
mkCheckExpType TcType
arg_ty) (TcM (LHsCmdTop GhcTcId)
 -> TcM (OutPat GhcTcId, LHsCmdTop GhcTcId))
-> TcM (LHsCmdTop GhcTcId)
-> TcM (OutPat GhcTcId, LHsCmdTop GhcTcId)
forall a b. (a -> b) -> a -> b
$
                          CmdEnv
-> LHsCmdTop GhcRn -> (TcType, TcType) -> TcM (LHsCmdTop GhcTcId)
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))
        ; (OutPat GhcTcId, LHsCmdTop GhcTcId, TcCoercion)
-> TcM (OutPat GhcTcId, LHsCmdTop GhcTcId, TcCoercion)
forall (m :: * -> *) a. Monad m => a -> m a
return (OutPat GhcTcId
pat', LHsCmdTop GhcTcId
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 env :: CmdEnv
env t1 :: TcType
t1 t2 :: 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 GhcTcId)
tcCmdTop env :: CmdEnv
env (L loc :: SrcSpan
loc (HsCmdTop names :: XCmdTop GhcRn
names cmd :: LHsCmd GhcRn
cmd)) cmd_ty :: (TcType, TcType)
cmd_ty@(cmd_stk :: TcType
cmd_stk, res_ty :: TcType
res_ty)
  = SrcSpan -> TcM (LHsCmdTop GhcTcId) -> TcM (LHsCmdTop GhcTcId)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM (LHsCmdTop GhcTcId) -> TcM (LHsCmdTop GhcTcId))
-> TcM (LHsCmdTop GhcTcId) -> TcM (LHsCmdTop GhcTcId)
forall a b. (a -> b) -> a -> b
$
    do  { LHsCmd GhcTcId
cmd'   <- CmdEnv -> LHsCmd GhcRn -> (TcType, TcType) -> TcM (LHsCmd GhcTcId)
tcCmd CmdEnv
env LHsCmd GhcRn
cmd (TcType, TcType)
cmd_ty
        ; [(Name, HsExpr GhcTcId)]
names' <- ((Name, HsExpr GhcRn)
 -> IOEnv (Env TcGblEnv TcLclEnv) (Name, HsExpr GhcTcId))
-> [(Name, HsExpr GhcRn)]
-> IOEnv (Env TcGblEnv TcLclEnv) [(Name, HsExpr GhcTcId)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (CtOrigin
-> TcType
-> (Name, HsExpr GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Name, HsExpr GhcTcId)
tcSyntaxName CtOrigin
ProcOrigin (CmdEnv -> TcType
cmd_arr CmdEnv
env)) [(Name, HsExpr GhcRn)]
XCmdTop GhcRn
names
        ; LHsCmdTop GhcTcId -> TcM (LHsCmdTop GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> HsCmdTop GhcTcId -> LHsCmdTop GhcTcId
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsCmdTop GhcTcId -> LHsCmdTop GhcTcId)
-> HsCmdTop GhcTcId -> LHsCmdTop GhcTcId
forall a b. (a -> b) -> a -> b
$ XCmdTop GhcTcId -> LHsCmd GhcTcId -> HsCmdTop GhcTcId
forall p. XCmdTop p -> LHsCmd p -> HsCmdTop p
HsCmdTop (TcType -> TcType -> [(Name, HsExpr GhcTcId)] -> CmdTopTc
CmdTopTc TcType
cmd_stk TcType
res_ty [(Name, HsExpr GhcTcId)]
names') LHsCmd GhcTcId
cmd') }
tcCmdTop _ (L _ XCmdTop{}) _ = String -> TcM (LHsCmdTop GhcTcId)
forall a. String -> a
panic "tcCmdTop"

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

tc_cmd :: CmdEnv -> HsCmd GhcRn  -> CmdType -> TcM (HsCmd GhcTcId)
tc_cmd :: CmdEnv -> HsCmd GhcRn -> (TcType, TcType) -> TcM (HsCmd GhcTcId)
tc_cmd env :: CmdEnv
env (HsCmdPar x :: XCmdPar GhcRn
x cmd :: LHsCmd GhcRn
cmd) res_ty :: (TcType, TcType)
res_ty
  = do  { LHsCmd GhcTcId
cmd' <- CmdEnv -> LHsCmd GhcRn -> (TcType, TcType) -> TcM (LHsCmd GhcTcId)
tcCmd CmdEnv
env LHsCmd GhcRn
cmd (TcType, TcType)
res_ty
        ; HsCmd GhcTcId -> TcM (HsCmd GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (XCmdPar GhcTcId -> LHsCmd GhcTcId -> HsCmd GhcTcId
forall id. XCmdPar id -> LHsCmd id -> HsCmd id
HsCmdPar XCmdPar GhcRn
XCmdPar GhcTcId
x LHsCmd GhcTcId
cmd') }

tc_cmd env :: CmdEnv
env (HsCmdLet x :: XCmdLet GhcRn
x (L l :: SrcSpan
l binds :: HsLocalBinds GhcRn
binds) (L body_loc :: SrcSpan
body_loc body :: HsCmd GhcRn
body)) res_ty :: (TcType, TcType)
res_ty
  = do  { (binds' :: HsLocalBinds GhcTcId
binds', body' :: HsCmd GhcTcId
body') <- HsLocalBinds GhcRn
-> TcM (HsCmd GhcTcId) -> TcM (HsLocalBinds GhcTcId, HsCmd GhcTcId)
forall thing.
HsLocalBinds GhcRn
-> TcM thing -> TcM (HsLocalBinds GhcTcId, thing)
tcLocalBinds HsLocalBinds GhcRn
binds         (TcM (HsCmd GhcTcId) -> TcM (HsLocalBinds GhcTcId, HsCmd GhcTcId))
-> TcM (HsCmd GhcTcId) -> TcM (HsLocalBinds GhcTcId, HsCmd GhcTcId)
forall a b. (a -> b) -> a -> b
$
                             SrcSpan -> TcM (HsCmd GhcTcId) -> TcM (HsCmd GhcTcId)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
body_loc        (TcM (HsCmd GhcTcId) -> TcM (HsCmd GhcTcId))
-> TcM (HsCmd GhcTcId) -> TcM (HsCmd GhcTcId)
forall a b. (a -> b) -> a -> b
$
                             CmdEnv -> HsCmd GhcRn -> (TcType, TcType) -> TcM (HsCmd GhcTcId)
tc_cmd CmdEnv
env HsCmd GhcRn
body (TcType, TcType)
res_ty
        ; HsCmd GhcTcId -> TcM (HsCmd GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (XCmdLet GhcTcId
-> LHsLocalBinds GhcTcId -> LHsCmd GhcTcId -> HsCmd GhcTcId
forall id. XCmdLet id -> LHsLocalBinds id -> LHsCmd id -> HsCmd id
HsCmdLet XCmdLet GhcRn
XCmdLet GhcTcId
x (SrcSpan -> HsLocalBinds GhcTcId -> LHsLocalBinds GhcTcId
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsLocalBinds GhcTcId
binds') (SrcSpan -> HsCmd GhcTcId -> LHsCmd GhcTcId
forall l e. l -> e -> GenLocated l e
L SrcSpan
body_loc HsCmd GhcTcId
body')) }

tc_cmd env :: CmdEnv
env in_cmd :: HsCmd GhcRn
in_cmd@(HsCmdCase x :: XCmdCase GhcRn
x scrut :: LHsExpr GhcRn
scrut matches :: MatchGroup GhcRn (LHsCmd GhcRn)
matches) (stk :: TcType
stk, res_ty :: TcType
res_ty)
  = MsgDoc -> TcM (HsCmd GhcTcId) -> TcM (HsCmd GhcTcId)
forall a. MsgDoc -> TcM a -> TcM a
addErrCtxt (HsCmd GhcRn -> MsgDoc
cmdCtxt HsCmd GhcRn
in_cmd) (TcM (HsCmd GhcTcId) -> TcM (HsCmd GhcTcId))
-> TcM (HsCmd GhcTcId) -> TcM (HsCmd GhcTcId)
forall a b. (a -> b) -> a -> b
$ do
      (scrut' :: LHsExpr GhcTcId
scrut', scrut_ty :: TcType
scrut_ty) <- LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcType)
tcInferRho LHsExpr GhcRn
scrut
      MatchGroup GhcTcId (LHsCmd GhcTcId)
matches' <- TcMatchCtxt HsCmd
-> TcType
-> MatchGroup GhcRn (LHsCmd GhcRn)
-> ExpRhoType
-> TcM (MatchGroup GhcTcId (LHsCmd GhcTcId))
forall (body :: * -> *).
Outputable (body GhcRn) =>
TcMatchCtxt body
-> TcType
-> MatchGroup GhcRn (Located (body GhcRn))
-> ExpRhoType
-> TcM (MatchGroup GhcTcId (Located (body GhcTcId)))
tcMatchesCase TcMatchCtxt HsCmd
match_ctxt TcType
scrut_ty MatchGroup GhcRn (LHsCmd GhcRn)
matches (TcType -> ExpRhoType
mkCheckExpType TcType
res_ty)
      HsCmd GhcTcId -> TcM (HsCmd GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (XCmdCase GhcTcId
-> LHsExpr GhcTcId
-> MatchGroup GhcTcId (LHsCmd GhcTcId)
-> HsCmd GhcTcId
forall id.
XCmdCase id -> LHsExpr id -> MatchGroup id (LHsCmd id) -> HsCmd id
HsCmdCase XCmdCase GhcRn
XCmdCase GhcTcId
x LHsExpr GhcTcId
scrut' MatchGroup GhcTcId (LHsCmd GhcTcId)
matches')
  where
    match_ctxt :: TcMatchCtxt HsCmd
match_ctxt = MC :: forall (body :: * -> *).
HsMatchContext Name
-> (Located (body GhcRn)
    -> ExpRhoType -> TcM (Located (body GhcTcId)))
-> TcMatchCtxt body
MC { mc_what :: HsMatchContext Name
mc_what = HsMatchContext Name
forall id. HsMatchContext id
CaseAlt,
                      mc_body :: LHsCmd GhcRn -> ExpRhoType -> TcM (LHsCmd GhcTcId)
mc_body = LHsCmd GhcRn -> ExpRhoType -> TcM (LHsCmd GhcTcId)
mc_body }
    mc_body :: LHsCmd GhcRn -> ExpRhoType -> TcM (LHsCmd GhcTcId)
mc_body body :: LHsCmd GhcRn
body res_ty' :: ExpRhoType
res_ty' = do { TcType
res_ty' <- ExpRhoType -> TcM TcType
expTypeToType ExpRhoType
res_ty'
                              ; CmdEnv -> LHsCmd GhcRn -> (TcType, TcType) -> TcM (LHsCmd GhcTcId)
tcCmd CmdEnv
env LHsCmd GhcRn
body (TcType
stk, TcType
res_ty') }

tc_cmd env :: CmdEnv
env (HsCmdIf x :: XCmdIf GhcRn
x Nothing pred :: LHsExpr GhcRn
pred b1 :: LHsCmd GhcRn
b1 b2 :: LHsCmd GhcRn
b2) res_ty :: (TcType, TcType)
res_ty    -- Ordinary 'if'
  = do  { LHsExpr GhcTcId
pred' <- LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
tcMonoExpr LHsExpr GhcRn
pred (TcType -> ExpRhoType
mkCheckExpType TcType
boolTy)
        ; LHsCmd GhcTcId
b1'   <- CmdEnv -> LHsCmd GhcRn -> (TcType, TcType) -> TcM (LHsCmd GhcTcId)
tcCmd CmdEnv
env LHsCmd GhcRn
b1 (TcType, TcType)
res_ty
        ; LHsCmd GhcTcId
b2'   <- CmdEnv -> LHsCmd GhcRn -> (TcType, TcType) -> TcM (LHsCmd GhcTcId)
tcCmd CmdEnv
env LHsCmd GhcRn
b2 (TcType, TcType)
res_ty
        ; HsCmd GhcTcId -> TcM (HsCmd GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (XCmdIf GhcTcId
-> Maybe (SyntaxExpr GhcTcId)
-> LHsExpr GhcTcId
-> LHsCmd GhcTcId
-> LHsCmd GhcTcId
-> HsCmd GhcTcId
forall id.
XCmdIf id
-> Maybe (SyntaxExpr id)
-> LHsExpr id
-> LHsCmd id
-> LHsCmd id
-> HsCmd id
HsCmdIf XCmdIf GhcRn
XCmdIf GhcTcId
x Maybe (SyntaxExpr GhcTcId)
forall a. Maybe a
Nothing LHsExpr GhcTcId
pred' LHsCmd GhcTcId
b1' LHsCmd GhcTcId
b2')
    }

tc_cmd env :: CmdEnv
env (HsCmdIf x :: XCmdIf GhcRn
x (Just fun :: SyntaxExpr GhcRn
fun) pred :: LHsExpr GhcRn
pred b1 :: LHsCmd GhcRn
b1 b2 :: LHsCmd GhcRn
b2) res_ty :: (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.
        ; (_, [r_tv :: 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 "Predicate type of `ifThenElse' depends on result type")
        ; (pred' :: LHsExpr GhcTcId
pred', fun' :: SyntaxExpr GhcTcId
fun')
            <- CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcType] -> TcM (LHsExpr GhcTcId))
-> TcM (LHsExpr GhcTcId, SyntaxExpr GhcTcId)
forall a.
CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
tcSyntaxOp CtOrigin
IfOrigin SyntaxExpr GhcRn
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 GhcTcId))
 -> TcM (LHsExpr GhcTcId, SyntaxExpr GhcTcId))
-> ([TcType] -> TcM (LHsExpr GhcTcId))
-> TcM (LHsExpr GhcTcId, SyntaxExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$ \ _ ->
               LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
tcMonoExpr LHsExpr GhcRn
pred (TcType -> ExpRhoType
mkCheckExpType TcType
pred_ty)

        ; LHsCmd GhcTcId
b1'   <- CmdEnv -> LHsCmd GhcRn -> (TcType, TcType) -> TcM (LHsCmd GhcTcId)
tcCmd CmdEnv
env LHsCmd GhcRn
b1 (TcType, TcType)
res_ty
        ; LHsCmd GhcTcId
b2'   <- CmdEnv -> LHsCmd GhcRn -> (TcType, TcType) -> TcM (LHsCmd GhcTcId)
tcCmd CmdEnv
env LHsCmd GhcRn
b2 (TcType, TcType)
res_ty
        ; HsCmd GhcTcId -> TcM (HsCmd GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (XCmdIf GhcTcId
-> Maybe (SyntaxExpr GhcTcId)
-> LHsExpr GhcTcId
-> LHsCmd GhcTcId
-> LHsCmd GhcTcId
-> HsCmd GhcTcId
forall id.
XCmdIf id
-> Maybe (SyntaxExpr id)
-> LHsExpr id
-> LHsCmd id
-> LHsCmd id
-> HsCmd id
HsCmdIf XCmdIf GhcRn
XCmdIf GhcTcId
x (SyntaxExpr GhcTcId -> Maybe (SyntaxExpr GhcTcId)
forall a. a -> Maybe a
Just SyntaxExpr GhcTcId
fun') LHsExpr GhcTcId
pred' LHsCmd GhcTcId
b1' LHsCmd GhcTcId
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 env :: CmdEnv
env cmd :: HsCmd GhcRn
cmd@(HsCmdArrApp _ fun :: LHsExpr GhcRn
fun arg :: LHsExpr GhcRn
arg ho_app :: HsArrAppType
ho_app lr :: Bool
lr) (_, res_ty :: TcType
res_ty)
  = MsgDoc -> TcM (HsCmd GhcTcId) -> TcM (HsCmd GhcTcId)
forall a. MsgDoc -> TcM a -> TcM a
addErrCtxt (HsCmd GhcRn -> MsgDoc
cmdCtxt HsCmd GhcRn
cmd)    (TcM (HsCmd GhcTcId) -> TcM (HsCmd GhcTcId))
-> TcM (HsCmd GhcTcId) -> TcM (HsCmd GhcTcId)
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 GhcTcId
fun' <- TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId)
select_arrow_scope (LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
tcMonoExpr LHsExpr GhcRn
fun (TcType -> ExpRhoType
mkCheckExpType TcType
fun_ty))

        ; LHsExpr GhcTcId
arg' <- LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
tcMonoExpr LHsExpr GhcRn
arg (TcType -> ExpRhoType
mkCheckExpType TcType
arg_ty)

        ; HsCmd GhcTcId -> TcM (HsCmd GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (XCmdArrApp GhcTcId
-> LHsExpr GhcTcId
-> LHsExpr GhcTcId
-> HsArrAppType
-> Bool
-> HsCmd GhcTcId
forall id.
XCmdArrApp id
-> LHsExpr id -> LHsExpr id -> HsArrAppType -> Bool -> HsCmd id
HsCmdArrApp TcType
XCmdArrApp GhcTcId
fun_ty LHsExpr GhcTcId
fun' LHsExpr GhcTcId
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 TcRnTypes
    select_arrow_scope :: TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId)
select_arrow_scope tc :: TcM (LHsExpr GhcTcId)
tc = case HsArrAppType
ho_app of
        HsHigherOrderApp -> TcM (LHsExpr GhcTcId)
tc
        HsFirstOrderApp  -> TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId)
forall a. TcM a -> TcM a
escapeArrowScope TcM (LHsExpr GhcTcId)
tc

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

tc_cmd env :: CmdEnv
env cmd :: HsCmd GhcRn
cmd@(HsCmdApp x :: XCmdApp GhcRn
x fun :: LHsCmd GhcRn
fun arg :: LHsExpr GhcRn
arg) (cmd_stk :: TcType
cmd_stk, res_ty :: TcType
res_ty)
  = MsgDoc -> TcM (HsCmd GhcTcId) -> TcM (HsCmd GhcTcId)
forall a. MsgDoc -> TcM a -> TcM a
addErrCtxt (HsCmd GhcRn -> MsgDoc
cmdCtxt HsCmd GhcRn
cmd)    (TcM (HsCmd GhcTcId) -> TcM (HsCmd GhcTcId))
-> TcM (HsCmd GhcTcId) -> TcM (HsCmd GhcTcId)
forall a b. (a -> b) -> a -> b
$
    do  { TcType
arg_ty <- TcM TcType
newOpenFlexiTyVarTy
        ; LHsCmd GhcTcId
fun'   <- CmdEnv -> LHsCmd GhcRn -> (TcType, TcType) -> TcM (LHsCmd GhcTcId)
tcCmd CmdEnv
env LHsCmd GhcRn
fun (TcType -> TcType -> TcType
mkPairTy TcType
arg_ty TcType
cmd_stk, TcType
res_ty)
        ; LHsExpr GhcTcId
arg'   <- LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
tcMonoExpr LHsExpr GhcRn
arg (TcType -> ExpRhoType
mkCheckExpType TcType
arg_ty)
        ; HsCmd GhcTcId -> TcM (HsCmd GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (XCmdApp GhcTcId
-> LHsCmd GhcTcId -> LHsExpr GhcTcId -> HsCmd GhcTcId
forall id. XCmdApp id -> LHsCmd id -> LHsExpr id -> HsCmd id
HsCmdApp XCmdApp GhcRn
XCmdApp GhcTcId
x LHsCmd GhcTcId
fun' LHsExpr GhcTcId
arg') }

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

tc_cmd env :: CmdEnv
env
       (HsCmdLam x :: XCmdLam GhcRn
x (MG { mg_alts :: forall p body. MatchGroup p body -> Located [LMatch p body]
mg_alts = L l :: SrcSpan
l [L mtch_loc :: SrcSpan
mtch_loc
                                   (match :: Match GhcRn (LHsCmd GhcRn)
match@(Match { m_pats :: forall p body. Match p body -> [LPat p]
m_pats = [InPat 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 }))
       (cmd_stk :: TcType
cmd_stk, res_ty :: TcType
res_ty)
  = MsgDoc -> TcM (HsCmd GhcTcId) -> TcM (HsCmd GhcTcId)
forall a. MsgDoc -> TcM a -> TcM a
addErrCtxt (Match GhcRn (LHsCmd GhcRn) -> MsgDoc
forall (idR :: Pass) body.
(OutputableBndrId (GhcPass idR),
 Outputable (NameOrRdrName (NameOrRdrName (IdP (GhcPass idR)))),
 Outputable body) =>
Match (GhcPass idR) body -> MsgDoc
pprMatchInCtxt Match GhcRn (LHsCmd GhcRn)
match)        (TcM (HsCmd GhcTcId) -> TcM (HsCmd GhcTcId))
-> TcM (HsCmd GhcTcId) -> TcM (HsCmd GhcTcId)
forall a b. (a -> b) -> a -> b
$
    do  { (co :: TcCoercion
co, arg_tys :: [TcType]
arg_tys, cmd_stk' :: TcType
cmd_stk') <- Arity -> TcType -> TcM (TcCoercion, [TcType], TcType)
matchExpectedCmdArgs Arity
n_pats TcType
cmd_stk

                -- Check the patterns, and the GRHSs inside
        ; (pats' :: [OutPat GhcTcId]
pats', grhss' :: GRHSs GhcTcId (LHsCmd GhcTcId)
grhss') <- SrcSpan
-> TcRn ([OutPat GhcTcId], GRHSs GhcTcId (LHsCmd GhcTcId))
-> TcRn ([OutPat GhcTcId], GRHSs GhcTcId (LHsCmd GhcTcId))
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
mtch_loc                                 (TcRn ([OutPat GhcTcId], GRHSs GhcTcId (LHsCmd GhcTcId))
 -> TcRn ([OutPat GhcTcId], GRHSs GhcTcId (LHsCmd GhcTcId)))
-> TcRn ([OutPat GhcTcId], GRHSs GhcTcId (LHsCmd GhcTcId))
-> TcRn ([OutPat GhcTcId], GRHSs GhcTcId (LHsCmd GhcTcId))
forall a b. (a -> b) -> a -> b
$
                             HsMatchContext Name
-> [InPat GhcRn]
-> [ExpRhoType]
-> TcM (GRHSs GhcTcId (LHsCmd GhcTcId))
-> TcRn ([OutPat GhcTcId], GRHSs GhcTcId (LHsCmd GhcTcId))
forall a.
HsMatchContext Name
-> [InPat GhcRn]
-> [ExpRhoType]
-> TcM a
-> TcM ([OutPat GhcTcId], a)
tcPats HsMatchContext Name
forall id. HsMatchContext id
LambdaExpr [InPat GhcRn]
pats ((TcType -> ExpRhoType) -> [TcType] -> [ExpRhoType]
forall a b. (a -> b) -> [a] -> [b]
map TcType -> ExpRhoType
mkCheckExpType [TcType]
arg_tys) (TcM (GRHSs GhcTcId (LHsCmd GhcTcId))
 -> TcRn ([OutPat GhcTcId], GRHSs GhcTcId (LHsCmd GhcTcId)))
-> TcM (GRHSs GhcTcId (LHsCmd GhcTcId))
-> TcRn ([OutPat GhcTcId], GRHSs GhcTcId (LHsCmd GhcTcId))
forall a b. (a -> b) -> a -> b
$
                             GRHSs GhcRn (LHsCmd GhcRn)
-> TcType -> ExpRhoType -> TcM (GRHSs GhcTcId (LHsCmd GhcTcId))
tc_grhss GRHSs GhcRn (LHsCmd GhcRn)
grhss TcType
cmd_stk' (TcType -> ExpRhoType
mkCheckExpType TcType
res_ty)

        ; let match' :: GenLocated SrcSpan (Match GhcTcId (LHsCmd GhcTcId))
match' = SrcSpan
-> Match GhcTcId (LHsCmd GhcTcId)
-> GenLocated SrcSpan (Match GhcTcId (LHsCmd GhcTcId))
forall l e. l -> e -> GenLocated l e
L SrcSpan
mtch_loc (Match :: forall p body.
XCMatch p body
-> HsMatchContext (NameOrRdrName (IdP p))
-> [LPat p]
-> GRHSs p body
-> Match p body
Match { m_ext :: XCMatch GhcTcId (LHsCmd GhcTcId)
m_ext = XCMatch GhcTcId (LHsCmd GhcTcId)
NoExt
noExt
                                         , m_ctxt :: HsMatchContext (NameOrRdrName (IdP GhcTcId))
m_ctxt = HsMatchContext (NameOrRdrName (IdP GhcTcId))
forall id. HsMatchContext id
LambdaExpr, m_pats :: [OutPat GhcTcId]
m_pats = [OutPat GhcTcId]
pats'
                                         , m_grhss :: GRHSs GhcTcId (LHsCmd GhcTcId)
m_grhss = GRHSs GhcTcId (LHsCmd GhcTcId)
grhss' })
              arg_tys :: [TcType]
arg_tys = (OutPat GhcTcId -> TcType) -> [OutPat GhcTcId] -> [TcType]
forall a b. (a -> b) -> [a] -> [b]
map OutPat GhcTcId -> TcType
hsLPatType [OutPat GhcTcId]
pats'
              cmd' :: HsCmd GhcTcId
cmd' = XCmdLam GhcTcId
-> MatchGroup GhcTcId (LHsCmd GhcTcId) -> HsCmd GhcTcId
forall id. XCmdLam id -> MatchGroup id (LHsCmd id) -> HsCmd id
HsCmdLam XCmdLam GhcRn
XCmdLam GhcTcId
x (MG :: forall p body.
XMG p body
-> Located [LMatch p body] -> Origin -> MatchGroup p body
MG { mg_alts :: Located [GenLocated SrcSpan (Match GhcTcId (LHsCmd GhcTcId))]
mg_alts = SrcSpan
-> [GenLocated SrcSpan (Match GhcTcId (LHsCmd GhcTcId))]
-> Located [GenLocated SrcSpan (Match GhcTcId (LHsCmd GhcTcId))]
forall l e. l -> e -> GenLocated l e
L SrcSpan
l [GenLocated SrcSpan (Match GhcTcId (LHsCmd GhcTcId))
match']
                                    , mg_ext :: XMG GhcTcId (LHsCmd GhcTcId)
mg_ext = [TcType] -> TcType -> MatchGroupTc
MatchGroupTc [TcType]
arg_tys TcType
res_ty
                                    , mg_origin :: Origin
mg_origin = Origin
origin })
        ; HsCmd GhcTcId -> TcM (HsCmd GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> HsCmd GhcTcId -> HsCmd GhcTcId
forall (p :: Pass).
HsWrapper -> HsCmd (GhcPass p) -> HsCmd (GhcPass p)
mkHsCmdWrap (TcCoercion -> HsWrapper
mkWpCastN TcCoercion
co) HsCmd GhcTcId
cmd') }
  where
    n_pats :: Arity
n_pats     = [InPat GhcRn] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [InPat GhcRn]
pats
    match_ctxt :: HsMatchContext Name
match_ctxt = (HsMatchContext Name
forall id. HsMatchContext id
LambdaExpr :: HsMatchContext Name)    -- Maybe KappaExpr?
    pg_ctxt :: HsStmtContext Name
pg_ctxt    = HsMatchContext Name -> HsStmtContext Name
forall id. HsMatchContext id -> HsStmtContext id
PatGuard HsMatchContext Name
match_ctxt

    tc_grhss :: GRHSs GhcRn (LHsCmd GhcRn)
-> TcType -> ExpRhoType -> TcM (GRHSs GhcTcId (LHsCmd GhcTcId))
tc_grhss (GRHSs x :: XCGRHSs GhcRn (LHsCmd GhcRn)
x grhss :: [LGRHS GhcRn (LHsCmd GhcRn)]
grhss (L l :: SrcSpan
l binds :: HsLocalBinds GhcRn
binds)) stk_ty :: TcType
stk_ty res_ty :: ExpRhoType
res_ty
        = do { (binds' :: HsLocalBinds GhcTcId
binds', grhss' :: [LGRHS GhcTcId (LHsCmd GhcTcId)]
grhss') <- HsLocalBinds GhcRn
-> TcM [LGRHS GhcTcId (LHsCmd GhcTcId)]
-> TcM (HsLocalBinds GhcTcId, [LGRHS GhcTcId (LHsCmd GhcTcId)])
forall thing.
HsLocalBinds GhcRn
-> TcM thing -> TcM (HsLocalBinds GhcTcId, thing)
tcLocalBinds HsLocalBinds GhcRn
binds (TcM [LGRHS GhcTcId (LHsCmd GhcTcId)]
 -> TcM (HsLocalBinds GhcTcId, [LGRHS GhcTcId (LHsCmd GhcTcId)]))
-> TcM [LGRHS GhcTcId (LHsCmd GhcTcId)]
-> TcM (HsLocalBinds GhcTcId, [LGRHS GhcTcId (LHsCmd GhcTcId)])
forall a b. (a -> b) -> a -> b
$
                                   (LGRHS GhcRn (LHsCmd GhcRn)
 -> IOEnv (Env TcGblEnv TcLclEnv) (LGRHS GhcTcId (LHsCmd GhcTcId)))
-> [LGRHS GhcRn (LHsCmd GhcRn)]
-> TcM [LGRHS GhcTcId (LHsCmd GhcTcId)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((SrcSpanLess (LGRHS GhcRn (LHsCmd GhcRn))
 -> TcM (SrcSpanLess (LGRHS GhcTcId (LHsCmd GhcTcId))))
-> LGRHS GhcRn (LHsCmd GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (LGRHS GhcTcId (LHsCmd GhcTcId))
forall a b.
(HasSrcSpan a, HasSrcSpan b) =>
(SrcSpanLess a -> TcM (SrcSpanLess b)) -> a -> TcM b
wrapLocM (TcType
-> ExpRhoType
-> GRHS GhcRn (LHsCmd GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (GRHS GhcTcId (LHsCmd GhcTcId))
tc_grhs TcType
stk_ty ExpRhoType
res_ty)) [LGRHS GhcRn (LHsCmd GhcRn)]
grhss
             ; GRHSs GhcTcId (LHsCmd GhcTcId)
-> TcM (GRHSs GhcTcId (LHsCmd GhcTcId))
forall (m :: * -> *) a. Monad m => a -> m a
return (XCGRHSs GhcTcId (LHsCmd GhcTcId)
-> [LGRHS GhcTcId (LHsCmd GhcTcId)]
-> LHsLocalBinds GhcTcId
-> GRHSs GhcTcId (LHsCmd GhcTcId)
forall p body.
XCGRHSs p body -> [LGRHS p body] -> LHsLocalBinds p -> GRHSs p body
GRHSs XCGRHSs GhcRn (LHsCmd GhcRn)
XCGRHSs GhcTcId (LHsCmd GhcTcId)
x [LGRHS GhcTcId (LHsCmd GhcTcId)]
grhss' (SrcSpan -> HsLocalBinds GhcTcId -> LHsLocalBinds GhcTcId
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsLocalBinds GhcTcId
binds')) }
    tc_grhss (XGRHSs _) _ _ = String -> TcM (GRHSs GhcTcId (LHsCmd GhcTcId))
forall a. String -> a
panic "tc_grhss"

    tc_grhs :: TcType
-> ExpRhoType
-> GRHS GhcRn (LHsCmd GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (GRHS GhcTcId (LHsCmd GhcTcId))
tc_grhs stk_ty :: TcType
stk_ty res_ty :: ExpRhoType
res_ty (GRHS x :: XCGRHS GhcRn (LHsCmd GhcRn)
x guards :: [GuardLStmt GhcRn]
guards body :: LHsCmd GhcRn
body)
        = do { (guards' :: [LStmt GhcTcId (LHsExpr GhcTcId)]
guards', rhs' :: LHsCmd GhcTcId
rhs') <- HsStmtContext Name
-> TcStmtChecker HsExpr ExpRhoType
-> [GuardLStmt GhcRn]
-> ExpRhoType
-> (ExpRhoType -> TcM (LHsCmd GhcTcId))
-> TcM ([LStmt GhcTcId (LHsExpr GhcTcId)], LHsCmd GhcTcId)
forall (body :: * -> *) rho_type thing.
Outputable (body GhcRn) =>
HsStmtContext Name
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
tcStmtsAndThen HsStmtContext Name
pg_ctxt TcStmtChecker HsExpr ExpRhoType
tcGuardStmt [GuardLStmt GhcRn]
guards ExpRhoType
res_ty ((ExpRhoType -> TcM (LHsCmd GhcTcId))
 -> TcM ([LStmt GhcTcId (LHsExpr GhcTcId)], LHsCmd GhcTcId))
-> (ExpRhoType -> TcM (LHsCmd GhcTcId))
-> TcM ([LStmt GhcTcId (LHsExpr GhcTcId)], LHsCmd GhcTcId)
forall a b. (a -> b) -> a -> b
$
                                  \ res_ty :: ExpRhoType
res_ty -> CmdEnv -> LHsCmd GhcRn -> (TcType, TcType) -> TcM (LHsCmd GhcTcId)
tcCmd CmdEnv
env LHsCmd GhcRn
body
                                                (TcType
stk_ty, String -> ExpRhoType -> TcType
checkingExpType "tc_grhs" ExpRhoType
res_ty)
             ; GRHS GhcTcId (LHsCmd GhcTcId)
-> IOEnv (Env TcGblEnv TcLclEnv) (GRHS GhcTcId (LHsCmd GhcTcId))
forall (m :: * -> *) a. Monad m => a -> m a
return (XCGRHS GhcTcId (LHsCmd GhcTcId)
-> [LStmt GhcTcId (LHsExpr GhcTcId)]
-> LHsCmd GhcTcId
-> GRHS GhcTcId (LHsCmd GhcTcId)
forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS XCGRHS GhcRn (LHsCmd GhcRn)
XCGRHS GhcTcId (LHsCmd GhcTcId)
x [LStmt GhcTcId (LHsExpr GhcTcId)]
guards' LHsCmd GhcTcId
rhs') }
    tc_grhs _ _ (XGRHS _) = String
-> IOEnv (Env TcGblEnv TcLclEnv) (GRHS GhcTcId (LHsCmd GhcTcId))
forall a. String -> a
panic "tc_grhs"

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

tc_cmd env :: CmdEnv
env (HsCmdDo _ (L l :: SrcSpan
l stmts :: [CmdLStmt GhcRn]
stmts) ) (cmd_stk :: TcType
cmd_stk, res_ty :: 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 GhcTcId (LHsCmd GhcTcId)]
stmts' <- HsStmtContext Name
-> TcStmtChecker HsCmd TcType
-> [CmdLStmt GhcRn]
-> TcType
-> TcM [LStmt GhcTcId (LHsCmd GhcTcId)]
forall (body :: * -> *) rho_type.
Outputable (body GhcRn) =>
HsStmtContext Name
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> TcM [LStmt GhcTcId (Located (body GhcTcId))]
tcStmts HsStmtContext Name
forall id. HsStmtContext id
ArrowExpr (CmdEnv -> TcStmtChecker HsCmd TcType
tcArrDoStmt CmdEnv
env) [CmdLStmt GhcRn]
stmts TcType
res_ty
        ; HsCmd GhcTcId -> TcM (HsCmd GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> HsCmd GhcTcId -> HsCmd GhcTcId
forall (p :: Pass).
HsWrapper -> HsCmd (GhcPass p) -> HsCmd (GhcPass p)
mkHsCmdWrap (TcCoercion -> HsWrapper
mkWpCastN TcCoercion
co) (XCmdDo GhcTcId
-> Located [LStmt GhcTcId (LHsCmd GhcTcId)] -> HsCmd GhcTcId
forall id. XCmdDo id -> Located [CmdLStmt id] -> HsCmd id
HsCmdDo TcType
XCmdDo GhcTcId
res_ty (SrcSpan
-> [LStmt GhcTcId (LHsCmd GhcTcId)]
-> Located [LStmt GhcTcId (LHsCmd GhcTcId)]
forall l e. l -> e -> GenLocated l e
L SrcSpan
l [LStmt GhcTcId (LHsCmd GhcTcId)]
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 env :: CmdEnv
env cmd :: HsCmd GhcRn
cmd@(HsCmdArrForm x :: XCmdArrForm GhcRn
x expr :: LHsExpr GhcRn
expr f :: LexicalFixity
f fixity :: Maybe Fixity
fixity cmd_args :: [LHsCmdTop GhcRn]
cmd_args) (cmd_stk :: TcType
cmd_stk, res_ty :: TcType
res_ty)
  = MsgDoc -> TcM (HsCmd GhcTcId) -> TcM (HsCmd GhcTcId)
forall a. MsgDoc -> TcM a -> TcM a
addErrCtxt (HsCmd GhcRn -> MsgDoc
cmdCtxt HsCmd GhcRn
cmd)    (TcM (HsCmd GhcTcId) -> TcM (HsCmd GhcTcId))
-> TcM (HsCmd GhcTcId) -> TcM (HsCmd GhcTcId)
forall a b. (a -> b) -> a -> b
$
    do  { (cmd_args' :: [LHsCmdTop GhcTcId]
cmd_args', cmd_tys :: [TcType]
cmd_tys) <- (LHsCmdTop GhcRn
 -> IOEnv (Env TcGblEnv TcLclEnv) (LHsCmdTop GhcTcId, TcType))
-> [LHsCmdTop GhcRn]
-> IOEnv (Env TcGblEnv TcLclEnv) ([LHsCmdTop GhcTcId], [TcType])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM LHsCmdTop GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (LHsCmdTop GhcTcId, TcType)
tc_cmd_arg [LHsCmdTop GhcRn]
cmd_args
                              -- We use alphaTyVar for 'w'
        ; let e_ty :: TcType
e_ty = TcTyVar -> TcType -> TcType
mkInvForAllTy TcTyVar
alphaTyVar (TcType -> TcType) -> TcType -> TcType
forall a b. (a -> b) -> a -> b
$
                     [TcType] -> TcType -> TcType
mkFunTys [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 GhcTcId
expr' <- LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTcId)
tcPolyExpr LHsExpr GhcRn
expr TcType
e_ty
        ; HsCmd GhcTcId -> TcM (HsCmd GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (XCmdArrForm GhcTcId
-> LHsExpr GhcTcId
-> LexicalFixity
-> Maybe Fixity
-> [LHsCmdTop GhcTcId]
-> HsCmd GhcTcId
forall id.
XCmdArrForm id
-> LHsExpr id
-> LexicalFixity
-> Maybe Fixity
-> [LHsCmdTop id]
-> HsCmd id
HsCmdArrForm XCmdArrForm GhcRn
XCmdArrForm GhcTcId
x LHsExpr GhcTcId
expr' LexicalFixity
f Maybe Fixity
fixity [LHsCmdTop GhcTcId]
cmd_args') }

  where
    tc_cmd_arg :: LHsCmdTop GhcRn -> TcM (LHsCmdTop GhcTcId, TcType)
    tc_cmd_arg :: LHsCmdTop GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (LHsCmdTop GhcTcId, TcType)
tc_cmd_arg cmd :: 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 GhcTcId
cmd' <- CmdEnv
-> LHsCmdTop GhcRn -> (TcType, TcType) -> TcM (LHsCmdTop GhcTcId)
tcCmdTop CmdEnv
env' LHsCmdTop GhcRn
cmd (TcType
stk_ty, TcType
res_ty)
            ; (LHsCmdTop GhcTcId, TcType)
-> IOEnv (Env TcGblEnv TcLclEnv) (LHsCmdTop GhcTcId, TcType)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsCmdTop GhcTcId
cmd',  CmdEnv -> TcType -> TcType -> TcType
mkCmdArrTy CmdEnv
env' (TcType -> TcType -> TcType
mkPairTy TcType
alphaTy TcType
stk_ty) TcType
res_ty) }

tc_cmd _ (XCmd {}) _ = String -> TcM (HsCmd GhcTcId)
forall a. String -> a
panic "tc_cmd"

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

tc_cmd _ cmd :: HsCmd GhcRn
cmd _
  = MsgDoc -> TcM (HsCmd GhcTcId)
forall a. MsgDoc -> TcM a
failWithTc ([MsgDoc] -> MsgDoc
vcat [String -> MsgDoc
text "The expression", Arity -> MsgDoc -> MsgDoc
nest 2 (HsCmd GhcRn -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsCmd GhcRn
cmd),
                      String -> MsgDoc
text "was found where an arrow command was expected"])


matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercionN, [TcType], TcType)
matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercion, [TcType], TcType)
matchExpectedCmdArgs 0 ty :: TcType
ty
  = (TcCoercion, [TcType], TcType)
-> TcM (TcCoercion, [TcType], TcType)
forall (m :: * -> *) a. Monad m => a -> m a
return (TcType -> TcCoercion
mkTcNomReflCo TcType
ty, [], TcType
ty)
matchExpectedCmdArgs n :: Arity
n ty :: TcType
ty
  = do { (co1 :: TcCoercion
co1, [ty1 :: TcType
ty1, ty2 :: TcType
ty2]) <- TyCon -> TcType -> TcM (TcCoercion, [TcType])
matchExpectedTyConApp TyCon
pairTyCon TcType
ty
       ; (co2 :: TcCoercion
co2, tys :: [TcType]
tys, res_ty :: TcType
res_ty) <- Arity -> TcType -> TcM (TcCoercion, [TcType], TcType)
matchExpectedCmdArgs (Arity
nArity -> Arity -> Arity
forall a. Num a => a -> a -> a
-1) TcType
ty2
       ; (TcCoercion, [TcType], TcType)
-> TcM (TcCoercion, [TcType], TcType)
forall (m :: * -> *) a. Monad m => a -> m a
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 env :: CmdEnv
env _ (LastStmt x :: XLastStmt GhcRn GhcRn (LHsCmd GhcRn)
x rhs :: LHsCmd GhcRn
rhs noret :: Bool
noret _) res_ty :: TcType
res_ty thing_inside :: TcType -> TcM thing
thing_inside
  = do  { LHsCmd GhcTcId
rhs' <- CmdEnv -> LHsCmd GhcRn -> (TcType, TcType) -> TcM (LHsCmd GhcTcId)
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 "tcArrDoStmt")
        ; (Stmt GhcTcId (LHsCmd GhcTcId), thing)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (Stmt GhcTcId (LHsCmd GhcTcId), thing)
forall (m :: * -> *) a. Monad m => a -> m a
return (XLastStmt GhcTcId GhcTcId (LHsCmd GhcTcId)
-> LHsCmd GhcTcId
-> Bool
-> SyntaxExpr GhcTcId
-> Stmt GhcTcId (LHsCmd GhcTcId)
forall idL idR body.
XLastStmt idL idR body
-> body -> Bool -> SyntaxExpr idR -> StmtLR idL idR body
LastStmt XLastStmt GhcRn GhcRn (LHsCmd GhcRn)
XLastStmt GhcTcId GhcTcId (LHsCmd GhcTcId)
x LHsCmd GhcTcId
rhs' Bool
noret SyntaxExpr GhcTcId
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr, thing
thing) }

tcArrDoStmt env :: CmdEnv
env _ (BodyStmt _ rhs :: LHsCmd GhcRn
rhs _ _) res_ty :: TcType
res_ty thing_inside :: TcType -> TcM thing
thing_inside
  = do  { (rhs' :: LHsCmd GhcTcId
rhs', elt_ty :: TcType
elt_ty) <- CmdEnv -> LHsCmd GhcRn -> TcM (LHsCmd GhcTcId, TcType)
tc_arr_rhs CmdEnv
env LHsCmd GhcRn
rhs
        ; thing
thing          <- TcType -> TcM thing
thing_inside TcType
res_ty
        ; (Stmt GhcTcId (LHsCmd GhcTcId), thing)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (Stmt GhcTcId (LHsCmd GhcTcId), thing)
forall (m :: * -> *) a. Monad m => a -> m a
return (XBodyStmt GhcTcId GhcTcId (LHsCmd GhcTcId)
-> LHsCmd GhcTcId
-> SyntaxExpr GhcTcId
-> SyntaxExpr GhcTcId
-> Stmt GhcTcId (LHsCmd GhcTcId)
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt TcType
XBodyStmt GhcTcId GhcTcId (LHsCmd GhcTcId)
elt_ty LHsCmd GhcTcId
rhs' SyntaxExpr GhcTcId
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr SyntaxExpr GhcTcId
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr, thing
thing) }

tcArrDoStmt env :: CmdEnv
env ctxt :: HsStmtContext Name
ctxt (BindStmt _ pat :: InPat GhcRn
pat rhs :: LHsCmd GhcRn
rhs _ _) res_ty :: TcType
res_ty thing_inside :: TcType -> TcM thing
thing_inside
  = do  { (rhs' :: LHsCmd GhcTcId
rhs', pat_ty :: TcType
pat_ty) <- CmdEnv -> LHsCmd GhcRn -> TcM (LHsCmd GhcTcId, TcType)
tc_arr_rhs CmdEnv
env LHsCmd GhcRn
rhs
        ; (pat' :: OutPat GhcTcId
pat', thing :: thing
thing)  <- HsMatchContext Name
-> InPat GhcRn
-> ExpRhoType
-> TcM thing
-> TcM (OutPat GhcTcId, thing)
forall a.
HsMatchContext Name
-> InPat GhcRn -> ExpRhoType -> TcM a -> TcM (OutPat GhcTcId, a)
tcPat (HsStmtContext Name -> HsMatchContext Name
forall id. HsStmtContext id -> HsMatchContext id
StmtCtxt HsStmtContext Name
ctxt) InPat GhcRn
pat (TcType -> ExpRhoType
mkCheckExpType TcType
pat_ty) (TcM thing -> TcM (OutPat GhcTcId, thing))
-> TcM thing -> TcM (OutPat GhcTcId, thing)
forall a b. (a -> b) -> a -> b
$
                            TcType -> TcM thing
thing_inside TcType
res_ty
        ; (Stmt GhcTcId (LHsCmd GhcTcId), thing)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (Stmt GhcTcId (LHsCmd GhcTcId), thing)
forall (m :: * -> *) a. Monad m => a -> m a
return (OutPat GhcTcId -> LHsCmd GhcTcId -> Stmt GhcTcId (LHsCmd GhcTcId)
forall (bodyR :: * -> *).
OutPat GhcTcId
-> Located (bodyR GhcTcId)
-> StmtLR GhcTcId GhcTcId (Located (bodyR GhcTcId))
mkTcBindStmt OutPat GhcTcId
pat' LHsCmd GhcTcId
rhs', thing
thing) }

tcArrDoStmt env :: CmdEnv
env ctxt :: HsStmtContext Name
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 }) res_ty :: TcType
res_ty thing_inside :: 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
`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
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 Name -> TcType -> TcTyVar
mkLocalId [Name]
tup_names [TcType]
tup_elt_tys
        ; [TcTyVar]
-> IOEnv
     (Env TcGblEnv TcLclEnv) (Stmt GhcTcId (LHsCmd GhcTcId), thing)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (Stmt GhcTcId (LHsCmd GhcTcId), thing)
forall a. [TcTyVar] -> TcM a -> TcM a
tcExtendIdEnv [TcTyVar]
tup_ids (IOEnv
   (Env TcGblEnv TcLclEnv) (Stmt GhcTcId (LHsCmd GhcTcId), thing)
 -> IOEnv
      (Env TcGblEnv TcLclEnv) (Stmt GhcTcId (LHsCmd GhcTcId), thing))
-> IOEnv
     (Env TcGblEnv TcLclEnv) (Stmt GhcTcId (LHsCmd GhcTcId), thing)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (Stmt GhcTcId (LHsCmd GhcTcId), thing)
forall a b. (a -> b) -> a -> b
$ do
        { (stmts' :: [LStmt GhcTcId (LHsCmd GhcTcId)]
stmts', tup_rets :: [HsExpr GhcTcId]
tup_rets)
                <- HsStmtContext Name
-> TcStmtChecker HsCmd TcType
-> [CmdLStmt GhcRn]
-> TcType
-> (TcType -> TcM [HsExpr GhcTcId])
-> TcM ([LStmt GhcTcId (LHsCmd GhcTcId)], [HsExpr GhcTcId])
forall (body :: * -> *) rho_type thing.
Outputable (body GhcRn) =>
HsStmtContext Name
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
tcStmtsAndThen HsStmtContext Name
ctxt (CmdEnv -> TcStmtChecker HsCmd TcType
tcArrDoStmt CmdEnv
env) [CmdLStmt GhcRn]
stmts TcType
res_ty   ((TcType -> TcM [HsExpr GhcTcId])
 -> TcM ([LStmt GhcTcId (LHsCmd GhcTcId)], [HsExpr GhcTcId]))
-> (TcType -> TcM [HsExpr GhcTcId])
-> TcM ([LStmt GhcTcId (LHsCmd GhcTcId)], [HsExpr GhcTcId])
forall a b. (a -> b) -> a -> b
$ \ _res_ty' :: TcType
_res_ty' ->
                        -- ToDo: res_ty not really right
                   (Name
 -> ExpRhoType -> IOEnv (Env TcGblEnv TcLclEnv) (HsExpr GhcTcId))
-> [Name] -> [ExpRhoType] -> TcM [HsExpr GhcTcId]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Name
-> ExpRhoType -> IOEnv (Env TcGblEnv TcLclEnv) (HsExpr GhcTcId)
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 HsExpr)

        ; 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 GhcTcId]
rec_rets = [Name] -> [HsExpr GhcTcId] -> [HsExpr GhcTcId]
forall b a. [b] -> [a] -> [a]
takeList [Name]
[IdP GhcRn]
rec_names [HsExpr GhcTcId]
tup_rets
        ; let ret_table :: [(TcTyVar, HsExpr GhcTcId)]
ret_table = [TcTyVar] -> [HsExpr GhcTcId] -> [(TcTyVar, HsExpr GhcTcId)]
forall a b. [a] -> [b] -> [(a, b)]
zip [TcTyVar]
tup_ids [HsExpr GhcTcId]
tup_rets
        ; let later_rets :: [HsExpr GhcTcId]
later_rets = [HsExpr GhcTcId
r | TcTyVar
i <- [TcTyVar]
later_ids, (j :: TcTyVar
j, r :: HsExpr GhcTcId
r) <- [(TcTyVar, HsExpr GhcTcId)]
ret_table, TcTyVar
i TcTyVar -> TcTyVar -> Bool
forall a. Eq a => a -> a -> Bool
== TcTyVar
j]

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

tcArrDoStmt _ _ stmt :: Stmt GhcRn (LHsCmd GhcRn)
stmt _ _
  = String
-> MsgDoc
-> IOEnv
     (Env TcGblEnv TcLclEnv) (Stmt GhcTcId (LHsCmd GhcTcId), thing)
forall a. HasCallStack => String -> MsgDoc -> a
pprPanic "tcArrDoStmt: unexpected Stmt" (Stmt GhcRn (LHsCmd GhcRn) -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Stmt GhcRn (LHsCmd GhcRn)
stmt)

tc_arr_rhs :: CmdEnv -> LHsCmd GhcRn -> TcM (LHsCmd GhcTcId, TcType)
tc_arr_rhs :: CmdEnv -> LHsCmd GhcRn -> TcM (LHsCmd GhcTcId, TcType)
tc_arr_rhs env :: CmdEnv
env rhs :: LHsCmd GhcRn
rhs = do { TcType
ty <- TcType -> TcM TcType
newFlexiTyVarTy TcType
liftedTypeKind
                        ; LHsCmd GhcTcId
rhs' <- CmdEnv -> LHsCmd GhcRn -> (TcType, TcType) -> TcM (LHsCmd GhcTcId)
tcCmd CmdEnv
env LHsCmd GhcRn
rhs (TcType
unitTy, TcType
ty)
                        ; (LHsCmd GhcTcId, TcType) -> TcM (LHsCmd GhcTcId, TcType)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsCmd GhcTcId
rhs', TcType
ty) }

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

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

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

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

cmdCtxt :: HsCmd GhcRn -> SDoc
cmdCtxt :: HsCmd GhcRn -> MsgDoc
cmdCtxt cmd :: HsCmd GhcRn
cmd = String -> MsgDoc
text "In the command:" MsgDoc -> MsgDoc -> MsgDoc
<+> HsCmd GhcRn -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsCmd GhcRn
cmd