Move pandoc meta functions to their own module

example/Main.hs

@@ -25,7 +25,8 @@ import qualified Reflex.Dom.Pandoc.SyntaxHighlighting as SyntaxHighlighting
 import qualified Rib
 import qualified Rib.App as App
 import qualified Rib.Settings as S
-import Rib.Types (Page (..), Post (..), getPostAttributeInlines, getPostAttributeJson)
+import Rib.Types
+import Rib.Pandoc
 
 data PostCategory
   = Programming
@@ -100,7 +101,7 @@ pageWidget page = elAttr "html" ("lang" =: "en") $ do
         case page of
           Page_Index posts -> do
             let (progPosts, otherPosts) =
-                  partition ((== Just Programming) . getPostAttributeJson "category") posts
+                  partition ((== Just Programming) . getPandocMetaJson "category" . _post_doc) posts
             elClass "h2" "ui header" $ text "Haskell & Nix notes"
             postList progPosts
             elClass "h2" "ui header" $ text "Other notes"
@@ -121,14 +122,14 @@ pageWidget page = elAttr "html" ("lang" =: "en") $ do
       Page_Post post -> postTitle post
 
     -- Render the post title (Markdown supported)
-    postTitle = maybe (text "Untitled") elPandocInlines . getPostAttributeInlines "title"
+    postTitle = maybe (text "Untitled") elPandocInlines . getPandocMetaInlines "title" . _post_doc
 
     -- Render a list of posts
     postList xs = divClass "ui relaxed divided list" $ forM_ xs $ \x ->
       divClass "item" $ do
         elAttr "a" ("class" =: "header" <> "href" =: _post_url x) $
           postTitle x
-        el "small" $ maybe blank elPandocInlines $ getPostAttributeInlines "description" x
+        el "small" $ maybe blank elPandocInlines $ getPandocMetaInlines "description" $ _post_doc x
 
     semanticUiCss = "https://cdn.jsdelivr.net/npm/semantic-ui@2.4.2/dist/semantic.min.css"
 

rib.cabal

@@ -21,6 +21,7 @@ library
   exposed-modules:
       Rib
     , Rib.App
+    , Rib.Pandoc
     , Rib.Settings
     , Rib.Types
     , Reflex.Dom.Pandoc.Document

src/Rib/Pandoc.hs

@@ -0,0 +1,42 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
+
+module Rib.Pandoc where
+
+import Control.Monad
+import Data.Aeson (decode, FromJSON)
+import Data.Maybe
+import Data.Text (Text)
+import qualified Data.Text as T
+
+import Text.Pandoc
+import Text.Pandoc.UTF8 (fromStringLazy)
+
+-- Get the YAML metadata for the given key in a post.
+--
+-- We expect this to return `[Inline]` unless we upgrade pandoc. See
+-- https://github.com/jgm/pandoc/issues/2139#issuecomment-310522113
+getPandocMetaInlines :: String -> Pandoc -> Maybe [Inline]
+getPandocMetaInlines k (Pandoc meta _) =
+  case lookupMeta k meta of
+    Just (MetaInlines inlines) -> Just inlines
+    _ -> Nothing
+
+-- Get the YAML metadata for a key that is a list of text values
+getPandocMetaList :: String -> Pandoc -> Maybe [Text]
+getPandocMetaList k (Pandoc meta _) =
+  case lookupMeta k meta of
+    Just (MetaList vals) -> Just $ catMaybes $ flip fmap vals $ \case
+      MetaInlines [Str val] -> Just $ T.pack val
+      _ -> Nothing
+    _ -> Nothing
+
+getPandocMetaRaw :: String -> Pandoc -> Maybe String
+getPandocMetaRaw k p = do
+  getPandocMetaInlines k p >>= \case
+    [Str v] -> Just v
+    _ -> Nothing
+
+-- Like getPandocMeta but expects the value to be JSON encoding of a type.
+getPandocMetaJson :: FromJSON a => String -> Pandoc -> Maybe a
+getPandocMetaJson k = decode . fromStringLazy <=< getPandocMetaRaw k

src/Rib/Types.hs

@@ -7,11 +7,9 @@ module Rib.Types
   ( Page(..)
   , Post(..)
   , PostFilePath(..)
-  , getPostAttributeInlines
-  , getPostAttributeList
-  , getPostAttributeJson
   ) where
 
+import Control.Monad
 import Data.Aeson (FromJSON, ToJSON, decode)
 import qualified Data.Map as Map
 import Data.Text (Text)
@@ -19,9 +17,8 @@ import Data.Maybe
 import qualified Data.Text as T
 import GHC.Generics (Generic)
 
+import Text.Pandoc (Pandoc)
 import Development.Shake.Classes (Binary, Hashable, NFData)
-import Text.Pandoc
-import Text.Pandoc.UTF8 (fromStringLazy)
 
 -- | Represents a HTML page that will be generated
 data Page
@@ -40,36 +37,3 @@ data Post = Post
 -- Used as a Shake Cache key to build a cache of post objects.
 newtype PostFilePath = PostFilePath FilePath
   deriving (Show, Eq, Hashable, Binary, NFData, Generic)
-
--- TODO: These functions should probably live in Pandoc Util module
-
--- Get the YAML metadata for the given key in a post.
---
--- We expect this to return `[Inline]` unless we upgrade pandoc. See
--- https://github.com/jgm/pandoc/issues/2139#issuecomment-310522113
-getPostAttributeInlines :: String -> Post -> Maybe [Inline]
-getPostAttributeInlines k (Post (Pandoc meta _) _) =
-  case Map.lookup k (unMeta meta) of
-    Just (MetaInlines inlines) -> Just inlines
-    _ -> Nothing
-
--- Get the YAML metadata for a key that is a list of text values
-getPostAttributeList :: String -> Post -> Maybe [Text]
-getPostAttributeList k (Post (Pandoc meta _) _) =
-  case Map.lookup k (unMeta meta) of
-    Just (MetaList vals) -> Just $ catMaybes $ flip fmap vals $ \case
-      MetaInlines [Str val] -> Just $ T.pack val
-      _ -> Nothing
-    _ -> Nothing
-
--- Like getPostAttribute but expects the value to be JSON encoding of a type.
-getPostAttributeJson :: FromJSON a => String -> Post -> Maybe a
-getPostAttributeJson k p = do
-  v <- getPostAttributeRaw k p
-  decode $ fromStringLazy v
-
-getPostAttributeRaw :: String -> Post -> Maybe String
-getPostAttributeRaw k p = do
-  getPostAttributeInlines k p >>= \case
-    [Str v] -> Just v
-    _ -> Nothing