module Game.GoreAndAsh.Actor.API(
ActorMonad(..)
, ActorException(..)
, actorSend
, actorSendMany
, actorSendDyn
, actorSendManyDyn
, actorProcessMessages
, actorProcessMessagesM
, actorMessages
, makeActor
, makeFixedActor
, runActor
, runActor'
, getActorFingerprint
) where
import Control.Monad.Catch
import Control.Monad.State.Strict
import Control.Wire
import Control.Wire.Unsafe.Event
import Data.Dynamic
import Data.Maybe (isJust, fromJust)
import GHC.Generics
import Prelude hiding (id, (.))
import qualified Data.Foldable as F
import qualified Data.HashMap.Strict as H
import qualified Data.Sequence as S
import Game.GoreAndAsh
import Game.GoreAndAsh.Actor.Indexed
import Game.GoreAndAsh.Actor.Message
import Game.GoreAndAsh.Actor.Module
import Game.GoreAndAsh.Actor.State
import Game.GoreAndAsh.Actor.TypeRep
data ActorException =
ActorIdConflict TypeRep Int
deriving (Show, Generic)
instance Exception ActorException
class MonadThrow m => ActorMonad m where
actorRegisterM :: ActorMessage i => m i
actorRegisterFixedM :: ActorMessage i => i -> m ()
actorDeleteM :: ActorMessage i => i -> m ()
actorRegisteredM :: ActorMessage i => i -> m Bool
actorSendM :: (ActorMessage i, Typeable (ActorMessageType i))
=> i -> ActorMessageType i -> m ()
actorGetMessagesM :: (ActorMessage i, Typeable (ActorMessageType i))
=> i -> m (S.Seq (ActorMessageType i))
findActorTypeRepM :: String -> m (Maybe HashableTypeRep)
registerActorTypeRepM :: forall proxy i . ActorMessage i => proxy i -> m ()
instance MonadThrow m => ActorMonad (ActorT s m) where
actorRegisterM = do
astate <- ActorT get
let (fpt, i, astate') = pushActorNextId astate
ActorT . put $! astate' {
actorBoxes = H.insert (fpt, toCounter i) (S.empty, S.empty) $! actorBoxes astate'
, actorNameMap = H.insert (show fpt) fpt $! actorNameMap astate'
}
return i
actorRegisterFixedM i = do
astate <- ActorT get
case regActorFixedId i astate of
Nothing -> throwM $! ActorIdConflict tp (toCounter i)
where tp = fromHashableTypeRep $ getActorFingerprint i
Just astate' -> ActorT . put $! astate'
actorDeleteM i = do
astate <- ActorT get
ActorT . put $! deleteActorId i astate
actorRegisteredM i = do
astate <- ActorT get
return . isActorIdRegistered i $! astate
actorSendM i msg = do
astate <- ActorT get
ActorT . put $! putActorMessage i (toDyn msg) astate
actorGetMessagesM i = do
astate <- ActorT get
let msgs = getActorMessages i astate
return . catMaybesSeq . fmap fromDynamic $! msgs
findActorTypeRepM n = do
astate <- ActorT get
return . H.lookup n . actorNameMap $! astate
registerActorTypeRepM p = do
astate <- ActorT get
let fp = actorFingerprint p
ActorT . put $! astate {
actorNameMap = H.insert (show fp) fp . actorNameMap $! astate
}
instance (MonadThrow (mt m), ActorMonad m, MonadTrans mt) => ActorMonad (mt m) where
actorRegisterM = lift actorRegisterM
actorRegisterFixedM = lift . actorRegisterFixedM
actorDeleteM = lift . actorDeleteM
actorRegisteredM = lift . actorRegisteredM
actorSendM a b = lift $ actorSendM a b
actorGetMessagesM = lift . actorGetMessagesM
findActorTypeRepM = lift . findActorTypeRepM
registerActorTypeRepM = lift . registerActorTypeRepM
catMaybesSeq :: S.Seq (Maybe a) -> S.Seq a
catMaybesSeq = fmap fromJust . S.filter isJust
getActorFingerprint :: forall i . ActorMessage i => i -> HashableTypeRep
getActorFingerprint _ = actorFingerprint (Proxy :: Proxy i)
pushActorNextId :: forall i s . ActorMessage i => ActorState s -> (HashableTypeRep, i, ActorState s)
pushActorNextId !s = case H.lookup k (actorBoxes s) of
Just _ -> pushActorNextId nextState
Nothing -> (fingerprint, nextId, nextState)
where
fingerprint = actorFingerprint (Proxy :: Proxy i)
(nextId, nextState) = rawGet s
k = (fingerprint, toCounter nextId)
rawGet :: ActorState s -> (i, ActorState s)
rawGet s' = case H.lookup fingerprint (actorNextId s') of
Nothing -> (fromCounter 0, s' {
actorNextId = H.insert fingerprint 1 (actorNextId s')
})
Just i -> (fromCounter i, s' {
actorNextId = H.insert fingerprint (i+1) (actorNextId s')
})
regActorFixedId :: forall i s . ActorMessage i => i -> ActorState s -> Maybe (ActorState s)
regActorFixedId !i !s = case H.lookup k (actorBoxes s) of
Just _ -> Nothing
Nothing -> Just $! s {
actorBoxes = H.insert k (S.empty, S.empty) . actorBoxes $! s
, actorNameMap = H.insert (show fingerprint) fingerprint . actorNameMap $! s
}
where
fingerprint = actorFingerprint (Proxy :: Proxy i)
k = (fingerprint, toCounter i)
deleteActorId :: forall i s . ActorMessage i => i -> ActorState s -> ActorState s
deleteActorId !i !s = s {
actorBoxes = H.delete k . actorBoxes $! s
, actorNameMap = H.delete (show fingerprint) . actorNameMap $! s
}
where
fingerprint = actorFingerprint (Proxy :: Proxy i)
k = (fingerprint, toCounter i)
isActorIdRegistered :: forall i s . ActorMessage i => i -> ActorState s -> Bool
isActorIdRegistered !i !s = case H.lookup k . actorBoxes $! s of
Nothing -> False
Just _ -> True
where
fingerprint = actorFingerprint (Proxy :: Proxy i)
k = (fingerprint, toCounter i)
putActorMessage :: forall i s . ActorMessage i => i -> Dynamic -> ActorState s -> ActorState s
putActorMessage !i !msg !s = case H.lookup k . actorBoxes $! s of
Nothing -> s
Just (msgsR, msgsS) -> s {
actorBoxes = H.insert k (msgsR, msgsS S.|> msg) . actorBoxes $! s
}
where
fingerprint = actorFingerprint (Proxy :: Proxy i)
k = (fingerprint, toCounter i)
getActorMessages :: forall i s . ActorMessage i => i -> ActorState s -> S.Seq Dynamic
getActorMessages !i !s = case H.lookup k . actorBoxes $! s of
Nothing -> S.empty
Just (msgs, _) -> msgs
where
fingerprint = actorFingerprint (Proxy :: Proxy i)
k = (fingerprint, toCounter i)
actorSend :: (ActorMonad m, ActorMessage i, Typeable (ActorMessageType i))
=> i -> GameWire m (Event (ActorMessageType i)) (Event ())
actorSend i = liftGameMonadEvent1 $ actorSendM i
actorSendMany :: (ActorMonad m, ActorMessage i, Typeable (ActorMessageType i), F.Foldable t)
=> i -> GameWire m (Event (t (ActorMessageType i))) (Event ())
actorSendMany i = liftGameMonadEvent1 $ F.mapM_ (actorSendM i)
actorSendDyn :: (ActorMonad m, ActorMessage i, Typeable (ActorMessageType i))
=> GameWire m (Event (i, ActorMessageType i)) (Event ())
actorSendDyn = liftGameMonadEvent1 $ \(i, m) -> actorSendM i m
actorSendManyDyn :: (ActorMonad m, ActorMessage i, Typeable (ActorMessageType i), F.Foldable t)
=> GameWire m (Event (t (i, ActorMessageType i))) (Event ())
actorSendManyDyn = liftGameMonadEvent1 $ F.mapM_ (uncurry actorSendM)
actorProcessMessages :: (ActorMonad m, ActorMessage i, Typeable (ActorMessageType i))
=> i
-> (a -> ActorMessageType i -> a)
-> GameWire m a a
actorProcessMessages i f = liftGameMonad1 $ \a -> do
msgs <- actorGetMessagesM i
return . F.foldl' f a $! msgs
actorProcessMessagesM :: (ActorMonad m, ActorMessage i, Typeable (ActorMessageType i))
=> i
-> (a -> ActorMessageType i -> GameMonadT m a)
-> GameWire m a a
actorProcessMessagesM i f = liftGameMonad1 $ \a -> do
msgs <- actorGetMessagesM i
foldM f a msgs
makeActor :: (ActorMonad m, ActorMessage i)
=> (i -> GameWire m a b)
-> GameActor m i a b
makeActor wbody = do
i <- actorRegisterM
return $! GameWireIndexed i (wbody i)
makeFixedActor :: (ActorMonad m, ActorMessage i)
=> i
-> GameWire m a b
-> GameActor m i a b
makeFixedActor i wbody = do
actorRegisterFixedM i
return $! GameWireIndexed i wbody
runActor :: ActorMonad m
=> GameActor m i a b
-> GameWire m a (b, i)
runActor actor = switch makeWire
where
makeWire = proc _ -> do
e <- mapE (\iw -> arr (, indexedId iw) . indexedWire iw) . now . liftGameMonadOnce actor -< ()
returnA -< (error "runActor: impossible", e)
runActor' :: ActorMonad m
=> GameActor m i a b
-> GameWire m a b
runActor' actor = arr fst . runActor actor
actorMessages :: (ActorMonad m, ActorMessage i, Typeable (ActorMessageType i))
=> i
-> (ActorMessageType i -> Bool)
-> GameWire m a (Event (S.Seq (ActorMessageType i)))
actorMessages i f = liftGameMonad $ do
msgs <- S.filter f <$> actorGetMessagesM i
return $! if S.null msgs then NoEvent
else Event msgs