module Data.GraphViz
(
graphToDot
, graphToDot'
, NodeCluster(..)
, clusterGraphToDot
, clusterGraphToDot'
, prettyPrint
, prettyPrint'
, AttributeNode
, AttributeEdge
, graphToGraph
, graphToGraph'
, dotizeGraph
, dotizeGraph'
, clusterGraphToGraph
, clusterGraphToGraph'
, dotizeClusterGraph
, dotizeClusterGraph'
, 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.Types.Printing(PrintDot)
import Data.Graph.Inductive.Graph
import qualified Data.Set as Set
import Control.Arrow((&&&))
import Data.Maybe(mapMaybe, fromJust)
import qualified Data.Map as Map
import Control.Monad(liftM)
import System.IO.Unsafe(unsafePerformIO)
isUndirected :: (Ord b, Graph g) => g a b -> Bool
isUndirected 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)
isDirected :: (Ord b, Graph g) => g a b -> Bool
isDirected = not . isUndirected
graphToDot :: (Graph gr) => Bool -> gr a b -> [GlobalAttributes]
-> (LNode a -> Attributes) -> (LEdge b -> Attributes)
-> DotGraph Node
graphToDot isDir graph gAttributes
= clusterGraphToDot isDir graph gAttributes clustBy cID fmtClust
where
clustBy :: LNode a -> NodeCluster () a
clustBy = N
cID = const Nothing
fmtClust = const []
graphToDot' :: (Ord b, Graph gr) => gr a b -> [GlobalAttributes]
-> (LNode a -> Attributes) -> (LEdge b -> Attributes)
-> DotGraph Node
graphToDot' graph = graphToDot (isDirected graph) graph
clusterGraphToDot :: (Ord c, Graph gr) => Bool -> gr a b
-> [GlobalAttributes] -> (LNode a -> NodeCluster c l)
-> (c -> Maybe GraphID) -> (c -> [GlobalAttributes])
-> (LNode l -> Attributes) -> (LEdge b -> Attributes)
-> DotGraph Node
clusterGraphToDot dirGraph graph gAttrs clusterBy cID fmtCluster fmtNode fmtEdge
= DotGraph { strictGraph = False
, directedGraph = dirGraph
, graphID = Nothing
, graphStatements = stmts
}
where
stmts = DotStmts { attrStmts = gAttrs
, subGraphs = cs
, nodeStmts = ns
, edgeStmts = es
}
(cs, ns) = clustersToNodes clusterBy cID fmtCluster fmtNode graph
es = mapMaybe mkDotEdge . labEdges $ graph
mkDotEdge e@(f,t,_) = if dirGraph || f <= t
then Just DotEdge { edgeFromNodeID = f
, edgeToNodeID = t
, edgeAttributes = fmtEdge e
, directedEdge = dirGraph
}
else Nothing
clusterGraphToDot' :: (Ord c, Ord b, Graph gr) => gr a b
-> [GlobalAttributes] -> (LNode a -> NodeCluster c l)
-> (c -> Maybe GraphID) -> (c -> [GlobalAttributes])
-> (LNode l -> Attributes) -> (LEdge b -> Attributes)
-> DotGraph Node
clusterGraphToDot' gr = clusterGraphToDot (isDirected gr) gr
type AttributeNode a = (Attributes, a)
type AttributeEdge b = (Attributes, b)
graphToGraph :: (Graph gr) => Bool -> gr a b -> [GlobalAttributes]
-> (LNode a -> Attributes) -> (LEdge b -> Attributes)
-> IO (gr (AttributeNode a) (AttributeEdge b))
graphToGraph isDir gr gAttributes fmtNode fmtEdge
= dotAttributes isDir gr dot
where
dot = graphToDot isDir gr gAttributes fmtNode fmtEdge
dotAttributes :: (Graph gr) => Bool -> gr a b -> DotGraph Node
-> IO (gr (AttributeNode a) (AttributeEdge b))
dotAttributes isDir gr dot
= do (Right output) <- graphvizWithHandle command
dot
DotOutput
hGetContents'
return $ rebuildGraphWithAttributes output
where
command = if isDir then dirCommand else undirCommand
rebuildGraphWithAttributes dotResult = mkGraph lnodes ledges
where
lnodes = map (\(n, l) -> (n, (nodeMap Map.! n, l)))
$ labNodes gr
ledges = map createEdges $ labEdges gr
createEdges (f, t, l) = if isDir || f <= t
then (f, t, getLabel (f,t))
else (f, t, getLabel (t,f))
where
getLabel c = (fromJust $ Map.lookup c edgeMap, l)
g' = parseDotGraph dotResult
ns = graphNodes g'
es = graphEdges g'
nodeMap = Map.fromList $ map (nodeID &&& nodeAttributes) ns
edgeMap = Map.fromList $ map ( (edgeFromNodeID &&& edgeToNodeID)
&&& edgeAttributes) es
graphToGraph' :: (Ord b, Graph gr) => gr a b -> [GlobalAttributes]
-> (LNode a -> Attributes) -> (LEdge b -> Attributes)
-> IO (gr (AttributeNode a) (AttributeEdge b))
graphToGraph' gr = graphToGraph (isDirected gr) gr
clusterGraphToGraph :: (Ord c, Graph gr) => Bool -> gr a b
-> [GlobalAttributes] -> (LNode a -> NodeCluster c l)
-> (c -> Maybe GraphID) -> (c -> [GlobalAttributes])
-> (LNode l -> Attributes) -> (LEdge b -> Attributes)
-> IO (gr (AttributeNode a) (AttributeEdge b))
clusterGraphToGraph isDir gr gAtts clBy cID fmtClust fmtNode fmtEdge
= dotAttributes isDir gr dot
where
dot = clusterGraphToDot isDir gr gAtts clBy cID fmtClust fmtNode fmtEdge
clusterGraphToGraph' :: (Ord b, Ord c, Graph gr) => gr a b
-> [GlobalAttributes] -> (LNode a -> NodeCluster c l)
-> (c -> Maybe GraphID) -> (c -> [GlobalAttributes])
-> (LNode l -> Attributes) -> (LEdge b -> Attributes)
-> IO (gr (AttributeNode a) (AttributeEdge b))
clusterGraphToGraph' gr = clusterGraphToGraph (isDirected gr) gr
dotizeGraph :: (Graph gr) => Bool -> gr a b
-> gr (AttributeNode a) (AttributeEdge b)
dotizeGraph isDir g = unsafePerformIO
$ graphToGraph isDir g gAttrs noAttrs noAttrs
where
gAttrs = []
noAttrs = const []
dotizeGraph' :: (Graph gr, Ord b) => gr a b
-> gr (AttributeNode a) (AttributeEdge b)
dotizeGraph' g = dotizeGraph (isDirected g) g
dotizeClusterGraph :: (Ord c, Graph gr) => Bool -> gr a b
-> (LNode a -> NodeCluster c l)
-> gr (AttributeNode a) (AttributeEdge b)
dotizeClusterGraph isDir g clustBy = unsafePerformIO
$ clusterGraphToGraph isDir g
gAttrs clustBy
cID cAttrs
noAttrs noAttrs
where
gAttrs = []
cID = const Nothing
cAttrs = const gAttrs
noAttrs = const []
dotizeClusterGraph' :: (Ord b, Ord c, Graph gr) => gr a b
-> (LNode a -> NodeCluster c l)
-> gr (AttributeNode a) (AttributeEdge b)
dotizeClusterGraph' g = dotizeClusterGraph (isDirected g) g
prettyPrint :: (PrintDot a) => DotGraph a -> IO String
prettyPrint dg = liftM fromRight
$ graphvizWithHandle (commandFor dg)
dg
Canon
hGetContents'
where
fromRight (Right r) = r
fromRight Left{} = fail "Usage of prettyPrint failed; \
\is the Graphviz suite of tools installed?"
prettyPrint' :: (PrintDot a) => DotGraph a -> String
prettyPrint' = unsafePerformIO . prettyPrint