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

-- | A collection of properties that are available while handling events.
-- Has access to a stage @RunState@, but not @Frame@ data.
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)