bracket, (un)block and MonadIO
Sebastien Carlier
sebc@macs.hw.ac.uk
Fri, 5 Sep 2003 12:48:10 +0100
--Boundary-00=_6fHW/oi3L7H2dxq
Content-Type: Text/Plain;
charset="iso-8859-1"
Content-Transfer-Encoding: quoted-printable
Content-Description: clearsigned data
Content-Disposition: inline
=2D----BEGIN PGP SIGNED MESSAGE-----
Hash: SHA1
On Friday 05 September 2003 10:48 am, Simon Marlow wrote:
>
> Thanks. I think I would prefer to have the generalised versions of
> block/unblock/catchException separate from the IO-specific versions, and
> exported by one of the Control.Monad modules, to avoid breaking too much
> code, and to avoid wiring MonadIO in too deeply.
=46ine, I understand.
> Would you mind redoing the patch?
The attached patch only changes modules under Control. It also generalizes=
=20
block, unblock, catch, catchJust, handle, handleJust, try, tryJust, finally=
,=20
catchDyn, bracket, and bracket_.
=2D --=20
Sebastien
=2D----BEGIN PGP SIGNATURE-----
Version: GnuPG v1.2.3 (GNU/Linux)
iD8DBQE/WHf6vtNcI2aw9NwRAsIXAKCZGlS1mvmMUndG5JIeo/sathKgxQCeJiho
xamJiT02qUtO/Qysn4VVF6Y=3D
=3Dbe2y
=2D----END PGP SIGNATURE-----
--Boundary-00=_6fHW/oi3L7H2dxq
Content-Type: text/x-diff;
charset="iso-8859-1";
name="MonadIO.patch"
Content-Transfer-Encoding: 7bit
Content-Disposition: attachment;
filename="MonadIO.patch"
diff -u -r ghc-6.0.1.orig/libraries/base/Control/Exception.hs ghc-6.0.1/libraries/base/Control/Exception.hs
--- ghc-6.0.1.orig/libraries/base/Control/Exception.hs 2003-05-12 11:16:27.000000000 +0100
+++ ghc-6.0.1/libraries/base/Control/Exception.hs 2003-09-05 12:39:46.000000000 +0100
@@ -37,16 +37,16 @@
-- 'IO' monad.
-- ** The @catch@ functions
- catch, -- :: IO a -> (Exception -> IO a) -> IO a
- catchJust, -- :: (Exception -> Maybe b) -> IO a -> (b -> IO a) -> IO a
+ catch, -- :: MonadIO m => m a -> (Exception -> m a) -> m a
+ catchJust, -- :: MonadIO m => (Exception -> Maybe b) -> m a -> (b -> m a) -> m a
-- ** The @handle@ functions
- handle, -- :: (Exception -> IO a) -> IO a -> IO a
- handleJust,-- :: (Exception -> Maybe b) -> (b -> IO a) -> IO a -> IO a
+ handle, -- :: MonadIO m => (Exception -> m a) -> m a -> m a
+ handleJust,-- :: (Exception -> Maybe b) -> (b -> m a) -> m a -> m a
-- ** The @try@ functions
- try, -- :: IO a -> IO (Either Exception a)
- tryJust, -- :: (Exception -> Maybe b) -> a -> IO (Either b a)
+ try, -- :: MonadIO m => m a -> m (Either Exception a)
+ tryJust, -- :: MonadIO m => (Exception -> Maybe b) -> a -> m (Either b a)
-- ** The @evaluate@ function
evaluate, -- :: a -> IO a
@@ -73,7 +73,7 @@
#ifdef __GLASGOW_HASKELL__
throwDynTo, -- :: Typeable ex => ThreadId -> ex -> b
#endif
- catchDyn, -- :: Typeable ex => IO a -> (ex -> IO a) -> IO a
+ catchDyn, -- :: (MonadIO m, Typeable ex) => m a -> (ex -> m a) -> m a
-- * Asynchronous Exceptions
@@ -84,8 +84,8 @@
-- |The following two functions allow a thread to control delivery of
-- asynchronous exceptions during a critical region.
- block, -- :: IO a -> IO a
- unblock, -- :: IO a -> IO a
+ block, -- :: MonadIO m => m a -> m a
+ unblock, -- :: MonadIO m => m a -> m a
-- *** Applying @block@ to an exception handler
@@ -101,16 +101,19 @@
-- * Utilities
- bracket, -- :: IO a -> (a -> IO b) -> (a -> IO c) -> IO ()
- bracket_, -- :: IO a -> IO b -> IO c -> IO ()
+ bracket, -- :: MonadIO m => m a -> (a -> m b) -> (a -> m c) -> m ()
+ bracket_, -- :: MonadIO m => m a -> m b -> m c -> m ()
- finally, -- :: IO a -> IO b -> IO b
+ finally, -- :: MonadIO m => m a -> m b -> m b
+
+ MonadIO( liftIO )
) where
#ifdef __GLASGOW_HASKELL__
import GHC.Base ( assert )
-import GHC.Exception as ExceptionBase hiding (catch)
+import GHC.Exception hiding ( block, unblock, catch )
+import qualified GHC.Exception as ExceptionBase
import GHC.Conc ( throwTo, ThreadId )
import GHC.IOBase ( IO(..) )
#endif
@@ -123,6 +126,7 @@
import System.IO.Error hiding ( catch, try )
import System.IO.Unsafe (unsafePerformIO)
import Data.Dynamic
+import Control.Monad.Trans ( MonadIO(..) )
#include "Dynamic.h"
INSTANCE_TYPEABLE0(Exception,exceptionTc,"Exception")
@@ -173,10 +177,11 @@
-- "Control.Exception", or importing
-- "Control.Exception" qualified, to avoid name-clashes.
-catch :: IO a -- ^ The computation to run
- -> (Exception -> IO a) -- ^ Handler to invoke if an exception is raised
- -> IO a
-catch = ExceptionBase.catchException
+catch :: MonadIO m
+ => m a -- ^ The computation to run
+ -> (Exception -> m a) -- ^ Handler to invoke if an exception is raised
+ -> m a
+catch = liftIO'' ExceptionBase.catchException
-- | The function 'catchJust' is like 'catch', but it takes an extra
-- argument which is an /exception predicate/, a function which
@@ -191,13 +196,14 @@
-- are re-raised, and may be caught by an enclosing
-- 'catch' or 'catchJust'.
catchJust
- :: (Exception -> Maybe b) -- ^ Predicate to select exceptions
- -> IO a -- ^ Computation to run
- -> (b -> IO a) -- ^ Handler
- -> IO a
+ :: MonadIO m
+ => (Exception -> Maybe b) -- ^ Predicate to select exceptions
+ -> m a -- ^ Computation to run
+ -> (b -> m a) -- ^ Handler
+ -> m a
catchJust p a handler = catch a handler'
where handler' e = case p e of
- Nothing -> throw e
+ Nothing -> liftIO $ throw e
Just b -> handler b
-- | A version of 'catch' with the arguments swapped around; useful in
@@ -205,13 +211,13 @@
--
-- > do handle (\e -> exitWith (ExitFailure 1)) $
-- > ...
-handle :: (Exception -> IO a) -> IO a -> IO a
-handle = flip catch
+handle :: MonadIO m => (Exception -> m a) -> m a -> m a
+handle = flip catch
-- | A version of 'catchJust' with the arguments swapped around (see
-- 'handle').
-handleJust :: (Exception -> Maybe b) -> (b -> IO a) -> IO a -> IO a
-handleJust p = flip (catchJust p)
+handleJust :: MonadIO m => (Exception -> Maybe b) -> (b -> m a) -> m a -> m a
+handleJust p = flip (catchJust p)
-----------------------------------------------------------------------------
-- evaluate
@@ -257,19 +263,19 @@
-- to re-throw the exception after performing whatever cleanup is needed.
-- Otherwise, 'tryJust' is generally considered to be better.
--
-try :: IO a -> IO (Either Exception a)
+try :: MonadIO m => m a -> m (Either Exception a)
try a = catch (a >>= \ v -> return (Right v)) (\e -> return (Left e))
-- | A variant of 'try' that takes an exception predicate to select
-- which exceptions are caught (c.f. 'catchJust'). If the exception
-- does not match the predicate, it is re-thrown.
-tryJust :: (Exception -> Maybe b) -> IO a -> IO (Either b a)
+tryJust :: MonadIO m => (Exception -> Maybe b) -> m a -> m (Either b a)
tryJust p a = do
r <- try a
case r of
Right v -> return (Right v)
Left e -> case p e of
- Nothing -> throw e
+ Nothing -> liftIO $ throw e
Just b -> return (Left b)
-----------------------------------------------------------------------------
@@ -301,14 +307,14 @@
-- datatype to use for your exception type, to avoid possible clashes
-- with dynamic exceptions used in other libraries.
--
-catchDyn :: Typeable exception => IO a -> (exception -> IO a) -> IO a
-catchDyn m k = catchException m handle
+catchDyn :: (MonadIO m, Typeable exception) => m a -> (exception -> m a) -> m a
+catchDyn m k = liftIO'' catchException m handle
where handle ex = case ex of
(DynException dyn) ->
case fromDynamic dyn of
Just exception -> k exception
- Nothing -> throw ex
- _ -> throw ex
+ Nothing -> liftIO $ throw ex
+ _ -> liftIO $ throw ex
-----------------------------------------------------------------------------
-- Exception Predicates
@@ -370,42 +376,52 @@
-- > withFile name = bracket (openFile name) hClose
--
bracket
- :: IO a -- ^ computation to run first (\"acquire resource\")
- -> (a -> IO b) -- ^ computation to run last (\"release resource\")
- -> (a -> IO c) -- ^ computation to run in-between
- -> IO c -- returns the value from the in-between computation
+ :: MonadIO m
+ => m a -- ^ computation to run first (\"acquire resource\")
+ -> (a -> m b) -- ^ computation to run last (\"release resource\")
+ -> (a -> m c) -- ^ computation to run in-between
+ -> m c -- returns the value from the in-between computation
bracket before after thing =
block (do
a <- before
r <- catch
(unblock (thing a))
- (\e -> do { after a; throw e })
+ (\e -> do { after a; liftIO $ throw e })
after a
return r
)
-
+
-- | A specialised variant of 'bracket' with just a computation to run
-- afterward.
--
-finally :: IO a -- ^ computation to run first
- -> IO b -- ^ computation to run afterward (even if an exception
+finally :: MonadIO m
+ => m a -- ^ computation to run first
+ -> m b -- ^ computation to run afterward (even if an exception
-- was raised)
- -> IO a -- returns the value from the first computation
+ -> m a -- returns the value from the first computation
a `finally` sequel =
block (do
r <- catch
(unblock a)
- (\e -> do { sequel; throw e })
+ (\e -> do { sequel; liftIO $ throw e })
sequel
return r
)
-- | A variant of 'bracket' where the return value from the first computation
-- is not required.
-bracket_ :: IO a -> IO b -> IO c -> IO c
+bracket_ :: MonadIO m => m a -> m b -> m c -> m c
bracket_ before after thing = bracket before (const after) (const thing)
+-- | A generalized version of 'block'
+block :: MonadIO m => m a -> m a
+block = liftIO' ExceptionBase.block
+
+-- | A generalized version of 'unblock'
+unblock :: MonadIO m => m a -> m a
+unblock = liftIO' ExceptionBase.unblock
+
-- -----------------------------------------------------------------------------
-- Asynchronous exceptions
diff -u -r ghc-6.0.1.orig/libraries/base/Control/Monad/Cont.hs ghc-6.0.1/libraries/base/Control/Monad/Cont.hs
--- ghc-6.0.1.orig/libraries/base/Control/Monad/Cont.hs 2003-05-14 18:31:47.000000000 +0100
+++ ghc-6.0.1/libraries/base/Control/Monad/Cont.hs 2003-09-05 11:20:58.000000000 +0100
@@ -77,6 +77,8 @@
instance (MonadIO m) => MonadIO (ContT r m) where
liftIO = lift . liftIO
+ liftIO' f m = ContT $ \ k -> liftIO' f (runContT m k)
+ liftIO'' f m1 m2 = ContT $ \ k -> liftIO'' f (runContT m1 k) (\ e -> runContT (m2 e) k)
instance (MonadReader r' m) => MonadReader r' (ContT r m) where
ask = lift ask
diff -u -r ghc-6.0.1.orig/libraries/base/Control/Monad/Error.hs ghc-6.0.1/libraries/base/Control/Monad/Error.hs
--- ghc-6.0.1.orig/libraries/base/Control/Monad/Error.hs 2003-05-14 18:31:47.000000000 +0100
+++ ghc-6.0.1/libraries/base/Control/Monad/Error.hs 2003-09-05 11:20:58.000000000 +0100
@@ -167,6 +167,8 @@
instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where
liftIO = lift . liftIO
+ liftIO' f m = ErrorT $ liftIO' f (runErrorT m)
+ liftIO'' f m1 m2 = ErrorT $ liftIO'' f (runErrorT m1) (\ e -> runErrorT (m2 e))
instance (Error e, MonadReader r m) => MonadReader r (ErrorT e m) where
ask = lift ask
diff -u -r ghc-6.0.1.orig/libraries/base/Control/Monad/List.hs ghc-6.0.1/libraries/base/Control/Monad/List.hs
--- ghc-6.0.1.orig/libraries/base/Control/Monad/List.hs 2003-05-14 18:31:47.000000000 +0100
+++ ghc-6.0.1/libraries/base/Control/Monad/List.hs 2003-09-05 11:20:58.000000000 +0100
@@ -61,6 +61,8 @@
instance (MonadIO m) => MonadIO (ListT m) where
liftIO = lift . liftIO
+ liftIO' f m = ListT $ liftIO' f (runListT m)
+ liftIO'' f m1 m2 = ListT $ liftIO'' f (runListT m1) (\ e -> runListT (m2 e))
instance (MonadReader s m) => MonadReader s (ListT m) where
ask = lift ask
diff -u -r ghc-6.0.1.orig/libraries/base/Control/Monad/RWS.hs ghc-6.0.1/libraries/base/Control/Monad/RWS.hs
--- ghc-6.0.1.orig/libraries/base/Control/Monad/RWS.hs 2003-05-14 18:31:47.000000000 +0100
+++ ghc-6.0.1/libraries/base/Control/Monad/RWS.hs 2003-09-05 11:20:58.000000000 +0100
@@ -142,7 +142,8 @@
instance (Monoid w, MonadIO m) => MonadIO (RWST r w s m) where
liftIO = lift . liftIO
-
+ liftIO' f m = RWST $ \ r s -> liftIO' f (runRWST m r s)
+ liftIO'' f m1 m2 = RWST $ \ r s -> liftIO'' f (runRWST m1 r s) (\ e -> runRWST (m2 e) r s)
evalRWST :: (Monad m) => RWST r w s m a -> r -> s -> m (a, w)
evalRWST m r s = do
diff -u -r ghc-6.0.1.orig/libraries/base/Control/Monad/Reader.hs ghc-6.0.1/libraries/base/Control/Monad/Reader.hs
--- ghc-6.0.1.orig/libraries/base/Control/Monad/Reader.hs 2003-05-14 18:31:47.000000000 +0100
+++ ghc-6.0.1/libraries/base/Control/Monad/Reader.hs 2003-09-05 11:20:58.000000000 +0100
@@ -130,6 +130,8 @@
instance (MonadIO m) => MonadIO (ReaderT r m) where
liftIO = lift . liftIO
+ liftIO' f m = ReaderT $ \ r -> liftIO' f (runReaderT m r)
+ liftIO'' f m1 m2 = ReaderT $ \ r -> liftIO'' f (runReaderT m1 r) (\ e -> runReaderT (m2 e) r)
mapReaderT :: (m a -> n b) -> ReaderT w m a -> ReaderT w n b
mapReaderT f m = ReaderT $ f . runReaderT m
diff -u -r ghc-6.0.1.orig/libraries/base/Control/Monad/State.hs ghc-6.0.1/libraries/base/Control/Monad/State.hs
--- ghc-6.0.1.orig/libraries/base/Control/Monad/State.hs 2003-05-14 18:31:47.000000000 +0100
+++ ghc-6.0.1/libraries/base/Control/Monad/State.hs 2003-09-05 11:20:58.000000000 +0100
@@ -211,6 +211,8 @@
instance (MonadIO m) => MonadIO (StateT s m) where
liftIO = lift . liftIO
+ liftIO' f m = StateT $ \ s -> liftIO' f (runStateT m s)
+ liftIO'' f m1 m2 = StateT $ \ s -> liftIO'' f (runStateT m1 s) (\ e -> runStateT (m2 e) s)
instance (MonadReader r m) => MonadReader r (StateT s m) where
ask = lift ask
diff -u -r ghc-6.0.1.orig/libraries/base/Control/Monad/Trans.hs ghc-6.0.1/libraries/base/Control/Monad/Trans.hs
--- ghc-6.0.1.orig/libraries/base/Control/Monad/Trans.hs 2003-03-08 19:02:39.000000000 +0000
+++ ghc-6.0.1/libraries/base/Control/Monad/Trans.hs 2003-09-05 11:22:04.000000000 +0100
@@ -39,6 +39,10 @@
class (Monad m) => MonadIO m where
liftIO :: IO a -> m a
+ liftIO' :: (forall a. IO a -> IO a) -> m a -> m a
+ liftIO'' :: (forall a. IO a -> (b -> IO a) -> IO a) -> m a -> (b -> m a) -> m a
instance MonadIO IO where
liftIO = id
+ liftIO' = id
+ liftIO'' = id
diff -u -r ghc-6.0.1.orig/libraries/base/Control/Monad/Writer.hs ghc-6.0.1/libraries/base/Control/Monad/Writer.hs
--- ghc-6.0.1.orig/libraries/base/Control/Monad/Writer.hs 2003-05-14 18:31:47.000000000 +0100
+++ ghc-6.0.1/libraries/base/Control/Monad/Writer.hs 2003-09-05 11:20:58.000000000 +0100
@@ -142,6 +142,8 @@
instance (Monoid w, MonadIO m) => MonadIO (WriterT w m) where
liftIO = lift . liftIO
+ liftIO' f m = WriterT $ liftIO' f (runWriterT m)
+ liftIO'' f m1 m2 = WriterT $ liftIO'' f (runWriterT m1) (\ e -> runWriterT (m2 e))
instance (Monoid w, MonadReader r m) => MonadReader r (WriterT w m) where
ask = lift ask
--Boundary-00=_6fHW/oi3L7H2dxq--