Messages.hs

{-# LANGUAGE AllowAmbiguousTypes #-}

module Mischief.ECS.Messages
  ( Message,
    add,
    write,
    read,
  )
where

import Control.Monad.IO.Class
import Data.Data (Typeable)
import Data.IORef
import Data.Kind
import Data.Map (Map)
import Data.Map qualified as Map
import Mischief.ECS.App.SystemDef
import Mischief.ECS.App.Systems
import Mischief.ECS.Components
import Mischief.ECS.Resources
import Mischief.ECS.World
import Mischief.ECS.World.Query (mkGet, single)
import Mischief.ECS.World.Query.Markers
import Prelude hiding (read)

-- | Message typeclass.
class (Typeable m) => Message m

-- | Resource for writing and reading messages.
--
-- Internally, this keeps track of which messages each system has already read.
data Messages m = Messages {messages :: [(Frame, Tick, m)], readers :: Map SystemId Reader}

newMessages :: forall m. Messages m
newMessages = Messages {messages = [], readers = Map.empty}

newtype Reader = Reader (IORef Tick)

getReader :: (Message m) => Messages m -> System Reader
getReader !m = do
  world <- unsafeGetWorld
  case Map.lookup world.systemId m.readers of
    Just r -> return r
    Nothing -> do
      tick <- liftIO $ newIORef $ Tick 0
      insertRes $ (\Messages {messages, readers} -> Messages {messages, readers = Map.insert world.systemId (Reader tick) readers}) m
      return $ Reader tick

instance (Message m) => Component (Messages m)

-- | Write a message.
write :: forall m. (Message m) => m -> System ()
write !message = do
  messages <- resOrInsert (newMessages @m)
  world <- unsafeGetWorld
  frame <- liftIO $ readIORef world.frame

  loc <- self
  Just currentSystemTick <- single $ mkGet loc (C @SystemTick)

  let message' = (frame, currentSystemTick.inner, message)
  let newMessages = (\Messages {messages, readers} -> Messages {messages = message' : messages, readers}) messages
  insertRes newMessages
  clearOldMessages newMessages

-- | Read all the messages that haven't been read by the current system.
read :: forall m. (Message m) => System [m]
read = do
  m <- res @(Messages m)
  case m of
    Nothing -> pure []
    Just m -> do
      Reader tick <- getReader m
      readerTick <- liftIO $ readIORef tick

      loc <- self
      Just currentSystemTick <- single $ mkGet loc (C @SystemTick)

      let newMessages = map (\(_, _, x) -> x) $ filter (\(_, tick, _) -> tick < currentSystemTick.inner && tick > readerTick) m.messages
      liftIO $ writeIORef tick currentSystemTick.inner

      return newMessages

-- | Register a new message type with the App. This will automatically create a corresponding resource.
add :: forall (m :: Type). (Message m) => System ()
add = insertRes $ newMessages @m

clearOldMessages :: (Message m) => Messages m -> System ()
clearOldMessages !m = do
  world <- unsafeGetWorld
  frame <- liftIO $ readIORef world.frame
  insertRes $ (\Messages {messages, readers} -> Messages {messages = filter (\(Frame x, _, _) -> Frame (x + 2) >= frame) messages, readers}) m