{-# LANGUAGE FlexibleContexts #-}
-- | Semantics of responses sent by the server to clients.
module Game.LambdaHack.Client.HandleResponseM
  ( MonadClientWriteRequest(..)
  , MonadClientAtomic(..)
  , 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

-- | 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

-- | 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 ()

-- | 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 cmd :: Response
cmd = case Response
cmd of
  RespUpdAtomic newState :: State
newState cmdA :: 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 :: * -> *).
(MonadClient m, MonadClientUI m) =>
UpdAtomic -> m ()
displayRespUpdAtomicUI UpdAtomic
cmdA
  RespUpdAtomicNoState cmdA :: 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 :: * -> *).
(MonadClient m, MonadClientUI m) =>
UpdAtomic -> m ()
displayRespUpdAtomicUI UpdAtomic
cmdA
  RespQueryAI aid :: 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 sfx :: SfxAtomic
sfx ->
    SfxAtomic -> m ()
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
SfxAtomic -> m ()
displayRespSfxAtomicUI SfxAtomic
sfx
  RespQueryUI -> do
    RequestUI
cmdH <- m RequestUI
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
m RequestUI
queryUI
    RequestUI -> m ()
forall (m :: * -> *).
MonadClientWriteRequest m =>
RequestUI -> m ()
sendRequestUI RequestUI
cmdH