{-|
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
import Control.Concurrent.STM.TChan (TChan, newTChanIO, readTChan, writeTChan)
import Control.Exception
import Control.Lens ((&), (^.), (.=), (.~), use)
import Control.Monad (unless, void, when)
import Control.Monad.Extra
import Control.Monad.State
import Control.Monad.STM (atomically)
import Data.Default
import Data.Either (isLeft)
import Data.Maybe (fromMaybe)
import Data.Map (Map)
import Data.List (foldl')
import Data.Text (Text)
import Data.Time
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
import Graphics.GL

import qualified Data.Map as Map
import qualified Data.Text as T
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, putStrLnErr)
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 {
  forall sp e ep. MainLoopArgs sp e ep -> Text
_mlOS :: Text,
  forall sp e ep. MainLoopArgs sp e ep -> Theme
_mlTheme :: Theme,
  forall sp e ep. MainLoopArgs sp e ep -> Millisecond
_mlAppStartTs :: Millisecond,
  forall sp e ep. MainLoopArgs sp e ep -> Int
_mlMaxFps :: Int,
  forall sp e ep. MainLoopArgs sp e ep -> Millisecond
_mlLatestRenderTs :: Millisecond,
  forall sp e ep. MainLoopArgs sp e ep -> Millisecond
_mlFrameStartTs :: Millisecond,
  forall sp e ep. MainLoopArgs sp e ep -> Millisecond
_mlFrameAccumTs :: Millisecond,
  forall sp e ep. MainLoopArgs sp e ep -> Int
_mlFrameCount :: Int,
  forall sp e ep. MainLoopArgs sp e ep -> [e]
_mlExitEvents :: [e],
  forall sp e ep. MainLoopArgs sp e ep -> WidgetNode sp ep
_mlWidgetRoot :: WidgetNode sp ep,
  forall sp e ep.
MainLoopArgs sp e ep -> MVar (Map Text WidgetShared)
_mlWidgetShared :: MVar (Map Text WidgetShared)
}

data RenderState s e = RenderState {
  forall s e. RenderState s e -> Double
_rstDpr :: Double,
  forall s e. RenderState s e -> WidgetEnv s e
_rstWidgetEnv :: WidgetEnv s e,
  forall 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 :: forall s e.
(Eq s, WidgetModel s, WidgetEvent e) =>
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) <- 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 <- forall a. IO (TChan a)
newTChanIO

  let monomerCtx :: MonomerCtx s ()
monomerCtx = 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

  forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (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 ()
destroySDLWindow Window
window
  where
    config :: AppConfig e
config = forall a. Monoid a => [a] -> a
mconcat [AppConfig e]
configs
    compCfgs :: [CompositeCfg s e s ()]
compCfgs
      = (forall t e. CmbOnInit t e => e -> t
onInit forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. AppConfig e -> [e]
_apcInitEvent AppConfig e
config)
      forall a. [a] -> [a] -> [a]
++ (forall t e. CmbOnDispose t e => e -> t
onDispose forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. AppConfig e -> [e]
_apcDisposeEvent AppConfig e
config)
      forall a. [a] -> [a] -> [a]
++ (forall t e a. CmbOnResize t e a => (a -> e) -> t
onResize forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. AppConfig e -> [Rect -> e]
_apcResizeEvent AppConfig e
config)
    appWidget :: WidgetNode s ()
appWidget = 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" 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 :: 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 sp ep)
channel WidgetNode sp ep
widgetRoot AppConfig e
config = do
  Double
dpr <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall s a. HasDpr s a => Lens' s a
L.dpr
  Size
winSize <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall s a. HasWindowSize s a => Lens' s a
L.windowSize

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

  Millisecond
appStartTs <- forall (m :: * -> *). MonadIO m => m Millisecond
getCurrentTimestamp
  sp
model <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall s a. HasMainModel s a => Lens' s a
L.mainModel
  Text
os <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Text
getPlatform
  MVar (Map Text WidgetShared)
widgetSharedMVar <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (MVar a)
newMVar forall k a. Map k a
Map.empty
  FontManager
fontManager <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [FontDef] -> Double -> IO FontManager
makeFontManager [FontDef]
fonts Double
dpr

  let wenv :: WidgetEnv sp e
wenv = WidgetEnv {
    _weOs :: Text
_weOs = Text
os,
    _weDpr :: Double
_weDpr = Double
dpr,
    _weAppStartTs :: Millisecond
_weAppStartTs = Millisecond
appStartTs,
    _weFontManager :: FontManager
_weFontManager = FontManager
fontManager,
    _weFindBranchByPath :: Path -> Seq WidgetNodeInfo
_weFindBranchByPath = forall a b. a -> b -> a
const forall a. Seq a
Seq.empty,
    _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 = forall k a. Map k a
Map.empty,
    _weCursor :: Maybe (Path, CursorIcon)
_weCursor = forall a. Maybe a
Nothing,
    _weHoveredPath :: Maybe Path
_weHoveredPath = forall a. Maybe a
Nothing,
    _weFocusedPath :: Path
_weFocusedPath = Path
emptyPath,
    _weOverlayPath :: Maybe Path
_weOverlayPath = forall a. Maybe a
Nothing,
    _weDragStatus :: Maybe (Path, WidgetDragMsg)
_weDragStatus = forall a. Maybe a
Nothing,
    _weMainBtnPress :: Maybe (Path, Point)
_weMainBtnPress = forall a. Maybe a
Nothing,
    _weModel :: sp
_weModel = sp
model,
    _weInputStatus :: InputStatus
_weInputStatus = forall a. Default a => a
def,
    _weTimestamp :: Millisecond
_weTimestamp = Millisecond
0,
    _weThemeChanged :: Bool
_weThemeChanged = Bool
False,
    _weInTopLayer :: Point -> Bool
_weInTopLayer = 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 forall s a. s -> Getting a s a -> a
^. forall s a. HasW s a => Lens' s a
L.w) (Size
winSize forall s a. s -> Getting a s a -> a
^. forall s a. HasH s a => Lens' s a
L.h),
    _weOffset :: Point
_weOffset = forall a. Default a => a
def
  }
  let pathReadyRoot :: WidgetNode sp ep
pathReadyRoot = WidgetNode sp ep
widgetRoot
        forall a b. a -> (a -> b) -> b
& forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasPath s a => Lens' s a
L.path forall s t a b. ASetter s t a b -> b -> s -> t
.~ Path
rootPath
        forall a b. a -> (a -> b) -> b
& forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasWidgetId s a => Lens' s a
L.widgetId forall s t a b. ASetter s t a b -> b -> s -> t
.~ Millisecond -> Path -> WidgetId
WidgetId (forall {e}. WidgetEnv sp e
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasTimestamp s a => Lens' s a
L.timestamp) Path
rootPath
  let makeMainThreadRenderer :: m RenderSetupResult
makeMainThreadRenderer = do
        Renderer
renderer <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [FontDef] -> Double -> IO Renderer
makeRenderer [FontDef]
fonts Double
dpr
        forall s a. HasRenderMethod s a => Lens' s a
L.renderMethod forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= forall a b. a -> Either a b
Left Renderer
renderer
        forall (m :: * -> *) a. Monad m => a -> m a
return RenderSetupResult
RenderSetupSingle

  RenderSetupResult
setupRes <- if Bool
useRenderThread
    then do
      TChan RenderSetupResult
stpChan <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a. IO (TChan a)
newTChanIO

      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkOS forall a b. (a -> b) -> a -> b
$
        {-
        The wenv and widgetRoot values are not used, since they are replaced
        during MsgInit. Kept to avoid issues with the Strict pragma.
        -}
        forall s e.
(Eq s, WidgetEvent e) =>
TChan RenderSetupResult
-> TChan (RenderMsg s e)
-> Window
-> GLContext
-> [FontDef]
-> Double
-> WidgetEnv s e
-> WidgetNode s e
-> IO ()
startRenderThread TChan RenderSetupResult
stpChan TChan (RenderMsg sp ep)
channel Window
window GLContext
glCtx [FontDef]
fonts Double
dpr forall {e}. WidgetEnv sp e
wenv WidgetNode sp ep
widgetRoot

      RenderSetupResult
setupRes <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> STM a
readTChan TChan RenderSetupResult
stpChan

      case RenderSetupResult
setupRes of
        RenderSetupMakeCurrentFailed [Char]
msg -> do
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO ()
putStrLnErr forall a b. (a -> b) -> a -> b
$ [Char]
"Setup of the rendering thread failed: " forall a. [a] -> [a] -> [a]
++ [Char]
msg
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO ()
putStrLnErr forall a b. (a -> b) -> a -> b
$ [Char]
"Falling back to rendering in the main thread. "
            forall a. [a] -> [a] -> [a]
++ [Char]
"The content may not be updated while resizing the window."

          m RenderSetupResult
makeMainThreadRenderer
        RenderSetupResult
_ -> do
          forall (m :: * -> *) a. Monad m => a -> m a
return RenderSetupResult
RenderSetupMulti
    else do
      m RenderSetupResult
makeMainThreadRenderer

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

  {-
  Deferred initialization step to account for Widgets that rely on OpenGL. They
  need the Renderer to be setup before handleWidgetInit is called, and it is
  safer to initialize the watcher after this happens.
  -}
  case RenderSetupResult
setupRes of
    RenderSetupResult
RenderSetupMulti -> do
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> a -> STM ()
writeTChan TChan (RenderMsg sp ep)
channel (forall s e. WidgetEnv s e -> WidgetNode s e -> RenderMsg s e
MsgInit WidgetEnv sp ep
newWenv WidgetNode sp ep
newRoot)

      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall s e. WidgetEnv s e -> Bool
isLinux WidgetEnv sp ep
newWenv) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall s e. TChan (RenderMsg s e) -> IO ()
watchWindowResize TChan (RenderMsg sp ep)
channel
    RenderSetupResult
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

  let loopArgs :: MainLoopArgs sp e ep
