module Engine.Events.Sink ( Sink(..) , spawn ) where import RIO import Control.Concurrent.Chan.Unagi qualified as Unagi import Control.Exception (AsyncException(ThreadKilled)) import UnliftIO.Concurrent (forkFinally, killThread) import UnliftIO.Resource (ReleaseKey) import UnliftIO.Resource qualified as Resource import Engine.Types (StageRIO) newtype Sink event st = Sink { forall event st. Sink event st -> event -> StageRIO st () signal :: event -> StageRIO st () } spawn :: (event -> StageRIO rs ()) -> StageRIO rs (ReleaseKey, Sink event rs) spawn :: forall event rs. (event -> StageRIO rs ()) -> StageRIO rs (ReleaseKey, Sink event rs) spawn event -> StageRIO rs () 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 st. (event -> StageRIO st ()) -> Sink event st Sink \event event -> forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (forall a. InChan a -> a -> IO () Unagi.writeChan InChan event eventsIn event event) let handler :: StageRIO rs () 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 -> StageRIO rs () handleEvent ThreadId tid <- forall (m :: * -> *) a. MonadUnliftIO m => m a -> (Either SomeException a -> m ()) -> m ThreadId forkFinally StageRIO rs () 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)