{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE Trustworthy #-}
-- For Empty and :<
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}

-- |
-- Module      :  Games.ECS.MessageQueue
-- Description : A simple message queue implementation.
-- Copyright   :  (C) 2020 Sophie Taylor
-- License     :  AGPL-3.0-or-later
-- Maintainer  :  Sophie Taylor <sophie@spacekitteh.moe>
-- Stability   :  experimental
-- Portability: GHC
--
-- Implements a simple message queuing system.
module Games.ECS.MessageQueue
  ( MessageQueue,
    --    queue,
    newMessageQueue,
    MonadAtomicMessageQueue (..),
    queueMessage,
    queueImmediateMessage,
    queueMessages,
    readMessage,
    processMessageQueue,
    MessagesProcessed (..),
  )
where

import Control.Lens
import Control.Monad
import Data.Hashable
import Data.Sequence (Seq, singleton)
import Data.Tuple (swap)
import GHC.Generics
import GHC.Types (SPEC (..))
import Games.ECS.Util.Misc
import Games.ECS.World

data DelayedOrNot
  = NotDelayed
  | Delayed
  deriving stock (DelayedOrNot -> DelayedOrNot -> Bool
(DelayedOrNot -> DelayedOrNot -> Bool)
-> (DelayedOrNot -> DelayedOrNot -> Bool) -> Eq DelayedOrNot
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DelayedOrNot -> DelayedOrNot -> Bool
== :: DelayedOrNot -> DelayedOrNot -> Bool
$c/= :: DelayedOrNot -> DelayedOrNot -> Bool
/= :: DelayedOrNot -> DelayedOrNot -> Bool
Eq, (forall x. DelayedOrNot -> Rep DelayedOrNot x)
-> (forall x. Rep DelayedOrNot x -> DelayedOrNot)
-> Generic DelayedOrNot
forall x. Rep DelayedOrNot x -> DelayedOrNot
forall x. DelayedOrNot -> Rep DelayedOrNot x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. DelayedOrNot -> Rep DelayedOrNot x
from :: forall x. DelayedOrNot -> Rep DelayedOrNot x
$cto :: forall x. Rep DelayedOrNot x -> DelayedOrNot
to :: forall x. Rep DelayedOrNot x -> DelayedOrNot
Generic)
  deriving anyclass (Eq DelayedOrNot
Eq DelayedOrNot =>
(Int -> DelayedOrNot -> Int)
-> (DelayedOrNot -> Int) -> Hashable DelayedOrNot
Int -> DelayedOrNot -> Int
DelayedOrNot -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> DelayedOrNot -> Int
hashWithSalt :: Int -> DelayedOrNot -> Int
$chash :: DelayedOrNot -> Int
hash :: DelayedOrNot -> Int
Hashable)

