Fix issue with cursor icon. Add unit tests

.ghcid

@@ -1,3 +1,3 @@
---command "stack repl --main-is monomer:exe:books"
+--command "stack repl --main-is monomer:exe:monomer-exe"
 --test ":main"
 --restart=package.yaml

app/Main.hs

@@ -419,7 +419,7 @@ buildUI wenv model = traceShow "Creating UI" widgetTree where
           scroll_ [] $ image_ "assets/images/pecans.jpg" [fitFill],
           scroll_ [] $ image_ "assets/images/pecans.jpg" [fitFill],
           scroll_ [] $ image_ "assets/images/pecans.jpg" [fitFill],
-          image_ "https://picsum.photos/1600/400" [fitFill, onLoadError ImageMsg]
+          image_ "https://picsum.photos/1600/400" [fitFill, onLoadError ImageMsg] `style` [cursorIcon CursorInvalid]
         ],
       textDropdown_ dropdown1 items id [onChange DropdownVal, onChangeIdx DropdownIdx],
       button_ "Click\nme!" (PrintMessage "Button clicked") [textMultiLine]

src/Monomer/Main/Handlers.hs

@@ -388,14 +388,22 @@ handleSetOverlay widgetId path previousStep = do
 
 handleResetOverlay
   :: (MonomerM s m) => WidgetId -> HandlerStep s e -> m (HandlerStep s e)
-handleResetOverlay widgetId previousStep = do
+handleResetOverlay widgetId step = do
+  let (wenv, root, reqs, evts) = step
+  let mousePos = wenv ^. L.inputStatus . L.mousePos
+
   overlay <- use L.overlayWidgetId
 
-  when (overlay == Just widgetId) $ do
-    L.overlayWidgetId .= Nothing
-    delWidgetIdPath widgetId
+  (wenv2, root2, reqs2, evts2) <- if overlay == Just widgetId
+    then do
+      L.overlayWidgetId .= Nothing
+      delWidgetIdPath widgetId
+      void $ handleResetCursorIcon widgetId step
+      handleSystemEvents wenv [Move mousePos] root
+    else
+      return (wenv, root, Empty, Empty)
 
-  return previousStep
+  return (wenv2, root2, reqs <> reqs2, evts <> evts2)
 
 handleSetCursorIcon
   :: (MonomerM s m)

src/Monomer/Widgets/Dropdown.hs

