From 8655d6ca41df4aa77a559d4067ad3815797b9803 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Fri, 27 Jun 2003 21:17:25 +0000
Subject: [PATCH] [project @ 2003-06-27 21:17:24 by simonpj] Heal the head

---
 ghc/compiler/typecheck/Inst.lhs       |   15 ++++++++++++---
 ghc/compiler/typecheck/TcRnDriver.lhs |   15 +++++++--------
 2 files changed, 19 insertions(+), 11 deletions(-)

diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index 5790e7b..9f3c684 100644
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -15,7 +15,8 @@ module Inst (
 	newDictsFromOld, newDicts, cloneDict, 
 	newOverloadedLit, newIPDict, 
 	newMethod, newMethodFromName, newMethodWithGivenTy, 
-	tcInstClassOp, tcInstCall, tcInstDataCon, tcSyntaxName,
+	tcInstClassOp, tcInstCall, tcInstDataCon, 
+	tcSyntaxName, tcStdSyntaxName,
 
 	tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, 
 	ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
@@ -653,8 +654,7 @@ tcSyntaxName :: InstOrigin
 
 tcSyntaxName orig ty (std_nm, HsVar user_nm)
   | std_nm == user_nm
-  = newMethodFromName orig ty std_nm	`thenM` \ id ->
-    returnM (std_nm, HsVar id)
+  = tcStdSyntaxName orig ty std_nm
 
 tcSyntaxName orig ty (std_nm, user_nm_expr)
   = tcLookupId std_nm		`thenM` \ std_id ->
@@ -669,6 +669,15 @@ tcSyntaxName orig ty (std_nm, user_nm_expr)
     tcCheckSigma user_nm_expr tau1			`thenM` \ expr ->
     returnM (std_nm, expr)
 
+tcStdSyntaxName :: InstOrigin
+	        -> TcType		-- Type to instantiate it at
+	        -> Name			-- Standard name
+	        -> TcM (Name, TcExpr)	-- (Standard name, suitable expression)
+
+tcStdSyntaxName orig ty std_nm
+  = newMethodFromName orig ty std_nm	`thenM` \ id ->
+    returnM (std_nm, HsVar id)
+
 syntaxNameCtxt name orig ty tidy_env
   = getInstLoc orig		`thenM` \ inst_loc ->
     let
diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs
index 1914c96..59fbb31 100644
--- a/ghc/compiler/typecheck/TcRnDriver.lhs
+++ b/ghc/compiler/typecheck/TcRnDriver.lhs
@@ -32,8 +32,8 @@ import HsSyn		( HsModule(..), HsBinds(..), MonoBinds(..), HsExpr(..),
 import RdrHsSyn		( RdrNameHsModule, RdrNameHsDecl, RdrNameStmt, RdrNameHsExpr,
 			  emptyGroup, mkGroup, findSplice, addImpDecls, main_RDR_Unqual )
 
-import PrelNames	( iNTERACTIVE, ioTyConName, printName,
-			  returnIOName, bindIOName, failIOName, thenIOName, runIOName, 
+import PrelNames	( iNTERACTIVE, ioTyConName, printName, monadNames,
+			  returnIOName, runIOName, 
 			  dollarMainName, itName, mAIN_Name, unsafeCoerceName
 			)
 import MkId		( unsafeCoerceId )
@@ -55,7 +55,7 @@ import TcType		( Type, liftedTypeKind,
 			  mkForAllTys, mkFunTys, mkTyConApp, tcSplitForAllTys
 			)
 import TcMatches	( tcStmtsAndThen, TcStmtCtxt(..) )
-import Inst		( showLIE )
+import Inst		( showLIE, tcStdSyntaxName )
 import TcBinds		( tcTopBinds )
 import TcClassDcl	( tcClassDecls2 )
 import TcDefaults	( tcDefaults )
@@ -402,7 +402,9 @@ tc_stmts stmts
 			     (ExplicitList placeHolderType (map mk_item names)) ;
 	    mk_item name = HsApp (HsVar unsafeCoerceName) (HsVar name) ;
 
-	    all_stmts = stmts ++ [ret_stmt]
+	    all_stmts = stmts ++ [ret_stmt] ;
+
+	    io_ty = mkTyConApp ioTyCon []
 	 } ;
 
 	-- OK, we're ready to typecheck the stmts
@@ -427,8 +429,7 @@ tc_stmts stmts
 	const_binds <- tcSimplifyTop lie ;
 
 	-- Build result expression and zonk it
-	io_ids <- mappM mk_rebound
-			[returnIOName, failIOName, bindIOName, thenIOName] ;
+	io_ids <- mappM (tcStdSyntaxName DoOrigin io_ty) monadNames ;
 	let { expr = mkHsLet const_binds $
 		     HsDo DoExpr tc_stmts io_ids
 		 	  (mkTyConApp ioTyCon [ret_ty]) noSrcLoc } ;
@@ -439,8 +440,6 @@ tc_stmts stmts
 	}
   where
     combine stmt (ids, stmts) = (ids, stmt:stmts)
-    mk_rebound n = do { id <- tcLookupId n; return (n, HsVar id) }
-	-- A bit hackoid
 \end{code}
 
 
-- 
1.7.10.4