From: simonpj@microsoft.com <unknown>
Date: Tue, 12 Aug 2008 08:22:55 +0000 (+0000)
Subject: Refactoring: define TcRnMonad.failWith and use it in the renamer
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=7b9ccfe6947e4ef514057668d6f6673c3fedc10d

Refactoring: define TcRnMonad.failWith and use it in the renamer
---

diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index 7074993..716a7a2 100644
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -564,9 +564,7 @@ rnBracket (VarBr n) = do { name <- lookupOccRn n
 rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e
 			 ; return (ExpBr e', fvs) }
 
-rnBracket (PatBr _) = do { addErr (ptext (sLit "Tempate Haskell pattern brackets are not supported yet"));
-                           failM }
-
+rnBracket (PatBr _) = failWith (ptext (sLit "Tempate Haskell pattern brackets are not supported yet"))
 rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs doc t
 			 ; return (TypBr t', fvs) }
 		    where
@@ -930,8 +928,7 @@ rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b))
                fv_pat)]
 
 rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _)))
-  = do	{ addErr (badIpBinds (ptext (sLit "an mdo expression")) binds)
-	; failM }
+  = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
 
 rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds))) 
     = do binds' <- rnValBindsLHS fix_env binds
@@ -993,8 +990,7 @@ rn_rec_stmt _ (L loc (BindStmt pat' expr _ _)) fv_pat
 	      L loc (BindStmt pat' expr' bind_op fail_op))]
 
 rn_rec_stmt _ (L _ (LetStmt binds@(HsIPBinds _))) _
-  = do	{ addErr (badIpBinds (ptext (sLit "an mdo expression")) binds)
-	; failM }
+  = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
 
 rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do 
   (binds', du_binds) <- 
diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
index 20803be..7a0948e 100644
--- a/compiler/rename/RnTypes.lhs
+++ b/compiler/rename/RnTypes.lhs
@@ -170,9 +170,8 @@ rnHsType doc (HsPredTy pred) = do
     pred' <- rnPred doc pred
     return (HsPredTy pred')
 
-rnHsType _ (HsSpliceTy _) = do
-    addErr (ptext (sLit "Type splices are not yet implemented"))
-    failM
+rnHsType _ (HsSpliceTy _) =
+    failWith (ptext (sLit "Type splices are not yet implemented"))
 
 rnHsType doc (HsDocTy ty haddock_doc) = do
     ty' <- rnLHsType doc ty
diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index 1f02518..2b7e567 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -464,9 +464,12 @@ getErrsVar = do { env <- getLclEnv; return (tcl_errs env) }
 setErrsVar :: TcRef Messages -> TcRn a -> TcRn a
 setErrsVar v = updLclEnv (\ env -> env { tcl_errs =  v })
 
-addErr :: Message -> TcRn ()
+addErr :: Message -> TcRn ()	-- Ignores the context stack
 addErr msg = do { loc <- getSrcSpanM ; addErrAt loc msg }
 
+failWith :: Message -> TcRn a
+failWith msg = addErr msg >> failM
+
 addLocErr :: Located e -> (e -> Message) -> TcRn ()
 addLocErr (L loc e) fn = addErrAt loc (fn e)