@@ -237,6 +237,7 @@ makeDropdown
 makeDropdown widgetData items makeMain makeRow config state = widget where
   container = def {
     containerChildrenOffset = Just (_ddsOffset state),
+    containerUseCustomCursor = True,
     containerGetBaseStyle = getBaseStyle,
     containerInit = init,
     containerFindNextFocus = findNextFocus,
@@ -306,7 +307,9 @@ makeDropdown widgetData items makeMain makeRow config state = widget where
     Blur
       | not isOpen && not (seqStartsWith path focusedPath)
         -> ddFocusChange _ddcOnBlur _ddcOnBlurReq node
-    Enter{} -> Nothing -- to have handleStyleChange applied
+    Enter{} -> Just result where
+      newIcon = fromMaybe CursorHand (style ^. L.cursorIcon)
+      result = resultReqs node [SetCursorIcon widgetId CursorHand]
     Move point -> result where
       mainNode = Seq.index (node ^. L.children) mainIdx
       listNode = Seq.index (node ^. L.children) listIdx
@@ -335,6 +338,7 @@ makeDropdown widgetData items makeMain makeRow config state = widget where
       | not isOpen -> Just $ resultReqs node [IgnoreChildrenEvents]
       | otherwise -> Nothing
     where
+      style = activeStyle wenv node
       widgetId = node ^. L.info . L.widgetId
       path = node ^. L.info . L.path
       focusedPath = wenv ^. L.focusedPath

src/Monomer/Widgets/Util/Style.hs

@@ -170,9 +170,11 @@ handleCursorChange wenv target evt style oldNode result = newResult where
   hasCursor = isJust (style ^. L.cursorIcon)
   isPressed = isNodePressed wenv node
   (curPath, curIcon) = fromMaybe def (wenv ^. L.cursor)
+  isParent = seqStartsWith path curPath && path /= curPath
   newIcon = fromMaybe CursorArrow (style ^. L.cursorIcon)
   setCursor = hasCursor
     && isCursorEvt evt
+    && not isParent
     && curIcon /= newIcon
   resetCursor = isTarget
     && not hasCursor

tasks.md

@@ -514,6 +514,7 @@
       - Improve cursor handling (if children do not have cursor settings they should not change it)
       - Re-import Color Table and keep it in original order
       - Maybe internally handle focus as widgetId? (use findWidgetByPath)
+      - Does it make sense to have Alert/Dialog accept a widget?
 
 - Pending
   - Add header in all files, indicating license and documenting what the module does
@@ -525,19 +526,19 @@
 Next
   - Add examples
     - Fetch content from url, show rows of data with embedded images
-      - Does it make sense to have Alert/Dialog accept a widget?
-      - Think about using stack resize logic in box
-        - Maybe whats needed are custom min/max options for box content
       - Add cursor icon unit tests
     - Composite example
       - Validate nested structures update correctly when disabling/enabling parent
     - Something of generative art (OpenGL example)
   - Auto scroll affects dropdown when listView is displayed
-  - Maybe label resizeFactor should default to zero? What about button/others?
-  - Maybe do not resize Single if size did not change? First step towards resize improvements
+  - Think about using stack resize logic in box
+    - Maybe label resizeFactor should default to zero? What about button/others?
+    - Maybe whats needed are custom min/max options for box content
+  - Check order of BtnReleased/Click/DblClick
   - Add underline and strikethrough
   - Add externalLink component
     - https://stackoverflow.com/questions/3037088/how-to-open-the-default-web-browser-in-windows-in-c/54334181
+  - Maybe do not resize Single if size did not change? First step towards resize improvements
 
 Future
   - Rename ListView -> SelectList

test/unit/Monomer/Common/CursorIconSpec.hs

@@ -0,0 +1,156 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Monomer.Common.CursorIconSpec (spec) where
+
+--import Control.Lens ((&), (^.), (.~), (%~), _2)
+import Control.Lens
+import Control.Lens.TH (abbreviatedFields, makeLensesWith)
+import Data.Default
+import Data.Maybe
+import Data.Sequence (Seq(..))
+import Data.Text (Text)
+import Safe
+import Test.Hspec
+
+import qualified Data.Map.Strict as M
+import qualified Data.Sequence as Seq
+
+import Monomer.Core
+import Monomer.Core.Combinators
+import Monomer.Core.Themes.SampleThemes
+import Monomer.Event
+import Monomer.Main
+import Monomer.TestUtil
+import Monomer.TestEventUtil
+import Monomer.Widgets.Box
+import Monomer.Widgets.Grid
+import Monomer.Widgets.Label
+import Monomer.Widgets.Spacer
+import Monomer.Widgets.Stack
+import Monomer.Widgets.TextDropdown
+
+import qualified Monomer.Lens as L
+
+newtype TestModel = TestModel {
+  _tmSelectedItem :: Int
+} deriving (Eq, Show)
+
+makeLensesWith abbreviatedFields ''TestModel
+
+spec :: Spec
+spec = describe "Cursor Icon" $ do
+  handleEventSimple
+  handleEventNested
+  handleEventOverlay
+
+handleEventSimple :: Spec
+handleEventSimple = describe "handleEventSimple" $ do
+  it "should not change the cursor if not event happened" $ do
+    icons [] `shouldBe` [CursorArrow]
+
+  it "should not change the cursor if the widget does not have a cursor" $ do
+    icons [[evtMove p1]] `shouldBe` [CursorArrow, CursorArrow]
+
+  it "should change the cursor if the widget has a custom cursor" $ do
+    icons [[evtMove p2]] `shouldBe` [CursorArrow, CursorHand]
+    icons [[evtMove p3]] `shouldBe` [CursorArrow, CursorIBeam]
+    icons [[evtMove p4]] `shouldBe` [CursorArrow, CursorInvalid]
+
+  it "should generate the correct sequence of cursors from the events" $ do
+    let evtsGroups = [[evtMove p2], [evtMove p3], [evtMove p4]]
+    icons evtsGroups `shouldBe` [CursorArrow, CursorHand, CursorIBeam, CursorInvalid]
+
+  where
+    wenv = mockWenvEvtUnit ()
+    node = vstack [
+        label "Test",
+        label "Test" `style` [cursorIcon CursorHand],
+        label "Test" `style` [cursorIcon CursorIBeam],
+        label "Test" `style` [cursorIcon CursorInvalid]
+      ]
+    icons egs = getIcons wenv node egs
+    p1 = Point 100 10
+    p2 = Point 100 30
+    p3 = Point 100 50
+    p4 = Point 100 70
+
+handleEventNested :: Spec
+handleEventNested = describe "handleEventNested" $ do
+  it "should change the cursor if the widget has a custom cursor" $ do
+    icons [[evtMove p11]] `shouldBe` [CursorArrow, CursorArrow]
+    icons [[evtMove p21]] `shouldBe` [CursorArrow, CursorSizeH]
+    icons [[evtMove p22]] `shouldBe` [CursorArrow, CursorHand]
+    icons [[evtMove p31]] `shouldBe` [CursorArrow, CursorSizeV]
+    icons [[evtMove p32]] `shouldBe` [CursorArrow, CursorHand]
+
+  it "should generate the correct sequence of cursors from the events" $ do
+    let evtsGroups = [[evtMove p11], [evtMove p21], [evtMove p22], [evtMove p31], [evtMove p32]]
+    icons evtsGroups `shouldBe` [CursorArrow, CursorArrow, CursorSizeH, CursorHand, CursorSizeV, CursorHand]
+
+  where
+    wenv = mockWenvEvtUnit ()
+    node = vstack [
+        label "Test",
+        hgrid [
+          hgrid [
+            label "Test" `style` [cursorIcon CursorSizeH],
+            filler
+          ]
+        ] `style` [cursorIcon CursorHand],
+        hgrid [
+          hgrid [
+            label "Test" `style` [cursorIcon CursorSizeV],
+            filler
+          ] `style` [cursorIcon CursorInvalid],
+          spacer
+        ] `style` [cursorIcon CursorHand]
+      ]
+    icons egs = getIcons wenv node egs
+    p11 = Point 100 10
+    p21 = Point 100 30
+    p22 = Point 400 30
+    p31 = Point 100 50
+    p32 = Point 400 50
+
+handleEventOverlay :: Spec
+handleEventOverlay = describe "handleEventOverlay" $ do
+  it "should not change the cursor if not event happened" $ do
+    icons [] `shouldBe` [CursorArrow]
+
+  it "should not show to arrow in overlay area if dropdown is not open" $ do
+    let evtsGroups = [[evtMove p1], [evtMove p2], [evtMove p3]]
+    icons evtsGroups `shouldBe` [CursorArrow, CursorHand, CursorInvalid, CursorInvalid]
+
+  it "should show arrow in overlay area if dropdown is open" $ do
+    let evtsGroups = [[evtMove p1], [evtClick p1], [evtMove p2], [evtMove p3]]
+    icons evtsGroups `shouldBe` [CursorArrow, CursorHand, CursorHand, CursorHand, CursorArrow]
+
+  it "should show arrow in overlay area when dropdown is open, invalid after it's closed" $ do
+    let evtsGroups = [[evtMove p1], [evtClick p1], [evtMove p3], [evtClick p3]]
+    icons evtsGroups `shouldBe` [CursorArrow, CursorHand, CursorHand, CursorArrow, CursorInvalid]
+
+  where
+    wenv = mockWenvEvtUnit (TestModel 0)
+    node = vstack [
+        textDropdown selectedItem [0..10::Int],
+        filler
+      ] `style` [cursorIcon CursorInvalid]
+    icons egs = getIcons wenv node egs
+    p1 = Point 100 10
+    p2 = Point 100 30
+    p3 = Point 100 400
+
+getIcons
+  :: Eq s
+  => WidgetEnv s e
+  -> WidgetNode s e
+  -> [[SystemEvent]]
+  -> [CursorIcon]
+getIcons wenv root evtsGroups = iconsRes where
+  firstIcon stack = fromMaybe CursorArrow (headMay stack)
+  ctxs = snd <$> nodeHandleEvents_ wenv WInit evtsGroups root
+  cursors = (^.. L.cursorStack . folded . _2) <$> ctxs
+  iconsRes = firstIcon <$> cursors

test/unit/Monomer/Common/PersistSpec.hs

@@ -6,7 +6,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell #-}
 
-module Monomer.Widgets.PersistSpec (spec) where
+module Monomer.Common.PersistSpec (spec) where
 
 import Codec.Serialise
 import Control.Lens ((&), (^.), (^?), (.~), (?~), (%~), non, _Just)

test/unit/Spec.hs

@@ -5,6 +5,9 @@ import Test.Hspec
 import qualified SDL
 import qualified SDL.Raw as Raw
 
+import qualified Monomer.Common.CursorIconSpec as CursorIconSpec
+import qualified Monomer.Common.PersistSpec as PersistSpec
+
 import qualified Monomer.Widgets.AlertSpec as AlertSpec
 import qualified Monomer.Widgets.BoxSpec as BoxSpec
 import qualified Monomer.Widgets.ButtonSpec as ButtonSpec
@@ -21,7 +24,6 @@ import qualified Monomer.Widgets.KeystrokeSpec as KeystrokeSpec
 import qualified Monomer.Widgets.LabelSpec as LabelSpec
 import qualified Monomer.Widgets.ListViewSpec as ListViewSpec
 import qualified Monomer.Widgets.NumericFieldSpec as NumericFieldSpec
-import qualified Monomer.Widgets.PersistSpec as PersistSpec
 import qualified Monomer.Widgets.RadioSpec as RadioSpec
 import qualified Monomer.Widgets.ScrollSpec as ScrollSpec
 import qualified Monomer.Widgets.SplitSpec as SplitSpec
@@ -47,9 +49,15 @@ main = do
 
 spec :: Spec
 spec = do
+  common
   widgets
   widgetsUtil
 
+common :: Spec
+common = describe "Common" $ do
+  CursorIconSpec.spec
+  PersistSpec.spec
+
 widgets :: Spec
 widgets = describe "Widgets" $ do
   AlertSpec.spec
@@ -68,7 +76,6 @@ widgets = describe "Widgets" $ do
   LabelSpec.spec
   ListViewSpec.spec
   NumericFieldSpec.spec
-  PersistSpec.spec
   RadioSpec.spec
   ScrollSpec.spec
   SplitSpec.spec