-- | Screen frames and animations.
module Game.LambdaHack.Client.UI.Frontend.Common
  ( RawFrontend(..)
  , startupBound, createRawFrontend, resetChanKey, saveKMP
  , modifierTranslate
  ) where

import Prelude ()

import Game.LambdaHack.Core.Prelude

import           Control.Concurrent
import qualified Control.Concurrent.STM as STM

import           Game.LambdaHack.Client.UI.Content.Screen
import           Game.LambdaHack.Client.UI.Frame
import           Game.LambdaHack.Client.UI.Key (KMP (..))
import qualified Game.LambdaHack.Client.UI.Key as K
import           Game.LambdaHack.Client.UI.PointUI
import           Game.LambdaHack.Common.Misc

-- | Raw frontend definition. The minimal closed set of values that need
-- to depend on the specifics of the chosen frontend.
data RawFrontend = RawFrontend
  { RawFrontend -> SingleFrame -> IO ()
fdisplay     :: SingleFrame -> IO ()
  , RawFrontend -> IO ()
fshutdown    :: IO ()
  , RawFrontend -> MVar ()
fshowNow     :: MVar ()
  , RawFrontend -> TQueue KMP
fchanKey     :: STM.TQueue KMP
  , RawFrontend -> IO ()
fprintScreen :: IO ()
  , RawFrontend -> ScreenContent
fcoscreen    :: ScreenContent
  }

-- | Start up a frontend on a bound thread.
--
-- In fact, it is started on the very main thread, via a hack, because
-- apparently some SDL backends are not thread-safe
-- (<https://wiki.libsdl.org/FAQDevelopment>;
-- "this should only be run in the thread that initialized the video subsystem,
-- and for extra safety, you should consider only doing those things
-- on the main thread in any case")
-- and at least the newer OS X obtusely requires the main thread, see
-- https://github.com/AllureOfTheStars/Allure/issues/79
-- In case any other exotic architecture requires the main thread,
-- we make the hack the default for all (on frontends that require a bound
-- thread, e.g., SLD2).
startupBound :: (MVar RawFrontend -> IO ()) -> IO RawFrontend
startupBound :: (MVar RawFrontend -> IO ()) -> IO RawFrontend
startupBound MVar RawFrontend -> IO ()
k = do
  MVar RawFrontend
rfMVar <- IO (MVar RawFrontend)
forall a. IO (MVar a)
newEmptyMVar
  MVar (IO ()) -> IO () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (IO ())
workaroundOnMainThreadMVar (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar RawFrontend -> IO ()
k MVar RawFrontend
rfMVar
  -- The following would run frontend on a bound thread, but it's not enough:
  -- a <- asyncBound $ k rfMVar
  -- link a
  MVar RawFrontend -> IO RawFrontend
forall a. MVar a -> IO a
takeMVar MVar RawFrontend
rfMVar

createRawFrontend :: ScreenContent -> (SingleFrame -> IO ()) -> IO ()
                  -> IO RawFrontend
createRawFrontend :: ScreenContent -> (SingleFrame -> IO ()) -> IO () -> IO RawFrontend
createRawFrontend ScreenContent
fcoscreen SingleFrame -> IO ()
fdisplay IO ()
fshutdown = do
  -- Set up the channel for keyboard input.
  TQueue KMP
fchanKey <- STM (TQueue KMP) -> IO (TQueue KMP)
forall a. STM a -> IO a
STM.atomically STM (TQueue KMP)
forall a. STM (TQueue a)
STM.newTQueue
  -- Create the session record.
  MVar ()
fshowNow <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
  RawFrontend -> IO RawFrontend
forall (m :: * -> *) a. Monad m => a -> m a
return (RawFrontend -> IO RawFrontend) -> RawFrontend -> IO RawFrontend
forall a b. (a -> b) -> a -> b
$! RawFrontend :: (SingleFrame -> IO ())
-> IO ()
-> MVar ()
-> TQueue KMP
-> IO ()
-> ScreenContent
-> RawFrontend
RawFrontend
    { SingleFrame -> IO ()
fdisplay :: SingleFrame -> IO ()
fdisplay :: SingleFrame -> IO ()
fdisplay
    , IO ()
fshutdown :: IO ()
fshutdown :: IO ()
fshutdown
    , MVar ()
fshowNow :: MVar ()
fshowNow :: MVar ()
fshowNow
    , TQueue KMP
fchanKey :: TQueue KMP
fchanKey :: TQueue KMP
fchanKey
    , fprintScreen :: IO ()
fprintScreen = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()  -- dummy, except for SDL2
    , ScreenContent
fcoscreen :: ScreenContent
fcoscreen :: ScreenContent
fcoscreen
    }

-- | Empty the keyboard channel.
resetChanKey :: STM.TQueue KMP -> IO ()
resetChanKey :: TQueue KMP -> IO ()
resetChanKey TQueue KMP
fchanKey = do
  Maybe KMP
res <- 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 TQueue KMP
fchanKey
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe KMP -> Bool
forall a. Maybe a -> Bool
isJust Maybe KMP
res) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue KMP -> IO ()
resetChanKey TQueue KMP
fchanKey

saveKMP :: RawFrontend -> K.Modifier -> K.Key -> PointUI -> IO ()
saveKMP :: RawFrontend -> Modifier -> Key -> PointUI -> IO ()
saveKMP !RawFrontend
rf !Modifier
modifier !Key
key !PointUI
kmpPointer = do
  -- Instantly show any frame waiting for display.
  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
  let kmp :: KMP
kmp = KMP :: KM -> PointUI -> KMP
KMP{kmpKeyMod :: KM
kmpKeyMod = KM :: Modifier -> Key -> KM
K.KM{Modifier
Key
key :: Key
modifier :: Modifier
key :: Key
modifier :: Modifier
..}, PointUI
kmpPointer :: PointUI
kmpPointer :: PointUI
kmpPointer}
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Key
key Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
K.DeadKey) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    -- Store the key in the channel.
    STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue KMP -> KMP -> STM ()
forall a. TQueue a -> a -> STM ()
STM.writeTQueue (RawFrontend -> TQueue KMP
fchanKey RawFrontend
rf) KMP
kmp

-- | Translates modifiers to our own encoding.
modifierTranslate :: Bool -> Bool -> Bool -> Bool -> K.Modifier
modifierTranslate :: Bool -> Bool -> Bool -> Bool -> Modifier
modifierTranslate Bool
modCtrl Bool
modShift Bool
modAlt Bool
modMeta
  | (Bool
modAlt Bool -> Bool -> Bool
|| Bool
modMeta) Bool -> Bool -> Bool
&& Bool
modShift = Modifier
K.AltShift
  | Bool
modAlt Bool -> Bool -> Bool
|| Bool
modMeta = Modifier
K.Alt
  | Bool
modCtrl Bool -> Bool -> Bool
&& Bool
modShift = Modifier
K.ControlShift
  | Bool
modCtrl = Modifier
K.Control
  | Bool
modShift = Modifier
K.Shift
  | Bool
otherwise = Modifier
K.NoModifier