ghostscript-parallel-0.0: src/Main.hs

module Main where

import qualified Options.Applicative as OP

import Shell.Utility.ParseArgument (parseNumber)
import Shell.Utility.Exit (exitFailureMsg)

import qualified Control.Concurrent.PooledIO.Independent as Pool

import qualified System.Environment as Env
import System.Directory (renameFile)
import System.Process (callProcess, readProcess)

import qualified Data.Foldable as Fold
import qualified Data.List.HT as ListHT
import qualified Data.Ix as Ix
import Data.Tuple.HT (mapSnd)
import Data.Monoid ((<>))

import Control.Applicative (pure, (<*>))

import Text.Printf (printf)


{-
qpdf --show-npages input.pdf

gs -q -dNODISPLAY --permit-file-read=$PATH_TO_PDF -c "($PATH_TO_PDF) (r) file runpdfbegin pdfpagecount = quit"
-}
countPages :: FilePath -> IO Int
countPages path = do
   countStr <-
      readProcess "gs"
         ["-q", "-dNODISPLAY", "--permit-file-read=" ++ path, "-c",
          "(" ++ path ++ ") (r) file runpdfbegin pdfpagecount = quit"]
         ""
   case reads countStr of
      [(count, _)] -> return count
      _ ->
         exitFailureMsg $
         "'gs' returned an incomprehensible page count, namely: " ++ countStr


-- cf. numeric-prelude
divUp :: (Integral a) => a -> a -> a
divUp x y = - div (-x) y

run ::
   Int -> Int -> Maybe Int ->
   FilePath -> FilePath -> [String] -> IO ()
run numJobs firstPage mLastPage input output gsArgs = do
   lastPage <- maybe (countPages input) return mLastPage
   let num = Ix.rangeSize (firstPage, lastPage)
   let ranges =
         zip [0::Integer ..] $
         ListHT.mapAdjacent
            (\p0 p1 -> (p0,p1-1))
            (map ((firstPage+) . flip divUp numJobs) $
             take (numJobs+1) $ iterate (num+) 0)
   Pool.runException (Just numJobs) $
      flip map ranges $ \(job,(p0,p1)) -> do
         callProcess "gs" $
            ("-dFirstPage=" ++ show p0) :
            ("-dLastPage=" ++ show p1) :
            (printf "-sOutputFile=%s-%d" output job) :
            gsArgs ++
            [input]
   let pages = do
         (job,range) <- ranges
         page <- Ix.range (1, Ix.rangeSize range)
         return (job, page)
   Fold.for_ (zip [1::Integer ..] pages) $ \(dstPage, (job, srcPage)) -> do
      renameFile
         (printf output srcPage ++ "-" ++ printf "%d" job)
         (printf output dstPage)


parser :: OP.Parser ([String] -> IO ())
parser =
   pure run
   <*>
      (OP.option
            (OP.eitherReader $ parseNumber "number of jobs" (0<) "positive") $
         OP.short 'j' <>
         OP.long "jobs" <>
         OP.metavar "NUMBER" <>
         OP.value 1 <>
         OP.help "Number of parallel threads")
   <*>
      (OP.option (OP.eitherReader $ parseNumber "page" (0<) "positive") $
         OP.long "first-page" <>
         OP.metavar "ONEBASED" <>
         OP.value 1 <>
         OP.help "First page to render")
   <*>
      (OP.option
            (fmap Just $ OP.eitherReader $ parseNumber "page" (0<) "positive") $
         OP.long "last-page" <>
         OP.metavar "ONEBASED" <>
         OP.value Nothing <>
         OP.help "Last page to render")
   <*>
      OP.strArgument
         (OP.metavar "INPUT" <>
          OP.help "Input Document")
   <*>
      OP.strArgument
         (OP.metavar "OUTPUT" <>
          OP.help "Output Filename Pattern")

info :: OP.Parser a -> OP.ParserInfo a
info p =
   OP.info
      (OP.helper <*> p)
      (OP.fullDesc <>
       OP.progDesc "Let Ghostscript render pages in parallel.")

main :: IO ()
main = do
   args <- Env.getArgs
   let (optParseArgs, gsArgs) = mapSnd (drop 1) $ break ("--" ==) args
   ($gsArgs) =<<
      OP.handleParseResult
         (OP.execParserPure OP.defaultPrefs (info parser) optParseArgs)