From 19595aee5d86ba258b3408257c3a374c12b9c720 Mon Sep 17 00:00:00 2001 From: Francisco Vallarino Date: Tue, 29 Dec 2020 14:07:15 -0300 Subject: [PATCH] Improve handling of lower layers in zstack. Add option to ignore events in a container --- app/Main.hs | 14 ++++---- src/Monomer/Core/Combinators.hs | 4 +++ src/Monomer/Widgets/Box.hs | 13 +++++++ src/Monomer/Widgets/Container.hs | 9 +++-- src/Monomer/Widgets/Stack.hs | 54 ++++++++++++++++++++++++---- src/Monomer/Widgets/ZStack.hs | 3 +- tasks.md | 2 +- test/unit/Monomer/Widgets/BoxSpec.hs | 44 ++++++++++++++++++++--- 8 files changed, 122 insertions(+), 21 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 961ee2c5..4412bfe4 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -198,12 +198,14 @@ buildUI wenv model = trace "Creating UI" widgetTree where textField textField1 `style` [bgColor orange] ] ], - hstack [ - vgrid [ - label "", - textField textField1 `style` [bgColor lightBlue, width 200] - ] - ] + box_ ( + hstack [ + vgrid [ + label "", + textField textField1 `style` [bgColor lightBlue, width 200] + ] + ] `style` [height 480] + ) [alignRight] ] [onlyTopActive False] widgetTree4 = hgrid [ label "" `style` [bgColor blue], diff --git a/src/Monomer/Core/Combinators.hs b/src/Monomer/Core/Combinators.hs index bbeb9502..d7ba9226 100644 --- a/src/Monomer/Core/Combinators.hs +++ b/src/Monomer/Core/Combinators.hs @@ -41,6 +41,10 @@ class Num a => CmbMaxValue t a | t -> a where class Num a => CmbDragRate t a | t -> a where dragRate :: a -> t +-- Container +class CmbIgnoreEmptyArea t where + ignoreEmptyArea :: Bool -> t + -- Text class CmbDecimals t where decimals :: Int -> t diff --git a/src/Monomer/Widgets/Box.hs b/src/Monomer/Widgets/Box.hs index cfc5caf5..d6562da8 100644 --- a/src/Monomer/Widgets/Box.hs +++ b/src/Monomer/Widgets/Box.hs @@ -23,6 +23,7 @@ import qualified Monomer.Lens as L data BoxCfg s e = BoxCfg { _boxExpandContent :: Maybe Bool, + _boxIgnoreEmptyArea :: Maybe Bool, _boxAlignH :: Maybe AlignH, _boxAlignV :: Maybe AlignV, _boxOnClick :: [e], @@ -34,6 +35,7 @@ data BoxCfg s e = BoxCfg { instance Default (BoxCfg s e) where def = BoxCfg { _boxExpandContent = Nothing, + _boxIgnoreEmptyArea = Nothing, _boxAlignH = Nothing, _boxAlignV = Nothing, _boxOnClick = [], @@ -45,6 +47,7 @@ instance Default (BoxCfg s e) where instance Semigroup (BoxCfg s e) where (<>) t1 t2 = BoxCfg { _boxExpandContent = _boxExpandContent t2 <|> _boxExpandContent t1, + _boxIgnoreEmptyArea = _boxIgnoreEmptyArea t2 <|> _boxIgnoreEmptyArea t1, _boxAlignH = _boxAlignH t2 <|> _boxAlignH t1, _boxAlignV = _boxAlignV t2 <|> _boxAlignV t1, _boxOnClick = _boxOnClick t1 <> _boxOnClick t2, @@ -56,6 +59,11 @@ instance Semigroup (BoxCfg s e) where instance Monoid (BoxCfg s e) where mempty = def +instance CmbIgnoreEmptyArea (BoxCfg s e) where + ignoreEmptyArea ignore = def { + _boxIgnoreEmptyArea = Just ignore + } + instance CmbAlignLeft (BoxCfg s e) where alignLeft = def { _boxAlignH = Just ALeft @@ -126,11 +134,16 @@ makeNode widget managedWidget = defaultWidgetNode "box" widget makeBox :: BoxCfg s e -> Widget s e makeBox config = widget where widget = createContainer def { + containerIgnoreEmptyArea = ignoreEmptyArea && emptyHandlersCount == 0, containerHandleEvent = handleEvent, containerGetSizeReq = getSizeReq, containerResize = resize } + ignoreEmptyArea = fromMaybe True (_boxIgnoreEmptyArea config) + emptyHandlersCount + = length (_boxOnClickEmpty config) + length (_boxOnClickEmptyReq config) + handleEvent wenv ctx evt node = case evt of Click point btn -> result where child = Seq.index (node ^. L.children) 0 diff --git a/src/Monomer/Widgets/Container.hs b/src/Monomer/Widgets/Container.hs index 9fe5a75c..9cd892ac 100644 --- a/src/Monomer/Widgets/Container.hs +++ b/src/Monomer/Widgets/Container.hs @@ -131,7 +131,7 @@ type ContainerResizeHandler s e -> (WidgetNode s e, Seq (Rect, Rect)) type ContainerRenderHandler s e - = Renderer + = Renderer -> WidgetEnv s e -> WidgetNode s e -> IO () @@ -140,6 +140,7 @@ data Container s e = Container { containerUseScissor :: Bool, containerStyleOnMerge :: Bool, containerResizeRequired :: Bool, + containerIgnoreEmptyArea :: Bool, containerUseCustomSize :: Bool, containerUseChildrenSizes :: Bool, containerGetBaseStyle :: ContainerGetBaseStyle s e, @@ -164,6 +165,7 @@ instance Default (Container s e) where containerUseScissor = True, containerStyleOnMerge = False, containerResizeRequired = True, + containerIgnoreEmptyArea = False, containerUseCustomSize = False, containerUseChildrenSizes = False, containerGetBaseStyle = defaultGetBaseStyle, @@ -433,6 +435,7 @@ findByPointWrapper -> WidgetNode s e -> Maybe Path findByPointWrapper container wenv start point node = result where + ignoreEmpty = containerIgnoreEmptyArea container handler = containerFindByPoint container isVisible = node ^. L.info . L.visible inVp = pointInViewport point node @@ -450,7 +453,9 @@ findByPointWrapper container wenv start point node = result where childPath = widgetFindByPoint childWidget wenv newStartPath point child child = Seq.index children idx childWidget = child ^. L.widget - Nothing -> Just $ node ^. L.info . L.path + Nothing + | not ignoreEmpty -> Just $ node ^. L.info . L.path + | otherwise -> Nothing result | isVisible && (inVp || resultPath /= Just path) = resultPath | otherwise = Nothing diff --git a/src/Monomer/Widgets/Stack.hs b/src/Monomer/Widgets/Stack.hs index 68366e88..a802f406 100644 --- a/src/Monomer/Widgets/Stack.hs +++ b/src/Monomer/Widgets/Stack.hs @@ -1,6 +1,8 @@ module Monomer.Widgets.Stack ( hstack, - vstack + hstack_, + vstack, + vstack_ ) where import Control.Applicative ((<|>)) @@ -17,19 +19,56 @@ import Monomer.Widgets.Container import qualified Monomer.Lens as L +newtype StackCfg = StackCfg { + _stcIgnoreEmptyArea :: Maybe Bool +} + +instance Default StackCfg where + def = StackCfg Nothing + +instance Semigroup StackCfg where + (<>) s1 s2 = StackCfg { + _stcIgnoreEmptyArea = _stcIgnoreEmptyArea s2 <|> _stcIgnoreEmptyArea s1 + } + +instance Monoid StackCfg where + mempty = def + +instance CmbIgnoreEmptyArea StackCfg where + ignoreEmptyArea ignore = def { + _stcIgnoreEmptyArea = Just ignore + } + hstack :: (Traversable t) => t (WidgetNode s e) -> WidgetNode s e -hstack children = newNode where - newNode = defaultWidgetNode "hstack" (makeStack True) +hstack children = hstack_ children def + +hstack_ + :: (Traversable t) + => t (WidgetNode s e) + -> [StackCfg] + -> WidgetNode s e +hstack_ children configs = newNode where + config = mconcat configs + newNode = defaultWidgetNode "hstack" (makeStack True config) & L.children .~ foldl' (|>) Empty children vstack :: (Traversable t) => t (WidgetNode s e) -> WidgetNode s e -vstack children = newNode where - newNode = defaultWidgetNode "vstack" (makeStack False) +vstack children = vstack_ children def + +vstack_ + :: (Traversable t) + => t (WidgetNode s e) + -> [StackCfg] + -> WidgetNode s e +vstack_ children configs = newNode where + config = mconcat configs + newNode = defaultWidgetNode "vstack" (makeStack False config) & L.children .~ foldl' (|>) Empty children -makeStack :: Bool -> Widget s e -makeStack isHorizontal = widget where +makeStack :: Bool -> StackCfg -> Widget s e +makeStack isHorizontal config = widget where widget = createContainer def { + containerIgnoreEmptyArea = ignoreEmptyArea, containerUseCustomSize = True, containerFindByPoint = defaultFindByPoint, containerGetSizeReq = getSizeReq, @@ -37,6 +76,7 @@ makeStack isHorizontal = widget where } isVertical = not isHorizontal + ignoreEmptyArea = fromMaybe True (_stcIgnoreEmptyArea config) getSizeReq wenv node children = (newSizeReqW, newSizeReqH) where vchildren = Seq.filter (_wniVisible . _wnInfo) children diff --git a/src/Monomer/Widgets/ZStack.hs b/src/Monomer/Widgets/ZStack.hs index 3662a8b8..5ffe867e 100644 --- a/src/Monomer/Widgets/ZStack.hs +++ b/src/Monomer/Widgets/ZStack.hs @@ -130,7 +130,8 @@ makeZStack config = widget where topVisibleIdx = fromMaybe 0 (Seq.findIndexR (_wniVisible . _wnInfo) children) isPointEmpty point idx = not covered where prevs = Seq.drop (idx + 1) children - isCovered c = isVisible c && pointInViewport point c + target c = widgetFindByPoint (c ^. L.widget) wenv Empty point c + isCovered c = isVisible c && isJust (target c) covered = any isCovered prevs isTopLayer idx child point = prevTopLayer && isValid where prevTopLayer = _weInTopLayer wenv point diff --git a/tasks.md b/tasks.md index 60bf273d..972a8cd2 100644 --- a/tasks.md +++ b/tasks.md @@ -359,6 +359,7 @@ - Refactor modules where consistency is lacking - Make sure WidgetTask/Node association is preserved if node location in tree changes - Button should handle ReleaseBtn instead of Click (allow multi click) + - ZStack should set _weIsTopLayer based on used space - Pending - Add header in all files, indicating license and documenting what the module does @@ -371,7 +372,6 @@ - Add user documentation Maybe postponed after release? - - ZStack should set _weIsTopLayer based on used space - Reimplement containerIgnoreEmptyClick - Box should allow setting size of children and ignore the rest - Check multiple resize when opening dialogs diff --git a/test/unit/Monomer/Widgets/BoxSpec.hs b/test/unit/Monomer/Widgets/BoxSpec.hs index fd851c26..897afbc0 100644 --- a/test/unit/Monomer/Widgets/BoxSpec.hs +++ b/test/unit/Monomer/Widgets/BoxSpec.hs @@ -13,16 +13,19 @@ import Monomer.TestUtil import Monomer.Widgets.Box import Monomer.Widgets.Button import Monomer.Widgets.Label +import Monomer.Widgets.ZStack import qualified Monomer.Lens as L -data BtnEvent - = BtnClick +newtype BtnEvent + = BtnClick Int deriving (Eq, Show) spec :: Spec spec = describe "Box" $ do handleEvent + handleEventIgnoreEmpty + handleEventSinkEmpty updateSizeReq resize @@ -32,14 +35,47 @@ handleEvent = describe "handleEvent" $ do events (Point 3000 3000) `shouldBe` Seq.empty it "should generate an event if the button (centered) is clicked" $ - events (Point 320 240) `shouldBe` Seq.singleton BtnClick + events (Point 320 240) `shouldBe` Seq.singleton (BtnClick 0) where wenv = mockWenv () - btn = button "Click" BtnClick + btn = button "Click" (BtnClick 0) boxNode = nodeInit wenv (box btn) events p = nodeHandleEventEvts wenv [Click p LeftBtn] boxNode +handleEventIgnoreEmpty :: Spec +handleEventIgnoreEmpty = describe "handleEventIgnoreEmpty" $ do + it "should click the bottom layer, since nothing is handled on top" $ + clickIgnored (Point 200 15) `shouldBe` Seq.singleton (BtnClick 1) + + it "should click the top layer, since pointer is on the button" $ + clickIgnored (Point 320 240) `shouldBe` Seq.singleton (BtnClick 2) + + where + wenv = mockWenv () + ignoredNode = zstack_ [ + button "Click 1" (BtnClick 1), + box (button "Click 2" (BtnClick 2) `style` [height 10]) + ] [onlyTopActive False] + clickIgnored p = nodeHandleEventEvts wenv [Click p LeftBtn] ignoredNode + +handleEventSinkEmpty :: Spec +handleEventSinkEmpty = describe "handleEventSinkEmpty" $ do + it "should do nothing, since event is not passed down" $ + clickSunk (Point 200 15) `shouldBe` Seq.empty + + it "should click the top layer, since pointer is on the button" $ + clickSunk (Point 320 240) `shouldBe` Seq.singleton (BtnClick 2) + + where + wenv = mockWenv () + centeredBtn = button "Click 2" (BtnClick 2) `style` [height 10] + sunkNode = zstack_ [ + button "Click 1" (BtnClick 1), + box_ centeredBtn [ignoreEmptyArea False] + ] [onlyTopActive False] + clickSunk p = nodeHandleEventEvts wenv [Click p LeftBtn] sunkNode + updateSizeReq :: Spec updateSizeReq = describe "updateSizeReq" $ do it "should return width = Flex 50 0.01" $