{-# LANGUAGE FlexibleContexts #-}
-- | Semantics of responses sent by the server to clients.
module Game.LambdaHack.Client.HandleResponseM
  ( MonadClientAtomic(..), MonadClientWriteRequest(..)
  , handleResponse
  ) where

import Prelude ()

import Game.LambdaHack.Core.Prelude

import Game.LambdaHack.Atomic (UpdAtomic)
import Game.LambdaHack.Client.AI
import Game.LambdaHack.Client.HandleAtomicM
import Game.LambdaHack.Client.MonadClient
import Game.LambdaHack.Client.Request
import Game.LambdaHack.Client.Response
import Game.LambdaHack.Client.UI
import Game.LambdaHack.Common.MonadStateRead
import Game.LambdaHack.Common.State

-- | Monad for executing atomic game state transformations on a client.
class MonadClient m => MonadClientAtomic m where
  -- | Execute an atomic update that changes the client's 'State'.
  execUpdAtomic :: UpdAtomic -> m ()
  -- | Put state that is intended to be the result of performing
  -- an atomic update by the server on its copy of the client's 'State'.
  execPutState :: State -> m ()

-- | Client monad in which one can send requests to the client.
class MonadClient m => MonadClientWriteRequest m where
  sendRequestAI :: RequestAI -> m ()
  sendRequestUI :: RequestUI -> m ()
  clientHasUI   :: m Bool

-- | Handle server responses.
--
-- Note that for clients communicating with the server over the net,
-- @RespUpdAtomicNoState@ should be used, because executing a single command
-- is cheaper than sending the whole state over the net.
-- However, for the standalone exe mode, with clients in the same process
-- as the server, a pointer to the state set with @execPutState@ is cheaper.
handleResponse :: ( MonadClientSetup m
                  , MonadClientUI m
                  , MonadClientAtomic m
                  , MonadClientWriteRequest m )
               => Response -> m ()
handleResponse :: Response -> m ()
handleResponse Response
cmd = case Response
cmd of
  RespUpdAtomic State
newState UpdAtomic
cmdA -> do
    State
oldState <- m State
forall (m :: * -> *). MonadStateRead m => m State
getState
    State -> m ()
forall (m :: * -> *). MonadClientAtomic m => State -> m ()
execPutState State
newState
    State -> UpdAtomic -> m ()
forall (m :: * -> *).
MonadClientSetup m =>
State -> UpdAtomic -> m ()
cmdAtomicSemCli State
oldState UpdAtomic
cmdA
    Bool
hasUI <- m Bool
forall (m :: * -> *). MonadClientWriteRequest m => m Bool
clientHasUI
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
hasUI (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ UpdAtomic -> m ()
forall (m :: * -> *). MonadClientUI m => UpdAtomic -> m ()
watchRespUpdAtomicUI UpdAtomic
cmdA
  RespUpdAtomicNoState UpdAtomic
cmdA -> do
    State
oldState <- m State
forall (m :: * -> *). MonadStateRead m => m State
getState
    UpdAtomic -> m ()
forall (m :: * -> *). MonadClientAtomic m => UpdAtomic -> m ()
execUpdAtomic UpdAtomic
cmdA
    State -> UpdAtomic -> m ()
forall (m :: * -> *).
MonadClientSetup m =>
State -> UpdAtomic -> m ()
cmdAtomicSemCli State
oldState UpdAtomic
cmdA
    Bool
hasUI <- m Bool
forall (m :: * -> *). MonadClientWriteRequest m => m Bool
clientHasUI
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
hasUI (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ UpdAtomic -> m ()
forall (m :: * -> *). MonadClientUI m => UpdAtomic -> m ()
watchRespUpdAtomicUI UpdAtomic
cmdA
  RespQueryAI ActorId
aid -> do
    RequestAI
cmdC <- ActorId -> m RequestAI
forall (m :: * -> *). MonadClient m => ActorId -> m RequestAI
queryAI ActorId
aid
    RequestAI -> m ()
forall (m :: * -> *).
MonadClientWriteRequest m =>
RequestAI -> m ()
sendRequestAI RequestAI
cmdC
  RespSfxAtomic SfxAtomic
sfx ->
    SfxAtomic -> m ()
forall (m :: * -> *). MonadClientUI m => SfxAtomic -> m ()
watchRespSfxAtomicUI SfxAtomic
sfx
  Response
RespQueryUIunderAI -> do
    RequestUI
req <- m RequestUI
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
m RequestUI
queryUIunderAI
    RequestUI -> m ()
forall (m :: * -> *).
MonadClientWriteRequest m =>
RequestUI -> m ()
sendRequestUI RequestUI
req
  Response
RespQueryUI -> do
    -- Stop displaying the prompt, if any.
    (SessionUI -> SessionUI) -> m ()
forall (m :: * -> *).
MonadClientUI m =>
(SessionUI -> SessionUI) -> m ()
modifySession ((SessionUI -> SessionUI) -> m ())
-> (SessionUI -> SessionUI) -> m ()
forall a b. (a -> b) -> a -> b
$ \SessionUI
sess -> SessionUI
sess {sreqDelay :: ReqDelay
sreqDelay = ReqDelay
ReqDelayNot}
    Maybe RequestUI
sreqPending <- (SessionUI -> Maybe RequestUI) -> m (Maybe RequestUI)
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Maybe RequestUI
sreqPending
    RequestUI
req <- case Maybe RequestUI
sreqPending of
      Maybe RequestUI
Nothing -> do
        -- Server sending @RespQueryUI@ means that it's sent everything
        -- and is now ready to receive a request ASAP, so no point polling
        -- and instead query the player repeatedly until request generated.
        let loop :: m RequestUI
loop = do
              Maybe RequestUI
mreq <- m (Maybe RequestUI)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
m (Maybe RequestUI)
queryUI
              m RequestUI
-> (RequestUI -> m RequestUI) -> Maybe RequestUI -> m RequestUI
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m RequestUI
loop RequestUI -> m RequestUI
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe RequestUI
mreq
        m RequestUI
loop
      Just RequestUI
reqPending -> do
        (SessionUI -> SessionUI) -> m ()
forall (m :: * -> *).
MonadClientUI m =>
(SessionUI -> SessionUI) -> m ()
modifySession ((SessionUI -> SessionUI) -> m ())
-> (SessionUI -> SessionUI) -> m ()
forall a b. (a -> b) -> a -> b
$ \SessionUI
sess -> SessionUI
sess {sreqPending :: Maybe RequestUI
sreqPending = Maybe RequestUI
forall a. Maybe a
Nothing}
        RequestUI -> m RequestUI
forall (m :: * -> *) a. Monad m => a -> m a
return RequestUI
reqPending
    RequestUI -> m ()
forall (m :: * -> *).
MonadClientWriteRequest m =>
RequestUI -> m ()
sendRequestUI RequestUI
req