monomer-hagrid 0.3.1.0 → 0.3.1.1
raw patch · 9 files changed
+407/−403 lines, 9 files
Files
- ChangeLog.md +4/−0
- example-basic/Main.hs +0/−213
- example-big-grid/Main.hs +0/−58
- example-resizing-cells/Main.hs +0/−111
- examples/basic/Main.hs +213/−0
- examples/big-grid/Main.hs +58/−0
- examples/resizing-cells/Main.hs +111/−0
- monomer-hagrid.cabal +4/−4
- src/Monomer/Hagrid.hs +17/−17
ChangeLog.md view
@@ -1,3 +1,7 @@+## 0.3.1.1+### Fixed+- Fixed a bug where row background color was determined by the original row index rather than the sorted index.+ ## 0.3.1.0 ### Changed - Remove ilist package dependency, since it is not in the latest Stackage LTS and is easily replaced.
− example-basic/Main.hs
@@ -1,213 +0,0 @@-{-# 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"
− example-big-grid/Main.hs
@@ -1,58 +0,0 @@-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)
− example-resizing-cells/Main.hs
@@ -1,111 +0,0 @@-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
+ examples/basic/Main.hs view
@@ -0,0 +1,213 @@+{-# 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"
+ examples/big-grid/Main.hs view
@@ -0,0 +1,58 @@+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)
+ examples/resizing-cells/Main.hs view
@@ -0,0 +1,111 @@+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
monomer-hagrid.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.0 name: monomer-hagrid-version: 0.3.1.0+version: 0.3.1.1 license: MIT license-file: LICENSE maintainer: garethdanielsmith@gmail.com@@ -53,7 +53,7 @@ executable example-basic main-is: Main.hs- hs-source-dirs: example-basic+ hs-source-dirs: examples/basic other-modules: Paths_monomer_hagrid autogen-modules: Paths_monomer_hagrid default-language: Haskell2010@@ -85,7 +85,7 @@ executable example-big-grid main-is: Main.hs- hs-source-dirs: example-big-grid+ hs-source-dirs: examples/big-grid other-modules: Paths_monomer_hagrid autogen-modules: Paths_monomer_hagrid default-language: Haskell2010@@ -116,7 +116,7 @@ executable example-resizing-cells main-is: Main.hs- hs-source-dirs: example-resizing-cells+ hs-source-dirs: examples/resizing-cells other-modules: Paths_monomer_hagrid autogen-modules: Paths_monomer_hagrid default-language: Haskell2010
src/Monomer/Hagrid.hs view
@@ -131,7 +131,7 @@ LabelWidget (Int -> a -> Text) | -- | Create a widget of arbitrary type. The function receives the original item -- index (i.e. not the index in the sorted list) and the item itself.- CustomWidget (forall s. WidgetModel s => Int -> a -> WidgetNode s e)+ CustomWidget (forall s. (WidgetModel s) => Int -> a -> WidgetNode s e) -- | How to create the footer widget for a column. data ColumnFooterWidget e a@@ -139,7 +139,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 => Seq (ItemWithIndex a) -> 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@@ -152,7 +152,7 @@ = -- | Means that a column can't be sorted. DontSort | -- | Means that a column can be sorted, using the specified sort key function.- forall b. Ord b => SortWith (a -> b)+ forall b. (Ord b) => SortWith (a -> b) -- | Whether a column is being sorted in ascending or descending order. data SortDirection@@ -177,7 +177,7 @@ | OrderByColumn Int | ResizeColumn Int Int | ResizeColumnFinished Int- | forall a. Typeable a => ScrollToRow (ScrollToRowCallback a)+ | forall a. (Typeable a) => ScrollToRow (ScrollToRowCallback a) | ScrollToRect Rect | ParentEvent e @@ -242,7 +242,7 @@ = SetVisibleArea {visibleArea :: Rect} | InnerResizeComplete | ContentPaneParentEvent e- | forall a. Typeable a => ContentPaneScrollToRow (ScrollToRowCallback a)+ | forall a. (Typeable a) => ContentPaneScrollToRow (ScrollToRowCallback a) -- | Creates a hagrid widget, using the default configuration. hagrid ::@@ -377,7 +377,7 @@ color = fromMaybe (rgb 255 255 255) (_sstText style >>= _txsFontColor) transColor = color {_colorA = 0.7} -headerPane :: forall e a. WidgetEvent e => [Column e a] -> HagridModel a -> WidgetNode (HagridModel a) (HagridEvent e)+headerPane :: forall e a. (WidgetEvent e) => [Column e a] -> HagridModel a -> WidgetNode (HagridModel a) (HagridEvent e) headerPane columnDefs model = makeNode (initialHeaderFooterState model) where makeNode :: HeaderFooterState -> WidgetNode (HagridModel a) (HagridEvent e)@@ -437,7 +437,7 @@ indL = l + w + state.offsetX - indW - pad indRect = Rect indL indT indW indW -headerButton :: WidgetEvent e => Int -> Column e a -> WidgetNode (HagridModel a) (HagridEvent e)+headerButton :: (WidgetEvent e) => Int -> Column e a -> WidgetNode (HagridModel a) (HagridEvent e) headerButton colIndex columnDef = button_ columnDef.name (OrderByColumn colIndex) [ellipsis] `styleBasic` [radius 0]@@ -533,7 +533,7 @@ node & L.widget .~ makeWidget state {offsetX} result = cast msg >>= handleTypedMessage -headerDragHandle :: WidgetEvent e => Int -> Column e a -> ModelColumn -> WidgetNode s (HagridEvent e)+headerDragHandle :: (WidgetEvent e) => Int -> Column e a -> ModelColumn -> WidgetNode s (HagridEvent e) headerDragHandle colIndex columnDef column = tree where tree = defaultWidgetNode "Hagrid.HeaderDragHandle" (headerDragHandleWidget Nothing)@@ -757,7 +757,7 @@ containerResize = resize } - rowWidgets = contentPaneRow columnDefs cpModel <$> cpModel.inflatedItems+ rowWidgets = S.mapWithIndex (contentPaneRow columnDefs cpModel) cpModel.inflatedItems merge _wenv newNode _oldNode oldState = resultReqs newNode reqs where@@ -799,9 +799,10 @@ (CompositeModel a, WidgetEvent e) => Seq (Column e a) -> ContentPaneModel a ->- (a, Int) ->+ Int ->+ ItemWithIndex a -> WidgetNode (ContentPaneModel a) (ContentPaneEvent e)-contentPaneRow columnDefs cpModel (item, rowIdx) = tree+contentPaneRow columnDefs cpModel sortedIdx item = tree where tree = defaultWidgetNode "Hagrid.Row" widget@@ -809,7 +810,7 @@ widget = createContainer- (cpModel.columnWidths, item, rowIdx)+ (cpModel.columnWidths, item, sortedIdx) def { containerGetSizeReq = getSizeReq, containerResize = resize,@@ -818,7 +819,7 @@ cellWidgets = do Column {widget} <- columnDefs- pure (cellWidget rowIdx item widget)+ pure (cellWidget item widget) getSizeReq _wenv _node children = (w, h) where@@ -864,7 +865,7 @@ colXs = scanl (+) 0 (fromIntegral <$> cpModel.columnWidths) bgColor | mouseover = Just mouseOverColor- | rowIdx `mod` 2 == 1 = Just oddRowBgColor+ | sortedIdx `mod` 2 == 1 = Just oddRowBgColor | otherwise = Nothing vp = node ^. L.info . L.viewport mouseover = pointInRect mouse vp@@ -1052,11 +1053,10 @@ cellWidget :: (CompositeModel a, WidgetEvent e) =>- Int ->- a ->+ ItemWithIndex a -> ColumnWidget e a -> WidgetNode (ContentPaneModel a) (ContentPaneEvent e)-cellWidget idx item = \case+cellWidget (item, idx) = \case LabelWidget get -> label_ (get idx item) [ellipsis] CustomWidget get -> widget where