LambdaHack 0.8.0.0 → 0.8.1.0

raw patch · 10 files changed

+444/−438 lines, 10 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• Game/LambdaHack/SampleImplementation/SampleMonadClient.hs +0/−147
• Game/LambdaHack/SampleImplementation/SampleMonadServer.hs +0/−198
• GameDefinition/Implementation/MonadClientImplementation.hs +147/−0
• GameDefinition/Implementation/MonadServerImplementation.hs +199/−0
• GameDefinition/Implementation/TieKnot.hs +77/−0
• GameDefinition/Main.hs +2/−1
• GameDefinition/TieKnot.hs +0/−77
• LambdaHack.cabal +12/−14
• test/test.hs +1/−1

@@ -1,3 +1,9 @@+## [v0.8.1.0](https://github.com/LambdaHack/LambdaHack/compare/v0.8.0.0...v0.8.1.0)++- no player-visible changes+- significantly reduce RAM usage when compiling library+- update and extend CI+ ## [v0.8.0.0, aka 'Explosive dashboard'](https://github.com/LambdaHack/LambdaHack/compare/v0.7.1.0...v0.8.0.0)  - rework greying out menu items and permitting item application and projection

@@ -1,147 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--- | The implementation of our custom game client monads. Just as any other--- component of the library, this implementation can be substituted.-module Game.LambdaHack.SampleImplementation.SampleMonadClient-  ( executorCli-#ifdef EXPOSE_INTERNAL-    -- * Internal operations-  , CliState(..), CliImplementation(..)-#endif-  ) where--import Prelude ()--import Game.LambdaHack.Common.Prelude--import           Control.Concurrent-import qualified Control.Monad.IO.Class as IO-import           Control.Monad.Trans.State.Strict hiding (State)--import           Game.LambdaHack.Atomic (MonadStateWrite (..), putState)-import           Game.LambdaHack.Client-import           Game.LambdaHack.Client.ClientOptions-import           Game.LambdaHack.Client.HandleAtomicM-import           Game.LambdaHack.Client.HandleResponseM-import           Game.LambdaHack.Client.LoopM-import           Game.LambdaHack.Client.MonadClient-import           Game.LambdaHack.Client.State-import           Game.LambdaHack.Client.UI-import           Game.LambdaHack.Client.UI.SessionUI-import           Game.LambdaHack.Common.Faction-import           Game.LambdaHack.Common.Kind-import           Game.LambdaHack.Common.MonadStateRead-import qualified Game.LambdaHack.Common.Save as Save-import           Game.LambdaHack.Common.State-import           Game.LambdaHack.Server (ChanServer (..))--data CliState = CliState-  { cliState   :: State            -- ^ current global state-  , cliClient  :: StateClient      -- ^ current client state-  , cliSession :: Maybe SessionUI  -- ^ UI state, empty for AI clients-  , cliDict    :: ChanServer       -- ^ this client connection information-  , cliToSave  :: Save.ChanSave (StateClient, Maybe SessionUI)-                                   -- ^ connection to the save thread-  }---- | Client state transformation monad.-newtype CliImplementation a = CliImplementation-  { runCliImplementation :: StateT CliState IO a }-  deriving (Monad, Functor, Applicative)--instance MonadStateRead CliImplementation where-  {-# INLINE getsState #-}-  getsState f = CliImplementation $ gets $ f . cliState--instance MonadStateWrite CliImplementation where-  {-# INLINE modifyState #-}-  modifyState f = CliImplementation $ state $ \cliS ->-    let !newCliState = f $ cliState cliS-    in ((), cliS {cliState = newCliState})--instance MonadClient CliImplementation where-  {-# INLINE getsClient #-}-  getsClient   f = CliImplementation $ gets $ f . cliClient-  {-# INLINE modifyClient #-}-  modifyClient f = CliImplementation $ state $ \cliS ->-    let !newCliState = f $ cliClient cliS-    in ((), cliS {cliClient = newCliState})-  liftIO = CliImplementation . IO.liftIO--instance MonadClientSetup CliImplementation where-  saveClient = CliImplementation $ do-    toSave <- gets cliToSave-    cli <- gets cliClient-    msess <- gets cliSession-    IO.liftIO $ Save.saveToChan toSave (cli, msess)-  restartClient  = CliImplementation $ state $ \cliS ->-    case cliSession cliS of-      Just sess ->-        let !newSess = (emptySessionUI (sUIOptions sess))-                         { schanF = schanF sess-                         , sbinding = sbinding sess-                         , shistory = shistory sess-                         , sstart = sstart sess-                         , sgstart = sgstart sess-                         , sallTime = sallTime sess-                         , snframes = snframes sess-                         , sallNframes = sallNframes sess-                         }-        in ((), cliS {cliSession = Just newSess})-      Nothing -> ((), cliS)--instance MonadClientUI CliImplementation where-  {-# INLINE getsSession #-}-  getsSession   f = CliImplementation $ gets $ f . fromJust . cliSession-  {-# INLINE modifySession #-}-  modifySession f = CliImplementation $ state $ \cliS ->-    let !newCliSession = f $ fromJust $ cliSession cliS-    in ((), cliS {cliSession = Just newCliSession})-  liftIO = CliImplementation . IO.liftIO--instance MonadClientReadResponse CliImplementation where-  receiveResponse = CliImplementation $ do-    ChanServer{responseS} <- gets cliDict-    IO.liftIO $ takeMVar responseS--instance MonadClientWriteRequest CliImplementation where-  sendRequestAI scmd = CliImplementation $ do-    ChanServer{requestAIS} <- gets cliDict-    IO.liftIO $ putMVar requestAIS scmd-  sendRequestUI scmd = CliImplementation $ do-    ChanServer{requestUIS} <- gets cliDict-    IO.liftIO $ putMVar (fromJust requestUIS) scmd-  clientHasUI = CliImplementation $ do-    mSession <- gets cliSession-    return $! isJust mSession--instance MonadClientAtomic CliImplementation where-  {-# INLINE execUpdAtomic #-}-  execUpdAtomic _ = return ()  -- handleUpdAtomic, until needed, save resources-    -- Don't catch anything; assume exceptions impossible.-  {-# INLINE execPutState #-}-  execPutState = putState---- | Run the main client loop, with the given arguments and empty--- initial states, in the @IO@ monad.-executorCli :: KeyKind -> UIOptions -> ClientOptions-            -> COps-            -> Bool-            -> FactionId-            -> ChanServer-            -> IO ()-executorCli copsClient sUIOptions clientOptions cops isUI fid cliDict =-  let cliSession | isUI = Just $ emptySessionUI sUIOptions-                 | otherwise = Nothing-      stateToFileName (cli, _) =-        ssavePrefixCli (soptions cli) <> Save.saveNameCli cops (sside cli)-      totalState cliToSave = CliState-        { cliState = updateCOpsAndCachedData (const cops) emptyState-            -- state is empty, so the cached data is left empty and untouched-        , cliClient = emptyStateClient fid-        , cliDict-        , cliToSave-        , cliSession-        }-      m = loopCli copsClient sUIOptions clientOptions-      exe = evalStateT (runCliImplementation m) . totalState-  in Save.wrapInSaves cops stateToFileName exe

@@ -1,198 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--- | The implementation of our custom game server monads. Just as any other--- component of the library, this implementation can be substituted.-module Game.LambdaHack.SampleImplementation.SampleMonadServer-  ( executorSer-#ifdef EXPOSE_INTERNAL-    -- * Internal operations-  , SerState(..), SerImplementation(..)-#endif-  ) where--import Prelude ()--import Game.LambdaHack.Common.Prelude--import           Control.Concurrent-import qualified Control.Exception as Ex-import qualified Control.Monad.IO.Class as IO-import           Control.Monad.Trans.State.Strict hiding (State)-import qualified Data.EnumMap.Strict as EM-import qualified Data.Text.IO as T-import           Options.Applicative (defaultPrefs, execParserPure,-                                      handleParseResult)-import           System.Exit (ExitCode (ExitSuccess))-import           System.FilePath-import           System.IO (hFlush, stdout)--import           Game.LambdaHack.Atomic-import           Game.LambdaHack.Client-import           Game.LambdaHack.Common.File-import           Game.LambdaHack.Common.Kind-import           Game.LambdaHack.Common.Misc-import           Game.LambdaHack.Common.MonadStateRead-import qualified Game.LambdaHack.Common.Save as Save-import           Game.LambdaHack.Common.State-import           Game.LambdaHack.Common.Thread-import           Game.LambdaHack.SampleImplementation.SampleMonadClient (executorCli)-import           Game.LambdaHack.Server-import           Game.LambdaHack.Server.BroadcastAtomic-import           Game.LambdaHack.Server.HandleAtomicM-import           Game.LambdaHack.Server.MonadServer-import           Game.LambdaHack.Server.ProtocolM-import           Game.LambdaHack.Server.ServerOptions-import           Game.LambdaHack.Server.State--data SerState = SerState-  { serState  :: State           -- ^ current global state-  , serServer :: StateServer     -- ^ current server state-  , serDict   :: ConnServerDict  -- ^ client-server connection information-  , serToSave :: Save.ChanSave (State, StateServer)-                                 -- ^ connection to the save thread-  }---- | Server state transformation monad.-newtype SerImplementation a =-    SerImplementation {runSerImplementation :: StateT SerState IO a}-  deriving (Monad, Functor, Applicative)--instance MonadStateRead SerImplementation where-  {-# INLINE getsState #-}-  getsState f = SerImplementation $ gets $ f . serState--instance MonadStateWrite SerImplementation where-  {-# INLINE modifyState #-}-  modifyState f = SerImplementation $ state $ \serS ->-    let !newSerState = f $ serState serS-    in ((), serS {serState = newSerState})--instance MonadServer SerImplementation where-  {-# INLINE getsServer #-}-  getsServer   f = SerImplementation $ gets $ f . serServer-  {-# INLINE modifyServer #-}-  modifyServer f = SerImplementation $ state $ \serS ->-    let !newSerServer = f $ serServer serS-    in ((), serS {serServer = newSerServer})-  chanSaveServer = SerImplementation $ gets serToSave-  liftIO         = SerImplementation . IO.liftIO--instance MonadServerReadRequest SerImplementation where-  {-# INLINE getsDict #-}-  getsDict   f = SerImplementation $ gets $ f . serDict-  {-# INLINE modifyDict #-}-  modifyDict f = SerImplementation $ state $ \serS ->-    let !newSerDict = f $ serDict serS-    in ((), serS {serDict = newSerDict})-  liftIO = SerImplementation . IO.liftIO--instance MonadServerAtomic SerImplementation where-  execUpdAtomic cmd = do-    oldState <- getState-    (ps, atomicBroken, executedOnServer) <- handleCmdAtomicServer cmd-    when executedOnServer $ cmdAtomicSemSer oldState cmd-    handleAndBroadcast ps atomicBroken (UpdAtomic cmd)-  execUpdAtomicSer cmd = SerImplementation $ StateT $ \cliS -> do-    cliSNewOrE <- Ex.try-                  $ execStateT (runSerImplementation $ handleUpdAtomic cmd)-                               cliS-    case cliSNewOrE of-      Left AtomicFail{} -> return (False, cliS)-      Right cliSNew ->-        -- We know @cliSNew@ differs only in @serState@.-        return (True, cliSNew)-  execUpdAtomicFid fid cmd = SerImplementation $ StateT $ \cliS -> do-    -- Don't catch anything; assume exceptions impossible.-    let sFid = sclientStates (serServer cliS) EM.! fid-    cliSNew <- execStateT (runSerImplementation $ handleUpdAtomic cmd)-                          cliS {serState = sFid}-    -- We know @cliSNew@ differs only in @serState@.-    let serServerNew = (serServer cliS)-          {sclientStates = EM.insert fid (serState cliSNew)-                           $ sclientStates $ serServer cliS}-    return $! ((), cliS {serServer = serServerNew})-  execUpdAtomicFidCatch fid cmd = SerImplementation $ StateT $ \cliS -> do-    let sFid = sclientStates (serServer cliS) EM.! fid-    cliSNewOrE <- Ex.try-                  $ execStateT (runSerImplementation $ handleUpdAtomic cmd)-                               cliS {serState = sFid}-    case cliSNewOrE of-      Left AtomicFail{} -> return (False, cliS)-      Right cliSNew -> do-        -- We know @cliSNew@ differs only in @serState@.-        let serServerNew = (serServer cliS)-              {sclientStates = EM.insert fid (serState cliSNew)-                               $ sclientStates $ serServer cliS}-        return $! (True, cliS {serServer = serServerNew})-  execSfxAtomic sfx = do-    ps <- posSfxAtomic sfx-    handleAndBroadcast ps [] (SfxAtomic sfx)-  execSendPer = sendPer---- Don't inline this, to keep GHC hard work inside the library--- for easy access of code analysis tools.--- | Run the main server loop, with the given arguments and empty--- initial states, in the @IO@ monad.-executorSer :: COps -> KeyKind -> ServerOptions -> IO ()-executorSer cops copsClient soptionsNxtCmdline = do-  -- Parse UI client configuration file.-  -- It is reparsed at each start of the game executable.-  let benchmark = sbenchmark $ sclientOptions soptionsNxtCmdline-  -- Fail here, not inside client code, so that savefiles are not removed,-  -- because they are not the source of the failure.-  sUIOptions <- mkUIOptions cops benchmark-  soptionsNxt <- case uCmdline sUIOptions of-    []   -> return soptionsNxtCmdline-    args -> handleParseResult $ execParserPure defaultPrefs serverOptionsPI args-  -- Options for the clients modified with the configuration file.-  -- The client debug inside server debug only holds the client commandline-  -- options and is never updated with config options, etc.-  let clientOptions = applyUIOptions cops sUIOptions-                      $ sclientOptions soptionsNxt-      -- Partially applied main loop of the clients.-      executorClient = executorCli copsClient sUIOptions clientOptions cops-  -- Wire together game content, the main loop of game clients-  -- and the game server loop.-  let stateToFileName (_, ser) =-        ssavePrefixSer (soptions ser) <> Save.saveNameSer cops-      totalState serToSave = SerState-        { serState = updateCOpsAndCachedData (const cops) emptyState-            -- state is empty, so the cached data is left empty and untouched-        , serServer = emptyStateServer-        , serDict = EM.empty-        , serToSave-        }-      m = loopSer soptionsNxt executorClient-      exe = evalStateT (runSerImplementation m) . totalState-      exeWithSaves = Save.wrapInSaves cops stateToFileName exe-      defPrefix = ssavePrefixSer defServerOptions-      bkpOneSave name = do-        dataDir <- appDataDir-        let path bkp = dataDir </> "saves" </> bkp <> name-        b <- doesFileExist (path "")-        when b $ renameFile (path "") (path "bkp.")-      bkpAllSaves = if benchmark then return () else do-        T.hPutStrLn stdout "The game crashed, so savefiles are moved aside."-        bkpOneSave $ defPrefix <> Save.saveNameSer cops-        forM_ [-99..99] $ \n ->-          bkpOneSave $ defPrefix <> Save.saveNameCli cops (toEnum n)-  -- Wait for clients to exit even in case of server crash-  -- (or server and client crash), which gives them time to save-  -- and report their own inconsistencies, if any.-  Ex.handle (\(ex :: Ex.SomeException) -> case Ex.fromException ex of-               Just ExitSuccess ->-                 -- User-forced shutdown, not crash, so the intention is-                 -- to keep old saves and also clients may be not ready to save.-                 Ex.throwIO ex-               _ -> do-                 Ex.uninterruptibleMask_ $ threadDelay 1000000-                   -- let clients report their errors and save-                 when (ssavePrefixSer soptionsNxt == defPrefix) bkpAllSaves-                 hFlush stdout-                 Ex.throwIO ex  -- crash eventually, which kills clients-            )-            exeWithSaves---  T.hPutStrLn stdout "Server exiting, waiting for clients."---  hFlush stdout-  waitForChildren childrenServer  -- no crash, wait for clients indefinitely---  T.hPutStrLn stdout "Server exiting now."---  hFlush stdout

@@ -0,0 +1,147 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- | The implementation of our custom game client monads. Just as any other+-- component of the library, this implementation can be substituted.+module Implementation.MonadClientImplementation+  ( executorCli+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , CliState(..), CliImplementation(..)+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import           Control.Concurrent+import qualified Control.Monad.IO.Class as IO+import           Control.Monad.Trans.State.Strict hiding (State)++import           Game.LambdaHack.Atomic (MonadStateWrite (..), putState)+import           Game.LambdaHack.Client+import           Game.LambdaHack.Client.ClientOptions+import           Game.LambdaHack.Client.HandleAtomicM+import           Game.LambdaHack.Client.HandleResponseM+import           Game.LambdaHack.Client.LoopM+import           Game.LambdaHack.Client.MonadClient+import           Game.LambdaHack.Client.State+import           Game.LambdaHack.Client.UI+import           Game.LambdaHack.Client.UI.SessionUI+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.MonadStateRead+import qualified Game.LambdaHack.Common.Save as Save+import           Game.LambdaHack.Common.State+import           Game.LambdaHack.Server (ChanServer (..))++data CliState = CliState+  { cliState   :: State            -- ^ current global state+  , cliClient  :: StateClient      -- ^ current client state+  , cliSession :: Maybe SessionUI  -- ^ UI state, empty for AI clients+  , cliDict    :: ChanServer       -- ^ this client connection information+  , cliToSave  :: Save.ChanSave (StateClient, Maybe SessionUI)+                                   -- ^ connection to the save thread+  }++-- | Client state transformation monad.+newtype CliImplementation a = CliImplementation+  { runCliImplementation :: StateT CliState IO a }+  deriving (Monad, Functor, Applicative)++instance MonadStateRead CliImplementation where+  {-# INLINE getsState #-}+  getsState f = CliImplementation $ gets $ f . cliState++instance MonadStateWrite CliImplementation where+  {-# INLINE modifyState #-}+  modifyState f = CliImplementation $ state $ \cliS ->+    let !newCliState = f $ cliState cliS+    in ((), cliS {cliState = newCliState})++instance MonadClient CliImplementation where+  {-# INLINE getsClient #-}+  getsClient   f = CliImplementation $ gets $ f . cliClient+  {-# INLINE modifyClient #-}+  modifyClient f = CliImplementation $ state $ \cliS ->+    let !newCliState = f $ cliClient cliS+    in ((), cliS {cliClient = newCliState})+  liftIO = CliImplementation . IO.liftIO++instance MonadClientSetup CliImplementation where+  saveClient = CliImplementation $ do+    toSave <- gets cliToSave+    cli <- gets cliClient+    msess <- gets cliSession+    IO.liftIO $ Save.saveToChan toSave (cli, msess)+  restartClient  = CliImplementation $ state $ \cliS ->+    case cliSession cliS of+      Just sess ->+        let !newSess = (emptySessionUI (sUIOptions sess))+                         { schanF = schanF sess+                         , sbinding = sbinding sess+                         , shistory = shistory sess+                         , sstart = sstart sess+                         , sgstart = sgstart sess+                         , sallTime = sallTime sess+                         , snframes = snframes sess+                         , sallNframes = sallNframes sess+                         }+        in ((), cliS {cliSession = Just newSess})+      Nothing -> ((), cliS)++instance MonadClientUI CliImplementation where+  {-# INLINE getsSession #-}+  getsSession   f = CliImplementation $ gets $ f . fromJust . cliSession+  {-# INLINE modifySession #-}+  modifySession f = CliImplementation $ state $ \cliS ->+    let !newCliSession = f $ fromJust $ cliSession cliS+    in ((), cliS {cliSession = Just newCliSession})+  liftIO = CliImplementation . IO.liftIO++instance MonadClientReadResponse CliImplementation where+  receiveResponse = CliImplementation $ do+    ChanServer{responseS} <- gets cliDict+    IO.liftIO $ takeMVar responseS++instance MonadClientWriteRequest CliImplementation where+  sendRequestAI scmd = CliImplementation $ do+    ChanServer{requestAIS} <- gets cliDict+    IO.liftIO $ putMVar requestAIS scmd+  sendRequestUI scmd = CliImplementation $ do+    ChanServer{requestUIS} <- gets cliDict+    IO.liftIO $ putMVar (fromJust requestUIS) scmd+  clientHasUI = CliImplementation $ do+    mSession <- gets cliSession+    return $! isJust mSession++instance MonadClientAtomic CliImplementation where+  {-# INLINE execUpdAtomic #-}+  execUpdAtomic _ = return ()  -- handleUpdAtomic, until needed, save resources+    -- Don't catch anything; assume exceptions impossible.+  {-# INLINE execPutState #-}+  execPutState = putState++-- | Run the main client loop, with the given arguments and empty+-- initial states, in the @IO@ monad.+executorCli :: KeyKind -> UIOptions -> ClientOptions+            -> COps+            -> Bool+            -> FactionId+            -> ChanServer+            -> IO ()+executorCli copsClient sUIOptions clientOptions cops isUI fid cliDict =+  let cliSession | isUI = Just $ emptySessionUI sUIOptions+                 | otherwise = Nothing+      stateToFileName (cli, _) =+        ssavePrefixCli (soptions cli) <> Save.saveNameCli cops (sside cli)+      totalState cliToSave = CliState+        { cliState = updateCOpsAndCachedData (const cops) emptyState+            -- state is empty, so the cached data is left empty and untouched+        , cliClient = emptyStateClient fid+        , cliDict+        , cliToSave+        , cliSession+        }+      m = loopCli copsClient sUIOptions clientOptions+      exe = evalStateT (runCliImplementation m) . totalState+  in Save.wrapInSaves cops stateToFileName exe

@@ -0,0 +1,199 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- | The implementation of our custom game server monads. Just as any other+-- component of the library, this implementation can be substituted.+module Implementation.MonadServerImplementation+  ( executorSer+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , SerState(..), SerImplementation(..)+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import           Control.Concurrent+import qualified Control.Exception as Ex+import qualified Control.Monad.IO.Class as IO+import           Control.Monad.Trans.State.Strict hiding (State)+import qualified Data.EnumMap.Strict as EM+import qualified Data.Text.IO as T+import           Options.Applicative (defaultPrefs, execParserPure,+                                      handleParseResult)+import           System.Exit (ExitCode (ExitSuccess))+import           System.FilePath+import           System.IO (hFlush, stdout)++import           Game.LambdaHack.Atomic+import           Game.LambdaHack.Client+import           Game.LambdaHack.Common.File+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.MonadStateRead+import qualified Game.LambdaHack.Common.Save as Save+import           Game.LambdaHack.Common.State+import           Game.LambdaHack.Common.Thread+import           Game.LambdaHack.Server+import           Game.LambdaHack.Server.BroadcastAtomic+import           Game.LambdaHack.Server.HandleAtomicM+import           Game.LambdaHack.Server.MonadServer+import           Game.LambdaHack.Server.ProtocolM+import           Game.LambdaHack.Server.ServerOptions+import           Game.LambdaHack.Server.State++import Implementation.MonadClientImplementation (executorCli)++data SerState = SerState+  { serState  :: State           -- ^ current global state+  , serServer :: StateServer     -- ^ current server state+  , serDict   :: ConnServerDict  -- ^ client-server connection information+  , serToSave :: Save.ChanSave (State, StateServer)+                                 -- ^ connection to the save thread+  }++-- | Server state transformation monad.+newtype SerImplementation a =+    SerImplementation {runSerImplementation :: StateT SerState IO a}+  deriving (Monad, Functor, Applicative)++instance MonadStateRead SerImplementation where+  {-# INLINE getsState #-}+  getsState f = SerImplementation $ gets $ f . serState++instance MonadStateWrite SerImplementation where+  {-# INLINE modifyState #-}+  modifyState f = SerImplementation $ state $ \serS ->+    let !newSerState = f $ serState serS+    in ((), serS {serState = newSerState})++instance MonadServer SerImplementation where+  {-# INLINE getsServer #-}+  getsServer   f = SerImplementation $ gets $ f . serServer+  {-# INLINE modifyServer #-}+  modifyServer f = SerImplementation $ state $ \serS ->+    let !newSerServer = f $ serServer serS+    in ((), serS {serServer = newSerServer})+  chanSaveServer = SerImplementation $ gets serToSave+  liftIO         = SerImplementation . IO.liftIO++instance MonadServerReadRequest SerImplementation where+  {-# INLINE getsDict #-}+  getsDict   f = SerImplementation $ gets $ f . serDict+  {-# INLINE modifyDict #-}+  modifyDict f = SerImplementation $ state $ \serS ->+    let !newSerDict = f $ serDict serS+    in ((), serS {serDict = newSerDict})+  liftIO = SerImplementation . IO.liftIO++instance MonadServerAtomic SerImplementation where+  execUpdAtomic cmd = do+    oldState <- getState+    (ps, atomicBroken, executedOnServer) <- handleCmdAtomicServer cmd+    when executedOnServer $ cmdAtomicSemSer oldState cmd+    handleAndBroadcast ps atomicBroken (UpdAtomic cmd)+  execUpdAtomicSer cmd = SerImplementation $ StateT $ \cliS -> do+    cliSNewOrE <- Ex.try+                  $ execStateT (runSerImplementation $ handleUpdAtomic cmd)+                               cliS+    case cliSNewOrE of+      Left AtomicFail{} -> return (False, cliS)+      Right cliSNew ->+        -- We know @cliSNew@ differs only in @serState@.+        return (True, cliSNew)+  execUpdAtomicFid fid cmd = SerImplementation $ StateT $ \cliS -> do+    -- Don't catch anything; assume exceptions impossible.+    let sFid = sclientStates (serServer cliS) EM.! fid+    cliSNew <- execStateT (runSerImplementation $ handleUpdAtomic cmd)+                          cliS {serState = sFid}+    -- We know @cliSNew@ differs only in @serState@.+    let serServerNew = (serServer cliS)+          {sclientStates = EM.insert fid (serState cliSNew)+                           $ sclientStates $ serServer cliS}+    return $! ((), cliS {serServer = serServerNew})+  execUpdAtomicFidCatch fid cmd = SerImplementation $ StateT $ \cliS -> do+    let sFid = sclientStates (serServer cliS) EM.! fid+    cliSNewOrE <- Ex.try+                  $ execStateT (runSerImplementation $ handleUpdAtomic cmd)+                               cliS {serState = sFid}+    case cliSNewOrE of+      Left AtomicFail{} -> return (False, cliS)+      Right cliSNew -> do+        -- We know @cliSNew@ differs only in @serState@.+        let serServerNew = (serServer cliS)+              {sclientStates = EM.insert fid (serState cliSNew)+                               $ sclientStates $ serServer cliS}+        return $! (True, cliS {serServer = serServerNew})+  execSfxAtomic sfx = do+    ps <- posSfxAtomic sfx+    handleAndBroadcast ps [] (SfxAtomic sfx)+  execSendPer = sendPer++-- Don't inline this, to keep GHC hard work inside the library+-- for easy access of code analysis tools.+-- | Run the main server loop, with the given arguments and empty+-- initial states, in the @IO@ monad.+executorSer :: COps -> KeyKind -> ServerOptions -> IO ()+executorSer cops copsClient soptionsNxtCmdline = do+  -- Parse UI client configuration file.+  -- It is reparsed at each start of the game executable.+  let benchmark = sbenchmark $ sclientOptions soptionsNxtCmdline+  -- Fail here, not inside client code, so that savefiles are not removed,+  -- because they are not the source of the failure.+  sUIOptions <- mkUIOptions cops benchmark+  soptionsNxt <- case uCmdline sUIOptions of+    []   -> return soptionsNxtCmdline+    args -> handleParseResult $ execParserPure defaultPrefs serverOptionsPI args+  -- Options for the clients modified with the configuration file.+  -- The client debug inside server debug only holds the client commandline+  -- options and is never updated with config options, etc.+  let clientOptions = applyUIOptions cops sUIOptions+                      $ sclientOptions soptionsNxt+      -- Partially applied main loop of the clients.+      executorClient = executorCli copsClient sUIOptions clientOptions cops+  -- Wire together game content, the main loop of game clients+  -- and the game server loop.+  let stateToFileName (_, ser) =+        ssavePrefixSer (soptions ser) <> Save.saveNameSer cops+      totalState serToSave = SerState+        { serState = updateCOpsAndCachedData (const cops) emptyState+            -- state is empty, so the cached data is left empty and untouched+        , serServer = emptyStateServer+        , serDict = EM.empty+        , serToSave+        }+      m = loopSer soptionsNxt executorClient+      exe = evalStateT (runSerImplementation m) . totalState+      exeWithSaves = Save.wrapInSaves cops stateToFileName exe+      defPrefix = ssavePrefixSer defServerOptions+      bkpOneSave name = do+        dataDir <- appDataDir+        let path bkp = dataDir </> "saves" </> bkp <> name+        b <- doesFileExist (path "")+        when b $ renameFile (path "") (path "bkp.")+      bkpAllSaves = if benchmark then return () else do+        T.hPutStrLn stdout "The game crashed, so savefiles are moved aside."+        bkpOneSave $ defPrefix <> Save.saveNameSer cops+        forM_ [-99..99] $ \n ->+          bkpOneSave $ defPrefix <> Save.saveNameCli cops (toEnum n)+  -- Wait for clients to exit even in case of server crash+  -- (or server and client crash), which gives them time to save+  -- and report their own inconsistencies, if any.+  Ex.handle (\(ex :: Ex.SomeException) -> case Ex.fromException ex of+               Just ExitSuccess ->+                 -- User-forced shutdown, not crash, so the intention is+                 -- to keep old saves and also clients may be not ready to save.+                 Ex.throwIO ex+               _ -> do+                 Ex.uninterruptibleMask_ $ threadDelay 1000000+                   -- let clients report their errors and save+                 when (ssavePrefixSer soptionsNxt == defPrefix) bkpAllSaves+                 hFlush stdout+                 Ex.throwIO ex  -- crash eventually, which kills clients+            )+            exeWithSaves+--  T.hPutStrLn stdout "Server exiting, waiting for clients."+--  hFlush stdout+  waitForChildren childrenServer  -- no crash, wait for clients indefinitely+--  T.hPutStrLn stdout "Server exiting now."+--  hFlush stdout

@@ -0,0 +1,77 @@+-- | Here the knot of engine code pieces, frontend and the game-specific+-- content definitions is tied, resulting in an executable game.+module Implementation.TieKnot+  ( tieKnot+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import qualified System.Random as R++import           Game.LambdaHack.Common.Kind+import qualified Game.LambdaHack.Common.Tile as Tile+import qualified Game.LambdaHack.Content.CaveKind as CK+import qualified Game.LambdaHack.Content.ItemKind as IK+import qualified Game.LambdaHack.Content.ModeKind as MK+import qualified Game.LambdaHack.Content.PlaceKind as PK+import qualified Game.LambdaHack.Content.RuleKind as RK+import qualified Game.LambdaHack.Content.TileKind as TK+import           Game.LambdaHack.Server++import qualified Client.UI.Content.KeyKind as Content.KeyKind+import qualified Content.CaveKind+import qualified Content.ItemKind+import qualified Content.ModeKind+import qualified Content.PlaceKind+import qualified Content.RuleKind+import qualified Content.TileKind+import           Implementation.MonadServerImplementation (executorSer)++-- | Tie the LambdaHack engine client, server and frontend code+-- with the game-specific content definitions, and run the game.+--+-- The custom monad types to be used are determined by the 'executorSer'+-- call, which in turn calls 'executorCli'. If other functions are used+-- in their place- the types are different and so the whole pattern+-- of computation differs. Which of the frontends is run inside the UI client+-- depends on the flags supplied when compiling the engine library.+-- Similarly for the choice of native vs JS builds.+tieKnot :: ServerOptions -> IO ()+tieKnot options@ServerOptions{sallClear, sboostRandomItem, sdungeonRng} = do+  -- This setup ensures the boosting option doesn't affect generating initial+  -- RNG for dungeon, etc., and also, that setting dungeon RNG on commandline+  -- equal to what was generated last time, ensures the same item boost.+  initialGen <- maybe R.getStdGen return sdungeonRng+  let soptionsNxt = options {sdungeonRng = Just initialGen}+      boostedItems = IK.boostItemKindList initialGen Content.ItemKind.items+      coitem = IK.makeData $+        if sboostRandomItem+        then boostedItems ++ Content.ItemKind.otherItemContent+        else Content.ItemKind.content+      coItemSpeedup = IK.speedupItem coitem+      cotile = TK.makeData coitem Content.TileKind.content+      coTileSpeedup = Tile.speedupTile sallClear cotile+      coplace = PK.makeData cotile Content.PlaceKind.content+      cocave = CK.makeData coitem coplace cotile Content.CaveKind.content+      -- Common content operations, created from content definitions.+      -- Evaluated fully to discover errors ASAP and to free memory.+      -- Fail here, not inside server code, so that savefiles are not removed,+      -- because they are not the source of the failure.+      !cops = COps+        { cocave+        , coitem+        , comode  = MK.makeData cocave coitem Content.ModeKind.content+        , coplace+        , corule  = RK.makeData Content.RuleKind.content+        , cotile+        , coItemSpeedup+        , coTileSpeedup+        }+      -- Client content operations containing default keypresses+      -- and command descriptions.+      !copsClient = Content.KeyKind.standardKeys+  -- Wire together game content, the main loops of game clients+  -- and the game server loop.+  executorSer cops copsClient soptionsNxt

@@ -23,7 +23,8 @@ #endif  import Game.LambdaHack.Server (serverOptionsPI)-import TieKnot++import Implementation.TieKnot  -- | Parse commandline options, tie the engine, content and clients knot, -- run the game and handle exit.

@@ -1,77 +0,0 @@--- | Here the knot of engine code pieces, frontend and the game-specific--- content definitions is tied, resulting in an executable game.-module TieKnot-  ( tieKnot-  ) where--import Prelude ()--import Game.LambdaHack.Common.Prelude--import qualified System.Random as R--import           Game.LambdaHack.Common.Kind-import qualified Game.LambdaHack.Common.Tile as Tile-import qualified Game.LambdaHack.Content.CaveKind as CK-import qualified Game.LambdaHack.Content.ItemKind as IK-import qualified Game.LambdaHack.Content.ModeKind as MK-import qualified Game.LambdaHack.Content.PlaceKind as PK-import qualified Game.LambdaHack.Content.RuleKind as RK-import qualified Game.LambdaHack.Content.TileKind as TK-import           Game.LambdaHack.SampleImplementation.SampleMonadServer (executorSer)-import           Game.LambdaHack.Server--import qualified Client.UI.Content.KeyKind as Content.KeyKind-import qualified Content.CaveKind-import qualified Content.ItemKind-import qualified Content.ModeKind-import qualified Content.PlaceKind-import qualified Content.RuleKind-import qualified Content.TileKind---- | Tie the LambdaHack engine client, server and frontend code--- with the game-specific content definitions, and run the game.------ The custom monad types to be used are determined by the 'executorSer'--- call, which in turn calls 'executorCli'. If other functions are used--- in their place- the types are different and so the whole pattern--- of computation differs. Which of the frontends is run inside the UI client--- depends on the flags supplied when compiling the engine library.--- Similarly for the choice of native vs JS builds.-tieKnot :: ServerOptions -> IO ()-tieKnot options@ServerOptions{sallClear, sboostRandomItem, sdungeonRng} = do-  -- This setup ensures the boosting option doesn't affect generating initial-  -- RNG for dungeon, etc., and also, that setting dungeon RNG on commandline-  -- equal to what was generated last time, ensures the same item boost.-  initialGen <- maybe R.getStdGen return sdungeonRng-  let soptionsNxt = options {sdungeonRng = Just initialGen}-      boostedItems = IK.boostItemKindList initialGen Content.ItemKind.items-      coitem = IK.makeData $-        if sboostRandomItem-        then boostedItems ++ Content.ItemKind.otherItemContent-        else Content.ItemKind.content-      coItemSpeedup = IK.speedupItem coitem-      cotile = TK.makeData coitem Content.TileKind.content-      coTileSpeedup = Tile.speedupTile sallClear cotile-      coplace = PK.makeData cotile Content.PlaceKind.content-      cocave = CK.makeData coitem coplace cotile Content.CaveKind.content-      -- Common content operations, created from content definitions.-      -- Evaluated fully to discover errors ASAP and to free memory.-      -- Fail here, not inside server code, so that savefiles are not removed,-      -- because they are not the source of the failure.-      !cops = COps-        { cocave-        , coitem-        , comode  = MK.makeData cocave coitem Content.ModeKind.content-        , coplace-        , corule  = RK.makeData Content.RuleKind.content-        , cotile-        , coItemSpeedup-        , coTileSpeedup-        }-      -- Client content operations containing default keypresses-      -- and command descriptions.-      !copsClient = Content.KeyKind.standardKeys-  -- Wire together game content, the main loops of game clients-  -- and the game server loop.-  executorSer cops copsClient soptionsNxt

@@ -5,7 +5,7 @@ -- PVP summary:+-+------- breaking API changes --             | | +----- minor or non-breaking API additions --             | | | +--- code changes with no API change-version:       0.8.0.0+version:       0.8.1.0 synopsis:      A game engine library for tactical squad ASCII roguelike dungeon crawlers description:   LambdaHack is a Haskell game engine library for ASCII roguelike                games of arbitrary theme, size and complexity, with optional@@ -45,7 +45,7 @@ bug-reports:   http://github.com/LambdaHack/LambdaHack/issues license:       BSD3 license-file:  LICENSE-tested-with:   GHC==8.0.2, GHC==8.2.2, GHC==8.4.2+tested-with:   GHC==8.0.2, GHC==8.2.2, GHC==8.4.3 data-files:    GameDefinition/config.ui.default,                GameDefinition/fonts/16x16x.fon,                GameDefinition/fonts/8x8xb.fon,@@ -199,8 +199,6 @@                       Game.LambdaHack.Content.PlaceKind                       Game.LambdaHack.Content.RuleKind                       Game.LambdaHack.Content.TileKind-                      Game.LambdaHack.SampleImplementation.SampleMonadClient-                      Game.LambdaHack.SampleImplementation.SampleMonadServer                       Game.LambdaHack.Server                       Game.LambdaHack.Server.BroadcastAtomic                       Game.LambdaHack.Server.Commandline@@ -230,7 +228,7 @@   other-modules:      Paths_LambdaHack   build-depends:                       assert-failure >= 0.1.2 && < 0.2,-                      async      >= 2,+                      async      >= 2.2.1,                       base       >= 4.9 && < 99,                       base-compat >= 0.8.0,                       binary     >= 0.8,@@ -323,13 +321,15 @@                       Content.PlaceKind,                       Content.RuleKind,                       Content.TileKind,-                      TieKnot,+                      Implementation.MonadClientImplementation,+                      Implementation.MonadServerImplementation,+                      Implementation.TieKnot,                       Paths_LambdaHack   build-depends:      LambdaHack,                       template-haskell >= 2.6,                        assert-failure >= 0.1.2 && < 0.2,-                      async      >= 2,+                      async      >= 2.2.1,                       base       >= 4.9 && < 99,                       base-compat >= 0.8.0,                       binary     >= 0.8,@@ -375,8 +375,6 @@     cpp-options:      -DUSE_JSFILE   } else {     build-depends:    zlib >= 0.5.3.1---    ghc-options:      -with-rtsopts=-K1K--- TODO: get back to -K1K when I can use pretty-1.1.3.4 (TH depends on an old one), that is, when I can drop GHC 8.0.2 and older and also when I fix some other stack leaks   }  test-suite test@@ -396,13 +394,15 @@                       Content.PlaceKind,                       Content.RuleKind,                       Content.TileKind,-                      TieKnot,+                      Implementation.MonadClientImplementation,+                      Implementation.MonadServerImplementation,+                      Implementation.TieKnot,                       Paths_LambdaHack   build-depends:      LambdaHack,                       template-haskell >= 2.6,                        assert-failure >= 0.1.2 && < 0.2,-                      async      >= 2,+                      async      >= 2.2.1,                       base       >= 4.9 && < 99,                       base-compat >= 0.8.0,                       binary     >= 0.8,@@ -431,7 +431,7 @@   default-language:   Haskell2010   default-extensions: MonoLocalBinds, ScopedTypeVariables, OverloadedStrings                       BangPatterns, RecordWildCards, NamedFieldPuns, MultiWayIf,-                      LambdaCase, StrictData+                      LambdaCase, StrictData, CPP   other-extensions:   TemplateHaskell   ghc-options:        -Wall -Wcompat -Worphans -Wincomplete-uni-patterns -Wincomplete-record-updates -Wimplicit-prelude -Wmissing-home-modules -Widentities -Wredundant-constraints   ghc-options:        -fno-ignore-asserts -fexpose-all-unfoldings -fspecialise-aggressively@@ -446,6 +446,4 @@     cpp-options:      -DGHCJS_BUSY_YIELD=50   } else {     build-depends:    zlib >= 0.5.3.1---    ghc-options:      -with-rtsopts=-K1K--- TODO: get back to -K1K when I can use pretty-1.1.3.4 (TH depends on an old one), that is, when I can drop GHC 8.0.2 and older and also when I fix some other stack leaks   }

@@ -5,7 +5,7 @@ import Game.LambdaHack.Common.Prelude import Game.LambdaHack.Server -import TieKnot+import Implementation.TieKnot  main :: IO () main = do