{-|
Module      : Slick.Pandoc
Description : Slick utilities for working with Pandoc
Copyright   : (c) Chris Penner, 2019
License     : BSD3
-}
{-# LANGUAGE OverloadedStrings #-}

module Slick.Pandoc
  ( markdownToHTML
  , markdownToHTML'
  , markdownToHTMLWithOpts
  , markdownToHTMLWithOpts' 
  , orgModeToHTML
  , orgModeToHTML'
  , orgModeToHTMLWithOpts
  , orgModeToHTMLWithOpts'
  , makePandocReader
  , makePandocReader'
  , makePandocReaderWithMetaWriter
  , makePandocReaderWithMetaWriter'
  , PandocReader
  , PandocWriter
  , loadUsing
  , loadUsing'
  , loadUsingMeta
  , defaultMarkdownOptions
  , defaultOrgModeOptions
  , defaultHtml5Options
  , convert
  , flattenMeta
  ) where

import Data.Aeson
import Development.Shake
import Text.Pandoc
import Text.Pandoc.Highlighting
import Slick.Utils
import Data.HashMap.Strict as HM

import qualified Data.Text                  as T

--------------------------------------------------------------------------------

type PandocReader textType = textType -> PandocIO Pandoc
type PandocWriter = Pandoc -> PandocIO T.Text

-- | Reasonable options for reading a markdown file. Behaves similar to Github Flavoured
-- Markdown
defaultMarkdownOptions :: ReaderOptions
defaultMarkdownOptions :: ReaderOptions
defaultMarkdownOptions =
  ReaderOptions
forall a. Default a => a
def { readerExtensions :: Extensions
readerExtensions = Extensions
exts }
  where
    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
       ]
     , Extensions
githubMarkdownExtensions
     ]

-- | Reasonable options for rendering to HTML. Includes default code highlighting rules
defaultHtml5Options :: WriterOptions
defaultHtml5Options :: WriterOptions
defaultHtml5Options =
  WriterOptions
forall a. Default a => a
def { writerHighlightStyle :: Maybe Style
writerHighlightStyle = Style -> Maybe Style
forall a. a -> Maybe a
Just Style
tango
      , writerExtensions :: Extensions
writerExtensions     = WriterOptions -> Extensions
writerExtensions WriterOptions
forall a. Default a => a
def
      }

-- | Reasonable options for reading an org-mode file
defaultOrgModeOptions :: ReaderOptions
defaultOrgModeOptions :: ReaderOptions
defaultOrgModeOptions =
  ReaderOptions
forall a. Default a => a
def { readerExtensions :: Extensions
readerExtensions = Extensions
exts }
  where
    exts :: Extensions
exts = [Extensions] -> Extensions
forall a. Monoid a => [a] -> a
mconcat
     [ [Extension] -> Extensions
extensionsFromList
       [ Extension
Ext_fenced_code_attributes
       , Extension
Ext_auto_identifiers
       ]
     ]
--------------------------------------------------------------------------------

-- | Handle possible pandoc failure within the Action Monad
unPandocM :: PandocIO a -> Action a
unPandocM :: PandocIO a -> Action a
unPandocM PandocIO a
p = do
  Either PandocError a
result <- IO (Either PandocError a) -> Action (Either PandocError a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either PandocError a) -> Action (Either PandocError a))
-> IO (Either PandocError a) -> Action (Either PandocError a)
forall a b. (a -> b) -> a -> b
$ PandocIO a -> IO (Either PandocError a)
forall a. PandocIO a -> IO (Either PandocError a)
runIO PandocIO a
p
  (PandocError -> Action a)
-> (a -> Action a) -> Either PandocError a -> Action a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Action a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Action a)
-> (PandocError -> String) -> PandocError -> Action a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PandocError -> String
forall a. Show a => a -> String
show) a -> Action a
forall (m :: * -> *) a. Monad m => a -> m a
return Either PandocError a
result

-- | Convert markdown text into a 'Value';
--
--   The 'Value'  has a "content" key containing rendered HTML.
--
--   Metadata is assigned on the respective keys in the 'Value'
markdownToHTML :: T.Text
               -> Action Value
