module Text.BlogLiterately.Diagrams
( diagramsXF, diagramsInlineXF
) where
import Control.Arrow
import Data.List (isPrefixOf)
import qualified Data.Map as M
import Safe (headDef, readMay)
import System.Directory (createDirectoryIfMissing)
import System.FilePath
import System.IO (hPutStrLn, stderr)
import Diagrams.Backend.Cairo
import Diagrams.Backend.Cairo.Internal
import Diagrams.Builder
import Diagrams.Prelude (R2, zeroV)
import Diagrams.TwoD.Size (SizeSpec2D (Dims), mkSizeSpec)
import Text.BlogLiterately
import Text.Pandoc
diagramsXF :: Transform
diagramsXF = ioTransform renderBlockDiagrams (const True)
renderBlockDiagrams :: BlogLiterately -> Pandoc -> IO Pandoc
renderBlockDiagrams _ p = bottomUpM (renderBlockDiagram defs) p
where
defs = queryWith extractDiaDef p
diagramsInlineXF :: Transform
diagramsInlineXF = ioTransform renderInlineDiagrams (const True)
renderInlineDiagrams :: BlogLiterately -> Pandoc -> IO Pandoc
renderInlineDiagrams _ p = bottomUpM (renderInlineDiagram defs) p
where
defs = queryWith extractDiaDef p
extractDiaDef :: Block -> [String]
extractDiaDef (CodeBlock (_, as, _) s)
= [src | "dia-def" `elem` (maybe id (:) tag) as]
where
(tag, src) = unTag s
extractDiaDef b = []
diaDir = "diagrams"
renderDiagram :: [String]
-> String
-> Attr
-> IO (Either String FilePath)
renderDiagram decls expr attr@(ident, cls, fields) = do
createDirectoryIfMissing True diaDir
res <- buildDiagram
Cairo
(zeroV :: R2)
(CairoOptions "default.png" size PNG False)
decls
(expr ++ " {- " ++ show attr ++ " -}")
[]
["Diagrams.Backend.Cairo"]
(hashedRegenerate
(\hash opts -> opts { cairoFileName = mkFile hash })
diaDir
)
case res of
ParseErr err -> do
let errStr = "\nParse error:\n" ++ err
putErrLn errStr
return (Left errStr)
InterpErr ierr -> do
let errStr = "\nInterpreter error:\n" ++ ppInterpError ierr
putErrLn errStr
return (Left errStr)
Skipped hash -> return (Right $ mkFile hash)
OK hash (act,_) -> act >> return (Right $ mkFile hash)
where
size = mkSizeSpec
(lookup "width" fields >>= readMay)
(lookup "height" fields >>= readMay)
mkFile base = diaDir </> base <.> "png"
renderBlockDiagram :: [String] -> Block -> IO Block
renderBlockDiagram defs c@(CodeBlock attr@(_, cls, _) s)
| "dia-def" `elem` tags = return Null
| "dia" `elem` tags = do
res <- renderDiagram (src : defs) "pad 1.1 dia" attr
case res of
Left err -> return (CodeBlock attr (s ++ err))
Right file -> return $ Para [Image [] (file, "")]
| otherwise = return c
where
(tag, src) = unTag s
tags = (maybe id (:) tag) cls
renderBlockDiagram _ b = return b
renderInlineDiagram :: [String] -> Inline -> IO Inline
renderInlineDiagram defs c@(Code attr@(_, cls, _) expr)
| "dia" `elem` cls = do
res <- renderDiagram defs expr attr
case res of
Left err -> return (Code attr (expr ++ err))
Right file -> return $ Image [] (file, "")
| otherwise = return c
renderInlineDiagram _ i = return i
putErrLn :: String -> IO ()
putErrLn = hPutStrLn stderr