{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# 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 ((&), (^.), (.=), (.~), _2, use)
import Control.Monad.Extra
import Control.Monad.State
import Control.Monad.STM (atomically)
import Data.Default
import Data.Either (isLeft)
import Data.Maybe (fromMaybe, fromJust, isJust)
import Data.Map (Map)
import Data.Text (Text)
import Data.Time
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
import Data.Word (Word32)
import Graphics.GL
import qualified Data.Map as Map
import qualified Data.Sequence as Seq
import qualified Data.Text as T
import qualified Foreign.Store as FS
import qualified SDL
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, isGhciRunning)
import Monomer.Widgets.Composite
import qualified Monomer.Lens as L
type AppEventResponse s e = EventResponse s e s e
type AppEventHandler s e
= WidgetEnv s e
-> WidgetNode s e
-> s
-> e
-> [AppEventResponse s e]
type AppUIBuilder s e = UIBuilder s e
data MainLoopArgs sp e ep = MainLoopArgs {
forall sp e ep. MainLoopArgs sp e ep -> Bool
_mlIsGhci :: Bool,
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
}
data MonomerReloadData s e = MonomerReloadData {
forall s e. MonomerReloadData s e -> Window
_mrdWindow :: !SDL.Window,
forall s e. MonomerReloadData s e -> GLContext
_mrdGlContext :: !SDL.GLContext,
forall s e. MonomerReloadData s e -> MonomerCtx s e
_mrdMonomerCtx :: !(MonomerCtx s e),
forall s e. MonomerReloadData s e -> String
_mrdModelFp :: !String,
forall s e. MonomerReloadData s e -> WidgetNode s e
_mrdRoot :: !(WidgetNode s e)
}
startApp
:: (Eq s, WidgetModel s, WidgetEvent e)
=> s
-> AppEventHandler s e
-> AppUIBuilder s e
-> [AppConfig s e]
-> IO ()
startApp :: forall s e.
(Eq s, WidgetModel s, WidgetEvent e) =>
s
-> AppEventHandler s e
-> AppUIBuilder s e
-> [AppConfig s e]
-> IO ()
startApp s
newModel AppEventHandler s e
eventHandler AppUIBuilder s e
uiBuilder [AppConfig s e]
configs = do
Bool
isGhci <- IO Bool
isGhciRunning
TChan (RenderMsg s e)
channel <- IO (TChan (RenderMsg s e))
forall a. IO (TChan a)
newTChanIO
(s
model, Maybe (WidgetNode s e)
oldRoot) <- AppConfig s e
-> s -> WidgetNode s e -> IO (s, Maybe (WidgetNode s e))
forall s e.
WidgetModel s =>
AppConfig s e
-> s -> WidgetNode s e -> IO (s, Maybe (WidgetNode s e))
retrieveModelAndRoot AppConfig s e
config s
newModel WidgetNode s e
newRoot
(Window
window, GLContext
glCtx, MonomerCtx s e
ctx) <- AppConfig s e
-> TChan (RenderMsg s e)
-> s
-> IO (Window, GLContext, MonomerCtx s e)
forall s e.
AppConfig s e
-> TChan (RenderMsg s e)
-> s
-> IO (Window, GLContext, MonomerCtx s e)
retrieveSDLWindow AppConfig s e
config TChan (RenderMsg s e)
channel s
model
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isGhci (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
MonomerReloadData s e -> IO ()
forall s e. MonomerReloadData s e -> IO ()
setReloadData (Window
-> GLContext
-> MonomerCtx s e
-> String
-> WidgetNode s e
-> MonomerReloadData s e
forall s e.
Window
-> GLContext
-> MonomerCtx s e
-> String
-> WidgetNode s e
-> MonomerReloadData s e
MonomerReloadData Window
window GLContext
glCtx MonomerCtx s e
ctx String
modelFp WidgetNode s e
newRoot)
((), MonomerCtx s e)
resp <- StateT (MonomerCtx s e) IO ()
-> MonomerCtx s e -> IO ((), MonomerCtx s e)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (Window
-> GLContext
-> TChan (RenderMsg s e)
-> Maybe (WidgetNode s e)
-> WidgetNode s e
-> AppConfig s e
-> StateT (MonomerCtx s e) IO ()
forall sp ep (m :: * -> *) e s.
(MonomerM sp ep m, Eq sp, WidgetEvent e, WidgetEvent ep) =>
Window
-> GLContext
-> TChan (RenderMsg sp ep)
-> Maybe (WidgetNode sp ep)
-> WidgetNode sp ep
-> AppConfig s e
-> m ()
runAppLoop Window
window GLContext
glCtx TChan (RenderMsg s e)
channel Maybe (WidgetNode s e)
oldRoot WidgetNode s e
newRoot AppConfig s e
config) MonomerCtx s e
ctx
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
isGhci Bool -> Bool -> Bool
|| ((), MonomerCtx s e)
resp ((), MonomerCtx s e)
-> Getting Bool ((), MonomerCtx s e) Bool -> Bool
forall s a. s -> Getting a s a -> a
^. (MonomerCtx s e -> Const Bool (MonomerCtx s e))
-> ((), MonomerCtx s e) -> Const Bool ((), MonomerCtx s e)
forall s t a b. Field2 s t a b => Lens s t a b
Lens
((), MonomerCtx s e)
((), MonomerCtx s e)
(MonomerCtx s e)
(MonomerCtx s e)
_2 ((MonomerCtx s e -> Const Bool (MonomerCtx s e))
-> ((), MonomerCtx s e) -> Const Bool ((), MonomerCtx s e))
-> ((Bool -> Const Bool Bool)
-> MonomerCtx s e -> Const Bool (MonomerCtx s e))
-> Getting Bool ((), MonomerCtx s e) Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Const Bool Bool)
-> MonomerCtx s e -> Const Bool (MonomerCtx s e)
forall s a. HasExitApplication s a => Lens' s a
Lens' (MonomerCtx s e) Bool
L.exitApplication) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Window -> IO ()
destroySDLWindow Window
window
IO ()
resetReloadData
where
config :: AppConfig s e
config = [AppConfig s e] -> AppConfig s e
forall a. Monoid a => [a] -> a
mconcat [AppConfig s e]
configs
compCfgs :: [CompositeCfg s e s e]
compCfgs
= (e -> CompositeCfg s e s e
forall t e. CmbOnInit t e => e -> t
onInit (e -> CompositeCfg s e s e) -> [e] -> [CompositeCfg s e s e]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AppConfig s e -> [e]
forall s e. AppConfig s e -> [e]
_apcInitEvent AppConfig s e
config)
[CompositeCfg s e s e]
-> [CompositeCfg s e s e] -> [CompositeCfg s e s e]
forall a. [a] -> [a] -> [a]
++ (e -> CompositeCfg s e s e
forall t e. CmbOnDispose t e => e -> t
onDispose (e -> CompositeCfg s e s e) -> [e] -> [CompositeCfg s e s e]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AppConfig s e -> [e]
forall s e. AppConfig s e -> [e]
_apcDisposeEvent AppConfig s e
config)
[CompositeCfg s e s e]
-> [CompositeCfg s e s e] -> [CompositeCfg s e s e]
forall a. [a] -> [a] -> [a]
++ ((Rect -> e) -> CompositeCfg s e s e
forall t e a. CmbOnResize t e a => (a -> e) -> t
onResize ((Rect -> e) -> CompositeCfg s e s e)
-> [Rect -> e] -> [CompositeCfg s e s e]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AppConfig s e -> [Rect -> e]
forall s e. AppConfig s e -> [Rect -> e]
_apcResizeEvent AppConfig s e
config)
~String
modelFp = String
-> ((s -> String) -> String) -> Maybe (s -> String) -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" ((s -> String) -> s -> String
forall a b. (a -> b) -> a -> b
$ s
newModel) (AppConfig s e -> Maybe (s -> String)
forall s e. AppConfig s e -> Maybe (s -> String)
_apcModelFingerprintFn AppConfig s e
config)
newRoot :: WidgetNode s e
newRoot = WidgetType
-> ALens' s s
-> AppUIBuilder s e
-> AppEventHandler s e
-> [CompositeCfg s e s e]
-> WidgetNode s e
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 e]
compCfgs
runAppLoop
:: (MonomerM sp ep m, Eq sp, WidgetEvent e, WidgetEvent ep)
=> SDL.Window
-> SDL.GLContext
-> TChan (RenderMsg sp ep)
-> Maybe (WidgetNode sp ep)
-> WidgetNode sp ep
-> AppConfig s e
-> m ()
runAppLoop :: forall sp ep (m :: * -> *) e s.
(MonomerM sp ep m, Eq sp, WidgetEvent e, WidgetEvent ep) =>
Window
-> GLContext
-> TChan (RenderMsg sp ep)
-> Maybe (WidgetNode sp ep)
-> WidgetNode sp ep
-> AppConfig s e
-> m ()
runAppLoop Window
window GLContext
glCtx TChan (RenderMsg sp ep)
channel Maybe (WidgetNode sp ep)
mRootOld WidgetNode sp ep
newRoot AppConfig s e
config = do
Bool
isGhci <- IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Bool
isGhciRunning
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
Lens' (MonomerCtx sp ep) Double
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
Lens' (MonomerCtx sp ep) Size
L.windowSize
let useRenderThreadFlag :: Bool
useRenderThreadFlag = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
True (AppConfig s e -> Maybe Bool
forall s e. AppConfig s e -> Maybe Bool
_apcUseRenderThread AppConfig s e
config)
let useRenderThread :: Bool
useRenderThread = Bool
useRenderThreadFlag Bool -> Bool -> Bool
&& Bool
rtsSupportsBoundThreads
let maxFps :: Int
maxFps = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
60 (AppConfig s e -> Maybe Int
forall s e. AppConfig s e -> Maybe Int
_apcMaxFps AppConfig s e
config)
let fonts :: [FontDef]
fonts = AppConfig s e -> [FontDef]
forall s e. AppConfig s e -> [FontDef]
_apcFonts AppConfig s 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 s e -> Maybe Theme
forall s e. AppConfig s e -> Maybe Theme
_apcTheme AppConfig s e
config)
let exitEvents :: [e]
exitEvents = AppConfig s e -> [e]
forall s e. AppConfig s e -> [e]
_apcExitEvent AppConfig s e
config
let mainBtn :: Button
mainBtn = Button -> Maybe Button -> Button
forall a. a -> Maybe a -> a
fromMaybe Button
BtnLeft (AppConfig s e -> Maybe Button
forall s e. AppConfig s e -> Maybe Button
_apcMainButton AppConfig s e
config)
let contextBtn :: Button
contextBtn = Button -> Maybe Button -> Button
forall a. a -> Maybe a -> a
fromMaybe Button
BtnRight (AppConfig s e -> Maybe Button
forall s e. AppConfig s e -> Maybe Button
_apcContextButton AppConfig s e
config)
Millisecond
appStartTs <- m Millisecond
forall (m :: * -> *). MonadIO m => m Millisecond
getCurrentTimestamp
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
Lens' (MonomerCtx sp ep) sp
L.mainModel
Text
os <- IO Text -> m Text
forall a. IO a -> m a
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 a. IO a -> m a
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
FontManager
fontManager <- IO FontManager -> m FontManager
forall a. IO a -> m a
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
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
let wenv :: WidgetEnv sp e
wenv = WidgetEnv {
_weOs :: Text
_weOs = Text
os,
_weDpr :: Double
_weDpr = Double
dpr,
_weIsGhci :: Bool
_weIsGhci = Bool
isGhci,
_weAppStartTs :: Millisecond
_weAppStartTs = Millisecond
appStartTs,
_weFontManager :: FontManager
_weFontManager = FontManager
fontManager,
_weFindBranchByPath :: Path -> Seq WidgetNodeInfo
_weFindBranchByPath = Seq WidgetNodeInfo -> Path -> Seq WidgetNodeInfo
forall a b. a -> b -> a
const Seq WidgetNodeInfo
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 = 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
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)
forall a. Maybe a
Nothing,
_weModel :: sp
_weModel = sp
model,
_weInputStatus :: InputStatus
_weInputStatus = InputStatus
forall a. Default a => a
def,
_weTimestamp :: Millisecond
_weTimestamp = Millisecond
0,
_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
Lens' Size Double
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
Lens' Size Double
L.h),
_weOffset :: Point
_weOffset = Point
forall a. Default a => a
def
}
let tmpRoot :: WidgetNode sp ep
tmpRoot = WidgetNode sp ep
newRoot
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
Lens' (WidgetNode sp ep) WidgetNodeInfo
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
Lens' WidgetNodeInfo Path
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
Lens' (WidgetNode sp ep) WidgetNodeInfo
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
Lens' WidgetNodeInfo WidgetId
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
.~ Millisecond -> Path -> WidgetId
WidgetId (WidgetEnv sp Any
forall {e}. WidgetEnv sp e
wenv WidgetEnv sp Any
-> Getting Millisecond (WidgetEnv sp Any) Millisecond
-> Millisecond
forall s a. s -> Getting a s a -> a
^. Getting Millisecond (WidgetEnv sp Any) Millisecond
forall s a. HasTimestamp s a => Lens' s a
Lens' (WidgetEnv sp Any) Millisecond
L.timestamp) Path
rootPath
let mergeNewRoot :: WidgetNode sp e -> WidgetNode sp e -> WidgetResult sp e
mergeNewRoot WidgetNode sp e
newRoot WidgetNode sp e
oldRoot = WidgetResult sp e
result where
result :: WidgetResult sp e
result = Widget sp e
-> WidgetEnv sp e
-> WidgetNode sp e
-> WidgetNode sp e
-> WidgetResult sp e
forall s e.
Widget s e
-> WidgetEnv s e
-> WidgetNode s e
-> WidgetNode s e
-> WidgetResult s e
widgetMerge (WidgetNode sp e
newRoot WidgetNode sp e
-> Getting (Widget sp e) (WidgetNode sp e) (Widget sp e)
-> Widget sp e
forall s a. s -> Getting a s a -> a
^. Getting (Widget sp e) (WidgetNode sp e) (Widget sp e)
forall s a. HasWidget s a => Lens' s a
Lens' (WidgetNode sp e) (Widget sp e)
L.widget) WidgetEnv sp e
forall {e}. WidgetEnv sp e
wenv WidgetNode sp e
newRoot WidgetNode sp e
oldRoot
let result :: WidgetResult sp ep
result = WidgetResult sp ep
-> (WidgetNode sp ep -> WidgetResult sp ep)
-> Maybe (WidgetNode sp ep)
-> WidgetResult sp ep
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (WidgetNode sp ep -> WidgetResult sp ep
forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode sp ep
tmpRoot) (WidgetNode sp ep -> WidgetNode sp ep -> WidgetResult sp ep
forall {e}. WidgetNode sp e -> WidgetNode sp e -> WidgetResult sp e
mergeNewRoot WidgetNode sp ep
tmpRoot) Maybe (WidgetNode sp ep)
mRootOld
let appRoot :: WidgetNode sp ep
appRoot = WidgetResult sp ep
result WidgetResult sp ep
-> Getting
(WidgetNode sp ep) (WidgetResult sp ep) (WidgetNode sp ep)
-> WidgetNode sp ep
forall s a. s -> Getting a s a -> a
^. Getting (WidgetNode sp ep) (WidgetResult sp ep) (WidgetNode sp ep)
forall s a. HasNode s a => Lens' s a
Lens' (WidgetResult sp ep) (WidgetNode sp ep)
L.node
let makeMainThreadRenderer :: m RenderSetupResult
makeMainThreadRenderer = do
Renderer
renderer <- IO Renderer -> m Renderer
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Renderer -> m Renderer) -> IO Renderer -> m Renderer
forall a b. (a -> b) -> a -> b
$ [FontDef] -> Double -> IO Renderer
makeRenderer [FontDef]
fonts Double
dpr
(Either Renderer (TChan (RenderMsg sp ep))
-> Identity (Either Renderer (TChan (RenderMsg sp ep))))
-> MonomerCtx sp ep -> Identity (MonomerCtx sp ep)
forall s a. HasRenderMethod s a => Lens' s a
Lens'
(MonomerCtx sp ep) (Either Renderer (TChan (RenderMsg sp ep)))
L.renderMethod ((Either Renderer (TChan (RenderMsg sp ep))
-> Identity (Either Renderer (TChan (RenderMsg sp ep))))
-> MonomerCtx sp ep -> Identity (MonomerCtx sp ep))
-> Either Renderer (TChan (RenderMsg sp ep)) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Renderer -> Either Renderer (TChan (RenderMsg sp ep))
forall a b. a -> Either a b
Left Renderer
renderer
RenderSetupResult -> m RenderSetupResult
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return RenderSetupResult
RenderSetupSingle
RenderSetupResult
setupRes <- if Bool
useRenderThread
then do
TChan RenderSetupResult
stpChan <- IO (TChan RenderSetupResult) -> m (TChan RenderSetupResult)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (TChan RenderSetupResult)
forall a. IO (TChan a)
newTChanIO
IO () -> m ()
forall a. IO a -> m a
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 RenderSetupResult
-> TChan (RenderMsg sp ep)
-> Window
-> GLContext
-> [FontDef]
-> Double
-> WidgetEnv sp ep
-> WidgetNode sp ep
-> IO ()
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 WidgetEnv sp ep
forall {e}. WidgetEnv sp e
wenv WidgetNode sp ep
appRoot
RenderSetupResult
setupRes <- IO RenderSetupResult -> m RenderSetupResult
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO RenderSetupResult -> m RenderSetupResult)
-> (STM RenderSetupResult -> IO RenderSetupResult)
-> STM RenderSetupResult
-> m RenderSetupResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM RenderSetupResult -> IO RenderSetupResult
forall a. STM a -> IO a
atomically (STM RenderSetupResult -> m RenderSetupResult)
-> STM RenderSetupResult -> m RenderSetupResult
forall a b. (a -> b) -> a -> b
$ TChan RenderSetupResult -> STM RenderSetupResult
forall a. TChan a -> STM a
readTChan TChan RenderSetupResult
stpChan
case RenderSetupResult
setupRes of
RenderSetupMakeCurrentFailed String
msg -> do
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (String -> IO ()) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLnErr (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Setup of the rendering thread failed: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (String -> IO ()) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLnErr (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Falling back to rendering in the main thread. "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"The content may not be updated while resizing the window."
m RenderSetupResult
makeMainThreadRenderer
RenderSetupResult
_ -> do
RenderSetupResult -> m RenderSetupResult
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return RenderSetupResult
RenderSetupMulti
else do
m RenderSetupResult
makeMainThreadRenderer
m ()
forall s e (m :: * -> *). MonomerM s e m => m ()
handleResourcesInit
(WidgetEnv sp ep
newWenv, WidgetNode sp ep
newAppRoot, Seq (WidgetRequest sp ep)
_) <- if Maybe (WidgetNode sp ep) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (WidgetNode sp ep)
mRootOld
then WidgetEnv sp ep
-> Bool
-> WidgetResult sp ep
-> m (WidgetEnv sp ep, WidgetNode sp ep, Seq (WidgetRequest sp ep))
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetEnv s e -> Bool -> WidgetResult s e -> m (HandlerStep s e)
handleWidgetResult WidgetEnv sp ep
forall {e}. WidgetEnv sp e
wenv Bool
True WidgetResult sp ep
result
else 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
appRoot
case RenderSetupResult
setupRes of
RenderSetupResult
RenderSetupMulti -> do
IO () -> m ()
forall a. IO a -> m a
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)
channel (WidgetEnv sp ep -> WidgetNode sp ep -> RenderMsg sp ep
forall s e. WidgetEnv s e -> WidgetNode s e -> RenderMsg s e
MsgInit WidgetEnv sp ep
newWenv WidgetNode sp ep
newAppRoot)
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (WidgetEnv sp ep -> Bool
forall s e. WidgetEnv s e -> Bool
isLinux WidgetEnv sp ep
newWenv) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
IO () -> m ()
forall a. IO a -> m a
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
RenderSetupResult
_ -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
let loopArgs :: MainLoopArgs sp e ep
loopArgs = MainLoopArgs {
_mlIsGhci :: Bool
_mlIsGhci = Bool
isGhci,
_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
newAppRoot,
_mlWidgetShared :: MVar (Map Text WidgetShared)
_mlWidgetShared = MVar (Map Text WidgetShared)
widgetSharedMVar
}
(sp -> Identity sp)
-> MonomerCtx sp ep -> Identity (MonomerCtx sp ep)
forall s a. HasMainModel s a => Lens' s a
Lens' (MonomerCtx sp ep) sp
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
Window
-> FontManager -> AppConfig s e -> MainLoopArgs sp e ep -> m ()
forall sp ep (m :: * -> *) e s.
(MonomerM sp ep m, WidgetEvent e) =>
Window
-> FontManager -> AppConfig s e -> MainLoopArgs sp e ep -> m ()
mainLoop Window
window FontManager
fontManager AppConfig s e
config MainLoopArgs sp e ep
loopArgs
mainLoop
:: (MonomerM sp ep m, WidgetEvent e)
=> SDL.Window
-> FontManager
-> AppConfig s e
-> MainLoopArgs sp e ep
-> m ()
mainLoop :: forall sp ep (m :: * -> *) e s.
(MonomerM sp ep m, WidgetEvent e) =>
Window
-> FontManager -> AppConfig s e -> MainLoopArgs sp e ep -> m ()
mainLoop Window
window FontManager
fontManager AppConfig s e
config MainLoopArgs sp e ep
loopArgs = do
let MainLoopArgs{Bool
Int
[e]
MVar (Map Text WidgetShared)
Text
Theme
WidgetNode sp ep
Millisecond
_mlIsGhci :: forall sp e ep. MainLoopArgs sp e ep -> Bool
_mlOS :: forall sp e ep. MainLoopArgs sp e ep -> Text
_mlTheme :: forall sp e ep. MainLoopArgs sp e ep -> Theme
_mlAppStartTs :: forall sp e ep. MainLoopArgs sp e ep -> Millisecond
_mlMaxFps :: forall sp e ep. MainLoopArgs sp e ep -> Int
_mlLatestRenderTs :: forall sp e ep. MainLoopArgs sp e ep -> Millisecond
_mlFrameStartTs :: forall sp e ep. MainLoopArgs sp e ep -> Millisecond
_mlFrameAccumTs :: forall sp e ep. MainLoopArgs sp e ep -> Millisecond
_mlFrameCount :: forall sp e ep. MainLoopArgs sp e ep -> Int
_mlExitEvents :: forall sp e ep. MainLoopArgs sp e ep -> [e]
_mlWidgetRoot :: forall sp e ep. MainLoopArgs sp e ep -> WidgetNode sp ep
_mlWidgetShared :: forall sp e ep.
MainLoopArgs sp e ep -> MVar (Map Text WidgetShared)
_mlIsGhci :: Bool
_mlOS :: Text
_mlTheme :: Theme
_mlAppStartTs :: Millisecond
_mlMaxFps :: Int
_mlLatestRenderTs :: Millisecond
_mlFrameStartTs :: Millisecond
_mlFrameAccumTs :: Millisecond
_mlFrameCount :: Int
_mlExitEvents :: [e]
_mlWidgetRoot :: WidgetNode sp ep
_mlWidgetShared :: MVar (Map Text WidgetShared)
..} = MainLoopArgs sp e ep
loopArgs
Millisecond
startTs <- Millisecond -> m Millisecond
forall (m :: * -> *). MonadIO m => Millisecond -> m Millisecond
getElapsedTimestampSince Millisecond
_mlAppStartTs
[Event]
events <- m ()
forall (m :: * -> *). MonadIO m => m ()
SDL.pumpEvents m () -> m [Event] -> m [Event]
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m [Event]
forall (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
Lens' (MonomerCtx sp ep) Size
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
Lens' (MonomerCtx sp ep) Double
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
Lens' (MonomerCtx sp ep) Double
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
Lens' (MonomerCtx sp ep) sp
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
Lens' (MonomerCtx sp ep) (Maybe (Path, Point))
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
Lens' (MonomerCtx sp ep) InputStatus
L.inputStatus
Point
mousePos <- IO Point -> m Point
forall a. IO a -> m a
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 a. IO a -> m a
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
Bool
prevRenderNeeded <- 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. HasRenderRequested s a => Lens' s a
Lens' (MonomerCtx sp ep) Bool
L.renderRequested
let Size Double
rw Double
rh = Size
windowSize
let ts :: Millisecond
ts = Millisecond
startTs Millisecond -> Millisecond -> Millisecond
forall a. Num a => a -> a -> a
- Millisecond
_mlFrameStartTs
let eventsPayload :: [EventPayload]
eventsPayload = (Event -> EventPayload) -> [Event] -> [EventPayload]
forall a b. (a -> b) -> [a] -> [b]
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 a. Eq a => a -> [a] -> 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 invertX :: Bool
invertX = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (AppConfig s e -> Maybe Bool
forall s e. AppConfig s e -> Maybe Bool
_apcInvertWheelX AppConfig s e
config)
let invertY :: Bool
invertY = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (AppConfig s e -> Maybe Bool
forall s e. AppConfig s e -> Maybe Bool
_apcInvertWheelY AppConfig s 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
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
Lens' (MonomerCtx sp ep) Bool
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
Lens' (MonomerCtx sp ep) (Maybe (Path, Point))
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 = Millisecond
_mlFrameAccumTs Millisecond -> Millisecond -> Bool
forall a. Ord a => a -> a -> Bool
> Millisecond
1000
let mainBtn :: Button
mainBtn = Button -> Maybe Button -> Button
forall a. a -> Maybe a -> a
fromMaybe Button
BtnLeft (AppConfig s e -> Maybe Button
forall s e. AppConfig s e -> Maybe Button
_apcMainButton AppConfig s e
config)
let contextBtn :: Button
contextBtn = Button -> Maybe Button -> Button
forall a. a -> Maybe a -> a
fromMaybe Button
BtnRight (AppConfig s e -> Maybe Button
forall s e. AppConfig s e -> Maybe Button
_apcContextButton AppConfig s e
config)
let wenv :: WidgetEnv sp ep
wenv = WidgetEnv {
_weOs :: Text
_weOs = Text
_mlOS,
_weDpr :: Double
_weDpr = Double
dpr,
_weIsGhci :: Bool
_weIsGhci = Bool
_mlIsGhci,
_weAppStartTs :: Millisecond
_weAppStartTs = Millisecond
_mlAppStartTs,
_weFontManager :: FontManager
_weFontManager = FontManager
fontManager,
_weFindBranchByPath :: Path -> Seq WidgetNodeInfo
_weFindBranchByPath = WidgetEnv sp ep -> WidgetNode sp ep -> Path -> Seq WidgetNodeInfo
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 = 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 :: Millisecond
_weTimestamp = Millisecond
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 Double
rw Double
rh,
_weOffset :: Point
_weOffset = Point
forall a. Default a => a
def
}
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
Lens' (WidgetNode sp ep) WidgetNodeInfo
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
Lens' WidgetNodeInfo WidgetId
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)
(Bool -> Identity Bool)
-> MonomerCtx sp ep -> Identity (MonomerCtx sp ep)
forall s a. HasRenderRequested s a => Lens' s a
Lens' (MonomerCtx sp ep) Bool
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
False
(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
Lens' (MonomerCtx sp ep) Size
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 a. a -> m a
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)
Millisecond
endTs <- Millisecond -> m Millisecond
forall (m :: * -> *). MonadIO m => Millisecond -> m Millisecond
getElapsedTimestampSince Millisecond
_mlAppStartTs
Bool
renderCurrentReq <- Millisecond -> Millisecond -> m Bool
forall s e (m :: * -> *).
MonomerM s e m =>
Millisecond -> Millisecond -> m Bool
checkRenderCurrent Millisecond
startTs Millisecond
_mlLatestRenderTs
Either Renderer (TChan (RenderMsg sp ep))
renderMethod <- Getting
(Either Renderer (TChan (RenderMsg sp ep)))
(MonomerCtx sp ep)
(Either Renderer (TChan (RenderMsg sp ep)))
-> m (Either Renderer (TChan (RenderMsg sp ep)))
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting
(Either Renderer (TChan (RenderMsg sp ep)))
(MonomerCtx sp ep)
(Either Renderer (TChan (RenderMsg sp ep)))
forall s a. HasRenderMethod s a => Lens' s a
Lens'
(MonomerCtx sp ep) (Either Renderer (TChan (RenderMsg sp ep)))
L.renderMethod
let actionEvt :: Bool
actionEvt = (EventPayload -> Bool) -> [EventPayload] -> Bool
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
&& (WidgetEnv sp ep -> Bool
forall s e. WidgetEnv s e -> Bool
isLinux WidgetEnv sp ep
wenv Bool -> Bool -> Bool
|| Either Renderer (TChan (RenderMsg sp ep)) -> 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
|| (EventPayload -> Bool) -> [EventPayload] -> 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
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
prevRenderNeeded Bool -> Bool -> Bool
|| Bool
renderNeeded) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
case Either Renderer (TChan (RenderMsg sp ep))
renderMethod of
Right TChan (RenderMsg sp ep)
renderChan -> do
IO () -> m ()
forall a. IO a -> m a
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)
renderChan (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)
Left Renderer
renderer -> do
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
Lens' (WidgetEnv sp ep) Theme
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
Lens' Theme Color
L.clearColor
IO () -> m ()
forall a. IO a -> m a
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
Lens' (MonomerCtx sp ep) Bool
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
renderNeeded
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 b. Integral b => Double -> b
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 :: Millisecond
remainingMs = Millisecond
endTs Millisecond -> Millisecond -> Millisecond
forall a. Num a => a -> a -> a
- Millisecond
startTs
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
- Millisecond -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Millisecond
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 :: Millisecond
latestRenderTs = if Bool
renderNeeded then Millisecond
startTs else Millisecond
_mlLatestRenderTs
let newModel :: sp
newModel = WidgetEnv sp ep
newWenv WidgetEnv sp ep -> Getting sp (WidgetEnv sp ep) sp -> sp
forall s a. s -> Getting a s a -> a
^. Getting sp (WidgetEnv sp ep) sp
forall s a. HasModel s a => Lens' s a
Lens' (WidgetEnv sp ep) sp
L.model
let newLoopArgs :: MainLoopArgs sp e ep
newLoopArgs = MainLoopArgs sp e ep
loopArgs {
_mlLatestRenderTs = latestRenderTs,
_mlFrameStartTs = startTs,
_mlFrameAccumTs = if newSecond then 0 else _mlFrameAccumTs + ts,
_mlFrameCount = if newSecond then 0 else _mlFrameCount + 1,
_mlWidgetRoot = newRoot
}
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
_mlIsGhci (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
MonomerCtx sp ep
ctx <- m (MonomerCtx sp ep)
forall s (m :: * -> *). MonadState s m => m s
get
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MonomerCtx sp ep -> WidgetNode sp ep -> IO ()
forall s e. MonomerCtx s e -> WidgetNode s e -> IO ()
updateReloadData MonomerCtx sp ep
ctx WidgetNode sp ep
newRoot
IO () -> m ()
forall a. IO a -> m a
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
Lens' (MonomerCtx sp ep) Bool
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 s e -> MainLoopArgs sp e ep -> m ()
forall sp ep (m :: * -> *) e s.
(MonomerM sp ep m, WidgetEvent e) =>
Window
-> FontManager -> AppConfig s e -> MainLoopArgs sp e ep -> m ()
mainLoop Window
window FontManager
fontManager AppConfig s e
config MainLoopArgs sp e ep
newLoopArgs)
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 <- IO () -> IO (Either SDLException ())
forall e a. Exception e => IO a -> IO (Either e a)
try (IO () -> IO (Either SDLException ()))
-> IO () -> IO (Either SDLException ())
forall a b. (a -> b) -> a -> b
$ Window -> GLContext -> IO ()
forall (m :: * -> *).
(Functor m, MonadIO m) =>
Window -> GLContext -> m ()
SDL.glMakeCurrent Window
window GLContext
glCtx
case Either SDLException ()
resp of
Right{} -> do
Renderer
renderer <- IO Renderer -> IO Renderer
forall a. IO a -> IO a
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 a. IO a -> IO a
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
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan RenderSetupResult -> RenderSetupResult -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan RenderSetupResult
setupChan RenderSetupResult
RenderSetupMulti
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)
msgChan Window
window Renderer
renderer FontManager
fontMgr RenderState s e
state
Left (SDL.SDLCallFailed Text
_ Text
_ Text
err) -> do
let msg :: String
msg = Text -> String
T.unpack Text
err
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan RenderSetupResult -> RenderSetupResult -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan RenderSetupResult
setupChan (String -> RenderSetupResult
RenderSetupMakeCurrentFailed String
msg)
Left SDLException
e -> do
let msg :: String
msg = SDLException -> String
forall e. Exception e => e -> String
displayException SDLException
e
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan RenderSetupResult -> RenderSetupResult -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan RenderSetupResult
setupChan (String -> RenderSetupResult
RenderSetupMakeCurrentFailed String
msg)
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 :: 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 <- 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)
msgChan
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)
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
RenderState s e -> IO (RenderState s e)
forall a. a -> IO a
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 (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
Lens' (WidgetEnv s e) FontManager
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
Lens' (WidgetEnv s e) Theme
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
Lens' Theme Color
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 a. a -> IO a
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
Lens' Size Double
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
Lens' Size Double
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
Lens' (WidgetEnv s e) FontManager
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
Lens' (WidgetEnv s e) Size
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
Lens' (WidgetEnv s e) Rect
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
Lens' (WidgetEnv s e) Theme
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
Lens' Theme Color
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
Lens' (WidgetNode s e) (Widget s e)
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
Lens' (WidgetResult s e) (WidgetNode s e)
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 a. a -> IO a
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 a. a -> IO a
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 a. a -> IO a
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
GLint -> GLint -> GLint -> GLint -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLint -> GLint -> GLint -> GLint -> m ()
glViewport GLint
0 GLint
0 (Double -> GLint
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
dwW) (Double -> GLint
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
dwH)
GLfloat -> GLfloat -> GLfloat -> GLfloat -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLfloat -> GLfloat -> GLfloat -> GLfloat -> m ()
glClearColor GLfloat
r GLfloat
g GLfloat
b GLfloat
a
Word32 -> IO ()
forall (m :: * -> *). MonadIO m => Word32 -> m ()
glClear Word32
GL_COLOR_BUFFER_BIT
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
Lens' (WidgetNode s e) (Widget s e)
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
Lens' Color Int
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
Lens' Color Int
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
Lens' Color Int
L.b) GLfloat -> GLfloat -> GLfloat
forall a. Fractional a => a -> a -> a
/ GLfloat
255
a :: GLfloat
a = Double -> GLfloat
forall a b. (Real a, Fractional b) => a -> b
realToFrac (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
Lens' Color Double
L.a)
watchWindowResize :: TChan (RenderMsg s e) -> IO ()
watchWindowResize :: forall s e. 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 a. a -> IO a
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 <- 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
Lens' (MonomerCtx s e) Bool
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
Lens' (MonomerCtx s e) (Map WidgetId RenderSchedule)
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
Lens' (MonomerCtx s e) (Map WidgetId RenderSchedule)
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 (Millisecond -> RenderSchedule -> Bool
renderScheduleActive Millisecond
currTs) Map WidgetId RenderSchedule
schedule
Bool -> m Bool
forall a. a -> m a
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 = Millisecond -> Millisecond -> RenderSchedule -> Bool
renderScheduleReq Millisecond
currTs Millisecond
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 :: 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 = Double -> Millisecond
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Millisecond -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Millisecond
currTs Millisecond -> Millisecond -> Millisecond
forall a. Num a => a -> a -> a
- Millisecond
start) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Millisecond -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Millisecond
ms)
stepTs :: Millisecond
stepTs = Millisecond
start Millisecond -> Millisecond -> Millisecond
forall a. Num a => a -> a -> a
+ Millisecond
ms Millisecond -> Millisecond -> Millisecond
forall a. Num a => a -> a -> a
* Millisecond
stepCount
required :: Bool
required = Millisecond
renderTs Millisecond -> Millisecond -> Bool
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 = Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Millisecond -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Millisecond
currTs Millisecond -> Millisecond -> Millisecond
forall a. Num a => a -> a -> a
- Millisecond
start) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Millisecond -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Millisecond
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 a. [a] -> 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 a. [a] -> 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 a. [a] -> Bool
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 (UTCTime -> Millisecond) -> m UTCTime -> m Millisecond
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
where
toMs :: UTCTime -> Millisecond
toMs = Pico -> Millisecond
forall b. Integral b => Pico -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Pico -> Millisecond)
-> (UTCTime -> Pico) -> UTCTime -> Millisecond
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pico
1e3 Pico -> Pico -> Pico
forall a. Num a => a -> a -> a
*) (Pico -> Pico) -> (UTCTime -> Pico) -> UTCTime -> Pico
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTime -> Pico
nominalDiffTimeToSeconds (NominalDiffTime -> Pico)
-> (UTCTime -> NominalDiffTime) -> UTCTime -> Pico
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 <- m Millisecond
forall (m :: * -> *). MonadIO m => m Millisecond
getCurrentTimestamp
Millisecond -> m Millisecond
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Millisecond
ts Millisecond -> Millisecond -> Millisecond
forall a. Num a => a -> a -> a
- Millisecond
start)
reloadStoreId :: Word32
reloadStoreId :: Word32
reloadStoreId = Word32
0
getReloadData :: IO (Maybe (MonomerReloadData s e))
getReloadData :: forall s e. IO (Maybe (MonomerReloadData s e))
getReloadData = Word32 -> IO (Maybe (Store Any))
forall a. Word32 -> IO (Maybe (Store a))
FS.lookupStore Word32
reloadStoreId IO (Maybe (Store Any))
-> (Maybe (Store Any) -> IO (Maybe (MonomerReloadData s e)))
-> IO (Maybe (MonomerReloadData s e))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just{} -> MonomerReloadData s e -> Maybe (MonomerReloadData s e)
forall a. a -> Maybe a
Just (MonomerReloadData s e -> Maybe (MonomerReloadData s e))
-> IO (MonomerReloadData s e) -> IO (Maybe (MonomerReloadData s e))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Store (MonomerReloadData s e) -> IO (MonomerReloadData s e)
forall a. Store a -> IO a
FS.readStore (Word32 -> Store (MonomerReloadData s e)
forall a. Word32 -> Store a
FS.Store Word32
reloadStoreId)
Maybe (Store Any)
_ -> Maybe (MonomerReloadData s e) -> IO (Maybe (MonomerReloadData s e))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (MonomerReloadData s e)
forall a. Maybe a
Nothing
setReloadData :: MonomerReloadData s e -> IO ()
setReloadData :: forall s e. MonomerReloadData s e -> IO ()
setReloadData = Store (MonomerReloadData s e) -> MonomerReloadData s e -> IO ()
forall a. Store a -> a -> IO ()
FS.writeStore (Word32 -> Store (MonomerReloadData s e)
forall a. Word32 -> Store a
FS.Store Word32
reloadStoreId)
resetReloadData :: IO ()
resetReloadData :: IO ()
resetReloadData = Store Any -> IO ()
forall a. Store a -> IO ()
FS.deleteStore (Word32 -> Store Any
forall a. Word32 -> Store a
FS.Store Word32
reloadStoreId)
updateReloadData :: MonomerCtx s e -> WidgetNode s e -> IO ()
updateReloadData :: forall s e. MonomerCtx s e -> WidgetNode s e -> IO ()
updateReloadData MonomerCtx s e
context WidgetNode s e
widgetRoot = do
IO (Maybe (MonomerReloadData Any Any))
-> (MonomerReloadData Any Any -> IO ()) -> IO ()
forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> (a -> m ()) -> m ()
whenJustM IO (Maybe (MonomerReloadData Any Any))
forall s e. IO (Maybe (MonomerReloadData s e))
getReloadData ((MonomerReloadData Any Any -> IO ()) -> IO ())
-> (MonomerReloadData Any Any -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \MonomerReloadData Any Any
rd ->
MonomerReloadData s e -> IO ()
forall s e. MonomerReloadData s e -> IO ()
setReloadData MonomerReloadData Any Any
rd {
_mrdMonomerCtx = context,
_mrdRoot = widgetRoot
}
retrieveSDLWindow
:: AppConfig s e
-> TChan (RenderMsg s e)
-> s
-> IO (SDL.Window, SDL.GLContext, MonomerCtx s e)
retrieveSDLWindow :: forall s e.
AppConfig s e
-> TChan (RenderMsg s e)
-> s
-> IO (Window, GLContext, MonomerCtx s e)
retrieveSDLWindow AppConfig s e
config TChan (RenderMsg s e)
channel s
model = do
IO (Maybe (MonomerReloadData Any Any))
forall s e. IO (Maybe (MonomerReloadData s e))
getReloadData IO (Maybe (MonomerReloadData Any Any))
-> (Maybe (MonomerReloadData Any Any)
-> IO (Window, GLContext, MonomerCtx s e))
-> IO (Window, GLContext, MonomerCtx s e)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just MonomerReloadData Any Any
rd -> (Window, GLContext, MonomerCtx s e)
-> IO (Window, GLContext, MonomerCtx s e)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (MonomerReloadData Any Any -> Window
forall s e. MonomerReloadData s e -> Window
_mrdWindow MonomerReloadData Any Any
rd, MonomerReloadData Any Any -> GLContext
forall s e. MonomerReloadData s e -> GLContext
_mrdGlContext MonomerReloadData Any Any
rd, MonomerCtx s e
newCtx) where
ctx :: MonomerCtx Any Any
ctx = MonomerReloadData Any Any -> MonomerCtx Any Any
forall s e. MonomerReloadData s e -> MonomerCtx s e
_mrdMonomerCtx MonomerReloadData Any Any
rd
newCtx :: MonomerCtx s e
newCtx = MonomerCtx Any Any
ctx {
_mcMainModel = model,
_mcRenderMethod = Right channel
}
Maybe (MonomerReloadData Any Any)
Nothing -> do
(Window
window, Double
dpr, Double
epr, GLContext
ctxRender) <- AppConfig s e -> IO (Window, Double, Double, GLContext)
forall s e. AppConfig s e -> IO (Window, Double, Double, GLContext)
initSDLWindow AppConfig s e
config
Size
vpSize <- Window -> Double -> IO Size
getViewportSize Window
window Double
dpr
let newCtx :: MonomerCtx s e
newCtx = Window
-> TChan (RenderMsg s e)
-> Size
-> Double
-> Double
-> s
-> MonomerCtx s e
forall s e.
Window
-> TChan (RenderMsg s e)
-> Size
-> Double
-> Double
-> s
-> MonomerCtx s e
initMonomerCtx Window
window TChan (RenderMsg s e)
channel Size
vpSize Double
dpr Double
epr s
model
(Window, GLContext, MonomerCtx s e)
-> IO (Window, GLContext, MonomerCtx s e)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Window
window, GLContext
ctxRender, MonomerCtx s e
newCtx)
retrieveModelAndRoot
:: WidgetModel s
=> AppConfig s e
-> s
-> WidgetNode s e
-> IO (s, Maybe (WidgetNode s e))
retrieveModelAndRoot :: forall s e.
WidgetModel s =>
AppConfig s e
-> s -> WidgetNode s e -> IO (s, Maybe (WidgetNode s e))
retrieveModelAndRoot AppConfig s e
config s
newModel WidgetNode s e
newRoot = IO (Maybe (MonomerReloadData s e))
forall s e. IO (Maybe (MonomerReloadData s e))
getReloadData IO (Maybe (MonomerReloadData s e))
-> (Maybe (MonomerReloadData s e)
-> IO (s, Maybe (WidgetNode s e)))
-> IO (s, Maybe (WidgetNode s e))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just MonomerReloadData s e
rd
| Bool
attemptModelReuse Bool -> Bool -> Bool
&& String
fingerprint String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== MonomerReloadData s e -> String
forall s e. MonomerReloadData s e -> String
_mrdModelFp MonomerReloadData s e
rd ->
(s, Maybe (WidgetNode s e)) -> IO (s, Maybe (WidgetNode s e))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (MonomerReloadData s e -> MonomerCtx s e
forall s e. MonomerReloadData s e -> MonomerCtx s e
_mrdMonomerCtx MonomerReloadData s e
rd MonomerCtx s e -> Getting s (MonomerCtx s e) s -> s
forall s a. s -> Getting a s a -> a
^. Getting s (MonomerCtx s e) s
forall s a. HasMainModel s a => Lens' s a
Lens' (MonomerCtx s e) s
L.mainModel, WidgetNode s e -> Maybe (WidgetNode s e)
forall a. a -> Maybe a
Just (MonomerReloadData s e -> WidgetNode s e
forall s e. MonomerReloadData s e -> WidgetNode s e
_mrdRoot MonomerReloadData s e
rd))
Maybe (MonomerReloadData s e)
_ -> do
(s, Maybe (WidgetNode s e)) -> IO (s, Maybe (WidgetNode s e))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (s
newModel, Maybe (WidgetNode s e)
forall a. Maybe a
Nothing)
where
attemptModelReuse :: Bool
attemptModelReuse = Maybe (s -> String) -> Bool
forall a. Maybe a -> Bool
isJust (AppConfig s e -> Maybe (s -> String)
forall s e. AppConfig s e -> Maybe (s -> String)
_apcModelFingerprintFn AppConfig s e
config)
~String
fingerprint = Maybe (s -> String) -> s -> String
forall a. HasCallStack => Maybe a -> a
fromJust (AppConfig s e -> Maybe (s -> String)
forall s e. AppConfig s e -> Maybe (s -> String)
_apcModelFingerprintFn AppConfig s e
config) s
newModel