X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Control%2FMonad%2FST.hs;h=c51ea9a36376c194c602cc1421551da7f9b38337;hb=7316246c1797d46f5757ae156486f09b3db083d9;hp=3ea3bb3910784712d162b0ab26575e01057b8922;hpb=d539a9457e2c79a9f13744d073d3f253ea2fb33e;p=ghc-base.git

diff --git a/Control/Monad/ST.hs b/Control/Monad/ST.hs
index 3ea3bb3..c51ea9a 100644
--- a/Control/Monad/ST.hs
+++ b/Control/Monad/ST.hs
@@ -21,24 +21,28 @@ module Control.Monad.ST
 	runST,		-- :: (forall s. ST s a) -> a
 	fixST,		-- :: (a -> ST s a) -> ST s a
 
-	-- * Unsafe operations
-	unsafeInterleaveST,  	-- :: ST s a -> ST s a
-	unsafeIOToST,		-- :: IO a -> ST s a
-
 	-- * Converting 'ST' to 'IO'
 	RealWorld,		-- abstract
-	stToIO			-- :: ST RealWorld a -> IO a
+	stToIO,			-- :: ST RealWorld a -> IO a
+
+	-- * Unsafe operations
+	unsafeInterleaveST,  	-- :: ST s a -> ST s a
+	unsafeIOToST		-- :: IO a -> ST s a
       ) where
 
 import Prelude
 
 import Control.Monad.Fix
-import Data.Typeable
+
+#include "Typeable.h"
 
 #ifdef __HUGS__
+import Data.Typeable
 import Hugs.ST
 import qualified Hugs.LazyST as LazyST
 
+INSTANCE_TYPEABLE0(RealWorld,realWorldTc,"RealWorld")
+
 fixST :: (a -> ST s a) -> ST s a
 fixST f = LazyST.lazyToStrictST (LazyST.fixST (LazyST.strictToLazyST . f))
 
@@ -48,26 +52,11 @@ unsafeInterleaveST =
 #endif
 
 #ifdef __GLASGOW_HASKELL__
-import GHC.ST
-import GHC.Base		( unsafeCoerce#, RealWorld )
-import GHC.IOBase 	( IO(..), stToIO )
-
--- This relies on IO and ST having the same representation modulo the
--- constraint on the type of the state
---
-unsafeIOToST        :: IO a -> ST s a
-unsafeIOToST (IO io) = ST $ \ s -> (unsafeCoerce# io) s
+import GHC.ST		( ST, runST, fixST, unsafeInterleaveST )
+import GHC.Base		( RealWorld )
+import GHC.IOBase 	( stToIO, unsafeIOToST )
 #endif
 
 instance MonadFix (ST s) where
 	mfix = fixST
 
--- ---------------------------------------------------------------------------
--- Typeable instance
-
-sTTc :: TyCon
-sTTc = mkTyCon "ST"
-
-instance (Typeable a, Typeable b) => Typeable (ST a b) where
-  typeOf st = mkAppTy sTTc [typeOf ((undefined :: ST a b -> a) st),
-			    typeOf ((undefined :: ST a b -> b) st)]