{-# LANGUAGE TemplateHaskell #-}
module Shakebook.Pandoc (
runPandocA
, PandocActionException(..)
, readFilePandoc
, readCSVFile
, readLaTeXFile
, readMarkdownFile
, readMediaWikiFile
, loadMarkdownAsJSON
, makePDFLaTeX
, needPandocImagesIn
, flattenMeta
, prefixAllImages
, progressivelyDemoteHeaders
, replaceUnusableImages
, viewContent
, viewSrcPath
, viewUrl
) where
import Control.Comonad
import Control.Comonad.Cofree
import Data.Aeson
import Data.Aeson.Lens
import Data.Aeson.With
import Development.Shake.Plus
import Path.Extensions
import RIO
import qualified RIO.ByteString.Lazy as LBS
import qualified RIO.Text as T
import qualified Slick.Pandoc
import Text.Pandoc.Class
import Text.Pandoc.Definition
import Text.Pandoc.Options
import Text.Pandoc.PDF
import Text.Pandoc.Readers
import Text.Pandoc.Templates
import Text.Pandoc.Walk
import Text.Pandoc.Writers
newtype PandocActionException = PandocActionException String
deriving (Show, Eq, Typeable)
instance Exception PandocActionException where
displayException (PandocActionException s) = s
runPandocA :: (MonadAction m, MonadThrow m ) => PandocIO a -> m a
runPandocA p = do
result <- liftIO $ runIO p
either throwM return result
readFilePandoc :: (MonadAction m, MonadThrow m, FileLike b a) => (ReaderOptions -> Text -> PandocIO Pandoc) -> ReaderOptions -> a -> m Pandoc
readFilePandoc run ropts src = readFile' src >>= runPandocA . run ropts
readMarkdownFile :: (MonadAction m, MonadThrow m, FileLike b a) => ReaderOptions -> a -> m Pandoc
readMarkdownFile = readFilePandoc readMarkdown
readMediaWikiFile :: (MonadAction m, MonadThrow m, FileLike b a) => ReaderOptions -> a -> m Pandoc
readMediaWikiFile = readFilePandoc readMediaWiki
readLaTeXFile :: (MonadAction m, MonadThrow m, FileLike b a) => ReaderOptions -> a -> m Pandoc
readLaTeXFile = readFilePandoc readLaTeX
readCSVFile :: (MonadAction m, MonadThrow m, FileLike b a) => ReaderOptions -> a -> m Pandoc
readCSVFile = readFilePandoc readCSV
needPandocImagesIn :: (MonadAction m, MonadThrow m) => Path Rel Dir -> Pandoc -> m ()
needPandocImagesIn outDir pdoc =
mapM parseRelFile (drop 1 . T.unpack <$> pullImages pdoc) >>= needIn outDir where
pullImages = query f
f (Image _ _ (src, _)) = [src]
f _ = []
makePDFLaTeX :: (MonadAction m, MonadThrow m) => WriterOptions -> Pandoc -> m LBS.ByteString
makePDFLaTeX wopts p = do
f <- runPandocA $ do
t <- compileDefaultTemplate "latex"
makePDF "pdflatex" [] writeLaTeX wopts { writerTemplate = Just t } p
either (throwM . PandocActionException . show) return f
progressivelyDemoteHeaders :: Cofree [] Pandoc -> Cofree [] Pandoc
progressivelyDemoteHeaders = pushHeaders 0 where
handleHeaders :: Int -> Block -> Block
handleHeaders i (Header a as xs) = Header (max 1 (a + i)) as xs
handleHeaders _ x = x
pushHeaders :: Int -> Cofree [] Pandoc -> Cofree [] Pandoc
pushHeaders i (x :< xs) = walk (handleHeaders i) x :< map (pushHeaders (i+1)) xs
replaceUnusableImages :: MonadThrow m => [String] -> (Text -> Inline) -> Pandoc -> m Pandoc
replaceUnusableImages exts f = walkM handleImages where
handleImages i@(Image _ _ (src, _)) = do
x <- parseAbsFile (T.unpack src) >>= fileExtension
return $ if x `elem` exts then f src else i
handleImages x = return x
prefixAllImages :: Path Rel Dir -> Pandoc -> Pandoc
prefixAllImages dir = walk handleImages where
handleImages (Image attr ins (src, txt)) = Image attr ins (T.pack (toFilePath dir) <> "/" <> src, txt)
handleImages x = x
flattenMeta :: MonadAction m => (Pandoc -> PandocIO Text) -> Meta -> m Value
flattenMeta opts meta = liftAction $ Slick.Pandoc.flattenMeta opts meta
viewContent :: ToJSON a => a -> Text
viewContent = view' (key "content" . _String)
withContent :: Text -> Value -> Value
withContent = withStringField "content"
viewSrcPath :: ToJSON a => a -> Text
viewSrcPath = view' (key "src-path" . _String)
withSrcPath :: Text -> Value -> Value
withSrcPath = withStringField "src-path"
viewUrl :: ToJSON a => a -> Text
viewUrl = view' (key "url" . _String)
withUrl :: Text -> Value -> Value
withUrl = withStringField "url"
toGroundedUrl :: Path Rel File -> Text
toGroundedUrl = T.pack . toFilePath . ($(mkAbsDir "/") </>)
loadMarkdownAsJSON :: (MonadAction m, MonadThrow m)
=> ReaderOptions
-> WriterOptions
-> Within Rel (Path Rel File)
-> m Value
loadMarkdownAsJSON ropts wopts srcPath = do
pdoc@(Pandoc meta _) <- readMarkdownFile ropts srcPath
meta' <- flattenMeta (writeHtml5String wopts) meta
outText <- runPandocA $ writeHtml5String wopts pdoc
supposedUrl <- toGroundedUrl <$> withHtmlExtension (extract srcPath)
return $ withContent outText
. withSrcPath (T.pack . toFilePath $ extract srcPath)
. withUrl supposedUrl $ meta'