loopArgs = MainLoopArgs {
    _mlOS :: Text
_mlOS = Text
os,
    _mlTheme :: Theme
_mlTheme = Theme
theme,
    _mlMaxFps :: Int
_mlMaxFps = Int
maxFps,
    _mlAppStartTs :: Millisecond
_mlAppStartTs = Millisecond
appStartTs,
    _mlLatestRenderTs :: Millisecond
_mlLatestRenderTs = Millisecond
0,
    _mlFrameStartTs :: Millisecond
_mlFrameStartTs = Millisecond
0,
    _mlFrameAccumTs :: Millisecond
_mlFrameAccumTs = Millisecond
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
  }

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

  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 :: 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 = do
  let MainLoopArgs{Int
[e]
Text
MVar (Map Text WidgetShared)
Theme
WidgetNode sp ep
Millisecond
_mlWidgetShared :: MVar (Map Text WidgetShared)
_mlWidgetRoot :: WidgetNode sp ep
_mlExitEvents :: [e]
_mlFrameCount :: Int
_mlFrameAccumTs :: Millisecond
_mlFrameStartTs :: Millisecond
_mlLatestRenderTs :: Millisecond
_mlMaxFps :: Int
_mlAppStartTs :: Millisecond
_mlTheme :: Theme
_mlOS :: Text
_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 -> Millisecond
_mlFrameStartTs :: forall sp e ep. MainLoopArgs sp e ep -> Millisecond
_mlLatestRenderTs :: forall sp e ep. MainLoopArgs sp e ep -> Millisecond
_mlMaxFps :: forall sp e ep. MainLoopArgs sp e ep -> Int
_mlAppStartTs :: forall sp e ep. MainLoopArgs sp e ep -> Millisecond
_mlTheme :: forall sp e ep. MainLoopArgs sp e ep -> Theme
_mlOS :: forall sp e ep. MainLoopArgs sp e ep -> Text
..} = MainLoopArgs sp e ep
loopArgs

  Millisecond
