module Game.LambdaHack.Client.Action.ActionType
( FunActionCli, ActionCli, executorCli
) where
import Control.Applicative
import Control.Concurrent.STM
import Control.Monad
import qualified Data.EnumMap.Strict as EM
import Data.Maybe
import qualified Data.Text as T
import System.FilePath
import qualified System.Random as R
import Game.LambdaHack.Client.Action.ActionClass
import Game.LambdaHack.Client.Config
import Game.LambdaHack.Client.State
import Game.LambdaHack.Common.Action
import Game.LambdaHack.Common.Animation
import Game.LambdaHack.Common.ClientCmd
import Game.LambdaHack.Common.Msg
import qualified Game.LambdaHack.Common.Save as Save
import Game.LambdaHack.Common.State
type FunActionCli c d a =
SessionUI
-> (ChanServer c d, Save.ChanSave (State, StateClient))
-> (State -> StateClient -> a -> IO ())
-> (R.StdGen -> Msg -> IO ())
-> State
-> StateClient
-> IO ()
newtype ActionCli c d a = ActionCli {runActionCli :: FunActionCli c d a}
returnActionCli :: a -> ActionCli c d a
returnActionCli x = ActionCli (\_c _d k _a s cli -> k s cli x)
bindActionCli :: ActionCli c d a -> (a -> ActionCli c d b) -> ActionCli c d b
bindActionCli m f = ActionCli (\c d k a s cli ->
let next ns ncli x =
runActionCli (f x) c d k a ns ncli
in runActionCli m c d next a s cli)
instance Monad (ActionCli c d) where
return = returnActionCli
(>>=) = bindActionCli
instance Applicative (ActionCli c d) where
pure = return
(<*>) = ap
instance Functor (ActionCli c d) where
fmap f m =
ActionCli (\c d k a s cli ->
runActionCli m c d (\s' cli' ->
k s' cli' . f) a s cli)
instance MonadClientAbort (ActionCli c d) where
tryWith exc m =
ActionCli (\c d k a s cli ->
let runA srandom msg =
runActionCli (exc msg) c d k a s cli {srandom}
in runActionCli m c d k runA s cli)
abortWith msg = ActionCli (\_c _d _k a _s cli -> a (srandom cli) msg)
instance MonadActionRO (ActionCli c d) where
getState = ActionCli (\_c _d k _a s cli -> k s cli s)
getsState = (`fmap` getState)
instance MonadAction (ActionCli c d) where
modifyState f = ActionCli (\_c _d k _a s cli -> k (f s) cli ())
putState = modifyState . const
instance MonadClient (ActionCli c d) where
getClient = ActionCli (\_c _d k _a s cli -> k s cli cli)
getsClient = (`fmap` getClient)
modifyClient f = ActionCli (\_c _d k _a s cli -> k s (f cli) ())
putClient = modifyClient . const
liftIO x = ActionCli (\_c _d k _a s cli -> x >>= k s cli)
saveClient = ActionCli (\_c (_, toSave) k _a s cli -> do
Save.saveToChan toSave (s, cli)
k s cli ())
instance MonadClientUI (ActionCli c d) where
getsSession f = ActionCli (\c _d k _a s cli -> k s cli (f c))
instance MonadClientReadServer c (ActionCli c d) where
readServer =
ActionCli (\_c (ChanServer{..}, _) k _a s cli -> do
ccmd <- atomically . readTQueue $ fromServer
k s cli ccmd)
instance MonadClientWriteServer d (ActionCli c d) where
writeServer scmd =
ActionCli (\_c (ChanServer{..}, _) k _a s cli -> do
atomically . writeTQueue toServer $ scmd
k s cli ())
executorCli :: ActionCli c d ()
-> SessionUI -> State -> StateClient -> ChanServer c d
-> IO ()
executorCli m sess s cli d =
let saveFile (_, cli2) =
configAppDataDir (sconfigUI cli2)
</> fromMaybe "save" (ssavePrefixCli (sdebugCli cli2))
<.> saveName (sside cli2) (sisAI cli2)
exe toSave =
runActionCli m
sess
(d, toSave)
(\_ _ _ -> return ())
(\_ msg -> let err = "unhandled abort for client"
<+> showT (sfactionD s EM.! sside cli)
<+> ":" <+> msg
in fail $ T.unpack err)
s
cli
in Save.wrapInSaves saveFile exe