module Game.LambdaHack.SampleImplementation.SampleMonadServer
( executorSer
#ifdef EXPOSE_INTERNAL
, SerImplementation
#endif
) where
import Control.Applicative
import qualified Control.Monad.IO.Class as IO
import Control.Monad.Trans.State.Strict hiding (State)
import qualified Data.EnumMap.Strict as EM
import Data.Maybe
import System.FilePath
import Game.LambdaHack.Atomic.BroadcastAtomicWrite
import Game.LambdaHack.Atomic.CmdAtomic
import Game.LambdaHack.Atomic.MonadAtomic
import Game.LambdaHack.Atomic.MonadStateWrite
import Game.LambdaHack.Common.MonadStateRead
import qualified Game.LambdaHack.Common.Save as Save
import Game.LambdaHack.Common.State
import Game.LambdaHack.Server.CommonServer
import Game.LambdaHack.Server.MonadServer
import Game.LambdaHack.Server.ProtocolServer
import Game.LambdaHack.Server.State
data SerState = SerState
{ serState :: !State
, serServer :: !StateServer
, serDict :: !ConnServerDict
, serToSave :: !(Save.ChanSave (State, StateServer))
}
newtype SerImplementation a =
SerImplementation {runSerImplementation :: StateT SerState IO a}
deriving (Monad, Functor, Applicative)
instance MonadStateRead SerImplementation where
getState = SerImplementation $ gets serState
getsState f = SerImplementation $ gets $ f . serState
instance MonadStateWrite SerImplementation where
modifyState f = SerImplementation $ state $ \serS ->
let newSerS = serS {serState = f $ serState serS}
in newSerS `seq` ((), newSerS)
putState s = SerImplementation $ state $ \serS ->
let newSerS = serS {serState = s}
in newSerS `seq` ((), newSerS)
instance MonadServer SerImplementation where
getServer = SerImplementation $ gets serServer
getsServer f = SerImplementation $ gets $ f . serServer
modifyServer f = SerImplementation $ state $ \serS ->
let newSerS = serS {serServer = f $ serServer serS}
in newSerS `seq` ((), newSerS)
putServer s = SerImplementation $ state $ \serS ->
let newSerS = serS {serServer = s}
in newSerS `seq` ((), newSerS)
liftIO = SerImplementation . IO.liftIO
saveChanServer = SerImplementation $ gets serToSave
instance MonadServerReadRequest SerImplementation where
getDict = SerImplementation $ gets serDict
getsDict f = SerImplementation $ gets $ f . serDict
modifyDict f =
SerImplementation $ modify $ \serS -> serS {serDict = f $ serDict serS}
putDict s =
SerImplementation $ modify $ \serS -> serS {serDict = s}
liftIO = SerImplementation . IO.liftIO
instance MonadAtomic SerImplementation where
execAtomic = handleAndBroadcastServer
handleAndBroadcastServer :: (MonadStateWrite m, MonadServerReadRequest m)
=> CmdAtomic -> m ()
handleAndBroadcastServer atomic = do
persOld <- getsServer sper
knowEvents <- getsServer $ sknowEvents . sdebugSer
handleAndBroadcast knowEvents persOld resetFidPerception resetLitInDungeon
sendUpdateAI sendUpdateUI atomic
executorSer :: SerImplementation () -> IO ()
executorSer m =
let saveFile (_, ser) =
fromMaybe "save" (ssavePrefixSer (sdebugSer ser))
<.> saveName
exe serToSave =
evalStateT (runSerImplementation m)
SerState { serState = emptyState
, serServer = emptyStateServer
, serDict = EM.empty
, serToSave
}
in Save.wrapInSaves saveFile exe