{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Text.Pandoc.Filter.Plot.Monad
( Configuration (..),
PlotM,
RuntimeEnv (..),
PlotState (..),
runPlotM,
mapConcurrentlyN,
runCommand,
withPrependedPath,
throwStrictError,
fileHash,
executable,
Verbosity (..),
LogSink (..),
debug,
err,
warning,
info,
liftIO,
ask,
asks,
asksConfig,
module Text.Pandoc.Filter.Plot.Monad.Types,
)
where
import Control.Concurrent.Async.Lifted (mapConcurrently)
import Control.Concurrent.MVar (MVar, newMVar, putMVar, takeMVar)
import Control.Concurrent.QSemN
( QSemN,
newQSemN,
signalQSemN,
waitQSemN,
)
import Control.Exception.Lifted (bracket, bracket_)
import Control.Monad.Reader
( MonadIO (liftIO),
MonadReader (ask),
ReaderT (runReaderT),
asks,
)
import Control.Monad.State.Strict
( MonadState (get, put),
StateT,
evalStateT,
)
import Data.ByteString.Lazy (toStrict)
import Data.Hashable (hash)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Text (Text, pack, unpack)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import System.Directory
( doesFileExist,
getCurrentDirectory,
getModificationTime,
)
import System.Environment (getEnv, setEnv)
import System.Exit (ExitCode (..), exitFailure)
import System.Process.Typed
( byteStringInput,
byteStringOutput,
nullStream,
readProcessStderr,
setStderr,
setStdin,
setStdout,
setWorkingDir,
shell,
)
import Text.Pandoc.Definition (Format (..))
import Text.Pandoc.Filter.Plot.Monad.Logging
( LogSink (..),
Logger,
MonadLogger (..),
Verbosity (..),
debug,
err,
info,
strict,
terminateLogging,
warning,
withLogger,
)
import Text.Pandoc.Filter.Plot.Monad.Types
import Prelude hiding (fst, log, snd)
type PlotM = StateT PlotState (ReaderT RuntimeEnv IO)
instance MonadLogger PlotM where
askLogger :: PlotM Logger
askLogger = forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RuntimeEnv -> Logger
envLogger
data RuntimeEnv = RuntimeEnv
{ RuntimeEnv -> Maybe Format
envFormat :: Maybe Format,
RuntimeEnv -> Configuration
envConfig :: Configuration,
RuntimeEnv -> Logger
envLogger :: Logger,
RuntimeEnv -> String
envCWD :: FilePath,
RuntimeEnv -> MVar ()
envIOLock :: MVar ()
}
asksConfig :: (Configuration -> a) -> PlotM a
asksConfig :: forall a. (Configuration -> a) -> PlotM a
asksConfig Configuration -> a
f = forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Configuration -> a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. RuntimeEnv -> Configuration
envConfig)
runPlotM :: Maybe Format -> Configuration -> PlotM a -> IO a
runPlotM :: forall a. Maybe Format -> Configuration -> PlotM a -> IO a
runPlotM Maybe Format
fmt Configuration
conf PlotM a
v = do
String
cwd <- IO String
getCurrentDirectory
MVar ()
sem <- forall a. a -> IO (MVar a)
newMVar ()
PlotState
st <-
MVar (Map String FileHash) -> PlotState
PlotState forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (MVar a)
newMVar forall a. Monoid a => a
mempty
let verbosity :: Verbosity
verbosity = Configuration -> Verbosity
logVerbosity Configuration
conf
sink :: LogSink
sink = Configuration -> LogSink
logSink Configuration
conf
forall a. Verbosity -> LogSink -> (Logger -> IO a) -> IO a
withLogger Verbosity
verbosity LogSink
sink forall a b. (a -> b) -> a -> b
$
\Logger
logger -> forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT PlotM a
v PlotState
st) (Maybe Format
-> Configuration -> Logger -> String -> MVar () -> RuntimeEnv
RuntimeEnv Maybe Format
fmt Configuration
conf Logger
logger String
cwd MVar ()
sem)
mapConcurrentlyN :: Traversable t => Int -> (a -> PlotM b) -> t a -> PlotM (t b)
mapConcurrentlyN :: forall (t :: * -> *) a b.
Traversable t =>
Int -> (a -> PlotM b) -> t a -> PlotM (t b)
mapConcurrentlyN Int
n a -> PlotM b
f t a
xs = do
QSemN
sem <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int -> IO QSemN
newQSemN Int
n
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, MonadBaseControl IO m) =>
(a -> m b) -> t a -> m (t b)
mapConcurrently (forall a. QSemN -> PlotM a -> PlotM a
with QSemN
sem forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> PlotM b
f) t a
xs
where
with :: QSemN -> PlotM a -> PlotM a
with :: forall a. QSemN -> PlotM a -> PlotM a
with QSemN
s = forall (m :: * -> *) a b c.
MonadBaseControl IO m =>
m a -> m b -> m c -> m c
bracket_ (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ QSemN -> Int -> IO ()
waitQSemN QSemN
s Int
1) (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ QSemN -> Int -> IO ()
signalQSemN QSemN
s Int
1)
runCommand ::
FilePath ->
Text ->
PlotM (ExitCode, Text)
runCommand :: String -> Text -> PlotM (ExitCode, Text)
runCommand String
wordir Text
command = do
(ExitCode
ec, ByteString
processOutput') <-
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) stdin stdout stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdout stderrIgnored
-> m (ExitCode, ByteString)
readProcessStderr forall a b. (a -> b) -> a -> b
$
forall stdin stdin0 stdout stderr.
StreamSpec 'STInput stdin
-> ProcessConfig stdin0 stdout stderr
-> ProcessConfig stdin stdout stderr
setStdin (ByteString -> StreamSpec 'STInput ()
byteStringInput ByteString
"") forall a b. (a -> b) -> a -> b
$
forall stdout stdin stdout0 stderr.
StreamSpec 'STOutput stdout
-> ProcessConfig stdin stdout0 stderr
-> ProcessConfig stdin stdout stderr
setStdout forall (anyStreamType :: StreamType). StreamSpec anyStreamType ()
nullStream forall a b. (a -> b) -> a -> b
$
forall stderr stdin stdout stderr0.
StreamSpec 'STOutput stderr
-> ProcessConfig stdin stdout stderr0
-> ProcessConfig stdin stdout stderr
setStderr StreamSpec 'STOutput (STM ByteString)
byteStringOutput forall a b. (a -> b) -> a -> b
$
forall stdin stdout stderr.
String
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setWorkingDir String
wordir forall a b. (a -> b) -> a -> b
$
String -> ProcessConfig () () ()
shell (Text -> String
unpack Text
command)
let processOutput :: Text
processOutput = OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
toStrict ByteString
processOutput'
logFunc :: Text -> StateT PlotState (ReaderT RuntimeEnv IO) ()
logFunc =
if ExitCode
ec forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
then forall (m :: * -> *). (MonadLogger m, MonadIO m) => Text -> m ()
debug
else forall (m :: * -> *). (MonadLogger m, MonadIO m) => Text -> m ()
err
message :: Text
message =
[Text] -> Text
T.unlines
[ Text
"Running command",
Text
" " forall a. Semigroup a => a -> a -> a
<> Text
command,
Text
"ended with exit code " forall a. Semigroup a => a -> a -> a
<> (String -> Text
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
$ ExitCode
ec)
]
errorMessage :: Text
errorMessage =
if Text
processOutput forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
mempty
then forall a. Monoid a => a
mempty
else
[Text] -> Text
T.unlines
[ Text
"*******",
Text
processOutput,
Text
"*******"
]
Text -> StateT PlotState (ReaderT RuntimeEnv IO) ()
logFunc forall a b. (a -> b) -> a -> b
$ Text
message forall a. Semigroup a => a -> a -> a
<> Text
errorMessage
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode
ec, Text
processOutput)
withPrependedPath :: FilePath -> PlotM a -> PlotM a
withPrependedPath :: forall a. String -> PlotM a -> PlotM a
withPrependedPath String
dir PlotM a
f = do
String
pathVar <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO String
getEnv String
"PATH"
let pathVarPrepended :: String
pathVarPrepended = forall a. Monoid a => [a] -> a
mconcat [String
dir, String
";", String
pathVar]
forall (m :: * -> *) a b c.
MonadBaseControl IO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
(forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
setEnv String
"PATH" String
pathVarPrepended)
(\()
_ -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
setEnv String
"PATH" String
pathVar)
(forall a b. a -> b -> a
const PlotM a
f)
throwStrictError :: Text -> PlotM ()
throwStrictError :: Text -> StateT PlotState (ReaderT RuntimeEnv IO) ()
throwStrictError Text
msg = do
forall (m :: * -> *). (MonadLogger m, MonadIO m) => Text -> m ()
strict Text
msg
Logger
logger <- forall (m :: * -> *). MonadLogger m => m Logger
askLogger
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> IO ()
terminateLogging Logger
logger forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. IO a
exitFailure
type FileHash = Word
data PlotState
= PlotState
(MVar (Map FilePath FileHash))
fileHash :: FilePath -> PlotM FileHash
fileHash :: String -> PlotM FileHash
fileHash String
path = do
PlotState MVar (Map String FileHash)
varHashes <- forall s (m :: * -> *). MonadState s m => m s
get
Map String FileHash
hashes <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
takeMVar MVar (Map String FileHash)
varHashes
(FileHash
fh, Map String FileHash
hashes') <- case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
path Map String FileHash
hashes of
Maybe FileHash
Nothing -> do
forall (m :: * -> *). (MonadLogger m, MonadIO m) => Text -> m ()
debug forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [Text
"Calculating hash of dependency ", String -> Text
pack String
path]
FileHash
fh <- String -> PlotM FileHash
fileHash' String
path
let hashes' :: Map String FileHash
hashes' = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
path FileHash
fh Map String FileHash
hashes
forall (m :: * -> *) a. Monad m => a -> m a
return (FileHash
fh, Map String FileHash
hashes')
Just FileHash
h -> do
forall (m :: * -> *). (MonadLogger m, MonadIO m) => Text -> m ()
debug forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [Text
"Hash of dependency ", String -> Text
pack String
path, Text
" already calculated."]
forall (m :: * -> *) a. Monad m => a -> m a
return (FileHash
h, Map String FileHash
hashes)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO ()
putMVar MVar (Map String FileHash)
varHashes Map String FileHash
hashes'
forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ MVar (Map String FileHash) -> PlotState
PlotState MVar (Map String FileHash)
varHashes
forall (m :: * -> *) a. Monad m => a -> m a
return FileHash
fh
where
fileHash' :: FilePath -> PlotM FileHash
fileHash' :: String -> PlotM FileHash
fileHash' String
fp = do
Bool
fileExists <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesFileExist String
fp
if Bool
fileExists
then forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Hashable a => a -> Int
hash forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO UTCTime
getModificationTime forall a b. (a -> b) -> a -> b
$ String
fp
else forall (m :: * -> *). (MonadLogger m, MonadIO m) => Text -> m ()
err (forall a. Monoid a => [a] -> a
mconcat [Text
"Dependency ", String -> Text
pack String
fp, Text
" does not exist."]) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return FileHash
0
executable :: Toolkit -> PlotM Executable
executable :: Toolkit -> PlotM Executable
executable Toolkit
tk = Toolkit -> StateT PlotState (ReaderT RuntimeEnv IO) String
exeSelector Toolkit
tk forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Executable
exeFromPath
where
exeSelector :: Toolkit -> StateT PlotState (ReaderT RuntimeEnv IO) String
exeSelector Toolkit
Matplotlib = forall a. (Configuration -> a) -> PlotM a
asksConfig Configuration -> String
matplotlibExe
exeSelector Toolkit
PlotlyPython = forall a. (Configuration -> a) -> PlotM a
asksConfig Configuration -> String
plotlyPythonExe
exeSelector Toolkit
PlotlyR = forall a. (Configuration -> a) -> PlotM a
asksConfig Configuration -> String
plotlyRExe
exeSelector Toolkit
Matlab = forall a. (Configuration -> a) -> PlotM a
asksConfig Configuration -> String
matlabExe
exeSelector Toolkit
Mathematica = forall a. (Configuration -> a) -> PlotM a
asksConfig Configuration -> String
mathematicaExe
exeSelector Toolkit
Octave = forall a. (Configuration -> a) -> PlotM a
asksConfig Configuration -> String
octaveExe
exeSelector Toolkit
GGPlot2 = forall a. (Configuration -> a) -> PlotM a
asksConfig Configuration -> String
ggplot2Exe
exeSelector Toolkit
GNUPlot = forall a. (Configuration -> a) -> PlotM a
asksConfig Configuration -> String
gnuplotExe
exeSelector Toolkit
Graphviz = forall a. (Configuration -> a) -> PlotM a
asksConfig Configuration -> String
graphvizExe
exeSelector Toolkit
Bokeh = forall a. (Configuration -> a) -> PlotM a
asksConfig Configuration -> String
bokehExe
exeSelector Toolkit
Plotsjl = forall a. (Configuration -> a) -> PlotM a
asksConfig Configuration -> String
plotsjlExe
exeSelector Toolkit
PlantUML = forall a. (Configuration -> a) -> PlotM a
asksConfig Configuration -> String
plantumlExe
exeSelector Toolkit
SageMath = forall a. (Configuration -> a) -> PlotM a
asksConfig Configuration -> String
sagemathExe
data Configuration = Configuration
{
Configuration -> String
defaultDirectory :: !FilePath,
Configuration -> Bool
defaultWithSource :: !Bool,
Configuration -> Int
defaultDPI :: !Int,
Configuration -> SaveFormat
defaultSaveFormat :: !SaveFormat,
Configuration -> [String]
defaultDependencies :: ![FilePath],
Configuration -> Format
captionFormat :: !Format,
Configuration -> Text
sourceCodeLabel :: !Text,
Configuration -> Bool
strictMode :: !Bool,
Configuration -> Verbosity
logVerbosity :: !Verbosity,
Configuration -> LogSink
logSink :: !LogSink,
Configuration -> Text
matplotlibPreamble :: !Script,
Configuration -> Text
plotlyPythonPreamble :: !Script,
Configuration -> Text
plotlyRPreamble :: !Script,
Configuration -> Text
matlabPreamble :: !Script,
Configuration -> Text
mathematicaPreamble :: !Script,
Configuration -> Text
octavePreamble :: !Script,
Configuration -> Text
ggplot2Preamble :: !Script,
Configuration -> Text
gnuplotPreamble :: !Script,
Configuration -> Text
graphvizPreamble :: !Script,
Configuration -> Text
bokehPreamble :: !Script,
Configuration -> Text
plotsjlPreamble :: !Script,
Configuration -> Text
plantumlPreamble :: !Script,
Configuration -> Text
sagemathPreamble :: !Script,
Configuration -> String
matplotlibExe :: !FilePath,
Configuration -> String
matlabExe :: !FilePath,
Configuration -> String
plotlyPythonExe :: !FilePath,
Configuration -> String
plotlyRExe :: !FilePath,
Configuration -> String
mathematicaExe :: !FilePath,
Configuration -> String
octaveExe :: !FilePath,
Configuration -> String
ggplot2Exe :: !FilePath,
Configuration -> String
gnuplotExe :: !FilePath,
Configuration -> String
graphvizExe :: !FilePath,
Configuration -> String
bokehExe :: !FilePath,
Configuration -> String
plotsjlExe :: !FilePath,
Configuration -> String
plantumlExe :: !FilePath,
Configuration -> String
sagemathExe :: !FilePath,
Configuration -> Text
matplotlibCmdArgs :: !Text,
Configuration -> Text
matlabCmdArgs :: !Text,
Configuration -> Text
plotlyPythonCmdArgs :: !Text,
Configuration -> Text
plotlyRCmdArgs :: !Text,
Configuration -> Text
mathematicaCmdArgs :: !Text,
Configuration -> Text
octaveCmdArgs :: !Text,
Configuration -> Text
ggplot2CmdArgs :: !Text,
Configuration -> Text
gnuplotCmdArgs :: !Text,
Configuration -> Text
graphvizCmdArgs :: !Text,
Configuration -> Text
bokehCmdArgs :: !Text,
Configuration -> Text
plotsjlCmdArgs :: !Text,
Configuration -> Text
plantumlCmdArgs :: !Text,
Configuration -> Text
sagemathCmdArgs :: !Text,
Configuration -> Bool
matplotlibTightBBox :: !Bool,
Configuration -> Bool
matplotlibTransparent :: !Bool
}
deriving (Configuration -> Configuration -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Configuration -> Configuration -> Bool
$c/= :: Configuration -> Configuration -> Bool
== :: Configuration -> Configuration -> Bool
$c== :: Configuration -> Configuration -> Bool
Eq, Int -> Configuration -> ShowS
[Configuration] -> ShowS
Configuration -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Configuration] -> ShowS
$cshowList :: [Configuration] -> ShowS
show :: Configuration -> String
$cshow :: Configuration -> String
showsPrec :: Int -> Configuration -> ShowS
$cshowsPrec :: Int -> Configuration -> ShowS
Show)