{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}

-- |

-- Module      : $header$

-- Copyright   : (c) Laurent P René de Cotret, 2019 - 2021

-- License     : GNU GPL, version 2 or above

-- Maintainer  : laurent.decotret@outlook.com

-- Stability   : internal

-- Portability : portable

--

-- Embedding HTML and LaTeX content

module Text.Pandoc.Filter.Plot.Embed
  ( extractPlot,
    toFigure,
  )
where

import Data.Default (def)
import Data.List (nub)
import Data.Maybe (fromMaybe)
import Data.Text (Text, pack)
import qualified Data.Text.IO as T
import Text.HTML.TagSoup
  ( Attribute,
    Tag (TagClose, TagOpen),
    canonicalizeTags,
    parseOptionsFast,
    parseTagsOptions,
    partitions,
    renderTags,
    (~/=),
    (~==),
  )
import Text.Pandoc.Builder
  ( Inlines,
    fromList,
    imageWith,
    link,
    para,
    str,
    toList,
  )
import Text.Pandoc.Class (runPure)
import Text.Pandoc.Definition (Attr, Block (..), Format, Pandoc (..))
import Text.Pandoc.Error (handleError)
import Text.Pandoc.Filter.Plot.Monad
import Text.Pandoc.Filter.Plot.Parse (captionReader)
import Text.Pandoc.Filter.Plot.Scripting (figurePath, sourceCodePath)
import Text.Pandoc.Writers.HTML (writeHtml5String)
import Text.Pandoc.Writers.LaTeX (writeLaTeX)
import Text.Shakespeare.Text (st)

-- | Convert a @FigureSpec@ to a Pandoc figure component.

-- Note that the script to generate figure files must still

-- be run in another function.

toFigure ::
  -- | text format of the caption

  Format ->
  FigureSpec ->
  PlotM Block
toFigure :: Format -> FigureSpec -> PlotM Block
toFigure Format
fmt FigureSpec
spec = do
  FilePath
target <- FigureSpec -> PlotM FilePath
figurePath FigureSpec
spec
  Text
scp <- FilePath -> Text
pack (FilePath -> Text)
-> PlotM FilePath -> StateT PlotState (ReaderT RuntimeEnv IO) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FigureSpec -> PlotM FilePath
sourceCodePath FigureSpec
spec
  Text
sourceLabel <- (Configuration -> Text)
-> StateT PlotState (ReaderT RuntimeEnv IO) Text
forall a. (Configuration -> a) -> PlotM a
asksConfig Configuration -> Text
sourceCodeLabel -- Allow the possibility for non-english labels

  let srcLink :: Inlines
srcLink = Text -> Text -> Inlines -> Inlines
link Text
scp Text
forall a. Monoid a => a
mempty (Text -> Inlines
str Text
sourceLabel)
      attrs' :: Attr
attrs' = FigureSpec -> Attr
blockAttrs FigureSpec
spec
      withSource' :: Bool
withSource' = FigureSpec -> Bool
withSource FigureSpec
spec
      captionText :: Inlines
captionText = [Inline] -> Inlines
forall a. [a] -> Many a
fromList ([Inline] -> Inlines) -> [Inline] -> Inlines
forall a b. (a -> b) -> a -> b
$ [Inline] -> Maybe [Inline] -> [Inline]
forall a. a -> Maybe a -> a
fromMaybe [Inline]
forall a. Monoid a => a
mempty (Format -> Text -> Maybe [Inline]
captionReader Format
fmt (Text -> Maybe [Inline]) -> Text -> Maybe [Inline]
forall a b. (a -> b) -> a -> b
$ FigureSpec -> Text
caption FigureSpec
spec)
      captionLinks :: Inlines
captionLinks = [Inlines] -> Inlines
forall a. Monoid a => [a] -> a
mconcat [Inlines
" (", Inlines
srcLink, Inlines
")"]
      caption' :: Inlines
