{-# LANGUAGE CPP #-}
{- |
Module      :  Control.Monad.IO.Peel
Copyright   :  © Anders Kaseorg, 2010
License     :  BSD-style

Maintainer  :  Anders Kaseorg <andersk@mit.edu>
Stability   :  experimental
Portability :  portable

This module defines the class 'MonadPeelIO' of 'IO'-based monads into
which control operations on 'IO' (such as exception catching; see
"Control.Exception.Peel") can be lifted.

'liftIOOp' and 'liftIOOp_' enable convenient lifting of two common
special cases of control operation types.
-}

module Control.Monad.IO.Peel (
  MonadPeelIO(..),
  liftIOOp,
  liftIOOp_,
  ) where

import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Peel
import Control.Monad.Trans.Identity
import Control.Monad.Trans.Maybe
#if MIN_VERSION_transformers(0,4,0)
import qualified Control.Monad.Trans.Except as Except
#endif
import Control.Monad.Trans.Reader
import Control.Monad.Trans.State
import qualified Control.Monad.Trans.State.Strict as Strict
import Control.Monad.Trans.Writer
import qualified Control.Monad.Trans.Writer.Strict as Strict
import qualified Control.Monad.Trans.RWS as RWS
import qualified Control.Monad.Trans.RWS.Strict as RWS.Strict
import Data.Monoid

-- |@MonadPeelIO@ is the class of 'IO'-based monads supporting an
-- extra operation 'peelIO', enabling control operations on 'IO' to be
-- lifted into the monad.
class MonadIO m => MonadPeelIO m where
  -- |@peelIO@ is a version of 'peel' that operates through an
  -- arbitrary stack of monad transformers directly to an inner 'IO'
  -- (analagously to how 'liftIO' is a version of @lift@).  So it can
  -- be used with 'liftIO' to lift control operations on 'IO' into any
  -- monad in 'MonadPeelIO'.  For example:
  --
  -- @
  --    foo :: 'IO' a -> 'IO' a
  --    foo' :: 'MonadPeelIO' m => m a -> m a
  --    foo' a = do
  --      k \<- 'peelIO'  -- k :: m a -> IO (m a)
  --      'join' $ 'liftIO' $ foo (k a)  -- uses foo :: 'IO' (m a) -> 'IO' (m a)
  -- @
  --
  -- Note that the \"obvious\" term of this type (@peelIO = 'return'
  -- 'return'@) /does not/ work correctly.  Instances of 'MonadPeelIO'
  -- should be constructed via 'MonadTransPeel', using @peelIO =
  -- 'liftPeel' peelIO@.
  peelIO :: m (m a -> IO (m a))

instance MonadPeelIO IO where
  peelIO :: forall a. IO (IO a -> IO (IO a))
peelIO = forall (m :: * -> *) (n :: * -> *) (o :: * -> *) a.
(Monad m, Monad n, Monad o) =>
n (m a -> m (o a))
idPeel

instance MonadPeelIO m => MonadPeelIO (IdentityT m) where
  peelIO :: forall a. IdentityT m (IdentityT m a -> IO (IdentityT m a))
