Detach Document type from Markup type class

Separation of concerns! Makes it simpler reason about what's happening.

src/Rib/Markup.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -13,9 +14,11 @@ module Rib.Markup
 
     -- * Document type
     Document (..),
+    mkDocumentFrom,
   )
 where
 
+import Control.Monad.Except hiding (fail)
 import Data.Aeson
 import Lucid (Html)
 import Named
@@ -39,6 +42,27 @@ data Document repr
       }
   deriving (Generic, Show)
 
+mkDocumentFrom ::
+  forall b repr.
+  Markup repr =>
+  -- | File path, used only to identify (not access) the document
+  "relpath" :! Path Rel File ->
+  -- | Actual file path, for access and reading
+  "path" :! Path b File ->
+  IO (Either (MarkupError repr) (Document repr))
+mkDocumentFrom (Arg k) (Arg f) = runExceptT $ do
+  -- HACK: this looks bad
+  v :: repr <-
+    liftEither
+      =<< ( lift $
+              readDoc @repr @b
+                ! #relpath k
+                ! #path f
+          )
+  let meta = extractMeta v
+  h <- liftEither $ renderDoc v
+  pure $ Document k v h meta
+
 -- | Class for denoting Markup representations.
 --
 -- See `Rib.Markup.Pandoc` and `Rib.Markup.MMark` for two available instances.
@@ -54,19 +78,24 @@ class Markup repr where
     Path Rel File ->
     -- | Markup text to parse
     Text ->
-    Either (MarkupError repr) (Document repr)
+    Either (MarkupError repr) repr
 
   -- | Like `parseDoc` but take the actual filepath instead of text.
   readDoc ::
+    forall b.
     -- | File path, used to identify the document only.
     "relpath" :! Path Rel File ->
     -- | Actual path to the file to parse.
     "path" :! Path b File ->
-    IO (Either (MarkupError repr) (Document repr))
+    IO (Either (MarkupError repr) repr)
+
+  extractMeta ::
+    repr ->
+    Maybe Value
 
   -- | Render the document as Lucid HTML
   renderDoc ::
-    Document repr ->
+    repr ->
     Either (MarkupError repr) (Html ())
 
   -- | Convert `MarkupError` to string

src/Rib/Markup/MMark.hs

@@ -40,16 +40,15 @@ instance Markup MMark where
 
   parseDoc f s = case MMark.parse (toFilePath f) s of
     Left e -> Left e
-    Right doc ->
-      let doc' = MMark.useExtensions exts $ useTocExt doc
-          meta = MMark.projectYaml doc
-       in Right $ Document f doc' (MMark.render doc') meta
+    Right doc -> Right $ MMark.useExtensions exts $ useTocExt doc
 
   readDoc (Arg k) (Arg f) = do
     content <- readFileText (toFilePath f)
     pure $ parseDoc k content
 
-  renderDoc = Right . MMark.render . _document_val
+  extractMeta = MMark.projectYaml
+
+  renderDoc = Right . MMark.render
 
   showMarkupError = toText . M.errorBundlePretty
 

src/Rib/Markup/Pandoc.hs

@@ -61,8 +61,7 @@ instance Markup Pandoc where
         $ liftEither
         $ detectReader k
     withExcept RibPandocError_PandocError $
-      mkDoc k
-        =<< parsePure r s
+      parsePure r s
 
   readDoc (Arg k) (Arg f) = runExceptT $ do
     content <- readFileText $ toFilePath f
@@ -70,21 +69,21 @@ instance Markup Pandoc where
       withExceptT RibPandocError_UnknownFormat $
         detectReader k
     withExceptT RibPandocError_PandocError $
-      mkDoc k
-        =<< parse r content
+      parse r content
+
+  extractMeta (Pandoc meta _) = flattenMeta meta
 
   renderDoc =
     fmap toHtmlRaw
       . first RibPandocError_PandocError
       . liftEither
       . render'
-      . _document_val
 
   showMarkupError = toText @String . show
 
 -- | Parse and render the markup directly to HTML
 renderPandoc :: Path Rel File -> Text -> Html ()
-renderPandoc f s = either (error . showMarkupError @Pandoc) id $ runExcept $ do
+renderPandoc f s = either (error . show) id $ runExcept $ do
   doc <- liftEither $ parseDoc @Pandoc f s
   liftEither $ renderDoc doc
 
@@ -104,7 +103,7 @@ parsePure r =
 -- Supports the [includeCode](https://github.com/owickstrom/pandoc-include-code) extension.
 parse ::
   (MonadIO m, MonadError PandocError m) =>
-  -- | Document format. Example: `Text.Pandoc.Readers.readMarkdown`
+  -- | Markup format. Example: `Text.Pandoc.Readers.readMarkdown`
   (ReaderOptions -> Text -> PandocIO Pandoc) ->
   -- | Source text to parse
   Text ->
@@ -192,14 +191,6 @@ detectReader f = do
     -- MonadError instead.
     catchInMonadError ef = either (throwError . ef) pure
 
-mkDoc :: MonadError PandocError m => Path Rel File -> Pandoc -> m (Document Pandoc)
-mkDoc f v = do
-  h <- liftEither $ render' v
-  pure $ Document f v h $ getMetadata v
-
-getMetadata :: Pandoc -> Maybe Value
-getMetadata (Pandoc meta _) = flattenMeta meta
-
 -- | Flatten a Pandoc 'Meta' into a well-structured JSON object.
 --
 -- Renders Pandoc text objects into plain strings along the way.

src/Rib/Shake.hs

@@ -91,7 +91,7 @@ readDocMulti pat = do
     need $ toFilePath <$> [input </> f]
     result <-
       liftIO $
-        readDoc
+        mkDocumentFrom
           ! #relpath f
           ! #path (input </> f)
     case result of