X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcMonad.lhs;h=e595a839e4c1e5c3ef19f23d414737e7e7d149b6;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=876564daad2815624243c9b4dd464db53384e358;hpb=5cf27e8f1731c52fe63a5b9615f927484164c61b;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs
index 876564d..e595a83 100644
--- a/ghc/compiler/typecheck/TcMonad.lhs
+++ b/ghc/compiler/typecheck/TcMonad.lhs
@@ -1,6 +1,8 @@
 \begin{code}
+#include "HsVersions.h"
+
 module TcMonad(
-	TcM(..), NF_TcM(..), TcDown, TcEnv, 
+	SYN_IE(TcM), SYN_IE(NF_TcM), TcDown, TcEnv, 
 	SST_R, FSST_R,
 
 	initTc,
@@ -26,32 +28,37 @@ module TcMonad(
 
 	rnMtoTcM,
 
-	TcError(..), TcWarning(..),
+	SYN_IE(TcError), SYN_IE(TcWarning),
 	mkTcErr, arityErr,
 
 	-- For closure
-	MutableVar(..), _MutableArray
+	SYN_IE(MutableVar),
+#if __GLASGOW_HASKELL__ >= 200
+	GHCbase.MutableArray
+#else
+	_MutableArray
+#endif
   ) where
 
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
 
-import TcMLoop		( TcEnv, initEnv, TcMaybe )  -- We need the type TcEnv and an initial Env
+IMPORT_DELOOPER(TcMLoop) ( TcEnv, initEnv, TcMaybe )  -- We need the type TcEnv and an initial Env
 
-import Type		( Type(..), GenType )
-import TyVar		( TyVar(..), GenTyVar )
-import Usage		( Usage(..), GenUsage )
-import ErrUtils		( Error(..), Message(..), ErrCtxt(..),
-			  Warning(..) )
+import Type		( SYN_IE(Type), GenType )
+import TyVar		( SYN_IE(TyVar), GenTyVar )
+import Usage		( SYN_IE(Usage), GenUsage )
+import ErrUtils		( SYN_IE(Error), SYN_IE(Message), SYN_IE(Warning) )
 
 import SST
-import RnMonad		( RnM(..), RnDown, initRn, setExtraRn )
-import RnUtils		( RnEnv(..) )
+import RnMonad		( SYN_IE(RnM), RnDown, initRn, setExtraRn,
+			  returnRn, thenRn, getImplicitUpRn
+			)
+import RnUtils		( SYN_IE(RnEnv) )
 
 import Bag		( Bag, emptyBag, isEmptyBag,
 			  foldBag, unitBag, unionBags, snocBag )
-import FiniteMap	( FiniteMap, emptyFM )
+import FiniteMap	( FiniteMap, emptyFM, isEmptyFM{-, keysFM ToDo:rm-} )
 --import Outputable	( Outputable(..), NamedThing(..), ExportFlag )
-import ErrUtils		( Error(..) )
 import Maybes		( MaybeErr(..) )
 --import Name		( Name )
 import SrcLoc		( SrcLoc, mkUnknownSrcLoc )
@@ -75,16 +82,22 @@ type TcM    s r =  TcDown s -> TcEnv s -> FSST s r ()
 \end{code}
 
 \begin{code}
--- With a builtin polymorphic type for _runSST the type for
--- initTc should use  TcM s r  instead of  TcM _RealWorld r 
+#if __GLASGOW_HASKELL__ >= 200
+# define REAL_WORLD RealWorld
+#else
+# define REAL_WORLD _RealWorld
+#endif
+
+-- With a builtin polymorphic type for runSST the type for
+-- initTc should use  TcM s r  instead of  TcM RealWorld r 
 
 initTc :: UniqSupply
-       -> TcM _RealWorld r
+       -> TcM REAL_WORLD r
        -> MaybeErr (r, Bag Warning)
 		   (Bag Error, Bag  Warning)
 
 initTc us do_this
-  = _runSST (
+  = runSST (
       newMutVarSST us 			`thenSST` \ us_var ->
       newMutVarSST (emptyBag,emptyBag)	`thenSST` \ errs_var ->
       newMutVarSST emptyUFM		`thenSST` \ tvs_var ->
@@ -229,7 +242,7 @@ forkNF_Tc m (TcDown deflts u_var src_loc err_cxt err_var) env
 	(us1, us2) = splitUniqSupply us
     in
     writeMutVarSST u_var us1	`thenSST_`
-    returnSST (_runSST (
+    returnSST ( runSST (
 	newMutVarSST us2 			`thenSST` \ u_var'   ->
       	newMutVarSST (emptyBag,emptyBag)	`thenSST` \ err_var' ->
       	newMutVarSST emptyUFM			`thenSST` \ tv_var'  ->
@@ -306,8 +319,20 @@ recoverNF_Tc recover m down env
 tryTc :: TcM s r -> TcM s r -> TcM s r
 tryTc recover m down env
   = recoverFSST (\ _ -> recover down env) $
+
     newMutVarSST (emptyBag,emptyBag)	`thenSST` \ new_errs_var ->
-    m (setTcErrs down new_errs_var) env
+
+    m (setTcErrs down new_errs_var) env	`thenFSST` \ result ->
+
+	-- Check that m has no errors; if it has internal recovery
+	-- mechanisms it might "succeed" but having found a bunch of
+	-- errors along the way. If so we want tryTc to use 
+	-- "recover" instead
+    readMutVarSST new_errs_var		`thenSST` \ (_,errs) ->
+    if isEmptyBag errs then
+	returnFSST result
+    else
+	recover down env
 
 checkTc :: Bool -> Message -> TcM s ()		-- Check that the boolean is true
 checkTc True  err = returnTc ()
@@ -449,7 +474,7 @@ getErrCtxt (TcDown def us loc ctxt errs)     = ctxt
 %~~~~~~~~~~~~~~~~~~
 
 \begin{code}
-rnMtoTcM :: RnEnv -> RnM _RealWorld a -> NF_TcM s (a, Bag Error)
+rnMtoTcM :: RnEnv -> RnM REAL_WORLD a -> NF_TcM s (a, Bag Error)
 
 rnMtoTcM rn_env rn_action down env
   = readMutVarSST u_var				`thenSST` \ uniq_supply ->
@@ -459,7 +484,20 @@ rnMtoTcM rn_env rn_action down env
     writeMutVarSST u_var new_uniq_supply	`thenSST_`
     let
 	(rn_result, rn_errs, rn_warns)
-	  = initRn True (panic "rnMtoTcM:module") rn_env uniq_s rn_action
+	  = initRn False{-*interface* mode! so we can see the builtins-}
+		   (panic "rnMtoTcM:module")
+		   rn_env uniq_s (
+		rn_action	`thenRn` \ result ->
+
+		-- Though we are in "interface mode", we must
+		-- not have added anything to the ImplicitEnv!
+		getImplicitUpRn	`thenRn` \ implicit_env@(v_env,tc_env) ->
+		if (isEmptyFM v_env && isEmptyFM tc_env)
+		then returnRn result
+		else panic "rnMtoTcM: non-empty ImplicitEnv!"
+--			(ppAboves ([ ppCat [ppPStr m, ppPStr n] | (OrigName m n) <- keysFM v_env]
+--				++ [ ppCat [ppPStr m, ppPStr n] | (OrigName m n) <- keysFM tc_env]))
+	    )
     in
     returnSST (rn_result, rn_errs)
   where