{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE NoImplicitPrelude #-}
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
|]
newtype Compdoc a = Compdoc {Compdoc a -> Record (FContent : a)
unCompdoc :: Record (FContent ': a)}
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)
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
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
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
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
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
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)