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--