module Glazier.Pipes.Ui where
import Control.Concurrent.STM
import Control.Concurrent.STM.TMVar.Extras as STE
import Control.Concurrent
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Morph
import Control.Monad.Trans.Maybe
import qualified Pipes as P
import qualified Pipes.Prelude as PP
runUi :: (MonadIO io) =>
Int
-> (s -> IO ())
-> P.Producer s io s
-> io s
runUi refreshDelay render appSignal = do
triggerRender <- liftIO $ newTMVarIO ()
frameRateThread <-
liftIO $
forkIO . void . forever $
do
atomically $ STE.waitTillEmptyTMVar triggerRender ()
threadDelay refreshDelay
atomically $ putTMVar triggerRender ()
enableRenderThread <- liftIO $ newTMVarIO ()
finishedRenderThread <- liftIO newEmptyTMVarIO
latestState <- liftIO newEmptyTMVarIO
void . liftIO $
forkFinally
(void . runMaybeT . forever $
do
liftIO . atomically . void $ takeTMVar triggerRender
s <-
MaybeT . liftIO . atomically $
(Just <$> takeTMVar latestState) `orElse` do
r <- tryReadTMVar enableRenderThread
case r of
Nothing -> pure Nothing
Just _ -> retry
lift $ render s)
(const . atomically $ putTMVar finishedRenderThread ())
s' <- P.runEffect $
appSignal P.>-> PP.mapM
(liftIO . atomically . void . STE.forceSwapTMVar latestState) P.>-> PP.drain
liftIO . atomically $ takeTMVar enableRenderThread
liftIO . atomically $ takeTMVar finishedRenderThread
liftIO $ killThread frameRateThread
liftIO $ pure s'