Initial support for continuous windows resize

monomer.cabal

@@ -192,6 +192,7 @@ executable books
       examples/books
   default-extensions:
       OverloadedStrings
+  ghc-options: -threaded
   build-depends:
       JuicyPixels
     , OpenGL
@@ -369,6 +370,7 @@ executable todo
       examples/todo
   default-extensions:
       OverloadedStrings
+  ghc-options: -threaded
   build-depends:
       JuicyPixels
     , OpenGL

package.yaml

@@ -89,6 +89,8 @@ executables:
   books:
     main: Main.hs
     source-dirs: examples/books
+    ghc-options:
+    - -threaded
     dependencies:
     - aeson
     - lens
@@ -120,6 +122,8 @@ executables:
   todo:
     main: Main.hs
     source-dirs: examples/todo
+    ghc-options:
+    - -threaded
     dependencies:
     - lens
     - monomer

src/Monomer/Graphics/NanoVGRenderer.hs

@@ -115,15 +115,17 @@ makeRenderer fonts dpr = do
   return $ newRenderer c dpr lock envRef
 
 newRenderer :: VG.Context -> Double -> L.Lock -> IORef Env -> Renderer
-newRenderer c dpr lock envRef = Renderer {..} where
+newRenderer c rdpr lock envRef = Renderer {..} where
+  dpr = 1
+
   beginFrame w h = do
-    newEnv <- handlePendingImages c envRef
+    newEnv <- L.with lock $ handlePendingImages c envRef
 
     VG.beginFrame c cw ch cdpr
     where
-      cw = fromIntegral w
-      ch = fromIntegral h
-      cdpr = realToFrac dpr
+      cw = realToFrac (w / dpr)
+      ch = realToFrac (h / dpr)
+      cdpr = realToFrac rdpr
 
   endFrame =
     VG.endFrame c

src/Monomer/Graphics/Types.hs

