{-# 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"