{-# LANGUAGE CPP #-}
{-# OPTIONS_HADDOCK not-home #-}
{-# OPTIONS_GHC -Wno-orphans #-}
-- |
-- Copyright: (c) 2021 Xy Ren
-- License: BSD3
-- Maintainer: xy.r@outlook.com
-- Stability: unstable
-- Portability: non-portable (GHC only)
--
-- This module contains the 'IOE' effect together with a few primitives for using it, as well as interpretation
-- combinators for 'IO'-related effects. It is not usually needed because safe functionalities are re-exported in the
-- "Cleff" module.
--
-- __This is an /internal/ module and its API may change even between minor versions.__ Therefore you should be
-- extra careful if you're to depend on this module.
module Cleff.Internal.Base
  ( -- * The 'IOE' Effect
    IOE
    -- * Primitive 'IO' functions
  , primLiftIO
  , primUnliftIO
    -- * Unwrapping 'Eff'
  , thisIsPureTrustMe
  , runIOE
  , runPure
    -- * Effect interpretation
  , HandlerIO
  , interpretIO
    -- * Combinators for interpreting higher-order effects
  , withToIO
  , fromIO
  ) where

import           Cleff.Internal.Interpret
import           Cleff.Internal.Monad
import           Control.Monad.Base          (MonadBase (liftBase))
import           Control.Monad.Catch         (ExitCase (ExitCaseException, ExitCaseSuccess), MonadCatch, MonadMask,
                                              MonadThrow)
import qualified Control.Monad.Catch         as Catch
import           Control.Monad.Primitive     (PrimMonad (PrimState, primitive), RealWorld)
import           Control.Monad.Trans.Control (MonadBaseControl (StM, liftBaseWith, restoreM))
import           GHC.IO                      (IO (IO))
import           System.IO.Unsafe            (unsafeDupablePerformIO)
import           UnliftIO                    (MonadIO (liftIO), MonadUnliftIO (withRunInIO), throwIO)
import qualified UnliftIO

-- * The 'IOE' effect

-- | The effect capable of lifting and unlifting the 'IO' monad, allowing you to use 'MonadIO', 'MonadUnliftIO',
-- 'PrimMonad', 'MonadCatch', 'MonadThrow' and 'MonadMask' functionalities. This is the "final" effect that most
-- effects eventually are interpreted into. For example, you can do:
--
-- @
-- log :: 'IOE' :> es => 'Eff' es ()
-- log = 'liftIO' ('putStrLn' "Test logging")
-- @
--
-- It is not recommended to use this effect directly in application code, as it is too liberal and allows arbitrary IO,
-- therefore making it harder to do proper effect management. Ideally, this is only used in interpreting more
-- fine-grained effects.
--
-- === Technical details
--
-- Note that this is /not/ a real effect and cannot be interpreted in any way besides 'thisIsPureTrustMe' and
-- 'runIOE'. This is mainly for performance concern, but also that there doesn't really exist reasonable
-- interpretations other than the current one, given the underlying implementation of the 'Eff' monad.
--
-- 'IOE' can be a real effect though, and you can enable the @dynamic-ioe@ build flag to have that. However it is only
-- for reference purposes and should not be used in production code.
data IOE :: Effect where
#ifdef DYNAMIC_IOE
  Lift :: IO a -> IOE m a
  Unlift :: ((m ~> IO) -> IO a) -> IOE m a
#endif

-- * Primitive 'IO' functions

-- | Lift an 'IO' computation into 'Eff'. This function is /highly unsafe/ and should not be used directly; use 'liftIO'
-- instead, or if you're interpreting higher-order effects, use 'fromIO'.
primLiftIO :: IO a -> Eff es a
primLiftIO :: IO a -> Eff es a
primLiftIO = (Env es -> IO a) -> Eff es a
forall (es :: [Effect]) a. (Env es -> IO a) -> Eff es a
Eff ((Env es -> IO a) -> Eff es a)
-> (IO a -> Env es -> IO a) -> IO a -> Eff es a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> Env es -> IO a
forall a b. a -> b -> a
const
{-# INLINE primLiftIO #-}

-- | Give a runner function a way to run 'Eff' actions as an 'IO' computation. This function is /highly unsafe/ and
-- should not be used directly; use 'withRunInIO' instead, or if you're interpreting higher-order effects, use
-- 'withToIO'.
primUnliftIO :: ((Eff es ~> IO) -> IO a) -> Eff es a
primUnliftIO :: ((Eff es ~> IO) -> IO a) -> Eff es a
primUnliftIO (Eff es ~> IO) -> IO a
f = (Env es -> IO a) -> Eff es a
forall (es :: [Effect]) a. (Env es -> IO a) -> Eff es a
Eff \Env es
es -> (Eff es ~> IO) -> IO a
f (Eff es a -> Env es -> IO a
forall (es :: [Effect]) a. Eff es a -> Env es -> IO a
`unEff` Env es
es)
{-# INLINE primUnliftIO #-}

instance IOE :> es => MonadIO (Eff es) where
#ifdef DYNAMIC_IOE
  liftIO = send . Lift
#else
  liftIO :: IO a -> Eff es a
liftIO = IO a -> Eff es a
forall a (es :: [Effect]). IO a -> Eff es a
primLiftIO
  {-# INLINE liftIO #-}
#endif

instance IOE :> es => MonadUnliftIO (Eff es) where
#ifdef DYNAMIC_IOE
  withRunInIO f = send $ Unlift f
#else
  withRunInIO :: ((forall a. Eff es a -> IO a) -> IO b) -> Eff es b
withRunInIO = ((forall a. Eff es a -> IO a) -> IO b) -> Eff es b
forall (es :: [Effect]) a. ((Eff es ~> IO) -> IO a) -> Eff es a
primUnliftIO
  {-# INLINE withRunInIO #-}
#endif

instance IOE :> es => MonadThrow (Eff es) where
  throwM :: e -> Eff es a
throwM = e -> Eff es a
forall (m :: Type -> Type) e a.
(MonadIO m, Exception e) =>
e -> m a
throwIO

instance IOE :> es => MonadCatch (Eff es) where
  catch :: Eff es a -> (e -> Eff es a) -> Eff es a
catch = Eff es a -> (e -> Eff es a) -> Eff es a
forall (m :: Type -> Type) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
UnliftIO.catch

instance IOE :> es => MonadMask (Eff es) where
  mask :: ((forall a. Eff es a -> Eff es a) -> Eff es b) -> Eff es b
mask = ((forall a. Eff es a -> Eff es a) -> Eff es b) -> Eff es b
forall (m :: Type -> Type) b.
MonadUnliftIO m =>
((forall a. m a -> m a) -> m b) -> m b
UnliftIO.mask
  uninterruptibleMask :: ((forall a. Eff es a -> Eff es a) -> Eff es b) -> Eff es b
uninterruptibleMask = ((forall a. Eff es a -> Eff es a) -> Eff es b) -> Eff es b
forall (m :: Type -> Type) b.
MonadUnliftIO m =>
((forall a. m a -> m a) -> m b) -> m b
UnliftIO.uninterruptibleMask
  generalBracket :: Eff es a
-> (a -> ExitCase b -> Eff es c)
-> (a -> Eff es b)
-> Eff es (b, c)
generalBracket Eff es a
ma a -> ExitCase b -> Eff es c
mz a -> Eff es b
m = ((forall a. Eff es a -> Eff es a) -> Eff es (b, c))
-> Eff es (b, c)
forall (m :: Type -> Type) b.
MonadUnliftIO m =>
((forall a. m a -> m a) -> m b) -> m b
UnliftIO.mask \forall a. Eff es a -> Eff es a
restore -> do
    a
a <- Eff es a
ma
    b
x <- Eff es b -> Eff es b
forall a. Eff es a -> Eff es a
restore (a -> Eff es b
m a
a) Eff es b -> (SomeException -> Eff es b) -> Eff es b
forall (m :: Type -> Type) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`UnliftIO.catch` \SomeException
e -> do
      c
_ <- a -> ExitCase b -> Eff es c
mz a
a (SomeException -> ExitCase b
forall a. SomeException -> ExitCase a
ExitCaseException SomeException
e)
      SomeException -> Eff es b
forall (m :: Type -> Type) e a.
(MonadIO m, Exception e) =>
e -> m a
throwIO SomeException
e
    c
z <- a -> ExitCase b -> Eff es c
mz a
a (b -> ExitCase b
forall a. a -> ExitCase a
ExitCaseSuccess b
x)
    (b, c) -> Eff es (b, c)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (b
x, c
z)

-- | Compatibility instance; use 'MonadIO' if possible.
instance IOE :> es => MonadBase IO (Eff es) where
  liftBase :: IO α -> Eff es α
liftBase = IO α -> Eff es α
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO

-- | Compatibility instance; use 'MonadUnliftIO' if possible.
instance IOE :> es => MonadBaseControl IO (Eff es) where
  type StM (Eff es) a = a
  liftBaseWith :: (RunInBase (Eff es) IO -> IO a) -> Eff es a
liftBaseWith = (RunInBase (Eff es) IO -> IO a) -> Eff es a
forall (m :: Type -> Type) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO
  restoreM :: StM (Eff es) a -> Eff es a
restoreM = StM (Eff es) a -> Eff es a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure

instance IOE :> es => PrimMonad (Eff es) where
  type PrimState (Eff es) = RealWorld
  primitive :: (State# (PrimState (Eff es))
 -> (# State# (PrimState (Eff es)), a #))
-> Eff es a
primitive = IO a -> Eff es a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO a -> Eff es a)
-> ((State# RealWorld -> (# State# RealWorld, a #)) -> IO a)
-> (State# RealWorld -> (# State# RealWorld, a #))
-> Eff es a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO

-- * Unwrapping 'Eff'

-- | Unsafely eliminate an 'IOE' effect from the top of the effect stack. This is mainly for implementing effects that
-- uses 'IO' but does not do anything really /impure/ (i.e. can be safely used 'unsafeDupablePerformIO' on), such as a
-- State effect.
thisIsPureTrustMe :: Eff (IOE ': es) ~> Eff es
thisIsPureTrustMe :: Eff (IOE : es) a -> Eff es a
thisIsPureTrustMe = Handler IOE es -> Eff (IOE : es) ~> Eff es
forall (e :: Effect) (es :: [Effect]).
Handler e es -> Eff (e : es) ~> Eff es
interpret IOE (Eff esSend) a -> Eff es a
Handler IOE es
\case
#ifdef DYNAMIC_IOE
  Lift m   -> primLiftIO m
  Unlift f -> primUnliftIO \runInIO -> f (runInIO . toEff)
#endif
{-# INLINE thisIsPureTrustMe #-}

-- | Unwrap an 'Eff' computation with side effects into an 'IO' computation, given that all effects other than 'IOE' are
-- interpreted.
runIOE :: Eff '[IOE] ~> IO
runIOE :: Eff '[IOE] a -> IO a
runIOE Eff '[IOE] a
m = Eff '[] a -> Env '[] -> IO a
forall (es :: [Effect]) a. Eff es a -> Env es -> IO a
unEff (Eff '[IOE] a -> Eff '[] a
forall (es :: [Effect]). Eff (IOE : es) ~> Eff es
thisIsPureTrustMe Eff '[IOE] a
m) Env '[]
emptyEnv
{-# INLINE runIOE #-}

-- | Unwrap a pure 'Eff' computation into a pure value, given that all effects are interpreted.
runPure :: Eff '[] a -> a
runPure :: Eff '[] a -> a
runPure Eff '[] a
m = IO a -> a
forall a. IO a -> a
unsafeDupablePerformIO (IO a -> a) -> IO a -> a
forall a b. (a -> b) -> a -> b
$ Eff '[] a -> Env '[] -> IO a
forall (es :: [Effect]) a. Eff es a -> Env es -> IO a
unEff Eff '[] a
m Env '[]
emptyEnv
{-# NOINLINE runPure #-}

-- * Effect interpretation

-- | The type of an /'IO' effect handler/, which is a function that transforms an effect @e@ into 'IO' computations.
-- This is used for 'interpretIO'.
type HandlerIO e es = ∀ esSend. Handling esSend e es => e (Eff esSend) ~> IO

-- | Interpret an effect in terms of 'IO', by transforming an effect into 'IO' computations.
--
-- @
-- 'interpretIO' f = 'interpret' ('liftIO' '.' f)
-- @
interpretIO :: IOE :> es => HandlerIO e es -> Eff (e ': es) ~> Eff es
interpretIO :: HandlerIO e es -> Eff (e : es) ~> Eff es
interpretIO HandlerIO e es
f = Handler e es -> Eff (e : es) ~> Eff es
forall (e :: Effect) (es :: [Effect]).
Handler e es -> Eff (e : es) ~> Eff es
interpret (IO a -> Eff es a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO a -> Eff es a)
-> (e (Eff esSend) a -> IO a) -> e (Eff esSend) a -> Eff es a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e (Eff esSend) a -> IO a
HandlerIO e es
f)
{-# INLINE interpretIO #-}

-- * Combinators for interpreting higher-order effects

-- | Temporarily gain the ability to unlift an @'Eff' esSend@ computation into 'IO'. This is analogous to
-- 'withRunInIO', and is useful in dealing with higher-order effects that involves 'IO'. For example, the @Resource@
-- effect that supports brecketing:
--
-- @
-- data Resource m a where
--   Bracket :: m a -> (a -> m ()) -> (a -> m b) -> Resource m b
-- @
--
-- can be interpreted into 'Control.Exception.bracket' actions in 'IO', by converting all effect computations into
-- 'IO' compucations via 'withToIO':
--
-- @
-- runResource :: 'IOE' ':>' es => 'Eff' (Resource ': es) a -> 'Eff' es a
-- runResource = 'interpret' \\case
--   Bracket alloc dealloc use -> 'withToIO' $ \\toIO ->
--     'Control.Exception.bracket' (toIO alloc) (toIO . dealloc) (toIO . use)
-- @
withToIO :: (Handling esSend e es, IOE :> es) => ((Eff esSend ~> IO) -> IO a) -> Eff es a
withToIO :: ((Eff esSend ~> IO) -> IO a) -> Eff es a
withToIO (Eff esSend ~> IO) -> IO a
f = (Env es -> IO a) -> Eff es a
forall (es :: [Effect]) a. (Env es -> IO a) -> Eff es a
Eff \Env es
es -> (Eff esSend ~> IO) -> IO a
f \Eff esSend a
m -> Eff esSend a -> Env esSend -> IO a
forall (es :: [Effect]) a. Eff es a -> Env es -> IO a
unEff Eff esSend a
m (Env es -> Env esSend -> Env esSend
forall (es :: [Effect]) (es' :: [Effect]).
Env es' -> Env es -> Env es
updateEnv Env es
es Env esSend
forall k (esSend :: [Effect]) (e :: Effect) (es :: k).
Handling esSend e es =>
Env esSend
esSend)

-- | Lift an 'IO' computation into @'Eff' esSend@. This is analogous to 'liftIO', and is only useful in dealing with
-- effect operations with the monad type in the negative position, for example 'Control.Exception.mask'ing:
--
-- @
-- data Mask :: 'Effect' where
--   Mask :: ((m '~>' m) -> m a) -> Mask m a
--                  ^ this "m" is in negative position
-- @
--
-- See how the @restore :: IO a -> IO a@ from 'Control.Exception.mask' is "wrapped" into
-- @'Eff' esSend a -> 'Eff' esSend a@:
--
-- @
-- runMask :: 'IOE' ':>' es => 'Eff' (Mask ': es) a -> 'Eff' es a
-- runMask = 'interpret' \\case
--   Mask f -> 'withToIO' $ \\toIO -> 'Control.Exception.mask' $
--     \\restore -> f ('fromIO' . restore . toIO)
-- @
--
-- Here, @toIO@ from 'withToIO' takes an @'Eff' esSend@ to 'IO', where it can be passed into the @restore@ function,
-- and the returned 'IO' computation is recovered into 'Eff' with 'fromIO'.
fromIO :: (Handling esSend e es, IOE :> es) => IO ~> Eff esSend
fromIO :: IO ~> Eff esSend
fromIO = (Env esSend -> IO a) -> Eff esSend a
forall (es :: [Effect]) a. (Env es -> IO a) -> Eff es a
Eff ((Env esSend -> IO a) -> Eff esSend a)
-> (IO a -> Env esSend -> IO a) -> IO a -> Eff esSend a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> Env esSend -> IO a
forall a b. a -> b -> a
const