{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}

-- | 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 Path
import Relude
import Rib.Shake (ribInputDir)
import Text.Pandoc
import Text.Pandoc.Filter.IncludeCode (includeCode)
import qualified Text.Pandoc.Readers
import Text.Pandoc.Walk (query, walkM)
import Text.Pandoc.Writers.Shared (toTableOfContents)

-- | Pure version of `parse`
parsePure ::
  (ReaderOptions -> Text -> PandocPure Pandoc) ->
  Text ->
  Pandoc
parsePure :: (ReaderOptions -> Text -> PandocPure Pandoc) -> Text -> Pandoc
parsePure textReader :: ReaderOptions -> Text -> PandocPure Pandoc
textReader s :: Text
s =
  (PandocError -> Pandoc)
-> (Pandoc -> Pandoc) -> Either PandocError Pandoc -> Pandoc
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> Pandoc
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> Pandoc) -> (PandocError -> Text) -> PandocError -> Pandoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PandocError -> Text
forall b a. (Show a, IsString b) => a -> b
show) Pandoc -> Pandoc
forall a. a -> a
id (Either PandocError Pandoc -> Pandoc)
-> Either PandocError Pandoc -> Pandoc
forall a b. (a -> b) -> a -> b
$ Except PandocError Pandoc -> Either PandocError Pandoc
forall e a. Except e a -> Either e a
runExcept (Except PandocError Pandoc -> Either PandocError Pandoc)
-> Except PandocError Pandoc -> Either PandocError Pandoc
forall a b. (a -> b) -> a -> b
$ do
    PandocPure Pandoc -> Except PandocError Pandoc
forall (m :: * -> *) a.
MonadError PandocError m =>
PandocPure a -> m a
runPure' (PandocPure Pandoc -> Except PandocError Pandoc)
-> PandocPure Pandoc -> Except PandocError Pandoc
forall a b. (a -> b) -> a -> b
$ ReaderOptions -> Text -> PandocPure Pandoc
textReader ReaderOptions
readerSettings Text
s

-- | Parse a lightweight markup language using Pandoc
parse ::
  -- | The pandoc text reader function to use, eg: `readMarkdown`
  (ReaderOptions -> Text -> PandocIO Pandoc) ->
  Path Rel File ->
  Action Pandoc
parse :: (ReaderOptions -> Text -> PandocIO Pandoc)
-> Path Rel File -> Action Pandoc
parse textReader :: ReaderOptions -> Text -> PandocIO Pandoc
textReader f :: Path Rel File
f =
  (String -> Action Pandoc)
-> (Pandoc -> Action Pandoc)
-> Either String Pandoc
-> Action Pandoc
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Action Pandoc
forall (m :: * -> *) a. MonadFail m => String -> m a
fail Pandoc -> Action Pandoc
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String Pandoc -> Action Pandoc)
-> Action (Either String Pandoc) -> Action Pandoc
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
    Path Rel Dir
inputDir <- Action (Path Rel Dir)
ribInputDir
    Text
content <- String -> Text
forall a. ToText a => a -> Text
toText (String -> Text) -> Action String -> Action Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasCallStack => String -> Action String
String -> Action String
readFile' (Path Rel File -> String
forall b t. Path b t -> String
toFilePath (Path Rel File -> String) -> Path Rel File -> String
forall a b. (a -> b) -> a -> b
$ Path Rel Dir
inputDir Path Rel Dir -> Path Rel File -> Path Rel File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
f)
    (Either PandocError Pandoc -> Either String Pandoc)
-> Action (Either PandocError Pandoc)
-> Action (Either String Pandoc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((PandocError -> String)
-> Either PandocError Pandoc -> Either String Pandoc
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first PandocError -> String
forall b a. (Show a, IsString b) => a -> b
show) (Action (Either PandocError Pandoc)
 -> Action (Either String Pandoc))
-> Action (Either PandocError Pandoc)
-> Action (Either String Pandoc)
forall a b. (a -> b) -> a -> b
$ ExceptT PandocError Action Pandoc
-> Action (Either PandocError Pandoc)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT PandocError Action Pandoc
 -> Action (Either PandocError Pandoc))
-> ExceptT PandocError Action Pandoc
-> Action (Either PandocError Pandoc)
forall a b. (a -> b) -> a -> b
$ do
      Pandoc
