{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE UndecidableInstances  #-}

{- |
Module                  : Unlift
Copyright               : (c) 2021 Kowainik
                          (c) 2017 FP Complete
SPDX-License-Identifier : MPL-2.0
Maintainer              : Kowainik <xrom.xkov@gmail.com>
Stability               : Stable
Portability             : Portable

This module provides 'MonadUnlift' typeclass and functions to work with it.

See 'MonadUnlift' documentation for more information about its purpose.

@since 0.0.0.0
-}
module Unlift
    ( MonadUnlift (..)
    , defaultWithRunInBase
    , askRunInBase
    , Unlift (..)
    , askUnlift
    ) where

import Control.Monad.Base (MonadBase)
import Control.Monad.ST (ST)
import Control.Monad.STM (STM)
import Control.Monad.Trans.Identity (IdentityT (..))
import Control.Monad.Trans.Reader (ReaderT (..))


{- | Typeclass to allow actions in monadic context @m@ to be run in the base monad @b@.

This typeclass is similar to @MonadUnliftIO@ from the
<http://hackage.haskell.org/package/unliftio unliftio> package. However
'MonadUnlift' works with any base monad, not only 'IO'.

This typeclass is helpful when writing code that is polymorphic over the base
monad, so later you can select a different base monad for each specific use-case.

While you can use @lift@ to allow some action to be lifted into another
monad, this class captures the opposite concept.

Instances of this typeclass should satisfy the following laws:

* __Distributivity:__

    @
    'withRunInBase' (\\run -> run f >> run g)
        ≡
    'withRunInBase' (\\run -> run f) >> 'withRunInBase' (\\run -> run g)
    @

* __Identity:__

    @
    'askUnlift' >>= \\u -> ('Control.Monad.Base.liftBase' . 'runUnlift' u) m ≡ m
    @

@since 0.0.0.0
-}
class (MonadBase b m) => MonadUnlift b m
  where
    {- | Convenient function to capture the monadic context @m@ and run the @b@
    action with a runner function. The runner function is used to run a monadic
    action @m@ in the base monad @b@.

    @since 0.0.0.0
    -}
    withRunInBase :: ((forall a . m a -> b a) -> b x) -> m x

{- |
@since 0.0.0.0
-}
instance MonadUnlift IO IO
  where
    withRunInBase :: ((forall a . IO a -> IO a) -> IO x) -> IO x
    withRunInBase :: ((forall a. IO a -> IO a) -> IO x) -> IO x
withRunInBase = \(forall a. IO a -> IO a) -> IO x
run -> (forall a. IO a -> IO a) -> IO x
run forall a. a -> a
forall a. IO a -> IO a
id

{- |
@since 0.0.0.0
-}
instance MonadUnlift STM STM
  where
    withRunInBase :: ((forall a . STM a -> STM a) -> STM x) -> STM x
    withRunInBase :: ((forall a. STM a -> STM a) -> STM x) -> STM x
withRunInBase = \(forall a. STM a -> STM a) -> STM x
run -> (forall a. STM a -> STM a) -> STM x
run forall a. a -> a
forall a. STM a -> STM a
id

{- |
@since 0.0.0.0
-}
instance MonadUnlift (ST s) (ST s)
  where
    withRunInBase :: ((forall a . ST s a -> ST s a) -> ST s x) -> ST s x
    withRunInBase :: ((forall a. ST s a -> ST s a) -> ST s x) -> ST s x
withRunInBase = \(forall a. ST s a -> ST s a) -> ST s x
run -> (forall a. ST s a -> ST s a) -> ST s x
run forall a. a -> a
forall a. ST s a -> ST s a
id

{- |
@since 0.0.0.0
-}
instance (MonadUnlift b m) => MonadUnlift b (IdentityT m)
  where
    withRunInBase :: ((forall a . IdentityT m a -> b a) -> b x) -> IdentityT m x
    withRunInBase :: ((forall a. IdentityT m a -> b a) -> b x) -> IdentityT m x
withRunInBase = (m x -> IdentityT m x)
-> (forall a. IdentityT m a -> m a)
-> ((forall a. IdentityT m a -> b a) -> b x)
-> IdentityT m x
forall (b :: * -> *) (n :: * -> *) x (m :: * -> *).
MonadUnlift b n =>
(n x -> m x)
-> (forall a. m a -> n a) -> ((forall a. m a -> b a) -> b x) -> m x
defaultWithRunInBase m x -> IdentityT m x
forall k (f :: k -> *) (a :: k). f a -> IdentityT f a
IdentityT forall a. IdentityT m a -> m a
forall k (f :: k -> *) (a :: k). IdentityT f a -> f a
runIdentityT


{- |
@since 0.0.0.0
-}
instance (MonadUnlift b m) => MonadUnlift b (ReaderT r m)
  where
    withRunInBase :: ((forall a . ReaderT r m a -> b a) -> b x) -> ReaderT r m x
    withRunInBase :: ((forall a. ReaderT r m a -> b a) -> b x) -> ReaderT r m x
withRunInBase (forall a. ReaderT r m a -> b a) -> b x
runWithReader = (r -> m x) -> ReaderT r m x
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((r -> m x) -> ReaderT r m x) -> (r -> m x) -> ReaderT r m x
forall a b. (a -> b) -> a -> b
$ \r
env ->
        ((forall a. m a -> b a) -> b x) -> m x
forall (b :: * -> *) (m :: * -> *) x.
MonadUnlift b m =>
((forall a. m a -> b a) -> b x) -> m x
withRunInBase (\forall a. m a -> b a
ma2ba -> (forall a. ReaderT r m a -> b a) -> b x
runWithReader (m a -> b a
forall a. m a -> b a
ma2ba (m a -> b a) -> (ReaderT r m a -> m a) -> ReaderT r m a -> b 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
env))

{- | A helper function for implementing @MonadUnlift@ instances.

Useful for the common case where you want to simply delegate to the
underlying transformer in @newtype@s.

__Example:__

@
__newtype__ AppT m a = AppT
    { unAppT :: 'ReaderT' Int m a
    } __deriving newtype__ ('Functor', 'Applicative', 'Monad')

__instance__ ('MonadUnlift' b m) => 'MonadUnlift' b (AppT m)
  __where__
    'withRunInBase' = 'defaultWithRunInBase' AppT unAppT
@

@since 0.0.0.0
-}
defaultWithRunInBase
    :: (MonadUnlift b n)
    => (n x -> m x)  -- ^ Wrapper
    -> (forall a . m a -> n a)  -- ^ Unwrapper
    -> ((forall a . m a -> b a) -> b x)  -- ^ Action to do in base monad
    -> m x  -- ^ Result in unlifted monad
defaultWithRunInBase :: (n x -> m x)
-> (forall a. m a -> n a) -> ((forall a. m a -> b a) -> b x) -> m x
defaultWithRunInBase n x -> m x
wrap forall a. m a -> n a
unwrap (forall a. m a -> b a) -> b x
run =
    n x -> m x
wrap (n x -> m x) -> n x -> m x
forall a b. (a -> b) -> a -> b
$ ((forall a. n a -> b a) -> b x) -> n x
forall (b :: * -> *) (m :: * -> *) x.
MonadUnlift b m =>
((forall a. m a -> b a) -> b x) -> m x
withRunInBase (\forall a. n a -> b a
ma2ba -> (forall a. m a -> b a) -> b x
run (n a -> b a
forall a. n a -> b a
ma2ba (n a -> b a) -> (m a -> n a) -> m a -> b a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> n a
forall a. m a -> n a
unwrap))

{- | Capture the current monadic context @m@, providing the ability to
run monadic actions in the base monad @b@.

Useful when you need to apply on one concrete type.

__Note:__ If you run into issues when using this function, most likely that
you need 'askUnlift' instead.

@since 0.0.0.0
-}
askRunInBase :: (MonadUnlift b m) => m (m a -> b a)
askRunInBase :: m (m a -> b a)
askRunInBase = ((forall a. m a -> b a) -> b (m a -> b a)) -> m (m a -> b a)
forall (b :: * -> *) (m :: * -> *) x.
MonadUnlift b m =>
((forall a. m a -> b a) -> b x) -> m x
withRunInBase (((forall a. m a -> b a) -> b (m a -> b a)) -> m (m a -> b a))
-> ((forall a. m a -> b a) -> b (m a -> b a)) -> m (m a -> b a)
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> b a
run -> (m a -> b a) -> b (m a -> b a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure m a -> b a
forall a. m a -> b a
run

{- | Polymorphic wrapper over the function returned by 'withRunInBase'.

Use 'askUnlift' instead of 'askRunInBase' when you need to use the return
@unlift@ with variables of different types.

@since 0.0.0.0
-}
newtype Unlift b m = Unlift
    { Unlift b m -> forall x. m x -> b x
runUnlift :: forall x . m x -> b x
    }

{- | Similar to 'askRunInBase', but works with the 'Unlift' wrapper.

Use 'askUnlift' instead of 'askRunInBase' when you need to use the return
@unlift@ with variables of different types.

@since 0.0.0.0
-}
askUnlift :: (MonadUnlift b m) => m (Unlift b m)
askUnlift :: m (Unlift b m)
askUnlift = ((forall a. m a -> b a) -> b (Unlift b m)) -> m (Unlift b m)
forall (b :: * -> *) (m :: * -> *) x.
MonadUnlift b m =>
((forall a. m a -> b a) -> b x) -> m x
withRunInBase (((forall a. m a -> b a) -> b (Unlift b m)) -> m (Unlift b m))
-> ((forall a. m a -> b a) -> b (Unlift b m)) -> m (Unlift b m)
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> b a
runInBase -> Unlift b m -> b (Unlift b m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((forall a. m a -> b a) -> Unlift b m
forall (b :: * -> *) (m :: * -> *).
(forall x. m x -> b x) -> Unlift b m
Unlift forall a. m a -> b a
runInBase)