-----------------------------------------------------------------------------
-- |
-- Module : Text.BlogLiterately.Diagrams
-- Copyright : (c) Brent Yorgey 2012-2013
-- License : BSD-style (see LICENSE)
-- Maintainer : Brent Yorgey <byorgey@gmail.com>
--
-- Custom transformation passes for the @BlogLiterately@ blog-writing
-- tool (<http://hackage.haskell.org/package/BlogLiterately>),
-- allowing inclusion of inline code using the @diagrams@ framework
-- (<http://projects.haskell.org/diagrams>) which are compiled into
-- images. See "Text.BlogLiterately.Run" for more information.
--
-- Note that this package provides an executable, @BlogLiteratelyD@,
-- which compiles embedded diagrams code as well as all the standard
-- transforms provided by BlogLiterately.
-----------------------------------------------------------------------------
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
-- | Transform a blog post by looking for code blocks with class
-- @dia@, and replacing them with images generated by evaluating the
-- identifier @dia@ and rendering the resulting diagram. In
-- addition, blocks with class @dia-def@ are collected (and deleted
-- from the output) and provided as additional definitions that will
-- be in scope during evaluation of all @dia@ blocks.
--
-- Be sure to use this transform /before/ the standard
-- 'Text.BlogLiterately.Transform.highlightXF' transform, /i.e./
-- with the 'Text.BlogLiterately.Run.blogLiteratelyCustom' function.
-- For example,
--
-- > main = blogLiteratelyCustom (diagramsXF : standardTransforms)
--
-- It also works well in conjunction with
-- 'Text.BlogLiterately.Transform.centerImagesXF' (which, of course,
-- should be placed after @diagramsXF@ in the pipeline). This
-- package provides an executable @BlogLiteratelyD@ which
-- includes @diagramsInlineXF@, @diagramsXF@, and @centerImagesXF@.
diagramsXF :: Transform
diagramsXF = ioTransform renderBlockDiagrams (const True)
renderBlockDiagrams :: BlogLiterately -> Pandoc -> IO Pandoc
renderBlockDiagrams _ p = bottomUpM (renderBlockDiagram defs) p
where
defs = queryWith extractDiaDef p
-- | Transform a blog post by looking for /inline/ code snippets with
-- class @dia@, and replacing them with images generated by
-- evaluating the contents of each code snippet as a Haskell
-- expression representing a diagram. Any code blocks with class
-- @dia-def@ will be in scope for the evaluation of these
-- expressions (such code blocks are unaffected).
--
-- Because @diagramsXF@ and @diagramsInlineXF@ both use blocks with
-- class @dia-def@, but @diagramsInlineXF@ leaves them alone whereas
-- @diagramsXF@ deletes them, @diagramsInlineXF@ must be placed
-- before @diagramsXF@ in the pipeline.
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" -- XXX make this configurable
-- | Given some code with declarations, some attributes, and an
-- expression to render, render it and return the filename of the
-- generated image (or an error message).
renderDiagram :: [String] -- ^ Declarations
-> String -- ^ Expression to render
-> Attr -- ^ Code attributes
-> 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 ++ " -}")
-- the above hack is to make sure that changing
-- attributes results in the diagram being recompiled.
-- XXX can take this out once new diagrams-builder is released
[]
["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