module Game.LambdaHack.Client.UI.Frontend
(
FrontReq(..), ChanFrontend(..)
, frontendName
, startupF
) where
import Control.Concurrent
import qualified Control.Concurrent.STM as STM
import Control.Exception.Assert.Sugar
import Control.Monad
import qualified Data.Text.IO as T
import System.IO
import Data.Maybe
import qualified Game.LambdaHack.Client.Key as K
import Game.LambdaHack.Client.UI.Animation
import Game.LambdaHack.Client.UI.Frontend.Chosen
import Game.LambdaHack.Common.ClientOptions
data FrontReq =
FrontNormalFrame {frontFrame :: !SingleFrame}
| FrontDelay
| FrontKey {frontKM :: ![K.KM], frontFr :: !SingleFrame}
| FrontSlides { frontClear :: ![K.KM]
, frontSlides :: ![SingleFrame]
, frontFromTop :: !(Maybe Bool) }
| FrontAutoYes !Bool
| FrontFinish
data ChanFrontend = ChanFrontend
{ responseF :: !(STM.TQueue K.KM)
, requestF :: !(STM.TQueue FrontReq)
}
startupF :: DebugModeCli
-> (Maybe (MVar ())
-> (ChanFrontend -> IO ())
-> IO ())
-> IO ()
startupF dbg cont =
(if sfrontendNull dbg then nullStartup
else if sfrontendStd dbg then stdStartup
else chosenStartup) dbg $ \fs -> do
cont (fescMVar fs) (loopFrontend fs)
let debugPrint t = when (sdbgMsgCli dbg) $ do
T.hPutStrLn stderr t
hFlush stderr
debugPrint "Server shuts down"
promptGetKey :: RawFrontend -> [K.KM] -> SingleFrame -> IO K.KM
promptGetKey fs [] frame = fpromptGetKey fs frame
promptGetKey fs keys frame = do
km <- fpromptGetKey fs frame
if km{K.pointer=Nothing} `elem` keys
then return km
else promptGetKey fs keys frame
getConfirmGeneric :: Bool -> RawFrontend -> [K.KM] -> SingleFrame -> IO K.KM
getConfirmGeneric autoYes fs clearKeys frame = do
let DebugModeCli{sdisableAutoYes} = fdebugCli fs
if autoYes && not sdisableAutoYes then do
fdisplay fs (Just frame)
return K.spaceKM
else do
let extraKeys = [K.spaceKM, K.escKM, K.pgupKM, K.pgdnKM]
promptGetKey fs (clearKeys ++ extraKeys) frame
loopFrontend :: RawFrontend -> ChanFrontend -> IO ()
loopFrontend fs ChanFrontend{..} = loop False
where
writeKM :: K.KM -> IO ()
writeKM km = STM.atomically $ STM.writeTQueue responseF km
loop :: Bool -> IO ()
loop autoYes = do
efr <- STM.atomically $ STM.readTQueue requestF
case efr of
FrontNormalFrame{..} -> do
fdisplay fs (Just frontFrame)
loop autoYes
FrontDelay -> do
fdisplay fs Nothing
loop autoYes
FrontKey{..} -> do
km <- promptGetKey fs frontKM frontFr
writeKM km
loop autoYes
FrontSlides{frontSlides = []} -> do
fsyncFrames fs
writeKM K.spaceKM
loop autoYes
FrontSlides{..} -> do
let displayFrs frs srf =
case frs of
[] -> assert `failure` "null slides" `twith` frs
[x] | isNothing frontFromTop -> do
fdisplay fs (Just x)
writeKM K.spaceKM
x : xs -> do
K.KM{..} <- getConfirmGeneric autoYes fs frontClear x
case key of
K.Esc -> writeKM K.escKM
K.PgUp -> case srf of
[] -> displayFrs frs srf
y : ys -> displayFrs (y : frs) ys
K.Space -> case xs of
[] -> writeKM K.escKM
_ -> displayFrs xs (x : srf)
_ -> case xs of
[] -> displayFrs frs srf
_ -> displayFrs xs (x : srf)
case (frontFromTop, reverse frontSlides) of
(Just False, r : rs) -> displayFrs [r] rs
_ -> displayFrs frontSlides []
loop autoYes
FrontAutoYes b ->
loop b
FrontFinish ->
return ()