caption' = if Bool
withSource' then Inlines
captionText Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
captionLinks else Inlines
captionText
  Attr -> FilePath -> Inlines -> PlotM Block
builder Attr
attrs' FilePath
target Inlines
caption'
  where
    builder :: Attr -> FilePath -> Inlines -> PlotM Block
builder = case FigureSpec -> SaveFormat
saveFormat FigureSpec
spec of
      SaveFormat
HTML -> Attr -> FilePath -> Inlines -> PlotM Block
interactiveBlock
      SaveFormat
LaTeX -> Attr -> FilePath -> Inlines -> PlotM Block
latexInput
      SaveFormat
_ -> Attr -> FilePath -> Inlines -> PlotM Block
figure

figure ::
  Attr ->
  FilePath ->
  Inlines ->
  PlotM Block
-- To render images as figures with captions, the target title

-- must be "fig:"

-- Janky? yes

figure :: Attr -> FilePath -> Inlines -> PlotM Block
figure Attr
as FilePath
fp Inlines
caption' =
  Block -> PlotM Block
forall (m :: * -> *) a. Monad m => a -> m a
return (Block -> PlotM Block)
-> (Inlines -> Block) -> Inlines -> PlotM Block
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Block] -> Block
forall a. [a] -> a
head ([Block] -> Block) -> (Inlines -> [Block]) -> Inlines -> Block
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Many Block -> [Block]
forall a. Many a -> [a]
toList (Many Block -> [Block])
-> (Inlines -> Many Block) -> Inlines -> [Block]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Inlines -> Many Block
para (Inlines -> PlotM Block) -> Inlines -> PlotM Block
forall a b. (a -> b) -> a -> b
$
    Attr -> Text -> Text -> Inlines -> Inlines
imageWith Attr
as (FilePath -> Text
pack FilePath
fp) Text
"fig:" Inlines
caption'

-- TODO: also add the case where SVG plots can be

--       embedded in HTML output

-- embeddedSVGBlock ::

--   Attr ->

--   FilePath ->

--   Inlines ->

--   PlotM Block

-- embeddedSVGBlock _ fp caption' = do

--   svgsource <- liftIO $ T.readFile fp

--   renderedCaption <- writeHtml caption'

--   return $

--     RawBlock

--       "html5"

--       [st|

-- <figure>

--     <svg>

--     #{svgsource}

--     </svg>

--     <figcaption>#{renderedCaption}</figcaption>

-- </figure>

--     |]


latexInput :: Attr -> FilePath -> Inlines -> PlotM Block
latexInput :: Attr -> FilePath -> Inlines -> PlotM Block
latexInput Attr
_ FilePath
fp Inlines
caption' = do
  Text
renderedCaption' <- Inlines -> StateT PlotState (ReaderT RuntimeEnv IO) Text
writeLatex Inlines
caption'
  let renderedCaption :: Text
renderedCaption =
        if Text
