[project @ 2003-06-27 21:17:24 by simonpj]

Heal the head

diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index 5790e7b..9f3c684 100644 (file)
--- 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 (file)
--- 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}