v' <- PandocIO Pandoc -> ExceptT PandocError Action Pandoc
forall (m :: * -> *) a.
(MonadError PandocError m, MonadIO m) =>
PandocIO a -> m a
runIO' (PandocIO Pandoc -> ExceptT PandocError Action Pandoc)
-> PandocIO Pandoc -> ExceptT PandocError Action Pandoc
forall a b. (a -> b) -> a -> b
$ ReaderOptions -> Text -> PandocIO Pandoc
textReader ReaderOptions
readerSettings Text
content
      IO Pandoc -> ExceptT PandocError Action Pandoc
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Pandoc -> ExceptT PandocError Action Pandoc)
-> IO Pandoc -> ExceptT PandocError Action Pandoc
forall a b. (a -> b) -> a -> b
$ (Block -> IO Block) -> Pandoc -> IO Pandoc
forall a b (m :: * -> *).
(Walkable a b, Monad m, Applicative m, Functor m) =>
(a -> m a) -> b -> m b
walkM Block -> IO Block
includeSources Pandoc
v'
  where
    includeSources :: Block -> IO Block
includeSources = Maybe Format -> Block -> IO Block
includeCode (Maybe Format -> Block -> IO Block)
-> Maybe Format -> Block -> IO Block
forall a b. (a -> b) -> a -> b
$ Format -> Maybe Format
forall a. a -> Maybe a
Just (Format -> Maybe Format) -> Format -> Maybe Format
forall a b. (a -> b) -> a -> b
$ Text -> Format
Format "html5"

-- | Render a Pandoc document to HTML
render :: Monad m => Pandoc -> HtmlT m ()
render :: Pandoc -> HtmlT m ()
render doc :: Pandoc
doc =
  (Text -> HtmlT m ())
-> (HtmlT m () -> HtmlT m ())
-> Either Text (HtmlT m ())
-> HtmlT m ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> HtmlT m ()
forall a t. (HasCallStack, IsText t) => t -> a
error HtmlT m () -> HtmlT m ()
forall a. a -> a
id (Either Text (HtmlT m ()) -> HtmlT m ())
-> Either Text (HtmlT m ()) -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ (PandocError -> Text)
-> Either PandocError (HtmlT m ()) -> Either Text (HtmlT m ())
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first PandocError -> Text
forall b a. (Show a, IsString b) => a -> b
show (Either PandocError (HtmlT m ()) -> Either Text (HtmlT m ()))
-> Either PandocError (HtmlT m ()) -> Either Text (HtmlT m ())
forall a b. (a -> b) -> a -> b
$ Except PandocError (HtmlT m ()) -> Either PandocError (HtmlT m ())
forall e a. Except e a -> Either e a
runExcept (Except PandocError (HtmlT m ())
 -> Either PandocError (HtmlT m ()))
-> Except PandocError (HtmlT m ())
-> Either PandocError (HtmlT m ())
forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *) a.
MonadError PandocError m =>
PandocPure a -> m a
runPure'
    (PandocPure (HtmlT m ()) -> Except PandocError (HtmlT m ()))
-> PandocPure (HtmlT m ()) -> Except PandocError (HtmlT m ())
forall a b. (a -> b) -> a -> b
$ (Text -> HtmlT m ()) -> PandocPure Text -> PandocPure (HtmlT m ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtmlRaw
    (PandocPure Text -> PandocPure (HtmlT m ()))
-> PandocPure Text -> PandocPure (HtmlT m ())
forall a b. (a -> b) -> a -> b
$ WriterOptions -> Pandoc -> PandocPure Text
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m Text
writeHtml5String WriterOptions
writerSettings Pandoc
doc

-- | Extract the Pandoc metadata as JSON value
extractMeta :: Pandoc -> Maybe (Either Text Value)
extractMeta :: Pandoc -> Maybe (Either Text Value)
extractMeta (Pandoc meta :: Meta
meta _) = Meta -> Maybe (Either Text Value)
flattenMeta Meta
meta

runPure' :: MonadError PandocError m => PandocPure a -> m a
runPure' :: PandocPure a -> m a
runPure' = Either PandocError a -> m a
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either PandocError a -> m a)
-> (PandocPure a -> Either PandocError a) -> PandocPure a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PandocPure a -> Either PandocError a
forall a. PandocPure a -> Either PandocError a
runPure

runIO' :: (MonadError PandocError m, MonadIO m) => PandocIO a -> m a
runIO' :: PandocIO a -> m a
runIO' = Either PandocError a -> m a
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either PandocError a -> m a)
-> (PandocIO a -> m (Either PandocError a)) -> PandocIO a -> m a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< IO (Either PandocError a) -> m (Either PandocError a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either PandocError a) -> m (Either PandocError a))
-> (PandocIO a -> IO (Either PandocError a))
-> PandocIO a
-> m (Either PandocError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PandocIO a -> IO (Either PandocError a)
forall a. PandocIO a -> IO (Either PandocError a)
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 :: [Inline] -> HtmlT m ()
renderPandocInlines =
  [Block] -> HtmlT m ()
forall (m :: * -> *). Monad m => [Block] -> HtmlT m ()
renderPandocBlocks ([Block] -> HtmlT m ())
-> ([Inline] -> [Block]) -> [Inline] -> HtmlT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> [Block]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Block -> [Block]) -> ([Inline] -> Block) -> [Inline] -> [Block]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Inline] -> Block
Plain

