{-# LANGUAGE MultiWayIf #-}
{-|
Copyright   : Written by David Himmelstrup
License     : Unlicense
Maintainer  : lemmih@gmail.com
Stability   : experimental
Portability : POSIX

Internal tools for rastering SVGs and rendering videos. You are unlikely
to ever directly use the functions in this module.

-}
module Reanimate.Render
  ( render
  , renderSvgs
  , renderSvgs_
  , renderSnippets        -- :: Animation -> IO ()
  , renderLimitedFrames
  , Format(..)
  , Raster(..)
  , Width, Height, FPS
  , requireRaster         -- :: Raster -> IO Raster
  , selectRaster          -- :: Raster -> IO Raster
  , applyRaster           -- :: Raster -> FilePath -> IO ()
  ) where

import           Control.Concurrent
import           Control.Exception
import           Control.Monad             (forM_, forever, unless, void, when)
import           Data.Either               (isRight)
import           Data.Function             (fix)
import qualified Data.Text                 as T
import qualified Data.Text.IO              as T
import           Data.Time
import           Graphics.SvgTree          (Number (..))
import           Numeric                   (showFFloat)
import           Reanimate.Animation       (Animation, duration, frameAt, renderSvg)
import           Reanimate.Driver.Check    (hasInkscape, hasMagick, hasRSvg)
import           Reanimate.Driver.Magick   (magickCmd)
import           Reanimate.Misc
import           Reanimate.Parameters
import           System.Console.ANSI.Codes (clearFromCursorToLineEndCode)
import           System.Directory          (doesFileExist, removeFile)
import           System.Exit               (ExitCode (ExitFailure), exitWith)
import           System.FileLock           (SharedExclusive (..), unlockFile, withTryFileLock)
import           System.FilePath           (replaceExtension, (<.>), (</>))
import           System.IO
import           System.IO.Temp            (createTempDirectory, getCanonicalTemporaryDirectory)
import           Text.Printf               (printf)

idempotentFile :: FilePath -> IO () -> IO ()
idempotentFile :: FilePath -> IO () -> IO ()
idempotentFile FilePath
path IO ()
action = do
    Maybe ()
_ <- FilePath -> SharedExclusive -> (FileLock -> IO ()) -> IO (Maybe ())
forall a.
FilePath -> SharedExclusive -> (FileLock -> IO a) -> IO (Maybe a)
withTryFileLock FilePath
lockFile SharedExclusive
Exclusive ((FileLock -> IO ()) -> IO (Maybe ()))
-> (FileLock -> IO ()) -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ \FileLock
lock -> do
      Bool
haveFile <- FilePath -> IO Bool
doesFileExist FilePath
path
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
haveFile IO ()
action
      FileLock -> IO ()
unlockFile FileLock
lock
      Either SomeException ()
_ <- IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
try (FilePath -> IO ()
removeFile FilePath
lockFile) :: IO (Either SomeException ())
      () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    lockFile :: FilePath
lockFile = FilePath
path FilePath -> FilePath -> FilePath
<.> FilePath
"lock"

-- | Generate SVGs at 60fps and put them in a folder.
renderSvgs :: FilePath -> Int -> Bool -> Animation -> IO ()
renderSvgs :: FilePath -> Int -> Bool -> Animation -> IO ()
renderSvgs FilePath
folder Int
offset Bool
_prettyPrint Animation
ani = do
  Int -> IO ()
forall a. Show a => a -> IO ()
print Int
frameCount
  MVar ()
lock <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
  (ErrorCall -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle ErrorCall -> IO ()
forall b. ErrorCall -> IO b
errHandler (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Int] -> (Int -> IO ()) -> IO ()
forall a. [a] -> (a -> IO ()) -> IO ()
concurrentForM_ (Int -> Int -> [Int]
frameOrder Int
rate Int
frameCount) ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
nth' -> do
    let nth :: Int
nth = (Int
nth'Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
offset) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
frameCount
        now :: Duration
now = (Animation -> Duration
duration Animation
ani Duration -> Duration -> Duration
forall a. Fractional a => a -> a -> a
/ (Int -> Duration
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
frameCount Duration -> Duration -> Duration
forall a. Num a => a -> a -> a
- Duration
1)) Duration -> Duration -> Duration
forall a. Num a => a -> a -> a
* Int -> Duration
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nth
        frame :: SVG
frame = Duration -> Animation -> SVG
frameAt (if Int
frameCount Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1 then Duration
0 else Duration
now) Animation
ani
        path :: FilePath
path = FilePath
folder FilePath -> FilePath -> FilePath
</> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
nth FilePath -> FilePath -> FilePath
<.> FilePath
"svg"
        svg :: FilePath
svg = Maybe Number -> Maybe Number -> SVG -> FilePath
renderSvg Maybe Number
forall a. Maybe a
Nothing Maybe Number
forall a. Maybe a
Nothing SVG
frame

    FilePath -> IO () -> IO ()
idempotentFile FilePath
path (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      FilePath -> FilePath -> IO ()
writeFile FilePath
path FilePath
svg
    MVar () -> (() -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
lock ((() -> IO ()) -> IO ()) -> (() -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \()
_ -> do
      Int -> IO ()
forall a. Show a => a -> IO ()
print Int
nth
      Handle -> IO ()
hFlush Handle
stdout
 where
  rate :: Int
rate       = Int
60
  frameCount :: Int
frameCount = Duration -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (Animation -> Duration
duration Animation
ani Duration -> Duration -> Duration
forall a. Num a => a -> a -> a
* Int -> Duration
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
rate) :: Int
  errHandler :: ErrorCall -> IO b
errHandler (ErrorCall FilePath
msg) = do
    Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr FilePath
msg
    ExitCode -> IO b
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)

renderSvgs_ :: Animation -> (Int -> FilePath -> IO ()) -> IO ()
renderSvgs_ :: Animation -> (Int -> FilePath -> IO ()) -> IO ()
renderSvgs_ Animation
ani Int -> FilePath -> IO ()
cb = do
  FilePath
tmp <- IO FilePath
getCanonicalTemporaryDirectory
  FilePath
tmpDir <- FilePath -> FilePath -> IO FilePath
createTempDirectory FilePath
tmp FilePath
"reanimate"
  MVar ()
lock <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
  (ErrorCall -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle ErrorCall -> IO ()
forall b. ErrorCall -> IO b
errHandler (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Int] -> (Int -> IO ()) -> IO ()
forall a. [a] -> (a -> IO ()) -> IO ()
concurrentForM_ (Int -> Int -> [Int]
frameOrder Int
rate Int
frameCount) ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
nth' -> do
    let nth :: Int
nth = (Int
nth') Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
frameCount
        now :: Duration
now = (Animation -> Duration
duration Animation
ani Duration -> Duration -> Duration
forall a. Fractional a => a -> a -> a
/ (Int -> Duration
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
frameCount Duration -> Duration -> Duration
forall a. Num a => a -> a -> a
- Duration
1)) Duration -> Duration -> Duration
forall a. Num a => a -> a -> a
* Int -> Duration
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nth
        frame :: SVG
frame = Duration -> Animation -> SVG
frameAt (if Int
frameCount Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1 then Duration
0 else Duration
now) Animation
ani
        path :: FilePath
path = FilePath
tmpDir FilePath -> FilePath -> FilePath
</> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
nth FilePath -> FilePath -> FilePath
<.> FilePath
"svg"
        svg :: FilePath
svg = Maybe Number -> Maybe Number -> SVG -> FilePath
renderSvg Maybe Number
forall a. Maybe a
Nothing Maybe Number
forall a. Maybe a
Nothing SVG
frame

    FilePath -> IO () -> IO ()
idempotentFile FilePath
path (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      FilePath -> FilePath -> IO ()
writeFile FilePath
path FilePath
svg
    MVar () -> (() -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
lock ((() -> IO ()) -> IO ()) -> (() -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \()
_ -> Int -> FilePath -> IO ()
cb Int
nth FilePath
path
 where
  rate :: Int
rate       = Int
60
  frameCount :: Int
frameCount = Duration -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (Animation -> Duration
duration Animation
ani Duration -> Duration -> Duration
forall a. Num a => a -> a -> a
* Int -> Duration
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
rate) :: Int
  errHandler :: ErrorCall -> IO b
errHandler (ErrorCall FilePath
msg) = do
    Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr FilePath
msg
    ExitCode -> IO b
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)

-- | Render as many frames as possible in 2 seconds. Limited to 20 frames.
renderLimitedFrames :: FilePath -> Int -> Bool -> Int -> Animation -> IO ()
renderLimitedFrames :: FilePath -> Int -> Bool -> Int -> Animation -> IO ()
renderLimitedFrames FilePath
folder Int
offset Bool
_prettyPrint Int
rate Animation
ani = do
    UTCTime
now <- IO UTCTime
getCurrentTime
    UTCTime -> Int -> [Int] -> IO ()
forall a. (Eq a, Num a) => UTCTime -> a -> [Int] -> IO ()
worker (NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
timeLimit UTCTime
now) Int
frameLimit (Int -> Int -> [Int]
frameOrder Int
rate Int
frameCount)
  where
    timeLimit :: NominalDiffTime
timeLimit = NominalDiffTime
2
    frameLimit :: Int
frameLimit = Int
20 :: Int
    worker :: UTCTime -> a -> [Int] -> IO ()
worker UTCTime
_ a
0 [Int]
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    worker UTCTime
_ a
_ [] = FilePath -> IO ()
putStrLn FilePath
"Done"
    worker UTCTime
localTimeLimit a
l (Int
x:[Int]
xs) = do
      UTCTime
curTime <- IO UTCTime
getCurrentTime
      if UTCTime
curTime UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> UTCTime
localTimeLimit
        then () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        else do
          let nth :: Int
nth = (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
offset) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
frameCount
              now :: Duration
now = (Animation -> Duration
duration Animation
ani Duration -> Duration -> Duration
forall a. Fractional a => a -> a -> a
/ (Int -> Duration
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
frameCount Duration -> Duration -> Duration
forall a. Num a => a -> a -> a
- Duration
1)) Duration -> Duration -> Duration
forall a. Num a => a -> a -> a
* Int -> Duration
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nth
              frame :: SVG
frame = Duration -> Animation -> SVG
frameAt (if Int
frameCount Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1 then Duration
0 else Duration
now) Animation
ani
              svg :: FilePath
svg = Maybe Number -> Maybe Number -> SVG -> FilePath
renderSvg Maybe Number
forall a. Maybe a
Nothing Maybe Number
forall a. Maybe a
Nothing SVG
frame
              path :: FilePath
path = FilePath
folder FilePath -> FilePath -> FilePath
</> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
nth FilePath -> FilePath -> FilePath
<.> FilePath
"svg"
              tmpPath :: FilePath
tmpPath = FilePath
path FilePath -> FilePath -> FilePath
<.> FilePath
"tmp"
          Bool
haveFile <- FilePath -> IO Bool
doesFileExist FilePath
path
          if Bool
haveFile
            then UTCTime -> a -> [Int] -> IO ()
worker UTCTime
localTimeLimit a
l [Int]
xs
            else do
              FilePath -> FilePath -> IO ()
writeFile FilePath
tmpPath FilePath
svg
              FilePath -> FilePath -> IO ()
renameOrCopyFile FilePath
tmpPath FilePath
path
              Int -> IO ()
forall a. Show a => a -> IO ()
print Int
nth
              UTCTime -> a -> [Int] -> IO ()
worker UTCTime
localTimeLimit (a
la -> a -> a
forall a. Num a => a -> a -> a
-a
1) [Int]
xs
    frameCount :: Int
frameCount = Duration -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (Animation -> Duration
duration Animation
ani Duration -> Duration -> Duration
forall a. Num a => a -> a -> a
* Int -> Duration
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
rate) :: Int

-- XXX: Merge with 'renderSvgs'
-- | Render 10 frames and print them to stdout. Used for testing.
--
--   XXX: Not related to the snippets in the playground.
renderSnippets :: Animation -> IO ()
renderSnippets :: Animation -> IO ()
renderSnippets Animation
ani = [Integer] -> (Integer -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Integer
0 .. Integer
frameCount Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1] ((Integer -> IO ()) -> IO ()) -> (Integer -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Integer
nth -> do
  let now :: Duration
now   = (Animation -> Duration
duration Animation
ani Duration -> Duration -> Duration
forall a. Fractional a => a -> a -> a
/ (Integer -> Duration
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
frameCount Duration -> Duration -> Duration
forall a. Num a => a -> a -> a
- Duration
1)) Duration -> Duration -> Duration
forall a. Num a => a -> a -> a
* Integer -> Duration
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
nth
      frame :: SVG
frame = Duration -> Animation -> SVG
frameAt Duration
now Animation
ani
      svg :: FilePath
svg   = Maybe Number -> Maybe Number -> SVG -> FilePath
renderSvg Maybe Number
forall a. Maybe a
Nothing Maybe Number
forall a. Maybe a
Nothing SVG
frame
  FilePath -> IO ()
putStr (Integer -> FilePath
forall a. Show a => a -> FilePath
show Integer
nth)
  Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat ([Text] -> Text) -> (FilePath -> [Text]) -> FilePath -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines (Text -> [Text]) -> (FilePath -> Text) -> FilePath -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath
svg
  where frameCount :: Integer
frameCount = Integer
10 :: Integer

frameOrder :: Int -> Int -> [Int]
frameOrder :: Int -> Int -> [Int]
frameOrder Int
fps Int
nFrames = [Int] -> Int -> [Int]
worker [] Int
fps
 where
  worker :: [Int] -> Int -> [Int]
worker [Int]
_seen Int
0        = []
  worker [Int]
seen  Int
nthFrame = [Int] -> Int -> Int -> [Int]
filterFrameList [Int]
seen Int
nthFrame Int
nFrames
    [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int] -> Int -> [Int]
worker (Int
nthFrame Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
seen) (Int
nthFrame Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2)

filterFrameList :: [Int] -> Int -> Int -> [Int]
filterFrameList :: [Int] -> Int -> Int -> [Int]
filterFrameList [Int]
seen Int
nthFrame Int
nFrames = (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Int -> Bool) -> Int -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Bool
isSeen)
                                               [Int
0, Int
nthFrame .. Int
nFrames Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
  where isSeen :: Int -> Bool
isSeen Int
x = (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Int
y -> Int
x Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
y Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) [Int]
seen

-- | Video formats supported by reanimate.
data Format = RenderMp4 | RenderGif | RenderWebm
  deriving (Int -> Format -> FilePath -> FilePath
[Format] -> FilePath -> FilePath
Format -> FilePath
(Int -> Format -> FilePath -> FilePath)
-> (Format -> FilePath)
-> ([Format] -> FilePath -> FilePath)
-> Show Format
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [Format] -> FilePath -> FilePath
$cshowList :: [Format] -> FilePath -> FilePath
show :: Format -> FilePath
$cshow :: Format -> FilePath
showsPrec :: Int -> Format -> FilePath -> FilePath
$cshowsPrec :: Int -> Format -> FilePath -> FilePath
Show)

mp4Arguments :: FPS -> FilePath -> FilePath -> FilePath -> [String]
mp4Arguments :: Int -> FilePath -> FilePath -> FilePath -> [FilePath]
mp4Arguments Int
fps FilePath
progress FilePath
template FilePath
target =
  [ FilePath
"-r"
  , Int -> FilePath
forall a. Show a => a -> FilePath
show Int
fps
  , FilePath
"-i"
  , FilePath
template
  , FilePath
"-y"
  , FilePath
"-c:v"
  , FilePath
"libx264"
  , FilePath
"-vf"
  , FilePath
"fps=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
fps
  , FilePath
"-preset"
  , FilePath
"slow"
  , FilePath
"-crf"
  , FilePath
"18"
  , FilePath
"-movflags"
  , FilePath
"+faststart"
  , FilePath
"-progress"
  , FilePath
progress
  , FilePath
"-pix_fmt"
  , FilePath
"yuv420p"
  , FilePath
target
  ]

-- gifArguments :: FPS -> FilePath -> FilePath -> FilePath -> [String]
-- gifArguments fps progress template target =

-- | Render animation to a video file with given parameters.
render
  :: Animation
  -> FilePath
  -> Raster
  -> Format
  -> Width
  -> Height
  -> FPS
  -> Bool
  -> IO ()
render :: Animation
-> FilePath
-> Raster
-> Format
-> Int
-> Int
-> Int
-> Bool
-> IO ()
render Animation
ani FilePath
target Raster
raster Format
format Int
width Int
height Int
fps Bool
partial = do
  FilePath -> Duration -> IO ()
forall r. PrintfType r => FilePath -> r
printf FilePath
"Starting render of animation: %.1f\n" (Animation -> Duration
duration Animation
ani)
  FilePath
ffmpeg <- FilePath -> IO FilePath
requireExecutable FilePath
"ffmpeg"
  Raster
-> Animation
-> Int
-> Int
-> Int
-> Bool
-> (FilePath -> IO ())
-> IO ()
forall a.
Raster
-> Animation
-> Int
-> Int
-> Int
-> Bool
-> (FilePath -> IO a)
-> IO a
generateFrames Raster
raster Animation
ani Int
width Int
height Int
fps Bool
partial ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \FilePath
template ->
    FilePath -> (FilePath -> IO ()) -> IO ()
forall a. FilePath -> (FilePath -> IO a) -> IO a
withTempFile FilePath
"txt" ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \FilePath
progress -> do
      FilePath -> FilePath -> IO ()
writeFile FilePath
progress FilePath
""
      Handle
progressH <- FilePath -> IOMode -> IO Handle
openFile FilePath
progress IOMode
ReadMode
      Handle -> BufferMode -> IO ()
hSetBuffering Handle
progressH BufferMode
NoBuffering
      MVar ()
allFinished <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
      IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
        FilePath -> Int -> (MVar Int -> IO ()) -> IO ()
progressPrinter FilePath
"rendered" (Animation -> Int -> Int
animationFrameCount Animation
ani Int
fps)
          ((MVar Int -> IO ()) -> IO ()) -> (MVar Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \MVar Int
done -> (IO () -> IO ()) -> IO ()
forall a. (a -> a) -> a
fix ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IO ()
loop -> do
            Bool
eof <- Handle -> IO Bool
hIsEOF Handle
progressH
            if Bool
eof
              then Int -> IO ()
threadDelay Int
1000000 IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
loop
              else do
                Either SomeException FilePath
l <- IO FilePath -> IO (Either SomeException FilePath)
forall e a. Exception e => IO a -> IO (Either e a)
try (Handle -> IO FilePath
hGetLine Handle
progressH)
                case Either SomeException FilePath
l of
                  Left  SomeException{} -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                  Right FilePath
str             ->
                    case Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
take Int
6 FilePath
str of
                      FilePath
"frame=" -> do
                        IO Int -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int -> IO ()) -> IO Int -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar Int -> Int -> IO Int
forall a. MVar a -> a -> IO a
swapMVar MVar Int
done (FilePath -> Int
forall a. Read a => FilePath -> a
read (Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
drop Int
6 FilePath
str))
                        IO ()
loop
                      FilePath
_ | FilePath
str FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"progress=end" -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                      FilePath
_                         -> IO ()
loop
        MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
allFinished ()
      case Format
format of
        Format
RenderMp4 -> FilePath -> [FilePath] -> IO ()
runCmd FilePath
ffmpeg (Int -> FilePath -> FilePath -> FilePath -> [FilePath]
mp4Arguments Int
fps FilePath
progress FilePath
template FilePath
target)
        Format
RenderGif -> FilePath -> (FilePath -> IO ()) -> IO ()
forall a. FilePath -> (FilePath -> IO a) -> IO a
withTempFile FilePath
"png" ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \FilePath
palette -> do
          FilePath -> [FilePath] -> IO ()
runCmd
            FilePath
ffmpeg
            [ FilePath
"-i"
            , FilePath
template
            , FilePath
"-y"
            , FilePath
"-vf"
            , FilePath
"fps="
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
fps
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
",scale="
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
width
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":"
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
height
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":flags=lanczos,palettegen"
            , FilePath
"-t"
            , Maybe Int -> Duration -> FilePath -> FilePath
forall a. RealFloat a => Maybe Int -> a -> FilePath -> FilePath
showFFloat Maybe Int
forall a. Maybe a
Nothing (Animation -> Duration
duration Animation
ani) FilePath
""
            , FilePath
palette
            ]
          FilePath -> [FilePath] -> IO ()
runCmd
            FilePath
ffmpeg
            [ FilePath
"-framerate"
            , Int -> FilePath
forall a. Show a => a -> FilePath
show Int
fps
            , FilePath
"-i"
            , FilePath
template
            , FilePath
"-y"
            , FilePath
"-i"
            , FilePath
palette
            , FilePath
"-progress"
            , FilePath
progress
            , FilePath
"-filter_complex"
            , FilePath
"fps="
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
fps
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
",scale="
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
width
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":"
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
height
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":flags=lanczos[x];[x][1:v]paletteuse"
            , FilePath
"-t"
            , Maybe Int -> Duration -> FilePath -> FilePath
forall a. RealFloat a => Maybe Int -> a -> FilePath -> FilePath
showFFloat Maybe Int
forall a. Maybe a
Nothing (Animation -> Duration
duration Animation
ani) FilePath
""
            , FilePath
target
            ]
        Format
RenderWebm -> FilePath -> [FilePath] -> IO ()
runCmd
          FilePath
ffmpeg
          [ FilePath
"-r"
          , Int -> FilePath
forall a. Show a => a -> FilePath
show Int
fps
          , FilePath
"-i"
          , FilePath
template
          , FilePath
"-y"
          , FilePath
"-progress"
          , FilePath
progress
          , FilePath
"-c:v"
          , FilePath
"libvpx-vp9"
          , FilePath
"-vf"
          , FilePath
"fps=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
fps
          , FilePath
target
          ]
      MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
allFinished

---------------------------------------------------------------------------------
-- Helpers

progressPrinter :: String -> Int -> (MVar Int -> IO ()) -> IO ()
progressPrinter :: FilePath -> Int -> (MVar Int -> IO ()) -> IO ()
progressPrinter FilePath
typeName Int
maxCount MVar Int -> IO ()
action = do
  FilePath -> FilePath -> Int -> IO ()
forall r. PrintfType r => FilePath -> r
printf FilePath
"\rFrames %s: 0/%d" FilePath
typeName Int
maxCount
  FilePath -> IO ()
putStr (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
clearFromCursorToLineEndCode FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\r"
  MVar Int
done  <- Int -> IO (MVar Int)
forall a. a -> IO (MVar a)
newMVar (Int
0 :: Int)
  UTCTime
start <- IO UTCTime
getCurrentTime
  let bgThread :: IO b
bgThread = IO () -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO b) -> IO () -> IO b
forall a b. (a -> b) -> a -> b
$ do
        Int
nDone <- MVar Int -> IO Int
forall a. MVar a -> IO a
readMVar MVar Int
done
        UTCTime
now   <- IO UTCTime
getCurrentTime
        let spent :: NominalDiffTime
spent = UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
now UTCTime
start
            remaining :: NominalDiffTime
remaining =
              (NominalDiffTime
spent NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Fractional a => a -> a -> a
/ (Int -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nDone NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Fractional a => a -> a -> a
/ Int -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
maxCount)) NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
- NominalDiffTime
spent
        FilePath -> FilePath -> Int -> Int -> IO ()
forall r. PrintfType r => FilePath -> r
printf FilePath
"\rFrames %s: %d/%d" FilePath
typeName Int
nDone Int
maxCount
        FilePath -> IO ()
putStr (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
", time spent: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ NominalDiffTime -> FilePath
ppDiff NominalDiffTime
spent
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
nDone Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          FilePath -> IO ()
putStr (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
", time remaining: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ NominalDiffTime -> FilePath
ppDiff NominalDiffTime
remaining
          FilePath -> IO ()
putStr (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
", total time: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ NominalDiffTime -> FilePath
ppDiff (NominalDiffTime
remaining NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
+ NominalDiffTime
spent)
        FilePath -> IO ()
putStr (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
clearFromCursorToLineEndCode FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\r"
        Handle -> IO ()
hFlush Handle
stdout
        Int -> IO ()
threadDelay Int
1000000
  IO () -> IO () -> IO ()
forall a. IO () -> IO a -> IO a
withBackgroundThread IO ()
forall b. IO b
bgThread (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar Int -> IO ()
action MVar Int
done
  UTCTime
now <- IO UTCTime
getCurrentTime
  let spent :: NominalDiffTime
spent = UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
now UTCTime
start
  FilePath -> FilePath -> Int -> Int -> IO ()
forall r. PrintfType r => FilePath -> r
printf FilePath
"\rFrames %s: %d/%d" FilePath
typeName Int
maxCount Int
maxCount
  FilePath -> IO ()
putStr (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
", time spent: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ NominalDiffTime -> FilePath
ppDiff NominalDiffTime
spent
  FilePath -> IO ()
putStr (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
clearFromCursorToLineEndCode FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n"

animationFrameCount :: Animation -> FPS -> Int
animationFrameCount :: Animation -> Int -> Int
animationFrameCount Animation
ani Int
rate = Duration -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (Animation -> Duration
duration Animation
ani Duration -> Duration -> Duration
forall a. Num a => a -> a -> a
* Int -> Duration
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
rate) :: Int

generateFrames
  :: Raster -> Animation -> Width -> Height -> FPS -> Bool -> (FilePath -> IO a) -> IO a
generateFrames :: Raster
-> Animation
-> Int
-> Int
-> Int
-> Bool
-> (FilePath -> IO a)
-> IO a
generateFrames Raster
raster Animation
ani Int
width_ Int
height_ Int
rate Bool
partial FilePath -> IO a
action = (FilePath -> IO a) -> IO a
forall a. (FilePath -> IO a) -> IO a
withTempDir ((FilePath -> IO a) -> IO a) -> (FilePath -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \FilePath
tmp -> do
  let frameName :: t -> FilePath
frameName t
nth = FilePath
tmp FilePath -> FilePath -> FilePath
</> FilePath -> t -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
nameTemplate t
nth
  FilePath -> IO ()
setRootDirectory FilePath
tmp
  FilePath -> Int -> (MVar Int -> IO ()) -> IO ()
progressPrinter FilePath
"generated" Int
frameCount
    ((MVar Int -> IO ()) -> IO ()) -> (MVar Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \MVar Int
done -> (AsyncException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle AsyncException -> IO ()
h (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Int] -> (Int -> IO ()) -> IO ()
forall a. [a] -> (a -> IO ()) -> IO ()
concurrentForM_ [Int]
frames ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
n -> do
        FilePath -> FilePath -> IO ()
writeFile (Int -> FilePath
forall t. PrintfArg t => t -> FilePath
frameName Int
n) (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe Number -> Maybe Number -> SVG -> FilePath
renderSvg Maybe Number
width Maybe Number
height (SVG -> FilePath) -> SVG -> FilePath
forall a b. (a -> b) -> a -> b
$ Int -> SVG
forall a. Integral a => a -> SVG
nthFrame Int
n
        MVar Int -> (Int -> IO Int) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar Int
done ((Int -> IO Int) -> IO ()) -> (Int -> IO Int) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
nDone -> Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
nDone Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Raster -> Bool
isValidRaster Raster
raster)
    (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Int -> (MVar Int -> IO ()) -> IO ()
progressPrinter FilePath
"rastered" Int
frameCount
    ((MVar Int -> IO ()) -> IO ()) -> (MVar Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \MVar Int
done -> (AsyncException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle AsyncException -> IO ()
h (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Int] -> (Int -> IO ()) -> IO ()
forall a. [a] -> (a -> IO ()) -> IO ()
concurrentForM_ [Int]
frames ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
n -> do
        Raster -> FilePath -> IO ()
applyRaster Raster
raster (Int -> FilePath
forall t. PrintfArg t => t -> FilePath
frameName Int
n)
        MVar Int -> (Int -> IO Int) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar Int
done ((Int -> IO Int) -> IO ()) -> (Int -> IO Int) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
nDone -> Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
nDone Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

  FilePath -> IO a
action (FilePath
tmp FilePath -> FilePath -> FilePath
</> Raster -> FilePath
rasterTemplate Raster
raster)
 where
  isValidRaster :: Raster -> Bool
isValidRaster Raster
RasterNone = Bool
False
  isValidRaster Raster
RasterAuto = Bool
False
  isValidRaster Raster
_          = Bool
True

  width :: Maybe Number
width  = Number -> Maybe Number
forall a. a -> Maybe a
Just (Number -> Maybe Number) -> Number -> Maybe Number
forall a b. (a -> b) -> a -> b
$ Duration -> Number
Px (Duration -> Number) -> Duration -> Number
forall a b. (a -> b) -> a -> b
$ Int -> Duration
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
width_
  height :: Maybe Number
height = Number -> Maybe Number
forall a. a -> Maybe a
Just (Number -> Maybe Number) -> Number -> Maybe Number
forall a b. (a -> b) -> a -> b
$ Duration -> Number
Px (Duration -> Number) -> Duration -> Number
forall a b. (a -> b) -> a -> b
$ Int -> Duration
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
height_
  h :: AsyncException -> IO ()
h AsyncException
UserInterrupt | Bool
partial = do
    Handle -> FilePath -> IO ()
hPutStrLn
      Handle
stderr
      FilePath
"\nCtrl-C detected. Trying to generate video with available frames. \
                       \Hit ctrl-c again to abort."
    () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  h AsyncException
other = AsyncException -> IO ()
forall e a. Exception e => e -> IO a
throwIO AsyncException
other
  -- frames = [0..frameCount-1]
  frames :: [Int]
frames = Int -> Int -> [Int]
frameOrder Int
rate Int
frameCount
  nthFrame :: a -> SVG
nthFrame a
nth = Duration -> Animation -> SVG
frameAt (Duration -> Duration
forall a. Fractional a => a -> a
recip (Int -> Duration
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
rate) Duration -> Duration -> Duration
forall a. Num a => a -> a -> a
* a -> Duration
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
nth) Animation
ani
  frameCount :: Int
frameCount = Animation -> Int -> Int
animationFrameCount Animation
ani Int
rate
  nameTemplate :: String
  nameTemplate :: FilePath
nameTemplate = FilePath
"render-%05d.svg"

withBackgroundThread :: IO () -> IO a -> IO a
withBackgroundThread :: IO () -> IO a -> IO a
withBackgroundThread IO ()
t = IO ThreadId -> (ThreadId -> IO ()) -> (ThreadId -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (IO () -> IO ThreadId
forkIO IO ()
t) ThreadId -> IO ()
killThread ((ThreadId -> IO a) -> IO a)
-> (IO a -> ThreadId -> IO a) -> IO a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> ThreadId -> IO a
forall a b. a -> b -> a
const

ppDiff :: NominalDiffTime -> String
ppDiff :: NominalDiffTime -> FilePath
ppDiff NominalDiffTime
diff | Int
hours Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Int
mins Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Int -> FilePath
forall a. Show a => a -> FilePath
show Int
secs FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"s"
            | Int
hours Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0              = FilePath -> Int -> Int -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"%.2d:%.2d" Int
mins Int
secs
            | Bool
otherwise               = FilePath -> Int -> Int -> Int -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"%.2d:%.2d:%.2d" Int
hours Int
mins Int
secs
 where
  (Int
osecs, Int
secs) = NominalDiffTime -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round NominalDiffTime
diff Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` (Int
60 :: Int)
  (Int
hours, Int
mins) = Int
osecs Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
60

rasterTemplate :: Raster -> String
rasterTemplate :: Raster -> FilePath
rasterTemplate Raster
RasterNone = FilePath
"render-%05d.svg"
rasterTemplate Raster
RasterAuto = FilePath
"render-%05d.svg"
rasterTemplate Raster
_          = FilePath
"render-%05d.png"

-- | Resolve RasterNone and RasterAuto. If no valid raster can
--   be found, exit with an error message.
requireRaster :: Raster -> IO Raster
requireRaster :: Raster -> IO Raster
requireRaster Raster
raster = do
  Raster
raster' <- Raster -> IO Raster
selectRaster (if Raster
raster Raster -> Raster -> Bool
forall a. Eq a => a -> a -> Bool
== Raster
RasterNone then Raster
RasterAuto else Raster
raster)
  case Raster
raster' of
    Raster
RasterNone -> do
      Handle -> FilePath -> IO ()
hPutStrLn
        Handle
stderr
        FilePath
"Raster required but none could be found. \
        \Please install either inkscape, imagemagick, or rsvg-convert."
      ExitCode -> IO Raster
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)
    Raster
_ -> Raster -> IO Raster
forall (f :: * -> *) a. Applicative f => a -> f a
pure Raster
raster'

-- | Resolve RasterNone and RasterAuto. If no valid raster can
--   be found, return RasterNone.
selectRaster :: Raster -> IO Raster
selectRaster :: Raster -> IO Raster
selectRaster Raster
RasterAuto = do
  Either FilePath FilePath
rsvg   <- IO (Either FilePath FilePath)
hasRSvg
  Either FilePath FilePath
ink    <- IO (Either FilePath FilePath)
hasInkscape
  Either FilePath FilePath
magick <- IO (Either FilePath FilePath)
hasMagick
  if
    | Either FilePath FilePath -> Bool
forall a b. Either a b -> Bool
isRight Either FilePath FilePath
rsvg   -> Raster -> IO Raster
forall (f :: * -> *) a. Applicative f => a -> f a
pure Raster
RasterRSvg
    | Either FilePath FilePath -> Bool
forall a b. Either a b -> Bool
isRight Either FilePath FilePath
ink    -> Raster -> IO Raster
forall (f :: * -> *) a. Applicative f => a -> f a
pure Raster
RasterInkscape
    | Either FilePath FilePath -> Bool
forall a b. Either a b -> Bool
isRight Either FilePath FilePath
magick -> Raster -> IO Raster
forall (f :: * -> *) a. Applicative f => a -> f a
pure Raster
RasterMagick
    | Bool
otherwise      -> Raster -> IO Raster
forall (f :: * -> *) a. Applicative f => a -> f a
pure Raster
RasterNone
selectRaster Raster
r = Raster -> IO Raster
forall (f :: * -> *) a. Applicative f => a -> f a
pure Raster
r

-- | Convert SVG file to a PNG file with selected raster engine. If
--   raster engine is RasterAuto or RasterNone, do nothing.
applyRaster :: Raster -> FilePath -> IO ()
applyRaster :: Raster -> FilePath -> IO ()
applyRaster Raster
RasterNone     FilePath
_    = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
applyRaster Raster
RasterAuto     FilePath
_    = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
applyRaster Raster
RasterInkscape FilePath
path = FilePath -> [FilePath] -> IO ()
runCmd
  FilePath
"inkscape"
  [ FilePath
"--without-gui"
  , FilePath
"--file=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
path
  , FilePath
"--export-png=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath -> FilePath
replaceExtension FilePath
path FilePath
"png"
  ]
applyRaster Raster
RasterRSvg FilePath
path = FilePath -> [FilePath] -> IO ()
runCmd
  FilePath
"rsvg-convert"
  [FilePath
path, FilePath
"--unlimited", FilePath
"--output", FilePath -> FilePath -> FilePath
replaceExtension FilePath
path FilePath
"png"]
applyRaster Raster
RasterMagick FilePath
path =
  FilePath -> [FilePath] -> IO ()
runCmd FilePath
magickCmd [FilePath
path, FilePath -> FilePath -> FilePath
replaceExtension FilePath
path FilePath
"png"]

concurrentForM_ :: [a] -> (a -> IO ()) -> IO ()
concurrentForM_ :: [a] -> (a -> IO ()) -> IO ()
concurrentForM_ [a]
lst a -> IO ()
action = do
  Int
n    <- IO Int
getNumCapabilities
  QSemN
sem  <- Int -> IO QSemN
newQSemN Int
n
  MVar SomeException
eVar <- IO (MVar SomeException)
forall a. IO (MVar a)
newEmptyMVar
  [a] -> (a -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [a]
lst ((a -> IO ()) -> IO ()) -> (a -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \a
elt -> do
    QSemN -> Int -> IO ()
waitQSemN QSemN
sem Int
1
    Bool
emp <- MVar SomeException -> IO Bool
forall a. MVar a -> IO Bool
isEmptyMVar MVar SomeException
eVar
    if Bool
emp
      then
        IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
          (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO
              (         IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch       (a -> IO ()
action a
elt) (IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ())
-> (SomeException -> IO Bool) -> SomeException -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar SomeException -> SomeException -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar SomeException
eVar)
              IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` QSemN -> Int -> IO ()
signalQSemN QSemN
sem          Int
1
              )
      else QSemN -> Int -> IO ()
signalQSemN QSemN
sem Int
1
  QSemN -> Int -> IO ()
waitQSemN QSemN
sem Int
n
  Maybe SomeException
mbE <- MVar SomeException -> IO (Maybe SomeException)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar SomeException
eVar
  case Maybe SomeException
mbE of
    Maybe SomeException
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just SomeException
e  -> SomeException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (SomeException
e :: SomeException)