X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcMatches.lhs;h=37fbd190f811bc8b6a43d20eb20c89bb4876d875;hp=40e1ca0bdbef91010bf6bc7e512c603e1550a141;hb=27de38efce6d73d2a0209f803cfa98c82773e773;hpb=c233954abc34df844eb6d8603a8754b75962dbfe

diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs
index 40e1ca0..37fbd19 100644
--- a/compiler/typecheck/TcMatches.lhs
+++ b/compiler/typecheck/TcMatches.lhs
@@ -7,7 +7,7 @@ TcMatches: Typecheck some @Matches@
 
 \begin{code}
 module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
-		   matchCtxt, TcMatchCtxt(..), 
+		   TcMatchCtxt(..), 
 		   tcStmts, tcDoStmts, tcBody,
 		   tcDoStmt, tcMDoStmt, tcGuardStmt
        ) where
@@ -36,6 +36,8 @@ import SrcLoc
 import FastString
 
 import Control.Monad
+
+#include "HsVersions.h"
 \end{code}
 
 %************************************************************************
@@ -92,6 +94,13 @@ tcMatchesCase :: TcMatchCtxt		-- Case context
 	      -> TcM (MatchGroup TcId)	-- Translated alternatives
 
 tcMatchesCase ctxt scrut_ty matches res_ty
+  | isEmptyMatchGroup matches
+  =	  -- Allow empty case expressions
+    do {  -- Make sure we follow the invariant that res_ty is filled in
+          res_ty' <- refineBoxToTau res_ty
+       ;  return (MatchGroup [] (mkFunTys [scrut_ty] res_ty')) }
+
+  | otherwise
   = tcMatches ctxt [scrut_ty] res_ty matches
 
 tcMatchLambda :: MatchGroup Name -> BoxyRhoType -> TcM (HsWrapper, MatchGroup TcId)
@@ -141,7 +150,8 @@ data TcMatchCtxt 	-- c.f. TcStmtCtxt, also in this module
 		 -> TcM (LHsExpr TcId) }	
 
 tcMatches ctxt pat_tys rhs_ty (MatchGroup matches _)
-  = do	{ matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
+  = ASSERT( not (null matches) )	-- Ensure that rhs_ty is filled in
+    do	{ matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
 	; return (MatchGroup matches' (mkFunTys pat_tys rhs_ty)) }
 
 -------------
@@ -164,17 +174,15 @@ tcMatch ctxt pat_tys rhs_ty match
       = tcGRHSs ctxt grhss rhs_ty	-- No result signature
 
 	-- Result type sigs are no longer supported
-    tc_grhss ctxt (Just res_sig) grhss rhs_ty
-      = do { addErr (ptext (sLit "Ignoring (deprecated) result type signature")
-			<+> ppr res_sig)
-    	   ; tcGRHSs ctxt grhss rhs_ty }
+    tc_grhss _ (Just {}) _ _
+      = panic "tc_ghrss"  	-- Rejected by renamer
 
 	-- For (\x -> e), tcExpr has already said "In the expresssion \x->e"
 	-- so we don't want to add "In the lambda abstraction \x->e"
     add_match_ctxt match thing_inside
 	= case mc_what ctxt of
 	    LambdaExpr -> thing_inside
-	    m_ctxt     -> addErrCtxt (matchCtxt m_ctxt match) thing_inside
+	    m_ctxt     -> addErrCtxt (pprMatchInCtxt m_ctxt match) thing_inside
 
 -------------
 tcGRHSs :: TcMatchCtxt -> GRHSs Name -> BoxyRhoType
@@ -303,7 +311,7 @@ tcStmts ctxt stmt_chk (L loc (LetStmt binds) : stmts) res_ty thing_inside
 tcStmts ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
   = do 	{ (stmt', (stmts', thing)) <- 
 		setSrcSpan loc		 		$
-    		addErrCtxt (stmtCtxt ctxt stmt)		$
+    		addErrCtxt (pprStmtInCtxt ctxt stmt)	$
 		stmt_chk ctxt stmt res_ty		$ \ res_ty' ->
 		popErrCtxt 				$
 		tcStmts ctxt stmt_chk stmts res_ty'	$
@@ -586,12 +594,3 @@ checkArgs fun (MatchGroup (match1:matches) _)
 checkArgs _ _ = panic "TcPat.checkArgs" -- Matches always non-empty
 \end{code}
 
-\begin{code}
-matchCtxt :: HsMatchContext Name -> Match Name -> SDoc
-matchCtxt ctxt match  = hang (ptext (sLit "In") <+> pprMatchContext ctxt <> colon) 
-			   4 (pprMatch ctxt match)
-
-stmtCtxt :: HsStmtContext Name -> StmtLR Name Name -> SDoc
-stmtCtxt ctxt stmt = hang (ptext (sLit "In a stmt of") <+> pprStmtContext ctxt <> colon)
-		  	4 (ppr stmt)
-\end{code}