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)