module Data.GraphViz.Commands
(
GraphvizCommand(..)
, dirCommand
, undirCommand
, commandFor
, GraphvizOutput(..)
, GraphvizCanvas(..)
, RunResult(..)
, maybeErr
, runGraphviz
, runGraphvizCommand
, addExtension
, runGraphvizCanvas
, runGraphvizCanvas'
, graphvizWithHandle
, hGetContents'
) where
import Prelude hiding (catch)
import Data.GraphViz.Types
import Data.GraphViz.Attributes(Attribute(Z))
import qualified Data.ByteString as B
import System.IO( Handle, hClose, hPutStr
, hGetContents, hSetBinaryMode)
import System.Exit(ExitCode(ExitSuccess))
import System.Process(runInteractiveProcess, waitForProcess)
import Control.Concurrent(MVar, forkIO, newEmptyMVar, putMVar, takeMVar)
import Control.Exception.Extensible( SomeException(..), catch
, bracket, evaluate, handle)
import Control.Monad(liftM)
import System.FilePath(FilePath, (<.>))
data GraphvizCommand = Dot
| Neato
| TwoPi
| Circo
| Fdp
deriving (Eq, Ord, Show, Read)
showCmd :: GraphvizCommand -> String
showCmd Dot = "dot"
showCmd Neato = "neato"
showCmd TwoPi = "twopi"
showCmd Circo = "circo"
showCmd Fdp = "fdp"
dirCommand :: GraphvizCommand
dirCommand = Dot
undirCommand :: GraphvizCommand
undirCommand = Neato
commandFor :: (DotRepr dg n) => dg n -> GraphvizCommand
commandFor dg = if graphIsDirected dg
then dirCommand
else undirCommand
class GraphvizResult o where
outputCall :: o -> String
isBinary :: o -> Bool
data GraphvizOutput = Bmp
| Canon
| DotOutput
| XDot
| Eps
| Fig
| Gd
| Gd2
| Gif
| Ico
| Imap
| Cmapx
| ImapNP
| CmapxNP
| Jpeg
| Pdf
| Plain
| PlainExt
| Png
| Ps
| Ps2
| Svg
| SvgZ
| Tiff
| Vml
| VmlZ
| Vrml
| WBmp
deriving (Eq, Ord, Show, Read)
instance GraphvizResult GraphvizOutput where
outputCall Bmp = "bmp"
outputCall Canon = "canon"
outputCall DotOutput = "dot"
outputCall XDot = "xdot"
outputCall Eps = "eps"
outputCall Fig = "fig"
outputCall Gd = "gd"
outputCall Gd2 = "gd2"
outputCall Gif = "gif"
outputCall Ico = "ico"
outputCall Imap = "imap"
outputCall Cmapx = "cmapx"
outputCall ImapNP = "imap_np"
outputCall CmapxNP = "cmapx_np"
outputCall Jpeg = "jpeg"
outputCall Pdf = "pdf"
outputCall Plain = "plain"
outputCall PlainExt = "plain-ext"
outputCall Png = "png"
outputCall Ps = "ps"
outputCall Ps2 = "ps2"
outputCall Svg = "svg"
outputCall SvgZ = "svgz"
outputCall Tiff = "tiff"
outputCall Vml = "vml"
outputCall VmlZ = "vmlz"
outputCall Vrml = "vrml"
outputCall WBmp = "wbmp"
isBinary Canon = False
isBinary DotOutput = False
isBinary XDot = False
isBinary Eps = False
isBinary Fig = False
isBinary Imap = False
isBinary Cmapx = False
isBinary ImapNP = False
isBinary CmapxNP = False
isBinary Plain = False
isBinary PlainExt = False
isBinary Ps = False
isBinary Svg = False
isBinary Vml = False
isBinary Vrml = False
isBinary _ = True
defaultExtension :: GraphvizOutput -> String
defaultExtension Bmp = "bmp"
defaultExtension Canon = "dot"
defaultExtension DotOutput = "dot"
defaultExtension XDot = "dot"
defaultExtension Eps = "eps"
defaultExtension Fig = "fig"
defaultExtension Gd = "gd"
defaultExtension Gd2 = "gd2"
defaultExtension Gif = "gif"
defaultExtension Ico = "ico"
defaultExtension Imap = "map"
defaultExtension Cmapx = "map"
defaultExtension ImapNP = "map"
defaultExtension CmapxNP = "map"
defaultExtension Jpeg = "jpg"
defaultExtension Pdf = "pdf"
defaultExtension Plain = "txt"
defaultExtension PlainExt = "txt"
defaultExtension Png = "png"
defaultExtension Ps = "ps"
defaultExtension Ps2 = "ps"
defaultExtension Svg = "svg"
defaultExtension SvgZ = "svgz"
defaultExtension Tiff = "tif"
defaultExtension Vml = "vml"
defaultExtension VmlZ = "vmlz"
defaultExtension Vrml = "vrml"
defaultExtension WBmp = "wbmp"
data GraphvizCanvas = Gtk | Xlib
deriving (Eq, Ord, Read, Show)
instance GraphvizResult GraphvizCanvas where
outputCall Gtk = "gtk"
outputCall Xlib = "xlib"
isBinary _ = True
data RunResult = Error String
| Success
deriving (Eq, Ord, Read, Show)
maybeErr :: Either String a -> RunResult
maybeErr = either Error (const Success)
runGraphviz :: (DotRepr dg n) => dg n -> GraphvizOutput -> FilePath
-> IO (Either String FilePath)
runGraphviz gr = runGraphvizCommand (commandFor gr) gr
runGraphvizCommand :: (DotRepr dg n) => GraphvizCommand -> dg n
-> GraphvizOutput -> FilePath
-> IO (Either String FilePath)
runGraphvizCommand cmd gr t fp
= liftM (either (Left . addFl) (const $ Right fp))
$ graphvizWithHandle cmd gr t toFile
where
addFl = (++) ("Unable to create " ++ fp ++ "\n")
toFile h = B.hGetContents h >>= B.writeFile fp
addExtension :: (GraphvizOutput -> FilePath -> a)
-> GraphvizOutput -> FilePath -> a
addExtension cmd t fp = cmd t fp'
where
fp' = fp <.> defaultExtension t
graphvizWithHandle :: (DotRepr dg n, Show a)
=> GraphvizCommand
-> dg n
-> GraphvizOutput
-> (Handle -> IO a)
-> IO (Either String a)
graphvizWithHandle = graphvizWithHandle'
graphvizWithHandle' :: (DotRepr dg n, GraphvizResult o, Show a)
=> GraphvizCommand -> dg n -> o
-> (Handle -> IO a) -> IO (Either String a)
graphvizWithHandle' cmd gr t f
= handle notRunnable
$ bracket
(runInteractiveProcess cmd' args Nothing Nothing)
(\(inh,outh,errh,_) -> hClose inh >> hClose outh >> hClose errh)
$ \(inp,outp,errp,prc) -> do
hSetBinaryMode inp False
hSetBinaryMode errp False
hSetBinaryMode outp $ isBinary t
forkIO $ hPutStr inp (printDotGraph gr) >> hClose inp
mvOutput <- newEmptyMVar
mvErr <- newEmptyMVar
_ <- forkIO $ signalWhenDone hGetContents' errp mvErr
_ <- forkIO $ signalWhenDone f' outp mvOutput
err <- takeMVar mvErr
output <- takeMVar mvOutput
exitCode <- waitForProcess prc
case exitCode of
ExitSuccess -> return output
_ -> return $ Left $ othErr ++ err
where
notRunnable e@SomeException{} = return . Left $ unwords
[ "Unable to call the Graphviz command "
, cmd'
, " with the arguments: "
, unwords args
, " because of: "
, show e
]
cmd' = showCmd cmd
args = ["-T" ++ outputCall t]
f' h = liftM Right (f h)
`catch`
(\e@SomeException{} -> return . Left $ fErr ++ show e)
fErr = "Error re-directing the output from " ++ cmd' ++ ": "
othErr = "Error messages from " ++ cmd' ++ ":\n"
signalWhenDone :: (Handle -> IO a) -> Handle -> MVar a -> IO ()
signalWhenDone f h mv = f h >>= putMVar mv >> return ()
runGraphvizCanvas :: (DotRepr dg n) => GraphvizCommand -> dg n
-> GraphvizCanvas -> IO RunResult
runGraphvizCanvas cmd gr c = liftM maybeErr
$ graphvizWithHandle' cmd gr c nullHandle
where
nullHandle :: Handle -> IO ()
nullHandle h = do r <- hGetContents h
evaluate (length r)
return ()
runGraphvizCanvas' :: (DotRepr dg n) => dg n -> GraphvizCanvas
-> IO RunResult
runGraphvizCanvas' d = runGraphvizCanvas (commandFor d) d
hGetContents' :: Handle -> IO String
hGetContents' h = do r <- hGetContents h
evaluate $ length r
return r