{-|
Module      : Monomer.Main.Core
Copyright   : (c) 2018 Francisco Vallarino
License     : BSD-3-Clause (see the LICENSE file)
Maintainer  : fjvallarino@gmail.com
Stability   : experimental
Portability : non-portable

Core glue for running an application.
-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE Strict #-}

module Monomer.Main.Core (
  AppEventResponse(..),
  AppEventHandler(..),
  AppUIBuilder(..),
  startApp
) where

import Control.Concurrent (MVar, forkIO, forkOS, newMVar, threadDelay)
import Control.Concurrent.STM.TChan (TChan, newTChanIO, readTChan, writeTChan)
import Control.Lens ((&), (^.), (.=), (.~), use)
import Control.Monad (unless, void, when)
import Control.Monad.Catch
import Control.Monad.Extra
import Control.Monad.State
import Control.Monad.STM (atomically)
import Data.Default
import Data.Maybe
import Data.Map (Map)
import Data.List (foldl')
import Data.Text (Text)

import qualified Data.Map as Map
import qualified Graphics.Rendering.OpenGL as GL
import qualified SDL
import qualified Data.Sequence as Seq

import Monomer.Core
import Monomer.Core.Combinators
import Monomer.Event
import Monomer.Main.Handlers
import Monomer.Main.Platform
import Monomer.Main.Types
import Monomer.Main.Util
import Monomer.Main.WidgetTask
import Monomer.Graphics
import Monomer.Helper (catchAny)
import Monomer.Widgets.Composite

import qualified Monomer.Lens as L

{-|
Type of response an App event handler can return, with __s__ being the model and
__e__ the user's event type.
-}
type AppEventResponse s e = EventResponse s e s ()

-- | Type of an App event handler.
type AppEventHandler s e
  = WidgetEnv s e            -- ^ The widget environment.
  -> WidgetNode s e          -- ^ The root node of the application.
  -> s                       -- ^ The application's model.
  -> e                       -- ^ The event to handle.
  -> [AppEventResponse s e]  -- ^ The list of requested actions.

-- | Type of the function responsible of creating the App UI.
type AppUIBuilder s e = UIBuilder s e

data MainLoopArgs sp e ep = MainLoopArgs {
  MainLoopArgs sp e ep -> Text
_mlOS :: Text,
  MainLoopArgs sp e ep -> Maybe Renderer
_mlRenderer :: Maybe Renderer,
  MainLoopArgs sp e ep -> Theme
_mlTheme :: Theme,
  MainLoopArgs sp e ep -> Int
_mlAppStartTs :: Int,
  MainLoopArgs sp e ep -> Int
_mlMaxFps :: Int,
  MainLoopArgs sp e ep -> Int
_mlLatestRenderTs :: Int,
  MainLoopArgs sp e ep -> Int
_mlFrameStartTs :: Int,
  MainLoopArgs sp e ep -> Int
_mlFrameAccumTs :: Int,
  MainLoopArgs sp e ep -> Int
_mlFrameCount :: Int,
  MainLoopArgs sp e ep -> [e]
_mlExitEvents :: [e],
  MainLoopArgs sp e ep -> WidgetNode sp ep
_mlWidgetRoot :: WidgetNode sp ep,
  MainLoopArgs sp e ep -> MVar (Map Text WidgetShared)
_mlWidgetShared :: MVar (Map Text WidgetShared),
  MainLoopArgs sp e ep -> TChan (RenderMsg sp ep)
_mlChannel :: TChan (RenderMsg sp ep)
}

data RenderState s e = RenderState {
  RenderState s e -> Double
_rstDpr :: Double,
  RenderState s e -> WidgetEnv s e
_rstWidgetEnv :: WidgetEnv s e,
  RenderState s e -> WidgetNode s e
_rstRootNode :: WidgetNode s e
}

{-|
Runs an application, creating the UI with the provided function and initial
model, handling future events with the event handler.

Control will not be returned until the UI exits. This needs to be ran in the
main thread if using macOS.
-}
startApp
  :: (Eq s, WidgetModel s, WidgetEvent e)
  => s                    -- ^ The initial model.
  -> AppEventHandler s e  -- ^ The event handler.
  -> AppUIBuilder s e     -- ^ The UI builder.
  -> [AppConfig e]        -- ^ The application config.
  -> IO ()                -- ^ The application action.
startApp :: s
-> AppEventHandler s e
-> AppUIBuilder s e
-> [AppConfig e]
-> IO ()
startApp s
model AppEventHandler s e
eventHandler AppUIBuilder s e
uiBuilder [AppConfig e]
configs = do
  (Window
window, Double
dpr, Double
epr, GLContext
glCtx) <- AppConfig e -> IO (Window, Double, Double, GLContext)
forall e. AppConfig e -> IO (Window, Double, Double, GLContext)
initSDLWindow AppConfig e
config
  Size
vpSize <- Window -> Double -> IO Size
getViewportSize Window
window Double
dpr
  TChan (RenderMsg s ())
channel <- IO (TChan (RenderMsg s ()))
forall a. IO (TChan a)
newTChanIO

  let monomerCtx :: MonomerCtx s ()
monomerCtx = Window
-> TChan (RenderMsg s ())
-> Size
-> Double
-> Double
-> s
-> MonomerCtx s ()
forall s e.
Window
-> TChan (RenderMsg s e)
-> Size
-> Double
-> Double
-> s
-> MonomerCtx s e
initMonomerCtx Window
window TChan (RenderMsg s ())
channel Size
vpSize Double
dpr Double
epr s
model

  StateT (MonomerCtx s ()) IO ()
-> MonomerCtx s () -> IO ((), MonomerCtx s ())
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (Window
-> GLContext
-> TChan (RenderMsg s ())
-> WidgetNode s ()
-> AppConfig e
-> StateT (MonomerCtx s ()) IO ()
forall sp ep (m :: * -> *) e.
(MonomerM sp ep m, Eq sp, WidgetEvent e, WidgetEvent ep) =>
Window
-> GLContext
-> TChan (RenderMsg sp ep)
-> WidgetNode sp ep
-> AppConfig e
-> m ()
runAppLoop Window
window GLContext
glCtx TChan (RenderMsg s ())
channel WidgetNode s ()
appWidget AppConfig e
config) MonomerCtx s ()
monomerCtx
  Window -> IO ()
detroySDLWindow Window
window
  where
    config :: AppConfig e
config = [AppConfig e] -> AppConfig e
forall a. Monoid a => [a] -> a
mconcat [AppConfig e]
configs
    compCfgs :: [CompositeCfg s e s ()]
compCfgs
      = (e -> CompositeCfg s e s ()
forall t e. CmbOnInit t e => e -> t
onInit (e -> CompositeCfg s e s ()) -> [e] -> [CompositeCfg s e s ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AppConfig e -> [e]
forall e. AppConfig e -> [e]
_apcInitEvent AppConfig e
config)
      [CompositeCfg s e s ()]
-> [CompositeCfg s e s ()] -> [CompositeCfg s e s ()]
forall a. [a] -> [a] -> [a]
++ (e -> CompositeCfg s e s ()
forall t e. CmbOnDispose t e => e -> t
onDispose (e -> CompositeCfg s e s ()) -> [e] -> [CompositeCfg s e s ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AppConfig e -> [e]
forall e. AppConfig e -> [e]
_apcDisposeEvent AppConfig e
config)
      [CompositeCfg s e s ()]
-> [CompositeCfg s e s ()] -> [CompositeCfg s e s ()]
forall a. [a] -> [a] -> [a]
++ ((Rect -> e) -> CompositeCfg s e s ()
forall t e a. CmbOnResize t e a => (a -> e) -> t
onResize ((Rect -> e) -> CompositeCfg s e s ())
-> [Rect -> e] -> [CompositeCfg s e s ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AppConfig e -> [Rect -> e]
forall e. AppConfig e -> [Rect -> e]
_apcResizeEvent AppConfig e
config)
    appWidget :: WidgetNode s ()
appWidget = WidgetType
-> ALens' s s
-> AppUIBuilder s e
-> AppEventHandler s e
-> [CompositeCfg s e s ()]
-> WidgetNode s ()
forall s e ep sp.
(CompositeModel s, CompositeEvent e, CompositeEvent ep,
 CompParentModel sp) =>
WidgetType
-> ALens' sp s
-> UIBuilder s e
-> EventHandler s e sp ep
-> [CompositeCfg s e sp ep]
-> WidgetNode sp ep
composite_ WidgetType
"app" ALens' s s
forall a. a -> a
id AppUIBuilder s e
uiBuilder AppEventHandler s e
eventHandler [CompositeCfg s e s ()]
compCfgs

runAppLoop
  :: (MonomerM sp ep m, Eq sp, WidgetEvent e, WidgetEvent ep)
  => SDL.Window
  -> SDL.GLContext
  -> TChan (RenderMsg sp ep)
  -> WidgetNode sp ep
  -> AppConfig e
  -> m ()
runAppLoop :: Window
-> GLContext
-> TChan (RenderMsg sp ep)
-> WidgetNode sp ep
-> AppConfig e
-> m ()
runAppLoop Window
window GLContext
glCtx TChan (RenderMsg sp ep)
channel WidgetNode sp ep
widgetRoot AppConfig e
config = do
  Double
dpr <- Getting Double (MonomerCtx sp ep) Double -> m Double
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Double (MonomerCtx sp ep) Double
forall s a. HasDpr s a => Lens' s a
L.dpr
  Size
winSize <- Getting Size (MonomerCtx sp ep) Size -> m Size
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Size (MonomerCtx sp ep) Size
forall s a. HasWindowSize s a => Lens' s a
L.windowSize

  let useRenderThread :: Bool
useRenderThread = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
True (AppConfig e -> Maybe Bool
forall e. AppConfig e -> Maybe Bool
_apcUseRenderThread AppConfig e
config)
  let maxFps :: Int
maxFps = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
60 (AppConfig e -> Maybe Int
forall e. AppConfig e -> Maybe Int
_apcMaxFps AppConfig e
config)
  let fonts :: [FontDef]
fonts = AppConfig e -> [FontDef]
forall e. AppConfig e -> [FontDef]
_apcFonts AppConfig e
config
  let theme :: Theme
theme = Theme -> Maybe Theme -> Theme
forall a. a -> Maybe a -> a
fromMaybe Theme
forall a. Default a => a
def (AppConfig e -> Maybe Theme
forall e. AppConfig e -> Maybe Theme
_apcTheme AppConfig e
config)
  let exitEvents :: [e]
exitEvents = AppConfig e -> [e]
forall e. AppConfig e -> [e]
_apcExitEvent AppConfig e
config
  let mainBtn :: Button
mainBtn = Button -> Maybe Button -> Button
forall a. a -> Maybe a -> a
fromMaybe Button
BtnLeft (AppConfig e -> Maybe Button
forall e. AppConfig e -> Maybe Button
_apcMainButton AppConfig e
config)
  let contextBtn :: Button
contextBtn = Button -> Maybe Button -> Button
forall a. a -> Maybe a -> a
fromMaybe Button
BtnRight (AppConfig e -> Maybe Button
forall e. AppConfig e -> Maybe Button
_apcContextButton AppConfig e
config)

  Int
startTs <- (Word32 -> Int) -> m Word32 -> m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral m Word32
forall (m :: * -> *). MonadIO m => m Word32
SDL.ticks
  sp
model <- Getting sp (MonomerCtx sp ep) sp -> m sp
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting sp (MonomerCtx sp ep) sp
forall s a. HasMainModel s a => Lens' s a
L.mainModel
  Text
os <- IO Text -> m Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Text
getPlatform
  MVar (Map Text WidgetShared)
widgetSharedMVar <- IO (MVar (Map Text WidgetShared))
-> m (MVar (Map Text WidgetShared))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MVar (Map Text WidgetShared))
 -> m (MVar (Map Text WidgetShared)))
-> IO (MVar (Map Text WidgetShared))
-> m (MVar (Map Text WidgetShared))
forall a b. (a -> b) -> a -> b
$ Map Text WidgetShared -> IO (MVar (Map Text WidgetShared))
forall a. a -> IO (MVar a)
newMVar Map Text WidgetShared
forall k a. Map k a
Map.empty
  Maybe Renderer
renderer <- if Bool
useRenderThread
    then Maybe Renderer -> m (Maybe Renderer)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Renderer
forall a. Maybe a
Nothing
    else IO (Maybe Renderer) -> m (Maybe Renderer)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Renderer) -> m (Maybe Renderer))
-> IO (Maybe Renderer) -> m (Maybe Renderer)
forall a b. (a -> b) -> a -> b
$ Renderer -> Maybe Renderer
forall a. a -> Maybe a
Just (Renderer -> Maybe Renderer) -> IO Renderer -> IO (Maybe Renderer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FontDef] -> Double -> IO Renderer
makeRenderer [FontDef]
fonts Double
dpr
  FontManager
fontManager <- IO FontManager -> m FontManager
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FontManager -> m FontManager)
-> IO FontManager -> m FontManager
forall a b. (a -> b) -> a -> b
$ [FontDef] -> Double -> IO FontManager
makeFontManager [FontDef]
fonts Double
dpr

  let wenv :: WidgetEnv sp e
