diff --git a/Data/GraphViz.hs b/Data/GraphViz.hs
--- a/Data/GraphViz.hs
+++ b/Data/GraphViz.hs
@@ -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:
+
+
+ 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 []
diff --git a/Data/GraphViz/Attributes.hs b/Data/GraphViz/Attributes.hs
--- a/Data/GraphViz/Attributes.hs
+++ b/Data/GraphViz/Attributes.hs
@@ -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
diff --git a/Data/GraphViz/Commands.hs b/Data/GraphViz/Commands.hs
new file mode 100644
--- /dev/null
+++ b/Data/GraphViz/Commands.hs
@@ -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/:
+
+
+-}
+
+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:
+
+ 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
+
diff --git a/Data/GraphViz/ParserCombinators.hs b/Data/GraphViz/ParserCombinators.hs
--- a/Data/GraphViz/ParserCombinators.hs
+++ b/Data/GraphViz/ParserCombinators.hs
@@ -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
diff --git a/Data/GraphViz/Types.hs b/Data/GraphViz/Types.hs
new file mode 100644
--- /dev/null
+++ b/Data/GraphViz/Types.hs
@@ -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 }
+ }
diff --git a/Data/GraphViz/Types/Clustering.hs b/Data/GraphViz/Types/Clustering.hs
new file mode 100644
--- /dev/null
+++ b/Data/GraphViz/Types/Clustering.hs
@@ -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'
+ }
diff --git a/TODO b/TODO
new file mode 100644
--- /dev/null
+++ b/TODO
@@ -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.
diff --git a/graphviz.cabal b/graphviz.cabal
--- a/graphviz.cabal
+++ b/graphviz.cabal
@@ -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
}