    {-# LANGUAGE GADTs, KindSignatures, RankNTypes #-}
    -- | Display game data on the screen and receive user input
    -- using one of the available raw frontends and derived operations.
    module Game.LambdaHack.Client.UI.Frontend
      ( -- * Connection and initialization
        FrontReq(..), ChanFrontend(..), chanFrontendIO
        -- * Re-exported part of the raw frontend
      , frontendName
    #ifdef EXPOSE_INTERNAL
        -- * Internal operations
      , FrontSetup, getKey, fchanFrontend, display, defaultMaxFps, microInSec
      , frameTimeoutThread, lazyStartup, nullStartup, seqFrame
    #endif
      ) where

    import Prelude ()

    import Game.LambdaHack.Core.Prelude

    import           Control.Concurrent
    import           Control.Concurrent.Async
    import qualified Control.Concurrent.STM as STM
    import           Control.Monad.ST.Strict
    import           Data.Kind (Type)
    import qualified Data.Text.IO as T
    import qualified Data.Vector.Generic as G
    import qualified Data.Vector.Unboxed as U
    import           Data.Word
    import           System.IO (hFlush, stdout)

    import           Game.LambdaHack.Client.UI.Content.Screen
    import           Game.LambdaHack.Client.UI.Frame
    import           Game.LambdaHack.Client.UI.Frontend.Common
    import qualified Game.LambdaHack.Client.UI.Frontend.Teletype as Teletype
    import           Game.LambdaHack.Client.UI.Key (KMP (..))
    import qualified Game.LambdaHack.Client.UI.Key as K
    import           Game.LambdaHack.Common.ClientOptions
    import qualified Game.LambdaHack.Common.PointArray as PointArray
    import qualified Game.LambdaHack.Definition.Color as Color

    #ifdef USE_BROWSER
    import qualified Game.LambdaHack.Client.UI.Frontend.Dom as Chosen
    #else
    import qualified Game.LambdaHack.Client.UI.Frontend.ANSI as ANSI
    import qualified Game.LambdaHack.Client.UI.Frontend.Sdl as Chosen
    #endif

    -- | The instructions sent by clients to the raw frontend, indexed
    -- by the returned value.
    data FrontReq :: Type -> Type where
      -- | Show a frame.
      FrontFrame :: Frame -> FrontReq ()
      -- | Perform an explicit delay of the given length.
      FrontDelay :: Int -> FrontReq ()
      -- | Flush frames, display a frame and ask for a keypress.
      FrontKey :: [K.KM] -> Frame -> FrontReq KMP
      -- | Tell if a keypress is pending.
      FrontPressed :: FrontReq Bool
      -- | Discard a single key in the queue, if any.
      FrontDiscardKey :: FrontReq ()
      -- | Discard all keys in the queue.
      FrontResetKeys :: FrontReq ()
      -- | Shut the frontend down.
      FrontShutdown :: FrontReq ()
      -- | Take screenshot.
      FrontPrintScreen :: FrontReq ()

    -- | Connection channel between a frontend and a client. Frontend acts
    -- as a server, serving keys, etc., when given frames to display.
    newtype ChanFrontend = ChanFrontend (forall a. FrontReq a -> IO a)

    -- | Machinery allocated for an individual frontend at its startup,
    -- unchanged for its lifetime.
    data FrontSetup = FrontSetup
      { FrontSetup -> Async ()
    fasyncTimeout :: Async ()
      , FrontSetup -> MVar Int
    fdelay        :: MVar Int
      }

    -- | Initialize the frontend chosen by the player via client options.
    chanFrontendIO :: ScreenContent -> ClientOptions -> IO ChanFrontend
    chanFrontendIO :: ScreenContent -> ClientOptions -> IO ChanFrontend
    chanFrontendIO ScreenContent
    coscreen ClientOptions
    soptions = do
      let startup :: IO RawFrontend
    startup | ClientOptions -> Bool
    sfrontendNull ClientOptions
    soptions = ScreenContent -> IO RawFrontend
    nullStartup ScreenContent
    coscreen
                  | ClientOptions -> Bool
    sfrontendLazy ClientOptions
    soptions = ScreenContent -> IO RawFrontend
    lazyStartup ScreenContent
    coscreen
    #ifndef REMOVE_TELETYPE
                  | ClientOptions -> Bool
    sfrontendTeletype ClientOptions
    soptions = ScreenContent -> IO RawFrontend
    Teletype.startup ScreenContent
    coscreen
    #endif
    #ifndef USE_BROWSER
                  | ClientOptions -> Bool
    sfrontendANSI ClientOptions
    soptions = ScreenContent -> IO RawFrontend
    ANSI.startup ScreenContent
    coscreen
    #endif
                  | Bool
    otherwise = ScreenContent -> ClientOptions -> IO RawFrontend
    Chosen.startup ScreenContent
    coscreen ClientOptions
    soptions
          maxFps :: Double
    maxFps = Double -> Maybe Double -> Double
    forall a. a -> Maybe a -> a
    fromMaybe Double
    defaultMaxFps (Maybe Double -> Double) -> Maybe Double -> Double
    forall a b. (a -> b) -> a -> b
    $ ClientOptions -> Maybe Double
    smaxFps ClientOptions
    soptions
          delta :: Int
    delta = Int -> Int -> Int
    forall a. Ord a => a -> a -> a
    max Int
    1 (Int -> Int) -> Int -> Int
    forall a b. (a -> b) -> a -> b
    $ Double -> Int
    forall b. Integral b => Double -> b
    forall a b. (RealFrac a, Integral b) => a -> b
    round (Double -> Int) -> Double -> Int
    forall a b. (a -> b) -> a -> b
    $ Int -> Double
    intToDouble Int
    microInSec Double -> Double -> Double
    forall a. Fractional a => a -> a -> a
    / Double -> Double -> Double
    forall a. Ord a => a -> a -> a
    max Double
    0.000001 Double
    maxFps
      rf <- IO RawFrontend
    startup
      when (sdbgMsgCli soptions) $ do
        T.hPutStr stdout "Frontend startup up.\n"
          -- hPutStrLn not atomic enough
        hFlush stdout
      fdelay <- newMVar 0
      fasyncTimeout <- async $ frameTimeoutThread delta fdelay rf
      -- Warning: not linking @fasyncTimeout@, so it'd better not crash.
      let fs = FrontSetup{Async ()
    MVar Int
    fasyncTimeout :: Async ()
    fdelay :: MVar Int
    fdelay :: MVar Int
    fasyncTimeout :: Async ()
    ..}
          chanFrontend = FrontSetup -> RawFrontend -> ChanFrontend
    fchanFrontend FrontSetup
    fs RawFrontend
    rf
      return chanFrontend

    -- Display a frame, wait for any of the specified keys (for any key,
    -- if the list is empty). Repeat if an unexpected key received.
    getKey :: FrontSetup -> RawFrontend -> [K.KM] -> Frame -> IO KMP
    getKey :: FrontSetup -> RawFrontend -> [KM] -> Frame -> IO KMP
    getKey FrontSetup
    fs rf :: RawFrontend
    rf@RawFrontend{TQueue KMP
    fchanKey :: TQueue KMP
    fchanKey :: RawFrontend -> TQueue KMP
    fchanKey} [KM]
    keys Frame
    frame = do
      -- Wait until timeout is up, not to skip the last frame of animation.
      RawFrontend -> Frame -> IO ()
    display RawFrontend
    rf Frame
    frame
      kmp <- STM KMP -> IO KMP
    forall a. STM a -> IO a
    STM.atomically (STM KMP -> IO KMP) -> STM KMP -> IO KMP
    forall a b. (a -> b) -> a -> b
    $ TQueue KMP -> STM KMP
    forall a. TQueue a -> STM a
    STM.readTQueue TQueue KMP
    fchanKey
      if null keys || kmpKeyMod kmp `elem` keys
      then return kmp
      else getKey fs rf keys frame

    -- Read UI requests from the client and send them to the frontend,
    fchanFrontend :: FrontSetup -> RawFrontend -> ChanFrontend
    fchanFrontend :: FrontSetup -> RawFrontend -> ChanFrontend
    fchanFrontend fs :: FrontSetup
    fs@FrontSetup{Async ()
    MVar Int
    fasyncTimeout :: FrontSetup -> Async ()
    fdelay :: FrontSetup -> MVar Int
    fasyncTimeout :: Async ()
    fdelay :: MVar Int
    ..} RawFrontend
    rf =
      (forall a. FrontReq a -> IO a) -> ChanFrontend
    ChanFrontend ((forall a. FrontReq a -> IO a) -> ChanFrontend)
    -> (forall a. FrontReq a -> IO a) -> ChanFrontend
    forall a b. (a -> b) -> a -> b
    $ \case
        FrontFrame Frame
    frontFrame -> RawFrontend -> Frame -> IO ()
    display RawFrontend
    rf Frame
    frontFrame
        FrontDelay Int
    k -> MVar Int -> (Int -> IO Int) -> IO ()
    forall a. MVar a -> (a -> IO a) -> IO ()
    modifyMVar_ MVar Int
    fdelay ((Int -> IO Int) -> IO ()) -> (Int -> IO Int) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Int -> IO Int
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Int -> IO Int) -> (Int -> Int) -> Int -> IO Int
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    k)
        FrontKey [KM]
    frontKeyKeys Frame
    frontKeyFrame ->
          FrontSetup -> RawFrontend -> [KM] -> Frame -> IO KMP
    getKey FrontSetup
    fs RawFrontend
    rf [KM]
    frontKeyKeys Frame
    frontKeyFrame
        FrontReq a
    FrontPressed -> do
          noKeysPending <- STM Bool -> IO Bool
    forall a. STM a -> IO a
    STM.atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
    forall a b. (a -> b) -> a -> b
    $ TQueue KMP -> STM Bool
    forall a. TQueue a -> STM Bool
    STM.isEmptyTQueue (RawFrontend -> TQueue KMP
    fchanKey RawFrontend
    rf)
          return $! not noKeysPending
        FrontReq a
    FrontDiscardKey ->
          IO (Maybe KMP) -> IO ()
    forall (f :: * -> *) a. Functor f => f a -> f ()
    void (IO (Maybe KMP) -> IO ()) -> IO (Maybe KMP) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ STM (Maybe KMP) -> IO (Maybe KMP)
    forall a. STM a -> IO a
    STM.atomically (STM (Maybe KMP) -> IO (Maybe KMP))
    -> STM (Maybe KMP) -> IO (Maybe KMP)
    forall a b. (a -> b) -> a -> b
    $ TQueue KMP -> STM (Maybe KMP)
    forall a. TQueue a -> STM (Maybe a)
    STM.tryReadTQueue (RawFrontend -> TQueue KMP
    fchanKey RawFrontend
    rf)
        FrontReq a
    FrontResetKeys -> TQueue KMP -> IO ()
    resetChanKey (RawFrontend -> TQueue KMP
    fchanKey RawFrontend
    rf)
        FrontReq a
    FrontShutdown -> do
          Async () -> IO ()
    forall a. Async a -> IO ()
    cancel Async ()
    fasyncTimeout
          -- In case the last frame display is pending:
          IO (Maybe ()) -> IO ()
    forall (f :: * -> *) a. Functor f => f a -> f ()
    void (IO (Maybe ()) -> IO ()) -> IO (Maybe ()) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ MVar () -> IO (Maybe ())
    forall a. MVar a -> IO (Maybe a)
    tryTakeMVar (MVar () -> IO (Maybe ())) -> MVar () -> IO (Maybe ())
    forall a b. (a -> b) -> a -> b
    $ RawFrontend -> MVar ()
    fshowNow RawFrontend
    rf
          RawFrontend -> IO ()
    fshutdown RawFrontend
    rf
        FrontReq a
    FrontPrintScreen -> RawFrontend -> IO ()
    fprintScreen RawFrontend
    rf

    display :: RawFrontend -> Frame -> IO ()
    display :: RawFrontend -> Frame -> IO ()
    display rf :: RawFrontend
    rf@RawFrontend{MVar ()
    fshowNow :: RawFrontend -> MVar ()
    fshowNow :: MVar ()
    fshowNow, fcoscreen :: RawFrontend -> ScreenContent
    fcoscreen=ScreenContent{Int
    rwidth :: Int
    rwidth :: ScreenContent -> Int
    rwidth, Int
    rheight :: Int
    rheight :: ScreenContent -> Int
    rheight}}
            ((FrameBase
    m, FrameForall
    upd), (OverlaySpace
    ovProp, OverlaySpace
    ovSquare, OverlaySpace
    ovMono)) = do
      let new :: forall s. ST s (G.Mutable U.Vector s Word32)
          new :: forall s. ST s (Mutable Vector s Word32)
    new = do
            v <- FrameBase -> forall s. ST s (Mutable Vector s Word32)
    unFrameBase FrameBase
    m
            unFrameForall upd v
            return v
          singleArray :: Array AttrCharW32
    singleArray = Int -> Int -> Vector (UnboxRep AttrCharW32) -> Array AttrCharW32
    forall c. Int -> Int -> Vector (UnboxRep c) -> Array c
    PointArray.Array Int
    rwidth Int
    rheight ((forall s. ST s (MVector s Word32)) -> Vector Word32
    forall a. Unbox a => (forall s. ST s (MVector s a)) -> Vector a
    U.create ST s (MVector s Word32)
    ST s (Mutable Vector s Word32)
    forall s. ST s (MVector s Word32)
    forall s. ST s (Mutable Vector s Word32)
    new)
      MVar () -> () -> IO ()
    forall a. MVar a -> a -> IO ()
    putMVar MVar ()
    fshowNow () -- 1. wait for permission to display; 3. ack
      RawFrontend -> SingleFrame -> IO ()
    fdisplay RawFrontend
    rf (SingleFrame -> IO ()) -> SingleFrame -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Array AttrCharW32
    -> OverlaySpace -> OverlaySpace -> OverlaySpace -> SingleFrame
    SingleFrame Array AttrCharW32
    singleArray OverlaySpace
    ovProp OverlaySpace
    ovSquare OverlaySpace
    ovMono

    defaultMaxFps :: Double
    defaultMaxFps :: Double
    defaultMaxFps = Double
    24

    microInSec :: Int
    microInSec :: Int
    microInSec = Int
    1000000

    -- This thread is canceled forcefully, because the @threadDelay@
    -- may be much longer than an acceptable shutdown time.
    frameTimeoutThread :: Int -> MVar Int -> RawFrontend -> IO ()
    frameTimeoutThread :: Int -> MVar Int -> RawFrontend -> IO ()
    frameTimeoutThread Int
    delta MVar Int
    fdelay RawFrontend{IO ()
    MVar ()
    TQueue KMP
    ScreenContent
    SingleFrame -> IO ()
    fchanKey :: RawFrontend -> TQueue KMP
    fshowNow :: RawFrontend -> MVar ()
    fshutdown :: RawFrontend -> IO ()
    fprintScreen :: RawFrontend -> IO ()
    fcoscreen :: RawFrontend -> ScreenContent
    fdisplay :: RawFrontend -> SingleFrame -> IO ()
    fdisplay :: SingleFrame -> IO ()
    fshutdown :: IO ()
    fshowNow :: MVar ()
    fchanKey :: TQueue KMP
    fprintScreen :: IO ()
    fcoscreen :: ScreenContent
    ..} = do
      let loop :: IO ()
    loop = do
            Int -> IO ()
    threadDelay Int
    delta
            let delayLoop :: IO ()
    delayLoop = do
                  delay <- MVar Int -> IO Int
    forall a. MVar a -> IO a
    readMVar MVar Int
    fdelay
                  when (delay > 0) $ do
                    threadDelay $ delta * delay
                    modifyMVar_ fdelay $ return . subtract delay
                    delayLoop
            IO ()
    delayLoop
            let showFrameAndRepeatIfKeys :: IO ()
    showFrameAndRepeatIfKeys = do
                  -- @fshowNow@ is full at this point, unless @saveKM@ emptied it,
                  -- in which case we wait below until @display@ fills it
                  MVar () -> IO ()
    forall a. MVar a -> IO a
    takeMVar MVar ()
    fshowNow  -- 2. permit display
                  -- @fshowNow@ is ever empty only here, unless @saveKM@ empties it
                  MVar () -> IO ()
    forall a. MVar a -> IO a
    readMVar MVar ()
    fshowNow  -- 4. wait for ack before starting delay
                  -- @fshowNow@ is full at this point
                  noKeysPending <- STM Bool -> IO Bool
    forall a. STM a -> IO a
    STM.atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
    forall a b. (a -> b) -> a -> b
    $ TQueue KMP -> STM Bool
    forall a. TQueue a -> STM Bool
    STM.isEmptyTQueue TQueue KMP
    fchanKey
                  unless noKeysPending $ do
                    void $ swapMVar fdelay 0  -- cancel delays lest they accumulate
                    showFrameAndRepeatIfKeys
            IO ()
    showFrameAndRepeatIfKeys
            IO ()
    loop
      IO ()
    loop

    -- | The name of the chosen frontend.
    frontendName :: ClientOptions -> String
    frontendName :: ClientOptions -> String
    frontendName ClientOptions
    soptions =
      if | ClientOptions -> Bool
    sfrontendNull ClientOptions
    soptions -> String
    "null test"
         | ClientOptions -> Bool
    sfrontendLazy ClientOptions
    soptions -> String
    "lazy test"
    #ifndef REMOVE_TELETYPE
         | ClientOptions -> Bool
    sfrontendTeletype ClientOptions
    soptions -> String
    Teletype.frontendName
    #endif
    #ifndef USE_BROWSER
         | ClientOptions -> Bool
    sfrontendANSI ClientOptions
    soptions -> String
    ANSI.frontendName
    #endif
         | Bool
    otherwise -> String
    Chosen.frontendName

    lazyStartup :: ScreenContent -> IO RawFrontend
    lazyStartup :: ScreenContent -> IO RawFrontend
    lazyStartup ScreenContent
    coscreen = ScreenContent -> (SingleFrame -> IO ()) -> IO () -> IO RawFrontend
    createRawFrontend ScreenContent
    coscreen (\SingleFrame
    _ -> () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()) (() -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ())

    nullStartup :: ScreenContent -> IO RawFrontend
    nullStartup :: ScreenContent -> IO RawFrontend
    nullStartup ScreenContent
    coscreen = ScreenContent -> (SingleFrame -> IO ()) -> IO () -> IO RawFrontend
    createRawFrontend ScreenContent
    coscreen SingleFrame -> IO ()
    seqFrame (() -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ())

    seqFrame :: SingleFrame -> IO ()
    seqFrame :: SingleFrame -> IO ()
    seqFrame SingleFrame{OverlaySpace
    Array AttrCharW32
    singleArray :: Array AttrCharW32
    singlePropOverlay :: OverlaySpace
    singleSquareOverlay :: OverlaySpace
    singleMonoOverlay :: OverlaySpace
    singleMonoOverlay :: SingleFrame -> OverlaySpace
    singleSquareOverlay :: SingleFrame -> OverlaySpace
    singlePropOverlay :: SingleFrame -> OverlaySpace
    singleArray :: SingleFrame -> Array AttrCharW32
    ..} =
      let seqAttr :: () -> AttrCharW32 -> ()
    seqAttr () AttrCharW32
    attr = Color -> Text
    Color.colorToRGB (AttrCharW32 -> Color
    Color.fgFromW32 AttrCharW32
    attr)
                            Text -> () -> ()
    forall a b. a -> b -> b
    `seq` AttrCharW32 -> Highlight
    Color.bgFromW32 AttrCharW32
    attr
                            Highlight -> () -> ()
    forall a b. a -> b -> b
    `seq` AttrCharW32 -> Char
    Color.charFromW32 AttrCharW32
    attr Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    ' '
                            Bool -> () -> ()
    forall a b. a -> b -> b
    `seq` ()
          !_Force1 :: ()
    _Force1 = (() -> AttrCharW32 -> ()) -> () -> Array AttrCharW32 -> ()
    forall c a. UnboxRepClass c => (a -> c -> a) -> a -> Array c -> a
    PointArray.foldlA' () -> AttrCharW32 -> ()
    seqAttr () Array AttrCharW32
    singleArray
          !_Force2 :: Int
    _Force2 = OverlaySpace -> Int
    forall a. [a] -> Int
    length OverlaySpace
    singlePropOverlay
          !_Force3 :: Int
    _Force3 = OverlaySpace -> Int
    forall a. [a] -> Int
    length OverlaySpace
    singleSquareOverlay
          !_Force4 :: Int
    _Force4 = OverlaySpace -> Int
    forall a. [a] -> Int
    length OverlaySpace
    singleMonoOverlay
      in () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()