markdownToHTML :: Text -> Action Value
markdownToHTML Text
txt =
    ReaderOptions -> WriterOptions -> Text -> Action Value
markdownToHTMLWithOpts ReaderOptions
defaultMarkdownOptions WriterOptions
defaultHtml5Options Text
txt

-- | Like 'markdownToHTML' but allows returning any JSON serializable object
markdownToHTML' :: (FromJSON a)
                => T.Text
                -> Action a
markdownToHTML' :: Text -> Action a
markdownToHTML' Text
txt =
    Text -> Action Value
markdownToHTML Text
txt Action Value -> (Value -> Action a) -> Action a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Action a
forall a b. (FromJSON a, ToJSON a, FromJSON b) => a -> Action b
convert

-- | Like 'markdownToHTML' but allows providing additional pandoc reader and writer options
markdownToHTMLWithOpts
    :: ReaderOptions  -- ^ Pandoc reader options to specify extensions or other functionality
    -> WriterOptions  -- ^ Pandoc writer options to modify output
    -> T.Text         -- ^ Text for conversion
    -> Action Value
markdownToHTMLWithOpts :: ReaderOptions -> WriterOptions -> Text -> Action Value
markdownToHTMLWithOpts ReaderOptions
rops WriterOptions
wops Text
txt =
  PandocReader Text -> PandocWriter -> Text -> Action Value
forall textType.
PandocReader textType -> PandocWriter -> textType -> Action Value
loadUsing
    (ReaderOptions -> PandocReader Text
forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
readMarkdown ReaderOptions
rops)
    (WriterOptions -> PandocWriter
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m Text
writeHtml5String WriterOptions
wops)
    Text
txt

-- | Like 'markdownToHTMLWithOpts' but returns any JSON serializable object.
markdownToHTMLWithOpts'
    :: (FromJSON a)
    => ReaderOptions  -- ^ Pandoc reader options to specify extensions or other functionality
    -> WriterOptions  -- ^ Pandoc writer options to modify output
    -> T.Text         -- ^ Text for conversion
    -> Action a
markdownToHTMLWithOpts' :: ReaderOptions -> WriterOptions -> Text -> Action a
markdownToHTMLWithOpts' ReaderOptions
rops WriterOptions
wops Text
txt =
    ReaderOptions -> WriterOptions -> Text -> Action Value
markdownToHTMLWithOpts ReaderOptions
rops WriterOptions
wops Text
txt Action Value -> (Value -> Action a) -> Action a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Action a
forall a b. (FromJSON a, ToJSON a, FromJSON b) => a -> Action b
convert

-- | Convert org-mode text into a 'Value';
--
--   The 'Value'  has a "content" key containing rendered HTML.
--
--   Metadata is assigned on the respective keys in the 'Value'
orgModeToHTML :: T.Text
               -> Action Value
orgModeToHTML :: Text -> Action Value
orgModeToHTML Text
txt =
    ReaderOptions -> WriterOptions -> Text -> Action Value
orgModeToHTMLWithOpts ReaderOptions
defaultOrgModeOptions WriterOptions
defaultHtml5Options Text
txt

-- | Like 'orgModeToHTML' but allows returning any JSON compatible object.
orgModeToHTML' :: (FromJSON a)
               => T.Text
               -> Action a
orgModeToHTML' :: Text -> Action a
orgModeToHTML' Text
txt =
    Text -> Action Value
orgModeToHTML Text
txt Action Value -> (Value -> Action a) -> Action a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Action a
forall a b. (FromJSON a, ToJSON a, FromJSON b) => a -> Action b
convert

-- | Like 'orgModeToHTML' but allows providing additional pandoc reader and writer options
orgModeToHTMLWithOpts
    :: ReaderOptions  -- ^ Pandoc reader options to specify extensions or other functionality
    -> WriterOptions  -- ^ Pandoc writer options to modify output
    -> T.Text         -- ^ Text for conversion
    -> Action Value