wenv = WidgetEnv :: forall s e.
Text
-> Double
-> FontManager
-> (Path -> Maybe WidgetNodeInfo)
-> Button
-> Button
-> Theme
-> Size
-> MVar (Map Text WidgetShared)
-> WidgetKeyMap s e
-> Maybe Path
-> Path
-> Maybe Path
-> Maybe (Path, WidgetDragMsg)
-> Maybe (Path, Point)
-> Maybe (Path, CursorIcon)
-> s
-> InputStatus
-> Int
-> Bool
-> (Point -> Bool)
-> LayoutDirection
-> Rect
-> Point
-> WidgetEnv s e
WidgetEnv {
    _weOs :: Text
_weOs = Text
os,
    _weDpr :: Double
_weDpr = Double
dpr,
    _weFontManager :: FontManager
_weFontManager = FontManager
fontManager,
    _weFindByPath :: Path -> Maybe WidgetNodeInfo
_weFindByPath = Maybe WidgetNodeInfo -> Path -> Maybe WidgetNodeInfo
forall a b. a -> b -> a
const Maybe WidgetNodeInfo
forall a. Maybe a
Nothing,
    _weMainButton :: Button
_weMainButton = Button
mainBtn,
    _weContextButton :: Button
_weContextButton = Button
contextBtn,
    _weTheme :: Theme
_weTheme = Theme
theme,
    _weWindowSize :: Size
_weWindowSize = Size
winSize,
    _weWidgetShared :: MVar (Map Text WidgetShared)
_weWidgetShared = MVar (Map Text WidgetShared)
widgetSharedMVar,
    _weWidgetKeyMap :: WidgetKeyMap sp e
_weWidgetKeyMap = WidgetKeyMap sp e
forall k a. Map k a
Map.empty,
    _weCursor :: Maybe (Path, CursorIcon)
_weCursor = Maybe (Path, CursorIcon)
forall a. Maybe a
Nothing,
    _weHoveredPath :: Maybe Path
_weHoveredPath = Maybe Path
forall a. Maybe a
Nothing,
    _weFocusedPath :: Path
_weFocusedPath = Path
emptyPath,
    _weOverlayPath :: Maybe Path
_weOverlayPath = Maybe Path
forall a. Maybe a
Nothing,
    _weDragStatus :: Maybe (Path, WidgetDragMsg)
_weDragStatus = Maybe (Path, WidgetDragMsg)
forall a. Maybe a
Nothing,
    _weMainBtnPress :: Maybe (Path, Point)
_weMainBtnPress = Maybe (Path, Point)
forall a. Maybe a
Nothing,
    _weModel :: sp
_weModel = sp
model,
    _weInputStatus :: InputStatus
_weInputStatus = InputStatus
forall a. Default a => a
def,
    _weTimestamp :: Int
_weTimestamp = Int
startTs,
    _weThemeChanged :: Bool
_weThemeChanged = Bool
False,
    _weInTopLayer :: Point -> Bool
_weInTopLayer = Bool -> Point -> Bool
forall a b. a -> b -> a
const Bool
True,
    _weLayoutDirection :: LayoutDirection
_weLayoutDirection = LayoutDirection
LayoutNone,
    _weViewport :: Rect
_weViewport = Double -> Double -> Double -> Double -> Rect
Rect Double
0 Double
0 (Size
winSize Size -> Getting Double Size Double -> Double
forall s a. s -> Getting a s a -> a
^. Getting Double Size Double
forall s a. HasW s a => Lens' s a
L.w) (Size
winSize Size -> Getting Double Size Double -> Double
forall s a. s -> Getting a s a -> a
^. Getting Double Size Double
forall s a. HasH s a => Lens' s a
L.h),
    _weOffset :: Point
_weOffset = Point
forall a. Default a => a
def
  }
  let pathReadyRoot :: WidgetNode sp ep
pathReadyRoot = WidgetNode sp ep
widgetRoot
        WidgetNode sp ep
-> (WidgetNode sp ep -> WidgetNode sp ep) -> WidgetNode sp ep
forall a b. a -> (a -> b) -> b
& (WidgetNodeInfo -> Identity WidgetNodeInfo)
-> WidgetNode sp ep -> Identity (WidgetNode sp ep)
forall s a. HasInfo s a => Lens' s a
L.info ((WidgetNodeInfo -> Identity WidgetNodeInfo)
 -> WidgetNode sp ep -> Identity (WidgetNode sp ep))
-> ((Path -> Identity Path)
    -> WidgetNodeInfo -> Identity WidgetNodeInfo)
