monomer-hagrid 0.1.0.0 → 0.2.0.0

raw patch · 9 files changed

+984/−444 lines, 9 filesdep +randomdep ~bytestringdep ~containersdep ~data-defaultnew-component:exe:example-basicnew-component:exe:example-big-gridnew-component:exe:example-resizing-cellsPVP ok

version bump matches the API change (PVP)

Dependencies added: random

Dependency ranges changed: bytestring, containers, data-default, data-default-class, ilist, lens, mtl, stm, text, time

API changes (from Hackage documentation)

Files

• ChangeLog.md +8/−0
• README.md +14/−10
• example-basic/Main.hs +216/−0
• example-big-grid/Main.hs +62/−0
• example-resizing-cells/Main.hs +115/−0
• examples/Main.hs +0/−218
• monomer-hagrid.cabal +86/−33
• src/Monomer/Hagrid.hs +454/−168
• test/Monomer/HagridSpec.hs +29/−15

@@ -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.

@@ -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

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

@@ -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)

@@ -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

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

@@ -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

@@ -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

@@ -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 =