From: simonpj@microsoft.com <unknown>
Date: Thu, 30 Oct 2008 09:45:28 +0000 (+0000)
Subject: Fix Trac #2674: in TH reject empty case expressions and function definitions
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=b1f3ff48870a3a4670cb41b890b78bbfffa8a32e

Fix Trac #2674: in TH reject empty case expressions and function definitions
---

diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index 48844dd..4a35fda 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -327,6 +327,11 @@ cvtBind (TH.ValD (TH.VarP s) body ds)
 	; returnL $ mkFunBind s' [cl'] }
 
 cvtBind (TH.FunD nm cls)
+  | null cls
+  = failWith (ptext (sLit "Function binding for")
+    	     	    <+> quotes (text (TH.pprint nm))
+    	     	    <+> ptext (sLit "has no equations"))
+  | otherwise
   = do	{ nm' <- vNameL nm
 	; cls' <- mapM cvtClause cls
 	; returnL $ mkFunBind nm' cls' }
@@ -371,7 +376,9 @@ cvtl e = wrapL (cvt e)
     cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z
 			    ; return $ HsIf x' y' z' }
     cvt (LetE ds e)    = do { ds' <- cvtDecs ds; e' <- cvtl e; return $ HsLet ds' e' }
-    cvt (CaseE e ms)   = do { e' <- cvtl e; ms' <- mapM cvtMatch ms
+    cvt (CaseE e ms)   
+       | null ms       = failWith (ptext (sLit "Case expression with no alternatives"))
+       | otherwise     = do { e' <- cvtl e; ms' <- mapM cvtMatch ms
 			    ; return $ HsCase e' (mkMatchGroup ms') }
     cvt (DoE ss)       = cvtHsDo DoExpr ss
     cvt (CompE ss)     = cvtHsDo ListComp ss