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.Graph.Inductive.Graph
import Data.List
import Data.Function
import qualified Data.Set as Set
import Text.ParserCombinators.Poly.Lazy
import Control.Monad
import Data.Maybe
import qualified Data.Map as Map
import System.IO
import System.IO.Unsafe(unsafePerformIO)
import Data.GraphViz.Types
import Data.GraphViz.Types.Clustering
import Data.GraphViz.Attributes
import Data.GraphViz.Commands
isUndir :: (Ord b, Graph g) => g a b -> Bool
isUndir g = all hasFlip edges
where
edges = labEdges g
eSet = Set.fromList edges
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 graphAttributes fmtNode fmtEdge
= clusterGraphToDot graph graphAttributes 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 graphAttributes clusterBy fmtCluster fmtNode fmtEdge
= DotGraph { graphAttributes, graphNodes, graphEdges, directedGraph }
where
graphNodes = clustersToNodes clusterBy fmtCluster fmtNode graph
directedGraph = not $ isUndir graph
graphEdges = catMaybes . map mkDotEdge . labEdges $ graph
mkDotEdge e@(f,t,_) = if (directedGraph || f <= t)
then Just $ DotEdge {edgeHeadNodeID = t
,edgeTailNodeID = f
,edgeAttributes = fmtEdge e
,directedEdge = directedGraph}
else Nothing
type AttributeNode a = ([Attribute], a)
type AttributeEdge b = ([Attribute], b)
graphToGraph :: forall gr a b . (Ord b, Graph gr) =>
gr a b -> [Attribute] -> (LNode a -> [Attribute]) -> (LEdge b -> [Attribute]) -> IO (gr (AttributeNode a) (AttributeEdge b))
graphToGraph gr graphAttributes fmtNode fmtEdge
= do { out <- graphvizWithHandle command dot DotOutput hGetContents
; let res = fromJust out
; (length res) `seq` return ()
; return $ rebuildGraphWithAttributes res
}
where
undirected = isUndir gr
command = if undirected then undirCommand else dirCommand
dot = graphToDot gr graphAttributes fmtNode fmtEdge
rebuildGraphWithAttributes :: String -> gr (AttributeNode a) (AttributeEdge b)
rebuildGraphWithAttributes dotResult = mkGraph lnodes ledges
where
lnodes = map (\(n, l) -> (n, (fromJust $ Map.lookup n nodeMap, l))) . labNodes $ gr
ledges = map createEdges . labEdges $ gr
(DotGraph { graphEdges, graphNodes }) = fst . runParser readDotGraph $ dotResult
nodeMap = Map.fromList . map (\n -> (nodeID n, nodeAttributes n)) $ graphNodes
edgeMap = Map.fromList . map (\e -> ((edgeTailNodeID e, edgeHeadNodeID e), edgeAttributes e)) $ graphEdges
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)
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 []