module Text.BlogLiterately.Diagrams
( diagramsXF, diagramsInlineXF
) where
import Safe (readMay)
import System.Directory (createDirectoryIfMissing)
import System.FilePath
import System.IO (hPutStrLn, stderr)
import Diagrams.Backend.Cairo
import Diagrams.Backend.Cairo.Internal
import qualified Diagrams.Builder as DB
import Diagrams.Prelude (R2, zeroV)
import Diagrams.TwoD.Size (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 _ = []
diaDir :: FilePath
diaDir = "diagrams"
renderDiagram :: [String]
-> String
-> Attr
-> IO (Either String FilePath)
renderDiagram decls expr attr@(_ident, _cls, fields) = do
createDirectoryIfMissing True diaDir
res <- DB.buildDiagram
Cairo
(zeroV :: R2)
(CairoOptions "default.png" size PNG False)
decls
(expr ++ " {- " ++ show attr ++ " -}")
[]
["Diagrams.Backend.Cairo"]
(DB.hashedRegenerate
(\hash opts -> opts { cairoFileName = mkFile hash })
diaDir
)
case res of
DB.ParseErr err -> do
let errStr = "\nParse error:\n" ++ err
putErrLn errStr
return (Left errStr)
DB.InterpErr ierr -> do
let errStr = "\nInterpreter error:\n" ++ DB.ppInterpError ierr
putErrLn errStr
return (Left errStr)
DB.Skipped hash -> return (Right $ mkFile hash)
DB.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` classTags = return Null
| "dia" `elem` classTags = do
res <- renderDiagram (src : defs) "pad 1.1 dia" attr
case res of
Left err -> return (CodeBlock attr (s ++ err))
Right fileName -> return $ Para [Image [] (fileName, "")]
| otherwise = return c
where
(tag, src) = unTag s
classTags = (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 fileName -> return $ Image [] (fileName, "")
| otherwise = return c
renderInlineDiagram _ i = return i
putErrLn :: String -> IO ()
putErrLn = hPutStrLn stderr