graphviz 2008.9.20 → 2009.5.1

raw patch · 8 files changed

+614/−285 lines, 8 filesdep +arraydep ~basedep ~polyparsenew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: array

Dependency ranges changed: base, polyparse

API changes (from Hackage documentation)

Files

• Data/GraphViz.hs +51/−235
• Data/GraphViz/Attributes.hs +30/−27
• Data/GraphViz/Commands.hs +215/−0
• Data/GraphViz/ParserCombinators.hs +11/−11
• Data/GraphViz/Types.hs +161/−0
• Data/GraphViz/Types/Clustering.hs +114/−0
• TODO +10/−0
• graphviz.cabal +22/−12

@@ -1,176 +1,62 @@-{-# LANGUAGE RecordPuns+{-# LANGUAGE NamedFieldPuns            , ScopedTypeVariables            #-} - {--GraphViz ------------------------------------------------------\- |                                                                 |- | Copyright (c) 2008, Matthew Sackman (matthew@wellquite.org),    |- |              Ivan Lazar Miljenovic (ivan.miljenovic@gmail.com)  |- |                                                                 |- | GraphViz is freely distributable under the terms of a 3-Clause  |- | BSD-style license.                                              |- |                                                                 |- \-----------------------------------------------------------------}+{- |+   Module      : Data.GraphViz+   Description : GraphViz bindings for Haskell.+   Copyright   : (c) Matthew Sackman, Ivan Lazar Miljenovic+   License     : 3-Clause BSD-style+   Maintainer  : Ivan.Miljenovic@gmail.com +   This is the top-level module for the graphviz library.  It provides+   functions to convert 'Data.Graph.Inductive.Graph.Graph's into+   the /Dot/ language used by the /GraphViz/ program (as well as a+   limited ability to perform the reverse operation).++   Information about GraphViz and the Dot language can be found at:+   <http://graphviz.org/>++   Note that this module re-exports the "Data.GraphViz.Attributes"+   module, which exports a constructor that clashes with+   'Prelude.LT'.  As such, you may need to import either this module+   or the @Prelude@ qualified or hiding @LT@.++   -}+ module Data.GraphViz     ( graphToDot     , clusterGraphToDot     , graphToGraph-    , readDotGraph-    , commandFor-    , DotGraph (..)-    , DotNode (..)-    , DotEdge (..)+    , dotizeGraph     , NodeCluster(..)     , AttributeNode     , AttributeEdge+    , module Data.GraphViz.Types     , module Data.GraphViz.Attributes+    , module Data.GraphViz.Commands     )     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-import Control.Concurrent+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.ParserCombinators--data DotGraph = DotGraph { graphAttributes :: [Attribute]-                         , graphNodes :: [DotNode]-                         , graphEdges :: [DotEdge]-                         , directedGraph :: Bool-                         }--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 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, directedEdge })-        = '\t' : ((show edgeTailNodeID) ++ edge ++ (show edgeHeadNodeID) ++ attributes)-          where-            edge = " " ++ (if directedEdge then dirEdge else undirEdge) ++ " "-            attributes = case edgeAttributes of-                           [] -> ";"-                           a  -> ' ':((show a) ++ ";")--instance Show DotGraph where-    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"+import Data.GraphViz.Commands --- | 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.+-- | Determine if the given graph is undirected or directed. isUndir   :: (Ord b, Graph g) => g a b -> Bool isUndir g = all hasFlip edges     where@@ -179,8 +65,9 @@       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 the appropriate command on it (found using 'commandFor').+-- -----------------------------------------------------------------------------++-- | Convert a graph to GraphViz's /Dot/ format. graphToDot :: (Ord b, Graph gr) => gr a b -> [Attribute]            -> (LNode a -> [Attribute]) -> (LEdge b -> [Attribute]) -> DotGraph graphToDot graph graphAttributes fmtNode fmtEdge@@ -190,9 +77,8 @@         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').+-- | Convert a graph to /Dot/ format, using the specified clustering function+--   to group nodes into clusters. --   Clusters can be nested to arbitrary depth. clusterGraphToDot :: (Ord c, Ord b, Graph gr) => gr a b                   -> [Attribute] -> (LNode a -> NodeCluster c a)@@ -201,8 +87,7 @@ 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+        graphNodes = clustersToNodes clusterBy fmtCluster fmtNode graph         directedGraph = not $ isUndir graph         graphEdges = catMaybes . map mkDotEdge . labEdges $ graph         mkDotEdge e@(f,t,_) = if (directedGraph || f <= t)@@ -212,34 +97,7 @@                                                   ,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)@@ -250,15 +108,9 @@ 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 (command++" -Tdot")-         ; hPutStr inp (show dot)-         ; hClose inp-         ; forkIO $ (hGetContents errp >>= hPutStr stderr)-         ; res <- hGetContents outp+    = do { out <- graphvizWithHandle command dot DotOutput hGetContents+         ; let res = fromJust out          ; (length res) `seq` return ()-         ; hClose outp-         ; hClose errp-         ; waitForProcess proc          ; return $ rebuildGraphWithAttributes res          }     where@@ -279,49 +131,13 @@                 where                   getLabel c = (fromJust $ Map.lookup c edgeMap,l) -readDotNode :: Parser Char DotNode-readDotNode = do { optional whitespace-                 ; nodeID <- number-                 ; as <- optional (whitespace >> readAttributesList)-                 ; char ';'-                 ; skipToNewline-                 ; return (DotNode { nodeID, nodeAttributes = fromMaybe [] as })-                 }--readDotEdge :: Parser Char DotEdge-readDotEdge = do { optional whitespace-                 ; edgeTailNodeID <- number-                 ; whitespace-                 ; edge <- strings [dirEdge,undirEdge]-                 ; whitespace-                 ; edgeHeadNodeID <- number-                 ; as <- optional (whitespace >> readAttributesList)-                 ; char ';'-                 ; skipToNewline-                 ; return (DotEdge { edgeHeadNodeID-                                   , edgeTailNodeID-                                   , edgeAttributes = fromMaybe [] as-                                   , directedEdge = edge == dirEdge })-                 }+-- | Pass the plain graph through 'graphToGraph'.  This is an @IO@ action,+--   however since the state doesn't change it's safe to use 'unsafePerformIO'+--   to convert this to a normal function.+dotizeGraph   :: (DynGraph gr, Ord b) => gr a b+              -> gr (AttributeNode a) (AttributeEdge b)+dotizeGraph g = unsafePerformIO+                $ graphToGraph g gAttrs noAttrs noAttrs     where---readDotGraph :: Parser Char DotGraph-readDotGraph = do { d <- strings [dirGraph,undirGraph]-                  ; let directedGraph = d == dirGraph-                  ; whitespace-                  ; char '{'-                  ; skipToNewline-                  ; graphAttributes-                      <- liftM concat $-                         many (optional whitespace >>-                               oneOf [ (string "edge" >> skipToNewline >> return [])-                                     , (string "node" >> skipToNewline >> return [])-                                     , (string "graph" >> whitespace >> readAttributesList >>= \as -> skipToNewline >> return as)-                                     ]-                              )-                  ; graphNodes <- many readDotNode-                  ; graphEdges <- many readDotEdge-                  ; char '}'-                  ; return $ DotGraph { graphAttributes, graphNodes, graphEdges, directedGraph }-                  }+      gAttrs = []+      noAttrs = const []

@@ -1,24 +1,27 @@-{-# LANGUAGE RecordPuns-           , PatternSignatures+{-# LANGUAGE NamedFieldPuns+           , ScopedTypeVariables            #-} - {- GraphViz ------------------------------------------------------\- |                                                                 |- | Copyright (c) 2008, Matthew Sackman (matthew@wellquite.org),    |- |              Ivan Lazar Miljenovic (ivan.miljenovic@gmail.com)  |- |                                                                 |- | GraphViz is freely distributable under the terms of a 3-Clause  |- | BSD-style license.                                              |- |                                                                 |- \-----------------------------------------------------------------}+{- |+   Module      : Data.GraphViz.Attributes+   Description : Definition of the GraphViz attributes.+   Copyright   : (c) Matthew Sackman, Ivan Lazar Miljenovic+   License     : 3-Clause BSD-style+   Maintainer  : Ivan.Miljenovic@gmail.com +   This module defines the various attributes that different parts of+   a GraphViz graph can have.  Note that when using this module, you+   may need to either import it or @Prelude@ qualified or hiding+   @LT@, as this module exports a constructor with the same name.+  -}+ module Data.GraphViz.Attributes where  import Prelude hiding (LT)  import Data.Word import Numeric-import Text.ParserCombinators.PolyLazy+import Text.ParserCombinators.Poly.Lazy import Control.Monad import Data.Maybe @@ -37,25 +40,25 @@                  deriving (Eq)  instance Show ArrowType where-    show Normal = "normal"-    show Inv = "inv"-    show Dot = "dot"-    show InvDot = "invdot"-    show ODot = "odot"-    show InvODot = "invodot"-    show NoArrow = "none"-    show Tee = "tee"-    show Empty = "empty"+    show Normal   = "normal"+    show Inv      = "inv"+    show Dot      = "dot"+    show InvDot   = "invdot"+    show ODot     = "odot"+    show InvODot  = "invodot"+    show NoArrow  = "none"+    show Tee      = "tee"+    show Empty    = "empty"     show InvEmpty = "invempty"-    show Diamond = "diamond"+    show Diamond  = "diamond"     show ODiamond = "odiamond"     show EDiamond = "ediamond"-    show Crow = "crow"-    show Box = "box"-    show OBox = "obox"-    show Open = "open"+    show Crow     = "crow"+    show Box      = "box"+    show OBox     = "obox"+    show Open     = "open"     show HalfOpen = "halfopen"-    show Vee = "vee"+    show Vee      = "vee"  readArrowType :: Parser Char ArrowType readArrowType

@@ -0,0 +1,215 @@+{- |+   Module      : Data.GraphViz.Commands+   Description : Functions to run GraphViz commands.+   Copyright   : (c) Matthew Sackman, Ivan Lazar Miljenovic+   License     : 3-Clause BSD-style+   Maintainer  : Ivan.Miljenovic@gmail.com++   This module defines functions to call the various GraphViz+   commands.++   Most of these functions were from version 0.5 of /Graphalyze/:++   <http://hackage.haskell.org/cgi-bin/hackage-scripts/package/Graphalyze-0.5>+-}++module Data.GraphViz.Commands+    ( GraphvizCommand(..)+    , dirCommand+    , undirCommand+    , commandFor+    , GraphvizOutput(..)+    , runGraphviz+    , runGraphvizCommand+    , graphvizWithHandle+    )+    where++import System.IO+import System.Exit+import System.Process+import Data.Array.IO+import Control.Concurrent+import Control.Exception++import Data.GraphViz.Types++-- | The available Graphviz commands.+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"++-- | The default command for directed graphs.+dirCommand :: GraphvizCommand+dirCommand = DotCmd++-- | The default command for undirected graphs.+undirCommand :: GraphvizCommand+undirCommand = Neato++-- | The appropriate (default) GraphViz command for the given graph.+commandFor    :: DotGraph -> GraphvizCommand+commandFor dg = if (directedGraph dg)+                then dirCommand+                else undirCommand++-- | The possible Graphviz outputs, obtained by running /dot -Txxx/.+--   Note that it is not possible to choose between output variants,+--   and that not all of these may be available on your system.+--+--   This will probably be improved in future.+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"++-- | Run the recommended Graphviz command on this graph, saving the result+--   to the file provided (note: file extensions are /not/ checked).+--   Returns @True@ if successful, @False@ otherwise.+runGraphviz         :: DotGraph -> GraphvizOutput -> FilePath -> IO Bool+runGraphviz gr t fp = runGraphvizCommand (commandFor gr) gr t fp++-- | Run the chosen Graphviz command on this graph, saving the result+--   to the file provided (note: file extensions are /not/ checked).+--   Returns @True@ if successful, @False@ otherwise.+runGraphvizCommand :: GraphvizCommand -> DotGraph -> GraphvizOutput+                   -> FilePath -> IO Bool+runGraphvizCommand  cmd gr t fp+    = do pipe <- tryJust catcher $ 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+    where+      catcher   :: IOError -> Maybe ()+      catcher _ = Just ()++-- graphvizWithHandle sometimes throws an error about handles not+-- being closed properly: investigate.++-- | Run the chosen Graphviz command on this graph, but send the result to the+--   given handle rather than to a file.+--   The result is wrapped in 'Maybe' rather than throwing an error.+graphvizWithHandle :: (Show a) => GraphvizCommand -> 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+         -- Don't close outp until f finishes.+         a `seq` hClose outp+         exitCode <- waitForProcess proc+         case exitCode of+           ExitSuccess -> return (Just a)+           _           -> return Nothing+    where+      command = (show cmd) ++ " -T" ++ (show t)++{- |+   This function is taken from the /mohws/ project, available under a+   3-Clause BSD license.  The actual function is taken from:+   <http://code.haskell.org/mohws/src/Util.hs>+   It provides an efficient way of transferring data from one 'Handle'+   to another.+ -}+squirt :: Handle -> Handle -> IO ()+squirt rd wr = do+  arr <- newArray_ (0, bufsize-1)+  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+      -- This was originally separate+      bufsize :: Int+      bufsize = 4 * 1024+

@@ -1,19 +1,19 @@-{-# LANGUAGE PatternSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-} +{- |+   Module      : Data.GraphViz.ParserCombinators+   Description : Helper functions for Parsing.+   Copyright   : (c) Matthew Sackman, Ivan Lazar Miljenovic+   License     : 3-Clause BSD-style+   Maintainer  : Ivan.Miljenovic@gmail.com - {--GraphViz ------------------------------------------------------\- |                                                                 |- | Copyright (c) 2008, Matthew Sackman (matthew@wellquite.org),    |- |              Ivan Lazar Miljenovic (ivan.miljenovic@gmail.com)  |- |                                                                 |- | GraphViz is freely distributable under the terms of a 3-Clause  |- | BSD-style license.                                              |- |                                                                 |- \-----------------------------------------------------------------}+   This module defines simple helper functions for use with+   @Text.ParserCombinators.Poly.Lazy@.+-}  module Data.GraphViz.ParserCombinators where -import Text.ParserCombinators.PolyLazy+import Text.ParserCombinators.Poly.Lazy import Control.Monad  string :: String -> Parser Char String

@@ -0,0 +1,161 @@+{-# LANGUAGE NamedFieldPuns+           , ScopedTypeVariables+           #-}++{- |+   Module      : Data.GraphViz.Types+   Description : Definition of the GraphViz types.+   Copyright   : (c) Matthew Sackman, Ivan Lazar Miljenovic+   License     : 3-Clause BSD-style+   Maintainer  : Ivan.Miljenovic@gmail.com++   This module defines the overall types and methods that interact+   with them for the GraphViz library.+-}++module Data.GraphViz.Types+    ( DotGraph(..)+    , DotNode(..)+    , DotEdge(..)+    , readDotGraph+    ) where++import Data.Maybe+import Control.Monad+import Text.ParserCombinators.Poly.Lazy++import Data.GraphViz.Attributes+import Data.GraphViz.ParserCombinators++-- -----------------------------------------------------------------------------++-- | The internal representation of a graph in Dot form.+data DotGraph = DotGraph { graphAttributes :: [Attribute]+                         , graphNodes :: [DotNode]+                         , graphEdges :: [DotEdge]+                         , directedGraph :: Bool+                         }++instance Show DotGraph where+    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)++dirGraph :: String+dirGraph = "digraph"++undirGraph :: String+undirGraph = "graph"++-- -----------------------------------------------------------------------------++-- | A node in 'DotGraph' is either a singular node, or a cluster+--   containing nodes (or more clusters) within it.+data DotNode+    = DotNode { nodeID :: Int+              , nodeAttributes :: [Attribute]+              }+    | DotCluster { clusterID         :: String+                 , clusterAttributes :: [Attribute]+                 , clusterElems      :: [DotNode]+                 }++instance Show DotNode where+    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++-- | Prefix each 'String' with a tab character.+addTabs :: [String] -> [String]+addTabs = map ('\t':)++-- -----------------------------------------------------------------------------++-- | An edge in 'DotGraph'.+data DotEdge = DotEdge { edgeHeadNodeID :: Int+                       , edgeTailNodeID :: Int+                       , edgeAttributes :: [Attribute]+                       , directedEdge   :: Bool+                       }++instance Show DotEdge where+    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) ++ ";")++dirEdge :: String+dirEdge = "->"++undirEdge :: String+undirEdge = "--"++-- -----------------------------------------------------------------------------++-- | Parse a 'DotNode'+readDotNode :: Parser Char DotNode+readDotNode = do { optional whitespace+                 ; nodeID <- number+                 ; as <- optional (whitespace >> readAttributesList)+                 ; char ';'+                 ; skipToNewline+                 ; return (DotNode { nodeID, nodeAttributes = fromMaybe [] as })+                 }++-- | Parse a 'DotEdge'+readDotEdge :: Parser Char DotEdge+readDotEdge = do { optional whitespace+                 ; edgeTailNodeID <- number+                 ; whitespace+                 ; edge <- strings [dirEdge,undirEdge]+                 ; whitespace+                 ; edgeHeadNodeID <- number+                 ; as <- optional (whitespace >> readAttributesList)+                 ; char ';'+                 ; skipToNewline+                 ; return (DotEdge { edgeHeadNodeID+                                   , edgeTailNodeID+                                   , edgeAttributes = fromMaybe [] as+                                   , directedEdge = edge == dirEdge })+                 }++-- | Parse a 'DotGraph'+readDotGraph :: Parser Char DotGraph+readDotGraph = do { d <- strings [dirGraph,undirGraph]+                  ; let directedGraph = d == dirGraph+                  ; whitespace+                  ; char '{'+                  ; skipToNewline+                  ; graphAttributes+                      <- liftM concat $+                         many (optional whitespace >>+                               oneOf [ (string "edge" >> skipToNewline >> return [])+                                     , (string "node" >> skipToNewline >> return [])+                                     , (string "graph" >> whitespace >> readAttributesList >>= \as -> skipToNewline >> return as)+                                     ]+                              )+                  ; graphNodes <- many readDotNode+                  ; graphEdges <- many readDotEdge+                  ; char '}'+                  ; return $ DotGraph { graphAttributes, graphNodes, graphEdges, directedGraph }+                  }

@@ -0,0 +1,114 @@+{-# OPTIONS_HADDOCK hide #-}++{- |+   Module      : Data.GraphViz.Types.Clustering+   Description : Definition of the clustering types for GraphViz.+   Copyright   : (c) Matthew Sackman, Ivan Lazar Miljenovic+   License     : 3-Clause BSD-style+   Maintainer  : Ivan.Miljenovic@gmail.com++   This module defines types for creating clusters.+-}++module Data.GraphViz.Types.Clustering+    ( NodeCluster(..)+    , clustersToNodes+    ) where++-- LT is defined in Attributes+import Prelude hiding (LT)+import qualified Prelude as P++import Data.GraphViz.Types+import Data.GraphViz.Attributes++import Data.List(groupBy, sortBy, mapAccumL)+import Data.Graph.Inductive.Graph(Graph, LNode, labNodes)++-- -----------------------------------------------------------------------------++-- | 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)++-- | Create the @'DotNode'@s for the given graph.+clustersToNodes :: (Ord c, Graph gr) => (LNode a -> NodeCluster c a)+                   -> (c -> [Attribute]) -> (LNode a -> [Attribute])+                   -> gr a b -> [DotNode]+clustersToNodes clusterBy fmtCluster fmtNode+    = treesToNodes fmtCluster fmtNode+      . collapseNClusts+      . map (clustToTree . clusterBy)+      . labNodes++-- -----------------------------------------------------------------------------++-- | 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)]+++-- | Convert the cluster representation of the trees into @'DotNode'@s.+--   Clusters will be labelled with @'Int'@s.+treesToNodes :: (c -> [Attribute]) -> (LNode a -> [Attribute])+             -> [ClusterTree c a] -> [DotNode]+treesToNodes fmtCluster fmtNode = snd . treesToNodesFrom fmtCluster fmtNode 0++-- | Start labelling the clusters with this @'Int'@.+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'+                         }

@@ -0,0 +1,10 @@+Areas to work on:++* Add support for Data.Graph-style graphs.++* Allow user to choose whether or not the graph is meant to be+  directed or undirected.++* Ensure Data.GraphViz.Attributes contains all supported attributes for Dot.++* Remove (or at least minimise) usage of extensions.

@@ -1,27 +1,37 @@ Name:               graphviz-Version:            2008.9.20+Version:            2009.5.1 Stability:          Beta Copyright:          Matthew Sackman, Ivan Lazar Miljenovic Category:           Graphics-Maintainer:         matthew@wellquite.org+Maintainer:         Ivan.Miljenovic@gmail.com Author:             Matthew Sackman, Ivan Lazar Miljenovic License:            BSD3 License-File:       LICENSE-Cabal-Version:      >= 1.2+Extra-Source-Files: TODO+Cabal-Version:      >= 1.6 Build-Type:         Simple-Synopsis:           GraphViz wrapper for Haskell+Synopsis:           GraphViz wrapper for Haskell. Description:-  Allows you to convert Data.Graph... graphs into dot format,-  and parse them back in, as a Dot structure.+  Provides convenient functions to convert FGL graphs into the Dot+  language used by the GraphViz (http://graphviz.org/) programs with a+  large degree of customisation for layout, etc. -  Or, you can run your Data.Graph...graph via dot, get the positional-  information out from dot and build a new graph, combining the-  positional information with the original graph.+  Also allows a limited amount of parsing of Dot, and usage of+  GraphViz to attach positional data to each node and edge in the+  graph.  Library {-        Build-depends:     base, containers, process, fgl, polyparse-        Exposed-modules:   Data.GraphViz+        Build-Depends:     base == 4.*, containers, process, array,+                           fgl, polyparse >= 1.1++        Exposed-Modules:   Data.GraphViz+                           Data.GraphViz.Types+                           Data.GraphViz.Commands                            Data.GraphViz.Attributes++        Other-Modules:     Data.GraphViz.Types.Clustering                            Data.GraphViz.ParserCombinators-        ghc-options:       -Wall -fno-warn-name-shadowing++        Ghc-Options:       -Wall -fno-warn-name-shadowing+        Ghc-Prof-Options:  -prof -auto-all }