Clear Render request from inputField when focus is lost/widget is disposed/merged

src/Monomer/Widgets/InputField.hs

@@ -64,6 +64,9 @@ inputFieldState = InputFieldState {
 caretWidth :: Double
 caretWidth = 2
 
+caretMs :: Int
+caretMs = 500
+
 inputField_
   :: (Eq a, Default a, Typeable a)
   => WidgetType
@@ -84,6 +87,7 @@ makeInputField config state = widget where
     singleInit = init,
     singleGetState = makeState state,
     singleMerge = merge,
+    singleDispose = dispose,
     singleHandleEvent = handleEvent,
     singleGetSizeReq = getSizeReq,
     singleResize = resize,
@@ -138,7 +142,17 @@ makeInputField config state = widget where
       _wiWidget = makeInputField config newState
     }
     parsedVal = fromText newText
-    reqs = setModelValid (isJust parsedVal)
+    oldPath = _wiPath oldInst
+    newPath = _wiPath inst
+    focused = isFocused wenv oldInst
+    renderReqs
+      | focused = [ RenderStop oldPath, RenderEvery newPath caretMs ]
+      | otherwise = []
+    reqs = setModelValid (isJust parsedVal) ++ renderReqs
+
+  dispose wenv inst = resultReqs reqs inst where
+    path = _wiPath inst
+    reqs = [ RenderStop path ]
 
   handleKeyPress wenv mod code
     | isDelBackWord && emptySel = Just $ moveCursor removeWord prevWordStartIdx Nothing

test/unit/Monomer/TestUtil.hs

@@ -15,6 +15,7 @@ import Monomer.Core
 import Monomer.Event
 import Monomer.Graphics
 import Monomer.Main.Handlers
+import Monomer.Main.Types
 import Monomer.Main.Util
 
 testW :: Double
@@ -140,6 +141,15 @@ instResize wenv viewport inst = newInst where
   reqInst = widgetUpdateSizeReq (_wiWidget inst) wenv inst
   newInst = widgetResize (_wiWidget reqInst) wenv viewport viewport reqInst
 
+instHandleEventCtx
+  :: (Eq s)
+  => WidgetEnv s e
+  -> [SystemEvent]
+  -> WidgetInstance s e
+  -> MonomerContext s
+instHandleEventCtx wenv evts inst = ctx where
+  ctx = snd $ instHandleEvents wenv evts inst
+
 instHandleEventModel
   :: (Eq s)
   => WidgetEnv s e
@@ -147,7 +157,7 @@ instHandleEventModel
   -> WidgetInstance s e
   -> s
 instHandleEventModel wenv evts inst = _weModel wenv2 where
-  (wenv2, _, _) = instHandleEvents wenv evts inst
+  (wenv2, _, _) = fst $ instHandleEvents wenv evts inst
 
 instHandleEventEvts
   :: (Eq s)
@@ -156,7 +166,7 @@ instHandleEventEvts
   -> WidgetInstance s e
   -> Seq e
 instHandleEventEvts wenv evts inst = events where
-  (_, events, _) = instHandleEvents wenv evts inst
+  (_, events, _) = fst $ instHandleEvents wenv evts inst
 
 instHandleEventRoot
   :: (Eq s)
@@ -165,14 +175,14 @@ instHandleEventRoot
   -> WidgetInstance s e
   -> WidgetInstance s e
 instHandleEventRoot wenv evts inst = newRoot where
-  (_, _, newRoot) = instHandleEvents wenv evts inst
+  (_, _, newRoot) = fst $ instHandleEvents wenv evts inst
 
 instHandleEvents
   :: (Eq s)
   => WidgetEnv s e
   -> [SystemEvent]
   -> WidgetInstance s e
-  -> HandlerStep s e
+  -> (HandlerStep s e, MonomerContext s)
 instHandleEvents wenv evts inst = unsafePerformIO $ do
   let winSize = testWindowSize
   let vp = Rect 0 0 (_sW winSize) (_sH winSize)
@@ -182,14 +192,12 @@ instHandleEvents wenv evts inst = unsafePerformIO $ do
   -- Do NOT test code involving SDL Window functions
   let monomerContext = initMonomerContext model undefined winSize useHdpi dpr
 
