Improve handling of lower layers in zstack. Add option to ignore events in a container

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],

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

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

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

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

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

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

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" $