-- | The core message queue type.
newtype MessageQueue a = MessageQueue {forall a. MessageQueue a -> Seq (DelayedOrNot, a)
_queue :: Seq (DelayedOrNot, a)} deriving stock (MessageQueue a -> MessageQueue a -> Bool
(MessageQueue a -> MessageQueue a -> Bool)
-> (MessageQueue a -> MessageQueue a -> Bool)
-> Eq (MessageQueue a)
forall a. Eq a => MessageQueue a -> MessageQueue a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => MessageQueue a -> MessageQueue a -> Bool
== :: MessageQueue a -> MessageQueue a -> Bool
$c/= :: forall a. Eq a => MessageQueue a -> MessageQueue a -> Bool
/= :: MessageQueue a -> MessageQueue a -> Bool
Eq, (forall x. MessageQueue a -> Rep (MessageQueue a) x)
-> (forall x. Rep (MessageQueue a) x -> MessageQueue a)
-> Generic (MessageQueue a)
forall x. Rep (MessageQueue a) x -> MessageQueue a
forall x. MessageQueue a -> Rep (MessageQueue a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (MessageQueue a) x -> MessageQueue a
forall a x. MessageQueue a -> Rep (MessageQueue a) x
$cfrom :: forall a x. MessageQueue a -> Rep (MessageQueue a) x
from :: forall x. MessageQueue a -> Rep (MessageQueue a) x
$cto :: forall a x. Rep (MessageQueue a) x -> MessageQueue a
to :: forall x. Rep (MessageQueue a) x -> MessageQueue a
Generic)

makeLenses ''MessageQueue

-- | Construct a new, empty t'MessageQueue'.
{-# INLINE newMessageQueue #-}
newMessageQueue :: MessageQueue a
newMessageQueue :: forall a. MessageQueue a
newMessageQueue = let q :: Seq (DelayedOrNot, a)
q = Seq (DelayedOrNot, a)
forall s. AsEmpty s => s
Empty in Seq (DelayedOrNot, a) -> MessageQueue a
forall a. Seq (DelayedOrNot, a) -> MessageQueue a
MessageQueue Seq (DelayedOrNot, a)
q

instance (Hashable a) => Hashable (MessageQueue a) where
  {-# INLINE hashWithSalt #-}
  hashWithSalt :: Int -> MessageQueue a -> Int
hashWithSalt Int
salt (MessageQueue Seq (DelayedOrNot, a)
q) = Int -> HashableSeq (DelayedOrNot, a) -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
salt (Seq (DelayedOrNot, a) -> HashableSeq (DelayedOrNot, a)
forall a. Seq a -> HashableSeq a
HashableSeq Seq (DelayedOrNot, a)
q)

-- | Monads which can atomically modify a t'MessageQueue'.
class (Monad m) => MonadAtomicMessageQueue a m where
  -- | Monadically perform a given state transition atomically on the t'MessageQueue', and return the result.
  stateMessageQueue :: (MessageQueue a -> (MessageQueue a, val)) -> m val

  -- | Atomically modify a t'MessageQueue'.
  modifyMessageQueue :: (MessageQueue a -> MessageQueue a) -> m ()

{-# INLINEABLE queueMessage #-}

-- | Queue message
queueMessage :: forall a m. (MonadAtomicMessageQueue a m) => a -> m ()
queueMessage :: forall a (m :: * -> *). MonadAtomicMessageQueue a m => a -> m ()
queueMessage a
msg = do
  (MessageQueue a -> MessageQueue a) -> m ()
forall a (m :: * -> *).
MonadAtomicMessageQueue a m =>
(MessageQueue a -> MessageQueue a) -> m ()
modifyMessageQueue (\MessageQueue a
q -> MessageQueue a
q MessageQueue a
-> (MessageQueue a -> MessageQueue a) -> MessageQueue a
forall a b. a -> (a -> b) -> b
& (Seq (DelayedOrNot, a) -> Identity (Seq (DelayedOrNot, a)))
-> MessageQueue a -> Identity (MessageQueue a)
forall a a (p :: * -> * -> *) (f :: * -> *).
(Profunctor p, Functor f) =>
p (Seq (DelayedOrNot, a)) (f (Seq (DelayedOrNot, a)))
-> p (MessageQueue a) (f (MessageQueue a))
queue ((Seq (DelayedOrNot, a) -> Identity (Seq (DelayedOrNot, a)))
 -> MessageQueue a -> Identity (MessageQueue a))
-> (Seq (DelayedOrNot, a) -> Seq (DelayedOrNot, a))
-> MessageQueue a
-> MessageQueue a
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Seq (DelayedOrNot, a) -> (DelayedOrNot, a) -> Seq (DelayedOrNot, a)
forall s a. Snoc s s a a => s -> a -> s
|> (DelayedOrNot
NotDelayed, a
msg)))

{-# INLINEABLE queueImmediateMessage #-}

-- | Push a message on to the front of the queue.
queueImmediateMessage :: forall a m. (MonadAtomicMessageQueue a m) => a -> m ()
queueImmediateMessage :: forall a (m :: * -> *). MonadAtomicMessageQueue a m => a -> m ()
queueImmediateMessage a
msg = do
  (MessageQueue a -> MessageQueue a) -> m ()
forall a (m :: * -> *).
MonadAtomicMessageQueue a m =>
(MessageQueue a -> MessageQueue a) -> m ()
modifyMessageQueue (\MessageQueue a
q -> MessageQueue a
q MessageQueue a
-> (MessageQueue a -> MessageQueue a) -> MessageQueue a
forall a b. a -> (a -> b) -> b
& (Seq (DelayedOrNot, a) -> Identity (Seq (DelayedOrNot, a)))
-> MessageQueue a -> Identity (MessageQueue a)
forall a a (p :: * -> * -> *) (f :: * -> *).
(Profunctor p, Functor f) =>
p (Seq (DelayedOrNot, a)) (f (Seq (DelayedOrNot, a)))
-> p (MessageQueue a) (f (MessageQueue a))
queue ((Seq (DelayedOrNot, a) -> Identity (Seq (DelayedOrNot, a)))
 -> MessageQueue a -> Identity (MessageQueue a))
-> (Seq (DelayedOrNot, a) -> Seq (DelayedOrNot, a))
-> MessageQueue a
-> MessageQueue a
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ((DelayedOrNot
NotDelayed, a
msg) <|))

{-# INLINEABLE queueMessages #-}

-- | Queue a series of messages
queueMessages :: (Foldable f, MonadAtomicMessageQueue a m) => f a -> m ()
queueMessages :: forall (f :: * -> *) a (m :: * -> *).
(Foldable f, MonadAtomicMessageQueue a m) =>
f a -> m ()
queueMessages f a
msgs = f a -> (a -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ f a
msgs a -> m ()
forall a (m :: * -> *). MonadAtomicMessageQueue a m => a -> m ()
queueMessage

{-# INLINEABLE readMessage #-}

-- | Pops the message queue
readMessage :: (MonadAtomicMessageQueue a m) => (a -> Bool) -> m (Maybe a)
readMessage :: forall a (m :: * -> *).
MonadAtomicMessageQueue a m =>
(a -> Bool) -> m (Maybe a)
readMessage a -> Bool
shouldSkip =
  (MessageQueue a -> (MessageQueue a, Maybe a)) -> m (Maybe a)
forall val. (MessageQueue a -> (MessageQueue a, val)) -> m val
forall a (m :: * -> *) val.
MonadAtomicMessageQueue a m =>
(MessageQueue a -> (MessageQueue a, val)) -> m val
stateMessageQueue
    ( \(MessageQueue Seq (DelayedOrNot, a)
msgs) -> (Maybe a, MessageQueue a) -> (MessageQueue a, Maybe a)
forall a b. (a, b) -> (b, a)
swap ((Maybe a, MessageQueue a) -> (MessageQueue a, Maybe a))
-> (Seq (DelayedOrNot, a) -> (Maybe a, MessageQueue a))
-> Seq (DelayedOrNot, a)
-> (MessageQueue a, Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Seq (DelayedOrNot, a) -> MessageQueue a)
-> (Maybe a, Seq (DelayedOrNot, a)) -> (Maybe a, MessageQueue a)
forall a b. (a -> b) -> (Maybe a, a) -> (Maybe a, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Seq (DelayedOrNot, a) -> MessageQueue a
forall a. Seq (DelayedOrNot, a) -> MessageQueue a
MessageQueue (Seq (DelayedOrNot, a) -> MessageQueue a)
-> (Seq (DelayedOrNot, a) -> Seq (DelayedOrNot, a))
-> Seq (DelayedOrNot, a)
-> MessageQueue a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((DelayedOrNot, a) -> (DelayedOrNot, a))
-> Seq (DelayedOrNot, a) -> Seq (DelayedOrNot, a)
forall a b. (a -> b) -> Seq a -> Seq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DelayedOrNot, a) -> (DelayedOrNot, a)
forall {b}. (DelayedOrNot, b) -> (DelayedOrNot, b)
clearDelayed) ((Maybe a, Seq (DelayedOrNot, a)) -> (Maybe a, MessageQueue a))
-> (Seq (DelayedOrNot, a) -> (Maybe a, Seq (DelayedOrNot, a)))
-> Seq (DelayedOrNot, a)
-> (Maybe a, MessageQueue a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq (DelayedOrNot, a) -> (Maybe a, Seq (DelayedOrNot, a))
go (Seq (DelayedOrNot, a) -> (MessageQueue a, Maybe a))
-> Seq (DelayedOrNot, a) -> (MessageQueue a, Maybe a)
forall a b. (a -> b) -> a -> b
$ Seq (DelayedOrNot, a)
msgs
    )
  where
    clearDelayed :: (DelayedOrNot, b) -> (DelayedOrNot, b)
clearDelayed (DelayedOrNot
Delayed, b
a) = (DelayedOrNot
NotDelayed, b
a)
    clearDelayed (DelayedOrNot, b)
x = (DelayedOrNot, b)
x
    go :: Seq (DelayedOrNot, a) -> (Maybe a, Seq (DelayedOrNot, a))
go Seq (DelayedOrNot, a)
Empty = (Maybe a
forall a. Maybe a
Nothing, Seq (DelayedOrNot, a)
forall s. AsEmpty s => s
Empty)
    go ((DelayedOrNot
NotDelayed, a
a) :< Seq (DelayedOrNot, a)
rest)
      | a -> Bool
shouldSkip a
a = (Seq (DelayedOrNot, a) -> Seq (DelayedOrNot, a))
-> (Maybe a, Seq (DelayedOrNot, a))
-> (Maybe a, Seq (DelayedOrNot, a))
forall a b. (a -> b) -> (Maybe a, a) -> (Maybe a, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((DelayedOrNot
Delayed, a
a) <|) (Seq (DelayedOrNot, a) -> (Maybe a, Seq (DelayedOrNot, a))
go Seq (DelayedOrNot, a)
rest)
      | Bool
otherwise = (a -> Maybe a
forall a. a -> Maybe a
Just a
a, Seq (DelayedOrNot, a)
rest)
    go ((DelayedOrNot
Delayed, a
a) :< Seq (DelayedOrNot, a)
rest) = (Seq (DelayedOrNot, a) -> Seq (DelayedOrNot, a))
-> (Maybe a, Seq (DelayedOrNot, a))
-> (Maybe a, Seq (DelayedOrNot, a))
forall a b. (a -> b) -> (Maybe a, a) -> (Maybe a, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((DelayedOrNot
Delayed, a
a) <|) (Seq (DelayedOrNot, a) -> (Maybe a, Seq (DelayedOrNot, a))
go Seq (DelayedOrNot, a)
rest)

-- | Which messages were processed.
data MessagesProcessed a
  = AllMessagesProcessed
  | NewMessagesProcessed !(Seq a)
  deriving stock (MessagesProcessed a -> MessagesProcessed a -> Bool
(MessagesProcessed a -> MessagesProcessed a -> Bool)
-> (MessagesProcessed a -> MessagesProcessed a -> Bool)
-> Eq (MessagesProcessed a)
forall a.
Eq a =>
MessagesProcessed a -> MessagesProcessed a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a.
Eq a =>
MessagesProcessed a -> MessagesProcessed a -> Bool
== :: MessagesProcessed a -> MessagesProcessed a -> Bool
$c/= :: forall a.
Eq a =>
MessagesProcessed a -> MessagesProcessed a -> Bool
/= :: MessagesProcessed a -> MessagesProcessed a -> Bool
Eq, (forall x. MessagesProcessed a -> Rep (MessagesProcessed a) x)
-> (forall x. Rep (MessagesProcessed a) x -> MessagesProcessed a)
-> Generic (MessagesProcessed a)
forall x. Rep (MessagesProcessed a) x -> MessagesProcessed a
forall x. MessagesProcessed a -> Rep (MessagesProcessed a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (MessagesProcessed a) x -> MessagesProcessed a
forall a x. MessagesProcessed a -> Rep (MessagesProcessed a) x
$cfrom :: forall a x. MessagesProcessed a -> Rep (MessagesProcessed a) x
from :: forall x. MessagesProcessed a -> Rep (MessagesProcessed a) x
$cto :: forall a x. Rep (MessagesProcessed a) x -> MessagesProcessed a
to :: forall x. Rep (MessagesProcessed a) x -> MessagesProcessed a
Generic, Int -> MessagesProcessed a -> ShowS
[MessagesProcessed a] -> ShowS
MessagesProcessed a -> String
(Int -> MessagesProcessed a -> ShowS)
-> (MessagesProcessed a -> String)
-> ([MessagesProcessed a] -> ShowS)
-> Show (MessagesProcessed a)
forall a. Show a => Int -> MessagesProcessed a -> ShowS
forall a. Show a => [MessagesProcessed a] -> ShowS
forall a. Show a => MessagesProcessed a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> MessagesProcessed a -> ShowS
showsPrec :: Int -> MessagesProcessed a -> ShowS
$cshow :: forall a. Show a => MessagesProcessed a -> String
show :: MessagesProcessed a -> String
$cshowList :: forall a. Show a => [MessagesProcessed a] -> ShowS
showList :: [MessagesProcessed a] -> ShowS
Show)

instance (Hashable a) => Hashable (MessagesProcessed a) where
  {-# INLINE hashWithSalt #-}
  hashWithSalt :: Int -> MessagesProcessed a -> Int
hashWithSalt Int
salt MessagesProcessed a
AllMessagesProcessed = Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
salt (Int
0 :: Int)
  hashWithSalt Int
salt (NewMessagesProcessed Seq a
msgs) = (Int
salt Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (Int
1 :: Int)) Int -> HashableSeq a -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Seq a -> HashableSeq a
forall a. Seq a -> HashableSeq a
HashableSeq Seq a
msgs

instance Semigroup (MessagesProcessed a) where
  {-# INLINE (<>) #-}
  MessagesProcessed a
AllMessagesProcessed <> :: MessagesProcessed a -> MessagesProcessed a -> MessagesProcessed a
<> (NewMessagesProcessed Seq a
Empty) = MessagesProcessed a
forall a. MessagesProcessed a
AllMessagesProcessed
  MessagesProcessed a
AllMessagesProcessed <> MessagesProcessed a
b = MessagesProcessed a
b
  (NewMessagesProcessed Seq a
Empty) <> MessagesProcessed a
AllMessagesProcessed = MessagesProcessed a
forall a. MessagesProcessed a
AllMessagesProcessed
  MessagesProcessed a
a <> MessagesProcessed a
AllMessagesProcessed = MessagesProcessed a
a
  (NewMessagesProcessed Seq a
a) <> (NewMessagesProcessed Seq a
b) = Seq a -> MessagesProcessed a
forall a. Seq a -> MessagesProcessed a
NewMessagesProcessed (Seq a
a Seq a -> Seq a -> Seq a
forall a. Semigroup a => a -> a -> a
<> Seq a
b)

instance Monoid (MessagesProcessed a) where
  {-# INLINEABLE mempty #-}
  mempty :: MessagesProcessed a
mempty = MessagesProcessed a
forall a. MessagesProcessed a
AllMessagesProcessed

{-# INLINEABLE processMessageQueue #-}

-- | Processes a message queue until it's empty.
processMessageQueue ::
  forall world a m.
  (MonadAtomicMessageQueue a m) =>
  -- | Predicate on whether a message should be skipped this time round, and left in the queue.
  (world Storing -> a -> Bool) ->
  -- | How to process an individual message.
  (world Storing -> a -> m (world Storing)) ->
  -- | The world.
  world Storing ->
  m (MessagesProcessed a, world Storing)
processMessageQueue :: forall (world :: Access -> *) a (m :: * -> *).
MonadAtomicMessageQueue a m =>
(world 'Storing -> a -> Bool)
-> (world 'Storing -> a -> m (world 'Storing))
-> world 'Storing
-> m (MessagesProcessed a, world 'Storing)
processMessageQueue world 'Storing -> a -> Bool
shouldSkip world 'Storing -> a -> m (world 'Storing)
processMsg world 'Storing
oldWorld = SPEC
-> MessagesProcessed a
-> world 'Storing
-> m (MessagesProcessed a, world 'Storing)
processNextMessage SPEC
SPEC MessagesProcessed a
forall a. Monoid a => a
mempty world 'Storing
oldWorld
  where
    -- Process the message queue one at a time. Because it only ever locks the message queue long enough to
    -- pop it, messages can safely enqueue other messages.
    processNextMessage :: SPEC
-> MessagesProcessed a
-> world 'Storing
-> m (MessagesProcessed a, world 'Storing)
processNextMessage !SPEC
sPEC MessagesProcessed a
doneMessages world 'Storing
world = do
      Maybe a
nextMessage <- (a -> Bool) -> m (Maybe a)
forall a (m :: * -> *).
MonadAtomicMessageQueue a m =>
(a -> Bool) -> m (Maybe a)
readMessage (world 'Storing -> a -> Bool
shouldSkip world 'Storing
world)
      case Maybe a
nextMessage of
        -- The queue is empty or has no messages available to process; return the list of effects we processed and the updated world
        Maybe a
Nothing -> (MessagesProcessed a, world 'Storing)
-> m (MessagesProcessed a, world 'Storing)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MessagesProcessed a
doneMessages, world 'Storing
world)
        -- We've popped another effect off of the queue. Process it, then process the rest of the queue
        Just a
msg -> do
          world 'Storing
processedNewWorld <- world 'Storing -> a -> m (world 'Storing)
processMsg world 'Storing
world a
msg
          SPEC
-> MessagesProcessed a
-> world 'Storing
-> m (MessagesProcessed a, world 'Storing)
processNextMessage SPEC
sPEC (MessagesProcessed a
doneMessages MessagesProcessed a -> MessagesProcessed a -> MessagesProcessed a
forall a. Semigroup a => a -> a -> a
<> (Seq a -> MessagesProcessed a
forall a. Seq a -> MessagesProcessed a
NewMessagesProcessed (a -> Seq a
forall a. a -> Seq a
singleton a
msg))) world 'Storing
processedNewWorld