module Game.LambdaHack.SampleImplementation.SampleMonadClient
( executorCli
#ifdef EXPOSE_INTERNAL
, CliImplementation
#endif
) where
import Control.Applicative
import Control.Concurrent.STM
import qualified Control.Monad.IO.Class as IO
import Control.Monad.Trans.State.Strict hiding (State)
import Data.Maybe
import System.FilePath
import Game.LambdaHack.Atomic.HandleAtomicWrite
import Game.LambdaHack.Atomic.MonadAtomic
import Game.LambdaHack.Atomic.MonadStateWrite
import Game.LambdaHack.Client.MonadClient
import Game.LambdaHack.Client.ProtocolClient
import Game.LambdaHack.Client.State
import Game.LambdaHack.Client.UI.MonadClientUI
import Game.LambdaHack.Common.ClientOptions
import Game.LambdaHack.Common.MonadStateRead
import qualified Game.LambdaHack.Common.Save as Save
import Game.LambdaHack.Common.State
import Game.LambdaHack.Server.ProtocolServer
data CliState resp req = CliState
{ cliState :: !State
, cliClient :: !StateClient
, cliDict :: !(ChanServer resp req)
, cliToSave :: !(Save.ChanSave (State, StateClient))
, cliSession :: SessionUI
}
newtype CliImplementation resp req a =
CliImplementation {runCliImplementation :: StateT (CliState resp req) IO a}
deriving (Monad, Functor, Applicative)
instance MonadStateRead (CliImplementation resp req) where
getState = CliImplementation $ gets cliState
getsState f = CliImplementation $ gets $ f . cliState
instance MonadStateWrite (CliImplementation resp req) where
modifyState f = CliImplementation $ state $ \cliS ->
let newCliS = cliS {cliState = f $ cliState cliS}
in newCliS `seq` ((), newCliS)
putState s = CliImplementation $ state $ \cliS ->
let newCliS = cliS {cliState = s}
in newCliS `seq` ((), newCliS)
instance MonadClient (CliImplementation resp req) where
getClient = CliImplementation $ gets cliClient
getsClient f = CliImplementation $ gets $ f . cliClient
modifyClient f = CliImplementation $ state $ \cliS ->
let newCliS = cliS {cliClient = f $ cliClient cliS}
in newCliS `seq` ((), newCliS)
putClient s = CliImplementation $ state $ \cliS ->
let newCliS = cliS {cliClient = s}
in newCliS `seq` ((), newCliS)
liftIO = CliImplementation . IO.liftIO
saveChanClient = CliImplementation $ gets cliToSave
instance MonadClientUI (CliImplementation resp req) where
getsSession f = CliImplementation $ gets $ f . cliSession
liftIO = CliImplementation . IO.liftIO
instance MonadClientReadResponse resp (CliImplementation resp req) where
receiveResponse = CliImplementation $ do
ChanServer{responseS} <- gets cliDict
IO.liftIO $ atomically . readTQueue $ responseS
instance MonadClientWriteRequest req (CliImplementation resp req) where
sendRequest scmd = CliImplementation $ do
ChanServer{requestS} <- gets cliDict
IO.liftIO $ atomically . writeTQueue requestS $ scmd
instance MonadAtomic (CliImplementation resp req) where
execAtomic = handleCmdAtomic
executorCli :: CliImplementation resp req ()
-> SessionUI -> State -> StateClient -> ChanServer resp req
-> IO ()
executorCli m cliSession cliState cliClient cliDict =
let saveFile (_, cli2) =
fromMaybe "save" (ssavePrefixCli (sdebugCli cli2))
<.> saveName (sside cli2) (sisAI cli2)
exe cliToSave =
evalStateT (runCliImplementation m) CliState{..}
in Save.wrapInSaves saveFile exe