/
CmdLine.hs
341 lines (310 loc) · 11.9 KB
/
CmdLine.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
{-# LANGUAGE DeriveDataTypeable, CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Diagrams.Backend.Cairo.CmdLine
-- Copyright : (c) 2011 Diagrams-cairo team (see LICENSE)
-- License : BSD-style (see LICENSE)
-- Maintainer : diagrams-discuss@googlegroups.com
--
-- Convenient creation of command-line-driven executables for
-- rendering diagrams using the cairo backend.
--
-- * 'defaultMain' creates an executable which can render a single
-- diagram at various options.
--
-- * 'multiMain' is like 'defaultMain' but allows for a list of
-- diagrams from which the user can choose one to render.
--
-- * 'animMain' is like 'defaultMain' but for animations instead of
-- diagrams.
--
-- If you want to generate diagrams programmatically---/i.e./ if you
-- want to do anything more complex than what the below functions
-- provide---you have several options.
--
-- * A simple but somewhat inflexible approach is to wrap up
-- 'defaultMain' (or 'multiMain', or 'animMain') in a call to
-- 'System.Environment.withArgs'.
--
-- * A more flexible approach is to directly call 'renderDia'; see
-- "Diagrams.Backend.Cairo" for more information.
--
-----------------------------------------------------------------------------
module Diagrams.Backend.Cairo.CmdLine
( defaultMain
, multiMain
, animMain
, Cairo
) where
import Data.List (intercalate)
import Diagrams.Prelude hiding (width, height, interval)
import Diagrams.Backend.Cairo
-- Below hack is needed because GHC 7.0.x has a bug regarding export
-- of data family constructors; see comments in 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_, mplus)
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 Control.Concurrent (threadDelay)
import Control.Exception (catch, SomeException(..), bracket)
#ifdef CMDLINELOOP
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
data DiagramOpts = DiagramOpts
{ width :: Maybe Int
, height :: Maybe Int
, output :: FilePath
, list :: Bool
, 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)
, list = def
&= (if sel then help "List all available diagrams" 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
-- | This is the simplest way to render diagrams, and is intended to
-- be used like so:
--
-- > ... other definitions ...
-- > myDiagram = ...
-- >
-- > main = defaultMain myDiagram
--
-- Compiling a source file like the above example will result in an
-- executable which takes command-line options for setting the size,
-- output file, and so on, and renders @myDiagram@ with the
-- specified options.
--
-- On Unix systems, the generated executable also supports a
-- rudimentary \"looped\" mode, which watches the source file for
-- changes and recompiles itself on the fly.
--
-- Pass @--help@ to the generated executable to see all available
-- options. Currently it looks something like
--
-- @
-- Command-line diagram generation.
--
-- Foo [OPTIONS]
--
-- Common flags:
-- -w --width=INT Desired width of the output image
-- -h --height=INT Desired height of the output image
-- -o --output=FILE Output file
-- -f --fpu=FLOAT Frames per unit time (for animations)
-- -l --loop Run in a self-recompiling loop
-- -s --src=FILE Source file to watch
-- -i --interval=SECONDS When running in a loop, check for changes every n
-- seconds.
-- -? --help Display help message
-- -V --version Print version information
-- @
--
-- For example, a couple common scenarios include
--
-- @
-- $ ghc --make MyDiagram
--
-- # output image.png with a width of 400px (and auto-determined height)
-- $ ./MyDiagram -o image.png -w 400
--
-- # output 200x200 dia.pdf, then watch for changes every 10 seconds
-- $ ./MyDiagram -o dia.pdf -h 200 -w 200 -l -i 10
-- @
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
fst $ renderDia
Cairo
( CairoOptions
(output opts)
(mkSizeSpec
(fromIntegral <$> width opts)
(fromIntegral <$> height opts)
)
outTy
False
)
d
| otherwise -> putStrLn $ "Unknown file type: " ++ last ps
-- | @multiMain@ is like 'defaultMain', except instead of a single
-- diagram it takes a list of diagrams paired with names as input.
-- The generated executable then takes a @--selection@ option
-- specifying the name of the diagram that should be rendered. The
-- list of available diagrams may also be printed by passing the
-- option @--list@.
--
-- Example usage:
--
-- @
-- $ ghc --make MultiTest
-- [1 of 1] Compiling Main ( MultiTest.hs, MultiTest.o )
-- Linking MultiTest ...
-- $ ./MultiTest --list
-- Available diagrams:
-- foo bar
-- $ ./MultiTest --selection bar -o Bar.png -w 200
-- @
multiMain :: [(String, Diagram Cairo R2)] -> IO ()
multiMain ds = do
prog <- getProgName
opts <- cmdArgs (diagramOpts prog True)
if list opts
then showDiaList (map fst ds)
else
case selection opts of
Nothing -> putStrLn "No diagram selected." >> showDiaList (map fst ds)
Just sel -> case lookup sel ds of
Nothing -> putStrLn $ "Unknown diagram: " ++ sel
Just d -> chooseRender opts d
-- | Display the list of diagrams available for rendering.
showDiaList :: [String] -> IO ()
showDiaList ds = do
putStrLn "Available diagrams:"
putStrLn $ " " ++ intercalate " " ds
-- | @animMain@ is like 'defaultMain', but renders an animation
-- instead of a diagram. It takes as input an animation and produces
-- a command-line program which will crudely \"render\" the animation
-- by rendering one image for each frame, named by extending the given
-- output file name by consecutive integers. For example if the given
-- output file name is @foo\/blah.png@, the frames will be saved in
-- @foo\/blah001.png@, @foo\/blah002.png@, and so on (the number of
-- padding digits used depends on the total number of frames). It is
-- up to the user to take these images and stitch them together into
-- an actual animation format (using, /e.g./ @ffmpeg@).
--
-- Of course, this is a rather crude method of rendering animations;
-- more sophisticated methods will likely be added in the future.
--
-- The @--fpu@ option can be used to control how many frames will be
-- output for each second (unit time) of animation.
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 d n@ adds the integer index @n@ to the end of the
-- output file name, padding with zeros if necessary so that it uses
-- at least @d@ digits.
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 ModuleTime -> DiagramOpts -> String -> [String] -> IO ()
waitForChange lastAttempt opts prog args = do
hSetBuffering stdout NoBuffering
go lastAttempt
where go lastAtt = do
threadDelay (1000000 * interval opts)
-- putStrLn $ "Checking... (last attempt = " ++ show lastAttempt ++ ")"
(newBin, newAttempt) <- recompile lastAtt prog (src opts)
if newBin
then executeFile prog False args Nothing
else go $ newAttempt `mplus` lastAtt
-- | @recompile t prog@ attempts to recompile @prog@, assuming the
-- last attempt was made at time @t@. If @t@ is @Nothing@ assume
-- the last attempt time is the same as the modification time of the
-- binary. If the source file modification time is later than the
-- last attempt time, then attempt to recompile, and return the time
-- of this attempt. Otherwise (if nothing has changed since the
-- last attempt), return @Nothing@. Also return a Bool saying
-- whether a successful recompilation happened.
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