@@ -220,7 +220,7 @@ data FontManager = FontManager {
 -- | Low level rendering definitions.
 data Renderer = Renderer {
   -- | Begins a new frame.
-  beginFrame :: Int -> Int -> IO (),
+  beginFrame :: Double -> Double -> IO (),
   -- | Finishes a frame, consolidating the drawing operations since beginFrame.
   endFrame :: IO (),
   -- | Begins a new path

src/Monomer/Main/Core.hs

@@ -19,11 +19,14 @@ module Monomer.Main.Core (
   startApp
 ) where
 
-import Control.Concurrent (MVar, newMVar, threadDelay)
+import Control.Concurrent (MVar, forkIO, forkOS, newMVar, threadDelay)
+import Control.Concurrent.STM.TChan (TChan, newTChanIO, readTChan, tryReadTChan, writeTChan)
 import Control.Lens ((&), (^.), (.=), (.~), use)
+import Control.Monad (unless, void, when)
 import Control.Monad.Catch
 import Control.Monad.Extra
 import Control.Monad.State
+import Control.Monad.STM (atomically)
 import Data.Default
 import Data.Maybe
 import Data.Map (Map)
@@ -72,9 +75,78 @@ data MainLoopArgs s e ep = MainLoopArgs {
   _mlFrameCount :: Int,
   _mlExitEvents :: [e],
   _mlWidgetRoot :: WidgetNode s ep,
-  _mlWidgetShared :: MVar (Map Text WidgetShared)
+  _mlWidgetShared :: MVar (Map Text WidgetShared),
+  _mlChannel :: TChan (RenderMsg s ep)
 }
 
+data RenderMsg s e
+  = MsgResize Size
+  | MsgRender (WidgetEnv s e) (WidgetNode s e)
+  deriving Show
+
+data RenderState s e = RenderState {
+  _rstColor :: Color,
+  _rstWidgetEnv :: WidgetEnv s e,
+  _rstRootNode :: WidgetNode s e
+}
+
+runUI
+  :: (Eq s, WidgetEvent e)
+  => TChan (RenderMsg s e)
+  -> SDL.Window
+  -> SDL.GLContext
+  -> [FontDef]
+  -> Double
+  -> (Double, Double)
+  -> Color
+  -> WidgetEnv s e
+  -> WidgetNode s e
+  -> IO ()
+runUI channel window glCtx fonts dpr (rw, rh) color wenv root = do
+  SDL.glMakeCurrent window glCtx
+  renderer <- liftIO $ makeRenderer fonts dpr
+  resizeWindow window dpr
+  -- Hack, otherwise glyph positions are invalid until nanovg is initialized
+  liftIO $ beginFrame renderer rw rh
+  liftIO $ endFrame renderer
+
+  waitUIMsg channel window renderer state
+  where
+    state = RenderState color wenv root
+
+waitUIMsg
+  :: (Eq s, WidgetEvent e)
+  => TChan (RenderMsg s e)
+  -> SDL.Window
+  -> Renderer
+  -> RenderState s e
+  -> IO ()
+waitUIMsg channel window renderer state = do
+  msg <- liftIO . atomically $ readTChan channel
+  newState <- handleUIMsg window renderer state msg
+  waitUIMsg channel window renderer newState
+
+handleUIMsg
+  :: (Eq s, WidgetEvent e)
+  => SDL.Window
+  -> Renderer
+  -> RenderState s e
+  -> RenderMsg s e
+  -> IO (RenderState s e)
+handleUIMsg window renderer state (MsgRender newWenv newRoot) = do
+  let RenderState color _ _ = state
+  renderWidgets window renderer color newWenv newRoot
+  return (RenderState color newWenv newRoot)
+handleUIMsg window renderer state (MsgResize newSize) = do
+  let RenderState color wenv root = state
+  let viewport = Rect 0 0 (newSize ^. L.w) (newSize ^. L.h)
+  let result = widgetResize (root ^. L.widget) wenv root viewport
+  let newRoot = result ^. L.node
+
+  print ("Resizing MsgResize", newSize)
+  renderWidgets window renderer color wenv newRoot
+  return (RenderState color wenv newRoot)
+
 {-|
 Runs an application, creating the UI with the provided function and initial
 model, handling future events with the event handler.
@@ -90,12 +162,14 @@ startApp
   -> [AppConfig e]        -- ^ The application config.
   -> IO ()                -- ^ The application action.
 startApp model eventHandler uiBuilder configs = do
-  (window, dpr, epr) <- initSDLWindow config
-  winSize <- getDrawableSize window
+  (window, dpr, epr, glCtx) <- initSDLWindow config
+--  winSize <- getDrawableSize window
+  winSize <- getWindowSize window dpr
+  channel <- newTChanIO
 
   let monomerCtx = initMonomerCtx model window winSize dpr epr
 
-  runStateT (runAppLoop window appWidget config) monomerCtx
+  runStateT (runAppLoop window glCtx channel appWidget config) monomerCtx
   detroySDLWindow window
   where
     config = mconcat configs
@@ -106,16 +180,18 @@ startApp model eventHandler uiBuilder configs = do
     appWidget = composite_ "app" id uiBuilder eventHandler compCfgs
 
 runAppLoop
-  :: (MonomerM s m, WidgetEvent e)
+  :: (MonomerM s m, Eq s, WidgetEvent e, WidgetEvent ep)
   => SDL.Window
+  -> SDL.GLContext
+  -> TChan (RenderMsg s ep)
   -> WidgetNode s ep
   -> AppConfig e
   -> m ()
-runAppLoop window widgetRoot config = do
+runAppLoop window glCtx channel widgetRoot config = do
   dpr <- use L.dpr
   Size rw rh <- use L.windowSize
 
-  let newWindowSize = Size (rw / dpr) (rh / dpr)
+  let newWinSize = Size rw rh
   let maxFps = fromMaybe 60 (_apcMaxFps config)
   let fonts = _apcFonts config
   let theme = fromMaybe def (_apcTheme config)
@@ -123,18 +199,11 @@ runAppLoop window widgetRoot config = do
   let mainBtn = fromMaybe BtnLeft (_apcMainButton config)
   let contextBtn = fromMaybe BtnRight (_apcContextButton config)
 
-  resizeWindow window
   startTs <- fmap fromIntegral SDL.ticks
   model <- use L.mainModel
   os <- getPlatform
   widgetSharedMVar <- liftIO $ newMVar Map.empty
-
-  renderer <- liftIO $ makeRenderer fonts dpr
   fontManager <- liftIO $ makeFontManager fonts dpr
-  L.renderer .= Just renderer
-  -- Hack, otherwise glyph positions are invalid until nanovg is initialized
-  liftIO $ beginFrame renderer (round rw) (round rh)
-  liftIO $ endFrame renderer
 
   let wenv = WidgetEnv {
     _weOs = os,
@@ -143,7 +212,7 @@ runAppLoop window widgetRoot config = do
     _weMainButton = mainBtn,
     _weContextButton = contextBtn,
     _weTheme = theme,
-    _weWindowSize = newWindowSize,
+    _weWindowSize = newWinSize,
     _weWidgetShared = widgetSharedMVar,
     _weWidgetKeyMap = Map.empty,
     _weCursor = Nothing,
@@ -178,22 +247,28 @@ runAppLoop window widgetRoot config = do
     _mlFrameCount = 0,
     _mlExitEvents = exitEvents,
     _mlWidgetRoot = newRoot,
-    _mlWidgetShared = widgetSharedMVar
+    _mlWidgetShared = widgetSharedMVar,
+    _mlChannel = channel
   }
 
   L.mainModel .= _weModel newWenv
 
-  mainLoop window fontManager renderer config loopArgs
+  let bgColor = _themeClearColor theme
+
+  liftIO . forkOS . void $
+    runUI channel window glCtx fonts dpr (rw, rh) bgColor newWenv newRoot
+
+  liftIO $ watchWindowResize channel
+  mainLoop window fontManager config loopArgs
 
 mainLoop
   :: (MonomerM s m, WidgetEvent e)
   => SDL.Window
   -> FontManager
-  -> Renderer
   -> AppConfig e
   -> MainLoopArgs s e ep
   -> m ()
-mainLoop window fontManager renderer config loopArgs = do
+mainLoop window fontManager config loopArgs = do
   let MainLoopArgs{..} = loopArgs
 
   startTicks <- fmap fromIntegral SDL.ticks
@@ -211,13 +286,14 @@ mainLoop window fontManager renderer config loopArgs = do
   mainPress <- use L.mainBtnPress
   inputStatus <- use L.inputStatus
   mousePos <- getCurrentMousePos epr
+  currSize <- getWindowSize window dpr
 
   let Size rw rh = windowSize
   let ts = startTicks - _mlFrameStartTs
   let eventsPayload = fmap SDL.eventPayload events
   let quit = SDL.QuitEvent `elem` eventsPayload
 
-  let windowResized = isWindowResized eventsPayload
+  let windowResized = currSize /= windowSize && isWindowResized eventsPayload
   let windowExposed = isWindowExposed eventsPayload
   let mouseEntered = isMouseEntered eventsPayload
   let baseSystemEvents = convertEvents dpr epr mousePos eventsPayload
@@ -272,7 +348,7 @@ mainLoop window fontManager renderer config loopArgs = do
 
   (newWenv, newRoot, _) <- if windowResized
     then do
-      resizeWindow window
+--      liftIO $ resizeWindow window dpr
       handleResizeWidgets (seWenv, seRoot, Seq.empty)
     else return (seWenv, seRoot, Seq.empty)
 
@@ -286,7 +362,7 @@ mainLoop window fontManager renderer config loopArgs = do
   let renderNeeded = winRedrawEvt || renderEvent || renderCurrentReq
 
   when renderNeeded $
-    renderWidgets window renderer (_themeClearColor _mlTheme) newWenv newRoot
+    liftIO . atomically $ writeTChan _mlChannel (MsgRender newWenv newRoot)
 
   L.renderRequested .= windowResized
 
@@ -312,7 +388,18 @@ mainLoop window fontManager renderer config loopArgs = do
   when shouldQuit $
     void $ handleWidgetDispose newWenv newRoot
 
-  unless shouldQuit (mainLoop window fontManager renderer config newLoopArgs)
+  unless shouldQuit (mainLoop window fontManager config newLoopArgs)
+
+watchWindowResize :: TChan (RenderMsg s e) -> IO ()
+watchWindowResize channel = do
+  void . SDL.addEventWatch $ \ev -> do
+    case SDL.eventPayload ev of
+      SDL.WindowSizeChangedEvent sizeChangeData -> do
+        let SDL.V2 nw nh = SDL.windowSizeChangedEventSize sizeChangeData
+        let newSize = Size (fromIntegral nw) (fromIntegral nh)
+
+        atomically $ writeTChan channel (MsgResize newSize)
+      _ -> return ()
 
 checkRenderCurrent :: (MonomerM s m) => Int -> Int -> m Bool
 checkRenderCurrent currTs renderTs = do
@@ -340,26 +427,26 @@ renderScheduleActive currTs renderTs schedule = scheduleActive where
   scheduleActive = maybe True (> stepsDone) count
 
 renderWidgets
-  :: (MonomerM s m)
-  => SDL.Window
+  :: SDL.Window
   -> Renderer
   -> Color
   -> WidgetEnv s e
   -> WidgetNode s e
-  -> m ()
+  -> IO ()
 renderWidgets !window renderer clearColor wenv widgetRoot = do
-  SDL.V2 fbWidth fbHeight <- SDL.glGetDrawableSize window
+--  SDL.V2 fbWidth fbHeight <- SDL.glGetDrawableSize window
+  Size winW winH <- getWindowSize window 2
 
   liftIO $ GL.clearColor GL.$= clearColor4
   liftIO $ GL.clear [GL.ColorBuffer]
 
-  liftIO $ beginFrame renderer (fromIntegral fbWidth) (fromIntegral fbHeight)
+  liftIO $ beginFrame renderer winW winH
   liftIO $ widgetRender (widgetRoot ^. L.widget) wenv widgetRoot renderer
   liftIO $ endFrame renderer
 
   liftIO $ renderRawTasks renderer
 
-  liftIO $ beginFrame renderer (fromIntegral fbWidth) (fromIntegral fbHeight)
+  liftIO $ beginFrame renderer winW winH
   liftIO $ renderOverlays renderer
   liftIO $ endFrame renderer
 
@@ -374,18 +461,17 @@ renderWidgets !window renderer clearColor wenv widgetRoot = do
     clearColor4 = GL.Color4 r g b (realToFrac a)
 
 resizeWindow
-  :: (MonomerM s m)
-  => SDL.Window
-  -> m ()
-resizeWindow window = do
-  dpr <- use L.dpr
+  :: SDL.Window
+  -> Double
+  -> IO ()
+resizeWindow window dpr = do
   drawableSize <- getDrawableSize window
   windowSize <- getWindowSize window dpr
 
   let position = GL.Position 0 0
   let size = GL.Size (round $ _sW drawableSize) (round $ _sH drawableSize)
 
-  L.windowSize .= windowSize
+--  L.windowSize .= windowSize
   liftIO $ GL.viewport GL.$= (position, size)
 
 isWindowResized :: [SDL.EventPayload] -> Bool

src/Monomer/Main/Handlers.hs

@@ -52,8 +52,8 @@ import qualified SDL.Raw.Types as SDLT
 
 import Monomer.Core
 import Monomer.Event
-import Monomer.Graphics
-import Monomer.Helper
+import Monomer.Helper (seqStartsWith)
+import Monomer.Main.Platform (getWindowSize)
 import Monomer.Main.Types
 import Monomer.Main.Util
 
@@ -260,8 +260,11 @@ handleResizeWidgets
   => HandlerStep s e      -- ^ Current state/"HandlerStep".
   -> m (HandlerStep s e)  -- ^ Updated state/"HandlerStep".
 handleResizeWidgets previousStep = do
-  Size w h <- use L.windowSize
+  window <- use L.window
+  dpr <- use L.dpr
+  Size w h <- getWindowSize window dpr
 
+  liftIO $ print ("Resizing handlers", w, h)
   let winRect = Rect 0 0 w h
   let (wenv, root, reqs) = previousStep
   let newResult = widgetResize (root ^. L.widget) wenv root winRect
@@ -514,10 +517,10 @@ handleRenderStop widgetId previousStep = do
 handleRemoveRendererImage
   :: (MonomerM s m) => Text -> HandlerStep s e -> m (HandlerStep s e)
 handleRemoveRendererImage name previousStep = do
-  renderer <- use L.renderer
-
-  when (isJust renderer) $
-    liftIO $ deleteImage (fromJust renderer) name
+--  renderer <- use L.renderer
+--
+--  when (isJust renderer) $
+--    liftIO $ deleteImage (fromJust renderer) name
 
   return previousStep
 

src/Monomer/Main/Platform.hs

@@ -26,7 +26,6 @@ import Foreign (alloca, peek)
 import Foreign.C (peekCString, withCString)
 import Foreign.C.Types
 import SDL (($=))
-import System.IO.Unsafe (unsafePerformIO)
 
 import qualified Data.Text as T
 import qualified Foreign.C.String as STR
@@ -49,7 +48,7 @@ defaultWindowSize :: (Int, Int)
 defaultWindowSize = (800, 600)
 
 -- | Creates and initializes a window using the provided configuration.
-initSDLWindow :: AppConfig e -> IO (SDL.Window, Double, Double)
+initSDLWindow :: AppConfig e -> IO (SDL.Window, Double, Double, SDL.GLContext)
 initSDLWindow config = do
   SDL.initialize [SDL.InitVideo]
   SDL.HintRenderScaleQuality $= SDL.ScaleLinear
@@ -58,9 +57,9 @@ initSDLWindow config = do
      when (renderQuality /= SDL.ScaleLinear) $
        putStrLn "Warning: Linear texture filtering not enabled!"
 
-  os <- getPlatform
+  platform <- getPlatform
   initializeDpiAwareness
-  factor <- case os of
+  factor <- case platform of
     "Windows" -> getWindowsFactor
     "Linux" -> getLinuxFactor
     _ -> return 1 -- macOS
@@ -82,7 +81,7 @@ initSDLWindow config = do
   let scaleFactor = factor * userScaleFactor
   let contentRatio = fromIntegral fbWidth / winW
   let (dpr, epr)
-        | os `elem` ["Windows", "Linux"] = (scaleFactor, 1 / scaleFactor)
+        | platform `elem` ["Windows", "Linux"] = (scaleFactor, 1 / scaleFactor)
         | otherwise = (scaleFactor * contentRatio, 1 / scaleFactor) -- macOS
 
   when (isJust (_apcWindowTitle config)) $
@@ -98,11 +97,14 @@ initSDLWindow config = do
   err <- STR.peekCString err
   putStrLn err
 
-  _ <- SDL.glCreateContext window
+  ctxRender <- SDL.glCreateContext window
+
+  when (platform == "Windows") $
+    void $ SDL.glCreateContext window
 
   _ <- glewInit
 
-  return (window, dpr, epr)
+  return (window, dpr, epr, ctxRender)
   where
     customOpenGL = SDL.OpenGLConfig {
       SDL.glColorPrecision = SDL.V4 8 8 8 0,

src/Monomer/Main/Types.hs

@@ -81,8 +81,6 @@ data MonomerCtx s = MonomerCtx {
   _mcWindow :: SDL.Window,
   -- | Main window size.
   _mcWindowSize :: Size,
-  -- | Active renderer.
-  _mcRenderer :: Maybe Renderer,
   -- | Device pixel rate.
   _mcDpr :: Double,
   -- | Event pixel rate.

src/Monomer/Main/Util.hs

@@ -47,7 +47,6 @@ initMonomerCtx model win winSize dpr epr = MonomerCtx {
   _mcMainModel = model,
   _mcWindow = win,
   _mcWindowSize = winSize,
-  _mcRenderer = Nothing,
   _mcDpr = dpr,
   _mcEpr = epr,
   _mcInputStatus = def,

test/unit/Monomer/TestUtil.hs

@@ -149,7 +149,6 @@ mockFontManager = FontManager {
   computeGlyphsPos = mockGlyphsPos (Just 10)
 }
 
-
 mockWenv :: s -> WidgetEnv s e
 mockWenv model = WidgetEnv {
   _weOs = "Mac OS X",