renderedCaption' Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
""
          then [st|\caption{#{renderedCaption'}}|]
          else Text
""
  Block -> PlotM Block
forall (m :: * -> *) a. Monad m => a -> m a
return (Block -> PlotM Block) -> Block -> PlotM Block
forall a b. (a -> b) -> a -> b
$
    Format -> Text -> Block
RawBlock
      Format
"latex"
      [st|
    \begin{figure}
        \centering
        \input{#{pack $ normalizePath $ fp}}
        #{renderedCaption}
    \end{figure}
        |]
  where
    normalizePath :: FilePath -> FilePath
normalizePath = (Char -> Char) -> FilePath -> FilePath
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
f
      where
        f :: Char -> Char
f Char
'\\' = Char
'/'
        f Char
x = Char
x

interactiveBlock ::
  Attr ->
  FilePath ->
  Inlines ->
  PlotM Block
interactiveBlock :: Attr -> FilePath -> Inlines -> PlotM Block
interactiveBlock Attr
_ FilePath
fp Inlines
caption' = do
  -- TODO: should we instead include the scripts in the "include-after"

  --       template variable?

  --       See https://github.com/jgm/pandoc/issues/6582

  Text
htmlpage <- IO Text -> StateT PlotState (ReaderT RuntimeEnv IO) Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> StateT PlotState (ReaderT RuntimeEnv IO) Text)
-> IO Text -> StateT PlotState (ReaderT RuntimeEnv IO) Text
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Text
T.readFile FilePath
fp
  Text
renderedCaption <- Inlines -> StateT PlotState (ReaderT RuntimeEnv IO) Text
writeHtml Inlines
caption'
  Block -> PlotM Block
forall (m :: * -> *) a. Monad m => a -> m a
return (Block -> PlotM Block) -> Block -> PlotM Block
forall a b. (a -> b) -> a -> b
$
    Format -> Text -> Block
RawBlock
      Format
"html5"
      [st|
<figure>
    <div>
    #{extractPlot htmlpage}
    </div>
    <figcaption>#{renderedCaption}</figcaption>
</figure>
    |]

-- | Convert Pandoc inlines to html

writeHtml :: Inlines -> PlotM Text
writeHtml :: Inlines -> StateT PlotState (ReaderT RuntimeEnv IO) Text
writeHtml Inlines
is = IO Text -> StateT PlotState (ReaderT RuntimeEnv IO) Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> StateT PlotState (ReaderT RuntimeEnv IO) Text)
-> IO Text -> StateT PlotState (ReaderT RuntimeEnv IO) Text
forall a b. (a -> b) -> a -> b
$ Either PandocError Text -> IO Text
forall a. Either PandocError a -> IO a
handleError (Either PandocError Text -> IO Text)
-> Either PandocError Text -> IO Text
forall a b. (a -> b) -> a -> b
$ PandocPure Text -> Either PandocError Text
forall a. PandocPure a -> Either PandocError a
runPure (PandocPure Text -> Either PandocError Text)
-> PandocPure Text -> Either PandocError Text
forall a b. (a -> b) -> a -> b
$ WriterOptions -> Pandoc -> PandocPure Text
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m Text
writeHtml5String WriterOptions
forall a. Default a => a
def Pandoc
document
  where
    document :: Pandoc
document = Meta -> [Block] -> Pandoc
Pandoc Meta
forall a. Monoid a => a
mempty [[Inline] -> Block
Para ([Inline] -> Block) -> (Inlines -> [Inline]) -> Inlines -> Block
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Inlines -> [Inline]
forall a. Many a -> [a]
toList (Inlines -> Block) -> Inlines -> Block
forall a b. (a -> b) -> a -> b
$ Inlines
is]

writeLatex :: Inlines -> PlotM Text
writeLatex :: Inlines -> StateT PlotState (ReaderT RuntimeEnv IO) Text
writeLatex Inlines
is = IO Text -> StateT PlotState (ReaderT RuntimeEnv IO) Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> StateT PlotState (ReaderT RuntimeEnv IO) Text)
-> IO Text -> StateT PlotState (ReaderT RuntimeEnv IO) Text
forall a b. (a -> b) -> a -> b
$ Either PandocError Text -> IO Text
forall a. Either PandocError a -> IO a
handleError (Either PandocError Text -> IO Text)
-> Either PandocError Text -> IO Text
forall a b. (a -> b) -> a -> b
$ PandocPure Text -> Either PandocError Text
forall a. PandocPure a -> Either PandocError a
runPure (PandocPure Text -> Either PandocError Text)
-> PandocPure Text -> Either PandocError Text
forall a b. (a -> b) -> a -> b
$ WriterOptions -> Pandoc -> PandocPure Text
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m Text
writeLaTeX WriterOptions
forall a. Default a => a
def Pandoc
document
  where
    document :: Pandoc
