graphviz 2008.9.6 → 2008.9.20

raw patch · 4 files changed

+236/−58 lines, 4 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Data/GraphViz.hs +202/−30
• Data/GraphViz/Attributes.hs +23/−22
• Data/GraphViz/ParserCombinators.hs +8/−3
• graphviz.cabal +3/−3

@@ -1,30 +1,41 @@-{-# LANGUAGE RecordPuns +{-# LANGUAGE RecordPuns            , ScopedTypeVariables            #-} - {- GraphViz ------------------------------------------------------\+ {--GraphViz ------------------------------------------------------\  |                                                                 |- | Copyright (c) 2008, Matthew Sackman (matthew@wellquite.org)     |+ | Copyright (c) 2008, Matthew Sackman (matthew@wellquite.org),    |+ |              Ivan Lazar Miljenovic (ivan.miljenovic@gmail.com)  |  |                                                                 |- | DisTract is freely distributable under the terms of a 3-Clause  |+ | GraphViz is freely distributable under the terms of a 3-Clause  |  | BSD-style license.                                              |  |                                                                 |  \-----------------------------------------------------------------}  module Data.GraphViz     ( graphToDot+    , clusterGraphToDot     , graphToGraph     , readDotGraph+    , commandFor     , DotGraph (..)     , DotNode (..)     , DotEdge (..)+    , NodeCluster(..)     , AttributeNode     , AttributeEdge     , module Data.GraphViz.Attributes     )     where +-- LT is defined in Attributes+import Prelude hiding (LT)+import qualified Prelude as P+ import Data.Graph.Inductive.Graph+import Data.List+import Data.Function+import qualified Data.Set as Set import Text.ParserCombinators.PolyLazy import System.IO import System.Process@@ -39,59 +50,207 @@ data DotGraph = DotGraph { graphAttributes :: [Attribute]                          , graphNodes :: [DotNode]                          , graphEdges :: [DotEdge]+                         , directedGraph :: Bool                          } -data DotNode = DotNode { nodeID :: Int-                       , nodeAttributes :: [Attribute]-                       }+data DotNode+    = DotNode { nodeID :: Int+              , nodeAttributes :: [Attribute]+              }+    | DotCluster { clusterID         :: String+                 , clusterAttributes :: [Attribute]+                 , clusterElems      :: [DotNode]+                 }  data DotEdge = DotEdge { edgeHeadNodeID :: Int                        , edgeTailNodeID :: Int                        , edgeAttributes :: [Attribute]+                       , directedEdge   :: Bool                        }  instance Show DotNode where-    show (DotNode { nodeID, nodeAttributes })-        | null nodeAttributes = '\t':((show nodeID) ++ ";")-        | otherwise = '\t':((show nodeID) ++ (' ':((show nodeAttributes) ++ ";")))+    show n = init . unlines . addTabs $ nodesToString n +nodesToString :: DotNode -> [String]+nodesToString (DotNode { nodeID, nodeAttributes })+    | null nodeAttributes = [nID ++ ";"]+    | otherwise           = [nID ++ (' ':((show nodeAttributes) ++ ";"))]+    where+      nID = show nodeID+nodesToString (DotCluster { clusterID, clusterAttributes, clusterElems })+    = ["subgraph cluster_" ++ clusterID ++ " {"] ++ (addTabs inner) ++ ["}"]+    where+      inner = case clusterAttributes of+                [] -> nodes+                a  -> ("graph " ++ (show a) ++ ";") : nodes+      nodes = concatMap nodesToString clusterElems++addTabs :: [String] -> [String]+addTabs = map ('\t':)+ instance Show DotEdge where-    show (DotEdge { edgeHeadNodeID, edgeTailNodeID, edgeAttributes })-        = '\t' : ((show edgeTailNodeID) ++ " -> " ++ (show edgeHeadNodeID) ++ attributes)+    show (DotEdge { edgeHeadNodeID, edgeTailNodeID, edgeAttributes, directedEdge })+        = '\t' : ((show edgeTailNodeID) ++ edge ++ (show edgeHeadNodeID) ++ attributes)           where+            edge = " " ++ (if directedEdge then dirEdge else undirEdge) ++ " "             attributes = case edgeAttributes of                            [] -> ";"-                           a -> ' ':((show a) ++ ";")+                           a  -> ' ':((show a) ++ ";")  instance Show DotGraph where-    show (DotGraph { graphAttributes, graphNodes, graphEdges })-        = unlines $ "digraph {" : (rest ++ ["}"])+    show (DotGraph { graphAttributes, graphNodes, graphEdges, directedGraph })+        = unlines $ gType : " {" : (rest ++ ["}"])         where+          gType = if directedGraph then dirGraph else undirGraph           rest = case graphAttributes of                    [] -> nodesEdges                    a -> ("\tgraph " ++ (show a) ++ ";") : nodesEdges           nodesEdges = (map show graphNodes) ++ (map show graphEdges) +-- | Define into which cluster a particular node belongs.+--   Nodes can be nested to arbitrary depth.+data NodeCluster c a = N (LNode a) | C c (NodeCluster c a)+                        deriving (Show)++-- | A tree representation of a cluster.+data ClusterTree c a = NT (LNode a) | CT c [ClusterTree c a]+                       deriving (Show)++-- Convert a single node cluster into its tree representation.+clustToTree          :: NodeCluster c a -> ClusterTree c a+clustToTree (N ln)   = NT ln+clustToTree (C c nc) = CT c [clustToTree nc]++-- Two nodes are in the same "default" cluster; otherwise check if they+-- are in the same cluster.+sameClust :: (Eq c) => ClusterTree c a -> ClusterTree c a -> Bool+sameClust (NT _)    (NT _)    = True+sameClust (CT c1 _) (CT c2 _) = c1 == c2+sameClust _         _         = False++-- Singleton nodes come first, and then ordering based upon the cluster.+clustOrder :: (Ord c) => ClusterTree c a -> ClusterTree c a -> Ordering+clustOrder (NT _)    (NT _)    = EQ+clustOrder (NT _)    (CT _ _)  = P.LT -- don't use the attribute LT+clustOrder (CT _ _)  (NT _)    = GT+clustOrder (CT c1 _) (CT c2 _) = compare c1 c2++-- Extract the sub-trees.+getNodes           :: ClusterTree c a -> [ClusterTree c a]+getNodes n@(NT _)  = [n]+getNodes (CT _ ns) = ns++-- Combine clusters.+collapseNClusts :: (Ord c) => [ClusterTree c a] -> [ClusterTree c a]+collapseNClusts = concatMap grpCls+                  . groupBy sameClust+                  . sortBy clustOrder+    where+      grpCls []              = []+      grpCls ns@((NT _):_)   = ns+      grpCls cs@((CT c _):_) = [CT c (collapseNClusts $ concatMap getNodes cs)]++-- Differences between directed and undirected graphs.++dirEdge, undirEdge :: String+dirEdge = "->"+undirEdge = "--"++dirGraph, undirGraph :: String+dirGraph = "digraph"+undirGraph = "graph"++dirCommand, undirCommand :: String+dirCommand = "dot"+undirCommand = "neato"++-- | The appropriate GraphViz command for the given graph.+commandFor    :: DotGraph -> String+commandFor dg = if (directedGraph dg)+                then dirCommand+                else undirCommand++-- Determine ifi the given graph is undirected or directed.+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)+ -- | Convert a graph to dot format. You can then write this to a file---   and run dot on it-graphToDot :: (Graph gr) => gr a b -> [Attribute] -> (LNode a -> [Attribute]) -> (LEdge b -> [Attribute]) -> DotGraph+--   and run the appropriate command on it (found using 'commandFor').+graphToDot :: (Ord b, Graph gr) => gr a b -> [Attribute]+           -> (LNode a -> [Attribute]) -> (LEdge b -> [Attribute]) -> DotGraph graphToDot graph graphAttributes fmtNode fmtEdge-    = DotGraph { graphAttributes, graphNodes, graphEdges }+    = clusterGraphToDot graph graphAttributes clusterBy fmtCluster fmtNode fmtEdge       where-        graphNodes = map mkDotNode . labNodes $ graph-        graphEdges = map mkDotEdge . labEdges $ graph-        mkDotNode n = DotNode { nodeID = fst n, nodeAttributes = fmtNode n }-        mkDotEdge e@(f, t, _) = DotEdge { edgeHeadNodeID = t, edgeTailNodeID = f, edgeAttributes = fmtEdge e }+        clusterBy :: LNode a -> NodeCluster () a+        clusterBy = N+        fmtCluster _ = [] +-- | Convert a graph to dot format, using the specified clustering function+--   to group nodes into clusters.  You can then write this to a file and+--   run the appropriate command on it (found using 'commandFor').+--   Clusters can be nested to arbitrary depth.+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+        clusters = collapseNClusts . map (clustToTree . clusterBy) $ labNodes graph+        graphNodes = treesToNodes fmtCluster fmtNode clusters+        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++-- Convert the cluster representation of the trees into DotNodes.+-- Clusters will be labelled with integers.+treesToNodes :: (c -> [Attribute]) -> (LNode a -> [Attribute])+             -> [ClusterTree c a] -> [DotNode]+treesToNodes fmtCluster fmtNode = snd . treesToNodesFrom fmtCluster fmtNode 0++-- Start labelling the clusters with this integer.+treesToNodesFrom :: (c -> [Attribute]) -> (LNode a -> [Attribute])+                 -> Int -> [ClusterTree c a] -> (Int,[DotNode])+treesToNodesFrom fmtCluster fmtNode n = mapAccumL mkNodes n+    where+      mkNodes = treeToNode fmtCluster fmtNode++-- Convert this ClusterTree into its DotNode representation.+treeToNode :: (c -> [Attribute]) -> (LNode a -> [Attribute])+           -> Int -> ClusterTree c a -> (Int, DotNode)+treeToNode _ fmtNode n (NT ln) = ( n+                                 , DotNode { nodeID = fst ln+                                           , nodeAttributes = fmtNode ln+                                           }+                                 )+treeToNode fmtCluster fmtNode n (CT c nts) = (n',clust)+    where+      (n', nts') = treesToNodesFrom fmtCluster fmtNode (n+1) nts+      clust = DotCluster { clusterID = show n+                         , clusterAttributes = fmtCluster c+                         , clusterElems = nts'+                         }+ type AttributeNode a = ([Attribute], a) type AttributeEdge b = ([Attribute], b)  -- | Run the graph via dot to get positional information and then---   combine that information back into the original graph-graphToGraph :: forall gr a b . (Graph gr) =>+--   combine that information back into the original graph.+--   Note that this doesn't support graphs with clusters.+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 { (inp, outp, errp, proc) <- runInteractiveCommand "dot -Tdot"+    = do { (inp, outp, errp, proc) <- runInteractiveCommand (command++" -Tdot")          ; hPutStr inp (show dot)          ; hClose inp          ; forkIO $ (hGetContents errp >>= hPutStr stderr)@@ -103,15 +262,22 @@          ; 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 (\(f,t, l) -> (f, t, (fromJust $ Map.lookup (f,t) edgeMap, l))) . labEdges $ 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)  readDotNode :: Parser Char DotNode readDotNode = do { optional whitespace@@ -126,17 +292,23 @@ readDotEdge = do { optional whitespace                  ; edgeTailNodeID <- number                  ; whitespace-                 ; string "->"+                 ; edge <- strings [dirEdge,undirEdge]                  ; whitespace                  ; edgeHeadNodeID <- number                  ; as <- optional (whitespace >> readAttributesList)                  ; char ';'                  ; skipToNewline-                 ; return (DotEdge { edgeHeadNodeID, edgeTailNodeID, edgeAttributes = fromMaybe [] as })+                 ; return (DotEdge { edgeHeadNodeID+                                   , edgeTailNodeID+                                   , edgeAttributes = fromMaybe [] as+                                   , directedEdge = edge == dirEdge })                  }+    where + readDotGraph :: Parser Char DotGraph-readDotGraph = do { string "digraph"+readDotGraph = do { d <- strings [dirGraph,undirGraph]+                  ; let directedGraph = d == dirGraph                   ; whitespace                   ; char '{'                   ; skipToNewline@@ -151,5 +323,5 @@                   ; graphNodes <- many readDotNode                   ; graphEdges <- many readDotEdge                   ; char '}'-                  ; return $ DotGraph { graphAttributes, graphNodes, graphEdges }+                  ; return $ DotGraph { graphAttributes, graphNodes, graphEdges, directedGraph }                   }

@@ -4,9 +4,10 @@   {- GraphViz ------------------------------------------------------\  |                                                                 |- | Copyright (c) 2008, Matthew Sackman (matthew@wellquite.org)     |+ | Copyright (c) 2008, Matthew Sackman (matthew@wellquite.org),    |+ |              Ivan Lazar Miljenovic (ivan.miljenovic@gmail.com)  |  |                                                                 |- | DisTract is freely distributable under the terms of a 3-Clause  |+ | GraphViz is freely distributable under the terms of a 3-Clause  |  | BSD-style license.                                              |  |                                                                 |  \-----------------------------------------------------------------}@@ -58,26 +59,26 @@  readArrowType :: Parser Char ArrowType readArrowType-              = oneOf [ optionalQuotedString "normal" >> return Normal   -                      , optionalQuotedString "inv" >> return Inv      -                      , optionalQuotedString "dot" >> return Dot      -                      , optionalQuotedString "invdot" >> return InvDot   -                      , optionalQuotedString "odot" >> return ODot     -                      , optionalQuotedString "invodot" >> return InvODot  -                      , optionalQuotedString "noarrow" >> return NoArrow  -                      , optionalQuotedString "tee" >> return Tee      -                      , optionalQuotedString "empty" >> return Empty    -                      , optionalQuotedString "invempty" >> return InvEmpty -                      , optionalQuotedString "diamond" >> return Diamond  -                      , optionalQuotedString "odiamond" >> return ODiamond -                      , optionalQuotedString "ediamond" >> return EDiamond -                      , optionalQuotedString "crow" >> return Crow     -                      , optionalQuotedString "box" >> return Box      -                      , optionalQuotedString "obox" >> return OBox     -                      , optionalQuotedString "open" >> return Open     -                      , optionalQuotedString "halfopen" >> return HalfOpen -                      , optionalQuotedString "vee" >> return Vee      -                      ]                                          +              = oneOf [ optionalQuotedString "normal" >> return Normal+                      , optionalQuotedString "inv" >> return Inv+                      , optionalQuotedString "dot" >> return Dot+                      , optionalQuotedString "invdot" >> return InvDot+                      , optionalQuotedString "odot" >> return ODot+                      , optionalQuotedString "invodot" >> return InvODot+                      , optionalQuotedString "noarrow" >> return NoArrow+                      , optionalQuotedString "tee" >> return Tee+                      , optionalQuotedString "empty" >> return Empty+                      , optionalQuotedString "invempty" >> return InvEmpty+                      , optionalQuotedString "diamond" >> return Diamond+                      , optionalQuotedString "odiamond" >> return ODiamond+                      , optionalQuotedString "ediamond" >> return EDiamond+                      , optionalQuotedString "crow" >> return Crow+                      , optionalQuotedString "box" >> return Box+                      , optionalQuotedString "obox" >> return OBox+                      , optionalQuotedString "open" >> return Open+                      , optionalQuotedString "halfopen" >> return HalfOpen+                      , optionalQuotedString "vee" >> return Vee+                      ]  data ColorType = RGB { red :: Word8                       , green :: Word8

@@ -1,10 +1,12 @@ {-# LANGUAGE PatternSignatures #-} - {- GraphViz ------------------------------------------------------\++ {--GraphViz ------------------------------------------------------\  |                                                                 |- | Copyright (c) 2008, Matthew Sackman (matthew@wellquite.org)     |+ | Copyright (c) 2008, Matthew Sackman (matthew@wellquite.org),    |+ |              Ivan Lazar Miljenovic (ivan.miljenovic@gmail.com)  |  |                                                                 |- | DisTract is freely distributable under the terms of a 3-Clause  |+ | GraphViz is freely distributable under the terms of a 3-Clause  |  | BSD-style license.                                              |  |                                                                 |  \-----------------------------------------------------------------}@@ -16,6 +18,9 @@  string :: String -> Parser Char String string = mapM char++strings :: [String] -> Parser Char String+strings = oneOf . map string  char :: Char -> Parser Char Char char = satisfy . (==)

@@ -1,10 +1,10 @@ Name:               graphviz-Version:            2008.9.6+Version:            2008.9.20 Stability:          Beta-Copyright:          Matthew Sackman+Copyright:          Matthew Sackman, Ivan Lazar Miljenovic Category:           Graphics Maintainer:         matthew@wellquite.org-Author:             Matthew Sackman+Author:             Matthew Sackman, Ivan Lazar Miljenovic License:            BSD3 License-File:       LICENSE Cabal-Version:      >= 1.2