{-# LANGUAGE LambdaCase, OverloadedStrings #-}
module Media.SVG (
    optimizeSVGCompiler
  , mermaidTransform
) where

import           Control.Arrow             (first)
import           Control.Exception.Safe    (MonadThrow, throwString)
import           Control.Monad             (MonadPlus (..), (>=>))
import           Control.Monad.Extra       (ifM)
import           Control.Monad.IO.Class    (MonadIO (..))
import           Control.Monad.Trans       (MonadTrans (..))
import           Control.Monad.Trans.Maybe (hoistMaybe, runMaybeT)
import           Data.Functor              ((<&>))
import           Data.Maybe                (fromMaybe)
import qualified Data.Text                 as T
import qualified Data.Text.Lazy            as TL
import           Hakyll
import           Lucid.Base                (HtmlT, renderText, toHtmlRaw)
import           Lucid.Html5
import           System.Exit               (ExitCode (..))
import           System.Process            (proc, readCreateProcessWithExitCode)
import           Text.Pandoc               (Block (..), Format (..),
                                            Inline (..))

optimizeSVGCompiler :: [String] -> Compiler (Item String)
optimizeSVGCompiler :: [String] -> Compiler (Item String)
optimizeSVGCompiler [String]
opts = Compiler (Item String)
getResourceString
    Compiler (Item String)
-> (Item String -> Compiler (Item String))
-> Compiler (Item String)
forall a b. Compiler a -> (a -> Compiler b) -> Compiler b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> Compiler String)
-> Item String -> Compiler (Item String)
forall a b. (a -> Compiler b) -> Item a -> Compiler (Item b)
withItemBody (String -> [String] -> String -> Compiler String
unixFilter String
"npx" ([String] -> String -> Compiler String)
-> [String] -> String -> Compiler String
forall a b. (a -> b) -> a -> b
$ [String
"svgo", String
"-i", String
"-", String
"-o", String
"-"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
opts)

type SVGHtml n = HtmlT n ()

execMmdc :: (MonadIO m, Monad n, MonadThrow m) => T.Text -> m (SVGHtml n)
execMmdc :: forall (m :: * -> *) (n :: * -> *).
(MonadIO m, Monad n, MonadThrow m) =>
Text -> m (SVGHtml n)
execMmdc = IO (ExitCode, String, String) -> m (ExitCode, String, String)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ExitCode, String, String) -> m (ExitCode, String, String))
-> (Text -> IO (ExitCode, String, String))
-> Text
-> m (ExitCode, String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CreateProcess -> String -> IO (ExitCode, String, String)
readCreateProcessWithExitCode (String -> [String] -> CreateProcess
proc String
"npx" [String]
args) (String -> IO (ExitCode, String, String))
-> (Text -> String) -> Text -> IO (ExitCode, String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> m (ExitCode, String, String))
-> ((ExitCode, String, String) -> m (SVGHtml n))
-> Text
-> m (SVGHtml n)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \case
    (ExitFailure Int
_, String
_, String
err) -> String -> m (SVGHtml n)
forall (m :: * -> *) a.
(MonadThrow m, HasCallStack) =>
String -> m a
throwString String
err
    (ExitCode
ExitSuccess, String
out, String
_)   -> SVGHtml n -> m (SVGHtml n)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SVGHtml n -> m (SVGHtml n)) -> SVGHtml n -> m (SVGHtml n)
forall a b. (a -> b) -> a -> b
$ Text -> SVGHtml n
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
forall (m :: * -> *). Monad m => Text -> HtmlT m ()
toHtmlRaw (Text -> SVGHtml n) -> Text -> SVGHtml n
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
out
    where
        args :: [String]
args = [String
"mmdc", String
"-i", String
"/dev/stdin", String
"-e", String
"svg", String
"-o", String
"-"]

styledSvg :: Monad m => [(String, T.Text)] -> SVGHtml m -> SVGHtml m
styledSvg :: forall (m :: * -> *).
Monad m =>
[(String, Text)] -> SVGHtml m -> SVGHtml m
styledSvg [(String, Text)]
args HtmlT m ()
svgHtml = [Attribute] -> HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
figure_ [Text -> Attribute
class_ Text
"has-text-centered image"] (HtmlT m () -> HtmlT m ()) -> HtmlT m () -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ do
    HtmlT m ()
svgHtml
    HtmlT m () -> (Text -> HtmlT m ()) -> Maybe Text -> HtmlT m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe HtmlT m ()
