-----------------------------------------------------------------------------
-- |
-- 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           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

-- | 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 b = []

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 <- 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"]
           (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