startTs <- forall (m :: * -> *). MonadIO m => Millisecond -> m Millisecond
getElapsedTimestampSince Millisecond
_mlAppStartTs
  [Event]
events <- forall (m :: * -> *). MonadIO m => m ()
SDL.pumpEvents forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *). MonadIO m => m [Event]
SDL.pollEvents

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

  let Size Double
rw Double
rh = Size
windowSize
  let ts :: Millisecond
ts = Millisecond
startTs forall a. Num a => a -> a -> a
- Millisecond
_mlFrameStartTs
  let eventsPayload :: [EventPayload]
eventsPayload = 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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [EventPayload]
eventsPayload

  let windowResized :: Bool
windowResized = Size
currWinSize 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 invertX :: Bool
invertX = forall a. a -> Maybe a -> a
fromMaybe Bool
False (forall e. AppConfig e -> Maybe Bool
_apcInvertWheelX AppConfig e
config)
  let invertY :: Bool
invertY = forall a. a -> Maybe a -> a
fromMaybe Bool
False (forall e. AppConfig e -> Maybe Bool
_apcInvertWheelY AppConfig e
config)
  let convertCfg :: ConvertEventsCfg
convertCfg = Text -> Double -> Double -> Bool -> Bool -> ConvertEventsCfg
ConvertEventsCfg Text
_mlOS Double
dpr Double
epr Bool
invertX Bool
invertY
  let baseSystemEvents :: [SystemEvent]
