{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Text.Pandoc.Filter.Plot.Scripting
( ScriptResult(..)
, runTempScript
, runScriptIfNecessary
, toImage
) where
import Control.Monad.Reader
import Data.Hashable (hash)
import Data.Maybe (fromMaybe)
import Data.Text (Text, pack, unpack)
import qualified Data.Text.IO as T
import System.Directory (createDirectoryIfMissing,
doesFileExist, getTemporaryDirectory)
import System.Exit (ExitCode (..))
import System.FilePath (addExtension,
normalise, replaceExtension,
takeDirectory, (</>))
import Text.Pandoc.Builder (fromList, imageWith, link,
para, toList)
import Text.Pandoc.Definition (Block (..), Format)
import Text.Pandoc.Filter.Plot.Parse (captionReader)
import Text.Pandoc.Filter.Plot.Renderers
import Text.Pandoc.Filter.Plot.Monad
runScriptIfNecessary :: FigureSpec -> PlotM ScriptResult
runScriptIfNecessary :: FigureSpec -> PlotM ScriptResult
runScriptIfNecessary spec :: FigureSpec
spec = do
IO () -> ReaderT RuntimeEnv IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT RuntimeEnv IO ())
-> IO () -> ReaderT RuntimeEnv IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> IO ()) -> (FilePath -> FilePath) -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
takeDirectory (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FigureSpec -> FilePath
figurePath FigureSpec
spec
Bool
fileAlreadyExists <- IO Bool -> ReaderT RuntimeEnv IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ReaderT RuntimeEnv IO Bool)
-> (FilePath -> IO Bool) -> FilePath -> ReaderT RuntimeEnv IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO Bool
doesFileExist (FilePath -> ReaderT RuntimeEnv IO Bool)
-> FilePath -> ReaderT RuntimeEnv IO Bool
forall a b. (a -> b) -> a -> b
$ FigureSpec -> FilePath
figurePath FigureSpec
spec
ScriptResult
result <- if Bool
fileAlreadyExists
then ScriptResult -> PlotM ScriptResult
forall (m :: * -> *) a. Monad m => a -> m a
return ScriptResult
ScriptSuccess
else FigureSpec -> PlotM ScriptResult
runTempScript FigureSpec
spec
ScriptResult -> ReaderT RuntimeEnv IO ()
logScriptResult ScriptResult
result
case ScriptResult
result of
ScriptSuccess -> IO ScriptResult -> PlotM ScriptResult
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ScriptResult -> PlotM ScriptResult)
-> IO ScriptResult -> PlotM ScriptResult
forall a b. (a -> b) -> a -> b
$ FilePath -> Text -> IO ()
T.writeFile (FigureSpec -> FilePath
sourceCodePath FigureSpec
spec) (FigureSpec -> Text
script FigureSpec
spec) IO () -> IO ScriptResult -> IO ScriptResult
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ScriptResult -> IO ScriptResult
forall (m :: * -> *) a. Monad m => a -> m a
return ScriptResult
ScriptSuccess
other :: ScriptResult
other -> ScriptResult -> PlotM ScriptResult
forall (m :: * -> *) a. Monad m => a -> m a
return ScriptResult
other
where
logScriptResult :: ScriptResult -> ReaderT RuntimeEnv IO ()
logScriptResult ScriptSuccess = () -> ReaderT RuntimeEnv IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
logScriptResult r :: ScriptResult
r = Text -> ReaderT RuntimeEnv IO ()
err (Text -> ReaderT RuntimeEnv IO ())
-> (ScriptResult -> Text)
-> ScriptResult
-> ReaderT RuntimeEnv IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
pack (FilePath -> Text)
-> (ScriptResult -> FilePath) -> ScriptResult -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptResult -> FilePath
forall a. Show a => a -> FilePath
show (ScriptResult -> ReaderT RuntimeEnv IO ())
-> ScriptResult -> ReaderT RuntimeEnv IO ()
forall a b. (a -> b) -> a -> b
$ ScriptResult
r
data ScriptResult
= ScriptSuccess
| ScriptChecksFailed Text
| ScriptFailure Text Int
| ToolkitNotInstalled Toolkit
instance Show ScriptResult where
show :: ScriptResult -> FilePath
show ScriptSuccess = "Script success."
show (ScriptChecksFailed msg :: Text
msg) = Text -> FilePath
unpack (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ "Script checks failed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg
show (ScriptFailure msg :: Text
msg ec :: Int
ec) = [FilePath] -> FilePath
forall a. Monoid a => [a] -> a
mconcat ["Script failed with exit code ", Int -> FilePath
forall a. Show a => a -> FilePath
show Int
ec, " and the following message: ", Text -> FilePath
unpack Text
msg]
show (ToolkitNotInstalled tk :: Toolkit
tk) = (Toolkit -> FilePath
forall a. Show a => a -> FilePath
show Toolkit
tk) FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> " toolkit not installed."
runTempScript :: FigureSpec -> PlotM ScriptResult
runTempScript :: FigureSpec -> PlotM ScriptResult
runTempScript spec :: FigureSpec
spec@FigureSpec{..} = do
let checks :: [Text -> CheckResult]
checks = Toolkit -> [Text -> CheckResult]
scriptChecks Toolkit
toolkit
checkResult :: CheckResult
checkResult = [CheckResult] -> CheckResult
forall a. Monoid a => [a] -> a
mconcat ([CheckResult] -> CheckResult) -> [CheckResult] -> CheckResult
forall a b. (a -> b) -> a -> b
$ [Text -> CheckResult]
checks [Text -> CheckResult] -> [Text] -> [CheckResult]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Text
script]
case CheckResult
checkResult of
CheckFailed msg :: Text
msg -> ScriptResult -> PlotM ScriptResult
forall (m :: * -> *) a. Monad m => a -> m a
return (ScriptResult -> PlotM ScriptResult)
-> ScriptResult -> PlotM ScriptResult
forall a b. (a -> b) -> a -> b
$ Text -> ScriptResult
ScriptChecksFailed Text
msg
CheckPassed -> do
FilePath
scriptPath <- FigureSpec -> PlotM FilePath
tempScriptPath FigureSpec
spec
let captureFragment :: Text
captureFragment = (Toolkit -> FigureSpec -> FilePath -> Text
capture Toolkit
toolkit) FigureSpec
spec (FigureSpec -> FilePath
figurePath FigureSpec
spec)
scriptWithCapture :: Text
scriptWithCapture = if (Toolkit
toolkit Toolkit -> Toolkit -> Bool
forall a. Eq a => a -> a -> Bool
== Toolkit
GNUPlot)
then [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [Text
captureFragment, "\n", Text
script]
else [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [Text
script, "\n", Text
captureFragment]
IO () -> ReaderT RuntimeEnv IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT RuntimeEnv IO ())
-> IO () -> ReaderT RuntimeEnv IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Text -> IO ()
T.writeFile FilePath
scriptPath Text
scriptWithCapture
let outputSpec :: OutputSpec
outputSpec = OutputSpec :: FigureSpec -> FilePath -> FilePath -> OutputSpec
OutputSpec { oFigureSpec :: FigureSpec
oFigureSpec = FigureSpec
spec
, oScriptPath :: FilePath
oScriptPath = FilePath
scriptPath
, oFigurePath :: FilePath
oFigurePath = FigureSpec -> FilePath
figurePath FigureSpec
spec
}
Text
command_ <- Toolkit -> OutputSpec -> PlotM Text
command Toolkit
toolkit OutputSpec
outputSpec
(ec :: ExitCode
ec, _) <- Text -> PlotM (ExitCode, Text)
runCommand Text
command_
case ExitCode
ec of
ExitSuccess -> ScriptResult -> PlotM ScriptResult
forall (m :: * -> *) a. Monad m => a -> m a
return ScriptResult
ScriptSuccess
ExitFailure code :: Int
code -> do
Bool
toolkitInstalled <- Toolkit -> ReaderT RuntimeEnv IO Bool
toolkitAvailable Toolkit
toolkit
if Bool
toolkitInstalled
then ScriptResult -> PlotM ScriptResult
forall (m :: * -> *) a. Monad m => a -> m a
return (ScriptResult -> PlotM ScriptResult)
-> ScriptResult -> PlotM ScriptResult
forall a b. (a -> b) -> a -> b
$ Text -> Int -> ScriptResult
ScriptFailure Text
command_ Int
code
else ScriptResult -> PlotM ScriptResult
forall (m :: * -> *) a. Monad m => a -> m a
return (ScriptResult -> PlotM ScriptResult)
-> ScriptResult -> PlotM ScriptResult
forall a b. (a -> b) -> a -> b
$ Toolkit -> ScriptResult
ToolkitNotInstalled Toolkit
toolkit
toImage :: Format
-> FigureSpec
-> Block
toImage :: Format -> FigureSpec -> Block
toImage fmt :: Format
fmt spec :: FigureSpec
spec = [Block] -> Block
forall a. [a] -> a
head ([Block] -> Block)
-> (Many Block -> [Block]) -> Many Block -> Block
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Many Block -> [Block]
forall a. Many a -> [a]
toList (Many Block -> Block) -> Many Block -> Block
forall a b. (a -> b) -> a -> b
$ Inlines -> Many Block
para (Inlines -> Many Block) -> Inlines -> Many Block
forall a b. (a -> b) -> a -> b
$ Attr -> Text -> Text -> Inlines -> Inlines
imageWith Attr
attrs' (FilePath -> Text
pack FilePath
target') "fig:" Inlines
caption'
where
attrs' :: Attr
attrs' = FigureSpec -> Attr
blockAttrs FigureSpec
spec
target' :: FilePath
target' = FigureSpec -> FilePath
figurePath FigureSpec
spec
withSource' :: Bool
withSource' = FigureSpec -> Bool
withSource FigureSpec
spec
srcLink :: Inlines
srcLink = Text -> Text -> Inlines -> Inlines
link (FilePath -> Text
pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> FilePath
replaceExtension FilePath
target' ".txt") Text
forall a. Monoid a => a
mempty "Source code"
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
srcLink, ")"]
caption' :: Inlines
caption' = if Bool
withSource' then Inlines
captionText Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
captionLinks else Inlines
captionText
tempScriptPath :: FigureSpec -> PlotM FilePath
tempScriptPath :: FigureSpec -> PlotM FilePath
tempScriptPath FigureSpec{..} = do
let ext :: FilePath
ext = Toolkit -> FilePath
scriptExtension Toolkit
toolkit
let hashedPath :: FilePath
hashedPath = "pandocplot" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> (Int -> FilePath
forall a. Show a => a -> FilePath
show (Int -> FilePath) -> (Text -> Int) -> Text -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int
forall a. Num a => a -> a
abs (Int -> Int) -> (Text -> Int) -> Text -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Int
forall a. Hashable a => a -> Int
hash (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ Text
script) FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
ext
IO FilePath -> PlotM FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> PlotM FilePath) -> IO FilePath -> PlotM FilePath
forall a b. (a -> b) -> a -> b
$ (FilePath -> FilePath -> FilePath
</> FilePath
hashedPath) (FilePath -> FilePath) -> IO FilePath -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO FilePath
getTemporaryDirectory
sourceCodePath :: FigureSpec -> FilePath
sourceCodePath :: FigureSpec -> FilePath
sourceCodePath = FilePath -> FilePath
normalise (FilePath -> FilePath)
-> (FigureSpec -> FilePath) -> FigureSpec -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> FilePath -> FilePath)
-> FilePath -> FilePath -> FilePath
forall a b c. (a -> b -> c) -> b -> a -> c
flip FilePath -> FilePath -> FilePath
replaceExtension ".txt" (FilePath -> FilePath)
-> (FigureSpec -> FilePath) -> FigureSpec -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FigureSpec -> FilePath
figurePath
figurePath :: FigureSpec -> FilePath
figurePath :: FigureSpec -> FilePath
figurePath spec :: FigureSpec
spec = FilePath -> FilePath
normalise (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FigureSpec -> FilePath
directory FigureSpec
spec FilePath -> FilePath -> FilePath
</> FigureSpec -> FilePath
stem FigureSpec
spec
where
stem :: FigureSpec -> FilePath
stem = (FilePath -> FilePath -> FilePath)
-> FilePath -> FilePath -> FilePath
forall a b c. (a -> b -> c) -> b -> a -> c
flip FilePath -> FilePath -> FilePath
addExtension FilePath
ext (FilePath -> FilePath)
-> (FigureSpec -> FilePath) -> FigureSpec -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> FilePath
forall a. Show a => a -> FilePath
show (Int -> FilePath) -> (FigureSpec -> Int) -> FigureSpec -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FigureSpec -> Int
figureContentHash
ext :: FilePath
ext = SaveFormat -> FilePath
extension (SaveFormat -> FilePath)
-> (FigureSpec -> SaveFormat) -> FigureSpec -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FigureSpec -> SaveFormat
saveFormat (FigureSpec -> FilePath) -> FigureSpec -> FilePath
forall a b. (a -> b) -> a -> b
$ FigureSpec
spec