Add support for RunInRenderThread. Add dpr field to WidgetEnv

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 "

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

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

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
 

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

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,

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

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,