orgModeToHTMLWithOpts :: ReaderOptions -> WriterOptions -> Text -> Action Value
orgModeToHTMLWithOpts ReaderOptions
rops WriterOptions
wops Text
txt =
  PandocReader Text -> PandocWriter -> Text -> Action Value
forall textType.
PandocReader textType -> PandocWriter -> textType -> Action Value
loadUsing
    (ReaderOptions -> PandocReader Text
forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
readOrg ReaderOptions
rops)
    (WriterOptions -> PandocWriter
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m Text
writeHtml5String WriterOptions
wops)
    Text
txt

-- | Like 'orgModeToHTMLWithOpts' but allows returning any JSON compatible object
orgModeToHTMLWithOpts'
    :: (FromJSON a)
    => ReaderOptions  -- ^ Pandoc reader options to specify extensions or other functionality
    -> WriterOptions  -- ^ Pandoc writer options to modify output
    -> T.Text         -- ^ Text for conversion
    -> Action a
orgModeToHTMLWithOpts' :: ReaderOptions -> WriterOptions -> Text -> Action a
orgModeToHTMLWithOpts' ReaderOptions
rops WriterOptions
wops Text
txt =
    ReaderOptions -> WriterOptions -> Text -> Action Value
orgModeToHTMLWithOpts ReaderOptions
rops WriterOptions
wops Text
txt Action Value -> (Value -> Action a) -> Action a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Action a
forall a b. (FromJSON a, ToJSON a, FromJSON b) => a -> Action b
convert

-- | Given a reader from 'Text.Pandoc.Readers' this creates a loader which
--   given the source document will read its metadata into a 'Value'
--   returning both the 'Pandoc' object and the metadata within an 'Action'.
--   The metadata values will be read as Markdown but rendered as plain text,
--   removing any links, pictures, and inline formatting.
makePandocReader :: PandocReader textType
                 -> textType
                 -> Action (Pandoc, Value)
makePandocReader :: PandocReader textType -> textType -> Action (Pandoc, Value)
makePandocReader PandocReader textType
readerFunc textType
text =
  PandocReader textType
-> PandocWriter -> textType -> Action (Pandoc, Value)
forall textType.
PandocReader textType
-> PandocWriter -> textType -> Action (Pandoc, Value)
makePandocReaderWithMetaWriter PandocReader textType
readerFunc (WriterOptions -> PandocWriter
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m Text
writePlain WriterOptions
forall a. Default a => a
def) textType
text

-- | Given a reader from 'Text.Pandoc.Readers', and a writer from
--   'Text.Pandoc.Writers', this creates a loader which given the source
--   document will read its metadata as Markdown, then render it into a
--   'Value' using the writer, returning both the 'Pandoc' object and the
--   metadata within an 'Action'
makePandocReaderWithMetaWriter
    :: PandocReader textType
    -> PandocWriter
    -> textType
    -> Action (Pandoc, Value)
makePandocReaderWithMetaWriter :: PandocReader textType
-> PandocWriter -> textType -> Action (Pandoc, Value)
makePandocReaderWithMetaWriter PandocReader textType
readerFunc PandocWriter
writerFunc textType
text = do
  pdoc :: Pandoc
pdoc@(Pandoc Meta
meta [Block]
_) <- PandocIO Pandoc -> Action Pandoc
forall a. PandocIO a -> Action a
unPandocM (PandocIO Pandoc -> Action Pandoc)
-> PandocIO Pandoc -> Action Pandoc
forall a b. (a -> b) -> a -> b
$ PandocReader textType
readerFunc textType
text
  Value
