Diagrams.hs

{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE OverloadedStrings         #-}
{-# LANGUAGE RecordWildCards           #-}

-- | Convert appropriately annotated Code blocks to an image, with or
-- without display of the code.  Interpret the Code blocks as Haskell
-- code using the Diagrams libraries.

module Text.Pandoc.Diagrams where

import           Data.Hashable                   (Hashable)
import           Data.List                       (delete)
import           Data.Text                       (Text)
import qualified Data.Text                       as T
import           Data.Typeable                   (Typeable)
import qualified Diagrams.Backend.Cairo.Internal as BCairo
import qualified Diagrams.Backend.SVG            as BSvg
import qualified Diagrams.Builder                as DB
import qualified Diagrams.Core                   as DC
import           Diagrams.Prelude                (centerXY, pad, (&), (.~))
import           Diagrams.Size                   (dims)
import qualified Graphics.Svg                    as Svg
import           Linear                          (V2 (..), zero)
import           System.Directory                (createDirectoryIfMissing)
import           System.FilePath                 (pathSeparator, (<.>), (</>))
import           System.IO
import           Text.Pandoc.Definition

backendExt :: Opts -> String
backendExt Opts {_backend = SVG, ..} = "svg"
backendExt Opts {_backend = Cairo, ..} = case _outFormat of
  "beamer" -> "pdf"
  "latex"  -> "pdf"
  _        -> "png"

-- Return output type for a string
findCairoOutputType :: String -> BCairo.OutputType
findCairoOutputType "beamer" = BCairo.PDF
findCairoOutputType "latex"  = BCairo.PDF
findCairoOutputType _        = BCairo.PNG

data Opts = Opts {
    _outFormat    :: String,
    _outDir       :: FilePath,
    _expression   :: String,
    _absolutePath :: Bool,
    _backend      :: Backend
    }

data Backend = Cairo | SVG deriving (Read)

data Echo = Above | Below

insertDiagrams :: Opts -> Block -> IO [Block]
insertDiagrams opts@Opts{..} (CodeBlock (ident, classes, attrs) code)
    | "diagram-haskell" `elem` classes = do
      i <- img
      return $ case echo of
        Above -> [bl', i]
        Below -> [i, bl']
    | "diagram" `elem` classes = (:[]) <$> img
  where
    img = do
        d <- compileDiagram opts attrs code
        return $ case d of
            Left _err     -> Null  -- TODO log an error here
            Right imgName -> Plain
              [Image ("",[],[]) []
                 (if _absolutePath then T.cons pathSeparator imgName else imgName,"")
              ] -- no alt text, no title
    bl' = CodeBlock (ident, "haskell":delete "diagram-haskell" classes, attrs) code
    echo = readEcho attrs
insertDiagrams _ block = return [block]

-- Copied from https://github.com/diagrams/diagrams-doc/blob/master/doc/Xml2Html.hs
-- With the CPP removed, thereby requiring Cairo
-- TODO clean this up, move it into -builder somehow
-- | Compile the literate source code of a diagram to a .png/.pdf file with
--   a file name given by a hash of the source code contents
compileDiagram :: Opts -> [(Text,Text)] -> Text -> IO (Either String Text)
compileDiagram opts attrs src = do
  ensureDir $ _outDir opts
  case mkBuildOpts opts attrs src of
    SomeBuildOpts bo -> do
      res <- DB.buildDiagram bo
      case res of
        DB.ParseErr err    -> do
          hPutStrLn stderr ("\nError while parsing\n" ++ T.unpack src)
          hPutStrLn stderr err
          return $ Left "Error while parsing"

        DB.InterpErr ierr  -> do
          hPutStrLn stderr ("\nError while interpreting\n" ++ T.unpack src)
          hPutStrLn stderr (DB.ppInterpError ierr)
          return $ Left "Error while interpreting"

        DB.Skipped hash    -> do
          hPutStr stderr "."
          hFlush stderr
          return $ Right (T.pack $ mkFile opts (DB.hashToHexStr hash))

        DB.OK hash out -> do
          hPutStr stderr "O"
          hFlush stderr
          let path = mkFile opts (DB.hashToHexStr hash)
          handleResult path $ SomeResult out
          return $ Right (T.pack path)
  where
    ensureDir = createDirectoryIfMissing True
    handleResult path (SomeResult a) = mkImage path a

mkFile :: Opts -> FilePath -> FilePath
mkFile opts base = _outDir opts </> base <.> backendExt opts

data SomeResult = forall r. (MkImage r) => SomeResult r

data SomeBuildOpts v n =
  forall a. (Typeable a, DC.Backend a v n, Hashable (DC.Options a v n), MkImage (DC.Result a v n))
  => SomeBuildOpts (DB.BuildOpts a v n)

class MkImage a where
  mkImage :: FilePath -> a -> IO ()

instance MkImage (IO (), r) where
  mkImage _ = fst

instance MkImage Svg.Element where
  mkImage path e = writeFile path $ show e

mkBuildOpts :: Opts -> [(Text, Text)] -> Text -> SomeBuildOpts V2 Double
mkBuildOpts opts attrs src = case _backend opts of
  Cairo -> SomeBuildOpts $ DB.mkBuildOpts BCairo.Cairo zero
    ( BCairo.CairoOptions "default.png"
      (dims $ V2 (widthAttribute attrs) (heightAttribute attrs))
      (findCairoOutputType $ _outFormat opts)
      False
    )
    & DB.snippets .~ [T.unpack src]
    & DB.imports  .~
      [ "Diagrams.TwoD.Types" -- WHY IS THIS NECESSARY =(
      , "Diagrams.Core.Points" -- GHC 7.2 bug?  need  V (Point R2) = R2  (see #65)
      , "Diagrams.Backend.Cairo"
      , "Diagrams.Backend.Cairo.Internal"
      , "Graphics.SVGFonts"
      , "Data.Typeable"
      ]
    & DB.pragmas .~ ["DeriveDataTypeable"]
    & DB.diaExpr .~ _expression opts
    & DB.postProcess .~ postProcess
    & DB.decideRegen .~
      DB.hashedRegenerate
        (\hash opts' -> opts' { BCairo._cairoFileName = mkFile opts hash })
        (_outDir opts)
  SVG -> SomeBuildOpts $ DB.mkBuildOpts BSvg.SVG zero
    (BSvg.SVGOptions (dims $ V2 (widthAttribute attrs) (heightAttribute attrs)) Nothing "" [] True)
    & DB.snippets .~ [T.unpack src]
    & DB.imports  .~
      [ "Diagrams.TwoD.Types"
      , "Diagrams.Core.Points"
      , "Diagrams.Backend.SVG"
      , "Graphics.SVGFonts"
      , "Data.Typeable"
      ]
    & DB.pragmas .~ ["DeriveDataTypeable"]
    & DB.diaExpr .~ _expression opts
    & DB.postProcess .~ postProcess
  where
    postProcess = pad 1.1 . centerXY

widthAttribute :: [(Text,Text)] -> Double
widthAttribute attrs =
    case lookup "width" attrs of
        Nothing -> 500
        Just v  -> read (T.unpack v) :: Double

heightAttribute :: [(Text,Text)] -> Double
heightAttribute attrs =
    case lookup "height" attrs of
        Nothing -> 200
        Just v  -> read (T.unpack v) :: Double

readEcho :: [(Text, Text)] -> Echo
readEcho attrs = case lookup "echo" attrs of
  Nothing -> Below
  Just v -> case T.toLower v of
    "above" -> Above
    _       -> Below