renderPandocBlocks :: Monad m => [Block] -> HtmlT m ()
renderPandocBlocks :: [Block] -> HtmlT m ()
renderPandocBlocks =
  HtmlT Identity () -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtmlRaw (HtmlT Identity () -> HtmlT m ())
-> ([Block] -> HtmlT Identity ()) -> [Block] -> HtmlT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pandoc -> HtmlT Identity ()
forall (m :: * -> *). Monad m => Pandoc -> HtmlT m ()
render (Pandoc -> HtmlT Identity ())
-> ([Block] -> Pandoc) -> [Block] -> HtmlT Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Meta -> [Block] -> Pandoc
Pandoc Meta
forall a. Monoid a => a
mempty

-- | Get the top-level heading as Lucid HTML
getH1 :: Monad m => Pandoc -> Maybe (HtmlT m ())
getH1 :: Pandoc -> Maybe (HtmlT m ())
getH1 (Pandoc _ bs :: [Block]
bs) = ([Inline] -> HtmlT m ()) -> Maybe [Inline] -> Maybe (HtmlT m ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Inline] -> HtmlT m ()
forall (m :: * -> *). Monad m => [Inline] -> HtmlT m ()
renderPandocInlines (Maybe [Inline] -> Maybe (HtmlT m ()))
-> Maybe [Inline] -> Maybe (HtmlT m ())
forall a b. (a -> b) -> a -> b
$ ((Block -> Maybe [Inline]) -> [Block] -> Maybe [Inline])
-> [Block] -> (Block -> Maybe [Inline]) -> Maybe [Inline]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Block -> Maybe [Inline]) -> [Block] -> Maybe [Inline]
forall a b c. (Walkable a b, Monoid c) => (a -> c) -> b -> c
query [Block]
bs ((Block -> Maybe [Inline]) -> Maybe [Inline])
-> (Block -> Maybe [Inline]) -> Maybe [Inline]
forall a b. (a -> b) -> a -> b
$ \case
  Header 1 _ xs :: [Inline]
xs -> [Inline] -> Maybe [Inline]
forall a. a -> Maybe a
Just [Inline]
xs
  _ -> Maybe [Inline]
forall a. Maybe a
Nothing

-- | Get the document table of contents
getToC :: Monad m => Pandoc -> HtmlT m ()
getToC :: Pandoc -> HtmlT m ()
getToC (Pandoc _ bs :: [Block]
bs) = [Block] -> HtmlT m ()
forall (m :: * -> *). Monad m => [Block] -> HtmlT m ()
renderPandocBlocks [Block
toc]
  where
    toc :: Block
toc = WriterOptions -> [Block] -> Block
toTableOfContents WriterOptions
writerSettings [Block]
bs

-- | Get the first image in the document if one exists
getFirstImg ::
  Pandoc ->
  -- | Relative URL path to the image
  Maybe Text
getFirstImg :: Pandoc -> Maybe Text
getFirstImg (Pandoc _ bs :: [Block]
bs) = [Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe ([Text] -> Maybe Text) -> [Text] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ ((Inline -> [Text]) -> [Block] -> [Text])
-> [Block] -> (Inline -> [Text]) -> [Text]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Inline -> [Text]) -> [Block] -> [Text]
forall a b c. (Walkable a b, Monoid c) => (a -> c) -> b -> c
query [Block]
bs ((Inline -> [Text]) -> [Text]) -> (Inline -> [Text]) -> [Text]
forall a b. (a -> b) -> a -> b
$ \case
  Image _ _ (url :: Text
url, _) -> [Text -> Text
forall a. ToText a => a -> Text
toText Text
url]
  _ -> []

exts :: Extensions
exts :: Extensions
exts =
  [Extensions] -> Extensions
forall a. Monoid a => [a] -> a
mconcat
    [ [Extension] -> Extensions
extensionsFromList
        [ Extension
Ext_yaml_metadata_block,
          Extension
Ext_fenced_code_attributes,
          Extension
Ext_auto_identifiers,
          Extension
Ext_smart
        ],
      Extensions
githubMarkdownExtensions
    ]

readerSettings :: ReaderOptions
readerSettings :: ReaderOptions
readerSettings = ReaderOptions
forall a. Default a => a
def {readerExtensions :: Extensions
readerExtensions = Extensions
exts}

