import HsSyn
import TcHsSyn ( TcCmd, 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 )
= 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
\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)
#include "HsVersions.h"
-import {-# SOURCE #-} TcMatches ( tcGRHSs, tcMatchesFun )
+import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
import {-# SOURCE #-} TcExpr ( tcCheckSigma, tcCheckRho )
import CmdLineOpts ( DynFlag(Opt_NoMonomorphismRestriction) )
import HsSyn ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..),
- Match(..), HsMatchContext(..), mkMonoBind,
+ Match(..), mkMonoBind,
collectMonoBinders, andMonoBinds,
collectSigTysFromMonoBinds
)
let
complete_it = addSrcLoc locn $
addErrCtxt (patMonoBindsCtxt bind) $
- tcGRHSs PatBindRhs grhss (Check pat_ty) `thenM` \ grhss' ->
+ tcGRHSsPat grhss (Check pat_ty) `thenM` \ grhss' ->
returnM (PatMonoBind pat' grhss' locn, ids)
in
returnM (complete_it, if isRec is_rec then ids else emptyBag)
import qualified DsMeta
#endif
-import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..), recBindFields )
+import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..), recBindFields,
+ HsMatchContext(..) )
import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds )
import TcHsSyn ( TcExpr, TcRecordBinds, hsLitType, mkHsDictApp, mkHsTyApp, mkHsLet, (<$>) )
import TcRnMonad
tcLookupTyCon, tcLookupDataCon, tcLookupId, checkProcLevel
)
import TcArrows ( tcProc )
-import TcMatches ( tcMatchesCase, tcMatchLambda, tcDoStmts, tcThingWithSig )
+import TcMatches ( tcMatchesCase, tcMatchLambda, tcDoStmts, tcThingWithSig, TcMatchCtxt(..) )
import TcMonoType ( tcHsSigType, UserTypeCtxt(..) )
import TcPat ( badFieldCon )
import TcMType ( tcInstTyVars, tcInstType, newTyVarTy, newTyVarTys, zonkTcType )
-- (x:xs) -> ...
-- will report that map is applied to too few arguments
- tcMatchesCase matches res_ty `thenM` \ (scrut_ty, matches') ->
+ tcMatchesCase match_ctxt matches 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 = tcMonoExpr }
tcMonoExpr (HsIf pred b1 b2 src_loc) res_ty
= addSrcLoc src_loc $
_interface_ TcMatches 2
_exports_
-TcMatches tcGRHSs tcMatchesFun;
+TcMatches tcGRHSsPat tcMatchesFun;
_declarations_
-2 tcGRHSs _:_ _forall_ [s] =>
- HsExpr.HsMatchContext Name.Name
- -> RnHsSyn.RenamedGRHSs
+2 tcGRHSsPat _:_ _forall_ [s] =>
+ RnHsSyn.RenamedGRHSs
-> TcType.TcType
-> TcMonad.TcM s (TcHsSyn.TcGRHSs, TcMonad.LIE) ;;
3 tcMatchesFun _:_ _forall_ [s] =>
__interface TcMatches 1 0 where
-__export TcMatches tcGRHSs tcMatchesFun;
-1 tcGRHSs :: HsExpr.HsMatchContext Name.Name
- -> RnHsSyn.RenamedGRHSs
+__export TcMatches tcGRHSsPat tcMatchesFun;
+1 tcGRHSsPat :: RnHsSyn.RenamedGRHSs
-> TcUnify.Expected TcType.TcType
-> TcRnTypes.TcM TcHsSyn.TcGRHSs ;
1 tcMatchesFun ::
module TcMatches where
-tcGRHSs :: HsExpr.HsMatchContext Name.Name
- -> RnHsSyn.RenamedGRHSs
+tcGRHSsPat :: RnHsSyn.RenamedGRHSs
-> TcUnify.Expected TcType.TcType
-> TcRnTypes.TcM TcHsSyn.TcGRHSs
\section[TcMatches]{Typecheck some @Matches@}
\begin{code}
-module TcMatches ( tcMatchesFun, tcMatchesCase, tcMatchLambda, matchCtxt,
- tcDoStmts, tcStmtsAndThen, tcStmts, tcGRHSs, tcThingWithSig,
+module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
+ matchCtxt,
+ tcDoStmts, tcStmtsAndThen, tcStmts, tcThingWithSig,
tcMatchPats,
- TcStmtCtxt(..)
+ TcStmtCtxt(..), TcMatchCtxt(..)
) where
#include "HsVersions.h"
-- may show up as something wrong with the (non-existent) type signature
-- No need to zonk expected_ty, because subFunTys does that on the fly
- tcMatches (FunRhs fun_name) matches expected_ty
+ tcMatches match_ctxt matches expected_ty
+ where
+ match_ctxt = MC { mc_what = FunRhs fun_name,
+ mc_body = tcMonoExpr }
\end{code}
@tcMatchesCase@ doesn't do the argument-count check because the
parser guarantees that each equation has exactly one argument.
\begin{code}
-tcMatchesCase :: [RenamedMatch] -- The case alternatives
+tcMatchesCase :: TcMatchCtxt -- Case context
+ -> [RenamedMatch] -- The case alternatives
-> Expected TcRhoType -- Type of whole case expressions
-> TcM (TcRhoType, -- Inferred type of the scrutinee
[TcMatch]) -- Translated alternatives
-tcMatchesCase matches (Check expr_ty)
+tcMatchesCase ctxt matches (Check expr_ty)
= -- This case is a bit yukky, because it prevents the
-- scrutinee being higher-ranked, which might just possible
-- matter if we were seq'ing on it. But it's awkward to fix.
newTyVarTy openTypeKind `thenM` \ scrut_ty ->
- tcMatches CaseAlt matches (Check (mkFunTy scrut_ty expr_ty)) `thenM` \ matches' ->
+ tcMatches ctxt matches (Check (mkFunTy scrut_ty expr_ty)) `thenM` \ matches' ->
returnM (scrut_ty, matches')
-tcMatchesCase matches (Infer hole)
+tcMatchesCase ctxt matches (Infer hole)
= newHole `thenM` \ fun_hole ->
- tcMatches CaseAlt matches (Infer fun_hole) `thenM` \ matches' ->
+ tcMatches ctxt matches (Infer fun_hole) `thenM` \ matches' ->
readMutVar fun_hole `thenM` \ fun_ty ->
-- The result of tcMatches is bound to be a function type
unifyFunTy fun_ty `thenM` \ (scrut_ty, res_ty) ->
tcMatchLambda :: RenamedMatch -> Expected TcRhoType -> TcM TcMatch
-tcMatchLambda match res_ty = tcMatch LambdaExpr match res_ty
+tcMatchLambda match res_ty = tcMatch match_ctxt match res_ty
+ where
+ match_ctxt = MC { mc_what = LambdaExpr,
+ mc_body = tcMonoExpr }
\end{code}
+@tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
+
+\begin{code}
+tcGRHSsPat :: RenamedGRHSs
+ -> Expected TcRhoType
+ -> TcM TcGRHSs
+tcGRHSsPat grhss exp_ty = tcGRHSs match_ctxt grhss exp_ty
+ where
+ match_ctxt = MC { mc_what = PatBindRhs,
+ mc_body = tcMonoExpr }
+\end{code}
\begin{code}
-tcMatches :: RenamedMatchContext
+data TcMatchCtxt
+ = MC { mc_what :: RenamedMatchContext, -- What kind of thing this is
+ mc_body :: RenamedHsExpr -> Expected TcRhoType -> TcM TcExpr } -- Type checker for a body of an alternative
+
+tcMatches :: TcMatchCtxt
-> [RenamedMatch]
-> Expected TcRhoType
-> TcM [TcMatch]
%************************************************************************
\begin{code}
-tcMatch :: RenamedMatchContext
+tcMatch :: TcMatchCtxt
-> RenamedMatch
-> Expected TcRhoType -- Expected result-type of the Match.
-- Early unification with this guy gives better error messages
tcMatch ctxt match@(Match pats maybe_rhs_sig grhss) expected_ty
= addSrcLoc (getMatchLoc match) $ -- At one stage I removed this;
- addErrCtxt (matchCtxt ctxt match) $ -- I'm not sure why, so I put it back
+ addErrCtxt (matchCtxt (mc_what ctxt) match) $ -- I'm not sure why, so I put it back
subFunTys pats expected_ty $ \ pats_w_tys rhs_ty ->
-- This is the unique place we call subFunTys
-- The point is that if expected_y is a "hole", we want
lift_stmt (ResultStmt e l) = ResultStmt (co_fn <$> e) l
lift_stmt stmt = stmt
-
-tcGRHSs :: RenamedMatchContext -> RenamedGRHSs
+
+tcGRHSs :: TcMatchCtxt -> RenamedGRHSs
-> Expected TcRhoType
-> TcM TcGRHSs
-- not a Expected TcType, a decision we could revisit if necessary
tcGRHSs ctxt (GRHSs [GRHS [ResultStmt rhs loc1] loc2] binds _) exp_ty
= tcBindsAndThen glueBindsOnGRHSs binds $
- tcMonoExpr rhs exp_ty `thenM` \ rhs' ->
+ mc_body ctxt rhs exp_ty `thenM` \ rhs' ->
readExpectedType exp_ty `thenM` \ exp_ty' ->
returnM (GRHSs [GRHS [ResultStmt rhs' loc1] loc2] EmptyBinds exp_ty')
-- a monotype. Reason: it makes tcStmts much easier,
-- and even a one-armed guard has a notional second arm
let
- stmt_ctxt = SC { sc_what = PatGuard ctxt,
+ stmt_ctxt = SC { sc_what = PatGuard (mc_what ctxt),
sc_rhs = tcCheckRho,
- sc_body = \ body -> tcCheckRho body exp_ty',
+ sc_body = sc_body,
sc_ty = exp_ty' }
+ sc_body body = mc_body ctxt body (Check exp_ty')
tc_grhs (GRHS guarded locn)
= addSrcLoc locn $
projects / ghc-hetmet.git / commitdiff