From: simonpj@microsoft.com <unknown>
Date: Mon, 11 Aug 2008 12:31:58 +0000 (+0000)
Subject: Mostly fix Trac #2431: make empty case acceptable to (most of) GHC
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=27de38efce6d73d2a0209f803cfa98c82773e773;ds=sidebyside

Mostly fix Trac #2431: make empty case acceptable to (most of) GHC

See the comments with Trac #2431.  This patch makes an empty HsCase
acceptable to the renamer onwards.  If you want to accept empty case
in Haskell source there's a little more to do: the ticket lists the
remaining tasks.
---

diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 043f54f..eed7f87 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -266,10 +266,15 @@ dsExpr (HsSCC cc expr) = do
 dsExpr (HsCoreAnn fs expr)
   = Note (CoreNote $ unpackFS fs) <$> dsLExpr expr
 
-dsExpr (HsCase discrim matches) = do
-    core_discrim <- dsLExpr discrim
-    ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
-    return (scrungleMatch discrim_var core_discrim matching_code)
+dsExpr (HsCase discrim matches@(MatchGroup _ rhs_ty)) 
+  | isEmptyMatchGroup matches	-- A Core 'case' is always non-empty
+  = 		      		-- So desugar empty HsCase to error call
+    mkErrorAppDs pAT_ERROR_ID (funResultTy rhs_ty) "case"
+
+  | otherwise
+  = do { core_discrim <- dsLExpr discrim
+       ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
+       ; return (scrungleMatch discrim_var core_discrim matching_code) }
 
 -- Pepe: The binds are in scope in the body but NOT in the binding group
 --       This is to avoid silliness in breakpoints
diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index e5d85ca..bbb2712 100644
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -378,8 +378,8 @@ ppr_expr exprType@(HsLam matches)
  where idType :: HsExpr id -> HsMatchContext id; idType = undefined
 
 ppr_expr exprType@(HsCase expr matches)
-  = sep [ sep [ptext (sLit "case"), nest 4 (ppr expr), ptext (sLit "of")],
-          nest 2 (pprMatches (CaseAlt `asTypeOf` idType exprType) matches) ]
+  = sep [ sep [ptext (sLit "case"), nest 4 (ppr expr), ptext (sLit "of {")],
+          nest 2 (pprMatches (CaseAlt `asTypeOf` idType exprType) matches <+> char '}') ]
  where idType :: HsExpr id -> HsMatchContext id; idType = undefined
 
 ppr_expr (HsIf e1 e2 e3)
@@ -663,9 +663,12 @@ data Match id
                                 -- Nothing after typechecking
         (GRHSs id)
 
+isEmptyMatchGroup :: MatchGroup id -> Bool
+isEmptyMatchGroup (MatchGroup ms _) = null ms
+
 matchGroupArity :: MatchGroup id -> Arity
 matchGroupArity (MatchGroup [] _)
-  = panic "matchGroupArity"     -- MatchGroup is never empty
+  = panic "matchGroupArity"     -- Precondition: MatchGroup is non-empty
 matchGroupArity (MatchGroup (match:matches) _)
   = ASSERT( all ((== n_pats) . length . hsLMatchPats) matches )
     -- Assertion just checks that all the matches have the same number of pats
diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs
index fae6ae8..756c3fc 100644
--- a/compiler/rename/RnBinds.lhs
+++ b/compiler/rename/RnBinds.lhs
@@ -787,9 +787,9 @@ lookupSigOccRn mb_names sig v
 
 \begin{code}
 rnMatchGroup :: HsMatchContext Name -> MatchGroup RdrName -> RnM (MatchGroup Name, FreeVars)
-rnMatchGroup ctxt (MatchGroup ms _) = do
-    (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt) ms
-    return (MatchGroup new_ms placeHolderType, ms_fvs)
+rnMatchGroup ctxt (MatchGroup ms _) 
+  = do { (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt) ms
+       ; return (MatchGroup new_ms placeHolderType, ms_fvs) }
 
 rnMatch :: HsMatchContext Name -> LMatch RdrName -> RnM (LMatch Name, FreeVars)
 rnMatch ctxt  = wrapLocFstM (rnMatch' ctxt)
diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs
index b16c8d3..37fbd19 100644
--- a/compiler/typecheck/TcMatches.lhs
+++ b/compiler/typecheck/TcMatches.lhs
@@ -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)) }
 
 -------------