Hi, On Thu, Sep 04, 2003 at 10:45:17AM +0100, Simon Marlow wrote: > > > > Would anything prevent block, unblock, bracket (and other similar > > functions working on IO actions) from being generalized to all > > intances of MonadIO? > > I'm afraid I can't see a way to generalise the types of block and > unblock, since they are based on underlying primitives that really do > have type (IO a -> IO a). Perhaps if your monad is isomorphic to IO, it > could be done, but otherwise I don't think it's possible. Unless I'm > missing something.
It can be done by adding the right methods to the MonadIO class, with these rank-2 types: > 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 See the attached patch for the details. This solution is maybe a bit ugly, since these methods are fairly specific (liftIO' is needed to generalize block and unblock, and liftIO'' is needed to generalize catchException). But it does allow one to use catch/bracket/etc with monads built on top of IO with monad transformers, which is quite nice: > import Control.Monad.Reader > > type M = ReaderT Int IO > > main' :: M () > main' = catch > (do n <- ask > liftIO (putStrLn (show n))) > (\ e -> return ()) > > main :: IO () > main = > runReaderT main' 1 -- Sebastien P.S.: The patch moves the MonadIO class to GHC.IOBase, which already contains a function called ``liftIO'', but which does not appear to be used anywhere; I just commented it out...
diff -r -u 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-04 18:14:06.000000000
+0100
@@ -112,7 +112,7 @@
import GHC.Base ( assert )
import GHC.Exception as ExceptionBase hiding (catch)
import GHC.Conc ( throwTo, ThreadId )
-import GHC.IOBase ( IO(..) )
+import GHC.IOBase ( IO(..), MonadIO(..) )
#endif
#ifdef __HUGS__
@@ -173,9 +173,10 @@
-- "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 :: MonadIO m
+ => m a -- ^ The computation to run
+ -> (Exception -> m a) -- ^ Handler to invoke if an exception is raised
+ -> m a
catch = ExceptionBase.catchException
-- | The function 'catchJust' is like 'catch', but it takes an extra
@@ -370,10 +371,11 @@
-- > 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
@@ -383,7 +385,7 @@
after a
return r
)
-
+
-- | A specialised variant of 'bracket' with just a computation to run
-- afterward.
diff -r -u 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-04 18:46:10.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 -r -u 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-04 18:45:18.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 -r -u 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-04 18:43:48.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 -r -u 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-04 18:43:08.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 -r -u 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-04 18:50:42.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 -r -u 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-04 18:39:29.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 -r -u 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-04 16:59:31.000000000
+0100
@@ -20,12 +20,13 @@
module Control.Monad.Trans (
MonadTrans(..),
- MonadIO(..),
+ MonadIO(..),
) where
import Prelude
import System.IO
+import GHC.IOBase ( MonadIO(..) )
-- ---------------------------------------------------------------------------
-- MonadTrans class
@@ -36,9 +37,3 @@
class MonadTrans t where
lift :: Monad m => m a -> t m a
-
-class (Monad m) => MonadIO m where
- liftIO :: IO a -> m a
-
-instance MonadIO IO where
- liftIO = id
diff -r -u 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-04 18:39:11.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
diff -r -u ghc-6.0.1.orig/libraries/base/GHC/Exception.lhs
ghc-6.0.1/libraries/base/GHC/Exception.lhs
--- ghc-6.0.1.orig/libraries/base/GHC/Exception.lhs 2003-01-16 14:38:40.000000000
+0000
+++ ghc-6.0.1/libraries/base/GHC/Exception.lhs 2003-09-04 18:49:15.000000000 +0100
@@ -44,10 +44,11 @@
have to work around that in the definition of catchException below).
\begin{code}
-catchException :: IO a -> (Exception -> IO a) -> IO a
-catchException (IO m) k = IO $ \s -> catch# m (\ex -> unIO (k ex)) s
+catchException :: MonadIO m => m a -> (Exception -> m a) -> m a
+catchException = liftIO'' catchException'
+ where catchException' (IO m) k = IO $ \s -> catch# m (\ex -> unIO (k ex)) s
-catch :: IO a -> (IOError -> IO a) -> IO a
+catch :: MonadIO m => m a -> (IOError -> m a) -> m a
catch m k = catchException m handler
where handler (IOException err) = k err
handler other = throw other
@@ -69,17 +70,19 @@
-- no need to worry about re-enabling asynchronous exceptions; that is
-- done automatically on exiting the scope of
-- 'block'.
-block :: IO a -> IO a
+block :: MonadIO m => m a -> m a
-- | To re-enable asynchronous exceptions inside the scope of
-- 'block', 'unblock' can be
-- used. It scopes in exactly the same way, so on exit from
-- 'unblock' asynchronous exception delivery will
-- be disabled again.
-unblock :: IO a -> IO a
+unblock :: MonadIO m => m a -> m a
-block (IO io) = IO $ blockAsyncExceptions# io
-unblock (IO io) = IO $ unblockAsyncExceptions# io
+block = liftIO' block'
+ where block' (IO io) = IO $ blockAsyncExceptions# io
+unblock = liftIO' block'
+ where block' (IO io) = IO $ unblockAsyncExceptions# io
\end{code}
diff -r -u ghc-6.0.1.orig/libraries/base/GHC/IOBase.lhs
ghc-6.0.1/libraries/base/GHC/IOBase.lhs
--- ghc-6.0.1.orig/libraries/base/GHC/IOBase.lhs 2003-05-23 12:05:33.000000000
+0100
+++ ghc-6.0.1/libraries/base/GHC/IOBase.lhs 2003-09-04 18:25:35.000000000 +0100
@@ -88,11 +88,21 @@
m >>= k = bindIO m k
fail s = failIO s
+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
+
failIO :: String -> IO a
failIO s = ioError (userError s)
-liftIO :: IO a -> State# RealWorld -> STret RealWorld a
-liftIO (IO m) = \s -> case m s of (# s', r #) -> STret s' r
+-- liftIO :: IO a -> State# RealWorld -> STret RealWorld a
+-- liftIO (IO m) = \s -> case m s of (# s', r #) -> STret s' r
bindIO :: IO a -> (a -> IO b) -> IO b
bindIO (IO m) k = IO ( \ s ->
pgp00000.pgp
Description: PGP signature
