{-# 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
    -- * Related classes
  , MonadIO (liftIO)
  , MonadUnliftIO (withRunInIO)
    -- * Unwrapping 'Eff'
  , thisIsPureTrustMe
  , runIOE
  , runPure
  , runPureIO
    -- * Effect interpretation
  , HandlerIO
  , interpretIO
    -- * Combinators for interpreting higher-order effects
  , withToIO
  , fromIO
  ) where

import qualified Cleff.Internal.Env          as Env
import           Cleff.Internal.Interpret
import           Cleff.Internal.Monad
import qualified Cleff.Internal.Stack        as Stack
import           Control.Monad.Base          (MonadBase (liftBase))
import           Control.Monad.Catch         (MonadCatch, MonadMask, MonadThrow)
import qualified Control.Monad.Catch         as Catch
import           Control.Monad.IO.Unlift     (MonadIO (liftIO), MonadUnliftIO (withRunInIO))
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)

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

-- | 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 Env es -> IO a
m) -> Env es -> IO a
m Env es
es

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

instance IOE :> es => MonadThrow (Eff es) where
  throwM :: e -> Eff es a
throwM = IO a -> Eff es a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO a -> Eff es a) -> (e -> IO a) -> e -> Eff es a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> IO a
forall (m :: Type -> Type) e a.
(MonadThrow m, Exception e) =>
e -> m a
Catch.throwM

instance IOE :> es => MonadCatch (Eff es) where
  catch :: Eff es a -> (e -> Eff es a) -> Eff es a
catch Eff es a
m e -> Eff es a
h = ((forall a. Eff es a -> IO a) -> IO a) -> Eff es a
forall (m :: Type -> Type) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO \forall a. Eff es a -> IO a
run -> IO a -> (e -> IO a) -> IO a
forall (m :: Type -> Type) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
Catch.catch (Eff es a -> IO a
forall a. Eff es a -> IO a
run Eff es a
m) (Eff es a -> IO a
forall a. Eff es a -> IO a
run (Eff es a -> IO a) -> (e -> Eff es a) -> e -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Eff es a
h)

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
f = ((forall a. Eff es a -> IO a) -> IO b) -> Eff es b
forall (m :: Type -> Type) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO \forall a. Eff es a -> IO a
run -> ((forall a. IO a -> IO a) -> IO b) -> IO b
forall (m :: Type -> Type) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
Catch.mask \forall a. IO a -> IO a
restore -> Eff es b -> IO b
forall a. Eff es a -> IO a
run (Eff es b -> IO b) -> Eff es b -> IO b
forall a b. (a -> b) -> a -> b
$ (forall a. Eff es a -> Eff es a) -> Eff es b
f (IO a -> Eff es a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO a -> Eff es a) -> (Eff es a -> IO a) -> Eff es a -> Eff es a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> IO a
forall a. IO a -> IO a
restore (IO a -> IO a) -> (Eff es a -> IO a) -> Eff es a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eff es a -> IO a
forall a. Eff es a -> IO a
run)
  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
f = ((forall a. Eff es a -> IO a) -> IO b) -> Eff es b
forall (m :: Type -> Type) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO \forall a. Eff es a -> IO a
run -> ((forall a. IO a -> IO a) -> IO b) -> IO b
forall (m :: Type -> Type) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
Catch.uninterruptibleMask \forall a. IO a -> IO a
restore -> Eff es b -> IO b
forall a. Eff es a -> IO a
run (Eff es b -> IO b) -> Eff es b -> IO b
forall a b. (a -> b) -> a -> b
$ (forall a. Eff es a -> Eff es a) -> Eff es b
f (IO a -> Eff es a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO a -> Eff es a) -> (Eff es a -> IO a) -> Eff es a -> Eff es a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> IO a
forall a. IO a -> IO a
restore (IO a -> IO a) -> (Eff es a -> IO a) -> Eff es a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eff es a -> IO a
forall a. Eff es a -> IO a
run)
  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 -> IO a) -> IO (b, c)) -> Eff es (b, c)
forall (m :: Type -> Type) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO \forall a. Eff es a -> IO a
run -> IO a -> (a -> ExitCase b -> IO c) -> (a -> IO b) -> IO (b, c)
forall (m :: Type -> Type) a b c.
MonadMask m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
Catch.generalBracket (Eff es a -> IO a
forall a. Eff es a -> IO a
run Eff es a
ma) (\a
x ExitCase b
e -> Eff es c -> IO c
forall a. Eff es a -> IO a
run (Eff es c -> IO c) -> Eff es c -> IO c
forall a b. (a -> b) -> a -> b
$ a -> ExitCase b -> Eff es c
mz a
x ExitCase b
e) (Eff es b -> IO b
forall a. Eff es a -> IO a
run (Eff es b -> IO b) -> (a -> Eff es b) -> a -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Eff es b
m)

-- | 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 =
#ifndef DYNAMIC_IOE
  (Stack es -> Stack (IOE : es)) -> Eff (IOE : es) ~> Eff es
forall (es :: [Effect]) (es' :: [Effect]).
(Stack es' -> Stack es) -> Eff es ~> Eff es'
adjust (HandlerPtr IOE -> Stack es -> Stack (IOE : es)
forall (e :: Effect) (es :: [Effect]).
HandlerPtr e -> Stack es -> Stack (e : es)
Stack.cons (HandlerPtr IOE -> Stack es -> Stack (IOE : es))
-> HandlerPtr IOE -> Stack es -> Stack (IOE : es)
forall a b. (a -> b) -> a -> b
$ Int -> HandlerPtr IOE
forall (e :: Effect). Int -> HandlerPtr e
HandlerPtr (-Int
1))
#else
  interpret \case
    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 '[] a -> IO a
Eff '[] ~> IO
runPureIO (Eff '[] a -> IO a)
-> (Eff '[IOE] a -> Eff '[] a) -> Eff '[IOE] a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eff '[IOE] a -> Eff '[] a
forall (es :: [Effect]). Eff (IOE : es) ~> Eff es
thisIsPureTrustMe
{-# 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 = IO a -> a
forall a. IO a -> a
unsafeDupablePerformIO (IO a -> a) -> (Eff '[] a -> IO a) -> Eff '[] a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eff '[] a -> IO a
Eff '[] ~> IO
runPureIO
{-# INLINE runPure #-}

-- | Unwrap a pure 'Eff' computation into an 'IO' computation. You may occasionally need this.
runPureIO :: Eff '[] ~> IO
runPureIO :: Eff '[] a -> IO a
runPureIO = \(Eff Env '[] -> IO a
m) -> Env '[] -> IO a
m Env '[]
Env.empty
{-# INLINE runPureIO #-}

-- * 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 bracketing:
--
-- @
-- 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' computations 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 Env esSend -> IO a
m) -> Env esSend -> IO a
m (Env es -> Env esSend -> Env esSend
forall (es :: [Effect]) (es' :: [Effect]).
Env es' -> Env es -> Env es
Env.update Env es
es Env esSend
forall k (esSend :: [Effect]) (e :: Effect) (es :: k).
Handling esSend e es =>
Env esSend
esSend)
{-# INLINE withToIO #-}

-- | 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
{-# INLINE fromIO #-}