X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Futils%2FIOEnv.hs;h=224147f6671a6d40f2f100fc8536e520149ef3b5;hb=36fa8c4890e439fe8c2a4682df2a877fa2cc606b;hp=a87413b347c09a61349e81a697c967ad3cf04859;hpb=7018caf5ea3319d575823641d03e172b85ea8791;p=ghc-hetmet.git

diff --git a/compiler/utils/IOEnv.hs b/compiler/utils/IOEnv.hs
index a87413b..224147f 100644
--- a/compiler/utils/IOEnv.hs
+++ b/compiler/utils/IOEnv.hs
@@ -28,17 +28,16 @@ module IOEnv (
 	tryM, tryAllM, tryMostM, fixM, 
 
 	-- I/O operations
-	ioToIOEnv,
 	IORef, newMutVar, readMutVar, writeMutVar, updMutVar
   ) where
 #include "HsVersions.h"
 
 import Panic		( try, tryUser, tryMost, Exception(..) )
 
-import Data.IORef	( IORef, newIORef, readIORef, writeIORef )
+import Data.IORef	( IORef, newIORef, readIORef, writeIORef, modifyIORef )
 import System.IO.Unsafe	( unsafeInterleaveIO )
 import System.IO	( fixIO )
-
+import MonadUtils
 
 ----------------------------------------------------------------------
 --		Defining the monad type
@@ -49,13 +48,17 @@ newtype IOEnv env a = IOEnv (env -> IO a)
 unIOEnv (IOEnv m) = m
 
 instance Monad (IOEnv m) where
-  (>>=)  = thenM
-  (>>)   = thenM_
-  return = returnM
-  fail s = failM	-- Ignore the string
+    (>>=)  = thenM
+    (>>)   = thenM_
+    return = returnM
+    fail s = failM	-- Ignore the string
+
+instance Applicative (IOEnv m) where
+    pure = returnM
+    IOEnv f <*> IOEnv x = IOEnv (\ env -> f env <*> x env )
 
 instance Functor (IOEnv m) where
-  fmap f (IOEnv m) = IOEnv (\ env -> fmap f (m env))
+    fmap f (IOEnv m) = IOEnv (\ env -> fmap f (m env))
 
 returnM :: a -> IOEnv env a
 returnM a = IOEnv (\ env -> return a)
@@ -126,20 +129,20 @@ unsafeInterleaveM (IOEnv m) = IOEnv (\ env -> unsafeInterleaveIO (m env))
 --	Accessing input/output
 ----------------------------------------------------------------------
 
-ioToIOEnv :: IO a -> IOEnv env a
-ioToIOEnv io = IOEnv (\ env -> io)
+instance MonadIO (IOEnv env) where
+    liftIO io = IOEnv (\ env -> io)
 
 newMutVar :: a -> IOEnv env (IORef a)
-newMutVar val = IOEnv (\ env -> newIORef val)
+newMutVar val = liftIO (newIORef val)
 
 writeMutVar :: IORef a -> a -> IOEnv env ()
-writeMutVar var val = IOEnv (\ env -> writeIORef var val)
+writeMutVar var val = liftIO (writeIORef var val)
 
 readMutVar :: IORef a -> IOEnv env a
-readMutVar var = IOEnv (\ env -> readIORef var)
+readMutVar var = liftIO (readIORef var)
 
-updMutVar :: IORef a -> (a->a) -> IOEnv env ()
-updMutVar var upd_fn = IOEnv (\ env -> do { v <- readIORef var; writeIORef var (upd_fn v) })
+updMutVar :: IORef a -> (a -> a) -> IOEnv env ()
+updMutVar var upd = liftIO (modifyIORef var upd)
 
 
 ----------------------------------------------------------------------