meta' <- PandocWriter -> Meta -> Action Value
flattenMeta PandocWriter
writerFunc Meta
meta
  (Pandoc, Value) -> Action (Pandoc, Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pandoc
pdoc, Value
meta')

-- | Like 'makePandocReader' but will deserialize the metadata
--   into any object which implements 'FromJSON'. Failure to deserialize will
--   fail the Shake build. Metadata values will be read as Markdown but
--   rendered as plain text, removing any links, pictures, and inline
--   formatting.
makePandocReader'
    :: (FromJSON a)
    => PandocReader textType
    -> textType
    -> Action (Pandoc, a)
makePandocReader' :: PandocReader textType -> textType -> Action (Pandoc, a)
makePandocReader' PandocReader textType
readerFunc textType
text =
  PandocReader textType
-> PandocWriter -> textType -> Action (Pandoc, a)
forall a textType.
FromJSON a =>
PandocReader textType
-> PandocWriter -> textType -> Action (Pandoc, a)
makePandocReaderWithMetaWriter' PandocReader textType
readerFunc (WriterOptions -> PandocWriter
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m Text
writePlain WriterOptions
forall a. Default a => a
def) textType
text

-- | Like 'makePandocReaderWithMetaWriter' but will deserialize the metadata
--   into any object which implements 'FromJSON'. Failure to deserialize will
--   fail the Shake build.
makePandocReaderWithMetaWriter'
    :: (FromJSON a)
    => PandocReader textType
    -> PandocWriter
    -> textType
    -> Action (Pandoc, a)
makePandocReaderWithMetaWriter' :: PandocReader textType
-> PandocWriter -> textType -> Action (Pandoc, a)
makePandocReaderWithMetaWriter' PandocReader textType
readerFunc PandocWriter
writerFunc textType
text = do
  (Pandoc
pdoc, Value
meta)  <- PandocReader textType
-> PandocWriter -> textType -> Action (Pandoc, Value)
forall textType.
PandocReader textType
-> PandocWriter -> textType -> Action (Pandoc, Value)
makePandocReaderWithMetaWriter PandocReader textType
readerFunc PandocWriter
writerFunc textType
text
  a
convertedMeta <- Value -> Action a
forall a b. (FromJSON a, ToJSON a, FromJSON b) => a -> Action b
convert Value
meta
  (Pandoc, a) -> Action (Pandoc, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pandoc
pdoc, a
convertedMeta)

--------------------------------------------------------------------------------

-- | Load in a source document using the given 'PandocReader', then render the 'Pandoc'
--   into text using the given 'PandocWriter'. Takes a second 'PandocWriter' to render
--   metadata.
--   Returns a 'Value' wherein the rendered text is set to the "content" key and
--   any metadata is set to its respective key in the 'Value'
loadUsingMeta :: PandocReader textType -- ^ The reader used to load the document
          -> PandocWriter -- ^ The writer used to render the document itself
          -> PandocWriter -- ^ The writer used to process metadata.
          -> textType
          -> Action Value
loadUsingMeta :: PandocReader textType
-> PandocWriter -> PandocWriter -> textType -> Action Value
loadUsingMeta PandocReader textType
reader PandocWriter
writer PandocWriter
metaWriter textType
text = do
  (Pandoc
pdoc, Value
meta) <- PandocReader textType
-> PandocWriter -> textType -> Action (Pandoc, Value)
forall textType.
PandocReader textType
-> PandocWriter -> textType -> Action (Pandoc, Value)
makePandocReaderWithMetaWriter PandocReader textType
reader PandocWriter
metaWriter textType
text
  Text
outText      <- PandocIO Text -> Action Text
forall a. PandocIO a -> Action a
unPandocM (PandocIO Text -> Action Text) -> PandocIO Text -> Action Text
forall a b. (a -> b) -> a -> b
$ PandocWriter
writer Pandoc
pdoc
  Value
withContent <- case Value
meta of
      Object Object
m -> Value -> Action Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Action Value)
-> (Object -> Value) -> Object -> Action Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Value
Object (Object -> Action Value) -> Object -> Action Value
forall a b. (a -> b) -> a -> b
$ Text -> Value -> Object -> Object
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
"content" (Text -> Value
String Text
outText) Object
m
          -- meta & _Object . at "content" ?~ String outText
      Value
_ -> String -> Action Value
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Failed to parse metadata"
  Value -> Action Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
withContent

-- | Load in a source document using the given 'PandocReader', then render the 'Pandoc'
--   into text using the given 'PandocWriter'.
--   Returns a 'Value' wherein the rendered text is set to the "content" key and
--   any metadata is set to its respective key in the 'Value'
loadUsing :: PandocReader textType
          -> PandocWriter
          -> textType
          -> Action Value