baseSystemEvents = ConvertEventsCfg -> Point -> [EventPayload] -> [SystemEvent]
convertEvents ConvertEventsCfg
convertCfg Point
mousePos [EventPayload]
eventsPayload

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

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

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

  let newSecond :: Bool
newSecond = Millisecond
_mlFrameAccumTs forall a. Ord a => a -> a -> Bool
> Millisecond
1000
  let mainBtn :: Button
mainBtn = forall a. a -> Maybe a -> a
fromMaybe Button
BtnLeft (forall e. AppConfig e -> Maybe Button
_apcMainButton AppConfig e
config)
  let contextBtn :: Button
contextBtn = forall a. a -> Maybe a -> a
fromMaybe Button
BtnRight (forall e. AppConfig e -> Maybe Button
_apcContextButton AppConfig e
config)
  let wenv :: WidgetEnv sp ep
wenv = WidgetEnv {
    _weOs :: Text
_weOs = Text
_mlOS,
    _weDpr :: Double
_weDpr = Double
dpr,
    _weAppStartTs :: Millisecond
_weAppStartTs = Millisecond
_mlAppStartTs,
    _weFontManager :: FontManager
_weFontManager = FontManager
fontManager,
    _weFindBranchByPath :: Path -> Seq WidgetNodeInfo
_weFindBranchByPath = forall s e.
WidgetEnv s e -> WidgetNode s e -> Path -> Seq WidgetNodeInfo
findChildBranchByPath 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 = 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 :: Millisecond
_weTimestamp = Millisecond
startTs,
    _weThemeChanged :: Bool
_weThemeChanged = Bool
False,
    _weInTopLayer :: Point -> Bool
_weInTopLayer = 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 = forall a. Default a => a
def
  }
  -- Exit handler
  let baseWidgetId :: WidgetId
baseWidgetId = WidgetNode sp ep
_mlWidgetRoot forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasWidgetId s a => Lens' s a
L.widgetId
  let exitMsgs :: [WidgetRequest s e]
