{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}

-- |
-- Module      : $header$
-- Copyright   : (c) Laurent P René de Cotret, 2019 - present
-- License     : GNU GPL, version 2 or above
-- Maintainer  : laurent.decotret@outlook.com
-- Stability   : internal
-- Portability : portable
--
-- Scripting
module Text.Pandoc.Filter.Plot.Scripting
  ( ScriptResult (..),
    runTempScript,
    runScriptIfNecessary,
    figurePath,
    sourceCodePath,
  )
where

import Control.Concurrent.MVar (withMVar)
import Data.Default (def)
import Data.Functor.Identity (Identity (..))
import Data.Hashable (hash)
import Data.Text (Text, pack, unpack)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Paths_pandoc_plot (version)
import System.Directory
  ( createDirectoryIfMissing,
    doesFileExist,
    getTemporaryDirectory,
  )
import System.Exit (ExitCode (..))
import System.FilePath
  ( addExtension,
    normalise,
    replaceExtension,
    takeDirectory,
    (</>), 
    takeBaseName,
  )
import Text.Pandoc.Class (runPure)
import Text.Pandoc.Definition (Block (CodeBlock), Pandoc (Pandoc))
import Text.Pandoc.Filter.Plot.Monad
import Text.Pandoc.Filter.Plot.Scripting.Template
import Text.Pandoc.Options (WriterOptions (..))
import Text.Pandoc.SelfContained (makeSelfContained)
import Text.Pandoc.Templates
import Text.Pandoc.Writers (writeHtml5String)
import Text.Printf (printf)

-- Run script as described by the spec, only if necessary
runScriptIfNecessary :: FigureSpec -> PlotM ScriptResult
runScriptIfNecessary :: FigureSpec -> PlotM ScriptResult
runScriptIfNecessary FigureSpec
spec = do
  String
target <- FigureSpec -> PlotM String
figurePath FigureSpec
spec
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
takeDirectory forall a b. (a -> b) -> a -> b
$ String
target

  Bool
fileAlreadyExists <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO Bool
doesFileExist forall a b. (a -> b) -> a -> b
$ String
target
  ScriptResult
result <-
    if Bool
fileAlreadyExists
      then forall (m :: * -> *) a. Monad m => a -> m a
return ScriptResult
ScriptSuccess
      else FigureSpec -> PlotM ScriptResult
runTempScript FigureSpec
spec

  forall {m :: * -> *}.
(MonadLogger m, MonadIO m) =>
ScriptResult -> m ()
logScriptResult ScriptResult
result

  case ScriptResult
result of
    ScriptResult
ScriptSuccess -> FigureSpec -> StateT PlotState (ReaderT RuntimeEnv IO) ()
writeSource FigureSpec
spec forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ScriptResult
ScriptSuccess
    ScriptResult
other -> forall (m :: * -> *) a. Monad m => a -> m a
return ScriptResult
other
  where
    logScriptResult :: ScriptResult -> m ()
logScriptResult ScriptResult
ScriptSuccess = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    logScriptResult ScriptResult
r = forall (m :: * -> *). (MonadLogger m, MonadIO m) => Script -> m ()
err forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Script
pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ ScriptResult
r

-- | Possible result of running a script
data ScriptResult
  = ScriptSuccess
  | ScriptChecksFailed Text -- Message
  | ScriptFailure Text Int Script -- Command, exit code, and source script

instance Show ScriptResult where
  show :: ScriptResult -> String
show ScriptResult
ScriptSuccess = String
"Script success."
  show (ScriptChecksFailed Script
msg) = Script -> String
unpack forall a b. (a -> b) -> a -> b
$ Script
"Script checks failed: " forall a. Semigroup a => a -> a -> a
<> Script
msg
  show (ScriptFailure Script
cmd Int
ec Script
s) = forall a. Monoid a => [a] -> a
mconcat [String
"Command \"", Script -> String
unpack Script
cmd, String
"\" failed with exit code ", forall a. Show a => a -> String
show Int
ec, String
". The script source was: \n\n", Script -> String
unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Script -> Script
formatScript forall a b. (a -> b) -> a -> b
$ Script
s, String
"\n"]