-> (Path -> Identity Path)
-> WidgetNode sp ep
-> Identity (WidgetNode sp ep)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path -> Identity Path)
-> WidgetNodeInfo -> Identity WidgetNodeInfo
forall s a. HasPath s a => Lens' s a
L.path ((Path -> Identity Path)
 -> WidgetNode sp ep -> Identity (WidgetNode sp ep))
-> Path -> WidgetNode sp ep -> WidgetNode sp ep
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Path
rootPath
        WidgetNode sp ep
-> (WidgetNode sp ep -> WidgetNode sp ep) -> WidgetNode sp ep
forall a b. a -> (a -> b) -> b
& (WidgetNodeInfo -> Identity WidgetNodeInfo)
-> WidgetNode sp ep -> Identity (WidgetNode sp ep)
forall s a. HasInfo s a => Lens' s a
L.info ((WidgetNodeInfo -> Identity WidgetNodeInfo)
 -> WidgetNode sp ep -> Identity (WidgetNode sp ep))
-> ((WidgetId -> Identity WidgetId)
    -> WidgetNodeInfo -> Identity WidgetNodeInfo)
-> (WidgetId -> Identity WidgetId)
-> WidgetNode sp ep
-> Identity (WidgetNode sp ep)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WidgetId -> Identity WidgetId)
-> WidgetNodeInfo -> Identity WidgetNodeInfo
forall s a. HasWidgetId s a => Lens' s a
L.widgetId ((WidgetId -> Identity WidgetId)
 -> WidgetNode sp ep -> Identity (WidgetNode sp ep))
-> WidgetId -> WidgetNode sp ep -> WidgetNode sp ep
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Int -> Path -> WidgetId
WidgetId (WidgetEnv sp Any
forall e. WidgetEnv sp e
wenv WidgetEnv sp Any -> Getting Int (WidgetEnv sp Any) Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int (WidgetEnv sp Any) Int
forall s a. HasTimestamp s a => Lens' s a
L.timestamp) Path
rootPath

  m ()
forall s e (m :: * -> *). MonomerM s e m => m ()
handleResourcesInit
  (WidgetEnv sp ep
newWenv, WidgetNode sp ep
newRoot, Seq (WidgetRequest sp ep)
_) <- WidgetEnv sp ep
-> WidgetNode sp ep
-> m (WidgetEnv sp ep, WidgetNode sp ep, Seq (WidgetRequest sp ep))
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetEnv s e -> WidgetNode s e -> m (HandlerStep s e)
handleWidgetInit WidgetEnv sp ep
forall e. WidgetEnv sp e
wenv WidgetNode sp ep
pathReadyRoot

  let loopArgs :: MainLoopArgs sp e ep
loopArgs = MainLoopArgs :: forall sp e ep.
Text
-> Maybe Renderer
-> Theme
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> [e]
-> WidgetNode sp ep
-> MVar (Map Text WidgetShared)
-> TChan (RenderMsg sp ep)
-> MainLoopArgs sp e ep
MainLoopArgs {
    _mlOS :: Text
_mlOS = Text
os,
    _mlRenderer :: Maybe Renderer
_mlRenderer = Maybe Renderer
renderer,
    _mlTheme :: Theme
_mlTheme = Theme
theme,
    _mlMaxFps :: Int
_mlMaxFps = Int
maxFps,
    _mlAppStartTs :: Int
_mlAppStartTs = Int
0,
    _mlLatestRenderTs :: Int
_mlLatestRenderTs = Int
0,
    _mlFrameStartTs :: Int
_mlFrameStartTs = Int
startTs,
    _mlFrameAccumTs :: Int
_mlFrameAccumTs = Int
0,
    _mlFrameCount :: Int
_mlFrameCount = Int
0,
    _mlExitEvents :: [e]
_mlExitEvents = [e]
exitEvents,
    _mlWidgetRoot :: WidgetNode sp ep
_mlWidgetRoot = WidgetNode sp ep
newRoot,
    _mlWidgetShared :: MVar (Map Text WidgetShared)
_mlWidgetShared = MVar (Map Text WidgetShared)
widgetSharedMVar,
    _mlChannel :: TChan (RenderMsg sp ep)
_mlChannel = TChan (RenderMsg sp ep)
channel
  }

  (sp -> Identity sp)
-> MonomerCtx sp ep -> Identity (MonomerCtx sp ep)
forall s a. HasMainModel s a => Lens' s a
L.mainModel ((sp -> Identity sp)
 -> MonomerCtx sp ep -> Identity (MonomerCtx sp ep))
-> sp -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= WidgetEnv sp ep -> sp
forall s e. WidgetEnv s e -> s
_weModel WidgetEnv sp ep
newWenv

  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
useRenderThread (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ TChan (RenderMsg sp ep) -> IO ()
forall s e. TChan (RenderMsg s e) -> IO ()
watchWindowResize TChan (RenderMsg sp ep)
channel
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (IO () -> IO ()) -> IO () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> (IO () -> IO ThreadId) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkOS (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
      TChan (RenderMsg sp ep)
-> Window
-> GLContext
-> [FontDef]
-> Double
-> WidgetEnv sp ep
-> WidgetNode sp ep
-> IO ()
forall s e.
(Eq s, WidgetEvent e) =>
TChan (RenderMsg s e)
-> Window
-> GLContext
-> [FontDef]
-> Double
-> WidgetEnv s e
-> WidgetNode s e
-> IO ()
startRenderThread TChan (RenderMsg sp ep)
channel Window
window GLContext
glCtx [FontDef]
fonts Double
dpr WidgetEnv sp ep
newWenv WidgetNode sp ep
newRoot

  Window
-> FontManager -> AppConfig e -> MainLoopArgs sp e ep -> m ()
forall sp ep (m :: * -> *) e.
(MonomerM sp ep m, WidgetEvent e) =>
Window
-> FontManager -> AppConfig e -> MainLoopArgs sp e ep -> m ()
mainLoop Window
window FontManager
fontManager AppConfig e
config MainLoopArgs sp e ep
loopArgs

mainLoop
  :: (MonomerM sp ep m, WidgetEvent e)
  => SDL.Window
  -> FontManager
  -> AppConfig e
  -> MainLoopArgs sp e ep
  -> m ()
mainLoop :: Window
-> FontManager -> AppConfig e -> MainLoopArgs sp e ep -> m ()
mainLoop Window
window FontManager
fontManager AppConfig e
config MainLoopArgs sp e ep
loopArgs = do
  let MainLoopArgs{Int
[e]
Maybe Renderer
Text
MVar (Map Text WidgetShared)
TChan (RenderMsg sp ep)
Theme
WidgetNode sp ep
_mlChannel :: TChan (RenderMsg sp ep)
_mlWidgetShared :: MVar (Map Text WidgetShared)
_mlWidgetRoot :: WidgetNode sp ep
_mlExitEvents :: [e]
_mlFrameCount :: Int
_mlFrameAccumTs :: Int
_mlFrameStartTs :: Int
_mlLatestRenderTs :: Int
_mlMaxFps :: Int
_mlAppStartTs :: Int
_mlTheme :: Theme
_mlRenderer :: Maybe Renderer
_mlOS :: Text
_mlChannel :: forall sp e ep. MainLoopArgs sp e ep -> TChan (RenderMsg sp ep)
_mlWidgetShared :: forall sp e ep.
MainLoopArgs sp e ep -> MVar (Map Text WidgetShared)
_mlWidgetRoot :: forall sp e ep. MainLoopArgs sp e ep -> WidgetNode sp ep
_mlExitEvents :: forall sp e ep. MainLoopArgs sp e ep -> [e]
_mlFrameCount :: forall sp e ep. MainLoopArgs sp e ep -> Int
_mlFrameAccumTs :: forall sp e ep. MainLoopArgs sp e ep -> Int
_mlFrameStartTs :: forall sp e ep. MainLoopArgs sp e ep -> Int
_mlLatestRenderTs :: forall sp e ep. MainLoopArgs sp e ep -> Int
_mlMaxFps :: forall sp e ep. MainLoopArgs sp e ep -> Int
_mlAppStartTs :: forall sp e ep. MainLoopArgs sp e ep -> Int
_mlTheme :: forall sp e ep. MainLoopArgs sp e ep -> Theme
_mlRenderer :: forall sp e ep. MainLoopArgs sp e ep -> Maybe Renderer
_mlOS :: forall sp e ep. MainLoopArgs sp e ep -> Text
..} = MainLoopArgs sp e ep
loopArgs

  Int
startTicks <- (Word32 -> Int) -> m Word32 -> m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral m Word32
forall (m :: * -> *). MonadIO m => m Word32
SDL.ticks
  [Event]
events <- m [Event]
forall (m :: * -> *). (Functor m, MonadIO m) => m [Event]
SDL.pollEvents

  Size
windowSize <- Getting Size (MonomerCtx sp ep) Size -> m Size
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Size (MonomerCtx sp ep) Size
forall s a. HasWindowSize s a => Lens' s a
L.windowSize
  Double
dpr <- Getting Double (MonomerCtx sp ep) Double -> m Double
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Double (MonomerCtx sp ep) Double
forall s a. HasDpr s a => Lens' s a
L.dpr
  Double
epr <- Getting Double (MonomerCtx sp ep) Double -> m Double
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Double (MonomerCtx sp ep) Double
forall s a. HasEpr s a => Lens' s a
L.epr
  sp
currentModel <- Getting sp (MonomerCtx sp ep) sp -> m sp
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting sp (MonomerCtx sp ep) sp
forall s a. HasMainModel s a => Lens' s a
L.mainModel
  Maybe (Path, CursorIcon)
cursorIcon <- m (Maybe (Path, CursorIcon))
forall s e (m :: * -> *).
MonomerM s e m =>
m (Maybe (Path, CursorIcon))
getCurrentCursorIcon
  Maybe Path
hovered <- m (Maybe Path)
forall s e (m :: * -> *). MonomerM s e m => m (Maybe Path)
getHoveredPath
  Path
focused <- m Path
forall s e (m :: * -> *). MonomerM s e m => m Path
getFocusedPath
  Maybe Path
overlay <- m (Maybe Path)
forall s e (m :: * -> *). MonomerM s e m => m (Maybe Path)
getOverlayPath
  Maybe (Path, WidgetDragMsg)
dragged <- m (Maybe (Path, WidgetDragMsg))
forall s e (m :: * -> *).
MonomerM s e m =>
m (Maybe (Path, WidgetDragMsg))
getDraggedMsgInfo
  Maybe (Path, Point)
mainPress <- Getting
  (Maybe (Path, Point)) (MonomerCtx sp ep) (Maybe (Path, Point))
-> m (Maybe (Path, Point))
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting
  (Maybe (Path, Point)) (MonomerCtx sp ep) (Maybe (Path, Point))
forall s a. HasMainBtnPress s a => Lens' s a
L.mainBtnPress
  InputStatus
inputStatus <- Getting InputStatus (MonomerCtx sp ep) InputStatus -> m InputStatus
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting InputStatus (MonomerCtx sp ep) InputStatus
forall s a. HasInputStatus s a => Lens' s a
L.inputStatus
  Point
mousePos <- IO Point -> m Point
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Point -> m Point) -> IO Point -> m Point
forall a b. (a -> b) -> a -> b
$ Double -> IO Point
getCurrentMousePos Double
epr
  Size
currWinSize <- IO Size -> m Size
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Size -> m Size) -> IO Size -> m Size
forall a b. (a -> b) -> a -> b
$ Window -> Double -> IO Size
getViewportSize Window
window Double
dpr

  let Size Double
