module Diagrams.Backend.Cairo.CmdLine
( defaultMain
, multiMain
, animMain
, Cairo
) where
import Diagrams.Prelude hiding (width, height, interval)
import Diagrams.Backend.Cairo
#if __GLASGOW_HASKELL__ < 702 || __GLASGOW_HASKELL__ >= 704
import Diagrams.Backend.Cairo.Internal
#endif
import System.Console.CmdArgs.Implicit hiding (args)
import Prelude hiding (catch)
import Data.Maybe (fromMaybe)
import Control.Monad (when, forM_)
import Data.List.Split
import Text.Printf
import System.Environment (getArgs, getProgName)
import System.Directory (getModificationTime)
import System.FilePath (addExtension, splitExtension)
import System.Process (runProcess, waitForProcess)
import System.IO (openFile, hClose, IOMode(..),
hSetBuffering, BufferMode(..), stdout)
import System.Exit (ExitCode(..))
import System.Time (ClockTime, getClockTime)
import Control.Concurrent (threadDelay)
import Control.Exception (catch, SomeException(..), bracket)
#ifdef CMDLINELOOP
import System.Posix.Process (executeFile)
#endif
data DiagramOpts = DiagramOpts
{ width :: Maybe Int
, height :: Maybe Int
, output :: FilePath
, selection :: Maybe String
, fpu :: Double
#ifdef CMDLINELOOP
, loop :: Bool
, src :: Maybe String
, interval :: Int
#endif
}
deriving (Show, Data, Typeable)
diagramOpts :: String -> Bool -> DiagramOpts
diagramOpts prog sel = DiagramOpts
{ width = def
&= typ "INT"
&= help "Desired width of the output image"
, height = def
&= typ "INT"
&= help "Desired height of the output image"
, output = def
&= typFile
&= help "Output file"
, selection = def
&= help "Name of the diagram to render"
&= (if sel then typ "NAME" else ignore)
, fpu = 30
&= typ "FLOAT"
&= help "Frames per unit time (for animations)"
#ifdef CMDLINELOOP
, loop = False
&= help "Run in a self-recompiling loop"
, src = def
&= typFile
&= help "Source file to watch"
, interval = 1 &= typ "SECONDS"
&= help "When running in a loop, check for changes every n seconds."
#endif
}
&= summary "Command-line diagram generation."
&= program prog
defaultMain :: Diagram Cairo R2 -> IO ()
defaultMain d = do
prog <- getProgName
args <- getArgs
opts <- cmdArgs (diagramOpts prog False)
chooseRender opts d
#ifdef CMDLINELOOP
when (loop opts) (waitForChange Nothing opts prog args)
#endif
chooseRender :: DiagramOpts -> Diagram Cairo R2 -> IO ()
chooseRender opts d =
case splitOn "." (output opts) of
[""] -> putStrLn "No output file given."
ps | last ps `elem` ["png", "ps", "pdf", "svg"] -> do
let outTy = case last ps of
"png" -> PNG
"ps" -> PS
"pdf" -> PDF
"svg" -> SVG
_ -> PDF
sizeSpec = case (width opts, height opts) of
(Nothing, Nothing) -> Absolute
(Just w, Nothing) -> Width (fromIntegral w)
(Nothing, Just h) -> Height (fromIntegral h)
(Just w, Just h) -> Dims (fromIntegral w)
(fromIntegral h)
fst $ renderDia Cairo (CairoOptions
(output opts)
sizeSpec
outTy
)
d
| otherwise -> putStrLn $ "Unknown file type: " ++ last ps
multiMain :: [(String, Diagram Cairo R2)] -> IO ()
multiMain ds = do
prog <- getProgName
opts <- cmdArgs (diagramOpts prog True)
case selection opts of
Nothing -> putStrLn "No diagram selected."
Just sel -> case lookup sel ds of
Nothing -> putStrLn $ "Unknown diagram: " ++ sel
Just d -> chooseRender opts d
animMain :: Animation Cairo R2 -> IO ()
animMain anim = do
prog <- getProgName
opts <- cmdArgs (diagramOpts prog False)
let frames = simulate (toRational $ fpu opts) anim
nDigits = length . show . length $ frames
forM_ (zip [1..] frames) $ \(i,d) ->
chooseRender (indexize nDigits i opts) d
indexize :: Int -> Integer -> DiagramOpts -> DiagramOpts
indexize nDigits i opts = opts { output = output' }
where fmt = "%0" ++ show nDigits ++ "d"
output' = addExtension (base ++ printf fmt (i::Integer)) ext
(base, ext) = splitExtension (output opts)
#ifdef CMDLINELOOP
waitForChange :: Maybe ClockTime -> DiagramOpts -> String -> [String] -> IO ()
waitForChange lastAttempt opts prog args = do
hSetBuffering stdout NoBuffering
go lastAttempt
where go lastAtt = do
threadDelay (1000000 * interval opts)
(newBin, newAttempt) <- recompile lastAtt prog (src opts)
if newBin
then executeFile prog False args Nothing
else go $ getFirst (First newAttempt <> First lastAtt)
recompile :: Maybe ClockTime -> String -> Maybe String -> IO (Bool, Maybe ClockTime)
recompile lastAttempt prog mSrc = do
let errFile = prog ++ ".errors"
srcFile = fromMaybe (prog ++ ".hs") mSrc
binT <- maybe (getModTime prog) (return . Just) lastAttempt
srcT <- getModTime srcFile
if (srcT > binT)
then do
putStr "Recompiling..."
status <- bracket (openFile errFile WriteMode) hClose $ \h ->
waitForProcess =<< runProcess "ghc" ["--make", srcFile]
Nothing Nothing Nothing Nothing (Just h)
if (status /= ExitSuccess)
then putStrLn "" >> putStrLn (replicate 75 '-') >> readFile errFile >>= putStr
else putStrLn "done."
curTime <- getClockTime
return (status == ExitSuccess, Just curTime)
else return (False, Nothing)
where getModTime f = catch (Just <$> getModificationTime f)
(\(SomeException _) -> return Nothing)
#endif