{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications  #-}

-----------------------------------------------------------------------------
-- |
-- 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 qualified Codec.Picture               as J
import           Data.List                   (find, isPrefixOf)
import           Data.List.Split             (splitOn)
import           Data.Maybe                  (fromMaybe)
import           Data.Text                   (Text)
import qualified Data.Text                   as T
import qualified Data.Text.IO                as T

import           Diagrams.Backend.Rasterific
import qualified Diagrams.Builder            as DB
import           Diagrams.Prelude            (SizeSpec, V2, centerXY, pad, zero,
                                              (&), (.~))
import           Diagrams.TwoD.Size          (mkSizeSpec2D)
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 :: Transform
diagramsXF = (BlogLiterately -> Pandoc -> IO Pandoc)
-> (BlogLiterately -> Bool) -> Transform
ioTransform BlogLiterately -> Pandoc -> IO Pandoc
renderBlockDiagrams (forall a b. a -> b -> a
const Bool
True)

renderBlockDiagrams :: BlogLiterately -> Pandoc -> IO Pandoc
renderBlockDiagrams :: BlogLiterately -> Pandoc -> IO Pandoc
renderBlockDiagrams BlogLiterately
blOpts Pandoc
p = forall (m :: * -> *) a b.
(Monad m, Data a, Data b) =>
(a -> m a) -> b -> m b
bottomUpM (Maybe [Char]
-> Maybe (SizeSpec V2 Double) -> [Text] -> [Block] -> IO [Block]
renderBlockDiagram Maybe [Char]
imgDir Maybe (SizeSpec V2 Double)
imgSize [Text]
defs) Pandoc
p
  where
    defs :: [Text]
defs = forall a b c. (Data a, Monoid b, Data c) => (a -> b) -> c -> b
queryWith Block -> [Text]
extractDiaDef Pandoc
p

    imgDir  :: Maybe FilePath
    imgDir :: Maybe [Char]
imgDir = [Char] -> Maybe [Char]
field [Char]
"imgdir"
    imgSize :: Maybe (SizeSpec V2 Double)
    imgSize :: Maybe (SizeSpec V2 Double)
imgSize = [Char] -> Maybe [Char]
field [Char]
"imgsize" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[Char]
s ->
      case forall a. Eq a => [a] -> [a] -> [[a]]
splitOn [Char]
"x" [Char]
s of
        [[Char]
w,[Char]
h] -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall n. Num n => Maybe n -> Maybe n -> SizeSpec V2 n
mkSizeSpec2D (forall a. Read a => [Char] -> Maybe a
readMay [Char]
w) (forall a. Read a => [Char] -> Maybe a
readMay [Char]
h)
        [[Char]]
_     -> forall a. Maybe a
Nothing

    field :: [Char] -> Maybe [Char]
field [Char]
f = forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
f forall a. Num a => a -> a -> a
+ Int
1) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (([Char]
fforall a. [a] -> [a] -> [a]
++[Char]
":") forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) (BlogLiterately -> [[Char]]
_xtra BlogLiterately
blOpts)

-- | 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 :: Transform
diagramsInlineXF = (BlogLiterately -> Pandoc -> IO Pandoc)
-> (BlogLiterately -> Bool) -> Transform
ioTransform BlogLiterately -> Pandoc -> IO Pandoc
renderInlineDiagrams (forall a b. a -> b -> a
const Bool
True)

renderInlineDiagrams :: BlogLiterately -> Pandoc -> IO Pandoc
renderInlineDiagrams :: BlogLiterately -> Pandoc -> IO Pandoc
renderInlineDiagrams BlogLiterately
_ Pandoc
p = forall (m :: * -> *) a b.
(Monad m, Data a, Data b) =>
(a -> m a) -> b -> m b
bottomUpM ([Text] -> Inline -> IO Inline
renderInlineDiagram [Text]
defs) Pandoc
p
  where
    defs :: [Text]
defs = forall a b c. (Data a, Monoid b, Data c) => (a -> b) -> c -> b
queryWith Block -> [Text]
extractDiaDef Pandoc
p

extractDiaDef :: Block -> [Text]
extractDiaDef :: Block -> [Text]
extractDiaDef (CodeBlock (Text
_, [Text]
as, [(Text, Text)]
_) Text
s)
    = [Text
src | Text
"dia-def" forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (:) Maybe Text
tag) [Text]
as]
  where
    (Maybe Text
tag, Text
src) = Text -> (Maybe Text, Text)
unTag Text
s

extractDiaDef Block
_ = []

-- | 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 :: Bool               -- ^ Apply padding automatically?
              -> [Text]             -- ^ Declarations
              -> Text               -- ^ Expression to render
              -> SizeSpec V2 Double -- ^ Requested size
              -> Maybe FilePath     -- ^ Directory to save in ("diagrams" if unspecified)
              -> IO (Either Text FilePath)