rw Double
rh = Size
windowSize
  let ts :: Int
ts = Int
startTicks Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
_mlFrameStartTs
  let eventsPayload :: [EventPayload]
eventsPayload = (Event -> EventPayload) -> [Event] -> [EventPayload]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Event -> EventPayload
SDL.eventPayload [Event]
events
  let quit :: Bool
quit = EventPayload
SDL.QuitEvent EventPayload -> [EventPayload] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [EventPayload]
eventsPayload

  let windowResized :: Bool
windowResized = Size
currWinSize Size -> Size -> Bool
forall a. Eq a => a -> a -> Bool
/= Size
windowSize Bool -> Bool -> Bool
&& [EventPayload] -> Bool
isWindowResized [EventPayload]
eventsPayload
  let windowExposed :: Bool
windowExposed = [EventPayload] -> Bool
isWindowExposed [EventPayload]
eventsPayload
  let mouseEntered :: Bool
mouseEntered = [EventPayload] -> Bool
isMouseEntered [EventPayload]
eventsPayload
  let baseSystemEvents :: [SystemEvent]
baseSystemEvents = Double -> Double -> Point -> [EventPayload] -> [SystemEvent]
convertEvents Double
dpr Double
epr Point
mousePos [EventPayload]
eventsPayload

--  when newSecond $
--    liftIO . putStrLn $ "Frames: " ++ show _mlFrameCount

  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
