From: Twan van Laarhoven <twanvl@gmail.com>
Date: Thu, 17 Jan 2008 21:10:35 +0000 (+0000)
Subject: Monadify typecheck/TcBinds: use do, return and standard monad functions
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=84b4b408696f0cc65f6ad3acfbd3d62aa82e9831

Monadify typecheck/TcBinds: use do, return and standard monad functions
---

diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index 9e60bbd..ea2860a 100644
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -56,6 +56,8 @@ import List
 import Util
 import BasicTypes
 import Outputable
+
+import Control.Monad
 \end{code}
 
 
@@ -141,11 +143,11 @@ tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
 	-- I wonder if we should do these one at at time
 	-- Consider	?x = 4
 	--		?y = ?x + 1
-    tc_ip_bind (IPBind ip expr)
-      = newFlexiTyVarTy argTypeKind		`thenM` \ ty ->
-  	newIPDict (IPBindOrigin ip) ip ty	`thenM` \ (ip', ip_inst) ->
-  	tcMonoExpr expr ty			`thenM` \ expr' ->
-  	returnM (ip_inst, (IPBind ip' expr'))
+    tc_ip_bind (IPBind ip expr) = do
+        ty <- newFlexiTyVarTy argTypeKind
+        (ip', ip_inst) <- newIPDict (IPBindOrigin ip) ip ty
+        expr' <- tcMonoExpr expr ty
+        return (ip_inst, (IPBind ip' expr'))
 
 ------------------------
 tcValBinds :: TopLevelFlag 
@@ -575,9 +577,9 @@ tcMonoBinds binds sig_fn non_rec
 			 	-- A monomorphic binding for each term variable that lacks 
 				-- a type sig.  (Ones with a sig are already in scope.)
 
-	; binds' <- tcExtendIdEnv2 rhs_id_env $
+	; binds' <- tcExtendIdEnv2 rhs_id_env $ do
 		    traceTc (text "tcMonoBinds" <+> vcat [ ppr n <+> ppr id <+> ppr (idType id) 
-							 | (n,id) <- rhs_id_env]) `thenM_`
+							 | (n,id) <- rhs_id_env])
 		    mapM (wrapLocM tcRhs) tc_binds
 	; return (listToBag binds', mono_info) }
 
@@ -743,7 +745,7 @@ generalise dflags top_lvl bind_list sig_fn mono_infos lie_req
    	-- Check that signature type variables are OK
 	; final_qtvs <- checkSigsTyVars qtvs sigs
 
-	; returnM (final_qtvs, sig_lie, binds) }
+	; return (final_qtvs, sig_lie, binds) }
   where
     bndrs   = bndrNames mono_infos
     sigs    = [sig | (_, Just sig, _) <- mono_infos]
@@ -799,7 +801,7 @@ unifyCtxts (sig1 : sigs) 	-- Argument is always non-empty
 checkSigsTyVars :: [TcTyVar] -> [TcSigInfo] -> TcM [TcTyVar]
 checkSigsTyVars qtvs sigs 
   = do	{ gbl_tvs <- tcGetGlobalTyVars
-	; sig_tvs_s <- mappM (check_sig gbl_tvs) sigs
+	; sig_tvs_s <- mapM (check_sig gbl_tvs) sigs
 
 	; let	-- Sigh.  Make sure that all the tyvars in the type sigs
 		-- appear in the returned ty var list, which is what we are
@@ -811,15 +813,15 @@ checkSigsTyVars qtvs sigs
 		-- Here, 'a' won't appear in qtvs, so we have to add it
 	 	sig_tvs = foldl extendVarSetList emptyVarSet sig_tvs_s
 		all_tvs = varSetElems (extendVarSetList sig_tvs qtvs)
-	; returnM all_tvs }
+	; return all_tvs }
   where
     check_sig gbl_tvs (TcSigInfo {sig_id = id, sig_tvs = tvs, 
 				  sig_theta = theta, sig_tau = tau})
       = addErrCtxt (ptext SLIT("In the type signature for") <+> quotes (ppr id))	$
 	addErrCtxtM (sigCtxt id tvs theta tau)						$
 	do { tvs' <- checkDistinctTyVars tvs
-	   ; ifM (any (`elemVarSet` gbl_tvs) tvs')
-		 (bleatEscapedTvs gbl_tvs tvs tvs') 
+	   ; when (any (`elemVarSet` gbl_tvs) tvs')
+	          (bleatEscapedTvs gbl_tvs tvs tvs')
 	   ; return tvs' }
 
 checkDistinctTyVars :: [TcTyVar] -> TcM [TcTyVar]