module Diagrams.Backend.Rasterific.CmdLine
(
mainWith
, defaultMain
, multiMain
, animMain
, gifMain
, GifOpts(..)
, Rasterific
, B
) where
import Diagrams.Prelude hiding (width, height, interval
,option, (<>))
import Diagrams.Backend.Rasterific
import Diagrams.Backend.CmdLine
import Codec.Picture
import Codec.Picture.Types (dropTransparency)
import Codec.Picture.ColorQuant (defaultPaletteOptions)
import qualified Data.ByteString.Lazy as L (ByteString, writeFile)
import Options.Applicative
import Control.Lens ((^.), Lens', makeLenses)
import Data.List.Split
#ifdef CMDLINELOOP
import Data.Maybe (fromMaybe)
import Control.Monad (when, mplus)
import Control.Lens (_1)
import System.Environment (getArgs, getProgName)
import System.Directory (getModificationTime)
import System.Process (runProcess, waitForProcess)
import System.IO (openFile, hClose, IOMode(..)
,hSetBuffering, BufferMode(..)
,stdout)
import System.Exit (ExitCode(..))
import Control.Concurrent (threadDelay)
import Control.Exception (catch, SomeException(..), bracket)
import System.Posix.Process (executeFile)
#if MIN_VERSION_directory(1,2,0)
import Data.Time.Clock (UTCTime,getCurrentTime)
type ModuleTime = UTCTime
getModuleTime :: IO ModuleTime
getModuleTime = getCurrentTime
#else
import System.Time (ClockTime, getClockTime)
type ModuleTime = ClockTime
getModuleTime :: IO ModuleTime
getModuleTime = getClockTime
#endif
#endif
defaultMain :: Diagram Rasterific R2 -> IO ()
defaultMain = mainWith
#ifdef CMDLINELOOP
output' :: Lens' (MainOpts (Diagram Rasterific R2)) FilePath
output' = _1 . output
instance Mainable (Diagram Rasterific R2) where
type MainOpts (Diagram Rasterific R2) = (DiagramOpts, DiagramLoopOpts)
mainRender (opts,loopOpts) d = do
chooseRender opts d
when (loopOpts^.loop) (waitForChange Nothing loopOpts)
#else
output' :: Lens' (MainOpts (Diagram Rasterific R2)) FilePath
output' = output
instance Mainable (Diagram Rasterific R2) where
type MainOpts (Diagram Rasterific R2) = DiagramOpts
mainRender opts d = chooseRender opts d
#endif
chooseRender :: DiagramOpts -> Diagram Rasterific R2 -> IO ()
chooseRender opts d =
case splitOn "." (opts ^. output) of
[""] -> putStrLn "No output file given."
ps | last ps `elem` ["png", "tif", "bmp", "jpg"] -> do
let img = renderDia Rasterific
( RasterificOptions
(mkSizeSpec
(fromIntegral <$> opts ^. width )
(fromIntegral <$> opts ^. height)
)
)
d
case last ps of
"png" -> writePng (opts^.output) img
"tif" -> writeTiff (opts^.output) img
"bmp" -> writeBitmap (opts^.output) img
"jpg" -> writeJpeg 100 (opts^.output) img
_ -> writePng (opts^.output) img
| otherwise -> putStrLn $ "Unknown file type: " ++ last ps
multiMain :: [(String, Diagram Rasterific R2)] -> IO ()
multiMain = mainWith
instance Mainable [(String,Diagram Rasterific R2)] where
type MainOpts [(String,Diagram Rasterific R2)]
= (MainOpts (Diagram Rasterific R2), DiagramMultiOpts)
mainRender = defaultMultiMainRender
animMain :: Animation Rasterific R2 -> IO ()
animMain = mainWith
instance Mainable (Animation Rasterific R2) where
type MainOpts (Animation Rasterific R2) =
(MainOpts (Diagram Rasterific R2), DiagramAnimOpts)
mainRender = defaultAnimMainRender output'
#ifdef CMDLINELOOP
waitForChange :: Maybe ModuleTime -> DiagramLoopOpts -> IO ()
waitForChange lastAttempt opts = do
prog <- getProgName
args <- getArgs
hSetBuffering stdout NoBuffering
go prog args lastAttempt
where go prog args lastAtt = do
threadDelay (1000000 * opts^.interval)
(newBin, newAttempt) <- recompile lastAtt prog (opts^.src)
if newBin
then executeFile prog False args Nothing
else go prog args $ newAttempt `mplus` lastAtt
recompile :: Maybe ModuleTime -> String -> Maybe String -> IO (Bool, Maybe ModuleTime)
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 <- getModuleTime
return (status == ExitSuccess, Just curTime)
else return (False, Nothing)
where getModTime f = catch (Just <$> getModificationTime f)
(\(SomeException _) -> return Nothing)
#endif
gifMain :: [(Diagram Rasterific R2, GifDelay)] -> IO ()
gifMain = mainWith
data GifOpts = GifOpts { _dither :: Bool
, _noLooping :: Bool
, _loopRepeat :: Maybe Int}
makeLenses ''GifOpts
instance Parseable GifOpts where
parser = GifOpts <$> switch
( long "dither"
<> help "Turn on dithering." )
<*> switch
( long "looping-off"
<> help "Turn looping off" )
<*> ( optional . option )
( long "loop-repeat"
<> help "Number of times to repeat" )
instance Mainable [(Diagram Rasterific R2, GifDelay)] where
type MainOpts [(Diagram Rasterific R2, GifDelay)] = (DiagramOpts, GifOpts)
mainRender (dOpts, gOpts) ds = gifRender (dOpts, gOpts) ds
encodeGifAnimation' :: [GifDelay] -> GifLooping -> Bool
-> [Image PixelRGB8] -> Either String (L.ByteString)
encodeGifAnimation' delays looping dithering lst =
encodeGifImages looping triples
where
triples = zipWith (\(x,z) y -> (x, y, z)) doubles delays
doubles = [(pal, img)
| (img, pal) <- palettize
defaultPaletteOptions {enableImageDithering=dithering} <$> lst]
writeGifAnimation' :: FilePath -> [GifDelay] -> GifLooping -> Bool
-> [Image PixelRGB8] -> Either String (IO ())
writeGifAnimation' path delays looping dithering img =
L.writeFile path <$> encodeGifAnimation' delays looping dithering img
gifRender :: (DiagramOpts, GifOpts) -> [(Diagram Rasterific R2, GifDelay)] -> IO ()
gifRender (dOpts, gOpts) lst =
case splitOn "." (dOpts^.output) of
[""] -> putStrLn "No output file given"
ps | last ps == "gif" -> do
let looping = if gOpts^.noLooping
then LoopingNever
else case gOpts^.loopRepeat of
Nothing -> LoopingForever
Just n -> LoopingRepeat (fromIntegral n)
dias = map fst lst
delays = map snd lst
sizeSpec = mkSizeSpec (fromIntegral <$> dOpts^.width)
(fromIntegral <$> dOpts^.height)
opts = RasterificOptions sizeSpec
imageRGB8s = map (pixelMap dropTransparency
. renderDia Rasterific opts) dias
result = writeGifAnimation' (dOpts^.output) delays
looping (gOpts^.dither)
imageRGB8s
case result of
Left s -> putStrLn s
Right io -> io
| otherwise -> putStrLn $ "File name must end with .gif"