monomer-hagrid-0.3.0.0: example-basic/Main.hs

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