peelIO = forall (t :: (* -> *) -> * -> *) (m :: * -> *) (m' :: * -> *)
       (n' :: * -> *) (o' :: * -> *) a.
(MonadTransPeel t, Monad m, Monad m', Monad n', Monad (t n'),
 Monad o', Monad (t o')) =>
n' (m' (t o' a) -> m (o' (t o' a))) -> t n' (t m' a -> m (t o' a))
liftPeel forall (m :: * -> *) a. MonadPeelIO m => m (m a -> IO (m a))
peelIO
instance MonadPeelIO m => MonadPeelIO (MaybeT m) where
  peelIO :: forall a. MaybeT m (MaybeT m a -> IO (MaybeT m a))
peelIO = forall (t :: (* -> *) -> * -> *) (m :: * -> *) (m' :: * -> *)
       (n' :: * -> *) (o' :: * -> *) a.
(MonadTransPeel t, Monad m, Monad m', Monad n', Monad (t n'),
 Monad o', Monad (t o')) =>
n' (m' (t o' a) -> m (o' (t o' a))) -> t n' (t m' a -> m (t o' a))
liftPeel forall (m :: * -> *) a. MonadPeelIO m => m (m a -> IO (m a))
peelIO
#if MIN_VERSION_transformers(0,4,0)
instance MonadPeelIO m => MonadPeelIO (Except.ExceptT e m) where
  peelIO :: forall a. ExceptT e m (ExceptT e m a -> IO (ExceptT e m a))
peelIO = forall (t :: (* -> *) -> * -> *) (m :: * -> *) (m' :: * -> *)
       (n' :: * -> *) (o' :: * -> *) a.
(MonadTransPeel t, Monad m, Monad m', Monad n', Monad (t n'),
 Monad o', Monad (t o')) =>
n' (m' (t o' a) -> m (o' (t o' a))) -> t n' (t m' a -> m (t o' a))
liftPeel forall (m :: * -> *) a. MonadPeelIO m => m (m a -> IO (m a))
peelIO
#endif
instance MonadPeelIO m => MonadPeelIO (ReaderT r m) where
  peelIO :: forall a. ReaderT r m (ReaderT r m a -> IO (ReaderT r m a))
peelIO = forall (t :: (* -> *) -> * -> *) (m :: * -> *) (m' :: * -> *)
       (n' :: * -> *) (o' :: * -> *) a.
(MonadTransPeel t, Monad m, Monad m', Monad n', Monad (t n'),
 Monad o', Monad (t o')) =>
n' (m' (t o' a) -> m (o' (t o' a))) -> t n' (t m' a -> m (t o' a))
liftPeel forall (m :: * -> *) a. MonadPeelIO m => m (m a -> IO (m a))
peelIO
instance MonadPeelIO m => MonadPeelIO (StateT s m) where
  peelIO :: forall a. StateT s m (StateT s m a -> IO (StateT s m a))
peelIO = forall (t :: (* -> *) -> * -> *) (m :: * -> *) (m' :: * -> *)
       (n' :: * -> *) (o' :: * -> *) a.
(MonadTransPeel t, Monad m, Monad m', Monad n', Monad (t n'),
 Monad o', Monad (t o')) =>
n' (m' (t o' a) -> m (o' (t o' a))) -> t n' (t m' a -> m (t o' a))
liftPeel forall (m :: * -> *) a. MonadPeelIO m => m (m a -> IO (m a))
peelIO
instance MonadPeelIO m => MonadPeelIO (Strict.StateT s m) where
  peelIO :: forall a. StateT s m (StateT s m a -> IO (StateT s m a))
peelIO = forall (t :: (* -> *) -> * -> *) (m :: * -> *) (m' :: * -> *)
       (n' :: * -> *) (o' :: * -> *) a.
(MonadTransPeel t, Monad m, Monad m', Monad n', Monad (t n'),
 Monad o', Monad (t o')) =>
n' (m' (t o' a) -> m (o' (t o' a))) -> t n' (t m' a -> m (t o' a))
liftPeel forall (m :: * -> *) a. MonadPeelIO m => m (m a -> IO (m a))
peelIO
instance (Monoid w, MonadPeelIO m) => MonadPeelIO (WriterT w m) where
  peelIO :: forall a. WriterT w m (WriterT w m a -> IO (WriterT w m a))
peelIO = forall (t :: (* -> *) -> * -> *) (m :: * -> *) (m' :: * -> *)
       (n' :: * -> *) (o' :: * -> *) a.
(MonadTransPeel t, Monad m, Monad m', Monad n', Monad (t n'),
 Monad o', Monad (t o')) =>
n' (m' (t o' a) -> m (o' (t o' a))) -> t n' (t m' a -> m (t o' a))
liftPeel forall (m :: * -> *) a. MonadPeelIO m => m (m a -> IO (m a))
peelIO
instance (Monoid w, MonadPeelIO m) => MonadPeelIO (Strict.WriterT w m) where
  peelIO :: forall a. WriterT w m (WriterT w m a -> IO (WriterT w m a))
peelIO = forall (t :: (* -> *) -> * -> *) (m :: * -> *) (m' :: * -> *)
       (n' :: * -> *) (o' :: * -> *) a.
(MonadTransPeel t, Monad m, Monad m', Monad n', Monad (t n'),
 Monad o', Monad (t o')) =>
n' (m' (t o' a) -> m (o' (t o' a))) -> t n' (t m' a -> m (t o' a))
liftPeel forall (m :: * -> *) a. MonadPeelIO m => m (m a -> IO (m a))
peelIO
instance (Monoid w, MonadPeelIO m) => MonadPeelIO (RWS.RWST r w s m) where
  peelIO :: forall a. RWST r w s m (RWST r w s m a -> IO (RWST r w s m a))
peelIO = forall (t :: (* -> *) -> * -> *) (m :: * -> *) (m' :: * -> *)
       (n' :: * -> *) (o' :: * -> *) a.
(MonadTransPeel t, Monad m, Monad m', Monad n', Monad (t n'),
 Monad o', Monad (t o')) =>
n' (m' (t o' a) -> m (o' (t o' a))) -> t n' (t m' a -> m (t o' a))
liftPeel forall (m :: * -> *) a. MonadPeelIO m => m (m a -> IO (m a))
peelIO
instance (Monoid w, MonadPeelIO m) =>
         MonadPeelIO (RWS.Strict.RWST r w s m) where
  peelIO :: forall a. RWST r w s m (RWST r w s m a -> IO (RWST r w s m a))
peelIO = forall (t :: (* -> *) -> * -> *) (m :: * -> *) (m' :: * -> *)
       (n' :: * -> *) (o' :: * -> *) a.
(MonadTransPeel t, Monad m, Monad m', Monad n', Monad (t n'),
 Monad o', Monad (t o')) =>
n' (m' (t o' a) -> m (o' (t o' a))) -> t n' (t m' a -> m (t o' a))
liftPeel forall (m :: * -> *) a. MonadPeelIO m => m (m a -> IO (m a))
peelIO


-- |@liftIOOp@ is a particular application of 'peelIO' that allows
-- lifting control operations of type @(a -> 'IO' b) -> 'IO' b@
-- (e.g. @alloca@, @withMVar v@) to @'MonadPeelIO' m => (a -> m b) ->
-- m b@.
--
-- @
--    'liftIOOp' f g = do
--      k \<- 'peelIO'
--      'join' $ 'liftIO' $ f (k . g)
-- @
liftIOOp :: MonadPeelIO m => ((a -> IO (m b)) -> IO (m c)) -> (a -> m b) -> m c
liftIOOp :: forall (m :: * -> *) a b c.
MonadPeelIO m =>
((a -> IO (m b)) -> IO (m c)) -> (a -> m b) -> m c
liftIOOp (a -> IO (m b)) -> IO (m c)
f a -> m b
g = do
  m b -> IO (m b)
k <- forall (m :: * -> *) a. MonadPeelIO m => m (m a -> IO (m a))
peelIO
  forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ (a -> IO (m b)) -> IO (m c)
f (m b -> IO (m b)
k forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m b
g)

-- |@liftIOOp_@ is a particular application of 'peelIO' that allows
-- lifting control operations of type @'IO' a -> 'IO' a@
-- (e.g. @block@) to @'MonadPeelIO' m => m a -> m a@.
--
-- @
--    'liftIOOp_' f m = do
--      k \<- 'peelIO'
--      'join' $ 'liftIO' $ f (k m)
-- @
liftIOOp_ :: MonadPeelIO m => (IO (m a) -> IO (m b)) -> m a -> m b
liftIOOp_ :: forall (m :: * -> *) a b.
MonadPeelIO m =>
(IO (m a) -> IO (m b)) -> m a -> m b
liftIOOp_ IO (m a) -> IO (m b)
f m a
m = do
  m a -> IO (m a)
k <- forall (m :: * -> *) a. MonadPeelIO m => m (m a -> IO (m a))
peelIO
  forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO (m a) -> IO (m b)
f (m a -> IO (m a)
k m a
m)