document = Meta -> [Block] -> Pandoc
Pandoc Meta
forall a. Monoid a => a
mempty [[Inline] -> Block
Para ([Inline] -> Block) -> (Inlines -> [Inline]) -> Inlines -> Block
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Inlines -> [Inline]
forall a. Many a -> [a]
toList (Inlines -> Block) -> Inlines -> Block
forall a b. (a -> b) -> a -> b
$ Inlines
is]

-- | Extract the plot-relevant content from inside of a full HTML document.

-- Scripts contained in the <head> tag are extracted, as well as the entirety of the

-- <body> tag.

extractPlot :: Text -> Text
extractPlot :: Text -> Text
extractPlot Text
t =
  let tags :: [Tag Text]
tags = [Tag Text] -> [Tag Text]
forall str. StringLike str => [Tag str] -> [Tag str]
canonicalizeTags ([Tag Text] -> [Tag Text]) -> [Tag Text] -> [Tag Text]
forall a b. (a -> b) -> a -> b
$ ParseOptions Text -> Text -> [Tag Text]
forall str. StringLike str => ParseOptions str -> str -> [Tag str]
parseTagsOptions ParseOptions Text
forall str. StringLike str => ParseOptions str
parseOptionsFast Text
t
      extracted :: [[Tag Text]]
extracted = [Tag Text] -> [[Tag Text]]
headScripts [Tag Text]
tags [[Tag Text]] -> [[Tag Text]] -> [[Tag Text]]
forall a. Semigroup a => a -> a -> a
<> [Text -> [Tag Text] -> [Tag Text]
inside Text
"body" [Tag Text]
tags]
   in [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Tag Text] -> Text
forall str. StringLike str => [Tag str] -> str
renderTags ([Tag Text] -> Text) -> [[Tag Text]] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Tag Text] -> [Tag Text]
deferScripts ([Tag Text] -> [Tag Text]) -> [[Tag Text]] -> [[Tag Text]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Tag Text]]
extracted)
  where
    headScripts :: [Tag Text] -> [[Tag Text]]
headScripts = (Tag Text -> Bool) -> [Tag Text] -> [[Tag Text]]
forall a. (a -> Bool) -> [a] -> [[a]]
partitions (Tag Text -> FilePath -> Bool
forall str t. (StringLike str, TagRep t) => Tag str -> t -> Bool
~== (FilePath
"<script>" :: String)) ([Tag Text] -> [[Tag Text]])
-> ([Tag Text] -> [Tag Text]) -> [Tag Text] -> [[Tag Text]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Tag Text] -> [Tag Text]
inside Text
"head"

-- | Get content inside a tag, e.g. /inside "body"/ returns all tags

-- between /<body>/ and /</body>/

inside :: Text -> [Tag Text] -> [Tag Text]
inside :: Text -> [Tag Text] -> [Tag Text]
inside Text
t = [Tag Text] -> [Tag Text]
forall a. [a] -> [a]
init ([Tag Text] -> [Tag Text])
-> ([Tag Text] -> [Tag Text]) -> [Tag Text] -> [Tag Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tag Text] -> [Tag Text]
forall a. [a] -> [a]
tail ([Tag Text] -> [Tag Text])
-> ([Tag Text] -> [Tag Text]) -> [Tag Text] -> [Tag Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tag Text] -> [Tag Text]
tgs
  where
    tgs :: [Tag Text] -> [Tag Text]
tgs = (Tag Text -> Bool) -> [Tag Text] -> [Tag Text]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Tag Text -> Tag Text -> Bool
forall str t. (StringLike str, TagRep t) => Tag str -> t -> Bool
~/= Text -> Tag Text
forall str. str -> Tag str
TagClose Text
t) ([Tag Text] -> [Tag Text])
-> ([Tag Text] -> [Tag Text]) -> [Tag Text] -> [Tag Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tag Text -> Bool) -> [Tag Text] -> [Tag Text]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Tag Text -> Tag Text -> Bool
forall str t. (StringLike str, TagRep t) => Tag str -> t -> Bool
~/= Text -> [Attribute Text] -> Tag Text
forall str. str -> [Attribute str] -> Tag str
TagOpen Text
t [])

