From: simonpj@microsoft.com <unknown>
Date: Sat, 20 Sep 2008 21:11:01 +0000 (+0000)
Subject: Fix Trac #2597 (second bug): complain about an empty DoE block
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=6fa448e4c21d92d50d8a87bdd3c5f61072820c98;p=ghc-hetmet.git

Fix Trac #2597 (second bug): complain about an empty DoE block

When converting an empty do-block from TH syntax to HsSyn,
complain rather than crashing.
---

diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index 6b1014e..48844dd 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -51,14 +51,14 @@ convertToHsDecls loc ds = initCvt loc (mapM cvtTop ds)
 convertToHsExpr :: SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName)
 convertToHsExpr loc e 
   = case initCvt loc (cvtl e) of
-	Left msg  -> Left (msg $$ (ptext (sLit "When converting TH expression")
+	Left msg  -> Left (msg $$ (ptext (sLit "When splicing TH expression:")
 				    <+> text (show e)))
 	Right res -> Right res
 
 convertToPat :: SrcSpan -> TH.Pat -> Either Message (LPat RdrName)
 convertToPat loc e
   = case initCvt loc (cvtPat e) of
-        Left msg  -> Left (msg $$ (ptext (sLit "When converting TH pattern")
+        Left msg  -> Left (msg $$ (ptext (sLit "When splicing TH pattern:")
                                     <+> text (show e)))
         Right res -> Right res
 
@@ -412,6 +412,8 @@ cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; retur
 
 cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr RdrName)
 cvtHsDo do_or_lc stmts
+  | null stmts = failWith (ptext (sLit "Empty stmt list in do-block"))
+  | otherwise
   = do	{ stmts' <- cvtStmts stmts
 	; let body = case last stmts' of
 			L _ (ExprStmt body _ _) -> body