From cab59260463656910333475051e37245787f30ae Mon Sep 17 00:00:00 2001 From: jk <47693+sectore@users.noreply.github.com> Date: Thu, 28 May 2026 14:46:56 +0200 Subject: [PATCH] example(table): extend to reflect sort directions --- demo/Example/DataLists/DataTable.hs | 54 +++++++++++++++++++++-------- demo/Example/View/Icon.hs | 16 +++++++-- demo/Example/View/SortableTable.hs | 27 +++++++++------ 3 files changed, 70 insertions(+), 27 deletions(-) diff --git a/demo/Example/DataLists/DataTable.hs b/demo/Example/DataLists/DataTable.hs index a1434f4e..064d9249 100644 --- a/demo/Example/DataLists/DataTable.hs +++ b/demo/Example/DataLists/DataTable.hs @@ -6,13 +6,15 @@ module Example.DataLists.DataTable where import App.Docs import App.Route as Route import Data.List (sortOn) +import Data.Ord (Down (Down)) import Data.Text (pack) import Effectful import Example.Data.ProgrammingLanguage (ProgrammingLanguage (..), allLanguages) import Example.View.Layout -import Example.View.SortableTable (dataTable, sortBtn, sortColumn) +import Example.View.SortableTable (SortDirection (..), dataTable, sortBtn, sortColumn) import Web.Atomic.CSS import Web.Hyperbole +import Web.Hyperbole.HyperView import Prelude hiding (even, odd) -- DataTable -> do @@ -23,10 +25,13 @@ page = do pure $ layout (Data SortableTable) $ do el "We can write view Functions that work in any view, like a dataTable" example $(moduleSource) $ do - hyper Languages $ languagesView Nothing allLanguages + hyperState Languages Nothing $ languagesView allLanguages data Languages = Languages - deriving (Generic, ViewId) + deriving (Generic) + +instance ViewId Languages where + type ViewState Languages = Maybe (SortField, SortDirection) data SortField = SortName @@ -34,24 +39,43 @@ data SortField | SortFamily deriving (Show, Read, Eq, Generic, ToJSON, FromJSON) +toggleSortDir :: SortDirection -> SortDirection +toggleSortDir Ascending = Descending +toggleSortDir Descending = Ascending + instance HyperView Languages es where data Action Languages = SortOn SortField deriving (Generic, ViewAction) update (SortOn fld) = do - let sorted = sortOnField fld allLanguages - pure $ languagesView (Just fld) sorted + newDir <- gets $ \case + Just (currFld, currDir) | currFld == fld -> toggleSortDir currDir + _ -> Ascending + put $ Just (fld, newDir) + let sorted = sortOnField fld newDir allLanguages + pure $ languagesView sorted -sortOnField :: SortField -> [ProgrammingLanguage] -> [ProgrammingLanguage] -sortOnField = \case - SortName -> sortOn (.name) - SortDescription -> sortOn (.description) - SortFamily -> sortOn (.family) +sortOnField :: SortField -> SortDirection -> [ProgrammingLanguage] -> [ProgrammingLanguage] +sortOnField fld dir = case fld of + SortName -> sortBy (.name) + SortDescription -> sortBy (.description) + SortFamily -> sortBy (.family) + where + sortBy :: (Ord b) => (ProgrammingLanguage -> b) -> [ProgrammingLanguage] -> [ProgrammingLanguage] + sortBy f = case dir of + Ascending -> sortOn f + Descending -> sortOn (Down . f) -languagesView :: Maybe SortField -> [ProgrammingLanguage] -> View Languages () -languagesView fld langs = +languagesView :: [ProgrammingLanguage] -> View Languages () +languagesView langs = do + mSt <- viewState + let directionOf fld = case mSt of + Just (f, dir) | f == fld -> Just dir + _ -> Nothing + sortColumn' lbl fld = + sortColumn (sortBtn lbl (SortOn fld) (directionOf fld)) table langs ~ dataTable $ do - sortColumn (sortBtn "Language" (SortOn SortName) (fld == Just SortName)) (.name) - sortColumn (sortBtn "Family" (SortOn SortFamily) (fld == Just SortFamily)) $ \d -> pack $ show d.family - sortColumn (sortBtn "Description" (SortOn SortDescription) (fld == Just SortDescription)) (.description) + sortColumn' "Language" SortName (.name) + sortColumn' "Family" SortFamily $ \d -> pack $ show d.family + sortColumn' "Description" SortDescription (.description) diff --git a/demo/Example/View/Icon.hs b/demo/Example/View/Icon.hs index bee8dd39..d3caed8e 100644 --- a/demo/Example/View/Icon.hs +++ b/demo/Example/View/Icon.hs @@ -36,8 +36,20 @@ check = raw $ do chevronDown :: View c () chevronDown = raw $ do [i| - -|] + + |] + +chevronUp :: View c () +chevronUp = raw $ do + [i| + + |] + +chevronUpDown :: View c () +chevronUpDown = raw $ do + [i| + + |] -- Haskell logo -- https://commons.wikimedia.org/wiki/File:Haskell-Logo.svg diff --git a/demo/Example/View/SortableTable.hs b/demo/Example/View/SortableTable.hs index ba95404f..18ce7b77 100644 --- a/demo/Example/View/SortableTable.hs +++ b/demo/Example/View/SortableTable.hs @@ -2,12 +2,16 @@ module Example.View.SortableTable where import Data.Text (Text) import Example.Colors -import Example.Style qualified as Style import Example.View.Icon qualified as Icon import Web.Atomic.CSS import Web.Hyperbole import Prelude hiding (even, odd) +data SortDirection + = Ascending + | Descending + deriving (Show, Read, Eq, Generic, ToJSON, FromJSON) + dataRow :: (Styleable a) => CSS a -> CSS a dataRow = gap 10 . pad (All $ PxRem dataRowPadding) @@ -30,16 +34,19 @@ dataTable = ".data-table tr:nth-child(even)" (declarations (bg Light)) -sortBtn :: (ViewAction (Action id)) => Text -> Action id -> Bool -> View id () -sortBtn lbl click isSelected = do - button click ~ Style.link . flexRow . gap 0 $ do - el ~ selectedColumn $ text lbl - el ~ width 20 $ Icon.chevronDown +sortBtn :: (ViewAction (Action id)) => Text -> Action id -> Maybe SortDirection -> View id () +sortBtn lbl click mDir = + button click ~ sortStyle . flexRow . utility "items-center" ["align-items" :. "center"] . gap 4 $ do + el $ text lbl + el ~ width 16 $ sortIcon where - selectedColumn = - if isSelected - then underline - else id + sortStyle = case mDir of + Nothing -> color Secondary + Just _ -> color Primary . underline + sortIcon = case mDir of + Nothing -> el ~ color SecondaryLight $ Icon.chevronUpDown + Just Ascending -> el Icon.chevronDown + Just Descending -> el Icon.chevronUp sortColumn :: (ViewAction (Action id)) => View id () -> (dt -> Text) -> TableColumns id dt () sortColumn header cellText = do