Commit dbaa3bb3 authored by ross's avatar ross

[project @ 2003-09-20 17:26:46 by ross]

Re-arrange the interface to TcMatches to allow typechecking of case
commands (part of arrow notation):

* replace the export of the internal tcGRHSs with a more specific
  tcGRHSsPat for checking PatMonoBinds.

* generalize match contexts in the same way as stmt contexts, to include
  a typechecker for the bodies of alts.

This should probably be reviewed, but I hope it can make it into STABLE
after a while.
parent 71d25e0a
......@@ -13,7 +13,8 @@ import {-# SOURCE #-} TcExpr( tcCheckRho )
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 )
......@@ -99,6 +100,20 @@ tcCmd env (HsLet binds body) res_ty
= 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
......@@ -322,6 +337,9 @@ arrowTyConKind = mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind
\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)
......
......@@ -8,12 +8,12 @@ module TcBinds ( tcBindsAndThen, tcTopBinds, tcMonoBinds, tcSpecSigs ) where
#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
)
......@@ -719,7 +719,7 @@ tcMonoBinds mbinds tc_ty_sigs is_rec
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)
......
......@@ -17,7 +17,8 @@ import Name ( isExternalName )
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
......@@ -34,7 +35,7 @@ import TcEnv ( tcLookupClass, tcLookupGlobal_maybe, tcLookup,
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 )
......@@ -257,13 +258,16 @@ tcMonoExpr in_expr@(HsCase scrut matches src_loc) res_ty
-- (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
......
......@@ -4,10 +4,11 @@
\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"
......@@ -91,29 +92,33 @@ tcMatchesFun fun_name matches@(first_match:_) expected_ty
-- 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) ->
......@@ -122,12 +127,30 @@ tcMatchesCase matches (Infer hole)
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]
......@@ -150,7 +173,7 @@ tcMatches ctxt matches exp_ty
%************************************************************************
\begin{code}
tcMatch :: RenamedMatchContext
tcMatch :: TcMatchCtxt
-> RenamedMatch
-> Expected TcRhoType -- Expected result-type of the Match.
-- Early unification with this guy gives better error messages
......@@ -161,7 +184,7 @@ tcMatch :: RenamedMatchContext
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
......@@ -194,8 +217,8 @@ lift_grhss co_fn rhs_ty (GRHSs grhss binds ty)
lift_stmt (ResultStmt e l) = ResultStmt (co_fn <$> e) l
lift_stmt stmt = stmt
tcGRHSs :: RenamedMatchContext -> RenamedGRHSs
tcGRHSs :: TcMatchCtxt -> RenamedGRHSs
-> Expected TcRhoType
-> TcM TcGRHSs
......@@ -207,7 +230,7 @@ tcGRHSs :: RenamedMatchContext -> RenamedGRHSs
-- 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')
......@@ -218,10 +241,11 @@ tcGRHSs ctxt (GRHSs grhss binds _) 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 $
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment