diff --git a/cooklang-examples/OlivierSalad.cook b/cooklang-examples/OlivierSalad.cook index 8e62af7..584b278 100644 --- a/cooklang-examples/OlivierSalad.cook +++ b/cooklang-examples/OlivierSalad.cook @@ -1,5 +1,6 @@ --- title: Olivier Salad +tags: salad, side --- -- TODO add source diff --git a/src/Roux/Html.hs b/src/Roux/Html.hs index e798030..35f2463 100644 --- a/src/Roux/Html.hs +++ b/src/Roux/Html.hs @@ -187,7 +187,7 @@ renderAlpha recipes | null recipes = H.p "No recipes found." | otherwise = let sorted = sortOn alphaSortKey recipes - in H.ul ! A.class_ "roux-recipes" $ mapM_ (recipeItem . Idx.riFilename) sorted + in H.ul ! A.class_ "roux-recipes" $ mapM_ recipeItem sorted -- | Render recipes grouped by tags. renderByTags :: [Idx.RecipeInfo] -> Html @@ -234,20 +234,20 @@ renderByCourse recipes = do renderTagGroup :: (Text, [Idx.RecipeInfo]) -> Html renderTagGroup (tag, rs) = do H.h3 $ H.toHtml tag - H.ul ! A.class_ "roux-recipes" $ mapM_ (recipeItem . Idx.riFilename) rs + H.ul ! A.class_ "roux-recipes" $ mapM_ recipeItem 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 ! A.class_ "roux-recipes" $ mapM_ (recipeItem . Idx.riFilename) rs + H.ul ! A.class_ "roux-recipes" $ mapM_ recipeItem rs -- | Render a single recipe link on the index page. -recipeItem :: FilePath -> Html -recipeItem fp = +recipeItem :: Idx.RecipeInfo -> Html +recipeItem info = H.li $ - H.a ! A.href (H.toValue ("/recipes/" <> urlEncode fp)) $ - H.toHtml (T.pack (takeBaseName fp)) + H.a ! A.href (H.toValue ("/recipes/" <> urlEncode (Idx.riFilename info))) $ + H.toHtml (Idx.riTitle info) -- | Sort key for alphabetical ordering by title, falling back to filename. alphaSortKey :: Idx.RecipeInfo -> Text diff --git a/src/Roux/Parser.hs b/src/Roux/Parser.hs index f50811f..fc5f8ea 100644 --- a/src/Roux/Parser.hs +++ b/src/Roux/Parser.hs @@ -11,6 +11,8 @@ module Roux.Parser ( import Control.Monad (join) import Data.Char (isDigit) import Data.List.NonEmpty (NonEmpty ((:|))) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe, mapMaybe) import Data.Text (Text) import qualified Data.Text as T import qualified Text.Parsec as P @@ -40,15 +42,94 @@ data RawBlock parseCookFile :: Text -> Either String Recipe parseCookFile input = let trimmed = T.strip input - rawBlocks = splitByBlankLines trimmed + (meta, body) = extractFrontMatter trimmed + rawBlocks = splitByBlankLines body nonEmpty = filter (not . T.null) rawBlocks in case nonEmpty of [] -> - Right emptyRecipe + Right emptyRecipe{recipeMetadata = meta} blocks -> case traverse classifyBlock blocks of Left err -> Left err - Right items -> Right (buildRecipe items) + Right items -> + Right (buildRecipe items){recipeMetadata = meta} + +-- --------------------------------------------------------------------------- +-- YAML front matter +-- --------------------------------------------------------------------------- + +{- | Extract YAML front matter (between @---@ … @---@ delimiters) from the +start of a file, returning (metadata, remaining_body). If no front matter +is found, returns (emptyMetadata, input). +-} +extractFrontMatter :: Text -> (Metadata, Text) +extractFrontMatter input = + case T.stripPrefix "---\n" (T.stripStart input) of + Just afterOpen -> + case T.breakOn "\n---" afterOpen of + (yamlBlock, rest) + | not (T.null yamlBlock) -> + let meta = parseYamlLines yamlBlock + -- Skip the closing --- and any following newline + body = T.stripStart (T.drop 4 rest) + in (meta, body) + _ -> (emptyMetadata, input) + Nothing -> (emptyMetadata, input) + +{- | Parse simple YAML key-value lines into a 'Metadata' value. +Supports @key: value@ pairs. Known keys are mapped to canonical fields; +unknown keys go into 'metaCustom'. +-} +parseYamlLines :: Text -> Metadata +parseYamlLines yaml = + let pairs = mapMaybe parseYamlLine (T.lines yaml) + pairMap = Map.fromList pairs + in Metadata + { metaTitle = Map.lookup "title" pairMap + , metaServings = do + s <- Map.lookup "servings" pairMap + case reads (T.unpack s) of + [(n, "")] -> Just (n, Nothing) + _ -> Nothing + , metaAuthor = Map.lookup "author" pairMap + , metaSource = Map.lookup "source" pairMap + , metaTotalTime = Nothing + , metaPrepTime = Nothing + , metaCookTime = Nothing + , metaDifficulty = Map.lookup "difficulty" pairMap + , metaCuisine = Map.lookup "cuisine" pairMap + , metaCourse = case Map.lookup "course" pairMap of + Just c -> Just c + Nothing -> Map.lookup "category" pairMap + , metaDiet = maybe [] parseTagList (Map.lookup "diet" pairMap) + , metaTags = maybe [] parseTagList (Map.lookup "tags" pairMap) + , metaImage = case Map.lookup "image" pairMap of + Just i -> Just i + Nothing -> Map.lookup "picture" pairMap + , metaDescription = case Map.lookup "description" pairMap of + Just d -> Just d + Nothing -> Map.lookup "introduction" pairMap + , metaCustom = Map.empty + } + +-- | Parse a single @key: value@ line. +parseYamlLine :: Text -> Maybe (Text, Text) +parseYamlLine line = + case T.break (== ':') line of + (key, rest) + | not (T.null key) -> + let value = T.strip (T.drop 1 rest) + in Just (T.strip (T.toLower key), value) + | otherwise -> Nothing + +-- | Parse a YAML tag list: @[tag1, tag2]@ or @tag1, tag2@. +parseTagList :: Text -> [Text] +parseTagList t = + let stripped = T.strip t + content = case T.stripPrefix "[" stripped of + Just rest -> fromMaybe rest (T.stripSuffix "]" (T.strip rest)) + Nothing -> stripped + in map T.strip (T.splitOn "," content) -- --------------------------------------------------------------------------- -- File-level structure