-- | Format a script to show in error messages
formatScript :: Script -> Text
formatScript :: Script -> Script
formatScript Script
s = [Script] -> Script
T.unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Script -> Script
formatLine) forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
linenos (Script -> [Script]
T.lines Script
s)
  where
    nlines :: Int
nlines = forall (t :: * -> *) a. Foldable t => t a -> Int
length (Script -> [Script]
T.lines Script
s)
    linenos :: [Int]
linenos = [Int
1 .. Int
nlines]

    -- No version of ceil in Prelude, so 1 + floor will have to do
    maxdigits :: Int
    maxdigits :: Int
maxdigits = Int
1 forall a. Num a => a -> a -> a
+ forall a b. (RealFrac a, Integral b) => a -> b
floor (forall a. Floating a => a -> a -> a
logBase Double
10 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nlines :: Double))

    formatLine :: Int -> Text -> Text
    formatLine :: Int -> Script -> Script
formatLine Int
n Script
l = String -> Script
pack (forall r. PrintfType r => String -> r
printf (String
"%" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
maxdigits forall a. Semigroup a => a -> a -> a
<> String
"d") Int
n) forall a. Semigroup a => a -> a -> a
<> Script
" > " forall a. Semigroup a => a -> a -> a
<> Script
l

-- Run script as described by the spec
-- Checks are performed, according to the renderer
-- Note that stdout from the script is suppressed, but not
-- stderr.
runTempScript :: FigureSpec -> PlotM ScriptResult
runTempScript :: FigureSpec -> PlotM ScriptResult
runTempScript spec :: FigureSpec
spec@FigureSpec {Bool
Int
String
[String]
[(Script, Script)]
Attr
Script
Renderer
SaveFormat
Executable
blockAttrs :: FigureSpec -> Attr
extraAttrs :: FigureSpec -> [(Script, Script)]
dependencies :: FigureSpec -> [String]
dpi :: FigureSpec -> Int
directory :: FigureSpec -> String
saveFormat :: FigureSpec -> SaveFormat
script :: FigureSpec -> Script
withSource :: FigureSpec -> Bool
caption :: FigureSpec -> Script
fsExecutable :: FigureSpec -> Executable
renderer_ :: FigureSpec -> Renderer
blockAttrs :: Attr
extraAttrs :: [(Script, Script)]
dependencies :: [String]
dpi :: Int
directory :: String
saveFormat :: SaveFormat
script :: Script
withSource :: Bool
caption :: Script
fsExecutable :: Executable
renderer_ :: Renderer
..} = do
  let checks :: [Script -> CheckResult]
checks = Renderer -> [Script -> CheckResult]
rendererChecks Renderer
renderer_
      checkResult :: CheckResult
checkResult = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ [Script -> CheckResult]
checks forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Script
script]
  case CheckResult
checkResult of
    CheckFailed Script
msg -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Script -> ScriptResult
ScriptChecksFailed Script
msg
    CheckResult
CheckPassed -> do
      String
scriptPath <- FigureSpec -> PlotM String
tempScriptPath FigureSpec
spec
      String
target <- FigureSpec -> PlotM String
figurePath FigureSpec
spec
      String
cwd <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RuntimeEnv -> String
envCWD

      let scriptWithCapture :: Script
scriptWithCapture = Renderer -> FigureSpec -> String -> Script
rendererCapture Renderer
renderer_ FigureSpec
spec String
target

      -- Note the use of a lock. This is a crude solution for issue #53, where
      -- multiple identical figures can cause a race condition to write to the 
      -- same output file.
      MVar ()
sem <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RuntimeEnv -> MVar ()
envIOLock
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
sem forall a b. (a -> b) -> a -> b
$ \()
_ -> String -> Script -> IO ()
T.writeFile String
scriptPath Script
scriptWithCapture
      let outputSpec :: OutputSpec
outputSpec =
            OutputSpec
              { oFigureSpec :: FigureSpec
oFigureSpec = FigureSpec
spec,
                oScriptPath :: String
oScriptPath = String
scriptPath,
                oFigurePath :: String
oFigurePath = String
target,
                oExecutable :: Executable
oExecutable = Executable
fsExecutable,
                oCWD :: String
oCWD = String
cwd
              }
      let command_ :: Script