loadUsing :: PandocReader textType -> PandocWriter -> textType -> Action Value
loadUsing PandocReader textType
reader PandocWriter
writer textType
text = PandocReader textType
-> PandocWriter -> PandocWriter -> textType -> Action Value
forall textType.
PandocReader textType
-> PandocWriter -> PandocWriter -> textType -> Action Value
loadUsingMeta PandocReader textType
reader PandocWriter
writer PandocWriter
writer textType
text

-- | Like 'loadUsing' but allows also deserializes the 'Value' into any object
--   which implements 'FromJSON'.  Failure to deserialize will fail the Shake
--   build.
loadUsing' :: (FromJSON a)
           => PandocReader textType
           -> PandocWriter
           -> textType
           -> Action a
loadUsing' :: PandocReader textType -> PandocWriter -> textType -> Action a
loadUsing' PandocReader textType
reader PandocWriter
writer textType
text =
  PandocReader textType -> PandocWriter -> textType -> Action Value
forall textType.
PandocReader textType -> PandocWriter -> textType -> Action Value
loadUsing PandocReader textType
reader PandocWriter
writer textType
text Action Value -> (Value -> Action a) -> Action a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Action a
forall a b. (FromJSON a, ToJSON a, FromJSON b) => a -> Action b
convert

--------------------------------------------------------------------------------

-- | Flatten a Pandoc 'Meta' into a well-structured JSON object, rendering Pandoc
--   text objects into plain strings along the way.
flattenMeta :: PandocWriter -> Meta -> Action Value
flattenMeta :: PandocWriter -> Meta -> Action Value
flattenMeta PandocWriter
writer (Meta Map Text MetaValue
meta) = Map Text Value -> Value
forall a. ToJSON a => a -> Value
toJSON (Map Text Value -> Value)
-> Action (Map Text Value) -> Action Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MetaValue -> Action Value)
-> Map Text MetaValue -> Action (Map Text Value)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse MetaValue -> Action Value
go Map Text MetaValue
meta
 where
  go :: MetaValue -> Action Value
  go :: MetaValue -> Action Value
go (MetaMap     Map Text MetaValue
m) = Map Text Value -> Value
forall a. ToJSON a => a -> Value
toJSON (Map Text Value -> Value)
-> Action (Map Text Value) -> Action Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MetaValue -> Action Value)
-> Map Text MetaValue -> Action (Map Text Value)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse MetaValue -> Action Value
go Map Text MetaValue
m
  go (MetaList    [MetaValue]
m) = [Value] -> Value
forall a. ToJSON a => [a] -> Value
toJSONList ([Value] -> Value) -> Action [Value] -> Action Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MetaValue -> Action Value) -> [MetaValue] -> Action [Value]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse MetaValue -> Action Value
go [MetaValue]
m
  go (MetaBool    Bool
m) = Value -> Action Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Action Value) -> Value -> Action Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall a. ToJSON a => a -> Value
toJSON Bool
m
  go (MetaString  Text
m) = Value -> Action Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Action Value) -> Value -> Action 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) -> Action Text -> Action Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PandocIO Text -> Action Text
forall a. PandocIO a -> Action a
unPandocM (PandocIO Text -> Action Text)
-> ([Inline] -> PandocIO Text) -> [Inline] -> Action Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PandocWriter
writer PandocWriter -> ([Inline] -> Pandoc) -> [Inline] -> PandocIO 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] -> Action Text) -> [Inline] -> Action 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) -> Action Text -> Action Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PandocIO Text -> Action Text
forall a. PandocIO a -> Action a
unPandocM (PandocIO Text -> Action Text)
-> ([Block] -> PandocIO Text) -> [Block] -> Action Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PandocWriter
writer PandocWriter -> ([Block] -> Pandoc) -> [Block] -> PandocIO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Meta -> [Block] -> Pandoc
Pandoc Meta
forall a. Monoid a => a
mempty ([Block] -> Action Text) -> [Block] -> Action Text
forall a b. (a -> b) -> a -> b
$ [Block]
m)