{-# LANGUAGE RankNTypes #-}
-- | Please see the README.md file for information on using this
-- package at <https://www.stackage.org/package/unliftio-core>.
module Control.Monad.IO.Unlift
  ( MonadUnliftIO (..)
  , UnliftIO (..)
  , askUnliftIO
  , askRunInIO
  , withUnliftIO
  , toIO
  , wrappedWithRunInIO
  , liftIOOp
  , MonadIO (..)
  ) where

import Control.Monad.IO.Class
import Control.Monad.Trans.Reader (ReaderT (..))
import Control.Monad.Trans.Identity (IdentityT (..))

-- | The ability to run any monadic action @m a@ as @IO a@.
--
-- This is more precisely a natural transformation. We need to new
-- datatype (instead of simply using a @forall@) due to lack of
-- support in GHC for impredicative types.
--
-- @since 0.1.0.0
newtype UnliftIO m = UnliftIO { UnliftIO m -> forall a. m a -> IO a
unliftIO :: forall a. m a -> IO a }

-- | Monads which allow their actions to be run in 'IO'.
--
-- While 'MonadIO' allows an 'IO' action to be lifted into another
-- monad, this class captures the opposite concept: allowing you to
-- capture the monadic context. Note that, in order to meet the laws
-- given below, the intuition is that a monad must have no monadic
-- state, but may have monadic context. This essentially limits
-- 'MonadUnliftIO' to 'ReaderT' and 'IdentityT' transformers on top of
-- 'IO'.
--
-- Laws. For any function @run@ provided by 'withRunInIO', it must meet the
-- monad transformer laws as reformulated for @MonadUnliftIO@:
--
-- * @run . return = return@
--
-- * @run (m >>= f) = run m >>= run . f@
--
-- Instances of @MonadUnliftIO@ must also satisfy the following laws:
--
-- [Identity law] @withRunInIO (\\run -> run m) = m@
-- [Inverse law]  @withRunInIO (\\_ -> m) = liftIO m@
--
-- As an example of an invalid instance, a naive implementation of
-- @MonadUnliftIO (StateT s m)@ might be
--
-- @
-- withRunInIO inner =
--   StateT $ \\s ->
--     withRunInIO $ \\run ->
--       inner (run . flip evalStateT s)
-- @
--
-- This breaks the identity law because the inner @run m@ would throw away
-- any state changes in @m@.
--
-- @since 0.1.0.0
class MonadIO m => MonadUnliftIO m where
  -- | Convenience function for capturing the monadic context and running an 'IO'
  -- action with a runner function. The runner function is used to run a monadic
  -- action @m@ in @IO@.
  --
  -- @since 0.1.0.0
  withRunInIO :: ((forall a. m a -> IO a) -> IO b) -> m b

instance MonadUnliftIO IO where
  {-# INLINE withRunInIO #-}
  withRunInIO :: ((forall a. IO a -> IO a) -> IO b) -> IO b
withRunInIO (forall a. IO a -> IO a) -> IO b
inner = (forall a. IO a -> IO a) -> IO b
inner forall a. a -> a
forall a. IO a -> IO a
id

instance MonadUnliftIO m => MonadUnliftIO (ReaderT r m) where
  {-# INLINE withRunInIO #-}
  withRunInIO :: ((forall a. ReaderT r m a -> IO a) -> IO b) -> ReaderT r m b
withRunInIO (forall a. ReaderT r m a -> IO a) -> IO b
inner =
    (r -> m b) -> ReaderT r m b
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((r -> m b) -> ReaderT r m b) -> (r -> m b) -> ReaderT r m b
forall a b. (a -> b) -> a -> b
$ \r
r ->
    ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO b) -> m b)
-> ((forall a. m a -> IO a) -> IO b) -> m b
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
run ->
    (forall a. ReaderT r m a -> IO a) -> IO b
inner (m a -> IO a
forall a. m a -> IO a
run (m a -> IO a) -> (ReaderT r m a -> m a) -> ReaderT r m a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReaderT r m a -> r -> m a) -> r -> ReaderT r m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT r m a -> r -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT r
r)