command_ = Renderer -> OutputSpec -> Script
rendererCommand Renderer
renderer_ OutputSpec
outputSpec

      -- It is important that the CWD be inherited from the
      -- parent process. See #2.
      (ExitCode
ec, Script
_) <- String -> Script -> PlotM (ExitCode, Script)
runCommand String
cwd Script
command_
      case ExitCode
ec of
        ExitCode
ExitSuccess -> forall (m :: * -> *) a. Monad m => a -> m a
return ScriptResult
ScriptSuccess
        ExitFailure Int
code -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Script -> Int -> Script -> ScriptResult
ScriptFailure Script
command_ Int
code Script
script

-- | Determine the temp script path from Figure specifications
-- Note that for certain renderers, the appropriate file extension
-- is important.
tempScriptPath :: FigureSpec -> PlotM FilePath
tempScriptPath :: FigureSpec -> PlotM String
tempScriptPath fs :: FigureSpec
fs@FigureSpec {Bool
Int
String
[String]
[(Script, Script)]
Attr
Script
Renderer
SaveFormat
Executable
blockAttrs :: Attr
extraAttrs :: [(Script, Script)]
dependencies :: [String]
dpi :: Int
directory :: String
saveFormat :: SaveFormat
script :: Script
withSource :: Bool
caption :: Script
fsExecutable :: Executable
renderer_ :: Renderer
blockAttrs :: FigureSpec -> Attr
extraAttrs :: FigureSpec -> [(Script, Script)]
dependencies :: FigureSpec -> [String]
dpi :: FigureSpec -> Int
directory :: FigureSpec -> String
saveFormat :: FigureSpec -> SaveFormat
script :: FigureSpec -> Script
withSource :: FigureSpec -> Bool
caption :: FigureSpec -> Script
fsExecutable :: FigureSpec -> Executable
renderer_ :: FigureSpec -> Renderer
..} = do
  let ext :: String
ext = Renderer -> String
rendererScriptExtension Renderer
renderer_
  -- Note that this hash is only so that we are running scripts from unique
  -- file names; it does NOT determine whether this figure should
  -- be rendered or not.
  String
fp <- FigureSpec -> PlotM String
figurePath FigureSpec
fs
  let hashedPath :: String
hashedPath = String -> String
takeBaseName String
fp forall a. Semigroup a => a -> a -> a
<> String
ext
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ (String -> String -> String
</> String
hashedPath) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String
getTemporaryDirectory

-- | Determine the path to the source code that generated the figure.
-- To ensure that the source code path is distinguished from HTML figures, we use the extension .src.html.
sourceCodePath :: FigureSpec -> PlotM FilePath
sourceCodePath :: FigureSpec -> PlotM String
sourceCodePath = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> String
normalise forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> String -> String
replaceExtension String
".src.html") forall b c a. (b -> c) -> (a -> b) -> a -> c
. FigureSpec -> PlotM String
figurePath

-- | Hash of the content of a @FigureSpec@. Note that unlike usual hashes,
-- two @FigureSpec@ with the same @figureContentHash@ does not mean that they are equal!
--
-- Not all parts of a FigureSpec are related to running code.
-- For example, changing the caption should not require running the figure again.
figureContentHash :: FigureSpec -> PlotM Word
figureContentHash :: FigureSpec -> PlotM Word
figureContentHash FigureSpec {Bool
Int
String
[String]
[(Script, Script)]
Attr
Script
Renderer
SaveFormat
Executable
blockAttrs :: Attr
extraAttrs :: [(Script, Script)]
dependencies :: [String]
dpi :: Int
directory :: String
saveFormat :: SaveFormat
script :: Script
withSource :: Bool
caption :: Script
fsExecutable :: Executable
renderer_ :: Renderer
blockAttrs :: FigureSpec -> Attr
extraAttrs :: FigureSpec -> [(Script, Script)]
dependencies :: FigureSpec -> [String]
dpi :: FigureSpec -> Int
directory :: FigureSpec -> String
saveFormat :: FigureSpec -> SaveFormat
script :: FigureSpec -> Script
withSource :: FigureSpec -> Bool
caption :: FigureSpec -> Script
fsExecutable :: FigureSpec -> Executable
renderer_ :: FigureSpec -> Renderer
..} = do
  [Word]
dependenciesHash <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ String -> PlotM Word
fileHash forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
dependencies
  -- hash looks strange because instances only exist for 7-tuples or less
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
    forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$
      forall a. Hashable a => a -> Int
