{-# LANGUAGE CPP #-}
{-# OPTIONS_HADDOCK not-home #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Cleff.Internal.Base
(
IOE
, primLiftIO
, primUnliftIO
, thisIsPureTrustMe
, runIOE
, runPure
, runPureIO
, HandlerIO
, interpretIO
, withToIO
, fromIO
) where
import Cleff.Internal
import Cleff.Internal.Interpret
import Cleff.Internal.Monad
import qualified Cleff.Internal.Rec as Rec
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
data IOE :: Effect where
#ifdef DYNAMIC_IOE
Lift :: IO a -> IOE m a
Unlift :: ((m ~> IO) -> IO a) -> IOE m a
#endif
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
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 = 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)
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
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
thisIsPureTrustMe :: Eff (IOE : es) ~> Eff es
thisIsPureTrustMe :: Eff (IOE : es) a -> Eff es a
thisIsPureTrustMe =
#ifndef DYNAMIC_IOE
(Rec es -> Rec (IOE : es)) -> Eff (IOE : es) ~> Eff es
forall (es :: [Effect]) (es' :: [Effect]).
(Rec es' -> Rec es) -> Eff es ~> Eff es'
adjust (HandlerPtr IOE -> Rec es -> Rec (IOE : es)
forall (e :: Effect) (es :: [Effect]).
HandlerPtr e -> Rec es -> Rec (e : es)
Rec.cons (HandlerPtr IOE -> Rec es -> Rec (IOE : es))
-> HandlerPtr IOE -> Rec es -> Rec (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 #-}
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 #-}
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 #-}
runPureIO :: Eff '[] ~> IO
runPureIO :: Eff '[] a -> IO a
runPureIO = \(Eff Env '[] -> IO a
m) -> Env '[] -> IO a
m Env '[]
emptyEnv
{-# INLINE runPureIO #-}
type HandlerIO e es = ∀ esSend. Handling esSend e es => e (Eff esSend) ~> IO
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 #-}
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
updateEnv Env es
es Env esSend
forall k (esSend :: [Effect]) (e :: Effect) (es :: k).
Handling esSend e es =>
Env esSend
esSend)
{-# INLINE withToIO #-}
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 #-}