--
-- The IO Monad with an environment
--
+{-# LANGUAGE UndecidableInstances #-}
module IOEnv (
IOEnv, -- Instance of Monad
tryM, tryAllM, tryMostM, fixM,
-- I/O operations
- IORef, newMutVar, readMutVar, writeMutVar, updMutVar
+ IORef, newMutVar, readMutVar, writeMutVar, updMutVar,
+ atomicUpdMutVar, atomicUpdMutVar'
) where
import Exception
import Panic
-import Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef )
+import Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef,
+ atomicModifyIORef )
import Data.Typeable
import System.IO.Unsafe ( unsafeInterleaveIO )
import System.IO ( fixIO )
+import Control.Monad
import MonadUtils
----------------------------------------------------------------------
unIOEnv (f r) env })
thenM_ :: IOEnv env a -> IOEnv env b -> IOEnv env b
-thenM_ (IOEnv m) f = IOEnv (\ env -> do { m env ; unIOEnv f env })
+thenM_ (IOEnv m) f = IOEnv (\ env -> do { _ <- m env ; unIOEnv f env })
failM :: IOEnv env a
failM = IOEnv (\ _ -> throwIO IOEnvFailure)
----------------------------------------------------------------------
+-- MonadPlus
+----------------------------------------------------------------------
+
+-- For use if the user has imported Control.Monad.Error from MTL
+-- Requires UndecidableInstances
+instance MonadPlus IO => MonadPlus (IOEnv env) where
+ mzero = IOEnv (const mzero)
+ m `mplus` n = IOEnv (\env -> unIOEnv m env `mplus` unIOEnv n env)
+
+----------------------------------------------------------------------
-- Accessing input/output
----------------------------------------------------------------------
updMutVar :: IORef a -> (a -> a) -> IOEnv env ()
updMutVar var upd = liftIO (modifyIORef var upd)
+-- | Atomically update the reference. Does not force the evaluation of the
+-- new variable contents. For strict update, use 'atomicUpdMutVar''.
+atomicUpdMutVar :: IORef a -> (a -> (a, b)) -> IOEnv env b
+atomicUpdMutVar var upd = liftIO (atomicModifyIORef var upd)
+
+-- | Strict variant of 'atomicUpdMutVar'.
+atomicUpdMutVar' :: IORef a -> (a -> (a, b)) -> IOEnv env b
+atomicUpdMutVar' var upd = do
+ r <- atomicUpdMutVar var upd
+ _ <- liftIO . evaluate =<< readMutVar var
+ return r
----------------------------------------------------------------------
-- Accessing the environment