{-# LANGUAGE NumDecimals     #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies    #-}

{-# OPTIONS_HADDOCK not-home #-}

module Polysemy.Internal.Forklift where

import qualified Control.Concurrent.Async as A
import           Control.Concurrent.Chan.Unagi
import           Control.Concurrent.MVar
import           Control.Exception
import           Polysemy.Internal
import           Polysemy.Internal.Union


------------------------------------------------------------------------------
-- | A promise for interpreting an effect of the union @r@ in another thread.
--
-- @since 0.5.0.0
data Forklift r = forall a. Forklift
  { ()
responseMVar :: MVar a
  , ()
request      :: Union r (Sem r) a
  }


------------------------------------------------------------------------------
-- | A strategy for automatically interpreting an entire stack of effects by
-- just shipping them off to some other interpretation context.
--
-- @since 0.5.0.0
runViaForklift
    :: Member (Embed IO) r
    => InChan (Forklift r)
    -> Sem r a
    -> IO a
runViaForklift :: InChan (Forklift r) -> Sem r a -> IO a
runViaForklift InChan (Forklift r)
chan = (forall x. Union r (Sem r) x -> IO x) -> Sem r a -> IO a
forall (m :: * -> *) (r :: EffectRow) a.
Monad m =>
(forall x. Union r (Sem r) x -> m x) -> Sem r a -> m a
usingSem ((forall x. Union r (Sem r) x -> IO x) -> Sem r a -> IO a)
-> (forall x. Union r (Sem r) x -> IO x) -> Sem r a -> IO a
forall a b. (a -> b) -> a -> b
$ \Union r (Sem r) x
u -> do
  case Union r (Sem r) x -> Maybe (Weaving (Embed IO) (Sem r) x)
forall (e :: Effect) (r :: EffectRow) (m :: * -> *) a.
Member e r =>
Union r m a -> Maybe (Weaving e m a)
prj Union r (Sem r) x
u of
    Just (Weaving (Embed m) f ()
s forall x. f (Sem rInitial x) -> Sem r (f x)
_ f a -> x
ex forall x. f x -> Maybe x
_) ->
      f a -> x
ex (f a -> x) -> (a -> f a) -> a -> x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f () -> f a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s) (a -> x) -> IO a -> IO x
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
m
    Maybe (Weaving (Embed IO) (Sem r) x)
_ -> do
      MVar x
mvar <- IO (MVar x)
forall a. IO (MVar a)
newEmptyMVar
      InChan (Forklift r) -> Forklift r -> IO ()
forall a. InChan a -> a -> IO ()
writeChan InChan (Forklift r)
chan (Forklift r -> IO ()) -> Forklift r -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar x -> Union r (Sem r) x -> Forklift r
forall (r :: EffectRow) a.
MVar a -> Union r (Sem r) a -> Forklift r
Forklift MVar x
mvar Union r (Sem r) x
u
      MVar x -> IO x
forall a. MVar a -> IO a
takeMVar MVar x
mvar
{-# INLINE runViaForklift #-}



------------------------------------------------------------------------------
-- | Run an effect stack all the way down to 'IO' by running it in a new
-- thread, and temporarily turning the current thread into an event poll.
--
-- This function creates a thread, and so should be compiled with @-threaded@.
--
-- @since 0.5.0.0
withLowerToIO
    :: Member (Embed IO) r
    => ((forall x. Sem r x -> IO x) -> IO () -> IO a)
       -- ^ A lambda that takes the lowering function, and a finalizing 'IO'
       -- action to mark a the forked thread as being complete. The finalizing
       -- action need not be called.
    -> Sem r a
withLowerToIO :: ((forall x. Sem r x -> IO x) -> IO () -> IO a) -> Sem r a
withLowerToIO (forall x. Sem r x -> IO x) -> IO () -> IO a
action = do
  (InChan (Forklift r)
inchan, OutChan (Forklift r)
outchan) <- IO (InChan (Forklift r), OutChan (Forklift r))
-> Sem r (InChan (Forklift r), OutChan (Forklift r))
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed IO (InChan (Forklift r), OutChan (Forklift r))
forall a. IO (InChan a, OutChan a)
newChan
  MVar ()
signal <- IO (MVar ()) -> Sem r (MVar ())
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar

  Async a
res <- IO (Async a) -> Sem r (Async a)
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO (Async a) -> Sem r (Async a))
-> IO (Async a) -> Sem r (Async a)
forall a b. (a -> b) -> a -> b
$ IO a -> IO (Async a)
forall a. IO a -> IO (Async a)
A.async (IO a -> IO (Async a)) -> IO a -> IO (Async a)
forall a b. (a -> b) -> a -> b
$ do
    a
a <- (forall x. Sem r x -> IO x) -> IO () -> IO a
action (InChan (Forklift r) -> Sem r x -> IO x
forall (r :: EffectRow) a.
Member (Embed IO) r =>
InChan (Forklift r) -> Sem r a -> IO a
runViaForklift InChan (Forklift r)
inchan)
                (MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
signal ())
          IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`finally` (MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
signal ())
    a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

  let me :: Sem r a
me = do
        Either () (Forklift r)
raced <- IO (Either () (Forklift r)) -> Sem r (Either () (Forklift r))
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO (Either () (Forklift r)) -> Sem r (Either () (Forklift r)))
-> IO (Either () (Forklift r)) -> Sem r (Either () (Forklift r))
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Forklift r) -> IO (Either () (Forklift r))
forall a b. IO a -> IO b -> IO (Either a b)
A.race (MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
signal) (IO (Forklift r) -> IO (Either () (Forklift r)))
-> IO (Forklift r) -> IO (Either () (Forklift r))
forall a b. (a -> b) -> a -> b
$ OutChan (Forklift r) -> IO (Forklift r)
forall a. OutChan a -> IO a
readChan OutChan (Forklift r)
outchan
        case Either () (Forklift r)
raced of
          Left () -> IO a -> Sem r a
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO a -> Sem r a) -> IO a -> Sem r a
forall a b. (a -> b) -> a -> b
$ Async a -> IO a
forall a. Async a -> IO a
A.wait Async a
res
          Right (Forklift MVar a
mvar Union r (Sem r) a
req) -> do
            a
resp <- Union r (Sem r) a -> Sem r a
forall (r :: EffectRow) a. Union r (Sem r) a -> Sem r a
liftSem Union r (Sem r) a
req
            IO () -> Sem r ()
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO () -> Sem r ()) -> IO () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ MVar a -> a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar a
mvar (a -> IO ()) -> a -> IO ()
forall a b. (a -> b) -> a -> b
$ a
resp
            Sem r a
me_b
      {-# INLINE me #-}

      me_b :: Sem r a
me_b = Sem r a
me
      {-# NOINLINE me_b #-}

  Sem r a
me