[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

@@ -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)

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)

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	$

ghc/compiler/typecheck/TcMatches.hi-boot

 _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] => 

ghc/compiler/typecheck/TcMatches.hi-boot-5

 __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 :: 

ghc/compiler/typecheck/TcMatches.hi-boot-6

 module TcMatches where
 
-tcGRHSs       :: HsExpr.HsMatchContext Name.Name
-	      -> RnHsSyn.RenamedGRHSs
+tcGRHSsPat    :: RnHsSyn.RenamedGRHSs
 	      -> TcUnify.Expected TcType.TcType
 	      -> TcRnTypes.TcM TcHsSyn.TcGRHSs
 

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		$