exitMsgs = forall s e i. Typeable i => WidgetId -> i -> WidgetRequest s e
SendMessage WidgetId
baseWidgetId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [e]
_mlExitEvents
  let baseReqs :: Seq (WidgetRequest s e)
baseReqs
        | Bool
quit = forall a. [a] -> Seq a
Seq.fromList forall {s} {e}. [WidgetRequest s e]
exitMsgs
        | Bool
otherwise = 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, forall a. Seq a
Seq.empty)

  forall s a. HasRenderRequested s a => Lens' s a
L.renderRequested forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bool
False

  (WidgetEnv sp ep
rqWenv, WidgetNode sp ep
rqRoot, Seq (WidgetRequest sp ep)
_) <- forall s e (m :: * -> *).
MonomerM s e m =>
Seq (WidgetRequest s e) -> HandlerStep s e -> m (HandlerStep s e)
handleRequests forall {s} {e}. Seq (WidgetRequest s e)
baseReqs forall {a}. (WidgetEnv sp ep, WidgetNode sp ep, Seq a)
baseStep
  (WidgetEnv sp ep
wtWenv, WidgetNode sp ep
wtRoot, 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)
_) <- 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
      forall s a. HasWindowSize s a => Lens' s a
L.windowSize forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Size
currWinSize
      forall s e (m :: * -> *).
MonomerM s e m =>
HandlerStep s e -> m (HandlerStep s e)
handleResizeWidgets (WidgetEnv sp ep
seWenv, WidgetNode sp ep
seRoot, forall a. Seq a
Seq.empty)
    else forall (m :: * -> *) a. Monad m => a -> m a
return (WidgetEnv sp ep
seWenv, WidgetNode sp ep
seRoot, forall a. Seq a
Seq.empty)

  Millisecond
endTs <- forall (m :: * -> *). MonadIO m => Millisecond -> m Millisecond
getElapsedTimestampSince Millisecond
_mlAppStartTs

  -- Rendering
  Bool
renderCurrentReq <- forall s e (m :: * -> *).
MonomerM s e m =>
Millisecond -> Millisecond -> m Bool
checkRenderCurrent Millisecond
startTs Millisecond
_mlLatestRenderTs
  Either Renderer (TChan (RenderMsg sp ep))
renderMethod <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall s a. HasRenderMethod s a => Lens' s a
L.renderMethod

  let actionEvt :: Bool
actionEvt = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any EventPayload -> Bool
isActionEvent [EventPayload]
eventsPayload
  let renderResize :: Bool
renderResize = Bool
windowResized Bool -> Bool -> Bool
&& (forall s e. WidgetEnv s e -> Bool
isLinux WidgetEnv sp ep
wenv Bool -> Bool -> Bool
|| forall a b. Either a b -> Bool
isLeft Either Renderer (TChan (RenderMsg sp ep))
renderMethod)
  let windowRenderEvt :: Bool
windowRenderEvt = Bool
renderResize Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any EventPayload -> Bool
isWindowRenderEvent [EventPayload]
eventsPayload
  let renderNeeded :: Bool
renderNeeded = Bool
windowRenderEvt Bool -> Bool -> Bool
|| Bool
actionEvt Bool -> Bool -> Bool
|| Bool
renderCurrentReq

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
prevRenderNeeded Bool -> Bool -> Bool
|| Bool
renderNeeded) forall a b. (a -> b) -> a -> b
$
    case Either Renderer (TChan (RenderMsg sp ep))
renderMethod of
      Right TChan (RenderMsg sp ep)
renderChan -> do
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> a -> STM ()
writeTChan TChan (RenderMsg sp ep)
renderChan (forall s e. WidgetEnv s e -> WidgetNode s e -> RenderMsg s e
MsgRender WidgetEnv sp ep
newWenv WidgetNode sp ep
newRoot)
      Left Renderer
renderer -> do
        let bgColor :: Color
