module Data.GraphViz
( graphToDot
, clusterGraphToDot
, graphToGraph
, dotizeGraph
, NodeCluster(..)
, AttributeNode
, AttributeEdge
, module Data.GraphViz.Types
, module Data.GraphViz.Attributes
, module Data.GraphViz.Commands
) where
import Data.GraphViz.Types
import Data.GraphViz.Types.Clustering
import Data.GraphViz.Attributes
import Data.GraphViz.Commands
import Data.GraphViz.ParserCombinators(runParser)
import Data.Graph.Inductive.Graph
import qualified Data.Set as Set
import Control.Arrow((&&&))
import Data.Maybe
import qualified Data.Map as Map
import System.IO(hGetContents)
import System.IO.Unsafe(unsafePerformIO)
isUndir :: (Ord b, Graph g) => g a b -> Bool
isUndir g = all hasFlip es
where
es = labEdges g
eSet = Set.fromList es
hasFlip e = Set.member (flippedEdge e) eSet
flippedEdge (f,t,l) = (t,f,l)
graphToDot :: (Ord b, Graph gr) => gr a b -> [Attribute]
-> (LNode a -> [Attribute]) -> (LEdge b -> [Attribute]) -> DotGraph
graphToDot graph gAttributes fmtNode fmtEdge
= clusterGraphToDot graph gAttributes clusterBy fmtCluster fmtNode fmtEdge
where
clusterBy :: LNode a -> NodeCluster () a
clusterBy = N
fmtCluster _ = []
clusterGraphToDot :: (Ord c, Ord b, Graph gr) => gr a b
-> [Attribute] -> (LNode a -> NodeCluster c a)
-> (c -> [Attribute]) -> (LNode a -> [Attribute])
-> (LEdge b -> [Attribute]) -> DotGraph
clusterGraphToDot graph gAttrs clusterBy fmtCluster fmtNode fmtEdge
= DotGraph { strictGraph = False
, directedGraph = dirGraph
, graphID = Nothing
, graphAttributes = gAttrs
, graphNodes = ns
, graphEdges = es
}
where
dirGraph = not $ isUndir graph
ns = clustersToNodes clusterBy fmtCluster fmtNode graph
es = mapMaybe mkDotEdge . labEdges $ graph
mkDotEdge e@(f,t,_) = if dirGraph || f <= t
then Just DotEdge {edgeHeadNodeID = f
,edgeTailNodeID = t
,edgeAttributes = fmtEdge e
,directedEdge = dirGraph}
else Nothing
type AttributeNode a = ([Attribute], a)
type AttributeEdge b = ([Attribute], b)
graphToGraph :: (Ord b, Graph gr) => gr a b -> [Attribute]
-> (LNode a -> [Attribute]) -> (LEdge b -> [Attribute])
-> IO (gr (AttributeNode a) (AttributeEdge b))
graphToGraph gr gAttributes fmtNode fmtEdge
= do output <- graphvizWithHandle command dot DotOutput hGetContents
let res = fromJust output
length res `seq` return ()
return $ rebuildGraphWithAttributes res
where
undirected = isUndir gr
command = if undirected then undirCommand else dirCommand
dot = graphToDot gr gAttributes fmtNode fmtEdge
rebuildGraphWithAttributes dotResult = mkGraph lnodes ledges
where
lnodes = map (\(n, l) -> (n, (fromJust $ Map.lookup n nodeMap, l)))
$ labNodes gr
ledges = map createEdges $ labEdges gr
createEdges (f, t, l) = if undirected && f > t
then (f, t, getLabel (t,f))
else (f, t, getLabel (f,t))
where
getLabel c = (fromJust $ Map.lookup c edgeMap, l)
DotGraph { graphNodes = ns, graphEdges = es}
= fst . runParser parseDotGraph $ dotResult
nodeMap = Map.fromList $ map (nodeID &&& nodeAttributes) ns
edgeMap = Map.fromList $ map (\e -> ( ( edgeTailNodeID e
, edgeHeadNodeID e)
, edgeAttributes e)
) es
dotizeGraph :: (DynGraph gr, Ord b) => gr a b
-> gr (AttributeNode a) (AttributeEdge b)
dotizeGraph g = unsafePerformIO
$ graphToGraph g gAttrs noAttrs noAttrs
where
gAttrs = []
noAttrs = const []