module TcMatches ( tcMatchesFun, tcGRHS, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
TcMatchCtxt(..), TcStmtChecker, TcExprStmtChecker, TcCmdStmtChecker,
tcStmts, tcStmtsAndThen, tcDoStmts, tcBody,
tcDoStmt, tcGuardStmt
) where
import TcExpr( tcSyntaxOp, tcInferSigmaNC, tcInferSigma
, tcCheckId, tcMonoExpr, tcMonoExprNC, tcPolyExpr )
import HsSyn
import TcRnMonad
import TcEnv
import TcPat
import TcMType
import TcType
import TcBinds
import TcUnify
import Name
import TysWiredIn
import Id
import TyCon
import TysPrim
import TcEvidence
import Outputable
import Util
import SrcLoc
import FastString
import DynFlags
import PrelNames (monadFailClassName)
import qualified GHC.LanguageExtensions as LangExt
import MkCore
import Control.Monad
#if __GLASGOW_HASKELL__ < 709
import Data.Traversable ( traverse )
#endif
#include "HsVersions.h"
tcMatchesFun :: Name
-> MatchGroup Name (LHsExpr Name)
-> TcSigmaType
-> TcM (HsWrapper, MatchGroup TcId (LHsExpr TcId))
tcMatchesFun fun_name matches exp_ty
= do {
traceTc "tcMatchesFun" (ppr fun_name $$ ppr exp_ty)
; checkArgs fun_name matches
; exp_ty <- tauifyMultipleMatches matches exp_ty
; (wrap_gen, (wrap_fun, group))
<- tcSkolemise (FunSigCtxt fun_name True) exp_ty $ \ _ exp_rho ->
do { (wrap_fun, pat_tys, rhs_ty)
<- matchExpectedFunTys herald arity exp_rho
; matches' <- tcMatches match_ctxt pat_tys rhs_ty matches
; return (wrap_fun, matches') }
; return (wrap_gen <.> wrap_fun, group) }
where
arity = matchGroupArity matches
herald = ptext (sLit "The equation(s) for")
<+> quotes (ppr fun_name) <+> ptext (sLit "have")
match_ctxt = MC { mc_what = FunRhs fun_name, mc_body = tcBody }
tcMatchesCase :: (Outputable (body Name)) =>
TcMatchCtxt body
-> TcSigmaType
-> MatchGroup Name (Located (body Name))
-> TcRhoType
-> TcM (MatchGroup TcId (Located (body TcId)))
tcMatchesCase ctxt scrut_ty matches res_ty
= do { res_ty <- tauifyMultipleMatches matches res_ty
; tcMatches ctxt [scrut_ty] res_ty matches }
tcMatchLambda :: SDoc
-> TcMatchCtxt HsExpr
-> MatchGroup Name (LHsExpr Name)
-> TcRhoType
-> TcM (HsWrapper, [TcSigmaType], MatchGroup TcId (LHsExpr TcId))
tcMatchLambda herald match_ctxt match res_ty
= do { res_ty <- tauifyMultipleMatches match res_ty
; (wrap, pat_tys, rhs_ty) <- matchExpectedFunTys herald n_pats res_ty
; match' <- tcMatches match_ctxt pat_tys rhs_ty match
; return (wrap, pat_tys, match') }
where
n_pats | isEmptyMatchGroup match = 1
| otherwise = matchGroupArity match
tcGRHSsPat :: GRHSs Name (LHsExpr Name) -> TcRhoType
-> TcM (GRHSs TcId (LHsExpr TcId))
tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss res_ty
where
match_ctxt = MC { mc_what = PatBindRhs,
mc_body = tcBody }
tauifyMultipleMatches :: MatchGroup id body
-> TcType
-> TcM TcType
tauifyMultipleMatches group exp_ty
| isSingletonMatchGroup group
= return exp_ty
| otherwise
= tauTvForReturnTv exp_ty
tcMatches :: (Outputable (body Name)) => TcMatchCtxt body
-> [TcSigmaType]
-> TcRhoType
-> MatchGroup Name (Located (body Name))
-> TcM (MatchGroup TcId (Located (body TcId)))
data TcMatchCtxt body
= MC { mc_what :: HsMatchContext Name,
mc_body :: Located (body Name)
-> TcRhoType
-> TcM (Located (body TcId)) }
tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches
, mg_origin = origin })
= do { matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
; return (MG { mg_alts = L l matches'
, mg_arg_tys = pat_tys
, mg_res_ty = rhs_ty
, mg_origin = origin }) }
tcMatch :: (Outputable (body Name)) => TcMatchCtxt body
-> [TcSigmaType]
-> TcRhoType
-> LMatch Name (Located (body Name))
-> TcM (LMatch TcId (Located (body TcId)))
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 _ pats maybe_rhs_sig grhss)
= add_match_ctxt match $
do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $
tc_grhss ctxt maybe_rhs_sig grhss rhs_ty
; return (Match NonFunBindMatch pats' Nothing grhss') }
tc_grhss ctxt Nothing grhss rhs_ty
= tcGRHSs ctxt grhss rhs_ty
tc_grhss _ (Just {}) _ _
= panic "tc_ghrss"
add_match_ctxt match thing_inside
= case mc_what ctxt of
LambdaExpr -> thing_inside
m_ctxt -> addErrCtxt (pprMatchInCtxt m_ctxt match) thing_inside
tcGRHSs :: TcMatchCtxt body -> GRHSs Name (Located (body Name)) -> TcRhoType
-> TcM (GRHSs TcId (Located (body TcId)))
tcGRHSs ctxt (GRHSs grhss (L l binds)) res_ty
= do { (binds', grhss')
<- tcLocalBinds binds $
mapM (wrapLocM (tcGRHS ctxt res_ty)) grhss
; return (GRHSs grhss' (L l binds')) }
tcGRHS :: TcMatchCtxt body -> TcRhoType -> GRHS Name (Located (body Name))
-> TcM (GRHS TcId (Located (body TcId)))
tcGRHS ctxt res_ty (GRHS guards rhs)
= do { (guards', rhs')
<- tcStmtsAndThen stmt_ctxt tcGuardStmt guards res_ty $
mc_body ctxt rhs
; return (GRHS guards' rhs') }
where
stmt_ctxt = PatGuard (mc_what ctxt)
tcDoStmts :: HsStmtContext Name
-> Located [LStmt Name (LHsExpr Name)]
-> TcRhoType
-> TcM (HsExpr TcId)
tcDoStmts ListComp (L l stmts) res_ty
= do { (co, elt_ty) <- matchExpectedListTy res_ty
; let list_ty = mkListTy elt_ty
; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts elt_ty
; return $ mkHsWrapCo co (HsDo ListComp (L l stmts') list_ty) }
tcDoStmts PArrComp (L l stmts) res_ty
= do { (co, elt_ty) <- matchExpectedPArrTy res_ty
; let parr_ty = mkPArrTy elt_ty
; stmts' <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts elt_ty
; return $ mkHsWrapCo co (HsDo PArrComp (L l stmts') parr_ty) }
tcDoStmts DoExpr (L l stmts) res_ty
= do { stmts' <- tcStmts DoExpr tcDoStmt stmts res_ty
; return (HsDo DoExpr (L l stmts') res_ty) }
tcDoStmts MDoExpr (L l stmts) res_ty
= do { stmts' <- tcStmts MDoExpr tcDoStmt stmts res_ty
; return (HsDo MDoExpr (L l stmts') res_ty) }
tcDoStmts MonadComp (L l stmts) res_ty
= do { stmts' <- tcStmts MonadComp tcMcStmt stmts res_ty
; return (HsDo MonadComp (L l stmts') res_ty) }
tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)
tcBody :: LHsExpr Name -> TcRhoType -> TcM (LHsExpr TcId)
tcBody body res_ty
= do { traceTc "tcBody" (ppr res_ty)
; tcMonoExpr body res_ty
}
type TcExprStmtChecker = TcStmtChecker HsExpr
type TcCmdStmtChecker = TcStmtChecker HsCmd
type TcStmtChecker body
= forall thing. HsStmtContext Name
-> Stmt Name (Located (body Name))
-> TcRhoType
-> (TcRhoType -> TcM thing)
-> TcM (Stmt TcId (Located (body TcId)), thing)
tcStmts :: (Outputable (body Name)) => HsStmtContext Name
-> TcStmtChecker body
-> [LStmt Name (Located (body Name))]
-> TcRhoType
-> TcM [LStmt TcId (Located (body TcId))]
tcStmts ctxt stmt_chk stmts res_ty
= do { (stmts', _) <- tcStmtsAndThen ctxt stmt_chk stmts res_ty $
const (return ())
; return stmts' }
tcStmtsAndThen :: (Outputable (body Name)) => HsStmtContext Name
-> TcStmtChecker body
-> [LStmt Name (Located (body Name))]
-> TcRhoType
-> (TcRhoType -> TcM thing)
-> TcM ([LStmt TcId (Located (body TcId))], thing)
tcStmtsAndThen _ _ [] res_ty thing_inside
= do { thing <- thing_inside res_ty
; return ([], thing) }
tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt (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 (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 boolTy
; thing <- thing_inside res_ty
; return (BodyStmt guard' noSyntaxExpr noSyntaxExpr boolTy, thing) }
tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside
= do { (rhs', rhs_ty) <- tcInferSigmaNC rhs
; (pat', thing) <- tcPat_O (StmtCtxt ctxt) (exprCtOrigin (unLoc rhs))
pat rhs_ty $
thing_inside res_ty
; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
tcGuardStmt _ stmt _ _
= pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
tcLcStmt :: TyCon
-> TcExprStmtChecker
tcLcStmt _ _ (LastStmt body noret _) elt_ty thing_inside
= do { body' <- tcMonoExprNC body elt_ty
; thing <- thing_inside (panic "tcLcStmt: thing_inside")
; return (LastStmt body' noret noSyntaxExpr, thing) }
tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) elt_ty thing_inside
= do { pat_ty <- newFlexiTyVarTy liftedTypeKind
; rhs' <- tcMonoExpr rhs (mkTyConApp m_tc [pat_ty])
; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
thing_inside elt_ty
; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
tcLcStmt _ _ (BodyStmt rhs _ _ _) elt_ty thing_inside
= do { rhs' <- tcMonoExpr rhs boolTy
; thing <- thing_inside elt_ty
; return (BodyStmt rhs' noSyntaxExpr noSyntaxExpr boolTy, thing) }
tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s _ _) elt_ty thing_inside
= do { (pairs', thing) <- loop bndr_stmts_s
; return (ParStmt pairs' noSyntaxExpr noSyntaxExpr, thing) }
where
loop [] = do { thing <- thing_inside elt_ty
; return ([], thing) }
loop (ParStmtBlock 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 stmts' ids noSyntaxExpr : pairs', thing ) }
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 tcInferSigma 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 `mkFunTy` e_ty) `mkFunTy` ty
tup_ty = mkBigCoreVarTupTy bndr_ids
poly_arg_ty = m_app alphaTy
poly_res_ty = m_app (n_app alphaTy)
using_poly_ty = mkNamedForAllTy alphaTyVar Invisible $
by_arrow $
poly_arg_ty `mkFunTy` poly_res_ty
; using' <- tcPolyExpr using using_poly_ty
; let final_using = fmap (HsWrap (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 (emptyTransStmt { trS_stmts = stmts', trS_bndrs = bindersMap'
, trS_by = fmap fst by', trS_using = final_using
, trS_form = form }, thing) }
tcLcStmt _ _ stmt _ _
= pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
tcMcStmt :: TcExprStmtChecker
tcMcStmt _ (LastStmt body noret return_op) res_ty thing_inside
= do { a_ty <- newFlexiTyVarTy liftedTypeKind
; return_op' <- tcSyntaxOp MCompOrigin return_op
(a_ty `mkFunTy` res_ty)
; body' <- tcMonoExprNC body a_ty
; thing <- thing_inside (panic "tcMcStmt: thing_inside")
; return (LastStmt body' noret return_op', thing) }
tcMcStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
= do { rhs_ty <- newFlexiTyVarTy liftedTypeKind
; pat_ty <- newFlexiTyVarTy liftedTypeKind
; new_res_ty <- newFlexiTyVarTy liftedTypeKind
; bind_op' <- tcSyntaxOp MCompOrigin bind_op
(mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty)
; rhs' <- tcMonoExprNC rhs rhs_ty
; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
thing_inside new_res_ty
; fail_op' <- tcMonadFailOp (MCompPatOrigin pat) pat' fail_op new_res_ty
; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
tcMcStmt _ (BodyStmt rhs then_op guard_op _) res_ty thing_inside
= do {
test_ty <- newFlexiTyVarTy liftedTypeKind
; rhs_ty <- newFlexiTyVarTy liftedTypeKind
; new_res_ty <- newFlexiTyVarTy liftedTypeKind
; rhs' <- tcMonoExpr rhs test_ty
; guard_op' <- tcSyntaxOp MCompOrigin guard_op
(mkFunTy test_ty rhs_ty)
; then_op' <- tcSyntaxOp MCompOrigin then_op
(mkFunTys [rhs_ty, new_res_ty] res_ty)
; thing <- thing_inside new_res_ty
; return (BodyStmt rhs' then_op' guard_op' rhs_ty, 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 { let star_star_kind = liftedTypeKind `mkFunTy` liftedTypeKind
; m1_ty <- newFlexiTyVarTy star_star_kind
; m2_ty <- newFlexiTyVarTy star_star_kind
; tup_ty <- newFlexiTyVarTy liftedTypeKind
; by_e_ty <- newFlexiTyVarTy liftedTypeKind
; n_app <- case form of
ThenForm -> return (\ty -> ty)
_ -> do { n_ty <- newFlexiTyVarTy star_star_kind
; return (n_ty `mkAppTy`) }
; let by_arrow :: Type -> Type
by_arrow = case by of
Nothing -> \res -> res
Just {} -> \res -> (alphaTy `mkFunTy` by_e_ty) `mkFunTy` 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 = mkNamedForAllTy alphaTyVar Invisible $
by_arrow $
poly_arg_ty `mkFunTy` poly_res_ty
; let (bndr_names, n_bndr_names) = unzip bindersMap
; (stmts', (bndr_ids, by', return_op')) <-
tcStmtsAndThen (TransStmtCtxt ctxt) tcMcStmt stmts using_arg_ty $ \res_ty' -> do
{ by' <- case by of
Nothing -> return Nothing
Just e -> do { e' <- tcMonoExpr e by_e_ty; return (Just e') }
; bndr_ids <- tcLookupLocalIds bndr_names
; return_op' <- tcSyntaxOp MCompOrigin return_op $
(mkBigCoreVarTupTy bndr_ids) `mkFunTy` res_ty'
; return (bndr_ids, by', return_op') }
; new_res_ty <- newFlexiTyVarTy liftedTypeKind
; bind_op' <- tcSyntaxOp MCompOrigin bind_op $
using_res_ty `mkFunTy` (n_app tup_ty `mkFunTy` new_res_ty)
`mkFunTy` res_ty
; fmap_op' <- case form of
ThenForm -> return noSyntaxExpr
_ -> fmap unLoc . tcPolyExpr (noLoc fmap_op) $
mkNamedForAllTy alphaTyVar Invisible $
mkNamedForAllTy betaTyVar Invisible $
(alphaTy `mkFunTy` betaTy)
`mkFunTy` (n_app alphaTy)
`mkFunTy` (n_app betaTy)
; using' <- tcPolyExpr using using_poly_ty
; let final_using = fmap (HsWrap (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 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_fmap = fmap_op', trS_form = form }, thing) }
tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op) res_ty thing_inside
= do { let star_star_kind = liftedTypeKind `mkFunTy` liftedTypeKind
; m_ty <- newFlexiTyVarTy star_star_kind
; let mzip_ty = mkInvForAllTys [alphaTyVar, betaTyVar] $
(m_ty `mkAppTy` alphaTy)
`mkFunTy`
(m_ty `mkAppTy` betaTy)
`mkFunTy`
(m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy])
; mzip_op' <- unLoc `fmap` tcPolyExpr (noLoc mzip_op) mzip_ty
; (blocks', thing) <- loop m_ty bndr_stmts_s
; let tys = [ mkBigCoreVarTupTy bs | ParStmtBlock _ bs _ <- blocks']
tuple_ty = mk_tuple_ty tys
; bind_op' <- tcSyntaxOp MCompOrigin bind_op $
(m_ty `mkAppTy` tuple_ty)
`mkFunTy` (tuple_ty `mkFunTy` res_ty)
`mkFunTy` res_ty
; return (ParStmt blocks' mzip_op' bind_op', thing) }
where
mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys
loop _ [] = do { thing <- thing_inside res_ty
; return ([], thing) }
loop m_ty (ParStmtBlock stmts names return_op : pairs)
= do {
id_tys <- mapM (const (newFlexiTyVarTy liftedTypeKind)) names
; let m_tup_ty = m_ty `mkAppTy` mkBigCoreTupTy id_tys
; (stmts', (ids, return_op', pairs', thing))
<- tcStmtsAndThen ctxt tcMcStmt stmts m_tup_ty $ \m_tup_ty' ->
do { ids <- tcLookupLocalIds names
; let tup_ty = mkBigCoreVarTupTy ids
; return_op' <- tcSyntaxOp MCompOrigin return_op
(tup_ty `mkFunTy` m_tup_ty')
; (pairs', thing) <- loop m_ty pairs
; return (ids, return_op', pairs', thing) }
; return (ParStmtBlock stmts' ids return_op' : pairs', thing) }
tcMcStmt _ stmt _ _
= pprPanic "tcMcStmt: unexpected Stmt" (ppr stmt)
tcDoStmt :: TcExprStmtChecker
tcDoStmt _ (LastStmt body noret _) res_ty thing_inside
= do { body' <- tcMonoExprNC body res_ty
; thing <- thing_inside (panic "tcDoStmt: thing_inside")
; return (LastStmt body' noret noSyntaxExpr, thing) }
tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
= do {
rhs_ty <- newFlexiTyVarTy liftedTypeKind
; pat_ty <- newFlexiTyVarTy liftedTypeKind
; new_res_ty <- newFlexiTyVarTy liftedTypeKind
; bind_op' <- tcSyntaxOp DoOrigin bind_op
(mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty)
; rhs' <- tcMonoExprNC rhs rhs_ty
; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
thing_inside new_res_ty
; fail_op' <- tcMonadFailOp (DoPatOrigin pat) pat' fail_op new_res_ty
; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
tcDoStmt ctxt (ApplicativeStmt pairs mb_join _) res_ty thing_inside
= do {
; (mb_join', rhs_ty) <- case mb_join of
Nothing -> return (Nothing, res_ty)
Just join_op ->
do { rhs_ty <- newFlexiTyVarTy liftedTypeKind
; join_op' <- tcSyntaxOp DoOrigin join_op
(mkFunTy rhs_ty res_ty)
; return (Just join_op', rhs_ty) }
; (pairs', body_ty, thing) <-
tcApplicativeStmts ctxt pairs rhs_ty thing_inside
; return (ApplicativeStmt pairs' mb_join' body_ty, thing) }
tcDoStmt _ (BodyStmt rhs then_op _ _) res_ty thing_inside
= do {
rhs_ty <- newFlexiTyVarTy liftedTypeKind
; new_res_ty <- newFlexiTyVarTy liftedTypeKind
; then_op' <- tcSyntaxOp DoOrigin then_op
(mkFunTys [rhs_ty, new_res_ty] res_ty)
; rhs' <- tcMonoExprNC rhs rhs_ty
; thing <- thing_inside new_res_ty
; return (BodyStmt rhs' then_op' noSyntaxExpr rhs_ty, 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_ty <- newFlexiTyVarTy liftedTypeKind
; (stmts', (ret_op', tup_rets))
<- tcStmtsAndThen ctxt tcDoStmt stmts stmts_ty $ \ inner_res_ty ->
do { tup_rets <- zipWithM tcCheckId tup_names tup_elt_tys
; ret_op' <- tcSyntaxOp DoOrigin ret_op (mkFunTy tup_ty inner_res_ty)
; return (ret_op', tup_rets) }
; mfix_res_ty <- newFlexiTyVarTy liftedTypeKind
; mfix_op' <- tcSyntaxOp DoOrigin mfix_op
(mkFunTy (mkFunTy tup_ty stmts_ty) mfix_res_ty)
; new_res_ty <- newFlexiTyVarTy liftedTypeKind
; bind_op' <- tcSyntaxOp DoOrigin bind_op
(mkFunTys [mfix_res_ty, mkFunTy tup_ty new_res_ty] res_ty)
; thing <- thing_inside 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_later_rets = [], recS_rec_rets = tup_rets
, recS_ret_ty = stmts_ty }, thing)
}}
tcDoStmt _ stmt _ _
= pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
tcMonadFailOp :: CtOrigin
-> LPat TcId
-> HsExpr Name
-> TcType
-> TcRn (HsExpr TcId)
tcMonadFailOp orig pat fail_op res_ty
| isIrrefutableHsPat pat
= return noSyntaxExpr
| otherwise
= do {
rebindableSyntax <- xoptM LangExt.RebindableSyntax
; desugarFlag <- xoptM LangExt.MonadFailDesugaring
; missingWarning <- woptM Opt_WarnMissingMonadFailInstance
; if | rebindableSyntax && (desugarFlag || missingWarning)
-> warnRebindableClash pat
| not desugarFlag && missingWarning
-> emitMonadFailConstraint pat res_ty
| otherwise
-> return ()
; tcSyntaxOp orig fail_op (mkFunTy stringTy res_ty) }
emitMonadFailConstraint :: LPat TcId -> TcType -> TcRn ()
emitMonadFailConstraint pat res_ty
= do {
(_co, (monad_ty, _arg_ty)) <- matchExpectedAppTy res_ty
; monadFailClass <- tcLookupClass monadFailClassName
; _ <- emitWanted (FailablePattern pat)
(mkClassPred monadFailClass [monad_ty])
; return () }
warnRebindableClash :: LPat TcId -> TcRn ()
warnRebindableClash pattern = addWarnAt (getLoc pattern)
(text "The failable pattern" <+> quotes (ppr pattern)
$$
nest 2 (text "is used together with -XRebindableSyntax."
<+> text "If this is intentional,"
$$
text "compile with -fno-warn-missing-monadfail-instance."))
tcApplicativeStmts
:: HsStmtContext Name
-> [(HsExpr Name, ApplicativeArg Name Name)]
-> Type
-> (Type -> TcM t)
-> TcM ([(HsExpr TcId, ApplicativeArg TcId TcId)], Type, t)
tcApplicativeStmts ctxt pairs rhs_ty thing_inside
= do { body_ty <- newFlexiTyVarTy liftedTypeKind
; let arity = length pairs
; ts <- replicateM (arity1) $ newFlexiTyVarTy liftedTypeKind
; exp_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind
; pat_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind
; let fun_ty = mkFunTys pat_tys body_ty
; let (ops, args) = unzip pairs
; ops' <- goOps fun_ty (zip3 ops (ts ++ [rhs_ty]) exp_tys)
; (args', thing) <- goArgs (zip3 args pat_tys exp_tys) $
thing_inside body_ty
; return (zip ops' args', body_ty, thing) }
where
goOps _ [] = return []
goOps t_left ((op,t_i,exp_ty) : ops)
= do { op' <- tcSyntaxOp DoOrigin op (mkFunTys [t_left, exp_ty] t_i)
; ops' <- goOps t_i ops
; return (op' : ops') }
goArgs
:: [(ApplicativeArg Name Name, Type, Type)]
-> TcM t
-> TcM ([ApplicativeArg TcId TcId], t)
goArgs [] thing_inside
= do { thing <- thing_inside
; return ([],thing)
}
goArgs ((ApplicativeArgOne pat rhs, pat_ty, exp_ty) : rest) thing_inside
= do { let stmt :: ExprStmt Name
stmt = BindStmt pat rhs noSyntaxExpr noSyntaxExpr
; setSrcSpan (combineSrcSpans (getLoc pat) (getLoc rhs)) $
addErrCtxt (pprStmtInCtxt ctxt stmt) $
do { rhs' <- tcMonoExprNC rhs exp_ty
; (pat',(pairs, thing)) <-
tcPat (StmtCtxt ctxt) pat pat_ty $
popErrCtxt $
goArgs rest thing_inside
; return (ApplicativeArgOne pat' rhs' : pairs, thing) } }
goArgs ((ApplicativeArgMany stmts ret pat, pat_ty, exp_ty) : rest)
thing_inside
= do { (stmts', (ret',pat',rest',thing)) <-
tcStmtsAndThen ctxt tcDoStmt stmts exp_ty $ \res_ty -> do
{ L _ ret' <- tcMonoExprNC (noLoc ret) res_ty
; (pat',(rest', thing)) <-
tcPat (StmtCtxt ctxt) pat pat_ty $
goArgs rest thing_inside
; return (ret', pat', rest', thing)
}
; return (ApplicativeArgMany stmts' ret' pat' : rest', thing) }
checkArgs :: Name -> MatchGroup Name body -> TcM ()
checkArgs _ (MG { mg_alts = L _ [] })
= return ()
checkArgs fun (MG { mg_alts = L _ (match1:matches) })
| null bad_matches
= return ()
| otherwise
= failWithTc (vcat [ptext (sLit "Equations for") <+> quotes (ppr fun) <+>
ptext (sLit "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 Name body -> Int
args_in_match (L _ (Match _ pats _ _)) = length pats