{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE NoImplicitPrelude #-}

-- |
--   Module     : Text.Compdoc
--   License    : MIT
--   Stability  : experimental
--
-- Provides functionality for transforming a `Pandoc` into a composite record.
module Text.Compdoc
  ( FContent,
    fContent,
    Compdoc (..),
    readMarkdown',
    readMarkdownFile,
    runPandocPureDefault,
    pandocToCompdoc,
    contentBlock,
    writeBlocksDefault,
    flattenMeta,
  )
where

import Composite.Aeson
import Composite.Aeson.Throw
import Composite.Record
import Composite.TH
import Data.Aeson
import Data.Vinyl ((<+>))
import Path
import RIO
import Text.Pandoc
import Text.Pandoc.Readers
import Text.Pandoc.Throw

withLensesAndProxies
  [d|
    type FContent = "content" :-> Text
    |]

-- | A Compdoc is a Record with at least an FContent field.
--
-- @since 0.3.0.0
newtype Compdoc a = Compdoc {Compdoc a -> Record (FContent : a)
unCompdoc :: Record (FContent ': a)}

-- | Write a list of `Block`s to `Text` using `WriterOptions` defaulting to the empty string
-- in the case of error.
--
-- @since 0.1.0.0
writeBlocksDefault :: WriterOptions -> [Block] -> Text
writeBlocksDefault :: WriterOptions -> [Block] -> Text
writeBlocksDefault WriterOptions
wopts [Block]
x = Text -> PandocPure Text -> Text
forall a. a -> PandocPure a -> a
runPandocPureDefault Text
"" (WriterOptions -> Pandoc -> PandocPure Text
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m Text
writeHtml5String WriterOptions
wopts (Pandoc -> PandocPure Text) -> Pandoc -> PandocPure Text
forall a b. (a -> b) -> a -> b
$ Meta -> [Block] -> Pandoc
Pandoc Meta
forall a. Monoid a => a
mempty [Block]
x)

-- | Run a `PandocPure` operation with a default value in the event of failure.
--
-- @since 0.1.0.0
runPandocPureDefault :: a -> PandocPure a -> a
runPandocPureDefault :: a -> PandocPure a -> a
runPandocPureDefault a
x = (PandocError -> a) -> (a -> a) -> Either PandocError a -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (a -> PandocError -> a
forall a b. a -> b -> a
const a
x) a -> a
forall a. a -> a
id (Either PandocError a -> a)
-> (PandocPure a -> Either PandocError a) -> PandocPure a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PandocPure a -> Either PandocError a
forall a. PandocPure a -> Either PandocError a
runPure

-- | Read a markdown file from disk, supplying a `JsonFormat` for the metadata.
--
-- @since 0.1.0.0
readMarkdownFile ::
  (MonadIO m, MonadThrow m, Show e, Typeable e) =>
  ReaderOptions ->
  WriterOptions ->
  JsonFormat e (Record a) ->
  Path b File ->
  m (Compdoc a)
readMarkdownFile :: ReaderOptions
-> WriterOptions
-> JsonFormat e (Record a)
-> Path b File
-> m (Compdoc a)
readMarkdownFile ReaderOptions
ropts WriterOptions
wopts JsonFormat e (Record a)
f Path b File
srcPath =
  FilePath -> m Text
forall (m :: * -> *). MonadIO m => FilePath -> m Text
readFileUtf8 (Path b File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path b File
srcPath) m Text -> (Text -> m (Compdoc a)) -> m (Compdoc a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ReaderOptions
-> WriterOptions
-> JsonFormat e (Record a)
-> Text
-> m (Compdoc a)
forall e (m :: * -> *) (a :: [*]).
(Show e, Typeable e, MonadThrow m) =>
ReaderOptions
-> WriterOptions
-> JsonFormat e (Record a)
-> Text
-> m (Compdoc a)
readMarkdown' ReaderOptions
ropts WriterOptions
wopts JsonFormat e (Record a)
f

-- | Read some `Pandoc` markdown as `Text` as a `Record (Compdoc a)` supplying a `JsonFormat` for the metadata.
--
-- @since 0.1.0.0
readMarkdown' :: (Show e, Typeable e, MonadThrow m) => ReaderOptions -> WriterOptions -> JsonFormat e (Record a) -> Text -> m (Compdoc a)
readMarkdown' :: ReaderOptions
-> WriterOptions
-> JsonFormat e (Record a)
-> Text
-> m (Compdoc a)
readMarkdown' ReaderOptions
ropts WriterOptions
wopts JsonFormat e (Record a)
f Text
x = PandocPure Pandoc -> m Pandoc
forall (m :: * -> *) a. MonadThrow m => PandocPure a -> m a
runPandocPureThrow (ReaderOptions -> Text -> PandocPure Pandoc
forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
Text.Pandoc.Readers.readMarkdown ReaderOptions
ropts Text
x) m Pandoc -> (Pandoc -> m (Compdoc a)) -> m (Compdoc a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (WriterOptions -> Pandoc -> PandocPure Text)
-> WriterOptions
-> JsonFormat e (Record a)
-> Pandoc
-> m (Compdoc a)
forall e (m :: * -> *) (a :: [*]).
(Typeable e, Show e, MonadThrow m) =>
(WriterOptions -> Pandoc -> PandocPure Text)
-> WriterOptions
-> JsonFormat e (Record a)
-> Pandoc
-> m (Compdoc a)
pandocToCompdoc WriterOptions -> Pandoc -> PandocPure Text
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m Text
writeHtml5String WriterOptions
wopts JsonFormat e (Record a)
f

-- | Transform a `Pandoc` to a `Compdoc` supplying a `JsonFormat for the metadata.
--
-- @since 0.1.0.0
pandocToCompdoc :: (Typeable e, Show e, MonadThrow m) => (WriterOptions -> Pandoc -> PandocPure Text) -> WriterOptions -> JsonFormat e (Record a) -> Pandoc -> m (Compdoc a)
pandocToCompdoc :: (WriterOptions -> Pandoc -> PandocPure Text)
-> WriterOptions
-> JsonFormat e (Record a)
-> Pandoc
-> m (Compdoc a)
pandocToCompdoc WriterOptions -> Pandoc -> PandocPure Text
writer WriterOptions
wopts JsonFormat e (Record a)
f (Pandoc Meta
meta [Block]
xs) = do
  Record a
k <- (Pandoc -> PandocPure Text) -> Meta -> m Value
forall (m :: * -> *).
MonadThrow m =>
(Pandoc -> PandocPure Text) -> Meta -> m Value
flattenMeta (WriterOptions -> Pandoc -> PandocPure Text
writer WriterOptions
wopts) Meta
meta m Value -> (Value -> m (Record a)) -> m (Record a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= JsonFormat e (Record a) -> Value -> m (Record a)
forall e (m :: * -> *) x.
(Typeable e, Show e, MonadThrow m) =>
JsonFormat e x -> Value -> m x
parseValue' JsonFormat e (Record a)
f
  Compdoc a -> m (Compdoc a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Compdoc a -> m (Compdoc a)) -> Compdoc a -> m (Compdoc a)
forall a b. (a -> b) -> a -> b
$ Record (FContent : a) -> Compdoc a
forall (a :: [*]). Record (FContent : a) -> Compdoc a
Compdoc (Record (FContent : a) -> Compdoc a)
-> Record (FContent : a) -> Compdoc a
forall a b. (a -> b) -> a -> b
$ WriterOptions -> [Block] -> Record '[FContent]
contentBlock WriterOptions
wopts [Block]
xs Record '[FContent] -> Record a -> Rec Identity ('[FContent] ++ a)
forall k (f :: k -> *) (as :: [k]) (bs :: [k]).
Rec f as -> Rec f bs -> Rec f (as ++ bs)
<+> Record a
k

-- | Create the tail of a `Compdoc` which is just an `FContent` field.
--
-- @since 0.1.0.0
contentBlock :: WriterOptions -> [Block] -> Record (FContent : '[])
contentBlock :: WriterOptions -> [Block] -> Record '[FContent]
contentBlock WriterOptions
wopts [Block]
x = WriterOptions -> [Block] -> Text
writeBlocksDefault WriterOptions
wopts [Block]
x Text -> Rec Identity '[] -> Record '[FContent]
forall a (rs :: [*]) (s :: Symbol).
a -> Rec Identity rs -> Rec Identity ((s :-> a) : rs)
:*: Rec Identity '[]
forall u (a :: u -> *). Rec a '[]
RNil

-- | Flatten pandoc metadata to an aeson value.
--
-- @since 0.1.0.0
flattenMeta :: MonadThrow m => (Pandoc -> PandocPure Text) -> Meta -> m Value
flattenMeta :: (Pandoc -> PandocPure Text) -> Meta -> m Value
flattenMeta Pandoc -> PandocPure Text
writer (Meta Map Text MetaValue
meta) = Map Text Value -> Value
forall a. ToJSON a => a -> Value
toJSON (Map Text Value -> Value) -> m (Map Text Value) -> m Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MetaValue -> m Value) -> Map Text MetaValue -> m (Map Text Value)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse MetaValue -> m Value
forall (m :: * -> *). MonadThrow m => MetaValue -> m Value
go Map Text MetaValue
meta
  where
    go :: MonadThrow m => MetaValue -> m Value
    go :: MetaValue -> m Value
go (MetaMap Map Text MetaValue
m) = Map Text Value -> Value
forall a. ToJSON a => a -> Value
toJSON (Map Text Value -> Value) -> m (Map Text Value) -> m Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MetaValue -> m Value) -> Map Text MetaValue -> m (Map Text Value)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse MetaValue -> m Value
forall (m :: * -> *). MonadThrow m => MetaValue -> m Value
go Map Text MetaValue
m
    go (MetaList [MetaValue]
m) = [Value] -> Value
forall a. ToJSON a => [a] -> Value
toJSONList ([Value] -> Value) -> m [Value] -> m Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MetaValue -> m Value) -> [MetaValue] -> m [Value]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse MetaValue -> m Value
forall (m :: * -> *). MonadThrow m => MetaValue -> m Value
go [MetaValue]
m
    go (MetaBool Bool
m) = Value -> m Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall a. ToJSON a => a -> Value
toJSON Bool
m
    go (MetaString Text
m) = Value -> m Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Text -> Value
forall a. ToJSON a => a -> Value
toJSON Text
m
    go (MetaInlines [Inline]
m) = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value) -> m Text -> m Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PandocPure Text -> m Text
forall (m :: * -> *) a. MonadThrow m => PandocPure a -> m a
runPandocPureThrow (PandocPure Text -> m Text)
-> ([Inline] -> PandocPure Text) -> [Inline] -> m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pandoc -> PandocPure Text
writer (Pandoc -> PandocPure Text)
-> ([Inline] -> Pandoc) -> [Inline] -> PandocPure Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Meta -> [Block] -> Pandoc
Pandoc Meta
forall a. Monoid a => a
mempty ([Block] -> Pandoc) -> ([Inline] -> [Block]) -> [Inline] -> Pandoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: []) (Block -> [Block]) -> ([Inline] -> Block) -> [Inline] -> [Block]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Inline] -> Block
Plain ([Inline] -> m Text) -> [Inline] -> m Text
forall a b. (a -> b) -> a -> b
$ [Inline]
m)
    go (MetaBlocks [Block]
m) = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value) -> m Text -> m Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PandocPure Text -> m Text
forall (m :: * -> *) a. MonadThrow m => PandocPure a -> m a
runPandocPureThrow (PandocPure Text -> m Text)
-> ([Block] -> PandocPure Text) -> [Block] -> m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pandoc -> PandocPure Text
writer (Pandoc -> PandocPure Text)
-> ([Block] -> Pandoc) -> [Block] -> PandocPure Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Meta -> [Block] -> Pandoc
Pandoc Meta
forall a. Monoid a => a
mempty ([Block] -> m Text) -> [Block] -> m Text
forall a b. (a -> b) -> a -> b
$ [Block]
m)