forall a. Monoid a => a
mempty ([Attribute] -> HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
figcaption_ [Text -> Attribute
class_ Text
"has-text-centered"] (HtmlT m () -> HtmlT m ())
-> (Text -> HtmlT m ()) -> Text -> HtmlT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
forall (m :: * -> *). Monad m => Text -> HtmlT m ()
toHtmlRaw) (Maybe Text -> HtmlT m ()) -> Maybe Text -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ String -> [(String, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"caption" [(String, Text)]
args

-- | When a code block starts in @```{lang=mermaid}@,
-- convert its internal mermaid format to svg.
-- Add the caption as follows: @```{lang=mermaid caption=hoge}@.
mermaidTransform :: Block -> Compiler Block
mermaidTransform :: Block -> Compiler Block
mermaidTransform cb :: Block
cb@(CodeBlock (Text
_, [Text]
_, [(Text, Text)]
t) Text
contents) = Block -> Maybe Block -> Block
forall a. a -> Maybe a -> a
fromMaybe Block
cb (Maybe Block -> Block) -> Compiler (Maybe Block) -> Compiler Block
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    MaybeT Compiler Block -> Compiler (Maybe Block)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT MaybeT Compiler Block
mermaidTransform'
    where
        mermaidTransform' :: MaybeT Compiler Block
mermaidTransform' = let args :: [(String, Text)]
args = ((Text, Text) -> (String, Text))
-> [(Text, Text)] -> [(String, Text)]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> String) -> (Text, Text) -> (String, Text)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((Text -> String) -> (Text, Text) -> (String, Text))
-> (Text -> String) -> (Text, Text) -> (String, Text)
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> (Text -> Text) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.toLower) [(Text, Text)]
t in
            MaybeT Compiler Bool
-> MaybeT Compiler Block
-> MaybeT Compiler Block
-> MaybeT Compiler Block
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/=Text
"mermaid") (Text -> Bool) -> (Text -> Text) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.toLower (Text -> Bool) -> MaybeT Compiler Text -> MaybeT Compiler Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text -> MaybeT Compiler Text
forall (m :: * -> *) b. Applicative m => Maybe b -> MaybeT m b
hoistMaybe (String -> [(String, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"lang" [(String, Text)]
args))
                MaybeT Compiler Block
forall a. MaybeT Compiler a
forall (m :: * -> *) a. MonadPlus m => m a
mzero (MaybeT Compiler Block -> MaybeT Compiler Block)
-> MaybeT Compiler Block -> MaybeT Compiler Block
forall a b. (a -> b) -> a -> b
$
                Compiler Block -> MaybeT Compiler Block
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Compiler Block -> MaybeT Compiler Block)
-> Compiler Block -> MaybeT Compiler Block
forall a b. (a -> b) -> a -> b
$ IO (SVGHtml Identity) -> Compiler (SVGHtml Identity)
forall a. IO a -> Compiler a
unsafeCompiler (Text -> IO (SVGHtml Identity)
forall (m :: * -> *) (n :: * -> *).
(MonadIO m, Monad n, MonadThrow m) =>
Text -> m (SVGHtml n)
execMmdc Text
contents)
                    Compiler (SVGHtml Identity)
-> (SVGHtml Identity -> Block) -> Compiler Block
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> [Inline] -> Block
Plain ([Inline] -> Block)
-> (SVGHtml Identity -> [Inline]) -> SVGHtml Identity -> Block
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Inline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
:[]) (Inline -> [Inline])
-> (SVGHtml Identity -> Inline) -> SVGHtml Identity -> [Inline]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Format -> Text -> Inline
RawInline (Text -> Format
Format Text
"html")
                        (Text -> Inline)
-> (SVGHtml Identity -> Text) -> SVGHtml Identity -> Inline
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.toStrict (Text -> Text)
-> (SVGHtml Identity -> Text) -> SVGHtml Identity -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SVGHtml Identity -> Text
forall a. Html a -> Text
renderText (SVGHtml Identity -> Text)
-> (SVGHtml Identity -> SVGHtml Identity)
-> SVGHtml Identity
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, Text)] -> SVGHtml Identity -> SVGHtml Identity
forall (m :: * -> *).
Monad m =>
[(String, Text)] -> SVGHtml m -> SVGHtml m
styledSvg [(String, Text)]
args
mermaidTransform Block
x = Block -> Compiler Block
forall a. a -> Compiler a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Block
x