From d1ddcc2d40a6151d50fca33dbca1302fa7b2e19b Mon Sep 17 00:00:00 2001
From: Francisco Vallarino <fjvallarino@users.noreply.github.com>
Date: Mon, 31 Oct 2022 11:57:39 +0100
Subject: [PATCH] Fix rendering artifacts (#215)

* Consider SDL.TextEditingEvent as an action event

* When a frame requires rendering, make sure the next one is also rendered to avoid artifacts. It still does not render every frame

* Fix lint

* Fix typo

* Update Changelog
---
 ChangeLog.md                 | 11 +++++++++++
 src/Monomer/Event/Core.hs    |  1 +
 src/Monomer/Main/Core.hs     | 33 +++++++++++++++++++++++++++------
 src/Monomer/Main/Handlers.hs |  2 +-
 4 files changed, 40 insertions(+), 7 deletions(-)

diff --git a/ChangeLog.md b/ChangeLog.md
index 22001878..bf574a14 100644
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -1,3 +1,14 @@
+## 1.5.1.0
+
+### Fixed
+
+- Fix rendering artifacts ([PR #215](https://github.com/fjvallarino/monomer/pull/215)).
+
+### Changed
+
+- Add "examples" flag to optionally build examples and tutorials ([PR #218](https://github.com/fjvallarino/monomer/pull/218)).
+- Use pkg-config for glew linking ([PR #219](https://github.com/fjvallarino/monomer/pull/219)).
+
 ## 1.5.0.0
 
 ### Added
diff --git a/src/Monomer/Event/Core.hs b/src/Monomer/Event/Core.hs
index 66ac24a2..3ce23b6c 100644
--- a/src/Monomer/Event/Core.hs
+++ b/src/Monomer/Event/Core.hs
@@ -36,6 +36,7 @@ isActionEvent :: SDL.EventPayload -> Bool
 isActionEvent SDL.MouseButtonEvent{} = True
 isActionEvent SDL.MouseWheelEvent{} = True
 isActionEvent SDL.KeyboardEvent{} = True
+isActionEvent SDL.TextEditingEvent{} = True
 isActionEvent SDL.TextInputEvent{} = True
 isActionEvent _ = False
 
diff --git a/src/Monomer/Main/Core.hs b/src/Monomer/Main/Core.hs
index 4ae0137e..505ea8f0 100644
--- a/src/Monomer/Main/Core.hs
+++ b/src/Monomer/Main/Core.hs
@@ -270,6 +270,7 @@ mainLoop window fontManager config loopArgs = do
   inputStatus <- use L.inputStatus
   mousePos <- liftIO $ getCurrentMousePos epr
   currWinSize <- liftIO $ getViewportSize window dpr
+  prevRenderNeeded <- use L.renderRequested
 
   let Size rw rh = windowSize
   let ts = startTs - _mlFrameStartTs
@@ -331,6 +332,8 @@ mainLoop window fontManager config loopArgs = do
         | otherwise = Seq.Empty
   let baseStep = (wenv, _mlWidgetRoot, Seq.empty)
 
+  L.renderRequested .= False
+
   (rqWenv, rqRoot, _) <- handleRequests baseReqs baseStep
   (wtWenv, wtRoot, _) <- handleWidgetTasks rqWenv rqRoot
   (seWenv, seRoot, _) <- handleSystemEvents wtWenv wtRoot baseSystemEvents
@@ -346,11 +349,11 @@ mainLoop window fontManager config loopArgs = do
   -- Rendering
   renderCurrentReq <- checkRenderCurrent startTs _mlLatestRenderTs
 
-  let renderEvent = any isActionEvent eventsPayload
-  let winRedrawEvt = windowResized || windowExposed
-  let renderNeeded = winRedrawEvt || renderEvent || renderCurrentReq
+  let actionEvt = any isActionEvent eventsPayload
+  let windowRenderEvt = windowResized || any isWindowRenderEvent eventsPayload
+  let renderNeeded = windowRenderEvt || actionEvt || renderCurrentReq
 
-  when renderNeeded $ do
+  when (prevRenderNeeded || renderNeeded) $ do
     renderMethod <- use L.renderMethod
 
     case renderMethod of
@@ -361,8 +364,13 @@ mainLoop window fontManager config loopArgs = do
 
         liftIO $ renderWidgets window dpr renderer bgColor newWenv newRoot
 
-  -- Used in the next rendering cycle
-  L.renderRequested .= windowResized
+  {-
+  Used in the next rendering cycle.
+
+  Temporary workaround: when rendering is needed, make sure to render the next
+  frame too in order to avoid visual artifacts.
+  -}
+  L.renderRequested .= renderNeeded
 
   let fps = realToFrac _mlMaxFps
   let frameLength = round (1000000 / fps)
@@ -455,6 +463,7 @@ handleRenderMsg window renderer fontMgr state (MsgRender tmpWenv newRoot) = do
   let newWenv = tmpWenv
         & L.fontManager .~ fontMgr
   let color = newWenv ^. L.theme . L.clearColor
+
   renderWidgets window dpr renderer color newWenv newRoot
   return (RenderState dpr newWenv newRoot)
 handleRenderMsg window renderer fontMgr state (MsgResize _) = do
@@ -564,6 +573,18 @@ isMouseEntered :: [SDL.EventPayload] -> Bool
 isMouseEntered eventsPayload = not status where
   status = null [ e | e@SDL.WindowGainedMouseFocusEvent {} <- eventsPayload ]
 
+isWindowRenderEvent :: SDL.EventPayload -> Bool
+isWindowRenderEvent SDL.WindowShownEvent{} = True
+isWindowRenderEvent SDL.WindowExposedEvent{} = True
+isWindowRenderEvent SDL.WindowMovedEvent{} = True
+isWindowRenderEvent SDL.WindowResizedEvent{} = True
+isWindowRenderEvent SDL.WindowSizeChangedEvent{} = True
+isWindowRenderEvent SDL.WindowMaximizedEvent{} = True
+isWindowRenderEvent SDL.WindowRestoredEvent{} = True
+isWindowRenderEvent SDL.WindowGainedMouseFocusEvent{} = True
+isWindowRenderEvent SDL.WindowGainedKeyboardFocusEvent{} = True
+isWindowRenderEvent _ = False
+
 getCurrentTimestamp :: MonadIO m => m Millisecond
 getCurrentTimestamp = toMs <$> liftIO getCurrentTime
   where
diff --git a/src/Monomer/Main/Handlers.hs b/src/Monomer/Main/Handlers.hs
index f73d4d8d..b27ec499 100644
--- a/src/Monomer/Main/Handlers.hs
+++ b/src/Monomer/Main/Handlers.hs
@@ -281,7 +281,7 @@ handleResizeWidgets previousStep = do
       resizeRequests <- use L.resizeRequests
       paths <- mapM getWidgetIdPath resizeRequests
       let parts = Set.fromDistinctAscList . drop 1 . toList . Seq.inits
-      let sets = fold (parts <$> paths)
+      let sets = foldMap parts paths
 
       return (`Set.member` sets)