quit (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    (Bool -> Identity Bool)
-> MonomerCtx sp ep -> Identity (MonomerCtx sp ep)
forall s a. HasExitApplication s a => Lens' s a
L.exitApplication ((Bool -> Identity Bool)
 -> MonomerCtx sp ep -> Identity (MonomerCtx sp ep))
-> Bool -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bool
True

  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
windowExposed (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    (Maybe (Path, Point) -> Identity (Maybe (Path, Point)))
-> MonomerCtx sp ep -> Identity (MonomerCtx sp ep)
forall s a. HasMainBtnPress s a => Lens' s a
L.mainBtnPress ((Maybe (Path, Point) -> Identity (Maybe (Path, Point)))
 -> MonomerCtx sp ep -> Identity (MonomerCtx sp ep))
-> Maybe (Path, Point) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Maybe (Path, Point)
forall a. Maybe a
Nothing

  let newSecond :: Bool
newSecond = Int
_mlFrameAccumTs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1000
  let mainBtn :: Button
mainBtn = Button -> Maybe Button -> Button
forall a. a -> Maybe a -> a
fromMaybe Button
BtnLeft (AppConfig e -> Maybe Button
forall e. AppConfig e -> Maybe Button
_apcMainButton AppConfig e
config)
  let contextBtn :: Button
contextBtn = Button -> Maybe Button -> Button
forall a. a -> Maybe a -> a
fromMaybe Button
BtnRight (AppConfig e -> Maybe Button
forall e. AppConfig e -> Maybe Button
_apcContextButton AppConfig e
config)
  let wenv :: WidgetEnv sp ep
wenv = WidgetEnv :: forall s e.
Text
-> Double
-> FontManager
-> (Path -> Maybe WidgetNodeInfo)
-> Button
-> Button
-> Theme
-> Size
-> MVar (Map Text WidgetShared)
-> WidgetKeyMap s e
-> Maybe Path
-> Path
-> Maybe Path
-> Maybe (Path, WidgetDragMsg)
-> Maybe (Path, Point)
-> Maybe (Path, CursorIcon)
-> s
-> InputStatus
-> Int
-> Bool
-> (Point -> Bool)
-> LayoutDirection
-> Rect
-> Point
-> WidgetEnv s e
WidgetEnv {
    _weOs :: Text
_weOs = Text
_mlOS,
    _weDpr :: Double
_weDpr = Double
dpr,
    _weFontManager :: FontManager
_weFontManager = FontManager
fontManager,
    _weFindByPath :: Path -> Maybe WidgetNodeInfo
_weFindByPath = WidgetEnv sp ep -> WidgetNode sp ep -> Path -> Maybe WidgetNodeInfo
forall s e.
WidgetEnv s e -> WidgetNode s e -> Path -> Maybe WidgetNodeInfo
findWidgetByPath WidgetEnv sp ep
wenv WidgetNode sp ep
_mlWidgetRoot,
    _weMainButton :: Button
_weMainButton = Button
mainBtn,
    _weContextButton :: Button
_weContextButton = Button
contextBtn,
    _weTheme :: Theme
_weTheme = Theme
_mlTheme,
    _weWindowSize :: Size
_weWindowSize = Size
windowSize,
    _weWidgetShared :: MVar (Map Text WidgetShared)
_weWidgetShared = MVar (Map Text WidgetShared)
_mlWidgetShared,
    _weWidgetKeyMap :: WidgetKeyMap sp ep
_weWidgetKeyMap = WidgetKeyMap sp ep
forall k a. Map k a
Map.empty,
    _weCursor :: Maybe (Path, CursorIcon)
_weCursor = Maybe (Path, CursorIcon)
cursorIcon,
    _weHoveredPath :: Maybe Path
_weHoveredPath = Maybe Path
hovered,
    _weFocusedPath :: Path
_weFocusedPath = Path
focused,
    _weOverlayPath :: Maybe Path
_weOverlayPath = Maybe Path
overlay,
    _weDragStatus :: Maybe (Path, WidgetDragMsg)
_weDragStatus = Maybe (Path, WidgetDragMsg)
dragged,
    _weMainBtnPress :: Maybe (Path, Point)
_weMainBtnPress = Maybe (Path, Point)
mainPress,
    _weModel :: sp
_weModel = sp
currentModel,
    _weInputStatus :: InputStatus
_weInputStatus = InputStatus
inputStatus,
    _weTimestamp :: Int
_weTimestamp = Int
startTicks,
    _weThemeChanged :: Bool
_weThemeChanged = Bool
False,
    _weInTopLayer :: Point -> Bool
_weInTopLayer = Bool -> Point -> Bool
forall a b. a -> b -> a
const Bool
True,
    _weLayoutDirection :: LayoutDirection
_weLayoutDirection = LayoutDirection
LayoutNone,
    _weViewport :: Rect
_weViewport = Double -> Double -> Double -> Double -> Rect
Rect Double
0 Double
0 Double
rw Double
rh,
    _weOffset :: Point
_weOffset = Point
forall a. Default a => a
def
  }
  -- Exit handler
  let baseWidgetId :: WidgetId
baseWidgetId = WidgetNode sp ep
_mlWidgetRoot WidgetNode sp ep
-> Getting WidgetId (WidgetNode sp ep) WidgetId -> WidgetId
forall s a. s -> Getting a s a -> a
^. (WidgetNodeInfo -> Const WidgetId WidgetNodeInfo)
-> WidgetNode sp ep -> Const WidgetId (WidgetNode sp ep)
forall s a. HasInfo s a => Lens' s a
L.info ((WidgetNodeInfo -> Const WidgetId WidgetNodeInfo)
 -> WidgetNode sp ep -> Const WidgetId (WidgetNode sp ep))
-> ((WidgetId -> Const WidgetId WidgetId)
    -> WidgetNodeInfo -> Const WidgetId WidgetNodeInfo)
-> Getting WidgetId (WidgetNode sp ep) WidgetId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WidgetId -> Const WidgetId WidgetId)
-> WidgetNodeInfo -> Const WidgetId WidgetNodeInfo
forall s a. HasWidgetId s a => Lens' s a
L.widgetId
  let exitMsgs :: [WidgetRequest s e]
exitMsgs = WidgetId -> e -> WidgetRequest s e
forall s e i. Typeable i => WidgetId -> i -> WidgetRequest s e
SendMessage WidgetId
baseWidgetId (e -> WidgetRequest s e) -> [e] -> [WidgetRequest s e]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [e]
_mlExitEvents
  let baseReqs :: Seq (WidgetRequest s e)
baseReqs
        | Bool
quit = [WidgetRequest s e] -> Seq (WidgetRequest s e)
forall a. [a] -> Seq a
Seq.fromList [WidgetRequest s e]
forall s e. [WidgetRequest s e]
exitMsgs
        | Bool
otherwise = Seq (WidgetRequest s e)
forall a. Seq a
Seq.Empty
  let baseStep :: (WidgetEnv sp ep, WidgetNode sp ep, Seq a)
baseStep = (WidgetEnv sp ep
wenv, WidgetNode sp ep
_mlWidgetRoot, Seq a
forall a. Seq a
Seq.empty)

  (WidgetEnv sp ep
rqWenv, WidgetNode sp ep
rqRoot, Seq (WidgetRequest sp ep)
_) <- Seq (WidgetRequest sp ep)
-> (WidgetEnv sp ep, WidgetNode sp ep, Seq (WidgetRequest sp ep))
-> m (WidgetEnv sp ep, WidgetNode sp ep, Seq (WidgetRequest sp ep))
forall s e (m :: * -> *).
MonomerM s e m =>
Seq (WidgetRequest s e) -> HandlerStep s e -> m (HandlerStep s e)
handleRequests Seq (WidgetRequest sp ep)
forall s e. Seq (WidgetRequest s e)
baseReqs (WidgetEnv sp ep, WidgetNode sp ep, Seq (WidgetRequest sp ep))
forall a. (WidgetEnv sp ep, WidgetNode sp ep, Seq a)
baseStep
  (WidgetEnv sp ep
wtWenv, WidgetNode sp ep
wtRoot, Seq (WidgetRequest sp ep)
_) <- WidgetEnv sp ep
-> WidgetNode sp ep
-> m (WidgetEnv sp ep, WidgetNode sp ep, Seq (WidgetRequest sp ep))
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetEnv s e -> WidgetNode s e -> m (HandlerStep s e)
handleWidgetTasks WidgetEnv sp ep
rqWenv WidgetNode sp ep
rqRoot
  (WidgetEnv sp ep
seWenv, WidgetNode sp ep
seRoot, Seq (WidgetRequest sp ep)
_) <- WidgetEnv sp ep
-> WidgetNode sp ep
-> [SystemEvent]
-> m (WidgetEnv sp ep, WidgetNode sp ep, Seq (WidgetRequest sp ep))
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetEnv s e
-> WidgetNode s e -> [SystemEvent] -> m (HandlerStep s e)
handleSystemEvents WidgetEnv sp ep
wtWenv WidgetNode sp ep
wtRoot [SystemEvent]
baseSystemEvents

  (WidgetEnv sp ep
newWenv, WidgetNode sp ep
newRoot, Seq (WidgetRequest sp ep)
_) <- if Bool
windowResized
    then do
      (Size -> Identity Size)
-> MonomerCtx sp ep -> Identity (MonomerCtx sp ep)
forall s a. HasWindowSize s a => Lens' s a
L.windowSize ((Size -> Identity Size)
 -> MonomerCtx sp ep -> Identity (MonomerCtx sp ep))
-> Size -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Size
currWinSize
      (WidgetEnv sp ep, WidgetNode sp ep, Seq (WidgetRequest sp ep))
-> m (WidgetEnv sp ep, WidgetNode sp ep, Seq (WidgetRequest sp ep))
forall s e (m :: * -> *).
MonomerM s e m =>
HandlerStep s e -> m (HandlerStep s e)
handleResizeWidgets (WidgetEnv sp ep
seWenv, WidgetNode sp ep
seRoot, Seq (WidgetRequest sp ep)
forall a. Seq a
Seq.empty)
    else (WidgetEnv sp ep, WidgetNode sp ep, Seq (WidgetRequest sp ep))
-> m (WidgetEnv sp ep, WidgetNode sp ep, Seq (WidgetRequest sp ep))
forall (m :: * -> *) a. Monad m => a -> m a
return (WidgetEnv sp ep
seWenv, WidgetNode sp ep
seRoot, Seq (WidgetRequest sp ep)
forall a. Seq a
Seq.empty)

  Int
endTicks <- (Word32 -> Int) -> m Word32 -> m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral m Word32
forall (m :: * -> *). MonadIO m => m Word32
SDL.ticks

  -- Rendering
  Bool
renderCurrentReq <- Int -> Int -> m Bool
forall s e (m :: * -> *). MonomerM s e m => Int -> Int -> m Bool
checkRenderCurrent Int
startTicks Int
_mlLatestRenderTs

  let useRenderThread :: Bool
useRenderThread = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
True (AppConfig e -> Maybe Bool
forall e. AppConfig e -> Maybe Bool
_apcUseRenderThread AppConfig e
config)
  let renderEvent :: Bool
renderEvent = (EventPayload -> Bool) -> [EventPayload] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any EventPayload -> Bool
isActionEvent [EventPayload]
eventsPayload
  let winRedrawEvt :: Bool
winRedrawEvt = Bool
windowResized Bool -> Bool -> Bool
|| Bool
windowExposed
  let renderNeeded :: Bool
renderNeeded = Bool
winRedrawEvt Bool -> Bool -> Bool
|| Bool
renderEvent Bool -> Bool -> Bool
|| Bool
renderCurrentReq

  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
renderNeeded Bool -> Bool -> Bool
&& Bool
useRenderThread) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (STM () -> IO ()) -> STM () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ TChan (RenderMsg sp ep) -> RenderMsg sp ep -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan (RenderMsg sp ep)
_mlChannel (WidgetEnv sp ep -> WidgetNode sp ep -> RenderMsg sp ep
forall s e. WidgetEnv s e -> WidgetNode s e -> RenderMsg s e
MsgRender WidgetEnv sp ep
newWenv WidgetNode sp ep
newRoot)

  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
renderNeeded Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
useRenderThread) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    let renderer :: Renderer
renderer = Maybe Renderer -> Renderer
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Renderer
_mlRenderer
    let bgColor :: Color
bgColor = WidgetEnv sp ep
newWenv WidgetEnv sp ep -> Getting Color (WidgetEnv sp ep) Color -> Color
forall s a. s -> Getting a s a -> a
^. (Theme -> Const Color Theme)
-> WidgetEnv sp ep -> Const Color (WidgetEnv sp ep)
forall s a. HasTheme s a => Lens' s a
L.theme ((Theme -> Const Color Theme)
 -> WidgetEnv sp ep -> Const Color (WidgetEnv sp ep))
-> ((Color -> Const Color Color) -> Theme -> Const Color Theme)
-> Getting Color (WidgetEnv sp ep) Color
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Color -> Const Color Color) -> Theme -> Const Color Theme
forall s a. HasClearColor s a => Lens' s a
L.clearColor

    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Window
-> Double
-> Renderer
-> Color
-> WidgetEnv sp ep
-> WidgetNode sp ep
-> IO ()
forall s e.
Window
-> Double
-> Renderer
-> Color
-> WidgetEnv s e
-> WidgetNode s e
-> IO ()
renderWidgets Window
window Double
dpr Renderer
renderer Color
bgColor WidgetEnv sp ep
newWenv WidgetNode sp ep
newRoot

  (Bool -> Identity Bool)
