module Engine.Events.Sink
( Sink(..)
, spawn
, MonadSink
) where
import RIO
import Control.Concurrent.Chan.Unagi qualified as Unagi
import Control.Exception (AsyncException(ThreadKilled))
import Engine.Types (GlobalHandles)
import RIO.App (App)
import RIO.State (MonadState)
import UnliftIO.Concurrent (forkFinally, killThread)
import UnliftIO.Resource (ReleaseKey, MonadResource)
import UnliftIO.Resource qualified as Resource
type MonadSink rs m =
( MonadReader (App GlobalHandles rs) m
, MonadState rs m
, MonadResource m
, MonadUnliftIO m
)
newtype Sink event rs = Sink
{ forall event rs.
Sink event rs
-> forall (m :: * -> *). MonadSink rs m => event -> m ()
signal :: forall m . MonadSink rs m => event -> m ()
}
spawn
:: MonadSink rs m
=> (event -> m ())
-> m (ReleaseKey, Sink event rs)
spawn :: forall rs (m :: * -> *) event.
MonadSink rs m =>
(event -> m ()) -> m (ReleaseKey, Sink event rs)
spawn event -> m ()
handleEvent = do
(InChan event
eventsIn, OutChan event
eventsOut) <- IO (InChan event, OutChan event) -> m (InChan event, OutChan event)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (InChan event, OutChan event)
forall a. IO (InChan a, OutChan a)
Unagi.newChan
let sink :: Sink event rs
sink = (forall (m :: * -> *). MonadSink rs m => event -> m ())
-> Sink event rs
forall event rs.
(forall (m :: * -> *). MonadSink rs m => event -> m ())
-> Sink event rs
Sink ((forall (m :: * -> *). MonadSink rs m => event -> m ())
-> Sink event rs)
-> (forall (m :: * -> *). MonadSink rs m => event -> m ())
-> Sink event rs
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (event -> IO ()) -> event -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InChan event -> event -> IO ()
forall a. InChan a -> a -> IO ()
Unagi.writeChan InChan event
eventsIn
let
handler :: m ()
handler = m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
IO event -> m event
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (OutChan event -> IO event
forall a. OutChan a -> IO a
Unagi.readChan OutChan event
eventsOut) m event -> (event -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= event -> m ()
handleEvent
ThreadId
tid <- m () -> (Either SomeException () -> m ()) -> m ThreadId
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (Either SomeException a -> m ()) -> m ThreadId
forkFinally m ()
handler
\case
Left SomeException
exc ->
case SomeException -> Maybe AsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exc of
Just AsyncException
ThreadKilled ->
Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Event thread killed"
Maybe AsyncException
_others ->
Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError (Utf8Builder -> m ()) -> Utf8Builder -> m ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Event thread crashed: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> SomeException -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow SomeException
exc
Right () ->
Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"Event thread exited prematurely"
ReleaseKey
key <- IO () -> m ReleaseKey
forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
Resource.register (IO () -> m ReleaseKey) -> IO () -> m ReleaseKey
forall a b. (a -> b) -> a -> b
$ ThreadId -> IO ()
forall (m :: * -> *). MonadIO m => ThreadId -> m ()
killThread ThreadId
tid
pure (ReleaseKey
key, Sink event rs
sink)