From dbaa3bb30eaf9d806357e41435dab32695c47842 Mon Sep 17 00:00:00 2001 From: ross Date: Sat, 20 Sep 2003 17:26:49 +0000 Subject: [PATCH] [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. --- ghc/compiler/typecheck/TcArrows.lhs | 20 +++++++++- ghc/compiler/typecheck/TcBinds.lhs | 6 +-- ghc/compiler/typecheck/TcExpr.lhs | 10 +++-- ghc/compiler/typecheck/TcMatches.hi-boot | 7 ++-- ghc/compiler/typecheck/TcMatches.hi-boot-5 | 5 +-- ghc/compiler/typecheck/TcMatches.hi-boot-6 | 3 +- ghc/compiler/typecheck/TcMatches.lhs | 60 +++++++++++++++++++--------- 7 files changed, 77 insertions(+), 34 deletions(-) diff --git a/ghc/compiler/typecheck/TcArrows.lhs b/ghc/compiler/typecheck/TcArrows.lhs index b31c03a..77c7165 100644 --- a/ghc/compiler/typecheck/TcArrows.lhs +++ b/ghc/compiler/typecheck/TcArrows.lhs @@ -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) diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index ce66850..b5d2cb7 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -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) diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 7b55afd..096efb4 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -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 $ diff --git a/ghc/compiler/typecheck/TcMatches.hi-boot b/ghc/compiler/typecheck/TcMatches.hi-boot index cdb14ff..80f46b6 100644 --- a/ghc/compiler/typecheck/TcMatches.hi-boot +++ b/ghc/compiler/typecheck/TcMatches.hi-boot @@ -1,10 +1,9 @@ _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] => diff --git a/ghc/compiler/typecheck/TcMatches.hi-boot-5 b/ghc/compiler/typecheck/TcMatches.hi-boot-5 index 726424b..6b568de 100644 --- a/ghc/compiler/typecheck/TcMatches.hi-boot-5 +++ b/ghc/compiler/typecheck/TcMatches.hi-boot-5 @@ -1,7 +1,6 @@ __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 :: diff --git a/ghc/compiler/typecheck/TcMatches.hi-boot-6 b/ghc/compiler/typecheck/TcMatches.hi-boot-6 index bc2ecf5..aca8a45 100644 --- a/ghc/compiler/typecheck/TcMatches.hi-boot-6 +++ b/ghc/compiler/typecheck/TcMatches.hi-boot-6 @@ -1,7 +1,6 @@ module TcMatches where -tcGRHSs :: HsExpr.HsMatchContext Name.Name - -> RnHsSyn.RenamedGRHSs +tcGRHSsPat :: RnHsSyn.RenamedGRHSs -> TcUnify.Expected TcType.TcType -> TcRnTypes.TcM TcHsSyn.TcGRHSs diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs index 269abde..1a19b03 100644 --- a/ghc/compiler/typecheck/TcMatches.lhs +++ b/ghc/compiler/typecheck/TcMatches.lhs @@ -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 $ -- 1.7.10.4