instance MonadUnliftIO m => MonadUnliftIO (IdentityT m) where
  {-# INLINE withRunInIO #-}
  withRunInIO :: ((forall a. IdentityT m a -> IO a) -> IO b) -> IdentityT m b
withRunInIO (forall a. IdentityT m a -> IO a) -> IO b
inner =
    m b -> IdentityT m b
forall k (f :: k -> *) (a :: k). f a -> IdentityT f a
IdentityT (m b -> IdentityT m b) -> m b -> IdentityT m b
forall a b. (a -> b) -> a -> b
$
    ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO b) -> m b)
-> ((forall a. m a -> IO a) -> IO b) -> m b
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
run ->
    (forall a. IdentityT m a -> IO a) -> IO b
inner (m a -> IO a
forall a. m a -> IO a
run (m a -> IO a) -> (IdentityT m a -> m a) -> IdentityT m a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdentityT m a -> m a
forall k (f :: k -> *) (a :: k). IdentityT f a -> f a
runIdentityT)

-- | Capture the current monadic context, providing the ability to
-- run monadic actions in 'IO'.
--
-- See 'UnliftIO' for an explanation of why we need a helper
-- datatype here.
--
-- Prior to version 0.2.0.0 of this library, this was a method in the
-- 'MonadUnliftIO' type class. It was moved out due to
-- <https://github.com/fpco/unliftio/issues/55>.
--
-- @since 0.1.0.0
askUnliftIO :: MonadUnliftIO m => m (UnliftIO m)
askUnliftIO :: m (UnliftIO m)
askUnliftIO = ((forall a. m a -> IO a) -> IO (UnliftIO m)) -> m (UnliftIO m)
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (\forall a. m a -> IO a
run -> UnliftIO m -> IO (UnliftIO m)
forall (m :: * -> *) a. Monad m => a -> m a
return ((forall a. m a -> IO a) -> UnliftIO m
forall (m :: * -> *). (forall a. m a -> IO a) -> UnliftIO m
UnliftIO forall a. m a -> IO a
run))
{-# INLINE askUnliftIO #-}
-- Would be better, but GHC hates us
-- askUnliftIO :: m (forall a. m a -> IO a)


-- | Same as 'askUnliftIO', but returns a monomorphic function
-- instead of a polymorphic newtype wrapper. If you only need to apply
-- the transformation on one concrete type, this function can be more
-- convenient.
--
-- @since 0.1.0.0
{-# INLINE askRunInIO #-}
askRunInIO :: MonadUnliftIO m => m (m a -> IO a)
-- withRunInIO return would be nice, but GHC 7.8.4 doesn't like it
askRunInIO :: m (m a -> IO a)
askRunInIO = ((forall a. m a -> IO a) -> IO (m a -> IO a)) -> m (m a -> IO a)
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (\forall a. m a -> IO a
run -> ((m a -> IO a) -> IO (m a -> IO a)
forall (m :: * -> *) a. Monad m => a -> m a
return (\m a
ma -> m a -> IO a
forall a. m a -> IO a
run m a
ma)))

-- | Convenience function for capturing the monadic context and running
-- an 'IO' action. The 'UnliftIO' newtype wrapper is rarely needed, so
-- prefer 'withRunInIO' to this function.
--
-- @since 0.1.0.0
{-# INLINE withUnliftIO #-}
withUnliftIO :: MonadUnliftIO m => (UnliftIO m -> IO a) -> m a
withUnliftIO :: (UnliftIO m -> IO a) -> m a
withUnliftIO UnliftIO m -> IO a
inner = m (UnliftIO m)
forall (m :: * -> *). MonadUnliftIO m => m (UnliftIO m)
askUnliftIO m (UnliftIO m) -> (UnliftIO m -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> (UnliftIO m -> IO a) -> UnliftIO m -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnliftIO m -> IO a
inner

-- | Convert an action in @m@ to an action in @IO@.
--
-- @since 0.1.0.0
{-# INLINE toIO #-}
toIO :: MonadUnliftIO m => m a -> m (IO a)
toIO :: m a -> m (IO a)
toIO m a
m = ((forall a. m a -> IO a) -> IO (IO a)) -> m (IO a)
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO (IO a)) -> m (IO a))
-> ((forall a. m a -> IO a) -> IO (IO a)) -> m (IO a)
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
run -> IO a -> IO (IO a)
forall (m :: * -> *) a. Monad m => a -> m a
return (IO a -> IO (IO a)) -> IO a -> IO (IO a)
forall a b. (a -> b) -> a -> b
$ m a -> IO a
forall a. m a -> IO a
run m a
m

{- | A helper function for implementing @MonadUnliftIO@ instances.
Useful for the common case where you want to simply delegate to the
underlying transformer.

Note: You can derive 'MonadUnliftIO' for newtypes without this helper function
in @unliftio-core@ 0.2.0.0 and later.

@since 0.1.2.0
==== __Example__

> newtype AppT m a = AppT { unAppT :: ReaderT Int (ResourceT m) a }
>   deriving (Functor, Applicative, Monad, MonadIO)
>
> -- Same as `deriving newtype (MonadUnliftIO)`
> instance MonadUnliftIO m => MonadUnliftIO (AppT m) where
>   withRunInIO = wrappedWithRunInIO AppT unAppT
-}
{-# INLINE wrappedWithRunInIO #-}
wrappedWithRunInIO :: MonadUnliftIO n
                   => (n b -> m b)
                   -- ^ The wrapper, for instance @IdentityT@.
                   -> (forall a. m a -> n a)
                   -- ^ The inverse, for instance @runIdentityT@.
                   -> ((forall a. m a -> IO a) -> IO b)
                   -- ^ The actual function to invoke 'withRunInIO' with.
                   -> m b
wrappedWithRunInIO :: (n b -> m b)
-> (forall a. m a -> n a)
-> ((forall a. m a -> IO a) -> IO b)
-> m b
wrappedWithRunInIO n b -> m b
wrap forall a. m a -> n a
unwrap (forall a. m a -> IO a) -> IO b
inner = n b -> m b
wrap (n b -> m b) -> n b -> m b
forall a b. (a -> b) -> a -> b
$ ((forall a. n a -> IO a) -> IO b) -> n b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. n a -> IO a) -> IO b) -> n b)
-> ((forall a. n a -> IO a) -> IO b) -> n b
forall a b. (a -> b) -> a -> b
$ \forall a. n a -> IO a
run ->
  (forall a. m a -> IO a) -> IO b
inner ((forall a. m a -> IO a) -> IO b)
-> (forall a. m a -> IO a) -> IO b
forall a b. (a -> b) -> a -> b
$ n a -> IO a
forall a. n a -> IO a
run (n a -> IO a) -> (m a -> n a) -> m a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> n a
forall a. m a -> n a
unwrap

{- | A helper function for lifting @IO a -> IO b@ functions into any @MonadUnliftIO@.

=== __Example__

> liftedTry :: (Exception e, MonadUnliftIO m) => m a -> m (Either e a)
> liftedTry m = liftIOOp Control.Exception.try m

@since 0.2.1.0
-}
liftIOOp :: MonadUnliftIO m => (IO a -> IO b) -> m a -> m b
liftIOOp :: (IO a -> IO b) -> m a -> m b
liftIOOp IO a -> IO b
f m a
x = do
  m a -> IO a
runInIO <- m (m a -> IO a)
forall (m :: * -> *) a. MonadUnliftIO m => m (m a -> IO a)
askRunInIO
  IO b -> m b
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO b -> m b) -> IO b -> m b
forall a b. (a -> b) -> a -> b
$ IO a -> IO b
f (IO a -> IO b) -> IO a -> IO b
forall a b. (a -> b) -> a -> b
$ m a -> IO a
runInIO m a
x