{-# 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.Monad
import Polysemy.Internal
import Polysemy.Internal.Union
data Forklift r = forall a. Forklift
{ responseMVar :: MVar (Sem '[Embed IO] a)
, request :: Union r (Sem r) a
}
runViaForklift
:: LastMember (Embed IO) r
=> InChan (Forklift r)
-> Sem r a
-> Sem '[Embed IO] a
runViaForklift chan (Sem m) = Sem $ \k -> m $ \u -> do
case decompLast u of
Left x -> usingSem k $ join $ embed $ do
mvar <- newEmptyMVar
writeChan chan $ Forklift mvar x
takeMVar mvar
Right y -> k $ hoist (runViaForklift chan) y
{-# INLINE runViaForklift #-}
withLowerToIO
:: LastMember (Embed IO) r
=> ((forall x. Sem r x -> IO x) -> IO () -> IO a)
-> Sem r a
withLowerToIO action = do
(inchan, outchan) <- embed newChan
signal <- embed newEmptyMVar
res <- embed $ A.async $ do
a <- action (runM . runViaForklift inchan)
(putMVar signal ())
putMVar signal ()
pure a
let me = do
raced <- embed $ A.race (takeMVar signal) $ readChan outchan
case raced of
Left () -> embed $ A.wait res
Right (Forklift mvar req) -> do
resp <- liftSem req
embed $ putMVar mvar $ pure resp
me_b
{-# INLINE me #-}
me_b = me
{-# NOINLINE me_b #-}
me