Sink.hs

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
  { signal :: forall m . MonadSink rs m => event -> m ()
  }

spawn
  :: MonadSink rs m
  => (event -> m ())
  -> m (ReleaseKey, Sink event rs)
spawn handleEvent = do
  (eventsIn, eventsOut) <- liftIO Unagi.newChan
  let sink = Sink $ liftIO . Unagi.writeChan eventsIn

  let
    handler = forever $
      liftIO (Unagi.readChan eventsOut) >>= handleEvent

  tid <- forkFinally handler
    \case
      Left exc ->
        case fromException exc of
          Just ThreadKilled ->
            logDebug "Event thread killed"
          _others ->
            logError $ "Event thread crashed: " <> displayShow exc
      Right () ->
        logWarn "Event thread exited prematurely"
  key <- Resource.register $ killThread tid
  pure (key, sink)