-  (step, newCtx) <- flip runStateT monomerContext $ do
+  flip runStateT monomerContext $ do
     (wenv2, _, newInst) <- handleWidgetInit wenv inst
     let resizedInst = instResize wenv vp newInst
 
     handleSystemEvents wenv2 evts resizedInst
 
-  return step
-
 roundRectUnits :: Rect -> Rect
 roundRectUnits (Rect x y w h) = Rect nx ny nw nh where
   nx = fromIntegral (round x)

test/unit/Monomer/Widgets/TextFieldSpec.hs

@@ -42,8 +42,10 @@ spec = describe "TextField" $ do
 
 handleEvent :: Spec
 handleEvent = describe "handleEvent" $ do
-  it "should input an 'a'" $
+  it "should input an 'a'" $ do
     model [evtT "a"] ^. textValue `shouldBe` "a"
+    ctx [evtT "a"] ^. L.renderSchedule `shouldSatisfy` null
+    ctx [Focus, evtT "a"] ^. L.renderSchedule `shouldSatisfy` (==1) . length
 
   it "should input 'ababa', remove the middle 'a' and input 'c'" $ do
     let steps = [evtT "ababa", moveCharL, moveCharL, evtK keyBackspace, evtT "c"]
@@ -78,11 +80,13 @@ handleEvent = describe "handleEvent" $ do
     let steps = [evtT str, Focus, evtT "No"]
     model steps ^. textValue `shouldBe` "No"
 
-  it "should generate an event when focus is received" $
+  it "should generate an event when focus is received" $ do
     events Focus `shouldBe` Seq.singleton GotFocus
+    ctx [Focus] ^. L.renderSchedule `shouldSatisfy` (==1) . length
 
-  it "should generate an event when focus is lost" $
+  it "should generate an event when focus is lost" $ do
     events Blur `shouldBe` Seq.singleton LostFocus
+    ctx [Focus, Blur] ^. L.renderSchedule `shouldSatisfy` null
 
   where
     wenv = mockWenv (TestModel "")
@@ -90,6 +94,7 @@ handleEvent = describe "handleEvent" $ do
     txtInst = textField_ textValue txtCfg
     model es = instHandleEventModel wenv es txtInst
     events evt = instHandleEventEvts wenv [evt] txtInst
+    ctx evts = instHandleEventCtx wenv evts txtInst
 
 handleEventValue :: Spec
 handleEventValue = describe "handleEvent" $ do

test/unit/Monomer/Widgets/Util/StyleSpec.hs

@@ -58,9 +58,10 @@ testActiveStyle = describe "activeStyle" $ do
 testHandleSizeChange :: Spec
 testHandleSizeChange = describe "handleSizeChange" $ do
   it "should request Resize widgets if sizeReq changed" $ do
+    resHover ^? _Just . L.requests `shouldSatisfy` (==3) . maybeLength
     resHover ^? _Just . L.requests . ix 0 `shouldSatisfy` isResizeWidgets
-    resHover ^? _Just . L.requests . ix 1 `shouldSatisfy` isSetCursorIcon
-    resHover ^? _Just . L.requests `shouldSatisfy` (==2) . maybeLength
+    resHover ^? _Just . L.requests . ix 1 `shouldSatisfy` isRenderOnce
+    resHover ^? _Just . L.requests . ix 2 `shouldSatisfy` isSetCursorIcon
 
   it "should not request Resize widgets if sizeReq has not changed" $
     resFocus ^? _Just . L.requests `shouldSatisfy` (==0) . maybeLength
@@ -86,6 +87,10 @@ isResizeWidgets :: Maybe (WidgetRequest s) -> Bool
 isResizeWidgets (Just ResizeWidgets) = True
 isResizeWidgets _ = False
 
+isRenderOnce :: Maybe (WidgetRequest s) -> Bool
+isRenderOnce (Just RenderOnce{}) = True
+isRenderOnce _ = False
+
 isSetCursorIcon :: Maybe (WidgetRequest s) -> Bool
 isSetCursorIcon (Just SetCursorIcon{}) = True
 isSetCursorIcon _ = False