Add boxFilterEvent config option, exposing Container's filterEvent functionality (#146)

* Add boxFilterEvent to box, exposing Container's filterEvent functionality

* Add unit tests

* Update Changelog

ChangeLog.md

@@ -4,6 +4,7 @@
 
 - Support for switching vertical wheel scrolling to horizontal in scroll widget by pressing the shift key ([PR #137](https://github.com/fjvallarino/monomer/pull/137)).
 - Drawing and theme utility functions ([PR #138](https://github.com/fjvallarino/monomer/pull/138)).
+- `boxFilterEvent` config option, exposing Container's filterEvent functionality ([PR #146](https://github.com/fjvallarino/monomer/pull/146)).
 
 ## 1.4.0.0
 

src/Monomer/Widgets/Container.hs

@@ -258,7 +258,7 @@ type ContainerFindByPointHandler s e
 
 {-|
 Receives a System event and, optionally, modifies the event, its target, or
-cancels the event propagation by returning null.
+stops the event propagation by returning Nothing.
 
 Examples can be found in "Monomer.Widgets.Containers.Base.LabeledItem".
 -}

src/Monomer/Widgets/Containers/Box.hs

@@ -58,7 +58,8 @@ module Monomer.Widgets.Containers.Box (
   -- * Constructors
   box,
   box_,
-  expandContent
+  expandContent,
+  boxFilterEvent
 ) where
 
 import Control.Applicative ((<|>))
@@ -101,11 +102,13 @@ Configuration options for box:
 - 'onClickEmptyReq': generates a WidgetRequest on click in empty area.
 - 'expandContent': if the inner widget should use all the available space. To be
   able to use alignment options, this must be False (the default).
+- 'boxFilterEvent': allows filtering or modifying a 'SystemEvent'.
 -}
 data BoxCfg s e = BoxCfg {
   _boxExpandContent :: Maybe Bool,
   _boxIgnoreEmptyArea :: Maybe Bool,
   _boxSizeReqUpdater :: [SizeReqUpdater],
+  _boxFilterEvent :: Maybe (ContainerFilterHandler s e),
   _boxMergeRequired :: Maybe (WidgetEnv s e -> s -> s -> Bool),
   _boxAlignH :: Maybe AlignH,
   _boxAlignV :: Maybe AlignV,
@@ -124,6 +127,7 @@ instance Default (BoxCfg s e) where
     _boxExpandContent = Nothing,
     _boxIgnoreEmptyArea = Nothing,
     _boxSizeReqUpdater = [],
+    _boxFilterEvent = Nothing,
     _boxMergeRequired = Nothing,
     _boxAlignH = Nothing,
     _boxAlignV = Nothing,
@@ -142,6 +146,7 @@ instance Semigroup (BoxCfg s e) where
     _boxExpandContent = _boxExpandContent t2 <|> _boxExpandContent t1,
     _boxIgnoreEmptyArea = _boxIgnoreEmptyArea t2 <|> _boxIgnoreEmptyArea t1,
     _boxSizeReqUpdater = _boxSizeReqUpdater t1 <> _boxSizeReqUpdater t2,
+    _boxFilterEvent = _boxFilterEvent t2 <|> _boxFilterEvent t1,
     _boxMergeRequired = _boxMergeRequired t2 <|> _boxMergeRequired t1,
     _boxAlignH = _boxAlignH t2 <|> _boxAlignH t1,
     _boxAlignV = _boxAlignV t2 <|> _boxAlignV t1,
@@ -295,6 +300,15 @@ expandContent = def {
   _boxExpandContent = Just True
 }
 
+{-|
+Receives a System event and, optionally, modifies the event, its target, or
+stops the event propagation by returning Nothing.
+-}
+boxFilterEvent :: ContainerFilterHandler s e -> BoxCfg  s e
+boxFilterEvent handler = def {
+  _boxFilterEvent = Just handler
+}
+
 newtype BoxState s = BoxState {
   _bxsModel :: Maybe s
 }
@@ -330,6 +344,7 @@ makeBox config state = widget where
     containerInit = init,
     containerMergeChildrenReq = mergeRequired,
     containerMerge = merge,
+    containerFilterEvent = filterEvent,
     containerHandleEvent = handleEvent,
     containerGetSizeReq = getSizeReq,
     containerResize = resize
@@ -358,6 +373,10 @@ makeBox config state = widget where
     currentStyleConfig = def
       & L.isActive .~ isNodeTreeActive
 
+  filterEvent = case _boxFilterEvent config of
+    Just handler -> handler
+    _ -> \wenv node target evt -> Just (target, evt)
+
   handleEvent wenv node target evt = case evt of
     Focus prev -> handleFocusChange node prev (_boxOnFocusReq config)
     Blur next -> handleFocusChange node next (_boxOnBlurReq config)

test/unit/Monomer/Widgets/Containers/BoxSpec.hs

@@ -26,6 +26,7 @@ import Monomer.Graphics
 import Monomer.TestEventUtil
 import Monomer.TestUtil
 import Monomer.Widgets.Containers.Box
+import Monomer.Widgets.Containers.Grid
 import Monomer.Widgets.Containers.ZStack
 import Monomer.Widgets.Singles.Button
 import Monomer.Widgets.Singles.Label
@@ -45,6 +46,7 @@ data TestEvent
 spec :: Spec
 spec = describe "Box" $ do
   mergeReq
+  filterEvent
   handleEvent
   handleEventIgnoreEmpty
   handleEventSinkEmpty
@@ -75,6 +77,29 @@ mergeReq = describe "mergeReq" $ do
       oldNode2 = nodeInit wenv oldNode
       result = widgetMerge (newNode ^. L.widget) wenv newNode oldNode2
 
+filterEvent :: Spec
+filterEvent = describe "filterEvent" $ do
+  it "should click the first button, since the click event was directed to it" $
+    evts False [evtClick point1] `shouldBe` Seq.singleton (BtnClick 1)
+
+  it "should click the second button, since the click event's target was modified" $
+    evts True [evtClick point1] `shouldBe` Seq.singleton (BtnClick 2)
+
+  where
+    wenv = mockWenv ()
+    point1 = Point 320 200
+    point2 = Point 320 400
+
+    filterEvent wenv node target evt = Just (target & ix 2 .~ 1, evtClick point2)
+
+    btnBox ignore = box_ (expandContent : [boxFilterEvent filterEvent | ignore]) $
+      vgrid [
+        button "Button 1" (BtnClick 1),
+        button "Button 2" (BtnClick 2)
+      ]
+    evts ignore es = nodeHandleEventEvts wenv es $
+      nodeInit wenv (btnBox ignore)
+
 handleEvent :: Spec
 handleEvent = describe "handleEvent" $ do
   it "should not generate an event if clicked outside" $