content: {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE Rank2Types #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  
  -- | Helpers for working with Pandoc documents
  module Rib.Parser.Pandoc
    ( -- * Parsing
      parse,
      parsePure,
  
      -- * Rendering
      render,
      renderPandocInlines,
  
      -- * Extracting information
      extractMeta,
      getH1,
      getToC,
      getFirstImg,
  
      -- * Re-exports
      Pandoc,
      module Text.Pandoc.Readers,
    )
  where
  
  import Control.Monad.Except (MonadError, liftEither, runExcept)
  import Data.Aeson
  import Development.Shake (Action, readFile')
  import Lucid (HtmlT, toHtmlRaw)
  import Relude
  import Rib.Shake (ribInputDir)
  import System.FilePath
  import Text.Pandoc
  import qualified Text.Pandoc.Readers
  import Text.Pandoc.Walk (query)
  import Text.Pandoc.Writers.Shared (toTableOfContents)
  
  -- | Pure version of `parse`
  parsePure ::
    (ReaderOptions -> Text -> PandocPure Pandoc) ->
    Text ->
    Pandoc
  parsePure textReader s =
    either (error . show) id $ runExcept $ do
      runPure' $ textReader readerSettings s
  
  -- | Parse a lightweight markup language using Pandoc
  parse ::
    -- | The pandoc text reader function to use, eg: `readMarkdown`
    (ReaderOptions -> Text -> PandocIO Pandoc) ->
    FilePath ->
    Action Pandoc
  parse textReader f =
    either fail pure =<< do
      inputDir <- ribInputDir
      content <- toText <$> readFile' (inputDir </> f)
      fmap (first show) $ runExceptT $ do
        runIO' $ textReader readerSettings content
  
  -- | Render a Pandoc document to HTML
  render :: Monad m => Pandoc -> HtmlT m ()
  render doc =
    either error id $ first show $ runExcept $ do
      runPure'
      $ fmap toHtmlRaw
      $ writeHtml5String writerSettings doc
  
  -- | Extract the Pandoc metadata as JSON value
  extractMeta :: Pandoc -> Maybe (Either Text Value)
  extractMeta (Pandoc meta _) = flattenMeta meta
  
  runPure' :: MonadError PandocError m => PandocPure a -> m a
  runPure' = liftEither . runPure
  
  runIO' :: (MonadError PandocError m, MonadIO m) => PandocIO a -> m a
  runIO' = liftEither <=< liftIO . runIO
  
  -- | Render a list of Pandoc `Text.Pandoc.Inline` values as Lucid HTML
  --
  -- Useful when working with `Text.Pandoc.Meta` values from the document metadata.
  renderPandocInlines :: Monad m => [Inline] -> HtmlT m ()
  renderPandocInlines =
    renderPandocBlocks . pure . Plain
  
  renderPandocBlocks :: Monad m => [Block] -> HtmlT m ()
  renderPandocBlocks =
    toHtmlRaw . render . Pandoc mempty
  
  -- | Get the top-level heading as Lucid HTML
  getH1 :: Monad m => Pandoc -> Maybe (HtmlT m ())
  getH1 (Pandoc _ bs) = fmap renderPandocInlines $ flip query bs $ \case
    Header 1 _ xs -> Just xs
    _ -> Nothing
  
  -- | Get the document table of contents
  getToC :: Monad m => Pandoc -> HtmlT m ()
  getToC (Pandoc _ bs) = renderPandocBlocks [toc]
    where
      toc = toTableOfContents writerSettings bs
  
  -- | Get the first image in the document if one exists
  getFirstImg ::
    Pandoc ->
    -- | Relative URL path to the image
    Maybe Text
  getFirstImg (Pandoc _ bs) = listToMaybe $ flip query bs $ \case
    Image _ _ (url, _) -> [toText url]
    _ -> []
  
  exts :: Extensions
  exts =
    mconcat
      [ extensionsFromList
          [ Ext_yaml_metadata_block,
            Ext_fenced_code_attributes,
            Ext_auto_identifiers,
            Ext_smart
          ],
        githubMarkdownExtensions
      ]
  
  readerSettings :: ReaderOptions
  readerSettings = def {readerExtensions = exts}
  
  writerSettings :: WriterOptions
  writerSettings = def {writerExtensions = exts}
  
  -- Internal code
  
  -- | Flatten a Pandoc 'Meta' into a well-structured JSON object.
  --
  -- Renders Pandoc text objects into plain strings along the way.
  flattenMeta :: Meta -> Maybe (Either Text Value)
  flattenMeta (Meta meta) = fmap toJSON . traverse go <$> guarded (not . null) meta
    where
      go :: MetaValue -> Either Text Value
      go (MetaMap m) = toJSON <$> traverse go m
      go (MetaList m) = toJSONList <$> traverse go m
      go (MetaBool m) = pure $ toJSON m
      go (MetaString m) = pure $ toJSON m
      go (MetaInlines m) =
        bimap show toJSON
          $ runPure . plainWriter
          $ Pandoc mempty [Plain m]
      go (MetaBlocks m) =
        bimap show toJSON
          $ runPure . plainWriter
          $ Pandoc mempty m
      plainWriter = writePlain def
  