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) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a. IO (InChan a, OutChan a)
Unagi.newChan
let sink :: Sink event rs
sink = forall event rs.
(forall (m :: * -> *). MonadSink rs m => event -> m ())
-> Sink event rs
Sink forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. InChan a -> a -> IO ()
Unagi.writeChan InChan event
eventsIn
let
handler :: m ()
handler = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. OutChan a -> IO a
Unagi.readChan OutChan event
eventsOut) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= event -> m ()
handleEvent
ThreadId
tid <- forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (Either SomeException a -> m ()) -> m ThreadId
forkFinally m ()
handler
\case
Left SomeException
exc ->
case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exc of
Just AsyncException
ThreadKilled ->
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Event thread killed"
Maybe AsyncException
_others ->
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Event thread crashed: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow SomeException
exc
Right () ->
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"Event thread exited prematurely"
ReleaseKey
key <- forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
Resource.register forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => ThreadId -> m ()
killThread ThreadId
tid
pure (ReleaseKey
key, Sink event rs
sink)