diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,11 @@ +## 0.2.0.0 +### Added +- Speed up large grids by only creating widgets that are visible. +- Use `Seq` rather than lists, for better performance with large grids (breaks API). +- New "resizing-cells" example to show what happens when cells resize. +### Fixed +- The footer now only takes up vertical space if there are some footer widgets defined. + ## 0.1.0.0 Initial release. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -7,7 +7,7 @@ ## Current Status - Somewhat buggy and incomplete. Don't build your business on this. -## Features +## Current Features - Vertical and horizontal scrolling. - Resizable columns. - Column sorting, with a customizable sort key. @@ -16,21 +16,25 @@ - Custom width/height padding for each cell, configured per column. - Scrolling to a particular row when sent a message. - Custom footer widgets on the bottom of each column. +- Efficient implementation that only inflates visible widgets, scaling to at least 10000 rows. -## Goals -- Have complete and helpful documentation. -- Be reasonably configurable and inspectable. -- Be no uglier than standard Monomer widgets. -- Be performant with up to ten thousand rows. -- Have some tests. +## Definite Future Goals +- Better documention. +- Better tests. +- Prettier appearance. -## Todo List -- Improve performance with lots of rows (e.g. 1000). +## Possible Future Goals - Explore providing an API where current sort/column widths/etc are stored in the parent model and updated by hagrid via a lens. This may remove some complexity around merging and the specification of initial sorts/column widths. +## API Documentation + +See the generated docs on [Hackage](https://hackage.haskell.org/package/monomer-hagrid). + ## To build and run examples ```bash -stack run +stack run example-basic # Demo of the basic functionality. +stack run example-big-grid # Demo of a grid with over 10000 rows. +stack run example-resizing-cells # Demo where the cells are constantly changing size. ``` ## Contribution Guide diff --git a/example-basic/Main.hs b/example-basic/Main.hs new file mode 100644 --- /dev/null +++ b/example-basic/Main.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + +module Main (main) where + +import Control.Lens (Ixed (ix), makeLensesFor, singular) +import Data.Sequence (Seq ((:|>))) +import qualified Data.Sequence as S +import Data.Text (Text, pack) +import qualified Data.Text as T +import Data.Time (Day, addDays, defaultTimeLocale, formatTime, fromGregorian) +import Monomer +import Monomer.Hagrid (Column (..), ColumnAlign (..), ColumnFooterWidget (..), ColumnSortKey (..), SortDirection (..), hagrid_, initialSort, scrollToRow, showOrdColumn, textColumn, widgetColumn) +import Text.Printf (printf) + +data AppModel = AppModel + { theme :: Theme, + spiders :: Seq Spider, + columns :: [AppColumn], + rowToScrollTo :: Int + } + deriving (Eq, Show) + +newtype AppColumn = AppColumn + {enabled :: Bool} + deriving (Eq, Show) + +data AppEvent + = FeedSpider Int + | AddSpider + | NameColumnResized Int + | NameColumnSorted SortDirection + | ScrollToOriginalIndex + +data Spider = Spider + { index :: Int, + species :: Text, + name :: Text, + dateOfBirth :: Day, + weightKilos :: Double + } + deriving (Eq, Show) + +makeLensesFor [("enabled", "_enabled")] ''AppColumn +makeLensesFor [("columns", "_columns"), ("theme", "_theme"), ("rowToScrollTo", "_rowToScrollTo")] ''AppModel + +main :: IO () +main = startApp model handleEvent buildUI config + where + config = + [ appWindowTitle "Hagrid Basic Example", + appFontDef "Bold" "./assets/fonts/Cantarell/Cantarell-Bold.ttf", + appFontDef "Regular" "./assets/fonts/Cantarell/Cantarell-Regular.ttf", + appDisableAutoScale True, + appWindowState (MainWindowNormal (1200, 1000)) + ] + model = + AppModel + { theme = darkTheme, + spiders = spiders, + columns = AppColumn True <$ gridColumns, + rowToScrollTo = 0 + } + spiders = S.fromFunction numSpiders spider + spider i = + Spider + { index = i, + species = "Acromantula", + name = T.pack (printf "Son of Aragog %d" (i + 1)), + dateOfBirth = addDays (fromIntegral i) (fromGregorian 1942 3 1), + weightKilos = fromIntegral (numSpiders + 2 - i) * 2.3 + } + numSpiders = 100 + +buildUI :: UIBuilder AppModel AppEvent +buildUI _wenv model = tree + where + tree = + themeSwitch_ model.theme [themeClearBg] $ + vstack + [ grid `nodeKey` hagridKey, + vstack_ + [childSpacing] + (themeConfigurer : columnConfigurers <> actionButtons) + `styleBasic` [padding 8] + ] + + grid = + hagrid_ + [initialSort 1 SortDescending] + (mconcat (zipWith column model.columns gridColumns)) + model.spiders + + column (AppColumn enabled) columnDef = + [columnDef | enabled] + + themeConfigurer = + hstack_ + [childSpacing] + [ labeledRadio_ "Dark Theme" darkTheme _theme [textRight], + labeledRadio_ "Light Theme" lightTheme _theme [textRight] + ] + + columnConfigurers = + zipWith columnConfigurer [0 .. length model.columns - 1] gridColumns + + columnConfigurer :: Int -> Column AppEvent Spider -> WidgetNode AppModel AppEvent + columnConfigurer idx columnDef = + labeledCheckbox_ + columnDef.name + (_columns . singular (ix idx) . _enabled) + [textRight] + + actionButtons = + [ hstack_ + [childSpacing] + [ label "Scroll to index of unsorted list", + numericField _rowToScrollTo, + button "Go!" ScrollToOriginalIndex + ], + hstack_ + [childSpacing] + [button "Add spider" AddSpider] + ] + +handleEvent :: EventHandler AppModel AppEvent sp ep +handleEvent _wenv _node model = \case + FeedSpider idx + | Just spdr <- S.lookup idx model.spiders -> + [ Producer (const (putStrLn ("Feeding spider " <> T.unpack spdr.name))), + Model model {spiders = S.update idx spdr {weightKilos = spdr.weightKilos + 1} model.spiders} + ] + FeedSpider _ -> + [] + AddSpider -> + [Model model {spiders = model.spiders :|> newSpider model}] + NameColumnResized colWidth -> + [Producer (const (putStrLn ("Name column was resized: " <> show colWidth)))] + NameColumnSorted direction -> + [Producer (const (putStrLn ("Name column was sorted: " <> show direction)))] + ScrollToOriginalIndex -> + [scrollToRow (WidgetKey hagridKey) (rowScrollIndex model)] + +newSpider :: AppModel -> Spider +newSpider model = + Spider + { index = fromIntegral (length model.spiders), + name = "Extra Spider " <> pack (show (length model.spiders)), + species = "Spider plant", + dateOfBirth = fromGregorian 2022 6 26, + weightKilos = 0.01 + } + +rowScrollIndex :: AppModel -> Seq (Spider, Int) -> Maybe Int +rowScrollIndex model items = + snd <$> S.lookup model.rowToScrollTo items + +gridColumns :: [Column AppEvent Spider] +gridColumns = cols + where + cols = + [ (showOrdColumn "Index" (.index)) + { initialWidth = 120, + align = ColumnAlignRight, + footerWidget = CustomFooterWidget countFooter + }, + (textColumn "Name" (.name)) + { initialWidth = 300, + resizeHandler = Just NameColumnResized, + sortHandler = Just NameColumnSorted + }, + (textColumn "Species" (.species)) + { initialWidth = 200 + }, + (textColumn "Date of Birth" (T.pack . formatTime defaultTimeLocale "%Y-%m-%d" . dateOfBirth)) + { initialWidth = 200 + }, + (textColumn "Weight (Kg)" (T.pack . printf "%.2f" . weightKilos)) + { sortKey = SortWith weightKilos, + initialWidth = 200, + align = ColumnAlignRight, + footerWidget = CustomFooterWidget sumWeightFooter + }, + (widgetColumn "Actions" actionsColumn) + { initialWidth = 100, + paddingW = 5, + paddingH = 5 + } + ] + + countFooter spiders = + labelledFooter "Count" (T.pack . show . length $ spiders) + + sumWeightFooter spiders = tree + where + tree = labelledFooter "Sum" (T.pack (printf "%.2f" totalWeightKilos)) + totalWeightKilos = sum (weightKilos . fst <$> spiders) + + labelledFooter labelText text = + hstack + [ label labelText, + filler, + label text + `styleBasic` [textFont "Bold"] + ] + `styleBasic` [padding 10] + + actionsColumn :: Int -> Spider -> WidgetNode s AppEvent + actionsColumn idx _spdr = + button "Feed" (FeedSpider idx) + +hagridKey :: Text +hagridKey = "SpiderHagrid" diff --git a/example-big-grid/Main.hs b/example-big-grid/Main.hs new file mode 100644 --- /dev/null +++ b/example-big-grid/Main.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Main (main) where + +import Data.Function ((&)) +import Data.Sequence (Seq) +import qualified Data.Sequence as S +import Data.Text (Text, dropWhile, dropWhileEnd, pack, splitOn, strip) +import Data.Text.IO (readFile) +import Monomer +import Monomer.Hagrid (estimatedItemHeight, hagrid_, initialWidth, textColumn, widgetColumn) +import Prelude hiding (dropWhile, readFile) + +newtype AppModel = AppModel + { paragraphs :: Seq Text + } + deriving (Eq, Show) + +data AppEvent + +main :: IO () +main = do + paragraphs <- splitParagraphs <$> readFile "./assets/etc/war-and-peace.txt" + startApp (model paragraphs) handleEvent buildUI config + where + config = + [ appWindowTitle "Hagrid Big Grid Example", + appFontDef "Bold" "./assets/fonts/Cantarell/Cantarell-Bold.ttf", + appFontDef "Regular" "./assets/fonts/Cantarell/Cantarell-Regular.ttf", + appTheme darkTheme, + appDisableAutoScale True, + appWindowState (MainWindowNormal (1200, 1000)) + ] + model paragraphs = + AppModel + { paragraphs + } + +buildUI :: UIBuilder AppModel AppEvent +buildUI _wenv model = tree + where + tree = + hagrid_ + [estimatedItemHeight 100] + [ (textColumn "Author" (const "Leo Tolstoy")) {initialWidth = 180}, + (textColumn "Title" (const "War and Peace")) {initialWidth = 160}, + widgetColumn "Line Index" (\i _ -> label (pack (show i))), + (widgetColumn "Line" (\_ para -> label_ para [multiline, ellipsis])) {initialWidth = 760} + ] + model.paragraphs + +handleEvent :: EventHandler AppModel AppEvent sp ep +handleEvent _wenv _node _model = \case {} + +splitParagraphs :: Text -> Seq Text +splitParagraphs s = + splitOn "\n\n" s + & S.fromList + & fmap (dropWhile (== '\n') . dropWhileEnd (== '\n')) + & S.filter ((/= mempty) . strip) diff --git a/example-resizing-cells/Main.hs b/example-resizing-cells/Main.hs new file mode 100644 --- /dev/null +++ b/example-resizing-cells/Main.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} + +module Main (main) where + +import Control.Concurrent (threadDelay) +import Control.Monad (forM, forever) +import Data.Default.Class (def) +import Data.Sequence (Seq) +import qualified Data.Sequence as S +import Data.Text (Text, pack, words) +import Monomer +import Monomer.Hagrid (estimatedItemHeight, hagrid_, initialWidth, minWidth, showOrdColumn, textColumn, widgetColumn) +import Monomer.Widgets.Single +import System.Random.Stateful (globalStdGen, uniformRM) +import Prelude hiding (words) + +newtype AppModel = AppModel + { cellModels :: Seq CellModel + } + deriving (Eq, Show) + +data CellModel = CellModel + { info :: Text, + dotColor :: Color, + dotSize :: Double, + dotSpeed :: Int, + dotPhase :: Int + } + deriving (Eq, Show) + +data AppEvent = AppInit | UpdatePhase + +main :: IO () +main = do + cellModels <- forM (take 1_000 (zip infos colors)) $ \(info, dotColor) -> do + dotSize <- uniformRM (30, 200) globalStdGen + dotPhase <- uniformRM (0, 180) globalStdGen + dotSpeed <- uniformRM (1, 4) globalStdGen + pure CellModel {info, dotColor, dotSize, dotPhase, dotSpeed} + startApp (model cellModels) handleEvent buildUI config + where + config = + [ appWindowTitle "Hagrid Resizing Cells Example", + appFontDef "Bold" "./assets/fonts/Cantarell/Cantarell-Bold.ttf", + appFontDef "Regular" "./assets/fonts/Cantarell/Cantarell-Regular.ttf", + appTheme darkTheme, + appDisableAutoScale True, + appWindowState (MainWindowNormal (1_200, 1_000)), + appInitEvent AppInit + ] + model cellModels = + AppModel {cellModels = S.fromList cellModels} + colors = + cycle [red, green, blue, yellow] + infos = + cycle . words $ + "This demo shows how hagrid behaves when cells are dynamically changing size." + +buildUI :: UIBuilder AppModel AppEvent +buildUI _wenv model = tree + where + tree = + hagrid_ + [estimatedItemHeight 60] + [ widgetColumn "Line Index" (\i _ -> label (pack (show i))), + (textColumn "Info" (.info)) {initialWidth = 200}, + (showOrdColumn "Phase" (.dotPhase)) {initialWidth = 300}, + (widgetColumn "Dot" dotWidget) {minWidth = 220} + ] + model.cellModels + +handleEvent :: EventHandler AppModel AppEvent sp ep +handleEvent _wenv _node model = \case + AppInit -> + [ Producer $ \emit -> do + forever $ do + emit UpdatePhase + threadDelay (1_000_000 `div` 30) + ] + UpdatePhase -> + [Model model {cellModels = updatePhase <$> model.cellModels}] + where + updatePhase cellModel = + cellModel {dotPhase = cellModel.dotPhase + cellModel.dotSpeed} + +dotWidget :: Int -> CellModel -> WidgetNode s AppEvent +dotWidget _idx cellModel = tree + where + tree = + defaultWidgetNode "DotWidget" $ + createSingle + cellModel + def + { singleGetSizeReq = getSizeReq, + singleMerge = merge, + singleRender = render + } + + size = cellModel.dotSize * abs (sin (fromIntegral cellModel.dotPhase / 100)) + + merge _wenv node _oldNode oldState = resultReqs node [resizeReq | needResize] + where + resizeReq = ResizeWidgets node._wnInfo._wniWidgetId + needResize = oldState /= cellModel + + getSizeReq _wenv _node = + (fixedSize size, fixedSize size) + + render wenv node renderer = + drawEllipse renderer carea {_rW = size, _rH = size} (Just cellModel.dotColor) + where + style = currentStyle wenv node + carea = getContentArea node style diff --git a/examples/Main.hs b/examples/Main.hs deleted file mode 100644 --- a/examples/Main.hs +++ /dev/null @@ -1,218 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} - -module Main (main) where - -import Control.Lens (Ixed (ix), makeLensesFor, singular) -import Data.List.Index (setAt) -import Data.Text (Text, pack) -import qualified Data.Text as T -import Data.Time (Day, addDays, defaultTimeLocale, formatTime, fromGregorian) -import Monomer -import Monomer.Hagrid (Column (..), ColumnAlign (..), ColumnFooterWidget (..), ColumnSortKey (..), SortDirection (..), hagrid_, initialSort, scrollToRow, showOrdColumn, textColumn, widgetColumn) -import Text.Printf (printf) - -data AppModel = AppModel - { theme :: Theme, - spiders :: [Spider], - columns :: [AppColumn], - rowToScrollTo :: Int - } - deriving (Eq, Show) - -newtype AppColumn = AppColumn - {enabled :: Bool} - deriving (Eq, Show) - -data AppEvent - = FeedSpider Int - | AddSpider - | NameColumnResized Int - | NameColumnSorted SortDirection - | ScrollToOriginalIndex - -data Spider = Spider - { index :: Integer, - species :: Text, - name :: Text, - dateOfBirth :: Day, - weightKilos :: Double - } - deriving (Eq, Show) - -makeLensesFor [("enabled", "_enabled")] ''AppColumn -makeLensesFor [("columns", "_columns"), ("theme", "_theme"), ("rowToScrollTo", "_rowToScrollTo")] ''AppModel - -main :: IO () -main = startApp model handleEvent buildUI config - where - config = - [ appWindowTitle "Hagrid Examples", - appFontDef "Bold" "./assets/fonts/Cantarell/Cantarell-Bold.ttf", - appFontDef "Regular" "./assets/fonts/Cantarell/Cantarell-Regular.ttf", - appDisableAutoScale True, - appWindowState (MainWindowNormal (1200, 1000)) - ] - model = - AppModel - { theme = darkTheme, - spiders = spiders, - columns = AppColumn True <$ gridColumns, - rowToScrollTo = 0 - } - spiders = spider <$> [0 .. numSpiders - 1] - spider i = - Spider - { index = i, - species = "Acromantula", - name = T.pack (printf "Son of Aragog %d" (i + 1)), - dateOfBirth = addDays i (fromGregorian 1942 3 1), - weightKilos = fromIntegral (numSpiders + 2 - i) * 2.3 - } - numSpiders = 100 - -buildUI :: UIBuilder AppModel AppEvent -buildUI _wenv model = tree - where - tree = - themeSwitch_ model.theme [themeClearBg] $ - vstack - [ grid `nodeKey` hagridKey, - vstack_ - [childSpacing] - (themeConfigurer : columnConfigurers <> actionButtons) - `styleBasic` [padding 8] - ] - - grid = - hagrid_ - [initialSort 1 SortDescending] - (mconcat (zipWith column model.columns gridColumns)) - model.spiders - - column (AppColumn enabled) columnDef = - [columnDef | enabled] - - themeConfigurer = - hstack_ - [childSpacing] - [ labeledRadio_ "Dark Theme" darkTheme _theme [textRight], - labeledRadio_ "Light Theme" lightTheme _theme [textRight] - ] - - columnConfigurers = - zipWith columnConfigurer [0 .. length model.columns - 1] gridColumns - - columnConfigurer :: Int -> Column AppEvent Spider -> WidgetNode AppModel AppEvent - columnConfigurer idx columnDef = - labeledCheckbox_ - columnDef.name - (_columns . singular (ix idx) . _enabled) - [textRight] - - actionButtons = - [ hstack_ - [childSpacing] - [ label "Scroll to index of unsorted list", - numericField _rowToScrollTo, - button "Go!" ScrollToOriginalIndex - ], - hstack_ - [childSpacing] - [button "Add spider" AddSpider] - ] - -handleEvent :: EventHandler AppModel AppEvent sp ep -handleEvent _wenv _node model = \case - FeedSpider idx -> evts - where - evts = - [ Producer (const (putStrLn ("Feeding spider " <> T.unpack spdr.name))), - Model model {spiders = setAt idx spdr {weightKilos = spdr.weightKilos + 1} model.spiders} - ] - spdr = model.spiders !! idx - AddSpider -> - [Model model {spiders = model.spiders <> [newSpider model]}] - NameColumnResized colWidth -> - [Producer (const (putStrLn ("Name column was resized: " <> show colWidth)))] - NameColumnSorted direction -> - [Producer (const (putStrLn ("Name column was sorted: " <> show direction)))] - ScrollToOriginalIndex -> - [scrollToRow (WidgetKey hagridKey) (rowScrollIndex model)] - -newSpider :: AppModel -> Spider -newSpider model = - Spider - { index = fromIntegral (length model.spiders), - name = "Extra Spider " <> pack (show (length model.spiders)), - species = "Spider plant", - dateOfBirth = fromGregorian 2022 6 26, - weightKilos = 0.01 - } - -rowScrollIndex :: AppModel -> [(Spider, Int)] -> Maybe Int -rowScrollIndex model items - | model.rowToScrollTo >= 0 && model.rowToScrollTo < length items = - Just (snd (items !! model.rowToScrollTo)) - | otherwise = - Nothing - -gridColumns :: [Column AppEvent Spider] -gridColumns = cols - where - cols = - [ (showOrdColumn "Index" (.index)) - { initialWidth = 120, - align = ColumnAlignRight, - footerWidget = CustomFooterWidget countFooter - }, - (textColumn "Name" (.name)) - { initialWidth = 300, - resizeHandler = Just NameColumnResized, - sortHandler = Just NameColumnSorted - }, - (textColumn "Species" (.species)) - { initialWidth = 200 - }, - (textColumn "Date of Birth" (T.pack . formatTime defaultTimeLocale "%Y-%m-%d" . dateOfBirth)) - { initialWidth = 200 - }, - (textColumn "Weight (Kg)" (T.pack . printf "%.2f" . weightKilos)) - { sortKey = SortWith weightKilos, - initialWidth = 200, - align = ColumnAlignRight, - footerWidget = CustomFooterWidget sumWeightFooter - }, - (widgetColumn "Actions" actionsColumn) - { initialWidth = 100, - paddingW = 5, - paddingH = 5 - } - ] - - countFooter spiders = - labelledFooter "Count" (T.pack . show . length $ spiders) - - sumWeightFooter spiders = tree - where - tree = labelledFooter "Sum" (T.pack (printf "%.2f" totalWeightKilos)) - totalWeightKilos = sum (weightKilos . fst <$> spiders) - - labelledFooter labelText text = - hstack - [ label labelText, - filler, - label text - `styleBasic` [textFont "Bold"] - ] - `styleBasic` [padding 10] - - actionsColumn :: Int -> Spider -> WidgetNode s AppEvent - actionsColumn idx _spdr = - button "Feed" (FeedSpider idx) - -hagridKey :: Text -hagridKey = "SpiderHagrid" 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.1.0.0 +version: 0.2.0.0 license: MIT license-file: LICENSE maintainer: garethdanielsmith@gmail.com @@ -36,69 +36,122 @@ build-depends: base >=4.7 && <5, - containers >=0.6.5.1 && <0.7, - data-default-class >=0.1.2.0 && <0.2, - ilist >=0.4.0.1 && <0.5, - lens >=5.1.1 && <5.2, + containers <0.7, + data-default-class <0.2, + ilist <0.5, + lens <5.2, monomer >=1.5.0.0 && <1.6, - text >=1.2.5.0 && <1.3 + text <1.3 -executable examples +executable example-basic main-is: Main.hs - hs-source-dirs: examples + hs-source-dirs: example-basic other-modules: Paths_monomer_hagrid + autogen-modules: Paths_monomer_hagrid default-language: Haskell2010 default-extensions: DisambiguateRecordFields DuplicateRecordFields FlexibleContexts OverloadedRecordDot OverloadedStrings ghc-options: - -threaded -rtsopts -with-rtsopts=-N -Wall -Wcompat - -Wincomplete-record-updates -Wincomplete-uni-patterns - -Wredundant-constraints + -Wall -Wcompat -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wredundant-constraints -threaded + -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5, - containers >=0.6.5.1 && <0.7, - data-default-class >=0.1.2.0 && <0.2, - ilist >=0.4.0.1 && <0.5, - lens >=5.1.1 && <5.2, + containers <0.7, + data-default-class <0.2, + ilist <0.5, + lens <5.2, monomer >=1.5.0.0 && <1.6, - monomer-hagrid -any, - text >=1.2.5.0 && <1.3, - time >=1.11.1.1 && <1.12 + monomer-hagrid, + text <1.3, + time <1.12 +executable example-big-grid + main-is: Main.hs + hs-source-dirs: example-big-grid + other-modules: Paths_monomer_hagrid + autogen-modules: Paths_monomer_hagrid + default-language: Haskell2010 + default-extensions: + DisambiguateRecordFields DuplicateRecordFields FlexibleContexts + OverloadedRecordDot OverloadedStrings + + ghc-options: + -Wall -Wcompat -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wredundant-constraints -threaded + -rtsopts -with-rtsopts=-N + + build-depends: + base >=4.7 && <5, + containers <0.7, + data-default-class <0.2, + ilist <0.5, + lens <5.2, + monomer >=1.5.0.0 && <1.6, + monomer-hagrid, + text <1.3 + +executable example-resizing-cells + main-is: Main.hs + hs-source-dirs: example-resizing-cells + other-modules: Paths_monomer_hagrid + autogen-modules: Paths_monomer_hagrid + default-language: Haskell2010 + default-extensions: + DisambiguateRecordFields DuplicateRecordFields FlexibleContexts + OverloadedRecordDot OverloadedStrings + + ghc-options: + -Wall -Wcompat -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wredundant-constraints -threaded + -rtsopts -with-rtsopts=-N + + build-depends: + base >=4.7 && <5, + containers <0.7, + data-default-class <0.2, + ilist <0.5, + lens <5.2, + monomer >=1.5.0.0 && <1.6, + monomer-hagrid, + random <1.3, + text <1.3 + test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs - build-tool-depends: hspec-discover:hspec-discover ==2.* + build-tool-depends: hspec-discover:hspec-discover >=2 && <3 hs-source-dirs: test other-modules: Monomer.HagridSpec Monomer.TestUtil Paths_monomer_hagrid + autogen-modules: Paths_monomer_hagrid default-language: Haskell2010 default-extensions: DisambiguateRecordFields DuplicateRecordFields FlexibleContexts OverloadedRecordDot OverloadedStrings ghc-options: - -threaded -rtsopts -with-rtsopts=-N -Wall -Wcompat - -Wincomplete-record-updates -Wincomplete-uni-patterns - -Wredundant-constraints + -Wall -Wcompat -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wredundant-constraints -threaded + -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5, - bytestring >=0.11.3.1 && <0.12, - containers >=0.6.5.1 && <0.7, - data-default >=0.7.1.1 && <0.8, - data-default-class >=0.1.2.0 && <0.2, - hspec ==2.*, - ilist >=0.4.0.1 && <0.5, - lens >=5.1.1 && <5.2, + bytestring <0.12, + containers <0.7, + data-default <0.8, + data-default-class <0.2, + hspec >=2 && <3, + ilist <0.5, + lens <5.2, monomer >=1.5.0.0 && <1.6, - monomer-hagrid -any, - mtl >=2.2.2 && <2.3, - stm >=2.5.0.2 && <2.6, - text >=1.2.5.0 && <1.3 + monomer-hagrid, + mtl <2.3, + stm <2.6, + text <1.3 diff --git a/src/Monomer/Hagrid.hs b/src/Monomer/Hagrid.hs --- a/src/Monomer/Hagrid.hs +++ b/src/Monomer/Hagrid.hs @@ -3,7 +3,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} -- | A datagrid widget for the Monomer UI library. @@ -16,9 +15,11 @@ ColumnFooterWidget (..), ColumnSortKey (..), SortDirection (..), + ItemWithIndex, ScrollToRowCallback, -- * Configuration options + estimatedItemHeight, initialSort, -- * Hagrid constructors @@ -36,16 +37,15 @@ where import Control.Applicative ((<|>)) -import Control.Lens ((.~), (<>~), (^.)) +import Control.Lens (ix, (.~), (<>~), (^.), (^?!)) import Control.Lens.Combinators (non) import Control.Lens.Lens ((&)) import Control.Monad as X (forM_) import Data.Data (Typeable) -import Data.Default.Class as X (Default, def) +import Data.Default.Class (Default, def) import Data.Foldable (foldl') -import qualified Data.List as List import Data.List.Index (indexed, izipWith, modifyAt) -import Data.Maybe (fromJust, maybeToList) +import Data.Maybe (catMaybes, fromJust, isNothing, maybeToList) import Data.Maybe as X (fromMaybe) import Data.Ord (Down (Down)) import Data.Sequence (Seq ((:<|), (:|>))) @@ -60,18 +60,38 @@ -- | Configuration options for Hagrid widgets. data HagridCfg s e = HagridCfg - { cfgInitialSort :: Maybe (Int, SortDirection) + { cfgEstimatedItemHeight :: Maybe Double, + cfgInitialSort :: Maybe (Int, SortDirection) } instance Default (HagridCfg s e) where - def = HagridCfg {cfgInitialSort = Nothing} + def = + HagridCfg + { cfgEstimatedItemHeight = Nothing, + cfgInitialSort = Nothing + } instance Semigroup (HagridCfg s e) where - c1 <> c2 = HagridCfg {cfgInitialSort = c2.cfgInitialSort <|> c1.cfgInitialSort} + c1 <> c2 = + HagridCfg + { cfgEstimatedItemHeight = c2.cfgEstimatedItemHeight <|> c1.cfgEstimatedItemHeight, + cfgInitialSort = c2.cfgInitialSort <|> c1.cfgInitialSort + } instance Monoid (HagridCfg s e) where mempty = def +-- | Configures the estimated item height. This should be the average row height you expect +-- in your grid (including padding). This is used to show scrollbar size and position when +-- there are lots of rows and so not all the rows have been "inflated" into widgets. More +-- accurate values will improve performance and scrollbar position accuracy. +-- +-- The default value is 40, which is roughly the height of a single line of text with the default +-- column padding (10). +estimatedItemHeight :: Double -> HagridCfg s e +estimatedItemHeight h = + def {cfgEstimatedItemHeight = Just h} + -- | Configures the initial sort column and direction. initialSort :: -- | The initial sort column (zero-indexed, out of bounds values will have no effect). @@ -80,7 +100,7 @@ SortDirection -> HagridCfg s e initialSort column direction = - HagridCfg {cfgInitialSort = Just (column, direction)} + def {cfgInitialSort = Just (column, direction)} -- | A column definition. data Column e a = Column @@ -99,9 +119,9 @@ initialWidth :: Int, -- | The minimum allowed width of the column, in pixels. minWidth :: Int, - -- | The padding to the left and right of the widget in each cell of the column, in pixels. + -- | The padding to the left and right of the widget in each cell of the column, in pixels (the default is 10). paddingW :: Double, - -- | The padding above and below the widget in each cell in the column, in pixels. + -- | The padding above and below the widget in each cell in the column, in pixels (the default is 10). paddingH :: Double, -- | An optional event to emit when a user has finished resizing the column. The function receives the new width in pixels. resizeHandler :: Maybe (Int -> e), @@ -124,7 +144,7 @@ NoFooterWidget | -- | Create a footer widget. The function receives the items in their current sort -- order, and also along with each item it's original (unsorted) index. - CustomFooterWidget (forall s. WidgetModel s => [(a, Int)] -> WidgetNode s e) + CustomFooterWidget (forall s. WidgetModel s => Seq (ItemWithIndex a) -> WidgetNode s e) -- | How to align the widget within each cell of a column. data ColumnAlign @@ -145,11 +165,14 @@ | SortDescending deriving (Eq, Show) +-- | A item in the grid, with its row index. +type ItemWithIndex a = (a, Int) + -- | Picks an item to scroll to, based on the sorted or original grid contents. type ScrollToRowCallback a = -- | The items in the grid, in the originally provided order, along with each item's index -- in the current grid order. - [(a, Int)] -> + Seq (ItemWithIndex a) -> -- | The row to scroll to, as an index into the sorted items (e.g. 0 is always the first row -- in the grid, regardless of the current order). 'Nothing' will cancel the scroll. Maybe Int @@ -160,12 +183,14 @@ | ResizeColumn Int Int | ResizeColumnFinished Int | forall a. Typeable a => ScrollToRow (ScrollToRowCallback a) + | ScrollToRect Rect | ParentEvent ep data HagridModel a = HagridModel - { sortedItems :: [(a, Int)], -- each item, plus its index in the original (unsorted) list + { sortedItems :: Seq (ItemWithIndex a), columns :: [ModelColumn], - sortColumn :: Maybe (Int, SortDirection) + sortColumn :: Maybe (Int, SortDirection), + mdlEstimatedItemHeight :: Double } deriving (Eq, Show) @@ -177,12 +202,12 @@ -- | The state of the header or footer, which have a scroll offset because they -- scroll horizontally along with the content pane. -data OffsetXState = OffsetXState +newtype OffsetXState = OffsetXState { offsetX :: Double } deriving (Eq, Show) -data OffsetXEvent = SetOffsetX Double +newtype OffsetXEvent = SetOffsetX Double data HeaderDragHandleState = HeaderDragHandleState { dragStartMouseX :: Double, @@ -190,9 +215,36 @@ } deriving (Eq, Show) -data ContentPaneMessage a - = ContentPaneScrollToRow (ScrollToRowCallback a) +data ContentPaneModel a = ContentPaneModel + { -- | The width of each column. + columnWidths :: [Int], + -- | The visible area (relative to the content pane). + visibleArea :: Rect, + -- | The index in items of the special row that we try and keep in the same position + -- (relative to the viewport) when items get resized. + fixedRowIndex :: Int, + -- | The Y position of the fixed row within the viewport. When items get resized, we try + -- and keep this value fixed: it should only change when the user scrolls the viewport itself. + fixedRowViewportOffset :: Double, + -- | How many items there are before the inflated items. + itemsBeforeInflated :: Int, + -- | The items that have been inflated into actual widgets. + inflatedItems :: Seq (ItemWithIndex a), + phase :: ContentPanePhase + } + deriving (Eq, Show) +data ContentPanePhase + = ContentPaneIdle + | ContentPaneReinflating + deriving (Eq, Show) + +data ContentPaneEvent ep + = SetVisibleArea {visibleArea :: Rect} + | InnerResizeComplete + | ContentPaneParentEvent ep + | forall a. Typeable a => ContentPaneScrollToRow (ScrollToRowCallback a) + -- | Creates a hagrid widget, using the default configuration. hagrid :: forall a s e. @@ -200,7 +252,7 @@ -- | The definitions for each column in the grid. [Column e a] -> -- | The items for each row in the grid. - [a] -> + Seq a -> WidgetNode s e hagrid = hagrid_ def @@ -212,7 +264,7 @@ -- | The definitions for each column in the grid. [Column e a] -> -- | The items for each row in the grid. - [a] -> + Seq a -> WidgetNode s e hagrid_ cfg columnDefs items = widget where @@ -237,16 +289,21 @@ ] contentScroll = scroll_ [onChange ContentScrollChange] $ - contentPane columnDefs model `nodeKey` contentPaneKey + contentPaneOuter columnDefs model `nodeKey` contentPaneOuterKey handleEvent :: EventHandler (HagridModel a) (HagridEvent e) sp e handleEvent wenv _node model = \case - ScrollToRow row -> - [Message (WidgetKey contentPaneKey) (ContentPaneScrollToRow row)] - ContentScrollChange ScrollStatus {scrollDeltaX} -> + ScrollToRow callback -> + [Message (WidgetKey contentPaneOuterKey) (ContentPaneScrollToRow callback :: ContentPaneEvent e)] + ScrollToRect rect -> + [Message (WidgetKey contentScrollKey) (ScrollTo rect)] + ContentScrollChange ScrollStatus {scrollDeltaX, scrollDeltaY, scrollVpSize} -> [ Message (WidgetKey headerPaneKey) (SetOffsetX scrollDeltaX), + Message (WidgetKey contentPaneOuterKey) (SetVisibleArea {visibleArea} :: ContentPaneEvent e), Message (WidgetKey footerPaneKey) (SetOffsetX scrollDeltaX) ] + where + visibleArea = Rect (-scrollDeltaX) (-scrollDeltaY) scrollVpSize._sW scrollVpSize._sH OrderByColumn colIndex -> result where Column {sortHandler, sortKey} = columnDefs !! colIndex @@ -254,7 +311,7 @@ | Just (c, dir) <- model.sortColumn, c == colIndex = let sortColumn = Just (colIndex, flipSortDirection dir) - sortedItems = reverse model.sortedItems + sortedItems = S.reverse model.sortedItems in (sortColumn, sortedItems) | otherwise = let sortColumn = Just (colIndex, SortAscending) @@ -268,8 +325,7 @@ ResizeColumn colIndex newWidth -> [ Model (model {columns = modifyAt colIndex (\c -> c {currentWidth = newWidth}) model.columns}), Request (ResizeWidgets headerPaneId), - Request (ResizeWidgets footerPaneId), - Request (ResizeWidgets contentPaneId) + Request (ResizeWidgets footerPaneId) ] ResizeColumnFinished colIndex -> result where @@ -282,7 +338,6 @@ where headerPaneId = fromJust (widgetIdFromKey wenv (WidgetKey headerPaneKey)) footerPaneId = fromJust (widgetIdFromKey wenv (WidgetKey footerPaneKey)) - contentPaneId = fromJust (widgetIdFromKey wenv (WidgetKey contentPaneKey)) -- 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. @@ -387,8 +442,12 @@ where Rect l t _w h = viewport widgetWidths = do - w <- currentWidth <$> model.columns - [w - dragHandleWidth, dragHandleWidth] + (i, w) <- indexed (currentWidth <$> model.columns) + -- center the drag handle inbetween the columns + let buttonW + | i == 0 = w - (dragHandleWidth `div` 2) + | otherwise = w - dragHandleWidth + [buttonW, dragHandleWidth] (assignedAreas, _) = foldl' assignArea (mempty, l) widgetWidths assignArea (areas, colX) columnWidth = (areas :|> Rect colX t (fromIntegral columnWidth) h, colX + fromIntegral columnWidth) @@ -399,16 +458,19 @@ renderSortIndicator wenv node renderer (sortCol, sortDirection) = do drawSortIndicator renderer indRect (Just (accentColor wenv)) sortDirection where + Rect l t w h = node ^?! L.children . ix (sortCol * 2) . L.info . L.viewport + style = wenv ^. L.theme . L.basic . L.btnStyle - Rect l t _w h = node ^. L.info . L.viewport size = style ^. L.text . non def . L.fontSize . non def - colOffset = fromIntegral (sum (take (sortCol + 1) (currentWidth <$> model.columns)) - dragHandleWidth) - indW = unFontSize size * 2 / 3 - pad = indW / 3 + + -- put triangle corners at integer positions because it looks nicer + indW = ceilingDouble (unFontSize size * 2 / 3) + pad = ceilingDouble (unFontSize size * 2 / 9) + indT = case sortDirection of SortAscending -> t + h - pad - indW SortDescending -> t + pad - indL = l + state.offsetX + colOffset - indW - pad + indL = l + w + state.offsetX - indW - pad indRect = Rect indL indT indW indW headerButton :: WidgetEvent ep => Int -> Column ep a -> WidgetNode s (HagridEvent ep) @@ -416,7 +478,12 @@ button_ columnDef.name (OrderByColumn colIndex) [ellipsis] `styleBasic` [radius 0] -footerPane :: forall s ep a. (CompositeModel a, CompositeModel s, Typeable ep) => [Column ep a] -> HagridModel a -> WidgetNode (HagridModel s) (HagridEvent ep) +footerPane :: + forall s ep a. + (CompositeModel a, CompositeModel s, Typeable ep) => + [Column ep a] -> + HagridModel a -> + WidgetNode (HagridModel s) (HagridEvent ep) footerPane columnDefs model = makeNode (OffsetXState 0) where makeNode :: OffsetXState -> WidgetNode (HagridModel s) (HagridEvent ep) @@ -424,12 +491,10 @@ where node = defaultWidgetNode "Hagrid.FooterPane" (makeWidget state) - & L.children .~ childWidgets + & L.children .~ S.fromList (catMaybes childWidgets) - childWidgets :: Seq (WidgetNode (HagridModel s) (HagridEvent ep)) - childWidgets = - S.fromList $ - footerWidgetNode model.sortedItems . footerWidget <$> columnDefs + childWidgets :: [Maybe (WidgetNode (HagridModel s) (HagridEvent ep))] + childWidgets = footerWidgetNode model.sortedItems . footerWidget <$> columnDefs makeWidget :: OffsetXState -> Widget (HagridModel s) (HagridEvent ep) makeWidget state = container @@ -473,14 +538,18 @@ getSizeReq _wenv _node children = (w, h) where w = fixedSize (sum (fromIntegral . currentWidth <$> model.columns) + hScrollFudgeFactor) - h = foldl' sizeReqMergeMax (fixedSize 0) ((_wniSizeReqH . _wnInfo) <$> children) + h = foldl' sizeReqMergeMax (fixedSize 0) (_wniSizeReqH . _wnInfo <$> children) resize _wenv node viewport _children = (resultNode node, assignedAreas) where Rect l t _w h = viewport - (assignedAreas, _) = foldl' assignArea (mempty, l) model.columns - assignArea (areas, colX) ModelColumn {currentWidth} = - (areas :|> Rect colX t (fromIntegral currentWidth) h, colX + fromIntegral currentWidth) + (assignedAreas, _) = foldl' assignArea (mempty, l) (zip childWidgets model.columns) + assignArea (areas, colX) (childWidget, ModelColumn {currentWidth}) = (newAreas, newColX) + where + newAreas + | isNothing childWidget = areas + | otherwise = areas :|> Rect colX t (fromIntegral currentWidth) h + newColX = colX + fromIntegral currentWidth headerDragHandle :: WidgetEvent ep => Int -> Column ep a -> ModelColumn -> WidgetNode s (HagridEvent ep) headerDragHandle colIndex columnDef column = tree @@ -545,162 +614,342 @@ hScrollFudgeFactor :: Double hScrollFudgeFactor = 100 -contentPane :: +-- | Composite wrapper to allow creating/removing child widgets during resize. +contentPaneOuter :: forall a ep. (CompositeModel a, WidgetEvent ep) => [Column ep a] -> HagridModel a -> WidgetNode (HagridModel a) (HagridEvent ep) -contentPane columnDefs model = node +contentPaneOuter columnDefs model = + compositeD_ + "Hagrid.ContentPaneOuter" + (WidgetValue initialModel) + buildUI + handleEvent + [compositeMergeModel mergeModel] where - node = - defaultWidgetNode "Hagrid.ContentPane" contentPaneContainer - & L.children .~ S.fromList (mconcat childWidgetRows) + initialModel = + ContentPaneModel + { columnWidths = currentWidth <$> model.columns, + visibleArea = Rect 0 0 0 0, + fixedRowIndex = 0, + fixedRowViewportOffset = 0, + itemsBeforeInflated = 0, + inflatedItems = mempty, + phase = ContentPaneIdle + } - childWidgetRows = - [ [cellWidget idx item widget | Column {widget} <- columnDefs] - | (item, idx) <- model.sortedItems - ] + mergeModel :: MergeModelHandler (ContentPaneModel a) (ContentPaneEvent e) s + mergeModel _wenv _parentModel oldModel newModel = + oldModel {columnWidths, fixedRowIndex, itemsBeforeInflated, inflatedItems} + where + columnWidths = newModel.columnWidths + fixedRowIndex = min (max 0 (length model.sortedItems - 1)) oldModel.fixedRowIndex + itemsBeforeInflated = min (length model.sortedItems) oldModel.itemsBeforeInflated + inflatedItems = takeAt itemsBeforeInflated (length oldModel.inflatedItems) model.sortedItems - nCols = length columnDefs - columnDefsSeq = S.fromList columnDefs + buildUI _wenv cpModel = + contentPaneInner (S.fromList columnDefs) model cpModel `nodeKey` contentPaneInnerKey + handleEvent wenv node cpModel = \case + SetVisibleArea visibleArea -> result + where + result = case cpModel.phase of + ContentPaneIdle + | visibleAreaMoved && (startItemsMissing || endItemsMissing) -> + let newModel = + cpModel + { visibleArea, + fixedRowIndex, + fixedRowViewportOffset, + itemsBeforeInflated = fixedRowIndex, + inflatedItems = mempty, + phase = ContentPaneReinflating + } + in [Model newModel, resizeInnerRequest wenv] + | visibleAreaMoved -> + let newModel = cpModel {visibleArea, fixedRowIndex, fixedRowViewportOffset} + in [Model newModel] + | otherwise -> [] + ContentPaneReinflating + | visibleAreaMoved -> + let newModel = (cpModel :: ContentPaneModel a) {visibleArea} + in [Model newModel] + | otherwise -> [] + + (fixedRowIndex, fixedRowViewportOffset) = fixedRow minVisibleY rowHeights model cpModel + (rowsStartY, rowHeights, rowsEndY) = rowPositions node + + visibleAreaMoved = not (roundedRectEq visibleArea cpModel.visibleArea) + minVisibleY = visibleArea._rY + maxVisibleY = visibleArea._rY + visibleArea._rH + + startItemsMissing = cpModel.itemsBeforeInflated > 0 && minVisibleY < rowsStartY + endItemsMissing = itemsAfterInflated model cpModel > 0 && maxVisibleY > rowsEndY + ContentPaneScrollToRow callback -> result + where + result + | Just typedCb <- cast callback, + Just row <- typedCb indexedItems = + -- set the fixed index to the target row and let the viewport position be sorted out by the + -- adjustment that follows the addition and resizing of the rows around the target row. + let newModel = + cpModel + { fixedRowIndex = row, + fixedRowViewportOffset = 0, + itemsBeforeInflated = row, + inflatedItems = mempty, + phase = ContentPaneReinflating + } + in [Model newModel, resizeInnerRequest wenv] + | otherwise = + [] + + indexedItems = + model.sortedItems + & S.mapWithIndex (,) + & S.sortOn (snd . snd) + & fmap (\(sortedIndex, (item, _originalIndex)) -> (item, sortedIndex)) + InnerResizeComplete -> result + where + (rowsStartY, rowHeights, rowsEndY) = rowPositions node + + fixedRowY = rowsStartY + sum (S.take (cpModel.fixedRowIndex - cpModel.itemsBeforeInflated) rowHeights) + + result + | itemsToPrepend > 0 || itemsToAppend > 0 = + let inflatedItems = + takeAt + (cpModel.itemsBeforeInflated - itemsToPrepend) + (itemsToPrepend + length cpModel.inflatedItems + itemsToAppend) + model.sortedItems + itemsBeforeInflated = cpModel.itemsBeforeInflated - itemsToPrepend + in [Model cpModel {inflatedItems, itemsBeforeInflated}, resizeInnerRequest wenv] + | otherwise = + -- Once we have finished adding items then, if the added items are not the same size as estimated, + -- the row we want to scroll to might no longer be at the correct position in the viewport, so we + -- need to adjust the scroll position to position it correctly. + let adjustScrollEvt = [Report (ScrollToRect adjustScrollRect) | needAdjustScroll] + adjustScrollRect = Rect (vp._rX + cpModel.visibleArea._rX) (vp._rY + fixedRowY - cpModel.fixedRowViewportOffset) visibleWidth visibleHeight + needAdjustScroll = abs ((fixedRowY - cpModel.visibleArea._rY) - cpModel.fixedRowViewportOffset) >= 1 + in [Model cpModel {phase = ContentPaneIdle}] <> adjustScrollEvt + + itemsToPrepend = itemsToAdd (fixedRowY - rowsStartY) 1 cpModel.itemsBeforeInflated + itemsToAppend = itemsToAdd (rowsEndY - fixedRowY) 2 (itemsAfterInflated model cpModel) + + itemsToAdd existingItemsHeight f availableItems + | not (null model.sortedItems) && existingItemsHeight < visibleHeight * f = + let n = ceiling ((visibleHeight * f - existingItemsHeight) / model.mdlEstimatedItemHeight) + in min (max 8 (min 64 n)) availableItems + | otherwise = 0 + + vp = node ^. L.info . L.viewport + visibleWidth = cpModel.visibleArea._rW + visibleHeight = cpModel.visibleArea._rH + ContentPaneParentEvent ep -> + [Report (ParentEvent ep)] + +contentPaneInner :: + forall a ep. + (CompositeModel a, WidgetEvent ep) => + Seq (Column ep a) -> + HagridModel a -> + ContentPaneModel a -> + WidgetNode (ContentPaneModel a) (ContentPaneEvent ep) +contentPaneInner columnDefs model cpModel = node + where + node = + defaultWidgetNode "Hagrid.ContentPaneInner" contentPaneContainer + & L.children .~ rowWidgets + contentPaneContainer = createContainer - model + cpModel def + { containerMerge = merge, + containerGetSizeReq = getSizeReq, + containerResize = resize + } + + rowWidgets = contentPaneRow columnDefs cpModel <$> cpModel.inflatedItems + + merge _wenv newNode _oldNode oldState = resultReqs newNode reqs + where + reqs = [ResizeWidgets (newNode ^. L.info . L.widgetId) | needResize] + needResize = oldState.columnWidths /= cpModel.columnWidths + + getSizeReq _wenv _node children = (w, h) + where + w = fixedSize (fromIntegral (sum cpModel.columnWidths)) + h = fixedSize (uninflatedHeights + inflatedHeights) + + uninflatedHeights = fromIntegral uninflatedItems * model.mdlEstimatedItemHeight + uninflatedItems = cpModel.itemsBeforeInflated + itemsAfterInflated model cpModel + + inflatedHeights = sum (_szrFixed . _wniSizeReqH . _wnInfo <$> children) + + resize wenv node viewport children = (resultEvts node [InnerResizeComplete], rowAreas) + where + style = currentStyle wenv node + innerVp = fromMaybe def (removeOuterBounds style viewport) + + startX = innerVp._rX + startY = innerVp._rY + fromIntegral cpModel.itemsBeforeInflated * model.mdlEstimatedItemHeight + + sumColumnWidths = fromIntegral (sum cpModel.columnWidths) + + rowAreas = snd (foldl' foldRowAreas (startY, mempty) children) + foldRowAreas (y, areas) child = + (y + h, areas :|> Rect startX y sumColumnWidths h) + where + h = child ^. L.info . L.sizeReqH . L.fixed + +contentPaneRow :: + forall a ep. + (CompositeModel a, WidgetEvent ep) => + Seq (Column ep a) -> + ContentPaneModel a -> + (a, Int) -> + WidgetNode (ContentPaneModel a) (ContentPaneEvent ep) +contentPaneRow columnDefs cpModel (item, rowIdx) = tree + where + tree = + defaultWidgetNode "Hagrid.Row" widget + & L.children .~ cellWidgets + + widget = + createContainer + (cpModel.columnWidths, item, rowIdx) + def { containerGetSizeReq = getSizeReq, containerResize = resize, - containerRender = render, - containerHandleEvent = handleEvent, - containerHandleMessage = handleMessage + containerRender = render } + cellWidgets = do + Column {widget} <- columnDefs + pure (cellWidget rowIdx item widget) + getSizeReq _wenv _node children = (w, h) where - w = fixedSize (sum (fromIntegral . currentWidth <$> model.columns)) - h = fixedSize (sum (toRowHeights children columnDefsSeq)) + w = fixedSize (fromIntegral (sum cpModel.columnWidths)) + h = fixedSize (toRowHeight columnDefs children) - resize wenv node viewport children = (resultNode node, assignedAreas) + resize wenv node viewport children = (resultNode node, cellAreas) where style = currentStyle wenv node - Rect l t _w _h = fromMaybe def (removeOuterBounds style viewport) + innerVp = fromMaybe def (removeOuterBounds style viewport) - colXs = sizesToPositions (S.fromList (fromIntegral . currentWidth <$> model.columns)) - rowYs = sizesToPositions (toRowHeights children columnDefsSeq) + startX = innerVp._rX + startY = innerVp._rY - assignedAreas = do - (rowN, row) <- - S.mapWithIndex (\i -> (i,)) (S.chunksOf nCols children) - (colN, columnDef, widget) <- - S.mapWithIndex (\i (cd, w) -> (i, cd, w)) (S.zip columnDefsSeq row) - pure (assignArea colN columnDef rowN widget) + columnWidths = fromIntegral <$> S.fromList cpModel.columnWidths - assignArea col Column {paddingW, paddingH, align} row widget = Rect chX chY chW chH + cellAreas = snd (foldl' foldCellAreas (startX, mempty) (S.zip3 columnWidths columnDefs children)) + foldCellAreas (x, areas) (colW, Column {paddingW, paddingH, align}, widget) = + (x + colW, areas :|> Rect chX cellY chW cellH) where - (chX, chW) - | widgetReqW >= cellW = (cellX, cellW) - | align == ColumnAlignLeft = (cellX, widgetReqW) - | otherwise = (cellX + cellW - widgetReqW, widgetReqW) - (chY, chH) = - (cellY, cellH) + (chX, chW) = case align of + ColumnAlignLeft -> (cellX, cellW) + ColumnAlignRight -> (cellX + cellW - widgetW, widgetW) - cellX = l + S.index colXs col + paddingW - cellY = t + S.index rowYs row + paddingH - cellW = S.index colXs (col + 1) - S.index colXs col - paddingW * 2 - cellH = S.index rowYs (row + 1) - S.index rowYs row - paddingH * 2 + cellX = x + paddingW + cellY = startY + paddingH + cellW = colW - paddingW * 2 + cellH = viewport._rH - paddingH * 2 - widgetReqW = + widgetW = widget & _wnInfo & _wniSizeReqW - & \r -> _szrFixed r + _szrFlex r + & (\r -> _szrFixed r + _szrFlex r) + & min cellW render wenv node renderer = do - forM_ (neighbours rowYs) $ \(y1, y2, even) -> do - let color - | mouseover && _pY mouse >= (t + y1) && _pY mouse < (t + y2) = Just mouseOverColor - | not even = Just oddRowBgColor - | otherwise = Nothing - drawRect renderer (Rect l (t + y1) lastColX (y2 - y1)) color Nothing - - forM_ (S.drop 1 colXs) $ \colX -> do - drawLine renderer (Point (l + colX) t) (Point (l + colX) (t + lastRowY)) 1 (Just lineColor) - - forM_ (S.drop 1 rowYs) $ \rowY -> do - drawLine renderer (Point l (t + rowY)) (Point (l + lastColX) (t + rowY)) 1 (Just lineColor) + drawRect renderer vp bgColor Nothing + drawLine renderer (Point vp._rX (vp._rY + vp._rH)) (Point (vp._rX + vp._rW) (vp._rY + vp._rH)) 1 (Just lineColor) + forM_ (drop 1 colXs) $ \colX -> do + drawLine renderer (Point (vp._rX + colX) vp._rY) (Point (vp._rX + colX) (vp._rY + vp._rH)) 1 (Just lineColor) where - colXs = sizesToPositions (S.fromList (fromIntegral . currentWidth <$> model.columns)) - rowYs = sizesToPositions (toRowHeights (node ^. L.children) columnDefsSeq) - lastColX - | _ :|> a <- colXs = a - | otherwise = 0 - lastRowY - | _ :|> a <- rowYs = a - | otherwise = 0 + colXs = scanl (+) 0 (fromIntegral <$> cpModel.columnWidths) + bgColor + | mouseover = Just mouseOverColor + | rowIdx `mod` 2 == 1 = Just oddRowBgColor + | otherwise = Nothing vp = node ^. L.info . L.viewport - Rect l t _w _h = vp mouseover = pointInRect mouse vp mouse = wenv ^. L.inputStatus . L.mousePos mouseOverColor = (accentColor wenv) {_colorA = 0.3} oddRowBgColor = (accentColor wenv) {_colorA = 0.1} lineColor = accentColor wenv - handleEvent _wenv node _path = \case - Move (Point _pX _pY) -> - -- refresh which row shows as hovered - Just (resultReqs node [RenderOnce]) - _ -> Nothing - - handleMessage :: ContainerMessageHandler (HagridModel a) (HagridEvent ep) - handleMessage wenv node _path msg = result - where - result = cast msg >>= handleTypedMessage - - handleTypedMessage (ContentPaneScrollToRow callback) = result - where - result - | Just row <- callback indexedItems, - Just y1 <- S.lookup row rowYs, - Just y2 <- S.lookup (row + 1) rowYs = - Just (resultReqs node [SendMessage scrollId (ScrollTo (Rect vp._rX (vp._rY + y1) 1 (y2 - y1)))]) - | otherwise = - Nothing - - indexedItems = - model.sortedItems - & indexed - & List.sortOn (snd . snd) - & map (\(sortedIndex, (item, _originalIndex)) -> (item, sortedIndex)) - - vp = node ^. L.info . L.viewport - rowYs = sizesToPositions (toRowHeights (node ^. L.children) columnDefsSeq) - - scrollId = fromJust (widgetIdFromKey wenv (WidgetKey contentScrollKey)) - -initialModel :: [HagridCfg s e] -> [Column ep a] -> [a] -> HagridModel a -initialModel cfg columnDefs items = model +initialModel :: [HagridCfg s e] -> [Column ep a] -> Seq a -> HagridModel a +initialModel cfgs columnDefs items = model where model = HagridModel - { sortedItems = sortItems columnDefs sortColumn (zip items [0 ..]), + { sortedItems = sortItems columnDefs sortColumn (S.zip items (S.fromFunction (length items) id)), columns = initialColumn <$> columnDefs, - sortColumn + sortColumn, + mdlEstimatedItemHeight = max 1 (fromMaybe 40 cfg.cfgEstimatedItemHeight) } + cfg = mconcat cfgs + sortColumn - | Just (col, dir) <- (mconcat cfg).cfgInitialSort, + | Just (col, dir) <- cfg.cfgInitialSort, col >= 0, col < length columnDefs = Just (col, dir) | otherwise = Nothing - initialColumn Column {name, initialWidth} = + initialColumn Column {name, initialWidth, minWidth} = ModelColumn { name, - currentWidth = initialWidth + currentWidth = max minWidth initialWidth } +-- | When the viewport position changes, this function computes the index and +-- position within the viewport of the new fixed row. This is the first row +-- whose y-position is at least minVisibleY +fixedRow :: Double -> Seq Double -> HagridModel a -> ContentPaneModel a -> (Int, Double) +fixedRow minVisibleY inflatedItemHeights model cpModel = (min maxRow row, offset) + where + (row, offset) + | minVisibleY < inflatedStartY = + let row = ceiling (minVisibleY / model.mdlEstimatedItemHeight) + offset = (fromIntegral row * model.mdlEstimatedItemHeight) - minVisibleY + in (row, offset) + | otherwise = + inflatedItem itemsBeforeInflated inflatedStartY inflatedItemHeights + + maxRow = length model.sortedItems - 1 + + ContentPaneModel {itemsBeforeInflated} = cpModel + + inflatedStartY = fromIntegral itemsBeforeInflated * model.mdlEstimatedItemHeight + + inflatedItem i y = \case + itemHeight :<| itemHeights + | y + itemHeight >= minVisibleY -> + (i + 1, (y + itemHeight) - minVisibleY) + | otherwise -> + inflatedItem (i + 1) (y + itemHeight) itemHeights + S.Empty -> + let indexInSection = ceiling ((minVisibleY - y) / model.mdlEstimatedItemHeight) + row = i + indexInSection + offset = (y + fromIntegral indexInSection * model.mdlEstimatedItemHeight) - minVisibleY + in (row, offset) + +resizeInnerRequest :: WidgetEnv s e -> EventResponse s e sp ep +resizeInnerRequest wenv = + Request (ResizeWidgets (fromJust (widgetIdFromKey wenv (WidgetKey contentPaneInnerKey)))) + +itemsAfterInflated :: HagridModel a -> ContentPaneModel a -> Int +itemsAfterInflated model cpModel = + length model.sortedItems - (cpModel.itemsBeforeInflated + length cpModel.inflatedItems) + dragHandleWidth :: Int dragHandleWidth = 4 @@ -713,17 +962,24 @@ contentScrollKey :: Text contentScrollKey = "Hagrid.contentScroll" -contentPaneKey :: Text -contentPaneKey = "Hagrid.contentPane" +contentPaneOuterKey :: Text +contentPaneOuterKey = "Hagrid.contentPaneOuter" +contentPaneInnerKey :: Text +contentPaneInnerKey = "Hagrid.contentPaneInner" + footerPaneKey :: Text footerPaneKey = "Hagrid.footerPane" -sortItems :: [Column ep a] -> Maybe (Int, SortDirection) -> [(a, Int)] -> [(a, Int)] +sortItems :: + [Column ep a] -> + Maybe (Int, SortDirection) -> + Seq (ItemWithIndex a) -> + Seq (ItemWithIndex a) sortItems columnDefs sortColumn items = case modelSortKey columnDefs sortColumn of DontSort -> items - SortWith f -> List.sortOn (f . fst) items + SortWith f -> S.sortOn (f . fst) items modelSortKey :: [Column ep a] -> Maybe (Int, SortDirection) -> ColumnSortKey a modelSortKey columnDefs sortColumn = case sortColumn of @@ -735,11 +991,8 @@ _ -> DontSort -sizesToPositions :: Seq Double -> Seq Double -sizesToPositions = S.scanl (+) 0 - -toRowHeights :: Seq (WidgetNode s e1) -> Seq (Column e2 a) -> Seq Double -toRowHeights children columnDefs = mergeHeights <$> S.chunksOf (length columnDefs) children +toRowHeight :: Seq (Column e2 a) -> Seq (WidgetNode s e1) -> Double +toRowHeight columnDefs = mergeHeights where mergeHeights rowWidgets = foldl' max 0 (S.zipWith widgetHeight columnDefs rowWidgets) @@ -750,12 +1003,24 @@ & _wniSizeReqH & \r -> _szrFixed r + _szrFlex r + paddingH * 2 -neighbours :: Seq a -> Seq (a, a, Bool) -neighbours = \case - a :<| b :<| c :<| rest -> (a, b, False) :<| (b, c, True) :<| neighbours (c :<| rest) - a :<| b :<| S.Empty -> S.singleton (a, b, False) - _ -> S.empty +rowPositions :: forall s e. WidgetNode s e -> (Double, Seq Double, Double) +rowPositions node = (rowsStartY, rowHeights, rowsEndY) + where + vp = node._wnInfo._wniViewport + childVps = _wniViewport . _wnInfo <$> node._wnChildren + rowsStartY = case childVps of + cvp :<| _ -> cvp._rY - vp._rY + _ -> 0 + rowsEndY = case childVps of + _ :|> cvp -> (cvp._rY - vp._rY) + cvp._rH + _ -> 0 + rowHeights = _rH <$> childVps + +takeAt :: Int -> Int -> Seq a -> Seq a +takeAt at len s = + S.take len (S.drop at s) + -- | Creates a column that displays a text value, and is sortable by the text. textColumn :: -- | Name of the column, to display in the header. @@ -807,26 +1072,31 @@ sortHandler = Nothing } -cellWidget :: (CompositeModel a, WidgetEvent e, WidgetModel s) => Int -> a -> ColumnWidget e a -> WidgetNode (HagridModel s) (HagridEvent e) +cellWidget :: + (CompositeModel a, WidgetEvent e, WidgetModel s) => + Int -> + a -> + ColumnWidget e a -> + WidgetNode (ContentPaneModel s) (ContentPaneEvent e) cellWidget idx item = \case LabelWidget get -> label_ (get idx item) [ellipsis] CustomWidget get -> widget where widget = compositeD_ "Hagrid.Cell" (WidgetValue item) buildUI handleEvent [] - buildUI _wenv model = - get idx model + buildUI _wenv = + get idx handleEvent _wenv _node _model e = - [Report (ParentEvent e)] + [Report (ContentPaneParentEvent e)] footerWidgetNode :: (CompositeModel a, CompositeModel s, Typeable e) => - [(a, Int)] -> + Seq (ItemWithIndex a) -> ColumnFooterWidget e a -> - WidgetNode (HagridModel s) (HagridEvent e) + Maybe (WidgetNode (HagridModel s) (HagridEvent e)) footerWidgetNode items = \case - NoFooterWidget -> spacer - CustomFooterWidget get -> widget + NoFooterWidget -> Nothing + CustomFooterWidget get -> Just widget where widget = compositeD_ "Hagrid.FooterCell" (WidgetValue items) buildUI handleEvent [] @@ -837,6 +1107,10 @@ -- | Sends a message to the targeted 'hagrid' widget, that causes the -- widget to scroll such that a specified row becomes visible. +-- +-- Note that this is inherently dynamically typed. If the type of the callback +-- does not match the type of the targeted hagrid widget then the message +-- will be ignored. scrollToRow :: forall s e sp ep a. (Typeable a, Typeable e) => @@ -860,3 +1134,15 @@ flipSortDirection :: SortDirection -> SortDirection flipSortDirection SortAscending = SortDescending flipSortDirection SortDescending = SortAscending + +ceilingDouble :: Double -> Double +ceilingDouble x = fromIntegral (ceiling x :: Int) + +roundedRectEq :: Rect -> Rect -> Bool +roundedRectEq r1 r2 = + roundedEq r1._rX r2._rX + && roundedEq r1._rY r2._rY + && roundedEq (r1._rX + r1._rW) (r2._rX + r2._rW) + && roundedEq (r1._rY + r1._rH) (r2._rY + r2._rH) + where + roundedEq x y = (round x :: Int) == round y 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 qualified Data.Sequence as S import Data.Text (Text) import GHC.IO (unsafePerformIO) import Monomer @@ -61,6 +62,14 @@ [TestItem (fixedSize 10 & L.flex .~ 7)] `shouldBe` [Rect 0 40 50 17] + it "should have zero-height footer when no footer widgets specified" $ + viewports_ + [(testColumn "Col 1" (const (fixedSize 33))) {initialWidth = 50}] + [TestItem (fixedSize 0)] + [] + "Hagrid.FooterPane" + `shouldBe` [Rect 0 100 100 0] + sorting :: Spec sorting = describe "sorting" $ do it "should not sort rows by default" $ do @@ -107,8 +116,8 @@ merging = describe "merging" $ do it "should preserve column widths when items change" $ do let col = textColumn "Col" (const "") - startNode = nodeInit wenv (hagrid [col {initialWidth = 75}] [TestItem (fixedSize 1)]) - mergedNode = nodeMerge wenv (hagrid [col {initialWidth = 64}] [TestItem (fixedSize 2)]) startNode + startNode = nodeInit wenv (hagrid [col {initialWidth = 75}] (S.fromList [TestItem (fixedSize 1)])) + mergedNode = nodeMerge wenv (hagrid [col {initialWidth = 64}] (S.fromList [TestItem (fixedSize 2)])) startNode resizedNode = nodeResize wenv mergedNode (mergedNode ^. L.info . L.viewport) columnWidths startNode `shouldBe` [75] columnWidths resizedNode `shouldBe` [75] @@ -120,10 +129,11 @@ let cols = [(textColumn "Col" (const "")) {sortKey = SortWith (_szrFixed . sizeReq)}] items = - [ TestItem (fixedSize 1), - TestItem (fixedSize 2), - TestItem (fixedSize 3) - ] + S.fromList + [ TestItem (fixedSize 1), + TestItem (fixedSize 2), + TestItem (fixedSize 3) + ] {-# NOINLINE scrollToRowCallback #-} scrollToRowCallback cbItems = unsafePerformIO (Nothing <$ putMVar itemsMVar cbItems) -- hacky, but seems to work! @@ -137,14 +147,15 @@ nodeHandleEventEvts wenv [] cmpNode actualItems <- seq evts (takeMVar itemsMVar) actualItems - `shouldBe` [ (TestItem (fixedSize 1), 2), - (TestItem (fixedSize 2), 1), - (TestItem (fixedSize 3), 0) - ] + `shouldBe` S.fromList + [ (TestItem (fixedSize 1), 2), + (TestItem (fixedSize 2), 1), + (TestItem (fixedSize 3), 0) + ] testColumn :: Text -> (TestItem -> SizeReq) -> Column TestEvent TestItem testColumn name getHeight = - (widgetColumn name (testCellWidget getHeight)) {paddingW = 0, paddingH = 0} + (widgetColumn name (testCellWidget getHeight)) {minWidth = 10, paddingW = 0, paddingH = 0} -- | We test with custom widgets because these will create special "Hagrid.Cell" nodes in the widget -- tree that we can later use to pick out the cell widgets. @@ -160,20 +171,23 @@ cellViewports_ columnDefs items [] cellViewports_ :: [Column TestEvent TestItem] -> [TestItem] -> [SystemEvent] -> [Rect] -cellViewports_ columnDefs items evts = Foldable.toList childVps +cellViewports_ columnDefs items evts = viewports_ columnDefs items evts "Hagrid.Cell" + +viewports_ :: [Column TestEvent TestItem] -> [TestItem] -> [SystemEvent] -> WidgetType -> [Rect] +viewports_ columnDefs items evts wType = Foldable.toList childVps where - startNode = nodeInit wenv (hagrid columnDefs items) + startNode = nodeInit wenv (hagrid columnDefs (S.fromList items)) ((wenv', eventedNode, _reqs), _) = nodeHandleEvents wenv WNoInit evts startNode resizedNode = nodeResize wenv' eventedNode (eventedNode ^. L.info . L.viewport) instanceTree = widgetGetInstanceTree (resizedNode ^. L.widget) wenv' resizedNode - childVps = roundRectUnits . _wniViewport . _winInfo <$> widgetsOfType "Hagrid.Cell" instanceTree + childVps = roundRectUnits . _wniViewport . _winInfo <$> widgetsOfType wType instanceTree -- Extract the column widths by observing the locations of the special drag handle widgets columnWidths :: WidgetNode TestModel TestEvent -> [Int] columnWidths node = fromFractional <$> colWidths where (_, colWidths) = - Foldable.foldl' (\(px, cws) (Rect x _y w _h) -> (x + w, (x + w - px) : cws)) (0, []) vps + Foldable.foldl' (\(px, cws) (Rect x _y w _h) -> (x + w, (x + w / 2 - px) : cws)) (0, []) vps vps = _wniViewport . _winInfo <$> dragHandles dragHandles =