bgColor = WidgetEnv sp ep
newWenv forall s a. s -> Getting a s a -> a
^. forall s a. HasTheme s a => Lens' s a
L.theme forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasClearColor s a => Lens' s a
L.clearColor

        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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

  {-
  Used in the next rendering cycle.

  Temporary workaround: when rendering is needed, make sure to render the next
  frame too in order to avoid visual artifacts.
  -}
  forall s a. HasRenderRequested s a => Lens' s a
L.renderRequested forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bool
renderNeeded

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

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

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

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldQuit forall a b. (a -> b) -> a -> b
$
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ 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

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
shouldQuit (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)

{-
Attempts to initialize a GL context in a separate OS thread to handle rendering
actions. This allows for continuous content updates when the user resizes the
window.

In case the setup fails, it notifies the parent process so it can fall back to
rendering in the main thread.
-}
startRenderThread
  :: (Eq s, WidgetEvent e)
  => TChan RenderSetupResult
  -> TChan (RenderMsg s e)
  -> SDL.Window
  -> SDL.GLContext
  -> [FontDef]
  -> Double
  -> WidgetEnv s e
  -> WidgetNode s e
  -> IO ()
startRenderThread :: forall s e.
(Eq s, WidgetEvent e) =>
TChan RenderSetupResult
-> TChan (RenderMsg s e)
-> Window
-> GLContext
-> [FontDef]
-> Double
-> WidgetEnv s e
-> WidgetNode s e
-> IO ()
startRenderThread TChan RenderSetupResult
setupChan TChan (RenderMsg s e)
msgChan Window
window GLContext
glCtx [FontDef]
fonts Double
dpr WidgetEnv s e
wenv WidgetNode s e
root = do
  Either SDLException ()
resp <- forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(Functor m, MonadIO m) =>
Window -> GLContext -> m ()
SDL.glMakeCurrent Window
window GLContext
glCtx

  case Either SDLException ()
resp of
    Right{} -> do
      Renderer
renderer <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [FontDef] -> Double -> IO Renderer
makeRenderer [FontDef]
fonts Double
dpr
      FontManager
fontMgr <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [FontDef] -> Double -> IO FontManager
makeFontManager [FontDef]
fonts Double
dpr

      forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> a -> STM ()
writeTChan TChan RenderSetupResult
setupChan RenderSetupResult
RenderSetupMulti

      forall s e.
(Eq s, WidgetEvent e) =>
TChan (RenderMsg s e)
-> Window -> Renderer -> FontManager -> RenderState s e -> IO ()
waitRenderMsg TChan (RenderMsg s e)
msgChan Window
window Renderer
renderer FontManager
fontMgr RenderState s e
state
    Left (SDL.SDLCallFailed Text
_ Text
_ Text
err) -> do
      let msg :: [Char]
msg = Text -> [Char]
T.unpack Text
err
      forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> a -> STM ()
writeTChan TChan RenderSetupResult
setupChan ([Char] -> RenderSetupResult
RenderSetupMakeCurrentFailed [Char]
msg)
    Left SDLException
e -> do
      let msg :: [Char]
msg = forall e. Exception e => e -> [Char]
displayException SDLException
e
      forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> a -> STM ()
writeTChan TChan RenderSetupResult
setupChan ([Char] -> RenderSetupResult
RenderSetupMakeCurrentFailed [Char]
msg)
  where
    state :: RenderState s e
state = 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 :: forall s e.
(Eq s, WidgetEvent e) =>
TChan (RenderMsg s e)
-> Window -> Renderer -> FontManager -> RenderState s e -> IO ()
waitRenderMsg TChan (RenderMsg s e)
msgChan Window
window Renderer
renderer FontManager
fontMgr RenderState s e
state = do
  RenderMsg s e
msg <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> STM a
readTChan TChan (RenderMsg s e)
msgChan
  RenderState s e
newState <- 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
  forall s e.
