module TcMatches ( tcMatchesFun, tcGRHS, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
TcMatchCtxt(..), TcStmtChecker, TcExprStmtChecker, TcCmdStmtChecker,
tcStmts, tcStmtsAndThen, tcDoStmts, tcBody,
tcDoStmt, tcGuardStmt
) where
import GhcPrelude
import TcExpr( tcSyntaxOp, tcInferRhoNC, tcInferRho
, tcCheckId, tcMonoExpr, tcMonoExprNC, tcPolyExpr )
import BasicTypes (LexicalFixity(..))
import GHC.Hs
import TcRnMonad
import TcEnv
import TcPat
import TcMType
import TcType
import TcBinds
import TcUnify
import TcOrigin
import Name
import TysWiredIn
import Id
import TyCon
import TysPrim
import TcEvidence
import Outputable
import Util
import SrcLoc
import MkCore
import Control.Monad
import Control.Arrow ( second )
#include "HsVersions.h"
tcMatchesFun :: Located Name
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> ExpSigmaType
-> TcM (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId))
tcMatchesFun fn@(L _ fun_name) matches exp_ty
= do {
traceTc "tcMatchesFun" (ppr fun_name $$ ppr exp_ty)
; checkArgs fun_name matches
; (wrap_gen, (wrap_fun, group))
<- tcSkolemiseET (FunSigCtxt fun_name True) exp_ty $ \ exp_rho ->
do { (matches', wrap_fun)
<- matchExpectedFunTys herald arity exp_rho $
\ pat_tys rhs_ty ->
tcMatches match_ctxt pat_tys rhs_ty matches
; return (wrap_fun, matches') }
; return (wrap_gen <.> wrap_fun, group) }
where
arity = matchGroupArity matches
herald = text "The equation(s) for"
<+> quotes (ppr fun_name) <+> text "have"
what = FunRhs { mc_fun = fn, mc_fixity = Prefix, mc_strictness = strictness }
match_ctxt = MC { mc_what = what, mc_body = tcBody }
strictness
| [L _ match] <- unLoc $ mg_alts matches
, FunRhs{ mc_strictness = SrcStrict } <- m_ctxt match
= SrcStrict
| otherwise
= NoSrcStrict
tcMatchesCase :: (Outputable (body GhcRn)) =>
TcMatchCtxt body
-> TcSigmaType
-> MatchGroup GhcRn (Located (body GhcRn))
-> ExpRhoType
-> TcM (MatchGroup GhcTcId (Located (body GhcTcId)))
tcMatchesCase ctxt scrut_ty matches res_ty
= tcMatches ctxt [mkCheckExpType scrut_ty] res_ty matches
tcMatchLambda :: SDoc
-> TcMatchCtxt HsExpr
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> ExpRhoType
-> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId), HsWrapper)
tcMatchLambda herald match_ctxt match res_ty
= matchExpectedFunTys herald n_pats res_ty $ \ pat_tys rhs_ty ->
tcMatches match_ctxt pat_tys rhs_ty match
where
n_pats | isEmptyMatchGroup match = 1
| otherwise = matchGroupArity match
tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) -> TcRhoType
-> TcM (GRHSs GhcTcId (LHsExpr GhcTcId))
tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss (mkCheckExpType res_ty)
where
match_ctxt = MC { mc_what = PatBindRhs,
mc_body = tcBody }
tauifyMultipleMatches :: [LMatch id body]
-> [ExpType] -> TcM [ExpType]
tauifyMultipleMatches group exp_tys
| isSingletonMatchGroup group = return exp_tys
| otherwise = mapM tauifyExpType exp_tys
tcMatches :: (Outputable (body GhcRn)) => TcMatchCtxt body
-> [ExpSigmaType]
-> ExpRhoType
-> MatchGroup GhcRn (Located (body GhcRn))
-> TcM (MatchGroup GhcTcId (Located (body GhcTcId)))
data TcMatchCtxt body
= MC { mc_what :: HsMatchContext Name,
mc_body :: Located (body GhcRn)
-> ExpRhoType
-> TcM (Located (body GhcTcId)) }
tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches
, mg_origin = origin })
= do { rhs_ty:pat_tys <- tauifyMultipleMatches matches (rhs_ty:pat_tys)
; matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
; pat_tys <- mapM readExpType pat_tys
; rhs_ty <- readExpType rhs_ty
; return (MG { mg_alts = L l matches'
, mg_ext = MatchGroupTc pat_tys rhs_ty
, mg_origin = origin }) }
tcMatches _ _ _ (XMatchGroup nec) = noExtCon nec
tcMatch :: (Outputable (body GhcRn)) => TcMatchCtxt body
-> [ExpSigmaType]
-> ExpRhoType
-> LMatch GhcRn (Located (body GhcRn))
-> TcM (LMatch GhcTcId (Located (body GhcTcId)))
tcMatch ctxt pat_tys rhs_ty match
= wrapLocM (tc_match ctxt pat_tys rhs_ty) match
where
tc_match ctxt pat_tys rhs_ty
match@(Match { m_pats = pats, m_grhss = grhss })
= add_match_ctxt match $
do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $
tcGRHSs ctxt grhss rhs_ty
; return (Match { m_ext = noExtField
, m_ctxt = mc_what ctxt, m_pats = pats'
, m_grhss = grhss' }) }
tc_match _ _ _ (XMatch nec) = noExtCon nec
add_match_ctxt match thing_inside
= case mc_what ctxt of
LambdaExpr -> thing_inside
_ -> addErrCtxt (pprMatchInCtxt match) thing_inside
tcGRHSs :: TcMatchCtxt body -> GRHSs GhcRn (Located (body GhcRn)) -> ExpRhoType
-> TcM (GRHSs GhcTcId (Located (body GhcTcId)))
tcGRHSs ctxt (GRHSs _ grhss (L l binds)) res_ty
= do { (binds', grhss')
<- tcLocalBinds binds $
mapM (wrapLocM (tcGRHS ctxt res_ty)) grhss
; return (GRHSs noExtField grhss' (L l binds')) }
tcGRHSs _ (XGRHSs nec) _ = noExtCon nec
tcGRHS :: TcMatchCtxt body -> ExpRhoType -> GRHS GhcRn (Located (body GhcRn))
-> TcM (GRHS GhcTcId (Located (body GhcTcId)))
tcGRHS ctxt res_ty (GRHS _ guards rhs)
= do { (guards', rhs')
<- tcStmtsAndThen stmt_ctxt tcGuardStmt guards res_ty $
mc_body ctxt rhs
; return (GRHS noExtField guards' rhs') }
where
stmt_ctxt = PatGuard (mc_what ctxt)
tcGRHS _ _ (XGRHS nec) = noExtCon nec
tcDoStmts :: HsStmtContext Name
-> Located [LStmt GhcRn (LHsExpr GhcRn)]
-> ExpRhoType
-> TcM (HsExpr GhcTcId)
tcDoStmts ListComp (L l stmts) res_ty
= do { res_ty <- expTypeToType res_ty
; (co, elt_ty) <- matchExpectedListTy res_ty
; let list_ty = mkListTy elt_ty
; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts
(mkCheckExpType elt_ty)
; return $ mkHsWrapCo co (HsDo list_ty ListComp (L l stmts')) }
tcDoStmts DoExpr (L l stmts) res_ty
= do { stmts' <- tcStmts DoExpr tcDoStmt stmts res_ty
; res_ty <- readExpType res_ty
; return (HsDo res_ty DoExpr (L l stmts')) }
tcDoStmts MDoExpr (L l stmts) res_ty
= do { stmts' <- tcStmts MDoExpr tcDoStmt stmts res_ty
; res_ty <- readExpType res_ty
; return (HsDo res_ty MDoExpr (L l stmts')) }
tcDoStmts MonadComp (L l stmts) res_ty
= do { stmts' <- tcStmts MonadComp tcMcStmt stmts res_ty
; res_ty <- readExpType res_ty
; return (HsDo res_ty MonadComp (L l stmts')) }
tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)
tcBody :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
tcBody body res_ty
= do { traceTc "tcBody" (ppr res_ty)
; tcMonoExpr body res_ty
}
type TcExprStmtChecker = TcStmtChecker HsExpr ExpRhoType
type TcCmdStmtChecker = TcStmtChecker HsCmd TcRhoType
type TcStmtChecker body rho_type
= forall thing. HsStmtContext Name
-> Stmt GhcRn (Located (body GhcRn))
-> rho_type
-> (rho_type -> TcM thing)
-> TcM (Stmt GhcTcId (Located (body GhcTcId)), thing)
tcStmts :: (Outputable (body GhcRn)) => HsStmtContext Name
-> TcStmtChecker body rho_type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
-> TcM [LStmt GhcTcId (Located (body GhcTcId))]
tcStmts ctxt stmt_chk stmts res_ty
= do { (stmts', _) <- tcStmtsAndThen ctxt stmt_chk stmts res_ty $
const (return ())
; return stmts' }
tcStmtsAndThen :: (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 _ _ [] res_ty thing_inside
= do { thing <- thing_inside res_ty
; return ([], thing) }
tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt x (L l binds)) : stmts)
res_ty thing_inside
= do { (binds', (stmts',thing)) <- tcLocalBinds binds $
tcStmtsAndThen ctxt stmt_chk stmts res_ty thing_inside
; return (L loc (LetStmt x (L l binds')) : stmts', thing) }
tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
| ApplicativeStmt{} <- stmt
= do { (stmt', (stmts', thing)) <-
stmt_chk ctxt stmt res_ty $ \ res_ty' ->
tcStmtsAndThen ctxt stmt_chk stmts res_ty' $
thing_inside
; return (L loc stmt' : stmts', thing) }
| otherwise
= do { (stmt', (stmts', thing)) <-
setSrcSpan loc $
addErrCtxt (pprStmtInCtxt ctxt stmt) $
stmt_chk ctxt stmt res_ty $ \ res_ty' ->
popErrCtxt $
tcStmtsAndThen ctxt stmt_chk stmts res_ty' $
thing_inside
; return (L loc stmt' : stmts', thing) }
tcGuardStmt :: TcExprStmtChecker
tcGuardStmt _ (BodyStmt _ guard _ _) res_ty thing_inside
= do { guard' <- tcMonoExpr guard (mkCheckExpType boolTy)
; thing <- thing_inside res_ty
; return (BodyStmt boolTy guard' noSyntaxExpr noSyntaxExpr, thing) }
tcGuardStmt ctxt (BindStmt _ pat rhs _ _) res_ty thing_inside
= do { (rhs', rhs_ty) <- tcInferRhoNC rhs
; (pat', thing) <- tcPat_O (StmtCtxt ctxt) (lexprCtOrigin rhs)
pat (mkCheckExpType rhs_ty) $
thing_inside res_ty
; return (mkTcBindStmt pat' rhs', thing) }
tcGuardStmt _ stmt _ _
= pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
tcLcStmt :: TyCon
-> TcExprStmtChecker
tcLcStmt _ _ (LastStmt x body noret _) elt_ty thing_inside
= do { body' <- tcMonoExprNC body elt_ty
; thing <- thing_inside (panic "tcLcStmt: thing_inside")
; return (LastStmt x body' noret noSyntaxExpr, thing) }
tcLcStmt m_tc ctxt (BindStmt _ pat rhs _ _) elt_ty thing_inside
= do { pat_ty <- newFlexiTyVarTy liftedTypeKind
; rhs' <- tcMonoExpr rhs (mkCheckExpType $ mkTyConApp m_tc [pat_ty])
; (pat', thing) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
thing_inside elt_ty
; return (mkTcBindStmt pat' rhs', thing) }
tcLcStmt _ _ (BodyStmt _ rhs _ _) elt_ty thing_inside
= do { rhs' <- tcMonoExpr rhs (mkCheckExpType boolTy)
; thing <- thing_inside elt_ty
; return (BodyStmt boolTy rhs' noSyntaxExpr noSyntaxExpr, thing) }
tcLcStmt m_tc ctxt (ParStmt _ bndr_stmts_s _ _) elt_ty thing_inside
= do { (pairs', thing) <- loop bndr_stmts_s
; return (ParStmt unitTy pairs' noExpr noSyntaxExpr, thing) }
where
loop [] = do { thing <- thing_inside elt_ty
; return ([], thing) }
loop (ParStmtBlock x stmts names _ : pairs)
= do { (stmts', (ids, pairs', thing))
<- tcStmtsAndThen ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' ->
do { ids <- tcLookupLocalIds names
; (pairs', thing) <- loop pairs
; return (ids, pairs', thing) }
; return ( ParStmtBlock x stmts' ids noSyntaxExpr : pairs', thing ) }
loop (XParStmtBlock nec:_) = noExtCon nec
tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts
, trS_bndrs = bindersMap
, trS_by = by, trS_using = using }) elt_ty thing_inside
= do { let (bndr_names, n_bndr_names) = unzip bindersMap
unused_ty = pprPanic "tcLcStmt: inner ty" (ppr bindersMap)
; (stmts', (bndr_ids, by'))
<- tcStmtsAndThen (TransStmtCtxt ctxt) (tcLcStmt m_tc) stmts unused_ty $ \_ -> do
{ by' <- traverse tcInferRho by
; bndr_ids <- tcLookupLocalIds bndr_names
; return (bndr_ids, by') }
; let m_app ty = mkTyConApp m_tc [ty]
; let n_app = case form of
ThenForm -> (\ty -> ty)
_ -> m_app
by_arrow :: Type -> Type
by_arrow = case by' of
Nothing -> \ty -> ty
Just (_,e_ty) -> \ty -> (alphaTy `mkVisFunTy` e_ty) `mkVisFunTy` ty
tup_ty = mkBigCoreVarTupTy bndr_ids
poly_arg_ty = m_app alphaTy
poly_res_ty = m_app (n_app alphaTy)
using_poly_ty = mkInvForAllTy alphaTyVar $
by_arrow $
poly_arg_ty `mkVisFunTy` poly_res_ty
; using' <- tcPolyExpr using using_poly_ty
; let final_using = fmap (mkHsWrap (WpTyApp tup_ty)) using'
; let mk_n_bndr :: Name -> TcId -> TcId
mk_n_bndr n_bndr_name bndr_id = mkLocalIdOrCoVar n_bndr_name (n_app (idType bndr_id))
n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids
bindersMap' = bndr_ids `zip` n_bndr_ids
; thing <- tcExtendIdEnv n_bndr_ids (thing_inside elt_ty)
; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap'
, trS_by = fmap fst by', trS_using = final_using
, trS_ret = noSyntaxExpr
, trS_bind = noSyntaxExpr
, trS_fmap = noExpr
, trS_ext = unitTy
, trS_form = form }, thing) }
tcLcStmt _ _ stmt _ _
= pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
tcMcStmt :: TcExprStmtChecker
tcMcStmt _ (LastStmt x body noret return_op) res_ty thing_inside
= do { (body', return_op')
<- tcSyntaxOp MCompOrigin return_op [SynRho] res_ty $
\ [a_ty] ->
tcMonoExprNC body (mkCheckExpType a_ty)
; thing <- thing_inside (panic "tcMcStmt: thing_inside")
; return (LastStmt x body' noret return_op', thing) }
tcMcStmt ctxt (BindStmt _ pat rhs bind_op fail_op) res_ty thing_inside
= do { ((rhs', pat', thing, new_res_ty), bind_op')
<- tcSyntaxOp MCompOrigin bind_op
[SynRho, SynFun SynAny SynRho] res_ty $
\ [rhs_ty, pat_ty, new_res_ty] ->
do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty)
; (pat', thing) <- tcPat (StmtCtxt ctxt) pat
(mkCheckExpType pat_ty) $
thing_inside (mkCheckExpType new_res_ty)
; return (rhs', pat', thing, new_res_ty) }
; fail_op' <- tcMonadFailOp (MCompPatOrigin pat) pat' fail_op new_res_ty
; return (BindStmt new_res_ty pat' rhs' bind_op' fail_op', thing) }
tcMcStmt _ (BodyStmt _ rhs then_op guard_op) res_ty thing_inside
= do {
; ((thing, rhs', rhs_ty, guard_op'), then_op')
<- tcSyntaxOp MCompOrigin then_op [SynRho, SynRho] res_ty $
\ [rhs_ty, new_res_ty] ->
do { (rhs', guard_op')
<- tcSyntaxOp MCompOrigin guard_op [SynAny]
(mkCheckExpType rhs_ty) $
\ [test_ty] ->
tcMonoExpr rhs (mkCheckExpType test_ty)
; thing <- thing_inside (mkCheckExpType new_res_ty)
; return (thing, rhs', rhs_ty, guard_op') }
; return (BodyStmt rhs_ty rhs' then_op' guard_op', thing) }
tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap
, trS_by = by, trS_using = using, trS_form = form
, trS_ret = return_op, trS_bind = bind_op
, trS_fmap = fmap_op }) res_ty thing_inside
= do { m1_ty <- newFlexiTyVarTy typeToTypeKind
; m2_ty <- newFlexiTyVarTy typeToTypeKind
; tup_ty <- newFlexiTyVarTy liftedTypeKind
; by_e_ty <- newFlexiTyVarTy liftedTypeKind
; n_app <- case form of
ThenForm -> return (\ty -> ty)
_ -> do { n_ty <- newFlexiTyVarTy typeToTypeKind
; return (n_ty `mkAppTy`) }
; let by_arrow :: Type -> Type
by_arrow = case by of
Nothing -> \res -> res
Just {} -> \res -> (alphaTy `mkVisFunTy` by_e_ty) `mkVisFunTy` res
poly_arg_ty = m1_ty `mkAppTy` alphaTy
using_arg_ty = m1_ty `mkAppTy` tup_ty
poly_res_ty = m2_ty `mkAppTy` n_app alphaTy
using_res_ty = m2_ty `mkAppTy` n_app tup_ty
using_poly_ty = mkInvForAllTy alphaTyVar $
by_arrow $
poly_arg_ty `mkVisFunTy` poly_res_ty
; let (bndr_names, n_bndr_names) = unzip bindersMap
; (stmts', (bndr_ids, by', return_op')) <-
tcStmtsAndThen (TransStmtCtxt ctxt) tcMcStmt stmts
(mkCheckExpType using_arg_ty) $ \res_ty' -> do
{ by' <- case by of
Nothing -> return Nothing
Just e -> do { e' <- tcMonoExpr e
(mkCheckExpType by_e_ty)
; return (Just e') }
; bndr_ids <- tcLookupLocalIds bndr_names
; (_, return_op') <- tcSyntaxOp MCompOrigin return_op
[synKnownType (mkBigCoreVarTupTy bndr_ids)]
res_ty' $ \ _ -> return ()
; return (bndr_ids, by', return_op') }
; new_res_ty <- newFlexiTyVarTy liftedTypeKind
; (_, bind_op') <- tcSyntaxOp MCompOrigin bind_op
[ synKnownType using_res_ty
, synKnownType (n_app tup_ty `mkVisFunTy` new_res_ty) ]
res_ty $ \ _ -> return ()
; fmap_op' <- case form of
ThenForm -> return noExpr
_ -> fmap unLoc . tcPolyExpr (noLoc fmap_op) $
mkInvForAllTy alphaTyVar $
mkInvForAllTy betaTyVar $
(alphaTy `mkVisFunTy` betaTy)
`mkVisFunTy` (n_app alphaTy)
`mkVisFunTy` (n_app betaTy)
; using' <- tcPolyExpr using using_poly_ty
; let final_using = fmap (mkHsWrap (WpTyApp tup_ty)) using'
; let mk_n_bndr :: Name -> TcId -> TcId
mk_n_bndr n_bndr_name bndr_id = mkLocalIdOrCoVar n_bndr_name (n_app (idType bndr_id))
n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids
bindersMap' = bndr_ids `zip` n_bndr_ids
; thing <- tcExtendIdEnv n_bndr_ids $
thing_inside (mkCheckExpType new_res_ty)
; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap'
, trS_by = by', trS_using = final_using
, trS_ret = return_op', trS_bind = bind_op'
, trS_ext = n_app tup_ty
, trS_fmap = fmap_op', trS_form = form }, thing) }
tcMcStmt ctxt (ParStmt _ bndr_stmts_s mzip_op bind_op) res_ty thing_inside
= do { m_ty <- newFlexiTyVarTy typeToTypeKind
; let mzip_ty = mkInvForAllTys [alphaTyVar, betaTyVar] $
(m_ty `mkAppTy` alphaTy)
`mkVisFunTy`
(m_ty `mkAppTy` betaTy)
`mkVisFunTy`
(m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy])
; mzip_op' <- unLoc `fmap` tcPolyExpr (noLoc mzip_op) mzip_ty
; id_tys_s <- (mapM . mapM) (const (newFlexiTyVarTy liftedTypeKind))
[ names | ParStmtBlock _ _ names _ <- bndr_stmts_s ]
; let tup_tys = [ mkBigCoreTupTy id_tys | id_tys <- id_tys_s ]
tuple_ty = mk_tuple_ty tup_tys
; (((blocks', thing), inner_res_ty), bind_op')
<- tcSyntaxOp MCompOrigin bind_op
[ synKnownType (m_ty `mkAppTy` tuple_ty)
, SynFun (synKnownType tuple_ty) SynRho ] res_ty $
\ [inner_res_ty] ->
do { stuff <- loop m_ty (mkCheckExpType inner_res_ty)
tup_tys bndr_stmts_s
; return (stuff, inner_res_ty) }
; return (ParStmt inner_res_ty blocks' mzip_op' bind_op', thing) }
where
mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys
loop _ inner_res_ty [] [] = do { thing <- thing_inside inner_res_ty
; return ([], thing) }
loop m_ty inner_res_ty (tup_ty_in : tup_tys_in)
(ParStmtBlock x stmts names return_op : pairs)
= do { let m_tup_ty = m_ty `mkAppTy` tup_ty_in
; (stmts', (ids, return_op', pairs', thing))
<- tcStmtsAndThen ctxt tcMcStmt stmts (mkCheckExpType m_tup_ty) $
\m_tup_ty' ->
do { ids <- tcLookupLocalIds names
; let tup_ty = mkBigCoreVarTupTy ids
; (_, return_op') <-
tcSyntaxOp MCompOrigin return_op
[synKnownType tup_ty] m_tup_ty' $
\ _ -> return ()
; (pairs', thing) <- loop m_ty inner_res_ty tup_tys_in pairs
; return (ids, return_op', pairs', thing) }
; return (ParStmtBlock x stmts' ids return_op' : pairs', thing) }
loop _ _ _ _ = panic "tcMcStmt.loop"
tcMcStmt _ stmt _ _
= pprPanic "tcMcStmt: unexpected Stmt" (ppr stmt)
tcDoStmt :: TcExprStmtChecker
tcDoStmt _ (LastStmt x body noret _) res_ty thing_inside
= do { body' <- tcMonoExprNC body res_ty
; thing <- thing_inside (panic "tcDoStmt: thing_inside")
; return (LastStmt x body' noret noSyntaxExpr, thing) }
tcDoStmt ctxt (BindStmt _ pat rhs bind_op fail_op) res_ty thing_inside
= do {
((rhs', pat', new_res_ty, thing), bind_op')
<- tcSyntaxOp DoOrigin bind_op [SynRho, SynFun SynAny SynRho] res_ty $
\ [rhs_ty, pat_ty, new_res_ty] ->
do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty)
; (pat', thing) <- tcPat (StmtCtxt ctxt) pat
(mkCheckExpType pat_ty) $
thing_inside (mkCheckExpType new_res_ty)
; return (rhs', pat', new_res_ty, thing) }
; fail_op' <- tcMonadFailOp (DoPatOrigin pat) pat' fail_op new_res_ty
; return (BindStmt new_res_ty pat' rhs' bind_op' fail_op', thing) }
tcDoStmt ctxt (ApplicativeStmt _ pairs mb_join) res_ty thing_inside
= do { let tc_app_stmts ty = tcApplicativeStmts ctxt pairs ty $
thing_inside . mkCheckExpType
; ((pairs', body_ty, thing), mb_join') <- case mb_join of
Nothing -> (, Nothing) <$> tc_app_stmts res_ty
Just join_op ->
second Just <$>
(tcSyntaxOp DoOrigin join_op [SynRho] res_ty $
\ [rhs_ty] -> tc_app_stmts (mkCheckExpType rhs_ty))
; return (ApplicativeStmt body_ty pairs' mb_join', thing) }
tcDoStmt _ (BodyStmt _ rhs then_op _) res_ty thing_inside
= do {
; ((rhs', rhs_ty, thing), then_op')
<- tcSyntaxOp DoOrigin then_op [SynRho, SynRho] res_ty $
\ [rhs_ty, new_res_ty] ->
do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty)
; thing <- thing_inside (mkCheckExpType new_res_ty)
; return (rhs', rhs_ty, thing) }
; return (BodyStmt rhs_ty rhs' then_op' noSyntaxExpr, thing) }
tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
, recS_rec_ids = rec_names, recS_ret_fn = ret_op
, recS_mfix_fn = mfix_op, recS_bind_fn = bind_op })
res_ty thing_inside
= do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names
; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind
; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys
tup_ty = mkBigCoreTupTy tup_elt_tys
; tcExtendIdEnv tup_ids $ do
{ ((stmts', (ret_op', tup_rets)), stmts_ty)
<- tcInferInst $ \ exp_ty ->
tcStmtsAndThen ctxt tcDoStmt stmts exp_ty $ \ inner_res_ty ->
do { tup_rets <- zipWithM tcCheckId tup_names
(map mkCheckExpType tup_elt_tys)
; (_, ret_op')
<- tcSyntaxOp DoOrigin ret_op [synKnownType tup_ty]
inner_res_ty $ \_ -> return ()
; return (ret_op', tup_rets) }
; ((_, mfix_op'), mfix_res_ty)
<- tcInferInst $ \ exp_ty ->
tcSyntaxOp DoOrigin mfix_op
[synKnownType (mkVisFunTy tup_ty stmts_ty)] exp_ty $
\ _ -> return ()
; ((thing, new_res_ty), bind_op')
<- tcSyntaxOp DoOrigin bind_op
[ synKnownType mfix_res_ty
, synKnownType tup_ty `SynFun` SynRho ]
res_ty $
\ [new_res_ty] ->
do { thing <- thing_inside (mkCheckExpType new_res_ty)
; return (thing, new_res_ty) }
; let rec_ids = takeList rec_names tup_ids
; later_ids <- tcLookupLocalIds later_names
; traceTc "tcdo" $ vcat [ppr rec_ids <+> ppr (map idType rec_ids),
ppr later_ids <+> ppr (map idType later_ids)]
; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids
, recS_rec_ids = rec_ids, recS_ret_fn = ret_op'
, recS_mfix_fn = mfix_op', recS_bind_fn = bind_op'
, recS_ext = RecStmtTc
{ recS_bind_ty = new_res_ty
, recS_later_rets = []
, recS_rec_rets = tup_rets
, recS_ret_ty = stmts_ty} }, thing)
}}
tcDoStmt _ stmt _ _
= pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
tcMonadFailOp :: CtOrigin
-> LPat GhcTcId
-> SyntaxExpr GhcRn
-> TcType
-> TcRn (SyntaxExpr GhcTcId)
tcMonadFailOp orig pat fail_op res_ty
| isIrrefutableHsPat pat
= return noSyntaxExpr
| otherwise
= snd <$> (tcSyntaxOp orig fail_op [synKnownType stringTy]
(mkCheckExpType res_ty) $ \_ -> return ())
tcApplicativeStmts
:: HsStmtContext Name
-> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
-> ExpRhoType
-> (TcRhoType -> TcM t)
-> TcM ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], Type, t)
tcApplicativeStmts ctxt pairs rhs_ty thing_inside
= do { body_ty <- newFlexiTyVarTy liftedTypeKind
; let arity = length pairs
; ts <- replicateM (arity1) $ newInferExpTypeInst
; exp_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind
; pat_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind
; let fun_ty = mkVisFunTys pat_tys body_ty
; let (ops, args) = unzip pairs
; ops' <- goOps fun_ty (zip3 ops (ts ++ [rhs_ty]) exp_tys)
; args' <- mapM (goArg body_ty) (zip3 args pat_tys exp_tys)
; res <- tcExtendIdEnv (concatMap get_arg_bndrs args') $
thing_inside body_ty
; return (zip ops' args', body_ty, res) }
where
goOps _ [] = return []
goOps t_left ((op,t_i,exp_ty) : ops)
= do { (_, op')
<- tcSyntaxOp DoOrigin op
[synKnownType t_left, synKnownType exp_ty] t_i $
\ _ -> return ()
; t_i <- readExpType t_i
; ops' <- goOps t_i ops
; return (op' : ops') }
goArg :: Type -> (ApplicativeArg GhcRn, Type, Type)
-> TcM (ApplicativeArg GhcTcId)
goArg body_ty (ApplicativeArgOne
{ app_arg_pattern = pat
, arg_expr = rhs
, fail_operator = fail_op
, ..
}, pat_ty, exp_ty)
= setSrcSpan (combineSrcSpans (getLoc pat) (getLoc rhs)) $
addErrCtxt (pprStmtInCtxt ctxt (mkBindStmt pat rhs)) $
do { rhs' <- tcMonoExprNC rhs (mkCheckExpType exp_ty)
; (pat', _) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
return ()
; fail_op' <- tcMonadFailOp (DoPatOrigin pat) pat' fail_op body_ty
; return (ApplicativeArgOne
{ app_arg_pattern = pat'
, arg_expr = rhs'
, fail_operator = fail_op'
, .. }
) }
goArg _body_ty (ApplicativeArgMany x stmts ret pat, pat_ty, exp_ty)
= do { (stmts', (ret',pat')) <-
tcStmtsAndThen ctxt tcDoStmt stmts (mkCheckExpType exp_ty) $
\res_ty -> do
{ L _ ret' <- tcMonoExprNC (noLoc ret) res_ty
; (pat', _) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
return ()
; return (ret', pat')
}
; return (ApplicativeArgMany x stmts' ret' pat') }
goArg _body_ty (XApplicativeArg nec, _, _) = noExtCon nec
get_arg_bndrs :: ApplicativeArg GhcTcId -> [Id]
get_arg_bndrs (ApplicativeArgOne { app_arg_pattern = pat }) = collectPatBinders pat
get_arg_bndrs (ApplicativeArgMany { bv_pattern = pat }) = collectPatBinders pat
get_arg_bndrs (XApplicativeArg nec) = noExtCon nec
checkArgs :: Name -> MatchGroup GhcRn body -> TcM ()
checkArgs _ (MG { mg_alts = L _ [] })
= return ()
checkArgs fun (MG { mg_alts = L _ (match1:matches) })
| null bad_matches
= return ()
| otherwise
= failWithTc (vcat [ text "Equations for" <+> quotes (ppr fun) <+>
text "have different numbers of arguments"
, nest 2 (ppr (getLoc match1))
, nest 2 (ppr (getLoc (head bad_matches)))])
where
n_args1 = args_in_match match1
bad_matches = [m | m <- matches, args_in_match m /= n_args1]
args_in_match :: LMatch GhcRn body -> Int
args_in_match (L _ (Match { m_pats = pats })) = length pats
args_in_match (L _ (XMatch nec)) = noExtCon nec
checkArgs _ (XMatchGroup nec) = noExtCon nec