example(table): extend to reflect sort directions

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,35 +25,57 @@ 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
   | SortDescription
   | 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)

demo/Example/View/Icon.hs

@@ -36,8 +36,20 @@ check = raw $ do
 chevronDown :: View c ()
 chevronDown = raw $ do
   [i|<svg xmlns="http://www.w3.org/2000/svg" fill="none" viewBox="0 0 24 24" stroke-width="1.5" stroke="currentColor" class="size-6">
-  <path stroke-linecap="round" stroke-linejoin="round" d="m19.5 8.25-7.5 7.5-7.5-7.5" />
-</svg>|]
+    <path stroke-linecap="round" stroke-linejoin="round" d="m19.5 8.25-7.5 7.5-7.5-7.5" />
+    </svg>|]
+
+chevronUp :: View c ()
+chevronUp = raw $ do
+  [i|<svg xmlns="http://www.w3.org/2000/svg" viewBox="0 0 20 20" fill="currentColor" class="size-5">
+    <path fill-rule="evenodd" d="M9.47 6.47a.75.75 0 0 1 1.06 0l4.25 4.25a.75.75 0 1 1-1.06 1.06L10 8.06l-3.72 3.72a.75.75 0 0 1-1.06-1.06l4.25-4.25Z" clip-rule="evenodd" />
+  </svg>|]
+
+chevronUpDown :: View c ()
+chevronUpDown = raw $ do
+  [i|<svg xmlns="http://www.w3.org/2000/svg" viewBox="0 0 20 20" fill="currentColor" class="size-5">
+    <path fill-rule="evenodd" d="M10.53 3.47a.75.75 0 0 0-1.06 0L6.22 6.72a.75.75 0 0 0 1.06 1.06L10 5.06l2.72 2.72a.75.75 0 1 0 1.06-1.06l-3.25-3.25Zm-4.31 9.81 3.25 3.25a.75.75 0 0 0 1.06 0l3.25-3.25a.75.75 0 1 0-1.06-1.06L10 14.94l-2.72-2.72a.75.75 0 0 0-1.06 1.06Z" clip-rule="evenodd" />
+  </svg>|]
 
 -- Haskell logo
 -- https://commons.wikimedia.org/wiki/File:Haskell-Logo.svg

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