data ScriptTag
  = InlineScript [Attribute Text]
  | ExternalScript [Attribute Text]

fromTag :: Tag Text -> Maybe ScriptTag
fromTag :: Tag Text -> Maybe ScriptTag
fromTag (TagOpen Text
"script" [Attribute Text]
attrs) =
  ScriptTag -> Maybe ScriptTag
forall a. a -> Maybe a
Just (ScriptTag -> Maybe ScriptTag) -> ScriptTag -> Maybe ScriptTag
forall a b. (a -> b) -> a -> b
$
    if Text
"src" Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Attribute Text -> Text) -> [Attribute Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Attribute Text -> Text
forall a b. (a, b) -> a
fst [Attribute Text]
attrs
      then [Attribute Text] -> ScriptTag
ExternalScript [Attribute Text]
attrs
      else [Attribute Text] -> ScriptTag
InlineScript [Attribute Text]
attrs
fromTag Tag Text
_ = Maybe ScriptTag
forall a. Maybe a
Nothing

toTag :: ScriptTag -> Tag Text
toTag :: ScriptTag -> Tag Text
toTag (InlineScript [Attribute Text]
t) = Text -> [Attribute Text] -> Tag Text
forall str. str -> [Attribute str] -> Tag str
TagOpen Text
"script" [Attribute Text]
t
toTag (ExternalScript [Attribute Text]
t) = Text -> [Attribute Text] -> Tag Text
forall str. str -> [Attribute str] -> Tag str
TagOpen Text
"script" [Attribute Text]
t

deferScript :: ScriptTag -> ScriptTag
deferScript :: ScriptTag -> ScriptTag
deferScript (InlineScript [Attribute Text]
attrs) = [Attribute Text] -> ScriptTag
InlineScript ([Attribute Text] -> ScriptTag) -> [Attribute Text] -> ScriptTag
forall a b. (a -> b) -> a -> b
$ [Attribute Text] -> [Attribute Text]
forall a. Eq a => [a] -> [a]
nub ([Attribute Text] -> [Attribute Text])
-> [Attribute Text] -> [Attribute Text]
forall a b. (a -> b) -> a -> b
$ [Attribute Text]
attrs [Attribute Text] -> [Attribute Text] -> [Attribute Text]
forall a. Semigroup a => a -> a -> a
<> [(Text
"type", Text
"module")]
deferScript (ExternalScript [Attribute Text]
attrs) = [Attribute Text] -> ScriptTag
ExternalScript ([Attribute Text] -> ScriptTag) -> [Attribute Text] -> ScriptTag
forall a b. (a -> b) -> a -> b
$ [Attribute Text] -> [Attribute Text]
forall a. Eq a => [a] -> [a]
nub ([Attribute Text] -> [Attribute Text])
-> [Attribute Text] -> [Attribute Text]
forall a b. (a -> b) -> a -> b
$ [Attribute Text]
attrs [Attribute Text] -> [Attribute Text] -> [Attribute Text]
forall a. Semigroup a => a -> a -> a
<> [(Text
"defer", Text
forall a. Monoid a => a
mempty)]

-- | Replace /<script src=...>/ tags with /<script src=... defer>/,

-- and inline scripts as /<script type="module">/.

-- This makes scripts execute only after HTML parsing has finished.

deferScripts :: [Tag Text] -> [Tag Text]
deferScripts :: [Tag Text] -> [Tag Text]
deferScripts = (Tag Text -> Tag Text) -> [Tag Text] -> [Tag Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Tag Text
t -> Tag Text -> (ScriptTag -> Tag Text) -> Maybe ScriptTag -> Tag Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Tag Text
t (ScriptTag -> Tag Text
toTag (ScriptTag -> Tag Text)
-> (ScriptTag -> ScriptTag) -> ScriptTag -> Tag Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptTag -> ScriptTag
deferScript) (Tag Text -> Maybe ScriptTag
fromTag Tag Text
t))