From b0926ee60d98a50c35e60d1f61a01acabeb67d72 Mon Sep 17 00:00:00 2001 From: James Brechtel Date: Tue, 19 May 2026 08:16:58 -0400 Subject: [PATCH] Add three browse modes to index page: alphabetical, by tag, by course - Add SortMode type (AlphaSort | TagSort | CourseSort) to Roux.Html - Routes: / (alpha), /sorted/tags, /sorted/course - AlphaSort: recipes sorted by title (from metadata) or filename - TagSort: recipes grouped under tag headings, empty state when none - CourseSort: recipes grouped by course/category metadata - Navigation bar in index page with active-highlighted buttons - Add metaCourse field to Metadata model (+ emptyMetadata update) - Add nubOrd helper for deduplicating tag/course lists - All 26 tests passing, hlint clean --- src/Roux/Html.hs | 122 ++++++++++++++++++++++++++++++++++++++++++--- src/Roux/Parser.hs | 4 +- src/Roux/Server.hs | 8 ++- src/Roux/Types.hs | 2 + 4 files changed, 125 insertions(+), 11 deletions(-) diff --git a/src/Roux/Html.hs b/src/Roux/Html.hs index 93cd114..a740f4e 100644 --- a/src/Roux/Html.hs +++ b/src/Roux/Html.hs @@ -8,6 +8,7 @@ Blaze-html re-exports many common names (title, meta, step, a, b, …) so name-shadowing is unavoidable with local bindings. -} module Roux.Html ( + SortMode (..), indexPage, recipePage, urlEncode, @@ -17,8 +18,9 @@ module Roux.Html ( import Control.Monad (unless) import Data.ByteString.Lazy (ByteString) import Data.Function ((&)) +import Data.List (sortOn) import qualified Data.List.NonEmpty as NE -import Data.Maybe (catMaybes, fromMaybe) +import Data.Maybe (catMaybes, fromMaybe, mapMaybe) import Data.Ratio (denominator, numerator) import Data.Text (Text) import qualified Data.Text as T @@ -29,6 +31,17 @@ import Text.Blaze.Html5.Attributes as A import qualified Roux.RecipeIndex as Idx import Roux.Types +-- --------------------------------------------------------------------------- +-- Sort mode for the index page +-- --------------------------------------------------------------------------- + +-- | How to group or sort recipes on the index page. +data SortMode + = AlphaSort + | TagSort + | CourseSort + deriving stock (Eq, Show) + -- --------------------------------------------------------------------------- -- Helpers used throughout -- --------------------------------------------------------------------------- @@ -79,22 +92,104 @@ page title content = -- --------------------------------------------------------------------------- -- | Render the recipe index page. -indexPage :: [Idx.RecipeInfo] -> ByteString -indexPage recipes = +indexPage :: SortMode -> [Idx.RecipeInfo] -> ByteString +indexPage mode recipes = page "Roux — Recipes" $ do - H.nav $ H.ul $ H.li $ H.strong "Roux" + H.nav $ do + H.ul $ H.li $ H.strong "Roux" + H.ul $ do + H.li $ sortLink "A-Z" AlphaSort "/" mode + H.li $ sortLink "By Tag" TagSort "/sorted/tags" mode + H.li $ sortLink "By Course" CourseSort "/sorted/course" mode H.h2 "Recipes" H.p "Your personal recipe collection." - case filter (isRight . Idx.riRecipe) recipes of - [] -> H.p "No recipes found." - good -> - H.ul $ mapM_ (recipeItem . Idx.riFilename) good + let good = filter (isRight . Idx.riRecipe) recipes + case mode of + AlphaSort -> renderAlpha good + TagSort -> renderByTags good + CourseSort -> renderByCourse good -- Show parse errors separately let bad = filter (isLeft . Idx.riRecipe) recipes unless (null bad) $ do H.h3 "Unparseable recipes" H.ul $ mapM_ (H.li . H.toHtml . Idx.riTitle) bad +-- | A navigation link for a sort mode, highlighted when active. +sortLink :: Text -> SortMode -> Text -> SortMode -> Html +sortLink label linkMode url currentMode = + if linkMode == currentMode + then H.a ! A.href (H.toValue url) ! A.role "button" ! A.class_ "contrast outline" $ H.toHtml label + else H.a ! A.href (H.toValue url) $ H.toHtml label + +-- | Render recipes sorted alphabetically by title. +renderAlpha :: [Idx.RecipeInfo] -> Html +renderAlpha recipes + | null recipes = H.p "No recipes found." + | otherwise = + let sorted = sortOn alphaSortKey recipes + in H.ul $ mapM_ (recipeItem . Idx.riFilename) sorted + +-- | Sort key for alphabetical ordering by title, falling back to filename. +alphaSortKey :: Idx.RecipeInfo -> Text +alphaSortKey info = case Idx.riRecipe info of + Right r -> case metaTitle (recipeMetadata r) of + Just t -> t + Nothing -> T.pack (takeBaseName (Idx.riFilename info)) + Left _ -> T.pack "zzzz" + +-- | Render recipes grouped by tags. +renderByTags :: [Idx.RecipeInfo] -> Html +renderByTags recipes = do + let tags = collectTags recipes + if null tags + then H.p "No tagged recipes." + else mapM_ renderTagGroup tags + where + collectTags rs = + let entries = mapMaybe tagEntries rs + allTags = concat entries + uniqueTags = sortOn Prelude.id (nubOrd allTags) + in [(tag, filter (hasTag tag) rs) | tag <- uniqueTags] + tagEntries r = case Idx.riRecipe r of + Right recipe -> + let tags = metaTags (recipeMetadata recipe) + in if null tags then Nothing else Just tags + Left _ -> Nothing + hasTag tag r = case Idx.riRecipe r of + Right recipe -> tag `elem` metaTags (recipeMetadata recipe) + Left _ -> False + +-- | Render recipes grouped by course/category. +renderByCourse :: [Idx.RecipeInfo] -> Html +renderByCourse recipes = do + let groups = collectCourses recipes + if null groups + then H.p "No recipes with course metadata." + else mapM_ renderCourseGroup groups + where + collectCourses rs = + let entries = mapMaybe courseEntry rs + uniqueCourses = sortOn Prelude.id (nubOrd (Prelude.map fst entries)) + in [(course, [r | r <- rs, courseOf r == Just course]) | course <- uniqueCourses] + courseEntry r = case Idx.riRecipe r of + Right recipe -> (,) <$> metaCourse (recipeMetadata recipe) <*> pure () + Left _ -> Nothing + courseOf r = case Idx.riRecipe r of + Right recipe -> metaCourse (recipeMetadata recipe) + Left _ -> Nothing + +-- | Render a group of recipes under a tag heading. +renderTagGroup :: (Text, [Idx.RecipeInfo]) -> Html +renderTagGroup (tag, rs) = do + H.h3 $ H.toHtml tag + H.ul $ mapM_ (recipeItem . Idx.riFilename) rs + +-- | Render a group of recipes under a course heading. +renderCourseGroup :: (Text, [Idx.RecipeInfo]) -> Html +renderCourseGroup (course, rs) = do + H.h3 $ H.toHtml course + H.ul $ mapM_ (recipeItem . Idx.riFilename) rs + -- | Render a single recipe link on the index page. recipeItem :: FilePath -> Html recipeItem fp = @@ -322,3 +417,14 @@ isLeft _ = False -- | Check if an 'Either' is 'Right'. isRight :: Either a b -> Bool isRight = not . isLeft + +{- | Remove duplicate elements from a list while preserving order of first +occurrence. +-} +nubOrd :: (Eq a) => [a] -> [a] +nubOrd = go [] + where + go _ [] = [] + go seen (x : xs) + | x `elem` seen = go seen xs + | otherwise = x : go (x : seen) xs diff --git a/src/Roux/Parser.hs b/src/Roux/Parser.hs index e1f5085..f50811f 100644 --- a/src/Roux/Parser.hs +++ b/src/Roux/Parser.hs @@ -364,8 +364,8 @@ groupSections items = -- Items before the first header → unnamed section, then named (before, (RawSectionHeader name) : rest) -> let pre = - [Section Nothing (makeNonEmpty (map rawToBody before)) - | not (null before) + [ Section Nothing (makeNonEmpty (map rawToBody before)) + | not (null before) ] named = collectNamedSection name rest in pre ++ named diff --git a/src/Roux/Server.hs b/src/Roux/Server.hs index 3128945..493953b 100644 --- a/src/Roux/Server.hs +++ b/src/Roux/Server.hs @@ -41,7 +41,13 @@ app recipeDir = do handleRequest :: [Idx.RecipeInfo] -> Wai.Application handleRequest recipes request respond = case Wai.pathInfo request of - [] -> respond (htmlResponse (Html.indexPage recipes)) + -- Index page (default: alphabetical) + [] -> respond (htmlResponse (Html.indexPage Html.AlphaSort recipes)) + -- Index page (sorted by tags) + ["sorted", "tags"] -> respond (htmlResponse (Html.indexPage Html.TagSort recipes)) + -- Index page (sorted by course/category) + ["sorted", "course"] -> respond (htmlResponse (Html.indexPage Html.CourseSort recipes)) + -- Recipe detail page ["recipes", rawPath] -> case lookupRecipe (urlDecodePath rawPath) recipes of Just info -> respond (htmlResponse (Html.recipePage info)) diff --git a/src/Roux/Types.hs b/src/Roux/Types.hs index 6dbfc87..0bd1100 100644 --- a/src/Roux/Types.hs +++ b/src/Roux/Types.hs @@ -205,6 +205,7 @@ data Metadata = Metadata , metaCookTime :: !(Maybe Duration) , metaDifficulty :: !(Maybe Text) , metaCuisine :: !(Maybe Text) + , metaCourse :: !(Maybe Text) , metaDiet :: ![Text] , metaTags :: ![Text] , metaImage :: !(Maybe Text) @@ -226,6 +227,7 @@ emptyMetadata = , metaCookTime = Nothing , metaDifficulty = Nothing , metaCuisine = Nothing + , metaCourse = Nothing , metaDiet = [] , metaTags = [] , metaImage = Nothing