renderDiagram :: Bool
-> [Text]
-> Text
-> SizeSpec V2 Double
-> Maybe [Char]
-> IO (Either Text [Char])
renderDiagram Bool
shouldPad [Text]
decls Text
expr SizeSpec V2 Double
sz Maybe [Char]
mdir = do
    Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True [Char]
diaDir

    let bopts :: BuildOpts Rasterific V2 Double
bopts = forall b (v :: * -> *) n.
b -> v n -> Options b v n -> BuildOpts b v n
DB.mkBuildOpts Rasterific
Rasterific forall (f :: * -> *) a. (Additive f, Num a) => f a
zero (forall n. SizeSpec V2 n -> Options Rasterific V2 n
RasterificOptions SizeSpec V2 Double
sz)
                  forall a b. a -> (a -> b) -> b
& forall b (v :: * -> *) n. Lens' (BuildOpts b v n) [[Char]]
DB.snippets forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a b. (a -> b) -> [a] -> [b]
map Text -> [Char]
T.unpack [Text]
decls
                  forall a b. a -> (a -> b) -> b
& forall b (v :: * -> *) n. Lens' (BuildOpts b v n) [[Char]]
DB.imports  forall s t a b. ASetter s t a b -> b -> s -> t
.~ [[Char]
"Diagrams.Backend.Rasterific"]
                  forall a b. a -> (a -> b) -> b
& forall b (v :: * -> *) n. Lens' (BuildOpts b v n) [Char]
DB.diaExpr  forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text -> [Char]
T.unpack Text
expr
                  forall a b. a -> (a -> b) -> b
& forall b (v :: * -> *) n.
Lens' (BuildOpts b v n) (QDiagram b v n Any -> QDiagram b v n Any)
DB.postProcess forall s t a b. ASetter s t a b -> b -> s -> t
.~ (if Bool
shouldPad then forall (v :: * -> *) n m b.
(Metric v, OrderedField n, Monoid' m) =>
n -> QDiagram b v n m -> QDiagram b v n m
pad Double
1.1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) n a.
(InSpace v n a, R2 v, Fractional n, Alignable a, HasOrigin a) =>
a -> a
centerXY else forall a. a -> a
id)
                  forall a b. a -> (a -> b) -> b
& forall b (v :: * -> *) n.
Lens'
  (BuildOpts b v n)
  (Int -> IO (Maybe (Options b v n -> Options b v n)))
DB.decideRegen forall s t a b. ASetter s t a b -> b -> s -> t
.~
                      (forall a.
([Char] -> a -> a) -> [Char] -> Int -> IO (Maybe (a -> a))
DB.hashedRegenerate
                        (\[Char]
_ Options Rasterific V2 Double
opts -> Options Rasterific V2 Double
opts)
                        [Char]
diaDir
                      )

    BuildResult Rasterific V2 Double
res <- forall b (v :: * -> *) n.
(Typeable b, Data (v n), Data n, Metric v, HasLinearMap v,
 Typeable v, OrderedField n, Backend b v n,
 Hashable (Options b v n)) =>
BuildOpts b v n -> IO (BuildResult b v n)
DB.buildDiagram BuildOpts Rasterific V2 Double
bopts

    case BuildResult Rasterific V2 Double
res of
      DB.ParseErr [Char]
err    -> do
        let errStr :: Text
errStr = Text -> Text -> Text
T.append Text
"\nParse error:\n" ([Char] -> Text
T.pack [Char]
err)
        Text -> IO ()
putErrLn Text
errStr
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left Text
errStr)
      DB.InterpErr InterpreterError
ierr  -> do
        let errStr :: Text
errStr = Text -> Text -> Text
T.append Text
"\nInterpreter error:\n" ([Char] -> Text
T.pack (InterpreterError -> [Char]
DB.ppInterpError InterpreterError
ierr))
        Text -> IO ()
putErrLn Text
errStr
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left Text
errStr)
      DB.Skipped Int
hash    -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
mkFile (Int -> [Char]
DB.hashToHexStr Int
hash))
      DB.OK Int
hash Result Rasterific V2 Double
img     -> do
        let imgFile :: [Char]
imgFile = [Char] -> [Char]
mkFile (Int -> [Char]
DB.hashToHexStr Int
hash)
        [Char] -> DynamicImage -> IO ()
J.savePngImage [Char]
imgFile (Image PixelRGBA8 -> DynamicImage
J.ImageRGBA8 Result Rasterific V2 Double
img)
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right [Char]
imgFile)

  where
    diaDir :: [Char]
diaDir = forall a. a -> Maybe a -> a
fromMaybe [Char]
"diagrams" Maybe [Char]
mdir
    mkFile :: [Char] -> [Char]
mkFile [Char]
base = [Char]
diaDir [Char] -> [Char] -> [Char]
</> [Char]
base [Char] -> [Char] -> [Char]
<.> [Char]
"png"

renderBlockDiagram :: Maybe FilePath -> Maybe (SizeSpec V2 Double) -> [Text] -> [Block] -> IO [Block]
renderBlockDiagram :: Maybe [Char]
-> Maybe (SizeSpec V2 Double) -> [Text] -> [Block] -> IO [Block]
renderBlockDiagram Maybe [Char]
ximgDir Maybe (SizeSpec V2 Double)
ximgSize [Text]
defs [Block]
blocks = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Block -> IO [Block]
renderOne [Block]
blocks
 where
  renderOne :: Block -> IO [Block]