-> MonomerCtx sp ep -> Identity (MonomerCtx sp ep)
forall s a. HasRenderRequested s a => Lens' s a
L.renderRequested ((Bool -> Identity Bool)
 -> MonomerCtx sp ep -> Identity (MonomerCtx sp ep))
-> Bool -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bool
windowResized

  let fps :: Double
fps = Int -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac Int
_mlMaxFps
  let frameLength :: Int
frameLength = Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (Double
1000000 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
fps)
  let remainingMs :: Int
remainingMs = Int
endTicks Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
startTicks
  let tempDelay :: Int
tempDelay = Int -> Int
forall a. Num a => a -> a
abs (Int
frameLength Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
remainingMs Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000)
  let nextFrameDelay :: Int
nextFrameDelay = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
frameLength Int
tempDelay
  let latestRenderTs :: Int
latestRenderTs = if Bool
renderNeeded then Int
startTicks else Int
_mlLatestRenderTs
  let newLoopArgs :: MainLoopArgs sp e ep
newLoopArgs = MainLoopArgs sp e ep
loopArgs {
    _mlAppStartTs :: Int
_mlAppStartTs = Int
_mlAppStartTs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ts,
    _mlLatestRenderTs :: Int
_mlLatestRenderTs = Int
latestRenderTs,
    _mlFrameStartTs :: Int
_mlFrameStartTs = Int
startTicks,
    _mlFrameAccumTs :: Int
_mlFrameAccumTs = if Bool
newSecond then Int
0 else Int
_mlFrameAccumTs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ts,
    _mlFrameCount :: Int
_mlFrameCount = if Bool
newSecond then Int
0 else Int
_mlFrameCount Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1,
    _mlWidgetRoot :: WidgetNode sp ep
_mlWidgetRoot = WidgetNode sp ep
newRoot
  }

  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
nextFrameDelay

  Bool
shouldQuit <- Getting Bool (MonomerCtx sp ep) Bool -> m Bool
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Bool (MonomerCtx sp ep) Bool
forall s a. HasExitApplication s a => Lens' s a
L.exitApplication

  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldQuit (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    m (WidgetEnv sp ep, WidgetNode sp ep, Seq (WidgetRequest sp ep))
-> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (WidgetEnv sp ep, WidgetNode sp ep, Seq (WidgetRequest sp ep))
 -> m ())
-> m (WidgetEnv sp ep, WidgetNode sp ep, Seq (WidgetRequest sp ep))
-> m ()
forall a b. (a -> b) -> a -> b
$ WidgetEnv sp ep
-> WidgetNode sp ep
-> m (WidgetEnv sp ep, WidgetNode sp ep, Seq (WidgetRequest sp ep))
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetEnv s e -> WidgetNode s e -> m (HandlerStep s e)
handleWidgetDispose WidgetEnv sp ep
newWenv WidgetNode sp ep
newRoot

  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
shouldQuit (Window
-> FontManager -> AppConfig e -> MainLoopArgs sp e ep -> m ()
forall sp ep (m :: * -> *) e.
(MonomerM sp ep m, WidgetEvent e) =>
Window
-> FontManager -> AppConfig e -> MainLoopArgs sp e ep -> m ()
mainLoop Window
window FontManager
fontManager AppConfig e
config MainLoopArgs sp e ep
newLoopArgs)

startRenderThread
  :: (Eq s, WidgetEvent e)
  => TChan (RenderMsg s e)
  -> SDL.Window
  -> SDL.GLContext
  -> [FontDef]
  -> Double
  -> WidgetEnv s e
  -> WidgetNode s e
  -> IO ()
startRenderThread :: TChan (RenderMsg s e)
-> Window
-> GLContext
-> [FontDef]
-> Double
-> WidgetEnv s e
-> WidgetNode s e
-> IO ()
startRenderThread TChan (RenderMsg s e)
channel Window
window GLContext
glCtx [FontDef]
fonts Double
dpr WidgetEnv s e
wenv WidgetNode s e
root = do
  Window -> GLContext -> IO ()
forall (m :: * -> *).
(Functor m, MonadIO m) =>
Window -> GLContext -> m ()
SDL.glMakeCurrent Window
window GLContext
glCtx
  Renderer
renderer <- IO Renderer -> IO Renderer
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Renderer -> IO Renderer) -> IO Renderer -> IO Renderer
forall a b. (a -> b) -> a -> b
$ [FontDef] -> Double -> IO Renderer
makeRenderer [FontDef]
fonts Double
dpr
  FontManager
fontMgr <- IO FontManager -> IO FontManager
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FontManager -> IO FontManager)
-> IO FontManager -> IO FontManager
forall a b. (a -> b) -> a -> b
$ [FontDef] -> Double -> IO FontManager
makeFontManager [FontDef]
fonts Double
dpr

  TChan (RenderMsg s e)
-> Window -> Renderer -> FontManager -> RenderState s e -> IO ()
forall s e.
(Eq s, WidgetEvent e) =>
TChan (RenderMsg s e)
-> Window -> Renderer -> FontManager -> RenderState s e -> IO ()
waitRenderMsg TChan (RenderMsg s e)
channel Window
window Renderer
renderer FontManager
fontMgr RenderState s e
state
  where
    state :: RenderState s e
state = Double -> WidgetEnv s e -> WidgetNode s e -> RenderState s e
forall s e.
Double -> WidgetEnv s e -> WidgetNode s e -> RenderState s e
RenderState Double
dpr WidgetEnv s e
wenv WidgetNode s e
root

waitRenderMsg
  :: (Eq s, WidgetEvent e)
  => TChan (RenderMsg s e)
  -> SDL.Window
  -> Renderer
  -> FontManager
  -> RenderState s e
  -> IO ()
waitRenderMsg :: TChan (RenderMsg s e)
-> Window -> Renderer -> FontManager -> RenderState s e -> IO ()
waitRenderMsg TChan (RenderMsg s e)
channel Window
window Renderer
renderer FontManager
fontMgr RenderState s e
state = do
  RenderMsg s e
msg <- IO (RenderMsg s e) -> IO (RenderMsg s e)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (RenderMsg s e) -> IO (RenderMsg s e))
-> (STM (RenderMsg s e) -> IO (RenderMsg s e))
-> STM (RenderMsg s e)
-> IO (RenderMsg s e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (RenderMsg s e) -> IO (RenderMsg s e)
forall a. STM a -> IO a
atomically (STM (RenderMsg s e) -> IO (RenderMsg s e))
-> STM (RenderMsg s e) -> IO (RenderMsg s e)
forall a b. (a -> b) -> a -> b
$ TChan (RenderMsg s e) -> STM (RenderMsg s e)
forall a. TChan a -> STM a
readTChan TChan (RenderMsg s e)
channel
  RenderState s e
newState <- Window
-> Renderer
-> FontManager
-> RenderState s e
-> RenderMsg s e
-> IO (RenderState s e)
forall s e.
(Eq s, WidgetEvent e) =>
Window
-> Renderer
-> FontManager
-> RenderState s e
-> RenderMsg s e
-> IO (RenderState s e)
handleRenderMsg Window
window Renderer
renderer FontManager
fontMgr RenderState s e
state RenderMsg s e
msg
  TChan (RenderMsg s e)
-> Window -> Renderer -> FontManager -> RenderState s e -> IO ()
forall s e.
(Eq s, WidgetEvent e) =>
TChan (RenderMsg s e)
-> Window -> Renderer -> FontManager -> RenderState s e -> IO ()
waitRenderMsg TChan (RenderMsg s e)
channel Window
window Renderer
renderer FontManager
fontMgr RenderState s e
newState

handleRenderMsg
  :: (Eq s, WidgetEvent e)
  => SDL.Window
  -> Renderer
  -> FontManager
  -> RenderState s e
  -> RenderMsg s e
  -> IO (RenderState s e)
handleRenderMsg :: Window
-> Renderer
-> FontManager
-> RenderState s e
-> RenderMsg s e
-> IO (RenderState s e)
handleRenderMsg Window
window Renderer
renderer FontManager
fontMgr RenderState s e
state (MsgRender WidgetEnv s e
tmpWenv WidgetNode s e
newRoot) = do
  let RenderState Double
dpr WidgetEnv s e
_ WidgetNode s e
_ = RenderState s e
state
  let newWenv :: WidgetEnv s e
newWenv = WidgetEnv s e
tmpWenv
        WidgetEnv s e -> (WidgetEnv s e -> WidgetEnv s e) -> WidgetEnv s e
forall a b. a -> (a -> b) -> b
& (FontManager -> Identity FontManager)
-> WidgetEnv s e -> Identity (WidgetEnv s e)
forall s a. HasFontManager s a => Lens' s a
L.fontManager ((FontManager -> Identity FontManager)
 -> WidgetEnv s e -> Identity (WidgetEnv s e))
-> FontManager -> WidgetEnv s e -> WidgetEnv s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ FontManager
fontMgr
  let color :: Color
color = WidgetEnv s e
newWenv WidgetEnv s e -> Getting Color (WidgetEnv s e) Color -> Color
forall s a. s -> Getting a s a -> a
^. (Theme -> Const Color Theme)
-> WidgetEnv s e -> Const Color (WidgetEnv s e)
forall s a. HasTheme s a => Lens' s a
L.theme ((Theme -> Const Color Theme)
 -> WidgetEnv s e -> Const Color (WidgetEnv s e))
-> ((Color -> Const Color Color) -> Theme -> Const Color Theme)
-> Getting Color (WidgetEnv s e) Color
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Color -> Const Color Color) -> Theme -> Const Color Theme
forall s a. HasClearColor s a => Lens' s a
L.clearColor
  Window
