Commit dbaa3bb3 authored by ross's avatar ross
Browse files

[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 ) ...@@ -13,7 +13,8 @@ import {-# SOURCE #-} TcExpr( tcCheckRho )
import HsSyn import HsSyn
import TcHsSyn ( TcCmd, TcCmdTop, TcExpr, TcPat, mkHsLet ) 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, import TcType ( TcType, TcTauType, TcRhoType, mkFunTys, mkTyConApp,
mkTyVarTy, mkAppTys, tcSplitTyConApp_maybe, tcEqType ) mkTyVarTy, mkAppTys, tcSplitTyConApp_maybe, tcEqType )
...@@ -99,6 +100,20 @@ tcCmd env (HsLet binds body) res_ty ...@@ -99,6 +100,20 @@ tcCmd env (HsLet binds body) res_ty
= tcBindsAndThen HsLet binds $ = tcBindsAndThen HsLet binds $
tcCmd env body res_ty 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 tcCmd env (HsIf pred b1 b2 src_loc) res_ty
= addSrcLoc src_loc $ = addSrcLoc src_loc $
do { pred' <- tcCheckRho pred boolTy do { pred' <- tcCheckRho pred boolTy
...@@ -322,6 +337,9 @@ arrowTyConKind = mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind ...@@ -322,6 +337,9 @@ arrowTyConKind = mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind
\begin{code} \begin{code}
cmdCtxt cmd = ptext SLIT("In the command:") <+> ppr cmd 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 nonEmptyCmdStkErr cmd
= hang (ptext SLIT("Non-empty command stack at command:")) = hang (ptext SLIT("Non-empty command stack at command:"))
4 (ppr cmd) 4 (ppr cmd)
......
...@@ -8,12 +8,12 @@ module TcBinds ( tcBindsAndThen, tcTopBinds, tcMonoBinds, tcSpecSigs ) where ...@@ -8,12 +8,12 @@ module TcBinds ( tcBindsAndThen, tcTopBinds, tcMonoBinds, tcSpecSigs ) where
#include "HsVersions.h" #include "HsVersions.h"
import {-# SOURCE #-} TcMatches ( tcGRHSs, tcMatchesFun ) import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
import {-# SOURCE #-} TcExpr ( tcCheckSigma, tcCheckRho ) import {-# SOURCE #-} TcExpr ( tcCheckSigma, tcCheckRho )
import CmdLineOpts ( DynFlag(Opt_NoMonomorphismRestriction) ) import CmdLineOpts ( DynFlag(Opt_NoMonomorphismRestriction) )
import HsSyn ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), import HsSyn ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..),
Match(..), HsMatchContext(..), mkMonoBind, Match(..), mkMonoBind,
collectMonoBinders, andMonoBinds, collectMonoBinders, andMonoBinds,
collectSigTysFromMonoBinds collectSigTysFromMonoBinds
) )
...@@ -719,7 +719,7 @@ tcMonoBinds mbinds tc_ty_sigs is_rec ...@@ -719,7 +719,7 @@ tcMonoBinds mbinds tc_ty_sigs is_rec
let let
complete_it = addSrcLoc locn $ complete_it = addSrcLoc locn $
addErrCtxt (patMonoBindsCtxt bind) $ addErrCtxt (patMonoBindsCtxt bind) $
tcGRHSs PatBindRhs grhss (Check pat_ty) `thenM` \ grhss' -> tcGRHSsPat grhss (Check pat_ty) `thenM` \ grhss' ->
returnM (PatMonoBind pat' grhss' locn, ids) returnM (PatMonoBind pat' grhss' locn, ids)
in in
returnM (complete_it, if isRec is_rec then ids else emptyBag) returnM (complete_it, if isRec is_rec then ids else emptyBag)
......
...@@ -17,7 +17,8 @@ import Name ( isExternalName ) ...@@ -17,7 +17,8 @@ import Name ( isExternalName )
import qualified DsMeta import qualified DsMeta
#endif #endif
import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..), recBindFields ) import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..), recBindFields,
HsMatchContext(..) )
import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds ) import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds )
import TcHsSyn ( TcExpr, TcRecordBinds, hsLitType, mkHsDictApp, mkHsTyApp, mkHsLet, (<$>) ) import TcHsSyn ( TcExpr, TcRecordBinds, hsLitType, mkHsDictApp, mkHsTyApp, mkHsLet, (<$>) )
import TcRnMonad import TcRnMonad
...@@ -34,7 +35,7 @@ import TcEnv ( tcLookupClass, tcLookupGlobal_maybe, tcLookup, ...@@ -34,7 +35,7 @@ import TcEnv ( tcLookupClass, tcLookupGlobal_maybe, tcLookup,
tcLookupTyCon, tcLookupDataCon, tcLookupId, checkProcLevel tcLookupTyCon, tcLookupDataCon, tcLookupId, checkProcLevel
) )
import TcArrows ( tcProc ) import TcArrows ( tcProc )
import TcMatches ( tcMatchesCase, tcMatchLambda, tcDoStmts, tcThingWithSig ) import TcMatches ( tcMatchesCase, tcMatchLambda, tcDoStmts, tcThingWithSig, TcMatchCtxt(..) )
import TcMonoType ( tcHsSigType, UserTypeCtxt(..) ) import TcMonoType ( tcHsSigType, UserTypeCtxt(..) )
import TcPat ( badFieldCon ) import TcPat ( badFieldCon )
import TcMType ( tcInstTyVars, tcInstType, newTyVarTy, newTyVarTys, zonkTcType ) import TcMType ( tcInstTyVars, tcInstType, newTyVarTy, newTyVarTys, zonkTcType )
...@@ -257,13 +258,16 @@ tcMonoExpr in_expr@(HsCase scrut matches src_loc) res_ty ...@@ -257,13 +258,16 @@ tcMonoExpr in_expr@(HsCase scrut matches src_loc) res_ty
-- (x:xs) -> ... -- (x:xs) -> ...
-- will report that map is applied to too few arguments -- 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) ( addErrCtxt (caseScrutCtxt scrut) (
tcCheckRho scrut scrut_ty tcCheckRho scrut scrut_ty
) `thenM` \ scrut' -> ) `thenM` \ scrut' ->
returnM (HsCase scrut' matches' src_loc) 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 tcMonoExpr (HsIf pred b1 b2 src_loc) res_ty
= addSrcLoc src_loc $ = addSrcLoc src_loc $
......
_interface_ TcMatches 2 _interface_ TcMatches 2
_exports_ _exports_
TcMatches tcGRHSs tcMatchesFun; TcMatches tcGRHSsPat tcMatchesFun;
_declarations_ _declarations_
2 tcGRHSs _:_ _forall_ [s] => 2 tcGRHSsPat _:_ _forall_ [s] =>
HsExpr.HsMatchContext Name.Name RnHsSyn.RenamedGRHSs
-> RnHsSyn.RenamedGRHSs
-> TcType.TcType -> TcType.TcType
-> TcMonad.TcM s (TcHsSyn.TcGRHSs, TcMonad.LIE) ;; -> TcMonad.TcM s (TcHsSyn.TcGRHSs, TcMonad.LIE) ;;
3 tcMatchesFun _:_ _forall_ [s] => 3 tcMatchesFun _:_ _forall_ [s] =>
......
__interface TcMatches 1 0 where __interface TcMatches 1 0 where
__export TcMatches tcGRHSs tcMatchesFun; __export TcMatches tcGRHSsPat tcMatchesFun;
1 tcGRHSs :: HsExpr.HsMatchContext Name.Name 1 tcGRHSsPat :: RnHsSyn.RenamedGRHSs
-> RnHsSyn.RenamedGRHSs
-> TcUnify.Expected TcType.TcType -> TcUnify.Expected TcType.TcType
-> TcRnTypes.TcM TcHsSyn.TcGRHSs ; -> TcRnTypes.TcM TcHsSyn.TcGRHSs ;
1 tcMatchesFun :: 1 tcMatchesFun ::
......
module TcMatches where module TcMatches where
tcGRHSs :: HsExpr.HsMatchContext Name.Name tcGRHSsPat :: RnHsSyn.RenamedGRHSs
-> RnHsSyn.RenamedGRHSs
-> TcUnify.Expected TcType.TcType -> TcUnify.Expected TcType.TcType
-> TcRnTypes.TcM TcHsSyn.TcGRHSs -> TcRnTypes.TcM TcHsSyn.TcGRHSs
......
...@@ -4,10 +4,11 @@ ...@@ -4,10 +4,11 @@
\section[TcMatches]{Typecheck some @Matches@} \section[TcMatches]{Typecheck some @Matches@}
\begin{code} \begin{code}
module TcMatches ( tcMatchesFun, tcMatchesCase, tcMatchLambda, matchCtxt, module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
tcDoStmts, tcStmtsAndThen, tcStmts, tcGRHSs, tcThingWithSig, matchCtxt,
tcDoStmts, tcStmtsAndThen, tcStmts, tcThingWithSig,
tcMatchPats, tcMatchPats,
TcStmtCtxt(..) TcStmtCtxt(..), TcMatchCtxt(..)
) where ) where
#include "HsVersions.h" #include "HsVersions.h"
...@@ -91,29 +92,33 @@ tcMatchesFun fun_name matches@(first_match:_) expected_ty ...@@ -91,29 +92,33 @@ tcMatchesFun fun_name matches@(first_match:_) expected_ty
-- may show up as something wrong with the (non-existent) type signature -- 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 -- 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} \end{code}
@tcMatchesCase@ doesn't do the argument-count check because the @tcMatchesCase@ doesn't do the argument-count check because the
parser guarantees that each equation has exactly one argument. parser guarantees that each equation has exactly one argument.
\begin{code} \begin{code}
tcMatchesCase :: [RenamedMatch] -- The case alternatives tcMatchesCase :: TcMatchCtxt -- Case context
-> [RenamedMatch] -- The case alternatives
-> Expected TcRhoType -- Type of whole case expressions -> Expected TcRhoType -- Type of whole case expressions
-> TcM (TcRhoType, -- Inferred type of the scrutinee -> TcM (TcRhoType, -- Inferred type of the scrutinee
[TcMatch]) -- Translated alternatives [TcMatch]) -- Translated alternatives
tcMatchesCase matches (Check expr_ty) tcMatchesCase ctxt matches (Check expr_ty)
= -- This case is a bit yukky, because it prevents the = -- This case is a bit yukky, because it prevents the
-- scrutinee being higher-ranked, which might just possible -- scrutinee being higher-ranked, which might just possible
-- matter if we were seq'ing on it. But it's awkward to fix. -- matter if we were seq'ing on it. But it's awkward to fix.
newTyVarTy openTypeKind `thenM` \ scrut_ty -> 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') returnM (scrut_ty, matches')
tcMatchesCase matches (Infer hole) tcMatchesCase ctxt matches (Infer hole)
= newHole `thenM` \ fun_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 -> readMutVar fun_hole `thenM` \ fun_ty ->
-- The result of tcMatches is bound to be a function type -- The result of tcMatches is bound to be a function type
unifyFunTy fun_ty `thenM` \ (scrut_ty, res_ty) -> unifyFunTy fun_ty `thenM` \ (scrut_ty, res_ty) ->
...@@ -122,12 +127,30 @@ tcMatchesCase matches (Infer hole) ...@@ -122,12 +127,30 @@ tcMatchesCase matches (Infer hole)
tcMatchLambda :: RenamedMatch -> Expected TcRhoType -> TcM TcMatch 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} \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} \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] -> [RenamedMatch]
-> Expected TcRhoType -> Expected TcRhoType
-> TcM [TcMatch] -> TcM [TcMatch]
...@@ -150,7 +173,7 @@ tcMatches ctxt matches exp_ty ...@@ -150,7 +173,7 @@ tcMatches ctxt matches exp_ty
%************************************************************************ %************************************************************************
\begin{code} \begin{code}
tcMatch :: RenamedMatchContext tcMatch :: TcMatchCtxt
-> RenamedMatch -> RenamedMatch
-> Expected TcRhoType -- Expected result-type of the Match. -> Expected TcRhoType -- Expected result-type of the Match.
-- Early unification with this guy gives better error messages -- Early unification with this guy gives better error messages
...@@ -161,7 +184,7 @@ tcMatch :: RenamedMatchContext ...@@ -161,7 +184,7 @@ tcMatch :: RenamedMatchContext
tcMatch ctxt match@(Match pats maybe_rhs_sig grhss) expected_ty tcMatch ctxt match@(Match pats maybe_rhs_sig grhss) expected_ty
= addSrcLoc (getMatchLoc match) $ -- At one stage I removed this; = 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 -> subFunTys pats expected_ty $ \ pats_w_tys rhs_ty ->
-- This is the unique place we call subFunTys -- This is the unique place we call subFunTys
-- The point is that if expected_y is a "hole", we want -- 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) ...@@ -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 (ResultStmt e l) = ResultStmt (co_fn <$> e) l
lift_stmt stmt = stmt lift_stmt stmt = stmt
tcGRHSs :: RenamedMatchContext -> RenamedGRHSs tcGRHSs :: TcMatchCtxt -> RenamedGRHSs
-> Expected TcRhoType -> Expected TcRhoType
-> TcM TcGRHSs -> TcM TcGRHSs
...@@ -207,7 +230,7 @@ tcGRHSs :: RenamedMatchContext -> RenamedGRHSs ...@@ -207,7 +230,7 @@ tcGRHSs :: RenamedMatchContext -> RenamedGRHSs
-- not a Expected TcType, a decision we could revisit if necessary -- not a Expected TcType, a decision we could revisit if necessary
tcGRHSs ctxt (GRHSs [GRHS [ResultStmt rhs loc1] loc2] binds _) exp_ty tcGRHSs ctxt (GRHSs [GRHS [ResultStmt rhs loc1] loc2] binds _) exp_ty
= tcBindsAndThen glueBindsOnGRHSs binds $ = tcBindsAndThen glueBindsOnGRHSs binds $
tcMonoExpr rhs exp_ty `thenM` \ rhs' -> mc_body ctxt rhs exp_ty `thenM` \ rhs' ->
readExpectedType exp_ty `thenM` \ exp_ty' -> readExpectedType exp_ty `thenM` \ exp_ty' ->
returnM (GRHSs [GRHS [ResultStmt rhs' loc1] loc2] EmptyBinds exp_ty') returnM (GRHSs [GRHS [ResultStmt rhs' loc1] loc2] EmptyBinds exp_ty')
...@@ -218,10 +241,11 @@ tcGRHSs ctxt (GRHSs grhss binds _) exp_ty ...@@ -218,10 +241,11 @@ tcGRHSs ctxt (GRHSs grhss binds _) exp_ty
-- a monotype. Reason: it makes tcStmts much easier, -- a monotype. Reason: it makes tcStmts much easier,
-- and even a one-armed guard has a notional second arm -- and even a one-armed guard has a notional second arm
let let
stmt_ctxt = SC { sc_what = PatGuard ctxt, stmt_ctxt = SC { sc_what = PatGuard (mc_what ctxt),
sc_rhs = tcCheckRho, sc_rhs = tcCheckRho,
sc_body = \ body -> tcCheckRho body exp_ty', sc_body = sc_body,
sc_ty = exp_ty' } sc_ty = exp_ty' }
sc_body body = mc_body ctxt body (Check exp_ty')
tc_grhs (GRHS guarded locn) tc_grhs (GRHS guarded locn)
= addSrcLoc 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