module Data.Graph.Analysis.Visualisation
(
graphviz,
graphvizClusters,
GraphvizOutput(..),
GraphvizCommand(..),
runGraphviz,
runGraphvizCommand,
showPath,
showCycle,
showNodes
) where
import Prelude
import Data.Graph.Analysis.Types
import Data.Graph.Analysis.Utils
import Data.Graph.Inductive.Graph
import Data.GraphViz
import System.IO
import System.Exit
import System.Process
import Data.Array.IO
import Control.Concurrent
import Control.Exception
graphviz :: (Graph g, Show a, Ord b) => String -> g a b -> DotGraph
graphviz t g = graphToDot g attrs nattrs eattrs
where
attrs = [Label t]
nattrs (_,a) = [Label (show a)]
eattrs _ = []
graphvizClusters :: (Graph g, Show c, ClusterLabel a c, Ord b) =>
String -> g a b -> DotGraph
graphvizClusters t g = clusterGraphToDot g atts assignCluster catts natts eatts
where
atts = [Label t]
catts c = [Label (show c)]
natts (_,a) = [Label (nodelabel a)]
eatts _ = []
data GraphvizOutput = Canon
| Cmap
| Cmapx
| Cmapx_np
| Dia
| DotOutput
| Eps
| Fig
| Gd
| Gd2
| Gif
| Gtk
| Hpgl
| Imap
| Imap_np
| Ismap
| Jpe
| Jpeg
| Jpg
| Mif
| Mp
| Pcl
| Pdf
| Pic
| Plain
| PlainExt
| Png
| Ps
| Ps2
| Svg
| Svgz
| Tk
| Vml
| Vmlz
| Vrml
| Vtx
| Wbmp
| Xdot
| Xlib
instance Show GraphvizOutput where
show Canon = "canon"
show Cmap = "cmap"
show Cmapx = "cmapx"
show Cmapx_np = "cmapx_np"
show Dia = "dia"
show DotOutput = "dot"
show Eps = "eps"
show Fig = "fig"
show Gd = "gd"
show Gd2 = "gd2"
show Gif = "gif"
show Gtk = "gtk"
show Hpgl = "hpgl"
show Imap = "imap"
show Imap_np = "imap_np"
show Ismap = "ismap"
show Jpe = "jpe"
show Jpeg = "jpeg"
show Jpg = "jpg"
show Mif = "mif"
show Mp = "mp"
show Pcl = "pcl"
show Pdf = "pdf"
show Pic = "pic"
show Plain = "plain"
show PlainExt = "plain-ext"
show Png = "png"
show Ps = "ps"
show Ps2 = "ps2"
show Svg = "svg"
show Svgz = "svgz"
show Tk = "tk"
show Vml = "vml"
show Vmlz = "vmlz"
show Vrml = "vrml"
show Vtx = "vtx"
show Wbmp = "wbmp"
show Xdot = "xdot"
show Xlib = "xlib"
data GraphvizCommand = DotCmd | Neato | TwoPi | Circo | Fdp
instance Show GraphvizCommand where
show DotCmd = "dot"
show Neato = "neato"
show TwoPi = "twopi"
show Circo = "circo"
show Fdp = "fdp"
runGraphviz :: DotGraph -> GraphvizOutput -> FilePath -> IO Bool
runGraphviz gr t fp = runGraphvizInternal (commandFor gr) gr t fp
runGraphvizCommand :: GraphvizCommand -> DotGraph -> GraphvizOutput
-> FilePath -> IO Bool
runGraphvizCommand cmd gr t fp = runGraphvizInternal (show cmd) gr t fp
runGraphvizInternal :: String -> DotGraph -> GraphvizOutput -> FilePath
-> IO Bool
runGraphvizInternal cmd gr t fp
= do pipe <- try $ openFile fp WriteMode
case pipe of
(Left _) -> return False
(Right f) -> do file <- graphvizWithHandle cmd gr t (flip squirt f)
hClose f
case file of
(Just _) -> return True
_ -> return False
squirt :: Handle -> Handle -> IO ()
squirt rd wr = do
arr <- newArray_ (0, bufsize1)
let loop = do
r <- hGetArray rd arr bufsize
if (r == 0)
then return ()
else if (r < bufsize)
then hPutArray wr arr r
else hPutArray wr arr bufsize >> loop
loop
where
bufsize :: Int
bufsize = 4 * 1024
graphvizWithHandle :: (Show a) => String -> DotGraph -> GraphvizOutput -> (Handle -> IO a)
-> IO (Maybe a)
graphvizWithHandle cmd gr t f
= do (inp, outp, errp, proc) <- runInteractiveCommand command
forkIO $ hPrint inp gr >> hClose inp
forkIO $ (hGetContents errp >>= hPutStr stderr >> hClose errp)
a <- f outp
a `seq` hClose outp
exitCode <- waitForProcess proc
case exitCode of
ExitSuccess -> return (Just a)
_ -> return Nothing
where
command = cmd ++ " -T" ++ (show t)
showPath :: (Show a) => LNGroup a -> String
showPath [] = ""
showPath lns = blockPrint' (l:ls')
where
(l:ls) = map (show . label) lns
ls' = map ("-> "++) ls
showCycle ::(Show a) => LNGroup a -> String
showCycle [] = ""
showCycle lns@(ln:_) = showPath (lns ++ [ln])
showNodes :: (Show a) => LNGroup a -> String
showNodes = blockPrintList . map label