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) <- 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)