writerSettings :: WriterOptions
writerSettings :: WriterOptions
writerSettings = WriterOptions
forall a. Default a => a
def {writerExtensions :: Extensions
writerExtensions = Extensions
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 -> Maybe (Either Text Value)
flattenMeta (Meta meta :: Map Text MetaValue
meta) = (Map Text Value -> Value)
-> Either Text (Map Text Value) -> Either Text Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Map Text Value -> Value
forall a. ToJSON a => a -> Value
toJSON (Either Text (Map Text Value) -> Either Text Value)
-> (Map Text MetaValue -> Either Text (Map Text Value))
-> Map Text MetaValue
-> Either Text Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MetaValue -> Either Text Value)
-> Map Text MetaValue -> Either Text (Map Text Value)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse MetaValue -> Either Text Value
go (Map Text MetaValue -> Either Text Value)
-> Maybe (Map Text MetaValue) -> Maybe (Either Text Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Map Text MetaValue -> Bool)
-> Map Text MetaValue -> Maybe (Map Text MetaValue)
forall (f :: * -> *) a. Alternative f => (a -> Bool) -> a -> f a
guarded (Bool -> Bool
not (Bool -> Bool)
-> (Map Text MetaValue -> Bool) -> Map Text MetaValue -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text MetaValue -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) Map Text MetaValue
meta
  where
    go :: MetaValue -> Either Text Value
    go :: MetaValue -> Either Text Value
go (MetaMap m :: Map Text MetaValue
m) = Map Text Value -> Value
forall a. ToJSON a => a -> Value
toJSON (Map Text Value -> Value)
-> Either Text (Map Text Value) -> Either Text Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MetaValue -> Either Text Value)
-> Map Text MetaValue -> Either Text (Map Text Value)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse MetaValue -> Either Text Value
go Map Text MetaValue
m
    go (MetaList m :: [MetaValue]
m) = [Value] -> Value
forall a. ToJSON a => [a] -> Value
toJSONList ([Value] -> Value) -> Either Text [Value] -> Either Text Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MetaValue -> Either Text Value)
-> [MetaValue] -> Either Text [Value]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse MetaValue -> Either Text Value
go [MetaValue]
m
    go (MetaBool m :: Bool
m) = Value -> Either Text Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either Text Value) -> Value -> Either Text Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall a. ToJSON a => a -> Value
toJSON Bool
m
    go (MetaString m :: Text
m) = Value -> Either Text Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either Text Value) -> Value -> Either Text Value
forall a b. (a -> b) -> a -> b
$ Text -> Value
forall a. ToJSON a => a -> Value
toJSON Text
m
    go (MetaInlines m :: [Inline]
m) =
      (PandocError -> Text)
-> (Text -> Value) -> Either PandocError Text -> Either Text Value
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap PandocError -> Text
forall b a. (Show a, IsString b) => a -> b
show Text -> Value
forall a. ToJSON a => a -> Value
toJSON
        (Either PandocError Text -> Either Text Value)
-> Either PandocError Text -> Either Text Value
forall a b. (a -> b) -> a -> b
$ PandocPure Text -> Either PandocError Text
forall a. PandocPure a -> Either PandocError a
runPure (PandocPure Text -> Either PandocError Text)
-> (Pandoc -> PandocPure Text) -> Pandoc -> Either PandocError Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pandoc -> PandocPure Text
plainWriter
        (Pandoc -> Either PandocError Text)
-> Pandoc -> Either PandocError Text
forall a b. (a -> b) -> a -> b
$ Meta -> [Block] -> Pandoc
Pandoc Meta
forall a. Monoid a => a
mempty [[Inline] -> Block
Plain [Inline]
m]
    go (MetaBlocks m :: [Block]
m) =
      (PandocError -> Text)
-> (Text -> Value) -> Either PandocError Text -> Either Text Value
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap PandocError -> Text
forall b a. (Show a, IsString b) => a -> b
show Text -> Value
forall a. ToJSON a => a -> Value
toJSON
        (Either PandocError Text -> Either Text Value)
-> Either PandocError Text -> Either Text Value
forall a b. (a -> b) -> a -> b
$ PandocPure Text -> Either PandocError Text
forall a. PandocPure a -> Either PandocError a
runPure (PandocPure Text -> Either PandocError Text)
-> (Pandoc -> PandocPure Text) -> Pandoc -> Either PandocError Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pandoc -> PandocPure Text
plainWriter
        (Pandoc -> Either PandocError Text)
-> Pandoc -> Either PandocError Text
forall a b. (a -> b) -> a -> b
$ Meta -> [Block] -> Pandoc
Pandoc Meta
forall a. Monoid a => a
mempty [Block]
m
    plainWriter :: Pandoc -> PandocPure Text
plainWriter = WriterOptions -> Pandoc -> PandocPure Text
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m Text
writePlain WriterOptions
forall a. Default a => a
def