-> Double
-> Renderer
-> Color
-> WidgetEnv s e
-> WidgetNode s e
-> IO ()
forall s e.
Window
-> Double
-> Renderer
-> Color
-> WidgetEnv s e
-> WidgetNode s e
-> IO ()
renderWidgets Window
window Double
dpr Renderer
renderer Color
color WidgetEnv s e
newWenv WidgetNode s e
newRoot
  RenderState s e -> IO (RenderState s e)
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> WidgetEnv s e -> WidgetNode s e -> RenderState s e
forall s e.
Double -> WidgetEnv s e -> WidgetNode s e -> RenderState s e
RenderState Double
dpr WidgetEnv s e
newWenv WidgetNode s e
newRoot)
handleRenderMsg Window
window Renderer
renderer FontManager
fontMgr RenderState s e
state (MsgResize Size
_) = do
  Size
newSize <- Window -> Double -> IO Size
getViewportSize Window
window (RenderState s e -> Double
forall s e. RenderState s e -> Double
_rstDpr RenderState s e
state)

  let RenderState Double
dpr WidgetEnv s e
wenv WidgetNode s e
root = RenderState s e
state
  let viewport :: Rect
viewport = Double -> Double -> Double -> Double -> Rect
Rect Double
0 Double
0 (Size
newSize Size -> Getting Double Size Double -> Double
forall s a. s -> Getting a s a -> a
^. Getting Double Size Double
forall s a. HasW s a => Lens' s a
L.w) (Size
newSize Size -> Getting Double Size Double -> Double
forall s a. s -> Getting a s a -> a
^. Getting Double Size Double
forall s a. HasH s a => Lens' s a
L.h)
  let newWenv :: WidgetEnv s e
newWenv = WidgetEnv s e
wenv
        WidgetEnv s e -> (WidgetEnv s e -> WidgetEnv s e) -> WidgetEnv s e
forall a b. a -> (a -> b) -> b
& (FontManager -> Identity FontManager)
-> WidgetEnv s e -> Identity (WidgetEnv s e)
forall s a. HasFontManager s a => Lens' s a
L.fontManager ((FontManager -> Identity FontManager)
 -> WidgetEnv s e -> Identity (WidgetEnv s e))
-> FontManager -> WidgetEnv s e -> WidgetEnv s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ FontManager
fontMgr
        WidgetEnv s e -> (WidgetEnv s e -> WidgetEnv s e) -> WidgetEnv s e
forall a b. a -> (a -> b) -> b
& (Size -> Identity Size)
-> WidgetEnv s e -> Identity (WidgetEnv s e)
forall s a. HasWindowSize s a => Lens' s a
L.windowSize ((Size -> Identity Size)
 -> WidgetEnv s e -> Identity (WidgetEnv s e))
-> Size -> WidgetEnv s e -> WidgetEnv s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Size
newSize
        WidgetEnv s e -> (WidgetEnv s e -> WidgetEnv s e) -> WidgetEnv s e
forall a b. a -> (a -> b) -> b
& (Rect -> Identity Rect)
-> WidgetEnv s e -> Identity (WidgetEnv s e)
forall s a. HasViewport s a => Lens' s a
L.viewport ((Rect -> Identity Rect)
 -> WidgetEnv s e -> Identity (WidgetEnv s e))
-> Rect -> WidgetEnv s e -> WidgetEnv s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Rect
viewport
  let color :: Color
color = WidgetEnv s e
newWenv WidgetEnv s e -> Getting Color (WidgetEnv s e) Color -> Color
forall s a. s -> Getting a s a -> a
^. (Theme -> Const Color Theme)
-> WidgetEnv s e -> Const Color (WidgetEnv s e)
forall s a. HasTheme s a => Lens' s a
L.theme ((Theme -> Const Color Theme)
 -> WidgetEnv s e -> Const Color (WidgetEnv s e))
-> ((Color -> Const Color Color) -> Theme -> Const Color Theme)
-> Getting Color (WidgetEnv s e) Color
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Color -> Const Color Color) -> Theme -> Const Color Theme
forall s a. HasClearColor s a => Lens' s a
L.clearColor
  let resizeCheck :: b -> Bool
resizeCheck = Bool -> b -> Bool
forall a b. a -> b -> a
const Bool
False
  let result :: WidgetResult s e
result = Widget s e
-> WidgetEnv s e
-> WidgetNode s e
-> Rect
-> (Path -> Bool)
-> WidgetResult s e
forall s e.
Widget s e
-> WidgetEnv s e
-> WidgetNode s e
-> Rect
-> (Path -> Bool)
-> WidgetResult s e
widgetResize (WidgetNode s e
root WidgetNode s e
-> Getting (Widget s e) (WidgetNode s e) (Widget s e) -> Widget s e
forall s a. s -> Getting a s a -> a
^. Getting (Widget s e) (WidgetNode s e) (Widget s e)
forall s a. HasWidget s a => Lens' s a
L.widget) WidgetEnv s e
newWenv WidgetNode s e
root Rect
viewport Path -> Bool
forall b. b -> Bool
resizeCheck
  let newRoot :: WidgetNode s e
newRoot = WidgetResult s e
result WidgetResult s e
-> Getting (WidgetNode s e) (WidgetResult s e) (WidgetNode s e)
-> WidgetNode s e
forall s a. s -> Getting a s a -> a
^. Getting (WidgetNode s e) (WidgetResult s e) (WidgetNode s e)
forall s a. HasNode s a => Lens' s a
L.node

  Window
-> Double
-> Renderer
-> Color
-> WidgetEnv s e
-> WidgetNode s e
-> IO ()
forall s e.
Window
-> Double
-> Renderer
-> Color
-> WidgetEnv s e
-> WidgetNode s e
-> IO ()
renderWidgets Window
window Double
dpr Renderer
renderer Color
color WidgetEnv s e
newWenv WidgetNode s e
newRoot
  RenderState s e -> IO (RenderState s e)
forall (m :: * -> *) a. Monad m => a -> m a
return RenderState s e
state
handleRenderMsg Window
window Renderer
renderer FontManager
fontMgr RenderState s e
state (MsgRemoveImage Text
name) = do
  Renderer -> Text -> IO ()
deleteImage Renderer
renderer Text
name
  RenderState s e -> IO (RenderState s e)
forall (m :: * -> *) a. Monad m => a -> m a
return RenderState s e
state
handleRenderMsg Window
window Renderer
renderer FontManager
fontMgr RenderState s e
state (MsgRunInRender TChan i
chan IO i
task) = do
  (IO () -> (SomeException -> IO ()) -> IO ())
