diff --git a/.ghcid b/.ghcid index bb68ff50..0c291ab2 100644 --- a/.ghcid +++ b/.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 diff --git a/app/Main.hs b/app/Main.hs index abb5678d..8171629d 100644 --- a/app/Main.hs +++ b/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] diff --git a/src/Monomer/Main/Handlers.hs b/src/Monomer/Main/Handlers.hs index 98baf1cc..95ff07fb 100644 --- a/src/Monomer/Main/Handlers.hs +++ b/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) diff --git a/src/Monomer/Widgets/Dropdown.hs b/src/Monomer/Widgets/Dropdown.hs index ced2b49a..b3099ab0 100644 --- a/src/Monomer/Widgets/Dropdown.hs +++ b/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 diff --git a/src/Monomer/Widgets/Util/Style.hs b/src/Monomer/Widgets/Util/Style.hs index 48f7411d..89b6437a 100644 --- a/src/Monomer/Widgets/Util/Style.hs +++ b/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 diff --git a/tasks.md b/tasks.md index f516c09d..e7cfbb46 100644 --- a/tasks.md +++ b/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 diff --git a/test/unit/Monomer/Common/CursorIconSpec.hs b/test/unit/Monomer/Common/CursorIconSpec.hs new file mode 100644 index 00000000..32b4e1be --- /dev/null +++ b/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 diff --git a/test/unit/Monomer/Common/PersistSpec.hs b/test/unit/Monomer/Common/PersistSpec.hs index c8a943a9..a09e7808 100644 --- a/test/unit/Monomer/Common/PersistSpec.hs +++ b/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) diff --git a/test/unit/Spec.hs b/test/unit/Spec.hs index 739b7618..6e76db2b 100644 --- a/test/unit/Spec.hs +++ b/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