(Eq s, WidgetEvent e) =>
TChan (RenderMsg s e)
-> Window -> Renderer -> FontManager -> RenderState s e -> IO ()
waitRenderMsg TChan (RenderMsg s e)
msgChan 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 :: 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 (MsgInit WidgetEnv s e
newWenv WidgetNode s e
newRoot) = do
  let RenderState Double
dpr WidgetEnv s e
_ WidgetNode s e
_ = RenderState s e
state
  forall (m :: * -> *) a. Monad m => a -> m a
return (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 (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
        forall a b. a -> (a -> b) -> b
& forall s a. HasFontManager s a => Lens' s a
L.fontManager forall s t a b. ASetter s t a b -> b -> s -> t
.~ FontManager
fontMgr
  let color :: Color
color = WidgetEnv s e
newWenv forall s a. s -> Getting a s a -> a
^. forall s a. HasTheme s a => Lens' s a
L.theme forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasClearColor s a => Lens' s a
L.clearColor

  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
  forall (m :: * -> *) a. Monad m => a -> m a
return (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 (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 forall s a. s -> Getting a s a -> a
^. forall s a. HasW s a => Lens' s a
L.w) (Size
newSize forall s a. s -> Getting a s a -> a
^. forall s a. HasH s a => Lens' s a
L.h)
  let newWenv :: WidgetEnv s e
newWenv = WidgetEnv s e
wenv
        forall a b. a -> (a -> b) -> b
& forall s a. HasFontManager s a => Lens' s a
L.fontManager forall s t a b. ASetter s t a b -> b -> s -> t
.~ FontManager
fontMgr
        forall a b. a -> (a -> b) -> b
& forall s a. HasWindowSize s a => Lens' s a
L.windowSize forall s t a b. ASetter s t a b -> b -> s -> t
.~ Size
newSize
        forall a b. a -> (a -> b) -> b
& forall s a. HasViewport s a => Lens' s a
L.viewport forall s t a b. ASetter s t a b -> b -> s -> t
.~ Rect
viewport
  let color :: Color
color = WidgetEnv s e
newWenv forall s a. s -> Getting a s a -> a
^. forall s a. HasTheme s a => Lens' s a
L.theme forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasClearColor s a => Lens' s a
L.clearColor
  let resizeCheck :: b -> Bool
resizeCheck = forall a b. a -> b -> a
const Bool
False
  let result :: WidgetResult s e
result = forall s e.
Widget s e
-> WidgetEnv s e
-> WidgetNode s e
-> Rect
-> (Path -> Bool)
-> WidgetResult s e
widgetResize (WidgetNode s e
root forall s a. s -> Getting a s a -> a
^. forall s a. HasWidget s a => Lens' s a
L.widget) WidgetEnv s e
newWenv WidgetNode s e
root Rect
viewport forall {b}. b -> Bool
resizeCheck
  let newRoot :: WidgetNode s e
newRoot = WidgetResult s e
result forall s a. s -> Getting a s a -> a
^. forall s a. HasNode s a => Lens' s a
L.node

  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
  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
  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
  forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. IO a -> (SomeException -> IO a) -> IO a
catchAny forall a. Show a => a -> IO ()
print forall a b. (a -> b) -> a -> b
$ do
    i
value <- IO i
task
    forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> a -> STM ()
writeTChan TChan i
chan i
value
  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 :: forall s e.
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

  forall (m :: * -> *).
MonadIO m =>
GLint -> GLint -> GLint -> GLint -> m ()
glViewport GLint
0 GLint
0 (forall a b. (RealFrac a, Integral b) => a -> b
round Double
dwW) (forall a b. (RealFrac a, Integral b) => a -> b
round Double
dwH)

  forall (m :: * -> *).
MonadIO m =>
GLfloat -> GLfloat -> GLfloat -> GLfloat -> m ()
glClearColor GLfloat
r GLfloat
g GLfloat
b GLfloat
a
  forall (m :: * -> *). MonadIO m => GLbitfield -> m ()
glClear GLbitfield
GL_COLOR_BUFFER_BIT

  Renderer -> Double -> Double -> IO ()
beginFrame Renderer
renderer Double
vpW Double
vpH
  forall s e.
Widget s e -> WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
widgetRender (WidgetNode s e
widgetRoot forall s a. s -> Getting a s a -> a
^. 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

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

watchWindowResize :: TChan (RenderMsg s e) -> IO ()
watchWindowResize :: forall s e. TChan (RenderMsg s e) -> IO ()
watchWindowResize TChan (RenderMsg s e)
channel = do
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
MonadIO m =>
EventWatchCallback -> m EventWatch
SDL.addEventWatch 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 (forall a b. (Integral a, Num b) => a -> b
fromIntegral GLint
nw) (forall a b. (Integral a, Num b) => a -> b
fromIntegral GLint
nh)

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

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

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

renderScheduleActive :: Millisecond -> RenderSchedule -> Bool
renderScheduleActive :: Millisecond -> RenderSchedule -> Bool
renderScheduleActive Millisecond
currTs RenderSchedule
schedule = Bool
scheduleActive where
  RenderSchedule WidgetId
_ Millisecond
start Millisecond
ms Maybe Int
count = RenderSchedule
schedule
  stepCount :: Int
stepCount = forall a b. (RealFrac a, Integral b) => a -> b
floor (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Millisecond
currTs forall a. Num a => a -> a -> a
- Millisecond
start) forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Millisecond
ms)
  scheduleActive :: Bool
scheduleActive = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (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 = 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 = 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 = forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ EventPayload
e | e :: EventPayload
e@SDL.WindowGainedMouseFocusEvent {} <- [EventPayload]
eventsPayload ]

isWindowRenderEvent :: SDL.EventPayload -> Bool
isWindowRenderEvent :: EventPayload -> Bool
isWindowRenderEvent SDL.WindowShownEvent{} = Bool
True
isWindowRenderEvent SDL.WindowExposedEvent{} = Bool
True
isWindowRenderEvent SDL.WindowMovedEvent{} = Bool
True
isWindowRenderEvent SDL.WindowResizedEvent{} = Bool
True
isWindowRenderEvent SDL.WindowSizeChangedEvent{} = Bool
True
isWindowRenderEvent SDL.WindowMaximizedEvent{} = Bool
True
isWindowRenderEvent SDL.WindowRestoredEvent{} = Bool
True
isWindowRenderEvent SDL.WindowGainedMouseFocusEvent{} = Bool
True
isWindowRenderEvent SDL.WindowGainedKeyboardFocusEvent{} = Bool
True
isWindowRenderEvent EventPayload
_ = Bool
False

getCurrentTimestamp :: MonadIO m => m Millisecond
getCurrentTimestamp :: forall (m :: * -> *). MonadIO m => m Millisecond
getCurrentTimestamp = UTCTime -> Millisecond
toMs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  where
    toMs :: UTCTime -> Millisecond
toMs = forall a b. (RealFrac a, Integral b) => a -> b
floor forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pico
1e3 forall a. Num a => a -> a -> a
*) forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTime -> Pico
nominalDiffTimeToSeconds forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> NominalDiffTime
utcTimeToPOSIXSeconds

getElapsedTimestampSince :: MonadIO m => Millisecond -> m Millisecond
getElapsedTimestampSince :: forall (m :: * -> *). MonadIO m => Millisecond -> m Millisecond
getElapsedTimestampSince Millisecond
start = do
  Millisecond
ts <- forall (m :: * -> *). MonadIO m => m Millisecond
getCurrentTimestamp
  forall (m :: * -> *) a. Monad m => a -> m a
return (Millisecond
ts forall a. Num a => a -> a -> a
- Millisecond
start)