import {-# SOURCE #-} TcExpr( tcCheckRho )
import HsSyn
-import TcHsSyn ( TcCmd, TcCmdTop, TcExpr, TcPat, mkHsLet )
+import TcHsSyn ( TcCmdTop, TcExpr, TcPat, mkHsLet )
-import TcMatches ( TcStmtCtxt(..), tcMatchPats, matchCtxt, tcStmts )
+import TcMatches ( TcStmtCtxt(..), tcMatchPats, matchCtxt, tcStmts,
+ TcMatchCtxt(..), tcMatchesCase )
import TcType ( TcType, TcTauType, TcRhoType, mkFunTys, mkTyConApp,
mkTyVarTy, mkAppTys, tcSplitTyConApp_maybe, tcEqType )
-import TcMType ( newTyVar, newTyVarTy, newTyVarTys, newSigTyVar, zonkTcType )
+import TcMType ( newTyVarTy, newTyVarTys, newSigTyVar, zonkTcType )
import TcBinds ( tcBindsAndThen )
import TcSimplify ( tcSimplifyCheck )
import TcUnify ( Expected(..), checkSigTyVarsWrt, zapExpectedTo )
import VarSet
import Type ( Kind,
mkArrowKinds, liftedTypeKind, openTypeKind, tyVarsOfTypes )
-import RnHsSyn ( RenamedHsExpr, RenamedPat, RenamedHsCmd, RenamedHsCmdTop )
+import RnHsSyn ( RenamedHsExpr, RenamedPat, RenamedHsCmdTop )
import Outputable
import Util ( lengthAtLeast )
= tcBindsAndThen HsLet binds $
tcCmd env body res_ty
+tcCmd env in_cmd@(HsCase scrut matches src_loc) (stk, res_ty)
+ = addSrcLoc src_loc $
+ addErrCtxt (cmdCtxt in_cmd) $
+ tcMatchesCase match_ctxt matches (Check res_ty)
+ `thenM` \ (scrut_ty, matches') ->
+ addErrCtxt (caseScrutCtxt scrut) (
+ tcCheckRho scrut scrut_ty
+ ) `thenM` \ scrut' ->
+ returnM (HsCase scrut' matches' src_loc)
+ where
+ match_ctxt = MC { mc_what = CaseAlt,
+ mc_body = mc_body }
+ mc_body body (Check res_ty') = tcCmd env body (stk, res_ty')
+
tcCmd env (HsIf pred b1 b2 src_loc) res_ty
= addSrcLoc src_loc $
do { pred' <- tcCheckRho pred boolTy
HsHigherOrderApp -> tc
HsFirstOrderApp -> popArrowBinders tc
+-------------------------------------------
+-- Command application
+
+tcCmd env cmd@(HsApp fun arg) (cmd_stk, res_ty)
+ = addErrCtxt (cmdCtxt cmd) $
+ do { arg_ty <- newTyVarTy openTypeKind
+
+ ; fun' <- tcCmd env fun (arg_ty:cmd_stk, res_ty)
+
+ ; arg' <- tcCheckRho arg arg_ty
+
+ ; return (HsApp fun' arg') }
-------------------------------------------
-- Lambda
\begin{code}
cmdCtxt cmd = ptext SLIT("In the command:") <+> ppr cmd
+caseScrutCtxt cmd
+ = hang (ptext SLIT("In the scrutinee of a case command:")) 4 (ppr cmd)
+
nonEmptyCmdStkErr cmd
= hang (ptext SLIT("Non-empty command stack at command:"))
4 (ppr cmd)