diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,9 @@ +## 0.2.1.0 +### Changed +- Require the latest monomer (1.5.1.0), to get the fix for https://github.com/fjvallarino/monomer/issues/225 +### Fixed +- Always expand into all available space, even with no items in the grid, for consistency. + ## 0.2.0.1 ### Fixed - Fix a bug where the grid did not update when the model went from empty to non-empty. diff --git a/monomer-hagrid.cabal b/monomer-hagrid.cabal --- a/monomer-hagrid.cabal +++ b/monomer-hagrid.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: monomer-hagrid -version: 0.2.0.1 +version: 0.2.1.0 license: MIT license-file: LICENSE maintainer: garethdanielsmith@gmail.com @@ -40,7 +40,7 @@ data-default-class <0.2, ilist <0.5, lens <5.2, - monomer >=1.5.0.0 && <1.6, + monomer >=1.5.1.0 && <1.6, text <1.3 executable example-basic @@ -64,7 +64,7 @@ data-default-class <0.2, ilist <0.5, lens <5.2, - monomer >=1.5.0.0 && <1.6, + monomer >=1.5.1.0 && <1.6, monomer-hagrid, text <1.3, time <1.12 @@ -90,7 +90,7 @@ data-default-class <0.2, ilist <0.5, lens <5.2, - monomer >=1.5.0.0 && <1.6, + monomer >=1.5.1.0 && <1.6, monomer-hagrid, text <1.3 @@ -115,7 +115,7 @@ data-default-class <0.2, ilist <0.5, lens <5.2, - monomer >=1.5.0.0 && <1.6, + monomer >=1.5.1.0 && <1.6, monomer-hagrid, random <1.3, text <1.3 @@ -150,7 +150,7 @@ hspec >=2 && <3, ilist <0.5, lens <5.2, - monomer >=1.5.0.0 && <1.6, + monomer >=1.5.1.0 && <1.6, monomer-hagrid, mtl <2.3, stm <2.6, diff --git a/src/Monomer/Hagrid.hs b/src/Monomer/Hagrid.hs --- a/src/Monomer/Hagrid.hs +++ b/src/Monomer/Hagrid.hs @@ -37,15 +37,16 @@ where import Control.Applicative ((<|>)) -import Control.Lens (ix, (.~), (<>~), (^.), (^?!)) +import Control.Lens (ix, (.~), (^.), (^?!)) import Control.Lens.Combinators (non) import Control.Lens.Lens ((&)) +import Control.Lens.Operators ((%~)) import Control.Monad as X (forM_) import Data.Data (Typeable) import Data.Default.Class (Default, def) import Data.Foldable (foldl') import Data.List.Index (indexed, izipWith, modifyAt) -import Data.Maybe (catMaybes, fromJust, isNothing, maybeToList) +import Data.Maybe (catMaybes, isNothing, maybeToList) import Data.Maybe as X (fromMaybe) import Data.Ord (Down (Down)) import Data.Sequence (Seq ((:<|), (:|>))) @@ -177,14 +178,14 @@ -- in the grid, regardless of the current order). 'Nothing' will cancel the scroll. Maybe Int -data HagridEvent ep +data HagridEvent e = ContentScrollChange ScrollStatus | OrderByColumn Int | ResizeColumn Int Int | ResizeColumnFinished Int | forall a. Typeable a => ScrollToRow (ScrollToRowCallback a) | ScrollToRect Rect - | ParentEvent ep + | ParentEvent e data HagridModel a = HagridModel { sortedItems :: Seq (ItemWithIndex a), @@ -200,14 +201,16 @@ } deriving (Eq, Show) --- | The state of the header or footer, which have a scroll offset because they --- scroll horizontally along with the content pane. -newtype OffsetXState = OffsetXState - { offsetX :: Double +-- | The state of the header or footer. +data HeaderFooterState = HeaderFooterState + { -- | The width of each column. + columnWidths :: [Int], + -- | The horizontal scroll position: always matches the content pane horizontal scroll position. + offsetX :: Double } deriving (Eq, Show) -newtype OffsetXEvent = SetOffsetX Double +newtype HeaderFooterEvent = SetOffsetX Double data HeaderDragHandleState = HeaderDragHandleState { dragStartMouseX :: Double, @@ -241,10 +244,10 @@ | ContentPaneReinflating deriving (Eq, Show) -data ContentPaneEvent ep +data ContentPaneEvent e = SetVisibleArea {visibleArea :: Rect} | InnerResizeComplete - | ContentPaneParentEvent ep + | ContentPaneParentEvent e | forall a. Typeable a => ContentPaneScrollToRow (ScrollToRowCallback a) -- | Creates a hagrid widget, using the default configuration. @@ -286,15 +289,24 @@ tree = vstack [ headerPane columnDefs model `nodeKey` headerPaneKey, - contentScroll `nodeKey` contentScrollKey, + contentScroll + `styleBasic` [sizeReqW useExtra, sizeReqH useExtra] + `nodeKey` contentScrollKey, footerPane columnDefs model `nodeKey` footerPaneKey ] contentScroll = scroll_ [onChange ContentScrollChange] $ contentPaneOuter columnDefs model `nodeKey` contentPaneOuterKey + useExtra = + SizeReq + { _szrFixed = 0, + _szrFlex = 0, + _szrExtra = 1, + _szrFactor = 1 + } handleEvent :: EventHandler (HagridModel a) (HagridEvent e) sp e - handleEvent wenv _node model = \case + handleEvent _wenv _node model = \case ScrollToRow callback -> [Message (WidgetKey contentPaneOuterKey) (ContentPaneScrollToRow callback :: ContentPaneEvent e)] ScrollToRect rect -> @@ -325,10 +337,7 @@ handler = Report <$> maybeToList (sortHandler <*> (snd <$> sortColumn)) ResizeColumn colIndex newWidth -> - [ Model (model {columns = modifyAt colIndex (\c -> c {currentWidth = newWidth}) model.columns}), - Request (ResizeWidgets headerPaneId), - Request (ResizeWidgets footerPaneId) - ] + [Model (model {columns = modifyAt colIndex (\c -> c {currentWidth = newWidth}) model.columns})] ResizeColumnFinished colIndex -> result where ModelColumn {currentWidth} = model.columns !! colIndex @@ -337,9 +346,6 @@ Report <$> maybeToList (resizeHandler <*> Just currentWidth) ParentEvent e -> [Report e] - where - headerPaneId = fromJust (widgetIdFromKey wenv (WidgetKey headerPaneKey)) - footerPaneId = fromJust (widgetIdFromKey wenv (WidgetKey footerPaneKey)) -- If the column names have not changed then preseve the column widths and sort -- order too, otherwise unrelated model changes will reset the column widths/sort. @@ -377,10 +383,10 @@ color = fromMaybe (rgb 255 255 255) (_sstText style >>= _txsFontColor) transColor = color {_colorA = 0.7} -headerPane :: forall s ep a. WidgetEvent ep => [Column ep a] -> HagridModel a -> WidgetNode s (HagridEvent ep) -headerPane columnDefs model = makeNode (OffsetXState 0) +headerPane :: forall e a. WidgetEvent e => [Column e a] -> HagridModel a -> WidgetNode (HagridModel a) (HagridEvent e) +headerPane columnDefs model = makeNode (initialHeaderFooterState model) where - makeNode :: OffsetXState -> WidgetNode s (HagridEvent ep) + makeNode :: HeaderFooterState -> WidgetNode (HagridModel a) (HagridEvent e) makeNode state = node where node = @@ -395,50 +401,14 @@ btn = headerButton i columnDef handle = headerDragHandle i columnDef column - makeWidget :: OffsetXState -> Widget s (HagridEvent ep) + makeWidget :: HeaderFooterState -> Widget (HagridModel a) (HagridEvent e) makeWidget state = container where container = - createContainer + createHeaderFooter state - def - { containerChildrenOffset = Just (Point state.offsetX 0), - containerUpdateCWenv = updateCWenv, - containerMerge = merge, - containerHandleMessage = handleMessage, - containerGetSizeReq = getSizeReq, - containerResize = resize, - containerRenderAfter = renderAfter - } - - -- needed to ensure child widgets don't disappear when scrolling - updateCWenv wenv node _cnode _cidx = newWenv - where - style = currentStyle wenv node - carea = getContentArea node style - newWenv = - wenv - & L.viewport .~ moveRect (Point (-state.offsetX) 0) carea - - -- keep the scroll offset from the old node - merge _wenv node _oldNode oldState = resultNode newNode - where - newNode = node & L.widget .~ makeWidget oldState - - handleMessage :: ContainerMessageHandler s (HagridEvent ep) - handleMessage _wenv node _target msg = result - where - handleTypedMessage (SetOffsetX offsetX) - | offsetX == state.offsetX = Nothing - | otherwise = - Just . resultNode $ - node & L.widget .~ makeWidget state {offsetX} - result = cast msg >>= handleTypedMessage - - getSizeReq _wenv _node _children = (w, h) - where - w = fixedSize (sum (fromIntegral . currentWidth <$> model.columns) + hScrollFudgeFactor) - h = fixedSize dragHandleHeight + makeWidget + def {containerResize = resize, containerRenderAfter = renderAfter} resize _wenv node viewport _children = (resultNode node, assignedAreas) where @@ -447,12 +417,12 @@ (i, w) <- indexed (currentWidth <$> model.columns) -- center the drag handle inbetween the columns let buttonW - | i == 0 = w - (dragHandleWidth `div` 2) - | otherwise = w - dragHandleWidth + | i == 0 = fromIntegral w - (dragHandleWidth / 2) + | otherwise = fromIntegral w - dragHandleWidth [buttonW, dragHandleWidth] (assignedAreas, _) = foldl' assignArea (mempty, l) widgetWidths assignArea (areas, colX) columnWidth = - (areas :|> Rect colX t (fromIntegral columnWidth) h, colX + fromIntegral columnWidth) + (areas :|> Rect colX t columnWidth h, colX + columnWidth) renderAfter wenv node renderer = forM_ model.sortColumn (renderSortIndicator wenv node renderer) @@ -475,72 +445,37 @@ indL = l + w + state.offsetX - indW - pad indRect = Rect indL indT indW indW -headerButton :: WidgetEvent ep => Int -> Column ep a -> WidgetNode s (HagridEvent ep) +headerButton :: WidgetEvent e => Int -> Column e a -> WidgetNode (HagridModel a) (HagridEvent e) headerButton colIndex columnDef = button_ columnDef.name (OrderByColumn colIndex) [ellipsis] `styleBasic` [radius 0] footerPane :: - forall s ep a. - (CompositeModel a, CompositeModel s, Typeable ep) => - [Column ep a] -> + forall e a. + (CompositeModel a, WidgetEvent e) => + [Column e a] -> HagridModel a -> - WidgetNode (HagridModel s) (HagridEvent ep) -footerPane columnDefs model = makeNode (OffsetXState 0) + WidgetNode (HagridModel a) (HagridEvent e) +footerPane columnDefs model = makeNode (initialHeaderFooterState model) where - makeNode :: OffsetXState -> WidgetNode (HagridModel s) (HagridEvent ep) + makeNode :: HeaderFooterState -> WidgetNode (HagridModel a) (HagridEvent e) makeNode state = node where node = defaultWidgetNode "Hagrid.FooterPane" (makeWidget state) & L.children .~ S.fromList (catMaybes childWidgets) - childWidgets :: [Maybe (WidgetNode (HagridModel s) (HagridEvent ep))] + childWidgets :: [Maybe (WidgetNode (HagridModel a) (HagridEvent e))] childWidgets = footerWidgetNode model.sortedItems . footerWidget <$> columnDefs - makeWidget :: OffsetXState -> Widget (HagridModel s) (HagridEvent ep) + makeWidget :: HeaderFooterState -> Widget (HagridModel a) (HagridEvent e) makeWidget state = container where container = - createContainer + createHeaderFooter state - def - { containerChildrenOffset = Just (Point state.offsetX 0), - containerUpdateCWenv = updateCWenv, - containerMerge = merge, - containerHandleMessage = handleMessage, - containerGetSizeReq = getSizeReq, - containerResize = resize - } - - -- needed to ensure child widgets don't disappear when scrolling - updateCWenv wenv node _cnode _cidx = newWenv - where - style = currentStyle wenv node - carea = getContentArea node style - newWenv = - wenv - & L.viewport .~ moveRect (Point (-state.offsetX) 0) carea - - -- keep the scroll offset from the old node - merge _wenv node _oldNode oldState = resultNode newNode - where - newNode = node & L.widget .~ makeWidget oldState - - handleMessage :: ContainerMessageHandler (HagridModel s) (HagridEvent ep) - handleMessage _wenv node _target msg = result - where - handleTypedMessage (SetOffsetX offsetX) - | offsetX == state.offsetX = Nothing - | otherwise = - Just . resultNode $ - node & L.widget .~ makeWidget state {offsetX} - result = cast msg >>= handleTypedMessage - - getSizeReq _wenv _node children = (w, h) - where - w = fixedSize (sum (fromIntegral . currentWidth <$> model.columns) + hScrollFudgeFactor) - h = foldl' sizeReqMergeMax (fixedSize 0) (_wniSizeReqH . _wnInfo <$> children) + makeWidget + def {containerResize = resize} resize _wenv node viewport _children = (resultNode node, assignedAreas) where @@ -553,7 +488,59 @@ | otherwise = areas :|> Rect colX t (fromIntegral currentWidth) h newColX = colX + fromIntegral currentWidth -headerDragHandle :: WidgetEvent ep => Int -> Column ep a -> ModelColumn -> WidgetNode s (HagridEvent ep) +initialHeaderFooterState :: HagridModel a -> HeaderFooterState +initialHeaderFooterState model = + HeaderFooterState + { columnWidths = currentWidth <$> model.columns, + offsetX = 0 + } + +createHeaderFooter :: + forall a e. + HeaderFooterState -> + (HeaderFooterState -> Widget (HagridModel a) (HagridEvent e)) -> + Container (HagridModel a) (HagridEvent e) HeaderFooterState -> + Widget (HagridModel a) (HagridEvent e) +createHeaderFooter state makeWidget container = + createContainer + state + container + { containerChildrenOffset = Just (Point state.offsetX 0), + containerUpdateCWenv = updateCWenv, + containerMerge = merge, + containerHandleMessage = handleMessage, + containerGetSizeReq = getSizeReq + } + where + -- ensures child widgets don't disappear when scrolling + updateCWenv wenv node _cnode _cidx = newWenv + where + style = currentStyle wenv node + carea = getContentArea node style + newWenv = wenv & L.viewport .~ moveRect (Point (-state.offsetX) 0) carea + + merge _wenv node _oldNode oldState = resultReqs newNode reqs + where + newNode = node & L.widget .~ makeWidget state {offsetX = oldState.offsetX} + reqs = [ResizeWidgets (node ^. L.info . L.widgetId) | needResize] + needResize = oldState.columnWidths /= state.columnWidths + + getSizeReq _wenv _node children = (w, h) + where + w = fixedSize (fromIntegral (sum state.columnWidths) + hScrollFudgeFactor) + h = foldl' sizeReqMergeMax (fixedSize 0) (_wniSizeReqH . _wnInfo <$> children) + + handleMessage :: ContainerMessageHandler (HagridModel a) (HagridEvent e) + handleMessage _wenv node _target msg = result + where + handleTypedMessage (SetOffsetX offsetX) + | offsetX == state.offsetX = Nothing + | otherwise = + Just . resultNode $ + node & L.widget .~ makeWidget state {offsetX} + result = cast msg >>= handleTypedMessage + +headerDragHandle :: WidgetEvent e => Int -> Column e a -> ModelColumn -> WidgetNode s (HagridEvent e) headerDragHandle colIndex columnDef column = tree where tree = defaultWidgetNode "Hagrid.HeaderDragHandle" (headerDragHandleWidget Nothing) @@ -565,6 +552,7 @@ state def { singleGetBaseStyle = getBaseStyle, + singleGetSizeReq = getSizeReq, singleMerge = merge, singleHandleEvent = handleEvent, singleRender = render @@ -573,6 +561,9 @@ getBaseStyle _wenv _node = Just def {_styleBasic = Just def {_sstCursorIcon = Just CursorSizeH}} + getSizeReq _wenv _node = + (fixedSize dragHandleWidth, fixedSize dragHandleHeight) + merge _wenv newNode _oldNode oldState = -- preserve the drag state (this will be called continually as the column resizes) resultNode $ newNode & L.widget .~ headerDragHandleWidget oldState @@ -593,9 +584,7 @@ result | Just nw <- newColumnW = resizeRequest - & L.requests - <>~ S.fromList - [RaiseEvent (ResizeColumn colIndex nw)] + & L.requests %~ (:|> RaiseEvent (ResizeColumn colIndex nw)) | otherwise = resultReqs node [] newColumnW = do @@ -606,7 +595,6 @@ resizeRequest = widgetResize (node ^. L.widget) wenv node vp (const True) vp = node ^. L.info . L.viewport - render :: WidgetEnv s e -> WidgetNode s e -> Renderer -> IO () render wenv node renderer = do drawRect renderer vp (Just (accentColor wenv)) Nothing where @@ -614,15 +602,15 @@ -- | This needs to be at least as big as the width of a vertical scrollbar. hScrollFudgeFactor :: Double -hScrollFudgeFactor = 100 +hScrollFudgeFactor = 20 -- | Composite wrapper to allow creating/removing child widgets during resize. contentPaneOuter :: - forall a ep. - (CompositeModel a, WidgetEvent ep) => - [Column ep a] -> + forall a e. + (CompositeModel a, WidgetEvent e) => + [Column e a] -> HagridModel a -> - WidgetNode (HagridModel a) (HagridEvent ep) + WidgetNode (HagridModel a) (HagridEvent e) contentPaneOuter columnDefs model = compositeD_ "Hagrid.ContentPaneOuter" @@ -653,8 +641,8 @@ itemsAfterInflated = length parentModel.sortedItems - itemsBeforeInflated - length inflatedItems inflatedItems = takeAt itemsBeforeInflated (length oldModel.inflatedItems) parentModel.sortedItems - buildUI _wenv cpModel = - contentPaneInner (S.fromList columnDefs) model cpModel + buildUI _wenv = + contentPaneInner (S.fromList columnDefs) model handleEvent _wenv node cpModel = \case SetVisibleArea visibleArea -> result @@ -751,16 +739,16 @@ vp = node ^. L.info . L.viewport visibleWidth = cpModel.visibleArea._rW visibleHeight = cpModel.visibleArea._rH - ContentPaneParentEvent ep -> - [Report (ParentEvent ep)] + ContentPaneParentEvent e -> + [Report (ParentEvent e)] contentPaneInner :: - forall a ep. - (CompositeModel a, WidgetEvent ep) => - Seq (Column ep a) -> + forall a e. + (CompositeModel a, WidgetEvent e) => + Seq (Column e a) -> HagridModel a -> ContentPaneModel a -> - WidgetNode (ContentPaneModel a) (ContentPaneEvent ep) + WidgetNode (ContentPaneModel a) (ContentPaneEvent e) contentPaneInner columnDefs model cpModel = node where node = @@ -814,12 +802,12 @@ h = child ^. L.info . L.sizeReqH . L.fixed contentPaneRow :: - forall a ep. - (CompositeModel a, WidgetEvent ep) => - Seq (Column ep a) -> + forall a e. + (CompositeModel a, WidgetEvent e) => + Seq (Column e a) -> ContentPaneModel a -> (a, Int) -> - WidgetNode (ContentPaneModel a) (ContentPaneEvent ep) + WidgetNode (ContentPaneModel a) (ContentPaneEvent e) contentPaneRow columnDefs cpModel (item, rowIdx) = tree where tree = @@ -892,7 +880,7 @@ oddRowBgColor = (accentColor wenv) {_colorA = 0.1} lineColor = accentColor wenv -initialModel :: [HagridCfg s e] -> [Column ep a] -> Seq a -> HagridModel a +initialModel :: [HagridCfg s e] -> [Column e a] -> Seq a -> HagridModel a initialModel cfgs columnDefs items = model where model = @@ -950,7 +938,7 @@ offset = (y + fromIntegral indexInSection * model.mdlEstimatedItemHeight) - minVisibleY in (row, offset) -dragHandleWidth :: Int +dragHandleWidth :: Double dragHandleWidth = 4 dragHandleHeight :: Double @@ -969,7 +957,7 @@ footerPaneKey = "Hagrid.footerPane" sortItems :: - [Column ep a] -> + [Column e a] -> Maybe (Int, SortDirection) -> Seq (ItemWithIndex a) -> Seq (ItemWithIndex a) @@ -978,7 +966,7 @@ DontSort -> items SortWith f -> S.sortOn (f . fst) items -modelSortKey :: [Column ep a] -> Maybe (Int, SortDirection) -> ColumnSortKey a +modelSortKey :: [Column e a] -> Maybe (Int, SortDirection) -> ColumnSortKey a modelSortKey columnDefs sortColumn = case sortColumn of Just (sc, dir) | Column {sortKey = SortWith f} <- columnDefs !! sc -> @@ -988,7 +976,7 @@ _ -> DontSort -toRowHeight :: Seq (Column e2 a) -> Seq (WidgetNode s e1) -> Double +toRowHeight :: Seq (Column e a) -> Seq (WidgetNode s (ContentPaneEvent e)) -> Double toRowHeight columnDefs = mergeHeights where mergeHeights rowWidgets = @@ -1070,11 +1058,11 @@ } cellWidget :: - (CompositeModel a, WidgetEvent e, WidgetModel s) => + (CompositeModel a, WidgetEvent e) => Int -> a -> ColumnWidget e a -> - WidgetNode (ContentPaneModel s) (ContentPaneEvent e) + WidgetNode (ContentPaneModel a) (ContentPaneEvent e) cellWidget idx item = \case LabelWidget get -> label_ (get idx item) [ellipsis] CustomWidget get -> widget @@ -1087,10 +1075,10 @@ [Report (ContentPaneParentEvent e)] footerWidgetNode :: - (CompositeModel a, CompositeModel s, Typeable e) => + (CompositeModel a, WidgetEvent e) => Seq (ItemWithIndex a) -> ColumnFooterWidget e a -> - Maybe (WidgetNode (HagridModel s) (HagridEvent e)) + Maybe (WidgetNode (HagridModel a) (HagridEvent e)) footerWidgetNode items = \case NoFooterWidget -> Nothing CustomFooterWidget get -> Just widget diff --git a/test/Monomer/HagridSpec.hs b/test/Monomer/HagridSpec.hs --- a/test/Monomer/HagridSpec.hs +++ b/test/Monomer/HagridSpec.hs @@ -3,6 +3,7 @@ import Control.Concurrent (newEmptyMVar, putMVar, takeMVar) import Control.Lens ((&), (.~), (^.)) import qualified Data.Foldable as Foldable +import Data.Sequence (Seq) import qualified Data.Sequence as S import Data.Text (Text) import GHC.IO (unsafePerformIO) @@ -63,13 +64,26 @@ `shouldBe` [Rect 0 40 50 17] it "should have zero-height footer when no footer widgets specified" $ - viewports_ + hagridViewports [(testColumn "Col 1" (const (fixedSize 33))) {initialWidth = 50}] [TestItem (fixedSize 0)] [] "Hagrid.FooterPane" `shouldBe` [Rect 0 100 100 0] + it "should expand into available space both vertically and horizontally" $ do + viewports tree [] "Hagrid.Root" `shouldBe` [Rect 0 0 90 90] + where + tree = + vstack + [ hstack + [ hagrid [] (mempty :: Seq TestItem), + label10x10 + ], + label10x10 + ] + label10x10 = label "" `styleBasic` [width 10, height 10] + sorting :: Spec sorting = describe "sorting" $ do it "should not sort rows by default" $ do @@ -85,7 +99,7 @@ ] it "should sort in ascending order when column header clicked" $ do - cellViewports_ + cellViewportsEvts [(testColumn "Col 1" sizeReq) {initialWidth = 50, sortKey = SortWith (_szrFixed . sizeReq)}] [ TestItem (fixedSize 20), TestItem (fixedSize 10), @@ -98,7 +112,7 @@ ] it "should sort in descending order when column header clicked again" $ do - cellViewports_ + cellViewportsEvts [(testColumn "Col 1" sizeReq) {initialWidth = 50, sortKey = SortWith (_szrFixed . sizeReq)}] [ TestItem (fixedSize 20), TestItem (fixedSize 10), @@ -168,15 +182,20 @@ cellViewports :: [Column TestEvent TestItem] -> [TestItem] -> [Rect] cellViewports columnDefs items = - cellViewports_ columnDefs items [] + cellViewportsEvts columnDefs items [] -cellViewports_ :: [Column TestEvent TestItem] -> [TestItem] -> [SystemEvent] -> [Rect] -cellViewports_ columnDefs items evts = viewports_ columnDefs items evts "Hagrid.Cell" +cellViewportsEvts :: [Column TestEvent TestItem] -> [TestItem] -> [SystemEvent] -> [Rect] +cellViewportsEvts columnDefs items evts = + hagridViewports columnDefs items evts "Hagrid.Cell" -viewports_ :: [Column TestEvent TestItem] -> [TestItem] -> [SystemEvent] -> WidgetType -> [Rect] -viewports_ columnDefs items evts wType = Foldable.toList childVps +hagridViewports :: [Column TestEvent TestItem] -> [TestItem] -> [SystemEvent] -> WidgetType -> [Rect] +hagridViewports columnDefs items = + viewports (hagrid columnDefs (S.fromList items)) + +viewports :: WidgetNode TestModel TestEvent -> [SystemEvent] -> WidgetType -> [Rect] +viewports wgt evts wType = Foldable.toList childVps where - startNode = nodeInit wenv (hagrid columnDefs (S.fromList items)) + startNode = nodeInit wenv wgt ((wenv', eventedNode, _reqs), _) = nodeHandleEvents wenv WNoInit evts startNode resizedNode = nodeResize wenv' eventedNode (eventedNode ^. L.info . L.viewport) instanceTree = widgetGetInstanceTree (resizedNode ^. L.widget) wenv' resizedNode @@ -196,13 +215,13 @@ widgetGetInstanceTree (_wnWidget node) wenv node widgetsOfType :: WidgetType -> WidgetInstanceNode -> [WidgetInstanceNode] -widgetsOfType typ node = thisOne <> childOnes +widgetsOfType typ node = result where - thisOne - | (node ^. (L.info . L.widgetType)) == typ = [node] - | otherwise = [] + result + | (node ^. (L.info . L.widgetType)) == typ = node : childOnes + | otherwise = childOnes childOnes = - mconcat (widgetsOfType typ <$> Foldable.toList (node ^. L.children)) + foldMap (widgetsOfType typ) (node ^. L.children) windowSize :: Size windowSize = Size 100 100