{-# LANGUAGE OverloadedStrings #-}
module Slick.Pandoc
( markdownToHTML
, markdownToHTML'
, markdownToHTMLWithOpts
, markdownToHTMLWithOpts'
, makePandocReader
, makePandocReader'
, makePandocReaderWithMetaWriter
, makePandocReaderWithMetaWriter'
, PandocReader
, PandocWriter
, loadUsing
, loadUsing'
, defaultMarkdownOptions
, 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
defaultMarkdownOptions :: ReaderOptions
defaultMarkdownOptions =
def { readerExtensions = exts }
where
exts = mconcat
[ extensionsFromList
[ Ext_yaml_metadata_block
, Ext_fenced_code_attributes
, Ext_auto_identifiers
]
, githubMarkdownExtensions
]
defaultHtml5Options :: WriterOptions
defaultHtml5Options =
def { writerHighlightStyle = Just tango
, writerExtensions = writerExtensions def
}
unPandocM :: PandocIO a -> Action a
unPandocM p = do
result <- liftIO $ runIO p
either (fail . show) return result
markdownToHTML :: T.Text
-> Action Value
markdownToHTML txt =
markdownToHTMLWithOpts defaultMarkdownOptions defaultHtml5Options txt
markdownToHTML' :: (FromJSON a)
=> T.Text
-> Action a
markdownToHTML' txt =
markdownToHTML txt >>= convert
markdownToHTMLWithOpts
:: ReaderOptions
-> WriterOptions
-> T.Text
-> Action Value
markdownToHTMLWithOpts rops wops txt =
loadUsing
(readMarkdown rops)
(writeHtml5String wops)
txt
markdownToHTMLWithOpts'
:: (FromJSON a)
=> ReaderOptions
-> WriterOptions
-> T.Text
-> Action a
markdownToHTMLWithOpts' rops wops txt =
markdownToHTMLWithOpts rops wops txt >>= convert
makePandocReader :: PandocReader textType
-> textType
-> Action (Pandoc, Value)
makePandocReader readerFunc text =
makePandocReaderWithMetaWriter readerFunc (writePlain def) text
makePandocReaderWithMetaWriter
:: PandocReader textType
-> PandocWriter
-> textType
-> Action (Pandoc, Value)
makePandocReaderWithMetaWriter readerFunc writerFunc text = do
pdoc@(Pandoc meta _) <- unPandocM $ readerFunc text
meta' <- flattenMeta writerFunc meta
return (pdoc, meta')
makePandocReader'
:: (FromJSON a)
=> PandocReader textType
-> textType
-> Action (Pandoc, a)
makePandocReader' readerFunc text =
makePandocReaderWithMetaWriter' readerFunc (writePlain def) text
makePandocReaderWithMetaWriter'
:: (FromJSON a)
=> PandocReader textType
-> PandocWriter
-> textType
-> Action (Pandoc, a)
makePandocReaderWithMetaWriter' readerFunc writerFunc text = do
(pdoc, meta) <- makePandocReaderWithMetaWriter readerFunc writerFunc text
convertedMeta <- convert meta
return (pdoc, convertedMeta)
loadUsing :: PandocReader textType
-> PandocWriter
-> textType
-> Action Value
loadUsing reader writer text = do
(pdoc, meta) <- makePandocReaderWithMetaWriter reader writer text
outText <- unPandocM $ writer pdoc
withContent <- case meta of
Object m -> return . Object $ HM.insert "content" (String outText) m
_ -> fail "Failed to parse metadata"
return withContent
loadUsing' :: (FromJSON a)
=> PandocReader textType
-> PandocWriter
-> textType
-> Action a
loadUsing' reader writer text =
loadUsing reader writer text >>= convert
flattenMeta :: PandocWriter -> Meta -> Action Value
flattenMeta writer (Meta meta) = toJSON <$> traverse go meta
where
go :: MetaValue -> Action Value
go (MetaMap m) = toJSON <$> traverse go m
go (MetaList m) = toJSONList <$> traverse go m
go (MetaBool m) = pure $ toJSON m
go (MetaString m) = pure $ toJSON m
go (MetaInlines m) = toJSON <$> (unPandocM . writer . Pandoc mempty . (:[]) . Plain $ m)
go (MetaBlocks m) = toJSON <$> (unPandocM . writer . Pandoc mempty $ m)