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 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}
| FrontRunningFrame {frontFrame :: !SingleFrame}
| FrontDelay
| FrontKey {frontKM :: ![K.KM], frontFr :: !SingleFrame}
| FrontSlides {frontClear :: ![K.KM], frontSlides :: ![SingleFrame]}
| 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 `elem` keys
then return km
else promptGetKey fs keys frame
getConfirmGeneric :: RawFrontend -> [K.KM] -> SingleFrame -> IO (Maybe Bool)
getConfirmGeneric fs clearKeys frame = do
let DebugModeCli{snoMore} = fdebugCli fs
if snoMore then do
fdisplay fs True (Just frame)
return $ Just True
else do
let extraKeys = [K.spaceKM, K.escKM, K.pgupKM, K.pgdnKM]
km <- promptGetKey fs (clearKeys ++ extraKeys) frame
return $! if km == K.escKM
then Nothing
else if km == K.pgupKM
then Just False
else Just True
loopFrontend :: RawFrontend -> ChanFrontend -> IO ()
loopFrontend fs ChanFrontend{..} = loop
where
writeKM :: K.KM -> IO ()
writeKM km = STM.atomically $ STM.writeTQueue responseF km
loop :: IO ()
loop = do
efr <- STM.atomically $ STM.readTQueue requestF
case efr of
FrontNormalFrame{..} -> do
fdisplay fs False (Just frontFrame)
loop
FrontRunningFrame{..} -> do
fdisplay fs True (Just frontFrame)
loop
FrontDelay -> do
fdisplay fs False Nothing
loop
FrontKey{..} -> do
km <- promptGetKey fs frontKM frontFr
writeKM km
loop
FrontSlides{frontSlides = []} -> do
fsyncFrames fs
writeKM K.spaceKM
loop
FrontSlides{..} -> do
let displayFrs frs srf =
case frs of
[] -> assert `failure` "null slides" `twith` frs
[x] -> do
fdisplay fs False (Just x)
writeKM K.spaceKM
x : xs -> do
go <- getConfirmGeneric fs frontClear x
case go of
Nothing -> writeKM K.escKM
Just True -> displayFrs xs (x : srf)
Just False -> case srf of
[] -> displayFrs frs srf
y : ys -> displayFrs (y : frs) ys
displayFrs frontSlides []
loop
FrontFinish ->
return ()