Make zstack handle mouse according to used regions. Make stack adjust its size to its content. Simplify related settings

.hlint.yaml

@@ -53,6 +53,7 @@
 
 - ignore: {name: Eta reduce}
 - ignore: {name: Reduce duplication}
+- ignore: {name: Use Just}
 
 # Define some custom infix operators
 # - fixity: infixr 3 ~^#^~

app/Main.hs

@@ -116,7 +116,7 @@ handleAppEvent wenv model evt = case evt of
   _ -> []
 
 buildUI :: WidgetEnv App AppEvent -> App -> WidgetNode App AppEvent
-buildUI wenv model = trace "Creating UI" widgetIdChanged where
+buildUI wenv model = trace "Creating UI" widgetTree where
   widgetIdChanged = vstack [
       button "Show label" IncButton,
       hstack $ [label "First" | model ^. clickCount > 0] ++ [
@@ -170,7 +170,7 @@ buildUI wenv model = trace "Creating UI" widgetIdChanged where
       ]
     ]
   widgetTreeAlt
-    | model ^. clickCount `mod` 2 == 0 = widgetTree10
+    | even (model ^. clickCount) = widgetTree10
     | otherwise = widgetTree11
   widgetTree10 = vstack [
       hstack [
@@ -190,16 +190,20 @@ buildUI wenv model = trace "Creating UI" widgetIdChanged where
     ]
   widgetTree5 = zstack_ [
       hgrid [
-        label "test",
         vstack [
+          label "test",
+          button "Test" IncButton,
           textField textField1 `style` [bgColor blue],
           textField textField1 `style` [bgColor pink],
           textField textField1 `style` [bgColor orange]
         ]
       ],
-      hstack_ [
-        textField textField1 `style` [bgColor lightBlue, width 200]
-      ] [ignoreEmptyClick True]
+      hstack [
+        vgrid [
+          label "",
+          textField textField1 `style` [bgColor lightBlue, width 200]
+        ]
+      ]
     ] [onlyTopActive False]
   widgetTree4 = hgrid [
       label "" `style` [bgColor blue],

src/Monomer/Core/Combinators.hs

@@ -41,10 +41,6 @@ class Num a => CmbMaxValue t a | t -> a where
 class Num a => CmbDragRate t a | t -> a where
   dragRate :: a -> t
 
--- Container
-class CmbIgnoreEmptyClick t where
-  ignoreEmptyClick :: Bool -> t
-
 -- Text
 class CmbDecimals t where
   decimals :: Int -> t

src/Monomer/Widgets/Container.hs

@@ -138,10 +138,10 @@ type ContainerRenderHandler s e
 
 data Container s e = Container {
   containerUseScissor :: Bool,
-  containerIgnoreEmptyClick :: Bool,
   containerStyleOnMerge :: Bool,
   containerResizeRequired :: Bool,
-  containerKeepChildrenSizes :: Bool,
+  containerUseCustomSize :: Bool,
+  containerUseChildrenSizes :: Bool,
   containerGetBaseStyle :: ContainerGetBaseStyle s e,
   containerInit :: ContainerInitHandler s e,
   containerMerge :: ContainerMergeHandler s e,
@@ -162,10 +162,10 @@ data Container s e = Container {
 instance Default (Container s e) where
   def = Container {
     containerUseScissor = True,
-    containerIgnoreEmptyClick = False,
     containerStyleOnMerge = False,
     containerResizeRequired = True,
-    containerKeepChildrenSizes = False,
+    containerUseCustomSize = False,
+    containerUseChildrenSizes = False,
     containerGetBaseStyle = defaultGetBaseStyle,
     containerInit = defaultInit,
     containerMerge = defaultMerge,
@@ -433,8 +433,10 @@ findByPointWrapper
   -> WidgetNode s e
   -> Maybe Path
 findByPointWrapper container wenv start point node = result where
-  ignoreEmptyClick = containerIgnoreEmptyClick container
   handler = containerFindByPoint container
+  isVisible = node ^. L.info . L.visible
+  inVp = pointInViewport point node
+  path = node ^. L.info . L.path
   children = node ^. L.children
   newStartPath = Seq.drop 1 start
   childIdx = case newStartPath of
@@ -448,11 +450,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
-      | ignoreEmptyClick -> Nothing
-      | otherwise -> Just $ node ^. L.info . L.path
+    Nothing -> Just $ node ^. L.info . L.path
   result
-    | node ^. L.info . L.visible = resultPath
+    | isVisible && (inVp || resultPath /= Just path) = resultPath
     | otherwise = Nothing
 
 -- | Event Handling
@@ -588,10 +588,13 @@ resizeWrapper
   -> WidgetNode s e
 resizeWrapper container wenv viewport renderArea node = newNode where
   resizeRequired = containerResizeRequired container
-  vpChanged = viewport /= node ^. L.info . L.viewport
-  raChanged = renderArea /= node ^. L.info . L.renderArea
-  keepSizes = containerKeepChildrenSizes container
+  useCustomSize = containerUseCustomSize container
+  useChildrenSizes = containerUseChildrenSizes container
   handler = containerResize container
+  lensVp = L.info . L.viewport
+  lensRa = L.info . L.renderArea
+  vpChanged = viewport /= node ^. lensVp
+  raChanged = renderArea /= node ^. lensRa
   children = node ^. L.children
   (tempNode, assigned) = handler wenv viewport renderArea children node
   resize (child, (vp, ra)) = newChildNode where
@@ -601,13 +604,19 @@ resizeWrapper container wenv viewport renderArea node = newNode where
     icvp = fromMaybe vp (intersectRects vp cvp)
     icra = fromMaybe ra (intersectRects ra cra)
     newChildNode = tempChildNode
-      & L.info . L.viewport .~ (if keepSizes then icvp else vp)
-      & L.info . L.renderArea .~ (if keepSizes then icra else ra)
+      & L.info . L.viewport .~ (if useChildrenSizes then icvp else vp)
+      & L.info . L.renderArea .~ (if useChildrenSizes then icra else ra)
   newChildren = resize <$> Seq.zip children assigned
+  newVp
+    | useCustomSize = tempNode ^. lensVp
+    | otherwise = viewport
+  newRa
+    | useCustomSize = tempNode ^. lensRa
+    | otherwise = renderArea
   newNode
     | resizeRequired || vpChanged || raChanged = tempNode
-      & L.info . L.viewport .~ viewport
-      & L.info . L.renderArea .~ renderArea
+      & L.info . L.viewport .~ newVp
+      & L.info . L.renderArea .~ newRa
       & L.children .~ newChildren
     | otherwise = node
 

src/Monomer/Widgets/Single.hs

@@ -103,6 +103,7 @@ type SingleRenderHandler s e
 data Single s e = Single {
   singleStyleChangeCfg :: StyleChangeCfg,
   singleFocusOnPressedBtn :: Bool,
+  singleUseCustomSize :: Bool,
   singleGetBaseStyle :: SingleGetBaseStyle s e,
   singleGetActiveStyle :: SingleGetActiveStyle s e,
   singleInit :: SingleInitHandler s e,
@@ -122,6 +123,7 @@ instance Default (Single s e) where
   def = Single {
     singleStyleChangeCfg = def,
     singleFocusOnPressedBtn = True,
+    singleUseCustomSize = False,
     singleGetBaseStyle = defaultGetBaseStyle,
     singleGetActiveStyle = defaultGetActiveStyle,
     singleInit = defaultInit,
@@ -269,11 +271,20 @@ resizeHandlerWrapper
   -> WidgetNode s e
   -> WidgetNode s e
 resizeHandlerWrapper single wenv viewport renderArea node = newNode where
+  useCustomSize = singleUseCustomSize single
   handler = singleResize single
   tempNode = handler wenv viewport renderArea node
+  lensVp = L.info . L.viewport
+  lensRa = L.info . L.renderArea
+  newVp
+    | useCustomSize = tempNode ^. lensVp
+    | otherwise = viewport
+  newRa
+    | useCustomSize = tempNode ^. lensRa
+    | otherwise = renderArea
   newNode = tempNode
-    & L.info . L.viewport .~ viewport
-    & L.info . L.renderArea .~ renderArea
+    & L.info . L.viewport .~ newVp
+    & L.info . L.renderArea .~ newRa
 
 defaultRender :: SingleRenderHandler s e
 defaultRender renderer wenv node = return ()

src/Monomer/Widgets/Stack.hs

@@ -1,8 +1,6 @@
 module Monomer.Widgets.Stack (
   hstack,
-  hstack_,
-  vstack,
-  vstack_
+  vstack
 ) where
 
 import Control.Applicative ((<|>))
@@ -19,62 +17,25 @@ import Monomer.Widgets.Container
 
 import qualified Monomer.Lens as L
 
-newtype StackCfg = StackCfg {
-  _stcIgnoreEmptyClick :: Maybe Bool
-}
-
-instance Default StackCfg where
-  def = StackCfg Nothing
-
-instance Semigroup StackCfg where
-  (<>) s1 s2 = StackCfg {
-    _stcIgnoreEmptyClick = _stcIgnoreEmptyClick s2 <|> _stcIgnoreEmptyClick s1
-  }
-
-instance Monoid StackCfg where
-  mempty = def
-
-instance CmbIgnoreEmptyClick StackCfg where
-  ignoreEmptyClick ignore = def {
-    _stcIgnoreEmptyClick = Just ignore
-  }
-
 hstack :: (Traversable t) => t (WidgetNode s e) -> WidgetNode s e
-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)
+hstack children = newNode where
+  newNode = defaultWidgetNode "hstack" (makeStack True)
     & L.children .~ foldl' (|>) Empty children
 
 vstack :: (Traversable t) => t (WidgetNode s e) -> WidgetNode s e
-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)
+vstack children = newNode where
+  newNode = defaultWidgetNode "vstack" (makeStack False)
     & L.children .~ foldl' (|>) Empty children
 
-makeStack :: Bool -> StackCfg -> Widget s e
-makeStack isHorizontal config = widget where
+makeStack :: Bool -> Widget s e
+makeStack isHorizontal = widget where
   widget = createContainer def {
-    containerIgnoreEmptyClick = ignoreEmptyClick,
+    containerUseCustomSize = True,
     containerFindByPoint = defaultFindByPoint,
     containerGetSizeReq = getSizeReq,
     containerResize = resize
   }
 
-  ignoreEmptyClick = _stcIgnoreEmptyClick config == Just True
   isVertical = not isHorizontal
 
   getSizeReq wenv node children = (newSizeReqW, newSizeReqH) where
@@ -118,9 +79,16 @@ makeStack isHorizontal config = widget where
       newSize = resizeChild contentArea flexCoeff extraCoeff offset child
       newAccum = accum |> newSize
       newOffset = offset + rectSelector newSize
-    (newViewports, _) = foldl' foldHelper (Seq.empty, mainStart) children
+    (newViewports, newDim) = foldl' foldHelper (Seq.empty, mainStart) children
+    newCa
+      | isHorizontal = contentArea & L.w .~ newDim
+      | otherwise = contentArea & L.h .~ newDim
+    newRa = fromMaybe newCa (addOuterBounds style newCa)
+    newNode = node
+      & L.info . L.viewport .~ newRa
+      & L.info . L.renderArea .~ newRa
     assignedArea = Seq.zip newViewports newViewports
-    resized = (node, assignedArea)
+    resized = (newNode, assignedArea)
 
   resizeChild contentArea flexCoeff extraCoeff offset child = result where
     Rect l t w h = contentArea

src/Monomer/Widgets/ZStack.hs

@@ -11,7 +11,7 @@ import Control.Lens ((&), (^.), (.~), (%~))
 import Control.Monad (forM_, void, when)
 import Data.Default
 import Data.Maybe
-import Data.List (foldl')
+import Data.List (foldl', any)
 import Data.Sequence (Seq(..), (<|), (|>))
 
 import qualified Data.Sequence as Seq
@@ -56,7 +56,7 @@ zstack_ children configs = newNode where
 makeZStack :: ZStackCfg -> Widget s e
 makeZStack config = widget where
   baseWidget = createContainer def {
-    containerKeepChildrenSizes = True,
+    containerUseChildrenSizes = True,
     containerMergePost = mergePost,
     containerFindNextFocus = findNextFocus,
     containerGetSizeReq = getSizeReq,
@@ -67,6 +67,8 @@ makeZStack config = widget where
     widgetRender = render
   }
 
+  onlyTopActive = fromMaybe True (_zscOnlyTopActive config)
+
   mergePost wenv result oldState oldNode newNode = newResult where
     children = newNode ^. L.children
     focusedPath = wenv ^. L.focusedPath
@@ -83,20 +85,18 @@ makeZStack config = widget where
 
   -- | Find instance matching point
   findByPoint wenv startPath point node = result where
-    onlyTop = fromMaybe True (_zscOnlyTopActive config)
     children = node ^. L.children
     vchildren
-      | onlyTop = Seq.take 1 $ Seq.filter (_wniVisible . _wnInfo) children
+      | onlyTopActive = Seq.take 1 $ Seq.filter (_wniVisible . _wnInfo) children
       | otherwise = Seq.filter (_wniVisible . _wnInfo) children
     newStartPath = Seq.drop 1 startPath
     result = findFirstByPoint vchildren wenv newStartPath point
 
   findNextFocus wenv direction start node = result where
-    onlyTop = fromMaybe True (_zscOnlyTopActive config)
     children = node ^. L.children
     vchildren = Seq.filter (_wniVisible . _wnInfo) children
     result
-      | onlyTop = Seq.take 1 vchildren
+      | onlyTopActive = Seq.take 1 vchildren
       | otherwise = vchildren
 
   getSizeReq wenv node children = (newSizeReqW, newSizeReqH) where
@@ -128,9 +128,15 @@ makeZStack config = widget where
       renderArea = node ^. L.info . L.renderArea
       isVisible c = c ^. L.info . L.visible
       topVisibleIdx = fromMaybe 0 (Seq.findIndexR (_wniVisible . _wnInfo) children)
-      isTopLayer idx child point = prevTopLayer && isTopChild where
-        isTopChild = idx == topVisibleIdx
+      isPointEmpty point idx = not covered where
+        prevs = Seq.drop (idx + 1) children
+        isCovered c = isVisible c && pointInViewport point c
+        covered = any isCovered prevs
+      isTopLayer idx child point = prevTopLayer && isValid where
         prevTopLayer = _weInTopLayer wenv point
+        isValid
+          | onlyTopActive = idx == topVisibleIdx
+          | otherwise = isPointEmpty point idx
       cWenv idx child = wenv {
         _weInTopLayer = isTopLayer idx child
       }

tasks.md

@@ -358,6 +358,7 @@
     - Validate stack assigns space correctly
     - 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)
 
 - Pending
   - Add header in all files, indicating license and documenting what the module does
@@ -371,7 +372,8 @@
 
 Maybe postponed after release?
   - ZStack should set _weIsTopLayer based on used space
-  - Button should handle ReleaseBtn instead of Click (allow multi click)
+  - Reimplement containerIgnoreEmptyClick
+  - Box should allow setting size of children and ignore the rest
   - Check multiple resize when opening dialogs
   - Listview is not properly changing styles
     - Label needs to rebuild its glyphs if style/renderArea changes

test/unit/Monomer/Widgets/StackSpec.hs

@@ -81,7 +81,8 @@ resizeEmpty = describe "empty" $ do
 
   where
     wenv = mockWenv ()
-    vp = Rect 0 0 640 480
+    -- Main axis is adjusted to content
+    vp = Rect 0 0 640 0
     vstackNode = vstack []
     newNode = nodeInit wenv vstackNode
     viewport = newNode ^. L.info . L.viewport
@@ -208,7 +209,7 @@ resizeMixedH = describe "mixed items, horizontal" $ do
 
   where
     wenv = mockWenv ()
-    vp   = Rect   0 0 640 480
+    vp   = Rect   0 0 640  20
     cvp1 = Rect   0 0 196  20
     cvp2 = Rect 196 0 444  20
     hstackNode = vstack [
@@ -286,8 +287,9 @@ resizeAllV = describe "all kinds of sizeReq, vertical" $ do
 
 resizeNoSpaceV :: Spec
 resizeNoSpaceV = describe "vertical, without enough space" $ do
-  it "should have the provided viewport size" $
+  it "should have a larger viewport size (parent should fix it)" $ do
     viewport `shouldBe` vp
+    renderArea `shouldBe` vp
 
   it "should assign size proportional to requested size to each children" $
     childrenVp `shouldBe` Seq.fromList [cvp1, cvp2, cvp3, cvp4, cvp5]
@@ -297,7 +299,7 @@ resizeNoSpaceV = describe "vertical, without enough space" $ do
 
   where
     wenv = mockWenv ()
-    vp   = Rect 0   0 640 480
+    vp   = Rect 0   0 640 800
     cvp1 = Rect 0   0 640 200
     cvp2 = Rect 0 200 640 200
     cvp3 = Rect 0 400 640   0
@@ -312,13 +314,14 @@ resizeNoSpaceV = describe "vertical, without enough space" $ do
       ]
     newNode = nodeInit wenv vstackNode
     viewport = newNode ^. L.info . L.viewport
+    renderArea = newNode ^. L.info . L.renderArea
     childrenVp = roundRectUnits . _wniViewport . _wnInfo <$> newNode ^. L.children
     childrenRa = roundRectUnits . _wniRenderArea . _wnInfo <$> newNode ^. L.children
 
 resizeSpacerFlexH :: Spec
 resizeSpacerFlexH = describe "label flex and spacer, horizontal" $ do
   it "should have the provided viewport size" $
-    viewport `shouldBe` vp
+    roundRectUnits viewport `shouldBe` vp
 
   it "should assign size proportional to requested size to each children" $
     childrenVp `shouldBe` Seq.fromList [cvp1, cvp2, cvp3]

test/unit/Monomer/Widgets/ZStackSpec.hs

@@ -72,15 +72,15 @@ handleEventAllLayersActive = describe "handleEventAllLayersActive" $ do
     clickEvts (Point 3000 3000) `shouldBe` Seq.empty
 
   it "should click the first layer, since top is not visible and second does not have widgets in that location" $
-    clickEvts (Point 200 100) `shouldBe` Seq.singleton (BtnClick 1)
+    clickEvts (Point 200 15) `shouldBe` Seq.singleton (BtnClick 1)
 
   where
     wenv = mockWenv ()
     zstackNode = zstack_ [
         button "Click 1" (BtnClick 1),
-        hstack_ [
-          button "Click 2" (BtnClick 2) `style` [width 100]
-        ] [ignoreEmptyClick True],
+        vstack [
+          button "Click 2" (BtnClick 2) `style` [height 10]
+        ],
         button "Click 3" (BtnClick 3) `visible` False
       ] [onlyTopActive False]
     clickEvts p = nodeHandleEventEvts wenv [Click p LeftBtn] zstackNode