-> (SomeException -> IO ()) -> IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO () -> (SomeException -> IO ()) -> IO ()
forall a. IO a -> (SomeException -> IO a) -> IO a
catchAny SomeException -> IO ()
forall a. Show a => a -> IO ()
print (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    i
value <- IO i
task
    STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan i -> i -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan i
chan i
value
  RenderState s e -> IO (RenderState s e)
forall (m :: * -> *) a. Monad m => a -> m a
return RenderState s e
state

renderWidgets
  :: SDL.Window
  -> Double
  -> Renderer
  -> Color
  -> WidgetEnv s e
  -> WidgetNode s e
  -> IO ()
renderWidgets :: Window
-> Double
-> Renderer
-> Color
-> WidgetEnv s e
-> WidgetNode s e
-> IO ()
renderWidgets Window
window Double
dpr Renderer
renderer Color
clearColor WidgetEnv s e
wenv WidgetNode s e
widgetRoot = do
  Size Double
dwW Double
dwH <- Window -> IO Size
getDrawableSize Window
window
  Size Double
vpW Double
vpH <- Window -> Double -> IO Size
getViewportSize Window
window Double
dpr

  let position :: Position
position = GLint -> GLint -> Position
GL.Position GLint
0 GLint
0
  let size :: Size
size = GLint -> GLint -> Size
GL.Size (Double -> GLint
forall a b. (RealFrac a, Integral b) => a -> b
round Double
dwW) (Double -> GLint
forall a b. (RealFrac a, Integral b) => a -> b
round Double
dwH)

  StateVar (Position, Size)
GL.viewport StateVar (Position, Size) -> (Position, Size) -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
GL.$= (Position
position, Size
size)

  StateVar (Color4 GLfloat)
GL.clearColor StateVar (Color4 GLfloat) -> Color4 GLfloat -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
GL.$= Color4 GLfloat
clearColor4
  [ClearBuffer] -> IO ()
GL.clear [ClearBuffer
GL.ColorBuffer]

  Renderer -> Double -> Double -> IO ()
beginFrame Renderer
renderer Double
vpW Double
vpH
  Widget s e -> WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
forall s e.
Widget s e -> WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
widgetRender (WidgetNode s e
widgetRoot WidgetNode s e
-> Getting (Widget s e) (WidgetNode s e) (Widget s e) -> Widget s e
forall s a. s -> Getting a s a -> a
^. Getting (Widget s e) (WidgetNode s e) (Widget s e)
forall s a. HasWidget s a => Lens' s a
L.widget) WidgetEnv s e
wenv WidgetNode s e
widgetRoot Renderer
renderer
  Renderer -> IO ()
endFrame Renderer
renderer

  Renderer -> IO ()
renderRawTasks Renderer
renderer

  Renderer -> Double -> Double -> IO ()
beginFrame Renderer
renderer Double
vpW Double
vpH
  Renderer -> IO ()
renderOverlays Renderer
renderer
  Renderer -> IO ()
endFrame Renderer
renderer

  Renderer -> IO ()
renderRawOverlays Renderer
renderer

  Window -> IO ()
forall (m :: * -> *). MonadIO m => Window -> m ()
SDL.glSwapWindow Window
window
  where
    r :: GLfloat
r = Int -> GLfloat
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Color
clearColor Color -> Getting Int Color Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int Color Int
forall s a. HasR s a => Lens' s a
L.r) GLfloat -> GLfloat -> GLfloat
forall a. Fractional a => a -> a -> a
/ GLfloat
255
    g :: GLfloat
g = Int -> GLfloat
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Color
clearColor Color -> Getting Int Color Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int Color Int
forall s a. HasG s a => Lens' s a
L.g) GLfloat -> GLfloat -> GLfloat
forall a. Fractional a => a -> a -> a
/ GLfloat
255
    b :: GLfloat
b = Int -> GLfloat
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Color
clearColor Color -> Getting Int Color Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int Color Int
forall s a. HasB s a => Lens' s a
L.b) GLfloat -> GLfloat -> GLfloat
forall a. Fractional a => a -> a -> a
/ GLfloat
255
    a :: Double
a = Color
clearColor Color -> Getting Double Color Double -> Double
forall s a. s -> Getting a s a -> a
^. Getting Double Color Double
forall s a. HasA s a => Lens' s a
L.a
    clearColor4 :: Color4 GLfloat
clearColor4 = GLfloat -> GLfloat -> GLfloat -> GLfloat -> Color4 GLfloat
forall a. a -> a -> a -> a -> Color4 a
GL.Color4 GLfloat
r GLfloat
g GLfloat
b (Double -> GLfloat
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
a)

watchWindowResize :: TChan (RenderMsg s e) -> IO ()
watchWindowResize :: TChan (RenderMsg s e) -> IO ()
watchWindowResize TChan (RenderMsg s e)
channel = do
  IO EventWatch -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO EventWatch -> IO ())
-> (EventWatchCallback -> IO EventWatch)
-> EventWatchCallback
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EventWatchCallback -> IO EventWatch
forall (m :: * -> *).
MonadIO m =>
EventWatchCallback -> m EventWatch
SDL.addEventWatch (EventWatchCallback -> IO ()) -> EventWatchCallback -> IO ()
forall a b. (a -> b) -> a -> b
$ \Event
ev -> do
    case Event -> EventPayload
SDL.eventPayload Event
ev of
      SDL.WindowSizeChangedEvent WindowSizeChangedEventData
sizeChangeData -> do
        let SDL.V2 GLint
nw GLint
nh = WindowSizeChangedEventData -> V2 GLint
SDL.windowSizeChangedEventSize WindowSizeChangedEventData
sizeChangeData
        let newSize :: Size
newSize = Double -> Double -> Size
Size (GLint -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLint
nw) (GLint -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLint
nh)

        STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan (RenderMsg s e) -> RenderMsg s e -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan (RenderMsg s e)
channel (Size -> RenderMsg s e
forall s e. Size -> RenderMsg s e
MsgResize Size
newSize)
      EventPayload
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

checkRenderCurrent :: (MonomerM s e m) => Int -> Int -> m Bool
checkRenderCurrent :: Int -> Int -> m Bool
checkRenderCurrent Int
currTs Int
renderTs = do
  Bool
renderCurrent <- Getting Bool (MonomerCtx s e) Bool -> m Bool
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Bool (MonomerCtx s e) Bool
forall s a. HasRenderRequested s a => Lens' s a
L.renderRequested
  Map WidgetId RenderSchedule
schedule <- Getting
  (Map WidgetId RenderSchedule)
  (MonomerCtx s e)
  (Map WidgetId RenderSchedule)
-> m (Map WidgetId RenderSchedule)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting
  (Map WidgetId RenderSchedule)
  (MonomerCtx s e)
  (Map WidgetId RenderSchedule)
forall s a. HasRenderSchedule s a => Lens' s a
L.renderSchedule
  (Map WidgetId RenderSchedule
 -> Identity (Map WidgetId RenderSchedule))
-> MonomerCtx s e -> Identity (MonomerCtx s e)
forall s a. HasRenderSchedule s a => Lens' s a
L.renderSchedule ((Map WidgetId RenderSchedule
  -> Identity (Map WidgetId RenderSchedule))
 -> MonomerCtx s e -> Identity (MonomerCtx s e))
-> Map WidgetId RenderSchedule -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= (RenderSchedule -> Bool)
-> Map WidgetId RenderSchedule -> Map WidgetId RenderSchedule
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Int -> RenderSchedule -> Bool
renderScheduleActive Int
currTs) Map WidgetId RenderSchedule
schedule
  Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
renderCurrent Bool -> Bool -> Bool
|| Map WidgetId RenderSchedule -> Bool
forall (t :: * -> *). Foldable t => t RenderSchedule -> Bool
renderNext Map WidgetId RenderSchedule
schedule)
  where
    requiresRender :: RenderSchedule -> Bool
requiresRender = Int -> Int -> RenderSchedule -> Bool
renderScheduleReq Int
currTs Int
renderTs
    renderNext :: t RenderSchedule -> Bool
renderNext t RenderSchedule
schedule = (RenderSchedule -> Bool) -> t RenderSchedule -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any RenderSchedule -> Bool
requiresRender t RenderSchedule
schedule

renderScheduleReq :: Int -> Int -> RenderSchedule -> Bool
renderScheduleReq :: Int -> Int -> RenderSchedule -> Bool
renderScheduleReq Int
currTs Int
renderTs RenderSchedule
schedule = Bool
required where
  RenderSchedule WidgetId
_ Int
start Int
ms Maybe Int
_ = RenderSchedule
schedule
  stepCount :: Int
stepCount = Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
currTs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
start) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ms)
  stepTs :: Int
stepTs = Int
start Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ms Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
stepCount
  required :: Bool
required = Int
renderTs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
stepTs

renderScheduleActive :: Int -> RenderSchedule -> Bool
renderScheduleActive :: Int -> RenderSchedule -> Bool
renderScheduleActive Int
currTs RenderSchedule
schedule = Bool
scheduleActive where
  RenderSchedule WidgetId
_ Int
start Int
ms Maybe Int
count = RenderSchedule
schedule
  stepCount :: Int
stepCount = Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
currTs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
start) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ms)
  scheduleActive :: Bool
scheduleActive = Bool -> (Int -> Bool) -> Maybe Int -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
stepCount) Maybe Int
count

isWindowResized :: [SDL.EventPayload] -> Bool
isWindowResized :: [EventPayload] -> Bool
isWindowResized [EventPayload]
eventsPayload = Bool -> Bool
not Bool
status where
  status :: Bool
status = [EventPayload] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ EventPayload
e | e :: EventPayload
e@SDL.WindowResizedEvent {} <- [EventPayload]
eventsPayload ]

isWindowExposed :: [SDL.EventPayload] -> Bool
isWindowExposed :: [EventPayload] -> Bool
isWindowExposed [EventPayload]
eventsPayload = Bool -> Bool
not Bool
status where
  status :: Bool
status = [EventPayload] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ EventPayload
e | e :: EventPayload
e@SDL.WindowExposedEvent {} <- [EventPayload]
eventsPayload ]

isMouseEntered :: [SDL.EventPayload] -> Bool
isMouseEntered :: [EventPayload] -> Bool
isMouseEntered [EventPayload]
eventsPayload = Bool -> Bool
not Bool
status where
  status :: Bool
status = [EventPayload] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ EventPayload
e | e :: EventPayload
e@SDL.WindowGainedMouseFocusEvent {} <- [EventPayload]
eventsPayload ]