hash
        ( ( forall a. Enum a => a -> Int
fromEnum (Renderer -> Toolkit
rendererToolkit Renderer
renderer_),
            Script
script,
            forall a. Enum a => a -> Int
fromEnum SaveFormat
saveFormat,
            String
directory
          ),
          ( Int
dpi,
            [Word]
dependenciesHash,
            [(Script, Script)]
extraAttrs,
            forall a. Show a => a -> String
show Version
version -- Included version because capture scripts may change between releases
          )
        )

-- | Determine the path a figure should have.
-- The path for this file is unique to the content of the figure,
-- so that @figurePath@ can be used to determine whether a figure should
-- be rendered again or not.
figurePath :: FigureSpec -> PlotM FilePath
figurePath :: FigureSpec -> PlotM String
figurePath FigureSpec
spec = do
  Word
fh <- FigureSpec -> PlotM Word
figureContentHash FigureSpec
spec
  let ext :: String
ext = SaveFormat -> String
extension forall b c a. (b -> c) -> (a -> b) -> a -> c
. FigureSpec -> SaveFormat
saveFormat forall a b. (a -> b) -> a -> b
$ FigureSpec
spec
      -- MATLAB will refuse to process files that don't start with
      -- a letter so it is simplest to use filenames that start 
      -- with "pandocplot" throughout
      stem :: String
stem = forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> String -> String
addExtension String
ext forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => a -> a -> a
mappend String
"pandocplot" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Word
fh
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> String
normalise forall a b. (a -> b) -> a -> b
$ FigureSpec -> String
directory FigureSpec
spec String -> String -> String
</> String
stem

-- | Write the source code of a figure to an HTML file with appropriate syntax highlighting.
writeSource :: FigureSpec -> PlotM ()
writeSource :: FigureSpec -> StateT PlotState (ReaderT RuntimeEnv IO) ()
writeSource FigureSpec
spec = do
  let rdr :: Renderer
rdr = FigureSpec -> Renderer
renderer_ FigureSpec
spec
      language :: Script
language = Renderer -> Script
rendererLanguage Renderer
rdr
  String
scp <- FigureSpec -> PlotM String
sourceCodePath FigureSpec
spec
  let doc :: Pandoc
doc = Meta -> [Block] -> Pandoc
Pandoc forall a. Monoid a => a
mempty [Attr -> Script -> Block
CodeBlock (forall a. Monoid a => a
mempty, [Script
language], forall a. Monoid a => a
mempty) (FigureSpec -> Script
script FigureSpec
spec)]
      renderSource :: Template Script -> StateT PlotState (ReaderT RuntimeEnv IO) ()
renderSource = \Template Script
template -> do
        let opts :: WriterOptions
opts = forall a. Default a => a
def {writerTemplate :: Maybe (Template Script)
writerTemplate = forall a. a -> Maybe a
Just Template Script
template}
            -- Note that making the document self-contained is absolutely required so that the CSS for
            -- syntax highlighting is included directly in the document.
            t :: Script
t = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Monoid a => a
mempty) forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall a. PandocPure a -> Either PandocError a
runPure (forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m Script
writeHtml5String WriterOptions
opts Pandoc
doc forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). PandocMonad m => Script -> m Script
makeSelfContained)
        
        -- Note the use of a lock. This is a crude solution for issue #53, where
        -- multiple identical figures can cause a race condition to write to the 
        -- same output file.
        MVar ()
sem <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RuntimeEnv -> MVar ()
envIOLock
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
sem forall a b. (a -> b) -> a -> b
$ \()
_ -> String -> Script -> IO ()
T.writeFile String
scp Script
t

  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *). (MonadLogger m, MonadIO m) => Script -> m ()
err forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Script
pack) Template Script -> StateT PlotState (ReaderT RuntimeEnv IO) ()
renderSource forall a b. (a -> b) -> a -> b
$ forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(TemplateMonad m, TemplateTarget a) =>
String -> Script -> m (Either String (Template a))
compileTemplate forall a. Monoid a => a
mempty Script
sourceTemplate

sourceTemplate :: Text
sourceTemplate :: Script
sourceTemplate = String -> Script
pack $(sourceTemplate_)