renderOne c :: Block
c@(CodeBlock attr :: (Text, [Text], [(Text, Text)])
attr@(Text
_, [Text]
cls, [(Text, Text)]
fields) Text
s)
    | Text
"dia-def" forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
classTags = forall (m :: * -> *) a. Monad m => a -> m a
return []
    | Text
"dia"     forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
classTags = do
        Either Text [Char]
res <- Bool
-> [Text]
-> Text
-> SizeSpec V2 Double
-> Maybe [Char]
-> IO (Either Text [Char])
renderDiagram Bool
True (Text
src forall a. a -> [a] -> [a]
: [Text]
defs) Text
"dia" ([(Text, Text)] -> SizeSpec V2 Double
attrToSize [(Text, Text)]
fields) forall a. Maybe a
Nothing
        case Either Text [Char]
res of
          Left  Text
err      -> forall (m :: * -> *) a. Monad m => a -> m a
return [(Text, [Text], [(Text, Text)]) -> Text -> Block
CodeBlock (Text, [Text], [(Text, Text)])
attr (Text -> Text -> Text
T.append Text
s Text
err)]
          Right [Char]
fileName -> do
            case (Maybe [Char]
ximgDir, Maybe (SizeSpec V2 Double)
ximgSize) of
              (Just [Char]
_, Just SizeSpec V2 Double
sz) -> do
                Either Text [Char]
_ <- Bool
-> [Text]
-> Text
-> SizeSpec V2 Double
-> Maybe [Char]
-> IO (Either Text [Char])
renderDiagram Bool
True (Text
src forall a. a -> [a] -> [a]
: [Text]
defs) Text
"dia" SizeSpec V2 Double
sz Maybe [Char]
ximgDir
                forall (m :: * -> *) a. Monad m => a -> m a
return ()
              (Maybe [Char], Maybe (SizeSpec V2 Double))
_                 -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            forall (m :: * -> *) a. Monad m => a -> m a
return [[Inline] -> Block
Para [(Text, [Text], [(Text, Text)])
-> [Inline] -> (Text, Text) -> Inline
Image (Text, [Text], [(Text, Text)])
nullAttr [] ([Char] -> Text
T.pack [Char]
fileName, Text
"")]]
    | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return [Block
c]

    where
      (Maybe Text
tag, Text
src) = Text -> (Maybe Text, Text)
unTag Text
s
      classTags :: [Text]
classTags  = (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (:) Maybe Text
tag) [Text]
cls
  renderOne Block
b = forall (m :: * -> *) a. Monad m => a -> m a
return [Block
b]

renderInlineDiagram :: [Text] -> Inline -> IO Inline
renderInlineDiagram :: [Text] -> Inline -> IO Inline
renderInlineDiagram [Text]
defs c :: Inline
c@(Code attr :: (Text, [Text], [(Text, Text)])
attr@(Text
_, [Text]
cls, [(Text, Text)]
fields) Text
expr)
    | Text
"dia" forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
cls = do
        Either Text [Char]
res <- Bool
-> [Text]
-> Text
-> SizeSpec V2 Double
-> Maybe [Char]
-> IO (Either Text [Char])
renderDiagram Bool
False [Text]
defs Text
expr ([(Text, Text)] -> SizeSpec V2 Double
attrToSize [(Text, Text)]
fields) forall a. Maybe a
Nothing
        case Either Text [Char]
res of
          Left Text
err       -> forall (m :: * -> *) a. Monad m => a -> m a
return ((Text, [Text], [(Text, Text)]) -> Text -> Inline
Code (Text, [Text], [(Text, Text)])
attr (Text -> Text -> Text
T.append Text
expr Text
err))
          Right [Char]
fileName -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Text, [Text], [(Text, Text)])
-> [Inline] -> (Text, Text) -> Inline
Image (Text, [Text], [(Text, Text)])
nullAttr [] ([Char] -> Text
T.pack [Char]
fileName, Text
"")
    | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return Inline
c

renderInlineDiagram [Text]
_ Inline
i = forall (m :: * -> *) a. Monad m => a -> m a
return Inline
i

attrToSize :: [(Text, Text)] -> SizeSpec V2 Double
attrToSize :: [(Text, Text)] -> SizeSpec V2 Double
attrToSize [(Text, Text)]
fields
  = forall n. Num n => Maybe n -> Maybe n -> SizeSpec V2 n
mkSizeSpec2D
    (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"width" [(Text, Text)]
fields forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall a. Read a => [Char] -> Maybe a
readMay forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack))
    (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"height" [(Text, Text)]
fields forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall a. Read a => [Char] -> Maybe a
readMay forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack))


putErrLn :: Text -> IO ()
putErrLn :: Text -> IO ()
putErrLn = Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr