From 76d74a89f47c4c11dc96f2db77c91fb797b4eed7 Mon Sep 17 00:00:00 2001 From: Francisco Vallarino Date: Wed, 22 Sep 2021 18:21:19 -0300 Subject: [PATCH] Add support for RunInRenderThread. Add dpr field to WidgetEnv --- src/Monomer/Core/WidgetTypes.hs | 8 ++++++++ src/Monomer/Helper.hs | 5 +++++ src/Monomer/Main/Core.hs | 8 ++++++++ src/Monomer/Main/Handlers.hs | 20 +++++++++++++++++++- src/Monomer/Main/Types.hs | 2 +- src/Monomer/Widgets/Composite.hs | 2 ++ src/Monomer/Widgets/Singles/ExternalLink.hs | 5 +---- test/unit/Monomer/TestUtil.hs | 1 + 8 files changed, 45 insertions(+), 6 deletions(-) diff --git a/src/Monomer/Core/WidgetTypes.hs b/src/Monomer/Core/WidgetTypes.hs index a21318a2..863f2728 100644 --- a/src/Monomer/Core/WidgetTypes.hs +++ b/src/Monomer/Core/WidgetTypes.hs @@ -225,6 +225,11 @@ data WidgetRequest s e -- for WebSockets and similar data sources. It receives a function that -- can be used to send messages back to the producer owner. | forall i . Typeable i => RunProducer WidgetId Path ((i -> IO ()) -> IO ()) + -- | Runs an asynchronous tasks in the render thread. It is mandatory to + -- return a message that will be sent to the task owner (this is the only + -- way to feed data back). This should only be used when implementing low + -- level rendering widgets that need to create API specific resources. + | forall i . Typeable i => RunInRenderThread WidgetId Path (IO i) instance Eq e => Eq (WidgetRequest s e) where IgnoreParentEvents == IgnoreParentEvents = True @@ -286,6 +291,8 @@ data LayoutDirection data WidgetEnv s e = WidgetEnv { -- | The OS of the host. _weOs :: Text, + -- | Device pixel rate. + _weDpr :: Double, -- | Provides helper funtions for calculating text size. _weFontManager :: FontManager, -- | Returns the information of a node given a path from root, if any. @@ -703,6 +710,7 @@ instance Show (WidgetRequest s e) where show SendMessage{} = "SendMessage" show RunTask{} = "RunTask" show RunProducer{} = "RunProducer" + show RunInRenderThread{} = "RunInRenderThread" instance Show (WidgetResult s e) where show result = "WidgetResult " diff --git a/src/Monomer/Helper.hs b/src/Monomer/Helper.hs index 2c911080..0987fbb5 100644 --- a/src/Monomer/Helper.hs +++ b/src/Monomer/Helper.hs @@ -11,6 +11,7 @@ module and are not directly exported. -} module Monomer.Helper where +import Control.Exception (SomeException, catch) import Control.Monad.IO.Class (MonadIO) import Data.Sequence (Seq(..)) @@ -63,3 +64,7 @@ maxNumericValue = x where -- | Restricts a value to a given range. clamp :: (Ord a) => a -> a -> a -> a clamp mn mx = max mn . min mx + +-- | Catches any exception thrown by the provided action +catchAny :: IO a -> (SomeException -> IO a) -> IO a +catchAny = catch diff --git a/src/Monomer/Main/Core.hs b/src/Monomer/Main/Core.hs index f9630e33..b01fd35c 100644 --- a/src/Monomer/Main/Core.hs +++ b/src/Monomer/Main/Core.hs @@ -47,6 +47,7 @@ import Monomer.Main.Types import Monomer.Main.Util import Monomer.Main.WidgetTask import Monomer.Graphics +import Monomer.Helper (catchAny) import Monomer.Widgets.Composite import qualified Monomer.Lens as L @@ -152,6 +153,7 @@ runAppLoop window glCtx channel widgetRoot config = do let wenv = WidgetEnv { _weOs = os, + _weDpr = dpr, _weFontManager = fontManager, _weFindByPath = const Nothing, _weMainButton = mainBtn, @@ -258,6 +260,7 @@ mainLoop window fontManager config loopArgs = do let contextBtn = fromMaybe BtnRight (_apcContextButton config) let wenv = WidgetEnv { _weOs = _mlOS, + _weDpr = dpr, _weFontManager = fontManager, _weFindByPath = findWidgetByPath wenv _mlWidgetRoot, _weMainButton = mainBtn, @@ -410,6 +413,11 @@ handleRenderMsg window renderer fontMgr state (MsgResize _) = do handleRenderMsg window renderer fontMgr state (MsgRemoveImage name) = do deleteImage renderer name return state +handleRenderMsg window renderer fontMgr state (MsgRunInRender chan task) = do + flip catchAny print $ do + value <- task + atomically $ writeTChan chan value + return state renderWidgets :: SDL.Window diff --git a/src/Monomer/Main/Handlers.hs b/src/Monomer/Main/Handlers.hs index f2bf4f46..abc7ab84 100644 --- a/src/Monomer/Main/Handlers.hs +++ b/src/Monomer/Main/Handlers.hs @@ -29,7 +29,7 @@ import Control.Concurrent.Async (async) import Control.Lens ((&), (^.), (^?), (.~), (?~), (%~), (.=), (?=), (%=), (%%~), _Just, _1, _2, ix, at, use) import Control.Monad.STM (atomically) -import Control.Concurrent.STM.TChan (TChan, newTChanIO, writeTChan) +import Control.Concurrent.STM.TChan (TChan, newTChanIO, readTChan, writeTChan) import Control.Applicative ((<|>)) import Control.Monad import Control.Monad.IO.Class @@ -251,6 +251,7 @@ handleRequests reqs step = foldM handleRequest step reqs where SendMessage wid msg -> handleSendMessage wid msg step RunTask wid path handler -> handleRunTask wid path handler step RunProducer wid path handler -> handleRunProducer wid path handler step + RunInRenderThread wid path handler -> handleRunInRenderThread wid path handler step -- | Resizes the current root, and marks the render and resized flags. handleResizeWidgets @@ -653,6 +654,23 @@ handleRunProducer widgetId path handler previousStep = do return previousStep +handleRunInRenderThread + :: forall s e m i . (MonomerM s e m, Typeable i) + => WidgetId + -> Path + -> IO i + -> HandlerStep s e + -> m (HandlerStep s e) +handleRunInRenderThread widgetId path handler previousStep = do + renderChannel <- use L.renderChannel + + handleRunTask widgetId path (taskWrapper renderChannel) previousStep + where + taskWrapper renderChannel = do + msgChan <- newTChanIO + atomically $ writeTChan renderChannel (MsgRunInRender msgChan handler) + atomically $ readTChan msgChan + sendMessage :: TChan e -> e -> IO () sendMessage channel message = atomically $ writeTChan channel message diff --git a/src/Monomer/Main/Types.hs b/src/Monomer/Main/Types.hs index cdbcc324..6933ee4b 100644 --- a/src/Monomer/Main/Types.hs +++ b/src/Monomer/Main/Types.hs @@ -50,7 +50,7 @@ data RenderMsg s e = MsgRender (WidgetEnv s e) (WidgetNode s e) | MsgResize Size | MsgRemoveImage Text - deriving Show + | forall i . MsgRunInRender (TChan i) (IO i) {-| Requirements for periodic rendering by a widget. Start time is stored to diff --git a/src/Monomer/Widgets/Composite.hs b/src/Monomer/Widgets/Composite.hs index 3e779836..09d595a8 100644 --- a/src/Monomer/Widgets/Composite.hs +++ b/src/Monomer/Widgets/Composite.hs @@ -866,6 +866,7 @@ toParentReq wid (RaiseEvent message) = Just (SendMessage wid message) toParentReq _ (SendMessage wid message) = Just (SendMessage wid message) toParentReq _ (RunTask wid path action) = Just (RunTask wid path action) toParentReq _ (RunProducer wid path action) = Just (RunProducer wid path action) +toParentReq _ (RunInRenderThread wid path action) = Just (RunInRenderThread wid path action) collectWidgetKeys :: Map WidgetKey (WidgetNode s e) @@ -882,6 +883,7 @@ collectWidgetKeys keys node = newMap where convertWidgetEnv :: WidgetEnv sp ep -> WidgetKeyMap s e -> s -> WidgetEnv s e convertWidgetEnv wenv widgetKeyMap model = WidgetEnv { _weOs = _weOs wenv, + _weDpr = _weDpr wenv, _weFontManager = _weFontManager wenv, _weFindByPath = _weFindByPath wenv, _weMainButton = _weMainButton wenv, diff --git a/src/Monomer/Widgets/Singles/ExternalLink.hs b/src/Monomer/Widgets/Singles/ExternalLink.hs index 6ed29f2d..4d0b6086 100644 --- a/src/Monomer/Widgets/Singles/ExternalLink.hs +++ b/src/Monomer/Widgets/Singles/ExternalLink.hs @@ -24,7 +24,6 @@ module Monomer.Widgets.Singles.ExternalLink ( ) where import Control.Applicative ((<|>)) -import Control.Exception (SomeException, catch) import Control.Lens ((&), (^.), (.~)) import Data.Default import Data.Maybe @@ -34,6 +33,7 @@ import System.Process (callCommand) import qualified Data.Sequence as Seq import qualified Data.Text as T +import Monomer.Helper (catchAny) import Monomer.Widgets.Container import Monomer.Widgets.Singles.Label @@ -232,6 +232,3 @@ openLink wenv url = catchIgnore (callCommand openCommand) where catchIgnore :: IO () -> IO () catchIgnore task = catchAny task (const $ return ()) - -catchAny :: IO a -> (SomeException -> IO a) -> IO a -catchAny = catch diff --git a/test/unit/Monomer/TestUtil.hs b/test/unit/Monomer/TestUtil.hs index 69fa838c..a21be3c1 100644 --- a/test/unit/Monomer/TestUtil.hs +++ b/test/unit/Monomer/TestUtil.hs @@ -159,6 +159,7 @@ mockFontManager = FontManager { mockWenv :: s -> WidgetEnv s e mockWenv model = WidgetEnv { _weOs = "Mac OS X", + _weDpr = 2, _weFontManager = mockFontManager, _weFindByPath = const Nothing, _weMainButton = BtnLeft,