{- |
   Module     : Text.Compdoc
   License    : MIT
   Stability  : experimental

Provides functionality for transforming a `Pandoc` into a composite record.
-}
{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE TypeApplications  #-}
{-# LANGUAGE TypeOperators     #-}
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.
type Compdoc a = FContent ': a

-- | Write a list of `Block`s to `Text` using `WriterOptions` defaulting to the empty string
-- in the case of error.
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.
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.
readMarkdownFile :: (MonadIO m, MonadThrow m, Show e, Typeable e)
                 => ReaderOptions
                 -> WriterOptions
                 -> JsonFormat e (Record a)
                 -> Path b File
                 -> m (Record (Compdoc a))
readMarkdownFile :: ReaderOptions
-> WriterOptions
-> JsonFormat e (Record a)
-> Path b File
-> m (Record (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 (Record (Compdoc a))) -> m (Record (Compdoc a))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ReaderOptions
-> WriterOptions
-> JsonFormat e (Record a)
-> Text
-> m (Record (Compdoc a))
forall e (m :: * -> *) (a :: [*]).
(Show e, Typeable e, MonadThrow m) =>
ReaderOptions
-> WriterOptions
-> JsonFormat e (Record a)
-> Text
-> m (Record (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.
readMarkdown' :: (Show e, Typeable e, MonadThrow m) => ReaderOptions -> WriterOptions -> JsonFormat e (Record a) -> Text -> m (Record (Compdoc a))
readMarkdown' :: ReaderOptions
-> WriterOptions
-> JsonFormat e (Record a)
-> Text
-> m (Record (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 :: * -> *).
PandocMonad m =>
ReaderOptions -> Text -> m Pandoc
Text.Pandoc.Readers.readMarkdown ReaderOptions
ropts Text
x) m Pandoc
-> (Pandoc -> m (Record (Compdoc a))) -> m (Record (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 (Record (Compdoc a))
forall e (m :: * -> *) (a :: [*]).
(Typeable e, Show e, MonadThrow m) =>
(WriterOptions -> Pandoc -> PandocPure Text)
-> WriterOptions
-> JsonFormat e (Record a)
-> Pandoc
-> m (Record (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.
pandocToCompdoc :: (Typeable e, Show e, MonadThrow m) => (WriterOptions -> Pandoc -> PandocPure Text) -> WriterOptions -> JsonFormat e (Record a) -> Pandoc -> m (Record (Compdoc a))
pandocToCompdoc :: (WriterOptions -> Pandoc -> PandocPure Text)
-> WriterOptions
-> JsonFormat e (Record a)
-> Pandoc
-> m (Record (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
  Record (Compdoc a) -> m (Record (Compdoc a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Record (Compdoc a) -> m (Record (Compdoc a)))
-> Record (Compdoc a) -> m (Record (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.
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.
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)