Handle parsing errors in Pandoc metadata

CONTRIBUTING.md

@@ -1,4 +1,4 @@
-Rib is designed to be used not only its author, but also by others. To that end, if you notice that the library can be changed or improved in anyway so as to make it easier to write your own static sites, please do not hesitate to write a short proposal in the Issue tracker.
+Rib is designed to be used by not only its author, but also others. To that end, if you notice that the library can be changed or improved in anyway so as to make it easier to write your own static sites, please do not hesitate to write a short proposal in the Issue tracker.
 
 ## Coding style
 

src/Rib/Document.hs

@@ -36,9 +36,6 @@ data Document repr meta
         _document_val :: repr,
         -- | HTML rendering of the parsed representation.
         _document_html :: Html (),
-        -- | Metadata associated with the document as an aeson Value. If no metadata
-        -- is provided this will be Nothing.
-        _document_metaValue :: Maybe Value,
         -- | The parsed metadata.
         _document_meta :: meta
       }
@@ -47,13 +44,13 @@ data Document repr meta
 data DocumentError
   = DocumentError_MarkupError Text
   | DocumentError_MetadataMissing
-  | DocumentError_MetadataBadJSON Text
+  | DocumentError_MetadataMalformed Text
 
 instance Show DocumentError where
   show = \case
     DocumentError_MarkupError e -> toString e
     DocumentError_MetadataMissing -> "Metadata missing"
-    DocumentError_MetadataBadJSON msg -> "Bad metadata JSON: " <> toString msg
+    DocumentError_MetadataMalformed msg -> "Bad metadata JSON: " <> toString msg
 
 -- | Parse, render to HTML and extract metadata from the given file.
 --
@@ -75,17 +72,16 @@ mkDocumentFrom k@(arg #relpath -> k') f = do
     liftEither
       $ first DocumentError_MarkupError
       $ renderDoc v
-  let metaValueM = extractMeta v
   metaValue <-
-    maybeToEither
+    liftEither
-      DocumentError_MetadataMissing
+      . (first DocumentError_MetadataMalformed)
-      metaValueM
+      =<< maybeToEither DocumentError_MetadataMissing (extractMeta v)
   meta <-
     liftEither
-      $ first (DocumentError_MetadataBadJSON . toText)
+      $ first (DocumentError_MetadataMalformed . toText)
       $ resultToEither
       $ fromJSON metaValue
-  pure $ Document k' v html metaValueM meta
+  pure $ Document k' v html meta
   where
     maybeToEither e = \case
       Nothing -> throwError e

src/Rib/Markup.hs

@@ -13,7 +13,7 @@ module Rib.Markup
   )
 where
 
-import Data.Aeson
+import Data.Aeson (Value)
 import Lucid (Html)
 import Named
 import Path
@@ -42,7 +42,7 @@ class Markup repr where
 
   extractMeta ::
     repr ->
-    Maybe Value
+    Maybe (Either Text Value)
 
   -- | Render the document as Lucid HTML
   renderDoc ::

src/Rib/Markup/MMark.hs

@@ -44,7 +44,7 @@ instance Markup MMark where
     content <- readFileText (toFilePath f)
     pure $ parseDoc k content
 
-  extractMeta = MMark.projectYaml
+  extractMeta = fmap Right . MMark.projectYaml
 
   renderDoc = Right . MMark.render
 

src/Rib/Markup/Pandoc.hs

@@ -77,10 +77,8 @@ instance Markup Pandoc where
   extractMeta (Pandoc meta _) = flattenMeta meta
 
   renderDoc =
-    bimap show toHtmlRaw
+    bimap (show . RibPandocError_PandocError) toHtmlRaw
-      . first RibPandocError_PandocError
       . liftEither
-      . fmap toHtmlRaw
       . runPure
       . writeHtml5String writerSettings
 
@@ -170,16 +168,20 @@ detectReader f = do
 -- | Flatten a Pandoc 'Meta' into a well-structured JSON object.
 --
 -- Renders Pandoc text objects into plain strings along the way.
-flattenMeta :: Meta -> Maybe Value
+flattenMeta :: Meta -> Maybe (Either Text Value)
-flattenMeta (Meta meta) = toJSON . fmap go <$> guarded null meta
+flattenMeta (Meta meta) = fmap toJSON . traverse go <$> guarded null meta
   where
-    go :: MetaValue -> Value
+    go :: MetaValue -> Either Text Value
-    go (MetaMap m) = toJSON $ fmap go m
+    go (MetaMap m) = toJSON <$> traverse go m
-    go (MetaList m) = toJSONList $ fmap go m
+    go (MetaList m) = toJSONList <$> traverse go m
-    go (MetaBool m) = toJSON m
+    go (MetaBool m) = pure $ toJSON m
-    go (MetaString m) = toJSON m
+    go (MetaString m) = pure $ toJSON m
-    go (MetaInlines m) = toJSON (runPure' . writer $ Pandoc mempty [Plain m])
+    go (MetaInlines m) =
-    go (MetaBlocks m) = toJSON (runPure' . writer $ Pandoc mempty m)
+      bimap show toJSON
-    runPure' :: PandocPure a -> a
+        $ runPure . plainWriter
-    runPure' = either (error . show) id . runPure
+        $ Pandoc mempty [Plain m]
-    writer = writePlain def
+    go (MetaBlocks m) =
+      bimap show toJSON
+        $ runPure . plainWriter
+        $ Pandoc mempty m
+    plainWriter = writePlain def