diff --git a/Changelog b/Changelog
--- a/Changelog
+++ b/Changelog
@@ -1,3 +1,33 @@
+Changes in 2999.8.0.0
+=====================
+
+* Added support for generalised DotGraphs; this optional
+ representation removes the restriction of ordering of Dot
+ statements. This allows for greater flexibility of how to specify
+ Dot code. As an offshoot from this, most relevant functions now
+ utilise a new DotRepr class that work with both DotGraphs and the
+ new GDotGraphs; this shouldn't affect any code already in use.
+
+* With the prompting of Noam Lewis, the augmentation functions have
+ been revamped in two ways:
+
+ - Now contains support for multiple edges.
+
+ - The ability to perform "manual" augmentation if greater control is
+ desired.
+
+* Add a preview function to quickly render and visualise an FGL graph
+ using the Xlib canvas.
+
+* Added a pseudo-inverse of the FGL -> Dot functions (a graph is
+ created, but the original node and edge labels are unrecoverable).
+
+* The Printing and Parsing modules have been moved (from
+ Data.GraphViz.Types to Data.GraphViz).
+
+* Reworked file-generating commands such that they return the filename
+ of the created file if successful.
+
Changes in 2999.7.0.0
=====================
diff --git a/Data/GraphViz.hs b/Data/GraphViz.hs
--- a/Data/GraphViz.hs
+++ b/Data/GraphViz.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE FlexibleContexts #-}
+
{- |
Module : Data.GraphViz
Description : Graphviz bindings for Haskell.
@@ -13,39 +15,45 @@
Information about Graphviz and the Dot language can be found at:
- Commands for converting graphs to Dot format have two options: one
- in which the user specifies whether the graph is directed or
- undirected, and a primed version which attempts to automatically
- infer if the graph is directed or not. Note that these conversion
- functions assume that undirected graphs have every edge being
- duplicated (or at least that if there exists an edge from /n1/ to
- /n2/, then /n1 <= n2/).
-}
module Data.GraphViz
( -- * Conversion from graphs to /Dot/ format.
+ -- $conversion
graphToDot
, graphToDot'
-- ** Conversion with support for clusters.
, NodeCluster(..)
, clusterGraphToDot
, clusterGraphToDot'
- -- ** Utility functions
- , prettyPrint
- , prettyPrint'
- -- * Passing the graph through Graphviz.
+ -- ** Pseudo-inverse conversion.
+ , dotToGraph
+ -- * Graph augmentation.
+ -- $augment
-- ** Type aliases for @Node@ and @Edge@ labels.
, AttributeNode
, AttributeEdge
- -- ** For normal graphs.
+ -- ** Customisable augmentation.
, graphToGraph
, graphToGraph'
- , dotizeGraph
- , dotizeGraph'
- -- ** For clustered graphs.
, clusterGraphToGraph
, clusterGraphToGraph'
+ -- ** Quick augmentation.
+ -- $quickAugment
+ , dotizeGraph
+ , dotizeGraph'
, dotizeClusterGraph
, dotizeClusterGraph'
+ -- ** Manual augmentation.
+ -- $manualAugment
+ , EdgeID
+ , addEdgeIDs
+ , setEdgeComment
+ , dotAttributes
+ , augmentGraph
+ -- * Utility functions
+ , prettyPrint
+ , prettyPrint'
+ , preview
-- * Re-exporting other modules.
, module Data.GraphViz.Types
, module Data.GraphViz.Attributes
@@ -54,17 +62,18 @@
import Data.GraphViz.Types
import Data.GraphViz.Types.Clustering
+import Data.GraphViz.Util(uniq, uniqBy)
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 Data.Maybe(mapMaybe, isNothing)
import qualified Data.Map as Map
import Control.Monad(liftM)
import System.IO.Unsafe(unsafePerformIO)
+import Control.Concurrent(forkIO)
-- -----------------------------------------------------------------------------
@@ -83,8 +92,24 @@
-- -----------------------------------------------------------------------------
--- | Convert a graph to Graphviz's /Dot/ format. The 'Bool' value is
--- 'True' for directed graphs, 'False' otherwise.
+{- $conversion
+ There are various functions available for converting 'Graph's to
+ Graphviz's /Dot/ format (represented using the 'DotGraph' type).
+ There are two main types: converting plain graphs and converting
+ /clustered/ graphs (where the graph cluster that a particular 'Node'
+ belongs to is determined by its label).
+
+ These functions have two versions: one in which the user specifies
+ whether the graph is directed or undirected (with a 'Bool' value of
+ 'True' indicating that the graph is directed), and a primed version
+ which attempts to automatically infer if the graph is directed or not.
+ Note that these conversion functions assume that undirected graphs
+ have every edge being duplicated (or at least that if there exists an
+ edge from /n1/ to /n2/, then /n1 <= n2/; if /n1 > n2/ then it is
+ removed for an undirected graph).
+-}
+
+-- | Convert a graph to Graphviz's /Dot/ format.
graphToDot :: (Graph gr) => Bool -> gr a b -> [GlobalAttributes]
-> (LNode a -> Attributes) -> (LEdge b -> Attributes)
-> DotGraph Node
@@ -103,10 +128,32 @@
-> DotGraph Node
graphToDot' graph = graphToDot (isDirected graph) graph
+-- | A pseudo-inverse to 'graphToDot' and 'graphToDot''; \"pseudo\" in
+-- the sense that the original node and edge labels aren't able to
+-- be reconstructed.
+dotToGraph :: (DotRepr dg Node, Graph gr) => dg Node
+ -> gr Attributes Attributes
+dotToGraph dg = mkGraph ns' es
+ where
+ -- Applying uniqBy just in case...
+ ns = uniqBy fst . map toLN $ graphNodes dg
+ es = concatMap toLE $ graphEdges dg
+ -- Need to ensure that for some reason there are node IDs in an
+ -- edge but not on their own.
+ nSet = Set.fromList $ map fst ns
+ nEs = map (flip (,) [])
+ . uniq
+ . filter (flip Set.notMember nSet)
+ $ concatMap (\(n1,n2,_) -> [n1,n2]) es
+ ns' = ns ++ nEs
+ -- Conversion functions
+ toLN (DotNode n as) = (n,as)
+ toLE (DotEdge f t d as) = (if d then id else (:) (t,f,as)) [(f,t,as)]
+
+
-- | Convert a graph to /Dot/ format, using the specified clustering function
-- to group nodes into clusters.
-- Clusters can be nested to arbitrary depth.
--- The 'Bool' argument is 'True' for directed graphs, 'False' otherwise.
clusterGraphToDot :: (Ord c, Graph gr) => Bool -> gr a b
-> [GlobalAttributes] -> (LNode a -> NodeCluster c l)
-> (c -> Maybe GraphID) -> (c -> [GlobalAttributes])
@@ -147,57 +194,53 @@
-- -----------------------------------------------------------------------------
+{- $augment
+ The following functions provide support for passing a 'Graph'
+ through the appropriate 'GraphvizCommand' to augment the 'Graph' by
+ adding positional information, etc.
+
+ Please note that there are some restrictions on this: to enable
+ support for multiple edges between two nodes, the 'Comment'
+ 'Attribute' is used to provide a unique identifier for each edge. As
+ such, you should /not/ set this 'Attribute' for any 'LEdge'.
+
+ For unprimed functions, the 'Bool' argument is 'True' for directed
+ graphs, 'False' otherwise; for the primed versions of functions the
+ directionality of the graph is automatically inferred. Directed
+ graphs are passed through 'Dot', and undirected graphs through
+ 'Neato'.
+ Note that the reason these functions do not have 'unsafePerformIO'
+ applied to them is because if you set a global 'Attribute' of:
+
+ @
+ 'Start' ('StartStyle' 'RandomStyle')
+ @
+
+ then it will not necessarily be referentially transparent (ideally,
+ no matter what the seed is, it will still eventually be drawn to the
+ same optimum, but this can't be guaranteed). As such, if you are sure
+ that you're not using such an 'Attribute', then you should be able to
+ use 'unsafePerformIO' directly in your own code.
+-}
+
type AttributeNode a = (Attributes, a)
type AttributeEdge b = (Attributes, b)
-- | Run the appropriate Graphviz command on the graph to get
-- positional information and then combine that information back
--- into the original graph. Note that for the edge information to
--- be parsed properly when using multiple edges, each edge between
--- two nodes needs to have a unique label.
---
--- The 'Bool' argument is 'True' for directed graphs, 'False'
--- otherwise. Directed graphs are passed through /dot/, and
--- undirected graphs through /neato/.
+-- into the original graph.
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
+ = dotAttributes isDir gr' dot
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
+ dot = graphToDot isDir gr' gAttributes fmtNode (setEdgeComment fmtEdge)
+ gr' = addEdgeIDs gr
-- | Run the appropriate Graphviz command on the graph to get
-- positional information and then combine that information back
-- into the original graph.
---
-- Graph direction is automatically inferred.
graphToGraph' :: (Ord b, Graph gr) => gr a b -> [GlobalAttributes]
-> (LNode a -> Attributes) -> (LEdge b -> Attributes)
@@ -206,27 +249,22 @@
-- | Run the appropriate Graphviz command on the clustered graph to
-- get positional information and then combine that information back
--- into the original graph. Note that for the edge information to
--- be parsed properly when using multiple edges, each edge between
--- two nodes needs to have a unique label.
---
--- The 'Bool' argument is 'True' for directed graphs, 'False'
--- otherwise. Directed graphs are passed through /dot/, and
--- undirected graphs through /neato/.
+-- into the original graph.
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
+ = dotAttributes isDir gr' dot
where
- dot = clusterGraphToDot isDir gr gAtts clBy cID fmtClust fmtNode fmtEdge
+ dot = clusterGraphToDot isDir gr' gAtts clBy cID fmtClust fmtNode fmtEdge'
+ gr' = addEdgeIDs gr
+ fmtEdge' = setEdgeComment fmtEdge
-- | Run the appropriate Graphviz command on the clustered graph to
-- get positional information and then combine that information back
-- into the original graph.
---
-- Graph direction is automatically inferred.
clusterGraphToGraph' :: (Ord b, Ord c, Graph gr) => gr a b
-> [GlobalAttributes] -> (LNode a -> NodeCluster c l)
@@ -235,15 +273,16 @@
-> IO (gr (AttributeNode a) (AttributeEdge b))
clusterGraphToGraph' gr = clusterGraphToGraph (isDirected gr) gr
+-- -----------------------------------------------------------------------------
--- | Pass the graph through 'graphToGraph' with no 'Attribute's. 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.
---
--- The 'Bool' argument is 'True' for directed graphs, 'False'
--- otherwise. Directed graphs are passed through /dot/, and
--- undirected graphs through /neato/.
+{- $quickAugment
+ This section contains convenience functions for quick-and-dirty
+ augmentation of graphs. No 'Attribute's are applied, and
+ 'unsafePerformIO' is used to make these normal functions. Note that
+ this should be safe since these should be referentially transparent.
+-}
+
+-- | Pass the graph through 'graphToGraph' with no 'Attribute's.
dotizeGraph :: (Graph gr) => Bool -> gr a b
-> gr (AttributeNode a) (AttributeEdge b)
dotizeGraph isDir g = unsafePerformIO
@@ -252,24 +291,14 @@
gAttrs = []
noAttrs = const []
--- | Pass the graph through 'graphToGraph' with no 'Attribute's. 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.
---
+-- | Pass the graph through 'graphToGraph' with no 'Attribute's.
-- The graph direction is automatically inferred.
dotizeGraph' :: (Graph gr, Ord b) => gr a b
-> gr (AttributeNode a) (AttributeEdge b)
dotizeGraph' g = dotizeGraph (isDirected g) g
-- | Pass the clustered graph through 'clusterGraphToGraph' with no
--- 'Attribute's. 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.
---
--- The 'Bool' argument is 'True' for directed graphs, 'False'
--- otherwise. Directed graphs are passed through /dot/, and
--- undirected graphs through /neato/.
+-- 'Attribute's.
dotizeClusterGraph :: (Ord c, Graph gr) => Bool -> gr a b
-> (LNode a -> NodeCluster c l)
-> gr (AttributeNode a) (AttributeEdge b)
@@ -284,11 +313,8 @@
cAttrs = const gAttrs
noAttrs = const []
--- | Pass the clustered graph through 'graphToGraph' with no
--- 'Attribute's. 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.
---
+-- | Pass the clustered graph through 'clusterGraphToGraph' with no
+-- 'Attribute's.
-- The graph direction is automatically inferred.
dotizeClusterGraph' :: (Ord b, Ord c, Graph gr) => gr a b
-> (LNode a -> NodeCluster c l)
@@ -296,28 +322,136 @@
dotizeClusterGraph' g = dotizeClusterGraph (isDirected g) g
-- -----------------------------------------------------------------------------
+
+{- $manualAugment
+
+ This section allows you to manually augment graphs by providing
+ fine-grained control over the augmentation process (the standard
+ augmentation functions compose these together). Possible reasons for
+ manual augmentation are:
+
+ * Gain access to the intermediary 'DotRepr' used.
+
+ * Convert the default 'DotGraph' to a @GDotGraph@ (found in
+ "Data.GraphViz.Types.Generalised") so as to have greater control over
+ the generated Dot code.
+
+ * Use a specific 'GraphvizCommand' rather than the default.
+
+ Note that whilst these functions provide you with more control, you
+ must be careful how you use them: if you use the wrong 'DotRepr' for
+ a 'Graph', then the behaviour of 'augmentGraph' (and all functions
+ that use it) is undefined. The main point is to make sure that the
+ defined 'DotNode' and 'DotEdge' values aren't removed (or their ID
+ values - or the 'Comment' 'Attribute' for the 'DotEdge's - altered) to
+ ensure that it is possible to match up the nodes and edges in the
+ 'Graph' with those in the 'DotRepr'.
+
+-}
+
+-- | Used to augment an edge label with a unique identifier.
+data EdgeID b = EID { eID :: String
+ , eLbl :: b
+ }
+ deriving (Eq, Ord, Show)
+-- Show is only provided for printing/debugging purposes when using a
+-- normal Tree-based graph. Since it doesn't support Read, neither
+-- does EdgeID.
+
+-- | Add unique edge identifiers to each label. This is useful for
+-- when multiple edges between two nodes need to be distinguished.
+addEdgeIDs :: (Graph gr) => gr a b -> gr a (EdgeID b)
+addEdgeIDs g = mkGraph ns es'
+ where
+ ns = labNodes g
+ es = labEdges g
+ es' = zipWith addID es ([1..] :: [Int])
+ addID (f,t,l) i = (f,t,EID (show i) l)
+
+-- | Add the 'Comment' to the list of attributes containing the value
+-- of the unique edge identifier.
+setEdgeComment :: (LEdge b -> Attributes)
+ -> (LEdge (EdgeID b) -> Attributes)
+setEdgeComment f = \ e@(_,_,eid) -> Comment (eID eid) : (f . stripID) e
+
+-- | Remove the unique identifier from the 'LEdge'.
+stripID :: LEdge (EdgeID b) -> LEdge b
+stripID (f,t,eid) = (f,t, eLbl eid)
+
+-- | Pass the 'DotGraph' through the relevant command and then augment
+-- the 'Graph' that it came from.
+dotAttributes :: (Graph gr, DotRepr dg Node) => Bool -> gr a (EdgeID b)
+ -> dg Node -> IO (gr (AttributeNode a) (AttributeEdge b))
+dotAttributes isDir gr dot
+ = liftM (augmentGraph gr . parseDG . fromDotResult)
+ $ graphvizWithHandle command dot DotOutput hGetContents'
+ where
+ parseDG = asTypeOf dot . parseDotGraph
+ command = if isDir then dirCommand else undirCommand
+
+-- | Use the 'Attributes' in the provided 'DotGraph' to augment the
+-- node and edge labels in the provided 'Graph'. The unique
+-- identifiers on the edges are also stripped off.
+--
+-- Please note that the behaviour for this function is undefined if
+-- the 'DotGraph' does not come from the original 'Graph' (either
+-- by using a conversion function or by passing the result of a
+-- conversion function through a 'GraphvizCommand' via the
+-- 'DotOutput' or similar).
+augmentGraph :: (Graph gr, DotRepr dg Node) => gr a (EdgeID b)
+ -> dg Node -> gr (AttributeNode a) (AttributeEdge b)
+augmentGraph g dg = mkGraph lns les
+ where
+ lns = map (\(n, l) -> (n, (nodeMap Map.! n, l)))
+ $ labNodes g
+ les = map augmentEdge $ labEdges g
+ augmentEdge (f,t,(EID eid l)) = (f,t, (edgeMap Map.! eid, l))
+ ns = graphNodes dg
+ es = graphEdges dg
+ nodeMap = Map.fromList $ map (nodeID &&& nodeAttributes) ns
+ edgeMap = Map.fromList $ map (findID &&& edgeAttributes') es
+ findID = head . mapMaybe commentID . edgeAttributes
+ commentID (Comment s) = Just s
+ commentID _ = Nothing
+ -- Strip out the comment
+ edgeAttributes' = filter (isNothing . commentID) . edgeAttributes
+
+
+-- -----------------------------------------------------------------------------
-- Utility Functions
-- | Pretty-print the 'DotGraph' by passing it through the 'Canon'
-- output type (which produces \"canonical\" output). This is
--- required because the @printIt@ function in
--- "Data.GraphViz.Types.Printing" no longer uses indentation to
--- ensure the Dot code is printed correctly.
-prettyPrint :: (PrintDot a) => DotGraph a -> IO String
-prettyPrint dg = liftM fromRight
+-- required because the 'printDotGraph' function (and all printing
+-- functions in "Data.GraphViz.Types.Printing") no longer uses
+-- indentation (this is to ensure the Dot code is printed correctly
+-- due to the limitations of the Pretty Printer used).
+prettyPrint :: (DotRepr dg n) => dg n -> IO String
+prettyPrint dg = liftM fromDotResult
-- Note that the choice of command here should be
-- arbitrary.
$ 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?"
-- | The 'unsafePerformIO'd version of 'prettyPrint'. Graphviz should
-- always produce the same pretty-printed output, so this should be
-- safe.
-prettyPrint' :: (PrintDot a) => DotGraph a -> String
+prettyPrint' :: (DotRepr dg n) => dg n -> String
prettyPrint' = unsafePerformIO . prettyPrint
+
+-- | Quickly visualise a graph using the 'Xlib' 'GraphvizCanvas'.
+preview :: (Ord b, Graph gr) => gr a b -> IO ()
+preview g = ign $ forkIO (ign $ runGraphvizCanvas' dg Xlib)
+ where
+ dg = graphToDot' g [] (const []) (const [])
+ ign = (>> return ())
+
+-- | Used for obtaining results from 'graphvizWithHandle', etc. when
+-- errors should only occur when Graphviz isn't installed. If the
+-- value is @'Left' _@, then 'error' is used.
+fromDotResult :: Either l r -> r
+fromDotResult (Right r) = r
+fromDotResult Left{} = error "Could not run the relevant Graphviz command; \
+ \is the Graphviz suite of tools installed?"
diff --git a/Data/GraphViz/Attributes.hs b/Data/GraphViz/Attributes.hs
--- a/Data/GraphViz/Attributes.hs
+++ b/Data/GraphViz/Attributes.hs
@@ -67,6 +67,10 @@
* Deprecated 'Overlap' algorithms are not defined.
+ * The global @Orientation@ attribute is not defined, as it is
+ difficult to distinguish from the node-based 'Orientation'
+ 'Attribute'; also, its behaviour is duplicated by 'Rotate'.
+
-}
module Data.GraphViz.Attributes
( -- * The actual /Dot/ attributes.
@@ -159,9 +163,9 @@
) where
import Data.GraphViz.Attributes.Colors
-import Data.GraphViz.Types.Internal
-import Data.GraphViz.Types.Parsing
-import Data.GraphViz.Types.Printing
+import Data.GraphViz.Util
+import Data.GraphViz.Parsing
+import Data.GraphViz.Printing
import Data.Char(toLower)
import Data.Maybe(isJust)
diff --git a/Data/GraphViz/Attributes/Colors.hs b/Data/GraphViz/Attributes/Colors.hs
--- a/Data/GraphViz/Attributes/Colors.hs
+++ b/Data/GraphViz/Attributes/Colors.hs
@@ -37,8 +37,8 @@
, fromAColour
) where
-import Data.GraphViz.Types.Parsing
-import Data.GraphViz.Types.Printing
+import Data.GraphViz.Parsing
+import Data.GraphViz.Printing
import Data.Colour( AlphaColour, opaque, transparent, withOpacity
, over, black, alphaChannel, darken)
diff --git a/Data/GraphViz/Commands.hs b/Data/GraphViz/Commands.hs
--- a/Data/GraphViz/Commands.hs
+++ b/Data/GraphViz/Commands.hs
@@ -17,6 +17,11 @@
not easy (there is no listing of available renderers or formatters
on the Graphviz website), and for the most part the default ones do
the job well.
+
+ Please note that for 'GraphvizOutput' and 'GraphvizCanvas', you
+ will see that they are instances of a @GraphvizResult@ class; this is
+ an internal class that should not be visible outside this module, but
+ Haddock is being too helpful for its own good.
-}
module Data.GraphViz.Commands
( -- * The different Graphviz tools available.
@@ -30,6 +35,7 @@
, GraphvizCanvas(..)
-- * Running Graphviz.
, RunResult(..)
+ , maybeErr
, runGraphviz
, runGraphvizCommand
, addExtension
@@ -44,7 +50,6 @@
import Prelude hiding (catch)
import Data.GraphViz.Types
-import Data.GraphViz.Types.Printing
-- This is here just for Haddock linking purposes.
import Data.GraphViz.Attributes(Attribute(Z))
@@ -91,8 +96,8 @@
undirCommand = Neato
-- | The appropriate (default) Graphviz command for the given graph.
-commandFor :: DotGraph a -> GraphvizCommand
-commandFor dg = if directedGraph dg
+commandFor :: (DotRepr dg n) => dg n -> GraphvizCommand
+commandFor dg = if graphIsDirected dg
then dirCommand
else undirCommand
@@ -272,24 +277,26 @@
-- | Run the recommended Graphviz command on this graph, saving the result
-- to the file provided (note: file extensions are /not/ checked).
-runGraphviz :: (PrintDot n) => DotGraph n -> GraphvizOutput -> FilePath
- -> IO RunResult
+runGraphviz :: (DotRepr dg n) => dg n -> GraphvizOutput -> FilePath
+ -> IO (Either String FilePath)
runGraphviz gr = runGraphvizCommand (commandFor gr) gr
-- | Run the chosen Graphviz command on this graph, saving the result
-- to the file provided (note: file extensions are /not/ checked).
-runGraphvizCommand :: (PrintDot n) => GraphvizCommand -> DotGraph n
- -> GraphvizOutput -> FilePath -> IO RunResult
+runGraphvizCommand :: (DotRepr dg n) => GraphvizCommand -> dg n
+ -> GraphvizOutput -> FilePath
+ -> IO (Either String FilePath)
runGraphvizCommand cmd gr t fp
- = liftM maybeErr
+ = liftM (either (Left . addFl) (const $ Right fp))
$ graphvizWithHandle cmd gr t toFile
where
+ addFl = (++) ("Unable to create " ++ fp ++ "\n")
toFile h = B.hGetContents h >>= B.writeFile fp
-- | Append the default extension for the provided 'GraphvizOutput' to
-- the provided 'FilePath' for the output file.
-addExtension :: (GraphvizOutput -> FilePath -> IO a)
- -> GraphvizOutput -> FilePath -> IO a
+addExtension :: (GraphvizOutput -> FilePath -> a)
+ -> GraphvizOutput -> FilePath -> a
addExtension cmd t fp = cmd t fp'
where
fp' = fp <.> defaultExtension t
@@ -298,13 +305,13 @@
-- result to the given handle rather than to a file.
--
-- Note that the @'Handle' -> 'IO' a@ function /must/ fully consume
--- the input from the 'Handle'; 'hGetContents'' is an version of
+-- the input from the 'Handle'; 'hGetContents'' is a version of
-- 'hGetContents' that will ensure this happens.
--
--- If the command was unsuccessful, then @Left error@ is returned.
-graphvizWithHandle :: (PrintDot n, Show a)
+-- If the command was unsuccessful, then @'Left' error@ is returned.
+graphvizWithHandle :: (DotRepr dg n, Show a)
=> GraphvizCommand -- ^ Which command to run
- -> DotGraph n -- ^ The 'DotGraph' to use
+ -> dg n -- ^ The 'DotRepr' to use
-> GraphvizOutput -- ^ The 'GraphvizOutput' type
-> (Handle -> IO a) -- ^ Extract the output
-> IO (Either String a) -- ^ The error or the result.
@@ -312,8 +319,8 @@
-- This version is not exported as we don't want to let arbitrary
-- @Handle -> IO a@ functions to be used for GraphvizCanvas outputs.
-graphvizWithHandle' :: (PrintDot n, GraphvizResult o, Show a)
- => GraphvizCommand -> DotGraph n -> o
+graphvizWithHandle' :: (DotRepr dg n, GraphvizResult o, Show a)
+ => GraphvizCommand -> dg n -> o
-> (Handle -> IO a) -> IO (Either String a)
graphvizWithHandle' cmd gr t f
= handle notRunnable
@@ -373,7 +380,7 @@
-- | Run the chosen Graphviz command on this graph and render it using
-- the given canvas type.
-runGraphvizCanvas :: (PrintDot n) => GraphvizCommand -> DotGraph n
+runGraphvizCanvas :: (DotRepr dg n) => GraphvizCommand -> dg n
-> GraphvizCanvas -> IO RunResult
runGraphvizCanvas cmd gr c = liftM maybeErr
$ graphvizWithHandle' cmd gr c nullHandle
@@ -385,7 +392,7 @@
-- | Run the recommended Graphviz command on this graph and render it
-- using the given canvas type.
-runGraphvizCanvas' :: (PrintDot n) => DotGraph n -> GraphvizCanvas
+runGraphvizCanvas' :: (DotRepr dg n) => dg n -> GraphvizCanvas
-> IO RunResult
runGraphvizCanvas' d = runGraphvizCanvas (commandFor d) d
diff --git a/Data/GraphViz/Parsing.hs b/Data/GraphViz/Parsing.hs
new file mode 100644
--- /dev/null
+++ b/Data/GraphViz/Parsing.hs
@@ -0,0 +1,395 @@
+{- |
+ Module : Data.GraphViz.Parsing
+ Description : Helper functions for Parsing.
+ Copyright : (c) Matthew Sackman, Ivan Lazar Miljenovic
+ License : 3-Clause BSD-style
+ Maintainer : Ivan.Miljenovic@gmail.com
+
+ This module defines simple helper functions for use with
+ "Text.ParserCombinators.Poly.Lazy".
+
+ Note that the 'ParseDot' instances for 'Bool', etc. match those
+ specified for use with Graphviz (e.g. non-zero integers are
+ equivalent to 'True').
+
+ You should not be using this module; rather, it is here for
+ informative/documentative reasons. If you want to parse a
+ @'Data.GraphViz.Types.DotRepr'@, you should use
+ @'Data.GraphViz.Types.parseDotGraph'@ rather than its 'ParseDot'
+ instance.
+-}
+module Data.GraphViz.Parsing
+ ( -- * Re-exporting pertinent parts of Polyparse.
+ module Text.ParserCombinators.Poly.Lazy
+ -- * The ParseDot class.
+ , Parse
+ , ParseDot(..)
+ , parseIt
+ -- * Convenience parsing combinators.
+ , onlyBool
+ , stringBlock
+ , numString
+ , isNumString
+ , isIntString
+ , quotedString
+ , parseAndSpace
+ , string
+ , strings
+ , hasString
+ , character
+ , parseStrictFloat
+ , noneOf
+ , whitespace
+ , whitespace'
+ , optionalQuotedString
+ , optionalQuoted
+ , quotedParse
+ , orQuote
+ , quoteChar
+ , newline
+ , newline'
+ , parseComma
+ , tryParseList
+ , tryParseList'
+ , skipToNewline
+ , parseField
+ , parseFields
+ , parseFieldBool
+ , parseFieldsBool
+ , parseFieldDef
+ , parseFieldsDef
+ , commaSep
+ , commaSepUnqt
+ , commaSep'
+ , stringRep
+ , stringReps
+ -- * Pre-processing of Dot code to remove comments, etc.
+ , preProcess
+ ) where
+
+import Data.GraphViz.Util
+
+import Text.ParserCombinators.Poly.Lazy
+import Data.Char( digitToInt
+ , isDigit
+ , isSpace
+ , toLower
+ )
+import Data.Function(on)
+import Data.Maybe(isJust, fromMaybe, isNothing)
+import Data.Ratio((%))
+import Data.Word(Word8)
+import Control.Monad(liftM, when)
+
+-- -----------------------------------------------------------------------------
+-- Based off code from Text.Parse in the polyparse library
+
+-- | A @ReadS@-like type alias.
+type Parse a = Parser Char a
+
+class ParseDot a where
+ parseUnqt :: Parse a
+
+ parse :: Parse a
+ parse = optionalQuoted parseUnqt
+
+ parseUnqtList :: Parse [a]
+ parseUnqtList = bracketSep (parseAndSpace $ character '[')
+ (parseAndSpace $ parseComma)
+ (parseAndSpace $ character ']')
+ (parseAndSpace parse)
+
+ parseList :: Parse [a]
+ parseList = quotedParse parseUnqtList
+
+-- | Parse the required value, returning also the rest of the input
+-- 'String' that hasn't been parsed.
+parseIt :: (ParseDot a) => String -> (a, String)
+parseIt = runParser parse
+
+instance ParseDot Int where
+ parseUnqt = parseInt'
+
+instance ParseDot Word8 where
+ parseUnqt = parseInt
+
+instance ParseDot Double where
+ parseUnqt = parseFloat'
+
+instance ParseDot Bool where
+ parseUnqt = onlyBool
+ `onFail`
+ liftM (zero /=) parseInt'
+ where
+ zero :: Int
+ zero = 0
+
+-- | Use this when you do not want numbers to be treated as 'Bool' values.
+onlyBool :: Parse Bool
+onlyBool = oneOf [ stringRep True "true"
+ , stringRep False "false"
+ ]
+
+instance ParseDot Char where
+ -- Can't be a quote character.
+ parseUnqt = satisfy ((/=) quoteChar)
+
+ parse = satisfy restIDString
+ `onFail`
+ quotedParse parseUnqt
+
+ -- Too many problems with using this within other parsers where
+ -- using numString or stringBlock will cause a parse failure. As
+ -- such, this will successfully parse all un-quoted Strings.
+ parseUnqtList = quotedString
+
+ parseList = oneOf [numString, stringBlock]
+ `onFail`
+ -- This will also take care of quoted versions of
+ -- above.
+ quotedParse quotedString
+
+instance (ParseDot a) => ParseDot [a] where
+ parseUnqt = parseUnqtList
+
+ parse = parseList
+
+numString :: Parse String
+numString = liftM show parseStrictFloat
+ `onFail`
+ liftM show parseInt'
+
+stringBlock :: Parse String
+stringBlock = do frst <- satisfy frstIDString
+ rest <- many (satisfy restIDString)
+ return $ frst : rest
+
+-- | Used when quotes are explicitly required;
+quotedString :: Parse String
+quotedString = many stringInterior
+
+stringInterior :: Parse Char
+stringInterior = orQuote $ satisfy ((/=) quoteChar)
+
+parseSigned :: Real a => Parse a -> Parse a
+parseSigned p = (character '-' >> liftM negate p)
+ `onFail`
+ p
+
+parseInt :: (Integral a) => Parse a
+parseInt = do cs <- many1 (satisfy isDigit)
+ return (foldl1 (\n d-> n*radix+d)
+ (map (fromIntegral . digitToInt) cs))
+ `adjustErr` (++ "\nexpected one or more digits")
+ where
+ radix = 10
+
+parseInt' :: Parse Int
+parseInt' = parseSigned parseInt
+
+-- | Parse a floating point number that actually contains decimals.
+parseStrictFloat :: Parse Double
+parseStrictFloat = parseSigned parseFloat
+
+parseFloat :: (RealFrac a) => Parse a
+parseFloat = do ds <- many (satisfy isDigit)
+ frac <- optional
+ $ do character '.'
+ many1 (satisfy isDigit)
+ `adjustErr` (++ "\nexpected digit after .")
+ when (isNothing frac && null ds)
+ (fail "No actual digits in floating point number!")
+ expn <- optional parseExp
+ when (isNothing frac && isNothing expn)
+ (fail "This is an integer, not a floating point number!")
+ let frac' = fromMaybe "" frac
+ expn' = fromMaybe 0 expn
+ ( return . fromRational . (* (10^^(expn' - length frac')))
+ . (%1) . fst
+ . runParser parseInt) (ds++frac')
+ `onFail`
+ fail "Expected a floating point number"
+ where parseExp = do character 'e'
+ ((character '+' >> parseInt)
+ `onFail`
+ parseInt')
+
+parseFloat' :: Parse Double
+parseFloat' = parseSigned ( parseFloat
+ `onFail`
+ liftM fI parseInt
+ )
+ where
+ fI :: Integer -> Double
+ fI = fromIntegral
+
+-- -----------------------------------------------------------------------------
+
+parseAndSpace :: Parse a -> Parse a
+parseAndSpace p = p `discard` whitespace'
+
+string :: String -> Parse String
+string = mapM character
+
+stringRep :: a -> String -> Parse a
+stringRep v = stringReps v . return
+
+stringReps :: a -> [String] -> Parse a
+stringReps v ss = oneOf (map string ss) >> return v
+
+strings :: [String] -> Parse String
+strings = oneOf . map string
+
+hasString :: String -> Parse Bool
+hasString = liftM isJust . optional . string
+
+character :: Char -> Parse Char
+character c = satisfy (((==) `on` toLower) c)
+ `adjustErr`
+ (++ "\nnot the expected char: " ++ [c])
+
+noneOf :: (Eq a) => [a] -> Parser a a
+noneOf t = satisfy (\x -> all (/= x) t)
+
+whitespace :: Parse String
+whitespace = many1 (satisfy isSpace)
+
+whitespace' :: Parse String
+whitespace' = many (satisfy isSpace)
+
+optionalQuotedString :: String -> Parse String
+optionalQuotedString = optionalQuoted . string
+
+optionalQuoted :: Parse a -> Parse a
+optionalQuoted p = quotedParse p
+ `onFail`
+ p
+
+quotedParse :: Parse a -> Parse a
+quotedParse = bracket parseQuote parseQuote
+
+parseQuote :: Parse Char
+parseQuote = character quoteChar
+
+orQuote :: Parse Char -> Parse Char
+orQuote p = stringRep quoteChar "\\\""
+ `onFail`
+ p
+
+quoteChar :: Char
+quoteChar = '"'
+
+newline :: Parse String
+newline = oneOf $ map string ["\r\n", "\n", "\r"]
+
+-- | Consume all whitespace and newlines until a line with
+-- non-whitespace is reached. The whitespace on that line is
+-- not consumed.
+newline' :: Parse ()
+newline' = many (whitespace' >> newline) >> return ()
+
+-- | Parses and returns all characters up till the end of the line,
+-- then skips to the beginning of the next line.
+skipToNewline :: Parse String
+skipToNewline = many (noneOf ['\n','\r']) `discard` newline
+
+parseField :: (ParseDot a) => String -> Parse a
+parseField fld = do string fld
+ whitespace'
+ character '='
+ whitespace'
+ parse
+
+parseFields :: (ParseDot a) => [String] -> Parse a
+parseFields = oneOf . map parseField
+
+parseFieldBool :: String -> Parse Bool
+parseFieldBool = parseFieldDef True
+
+parseFieldsBool :: [String] -> Parse Bool
+parseFieldsBool = oneOf . map parseFieldBool
+
+-- | For 'Bool'-like data structures where the presence of the field
+-- name without a value implies a default value.
+parseFieldDef :: (ParseDot a) => a -> String -> Parse a
+parseFieldDef d fld = parseField fld
+ `onFail`
+ stringRep d fld
+
+parseFieldsDef :: (ParseDot a) => a -> [String] -> Parse a
+parseFieldsDef d = oneOf . map (parseFieldDef d)
+
+commaSep :: (ParseDot a, ParseDot b) => Parse (a, b)
+commaSep = commaSep' parse parse
+
+commaSepUnqt :: (ParseDot a, ParseDot b) => Parse (a, b)
+commaSepUnqt = commaSep' parseUnqt parseUnqt
+
+commaSep' :: Parse a -> Parse b -> Parse (a,b)
+commaSep' pa pb = do a <- pa
+ whitespace'
+ parseComma
+ whitespace'
+ b <- pb
+ return (a,b)
+
+parseComma :: Parse Char
+parseComma = character ','
+
+tryParseList :: (ParseDot a) => Parse [a]
+tryParseList = tryParseList' parse
+
+tryParseList' :: Parse [a] -> Parse [a]
+tryParseList' = liftM (fromMaybe []) . optional
+
+-- -----------------------------------------------------------------------------
+-- Filtering out unwanted Dot items such as comments
+
+-- | Remove unparseable features of Dot, such as comments and
+-- multi-line strings (which are converted to single-line strings).
+preProcess :: String -> String
+preProcess = fst . runParser parseOutUnwanted
+ -- snd should be null
+
+-- | Parse out comments and make quoted strings spread over multiple
+-- lines only over a single line. Should parse the /entire/ input
+-- 'String'.
+parseOutUnwanted :: Parse String
+parseOutUnwanted = liftM concat (many getNext)
+ where
+ getNext :: Parse String
+ getNext = parseSplitStrings
+ `onFail`
+ (oneOf [ parseLineComment, parseMultiLineComment ] >> return [])
+ `onFail`
+ liftM return next
+
+-- | Parse @//@-style comments.
+parseLineComment :: Parse String
+parseLineComment = string "//" >> newline
+
+-- | Parse @/* ... */@-style comments.
+parseMultiLineComment :: Parse String
+parseMultiLineComment = bracket start end (liftM concat $ many inner)
+ where
+ start = string "/*"
+ end = string "*/"
+ inner = many1 (satisfy ((/=) '*'))
+ `onFail`
+ do ast <- character '*'
+ n <- satisfy ((/=) '/')
+ liftM ((:) ast . (:) n) inner
+
+-- | Parse out @\@ from a quoted string.
+parseSplitStrings :: Parse String
+parseSplitStrings = do oq <- parseQuote
+ inner <- liftM concat $ many parseInner
+ cq <- parseQuote
+ return $ oq : inner ++ [cq]
+ where
+ parseInner = string "\\\""
+ `onFail`
+ (character '\\' >> newline >> return [])
+ `onFail`
+ liftM return (satisfy ((/=) quoteChar))
+
diff --git a/Data/GraphViz/Printing.hs b/Data/GraphViz/Printing.hs
new file mode 100644
--- /dev/null
+++ b/Data/GraphViz/Printing.hs
@@ -0,0 +1,175 @@
+{- |
+ Module : Data.GraphViz.Printing
+ Description : Helper functions for converting to Dot format.
+ Copyright : (c) Ivan Lazar Miljenovic
+ License : 3-Clause BSD-style
+ Maintainer : Ivan.Miljenovic@gmail.com
+
+ This module defines simple helper functions for use with
+ "Text.PrettyPrint". It also re-exports all the pretty-printing
+ combinators from that module.
+
+ Note that the 'PrintDot' instances for 'Bool', etc. match those
+ specified for use with Graphviz.
+
+ You should only be using this module if you are writing custom node
+ types for use with "Data.GraphViz.Types". For actual printing of
+ code, use @'Data.GraphViz.Types.printDotGraph'@ (which produces a
+ 'String' value).
+
+ The Dot language specification specifies that any identifier is in
+ one of four forms:
+
+ * Any string of alphabetic ([a-zA-Z\200-\377]) characters, underscores ('_') or digits ([0-9]), not beginning with a digit;
+
+ * a number [-]?(.[0-9]+ | [0-9]+(.[0-9]*)? );
+
+ * any double-quoted string (\"...\") possibly containing escaped quotes (\\\");
+
+ * an HTML string (<...>).
+
+ Due to these restrictions, you should only use 'text' when you are
+ sure that the 'String' in question is static and quotes are
+ definitely needed/unneeded; it is better to use the 'String'
+ instance for 'PrintDot'. For more information, see the
+ specification page:
+
+-}
+module Data.GraphViz.Printing
+ ( module Text.PrettyPrint
+ , DotCode
+ , renderDot -- Exported for Data.GraphViz.Types.printSGID
+ , PrintDot(..)
+ , printIt
+ , addQuotes
+ , wrap
+ , commaDel
+ , printField
+ ) where
+
+import Data.GraphViz.Util
+
+-- Only implicitly import and re-export combinators.
+import Text.PrettyPrint hiding ( Style(..)
+ , Mode(..)
+ , TextDetails(..)
+ , render
+ , style
+ , renderStyle
+ , fullRender
+ )
+
+import qualified Text.PrettyPrint as PP
+
+import Data.Word(Word8)
+
+-- -----------------------------------------------------------------------------
+
+-- | A type alias to indicate what is being produced.
+type DotCode = Doc
+
+-- | Correctly render Graphviz output.
+renderDot :: DotCode -> String
+renderDot = PP.renderStyle style'
+ where
+ style' = PP.style { PP.mode = PP.LeftMode }
+
+-- | A class used to correctly print parts of the Graphviz Dot language.
+-- Minimal implementation is 'unqtDot'.
+class PrintDot a where
+ -- | The unquoted representation, for use when composing values to
+ -- produce a larger printing value.
+ unqtDot :: a -> DotCode
+
+ -- | The actual quoted representation; this should be quoted if it
+ -- contains characters not permitted a plain ID String, a number
+ -- or it is not an HTML string.
+ -- Defaults to 'unqtDot'.
+ toDot :: a -> DotCode
+ toDot = unqtDot
+
+ -- | The correct way of representing a list of this value when
+ -- printed; not all Dot values require this to be implemented.
+ -- Defaults to Haskell-like list representation.
+ unqtListToDot :: [a] -> DotCode
+ unqtListToDot = brackets . hsep . punctuate comma
+ . map unqtDot
+
+ -- | The quoted form of 'unqtListToDot'; defaults to wrapping
+ -- double quotes around the result of 'unqtListToDot' (since the
+ -- default implementation has characters that must be quoted).
+ listToDot :: [a] -> DotCode
+ listToDot = doubleQuotes . unqtListToDot
+
+-- | Convert to DotCode; note that this has no indentation, as we can
+-- only have one of indentation and (possibly) infinite line lengths.
+printIt :: (PrintDot a) => a -> String
+printIt = renderDot . toDot
+
+instance PrintDot Int where
+ unqtDot = int
+
+instance PrintDot Word8 where
+ unqtDot = int . fromIntegral
+
+instance PrintDot Double where
+ -- If it's an "integral" double, then print as an integer.
+ -- This seems to match how Graphviz apps use Dot.
+ unqtDot d = if d == fromIntegral di
+ then int di
+ else double d
+ where
+ di = round d
+
+instance PrintDot Bool where
+ unqtDot True = text "true"
+ unqtDot False = text "false"
+
+instance PrintDot Char where
+ unqtDot = char
+
+ toDot = qtChar
+
+ unqtListToDot = unqtString
+
+ listToDot = qtString
+
+-- | Check to see if this 'Char' needs to be quoted or not.
+qtChar :: Char -> DotCode
+qtChar c
+ | restIDString c = char c -- Could be a number as well.
+ | otherwise = doubleQuotes $ char c
+
+needsQuotes :: String -> Bool
+needsQuotes str
+ | null str = True
+ | isKeyword str = True
+ | isIDString str = False
+ | isNumString str = False
+ | otherwise = True
+
+addQuotes :: String -> DotCode -> DotCode
+addQuotes = bool id doubleQuotes . needsQuotes
+
+-- | Escape quotes in Strings that need them.
+unqtString :: String -> DotCode
+unqtString "" = empty
+unqtString str = text $ escapeQuotes str -- no quotes? no worries!
+
+-- | Escape quotes and quote Strings that need them (including keywords).
+qtString :: String -> DotCode
+qtString str = addQuotes str $ unqtString str
+
+instance (PrintDot a) => PrintDot [a] where
+ unqtDot = unqtListToDot
+
+ toDot = listToDot
+
+wrap :: DotCode -> DotCode -> DotCode -> DotCode
+wrap b a d = b <> d <> a
+
+commaDel :: (PrintDot a, PrintDot b) => a -> b -> DotCode
+commaDel a b = unqtDot a <> comma <> unqtDot b
+
+printField :: (PrintDot a) => String -> a -> DotCode
+printField f v = text f <> equals <> toDot v
diff --git a/Data/GraphViz/Testing.hs b/Data/GraphViz/Testing.hs
--- a/Data/GraphViz/Testing.hs
+++ b/Data/GraphViz/Testing.hs
@@ -21,7 +21,7 @@
* The generated Strings are very simple, only composed of lower
case letters, digits and some symbols. This is because too many
- tests were "failing" due to some corner case; e.g. lower-case
+ tests were \"failing\" due to some corner case; e.g. lower-case
letters only because the parser parses Strings as lowercase, so
if a particular String isn't valid (e.g. @\"all\"@ for 'LayerID',
then the 'Arbitrary' instance has to ensure that all possible
@@ -33,12 +33,10 @@
as dot, etc. choke on invalid Dot code.
* To avoid needless endless recursion, 'DotSubGraph's do not have
- sub-'DotSubGraph's.
+ sub-'DotSubGraph's (same with 'GDotSubGraph's).
- * The 'Graph' values that are generated do not have multiple edges,
- as the 'prop_dotizeAugment' property uses 'dotize'', which makes
- no guarantees on what will happen for 'Graph's with multiple
- edges.
+ * The 'Graph' values that are generated do not have multiple edges
+ for simplicity purposes.
* This test suite isn't perfect: if you deliberately try to stuff
something up, you probably can.
@@ -49,15 +47,23 @@
-- ** The tests themselves
, Test(..)
, test_printParseID_Attributes
+ , test_generalisedSameDot
, test_printParseID
, test_preProcessingID
, test_parsePrettyID
, test_dotizeAugment
-- * Re-exporting modules for manual testing.
, module Data.GraphViz
+ , module Data.GraphViz.Types.Generalised
, module Data.GraphViz.Testing.Properties
+ -- * Debugging printing
+ , PrintDot(..)
, printIt
+ , renderDot
+ -- * Debugging parsing
+ , ParseDot(..)
, parseIt
+ , runParser
, preProcess
) where
@@ -70,8 +76,12 @@
import Data.GraphViz.Testing.Properties
import Data.GraphViz hiding (RunResult(..))
-import Data.GraphViz.Types.Parsing(parseIt, preProcess)
-import Data.GraphViz.Types.Printing(printIt)
+import Data.GraphViz.Parsing(ParseDot(..), parseIt, runParser, preProcess)
+import Data.GraphViz.Printing(PrintDot(..), printIt, renderDot)
+import Data.GraphViz.Types.Generalised hiding ( GraphID(..)
+ , GlobalAttributes(..)
+ , DotNode(..)
+ , DotEdge(..))
-- Can't use PatriciaTree because a Show instance is needed.
import Data.Graph.Inductive.Tree(Gr)
@@ -91,7 +101,7 @@
\If any of these tests fail, please inform the maintainer,\n\
\including full output of this test suite.\n\
\\n\
- \This test suite takes approximately 90 minutes to run on a\n\
+ \This test suite takes approximately 110 minutes to run on a\n\
\2 GHz Mobile Core 2 Duo (running with a single thread)."
successMsg = "All tests were successful!"
@@ -148,7 +158,9 @@
-- | The tests to run by default.
defaultTests :: [Test]
defaultTests = [ test_printParseID_Attributes
+ , test_generalisedSameDot
, test_printParseID
+ , test_printParseGID
, test_preProcessingID
-- Can't run this test, since we don't generate valid
-- DotGraphs to pass to Graphviz!
@@ -176,6 +188,19 @@
\rest of the tests, generating " ++ show numGen ++ " lists of\n\
\Attributes rather than the default " ++ show defGen ++ " tests."
+test_generalisedSameDot :: Test
+test_generalisedSameDot
+ = Test { name = "Printing generalised Dot code"
+ , desc = dsc
+ , test = quickCheckResult prop
+ }
+ where
+ prop :: DotGraph Int -> Bool
+ prop = prop_generalisedSameDot
+
+ dsc = "When generalising \"DotGraph\" values to \"GDotGraph\" values,\n\
+ \the generated Dot code should be identical."
+
test_printParseID :: Test
test_printParseID
= Test { name = "Printing and Parsing DotGraphs"
@@ -190,6 +215,20 @@
\generated Dot code. This test aims to determine the validity\n\
\of this for the overall \"DotGraph Int\" values."
+test_printParseGID :: Test
+test_printParseGID
+ = Test { name = "Printing and Parsing Generalised DotGraphs"
+ , desc = dsc
+ , test = quickCheckResult prop
+ }
+ where
+ prop :: GDotGraph Int -> Bool
+ prop = prop_printParseID
+
+ dsc = "The graphviz library should be able to parse back in its own\n\
+ \generated Dot code. This test aims to determine the validity\n\
+ \of this for the overall \"GDotGraph Int\" values."
+
test_preProcessingID :: Test
test_preProcessingID
= Test { name = "Pre-processing Dot code"
@@ -203,7 +242,9 @@
dsc = "When parsing Dot code, some pre-processing is done to remove items\n\
\such as comments and to join together multi-line strings. This\n\
\test verifies that this pre-processing doesn't affect actual\n\
- \Dot code by running the pre-processor on generated Dot code."
+ \Dot code by running the pre-processor on generated Dot code.\n\n\
+ \This test is not run on generalised Dot graphs as if it works for\n\
+ \normal dot graphs then it should also work for generalised ones."
-- | This test is not valid for use until valid DotGraphs can be generated.
test_parsePrettyID :: Test
diff --git a/Data/GraphViz/Testing/Instances.hs b/Data/GraphViz/Testing/Instances.hs
--- a/Data/GraphViz/Testing/Instances.hs
+++ b/Data/GraphViz/Testing/Instances.hs
@@ -17,15 +17,17 @@
-}
module Data.GraphViz.Testing.Instances() where
-import Data.GraphViz.Types.Parsing(isNumString)
+import Data.GraphViz.Parsing(isNumString)
import Data.GraphViz.Attributes
import Data.GraphViz.Types
+import Data.GraphViz.Types.Generalised
import Test.QuickCheck
import Data.Char(toLower)
import Data.List(nub)
+import qualified Data.Sequence as Seq
import Control.Monad(liftM, liftM2, liftM3, liftM4, guard)
import Data.Word(Word8)
@@ -51,7 +53,7 @@
shrink (HTML u) = map HTML $ shrink u
instance (Eq a, Arbitrary a) => Arbitrary (DotStatements a) where
- arbitrary = arbDS True
+ arbitrary = sized (arbDS True)
shrink ds@(DotStmts gas sgs ns es) = do gas' <- shrinkL gas
sgs' <- shrinkL sgs
@@ -61,11 +63,12 @@
$ DotStmts gas' sgs' ns' es'
-- | If 'True', generate 'DotSubGraph's; otherwise don't.
-arbDS :: (Arbitrary a, Eq a) => Bool -> Gen (DotStatements a)
-arbDS haveSGs = liftM4 DotStmts arbitrary genSGs arbitrary arbitrary
+arbDS :: (Arbitrary a, Eq a) => Bool -> Int -> Gen (DotStatements a)
+arbDS haveSGs s = liftM4 DotStmts arbitrary genSGs arbitrary arbitrary
where
+ s' = min s 2
genSGs = if haveSGs
- then resize 2 arbitrary
+ then resize s' arbitrary
else return []
instance Arbitrary GlobalAttributes where
@@ -79,7 +82,7 @@
shrink (EdgeAttrs atts) = map EdgeAttrs $ nonEmptyShrinks atts
instance (Eq a, Arbitrary a) => Arbitrary (DotSubGraph a) where
- arbitrary = liftM3 DotSG arbitrary arbitrary (arbDS False)
+ arbitrary = liftM3 DotSG arbitrary arbitrary (sized $ arbDS False)
shrink (DotSG isCl mid stmts) = map (DotSG isCl mid) $ shrink stmts
@@ -92,6 +95,58 @@
arbitrary = liftM4 DotEdge arbitrary arbitrary arbitrary arbitrary
shrink (DotEdge f t isDir as) = map (DotEdge f t isDir) $ shrinkList as
+
+-- -----------------------------------------------------------------------------
+-- Defining Arbitrary instances for the generalised types
+
+instance (Eq a, Arbitrary a) => Arbitrary (GDotGraph a) where
+ arbitrary = liftM4 GDotGraph arbitrary arbitrary arbitrary genGDStmts
+
+ shrink (GDotGraph str dir gid stmts) = map (GDotGraph str dir gid)
+ $ shrinkGDStmts stmts
+
+genGDStmts :: (Eq a, Arbitrary a) => Gen (GDotStatements a)
+genGDStmts = sized (arbGDS True)
+
+shrinkGDStmts :: (Eq a, Arbitrary a) => GDotStatements a -> [GDotStatements a]
+shrinkGDStmts gds
+ | len == 1 = map Seq.singleton . shrink $ Seq.index gds 0
+ | otherwise = [gds1, gds2]
+ where
+ len = Seq.length gds
+ -- Halve the sequence
+ (gds1, gds2) = (len `div` 2) `Seq.splitAt` gds
+
+instance (Eq a, Arbitrary a) => Arbitrary (GDotStatement a) where
+ -- Don't want as many sub-graphs as nodes, etc.
+ arbitrary = frequency [ (3, liftM GA arbitrary)
+ , (1, liftM SG arbitrary)
+ , (5, liftM DN arbitrary)
+ , (7, liftM DE arbitrary)
+ ]
+
+ shrink (GA ga) = map GA $ shrink ga
+ shrink (SG sg) = map SG $ shrink sg
+ shrink (DN dn) = map DN $ shrink dn
+ shrink (DE de) = map DE $ shrink de
+
+-- | If 'True', generate 'GDotSubGraph's; otherwise don't.
+arbGDS :: (Arbitrary a, Eq a) => Bool -> Int -> Gen (GDotStatements a)
+arbGDS haveSGs s = liftM (Seq.fromList . checkSGs) (resize s' arbList)
+ where
+ checkSGs = if haveSGs
+ then id
+ else filter notSG
+ notSG SG{} = False
+ notSG _ = True
+
+ s' = min s 10
+
+
+instance (Eq a, Arbitrary a) => Arbitrary (GDotSubGraph a) where
+ arbitrary = liftM3 GDotSG arbitrary arbitrary (sized $ arbGDS False)
+
+ shrink (GDotSG isCl mid stmts) = map (GDotSG isCl mid) $ shrinkGDStmts stmts
-- -----------------------------------------------------------------------------
-- Defining Arbitrary instances for Attributes
diff --git a/Data/GraphViz/Testing/Instances/FGL.hs b/Data/GraphViz/Testing/Instances/FGL.hs
--- a/Data/GraphViz/Testing/Instances/FGL.hs
+++ b/Data/GraphViz/Testing/Instances/FGL.hs
@@ -18,9 +18,9 @@
import Test.QuickCheck
+import Data.GraphViz.Util(uniq, uniqBy)
+
import Data.Graph.Inductive.Graph(Graph, mkGraph, nodes, delNode)
-import Data.Function(on)
-import Data.List(group, sort, nubBy)
import Control.Monad(liftM, liftM3)
-- -----------------------------------------------------------------------------
@@ -30,11 +30,10 @@
arbitrary = do ns <- suchThat genNs (not . null)
let nGen = elements ns
lns <- mapM makeLNode ns
- les <- liftM filtEs . listOf $ makeLEdge nGen
+ les <- liftM (uniqBy toE) . listOf $ makeLEdge nGen
return $ mkGraph lns les
where
- genNs = liftM (map head . group . sort) arbitrary
- filtEs = nubBy ((==) `on` toE)
+ genNs = liftM uniq arbitrary
toE (f,t,_) = (f,t)
makeLNode n = liftM ((,) n) arbitrary
makeLEdge nGen = liftM3 (,,) nGen nGen arbitrary
diff --git a/Data/GraphViz/Testing/Properties.hs b/Data/GraphViz/Testing/Properties.hs
--- a/Data/GraphViz/Testing/Properties.hs
+++ b/Data/GraphViz/Testing/Properties.hs
@@ -10,9 +10,10 @@
module Data.GraphViz.Testing.Properties where
import Data.GraphViz(dotizeGraph', prettyPrint')
-import Data.GraphViz.Types(DotGraph, printDotGraph)
-import Data.GraphViz.Types.Printing(PrintDot(..), printIt)
-import Data.GraphViz.Types.Parsing(ParseDot(..), parseIt, preProcess)
+import Data.GraphViz.Types(DotRepr, DotGraph, printDotGraph)
+import Data.GraphViz.Types.Generalised(generaliseDotGraph)
+import Data.GraphViz.Printing(PrintDot(..), printIt)
+import Data.GraphViz.Parsing(ParseDot(..), parseIt, preProcess)
import Test.QuickCheck
@@ -32,20 +33,28 @@
prop_printParseListID :: (ParseDot a, PrintDot a, Eq a) => [a] -> Property
prop_printParseListID as = not (null as) ==> prop_printParseID as
+-- | When converting a 'DotGraph' value to a 'GDotGraph' one, they
+-- should generate the same Dot code.
+prop_generalisedSameDot :: (ParseDot n, PrintDot n) => DotGraph n -> Bool
+prop_generalisedSameDot dg = printDotGraph dg == printDotGraph gdg
+ where
+ gdg = generaliseDotGraph dg
+
-- | Pre-processing shouldn't change the output of printed Dot code.
-- This should work for all 'PrintDot' instances, but is more
-- specific to 'DotGraph' values.
-prop_preProcessingID :: (PrintDot a) => DotGraph a -> Bool
+prop_preProcessingID :: (DotRepr dg n) => dg n -> Bool
prop_preProcessingID dg = preProcess dotCode == dotCode
where
dotCode = printDotGraph dg
-- | This is a version of 'prop_printParseID' that tries to parse the
-- pretty-printed output of 'prettyPrint'' rather than just 'printIt'.
-prop_parsePrettyID :: (Eq a, ParseDot a, PrintDot a) => DotGraph a -> Bool
+prop_parsePrettyID :: (DotRepr dg n, Eq (dg n), ParseDot (dg n))
+ => dg n -> Bool
prop_parsePrettyID dg = (fst . parseIt . prettyPrint') dg == dg
--- | This property verifies that 'dotize'', etc. only /augment/ the
+-- | This property verifies that 'dotizeGraph'', etc. only /augment/ the
-- original graph; that is, the actual nodes, edges and labels for
-- each remain unchanged. Whilst 'dotize'', etc. only require
-- 'Graph' instances, this property requires 'DynGraph' (which is a
diff --git a/Data/GraphViz/Types.hs b/Data/GraphViz/Types.hs
--- a/Data/GraphViz/Types.hs
+++ b/Data/GraphViz/Types.hs
@@ -1,3 +1,7 @@
+{-# LANGUAGE MultiParamTypeClasses
+ , FlexibleInstances
+ #-}
+
{- |
Module : Data.GraphViz.Types
Description : Definition of the Graphviz types.
@@ -26,7 +30,8 @@
does indeed have a valid 'GraphID'.
* All 'DotSubGraph's with @'isCluster' = 'True'@ /must/ have unique
- 'subGraphID' values.
+ 'subGraphID' values (well, only if you want them to be generated
+ sensibly).
* If eventually outputting to a format such as SVG, then you should
make sure that your 'DotGraph' has a 'graphID', as that is used
@@ -61,8 +66,10 @@
* Cannot place items in an arbitrary order: in particular, this
means that it is not possible to use the normal Graphviz hack of
- having graph attributes that do not apply to subgraphs\/clusters
- by listing them /after/ the subgraphs\/clusters.
+ having graph attributes that do not apply to subgraphs\/clusters by
+ listing them /after/ the subgraphs\/clusters. If you wish to be able
+ to use an arbitrary ordering, you may wish to use
+ "Data.GraphViz.Types.Generalised".
* The parser will strip out comments and convert multiline strings
into a single line string. Pre-processor lines (i.e. those
@@ -72,16 +79,13 @@
-}
module Data.GraphViz.Types
- ( -- * The overall representation of a graph in /Dot/ format.
- DotGraph(..)
- -- ** Printing and parsing a @DotGraph@.
+ ( -- * Abstraction from the representation type
+ DotRepr(..)
+ -- ** Printing and parsing a @DotRepr@.
, printDotGraph
, parseDotGraph
- -- ** Functions acting on a @DotGraph@.
- , setID
- , makeStrict
- , graphNodes
- , graphEdges
+ -- * The overall representation of a graph in /Dot/ format.
+ , DotGraph(..)
-- ** Reporting of errors in a @DotGraph@.
, DotError(..)
, isValidGraph
@@ -95,16 +99,53 @@
, DotEdge(..)
) where
+import Data.GraphViz.Types.Common
import Data.GraphViz.Attributes
-import Data.GraphViz.Types.Internal
-import Data.GraphViz.Types.Parsing
-import Data.GraphViz.Types.Printing
+import Data.GraphViz.Util
+import Data.GraphViz.Parsing
+import Data.GraphViz.Printing
-import Data.Maybe(isJust)
-import Control.Monad(liftM, when)
+import Control.Monad(liftM)
-- -----------------------------------------------------------------------------
+-- | This class is used to provide a common interface to different
+-- ways of representing a graph in /Dot/ form.
+class (PrintDot (dg n), ParseDot (dg n)) => DotRepr dg n where
+ -- | Is this graph directed?
+ graphIsDirected :: dg n -> Bool
+
+ -- | A strict graph disallows multiple edges.
+ makeStrict :: dg n -> dg n
+
+ -- | Set the ID of the graph.
+ setID :: GraphID -> dg n -> dg n
+
+ -- | Return all the 'DotNode's contained within this 'DotRepr'.
+ -- There is no requirement for it to return implicitly defined
+ -- nodes found only within a 'DotEdge'.
+ graphNodes :: dg n -> [DotNode n]
+
+ -- | Return all the 'DotEdge's contained within this 'DotRepr'.
+ graphEdges :: dg n -> [DotEdge n]
+
+-- | The actual /Dot/ code for an instance of 'DotRepr'. Note that it
+-- is expected that @'parseDotGraph' . 'printDotGraph' == 'id'@
+-- (this might not be true the other way around due to un-parseable
+-- components).
+printDotGraph :: (DotRepr dg n) => dg n -> String
+printDotGraph = printIt
+
+-- | Parse a limited subset of the Dot language to form an instance of
+-- 'DotRepr'. Each instance may have its own limitations on what
+-- may or may not be parseable Dot code.
+--
+-- Also removes any comments, etc. before parsing.
+parseDotGraph :: (DotRepr dg n) => String -> dg n
+parseDotGraph = fst . parseIt . preProcess
+
+-- -----------------------------------------------------------------------------
+
-- | The internal representation of a graph in Dot form.
data DotGraph a = DotGraph { strictGraph :: Bool -- ^ If 'True', no multiple edges are drawn.
, directedGraph :: Bool
@@ -113,37 +154,16 @@
}
deriving (Eq, Ord, Show, Read)
--- | A strict graph disallows multiple edges.
-makeStrict :: DotGraph a -> DotGraph a
-makeStrict g = g { strictGraph = True }
-
--- | Set the ID of the graph.
-setID :: GraphID -> DotGraph a -> DotGraph a
-setID i g = g { graphID = Just i }
+instance (PrintDot n, ParseDot n) => DotRepr DotGraph n where
+ graphIsDirected = directedGraph
--- | Return all the 'DotNode's contained within this 'DotGraph'. Note
--- that it does not yet return all implicitly defined nodes
--- contained only within 'DotEdge's.
-graphNodes :: DotGraph a -> [DotNode a]
-graphNodes = statementNodes . graphStatements
+ makeStrict g = g { strictGraph = True }
--- | Return all the 'DotEdge's contained within this 'DotGraph'.
-graphEdges :: DotGraph a -> [DotEdge a]
-graphEdges = statementEdges . graphStatements
+ setID i g = g { graphID = Just i }
--- | The actual /Dot/ code for a 'DotGraph'. Note that it is expected
--- that @'parseDotGraph' . 'printDotGraph' == 'id'@ (this might not
--- be true the other way around due to un-parseable components).
-printDotGraph :: (PrintDot a) => DotGraph a -> String
-printDotGraph = printIt
+ graphNodes = statementNodes . graphStatements
--- | Parse a limited subset of the Dot language to form a 'DotGraph'
--- (that is, the caveats listed in "Data.GraphViz.Attributes" aside,
--- Dot graphs are parsed if they match the layout of 'DotGraph').
---
--- Also removes any comments, etc. before parsing.
-parseDotGraph :: (ParseDot a) => String -> DotGraph a
-parseDotGraph = fst . parseIt . preProcess
+ graphEdges = statementEdges . graphStatements
-- | Check if all the 'Attribute's are being used correctly.
isValidGraph :: DotGraph a -> Bool
@@ -154,48 +174,17 @@
graphErrors = invalidStmts usedByGraphs . graphStatements
instance (PrintDot a) => PrintDot (DotGraph a) where
- unqtDot = printStmtBased printGraphID graphStatements
-
-printGraphID :: (PrintDot a) => DotGraph a -> DotCode
-printGraphID g = bool empty strGraph' (strictGraph g)
- <+> bool undirGraph' dirGraph' (directedGraph g)
- <+> maybe empty toDot (graphID g)
+ unqtDot = printStmtBased printGraphID' graphStatements toDot
+ where
+ printGraphID' = printGraphID strictGraph directedGraph graphID
instance (ParseDot a) => ParseDot (DotGraph a) where
- parseUnqt = parseStmtBased parseGraphID
+ parseUnqt = parseStmtBased parse (parseGraphID DotGraph)
parse = parseUnqt -- Don't want the option of quoting
`adjustErr`
(++ "\n\nNot a valid DotGraph")
-parseGraphID :: (ParseDot a) => Parse (DotStatements a -> DotGraph a)
-parseGraphID = do str <- liftM isJust
- $ optional (parseAndSpace $ string strGraph)
- dir <- parseAndSpace ( stringRep True dirGraph
- `onFail`
- stringRep False undirGraph
- )
- gID <- optional $ parseAndSpace parse
- return $ DotGraph str dir gID
-
-dirGraph :: String
-dirGraph = "digraph"
-
-dirGraph' :: DotCode
-dirGraph' = text dirGraph
-
-undirGraph :: String
-undirGraph = "graph"
-
-undirGraph' :: DotCode
-undirGraph' = text undirGraph
-
-strGraph :: String
-strGraph = "strict"
-
-strGraph' :: DotCode
-strGraph' = text strGraph
-
instance Functor DotGraph where
fmap f g = g { graphStatements = fmap f $ graphStatements g }
@@ -211,45 +200,6 @@
-- -----------------------------------------------------------------------------
--- | A polymorphic type that covers all possible ID values allowed by
--- Dot syntax. Note that whilst the 'ParseDot' and 'PrintDot'
--- instances for 'String' will properly take care of the special
--- cases for numbers, they are treated differently here.
-data GraphID = Str String
- | Int Int
- | Dbl Double
- | HTML URL
- deriving (Eq, Ord, Show, Read)
-
-instance PrintDot GraphID where
- unqtDot (Str str) = unqtDot str
- unqtDot (Int i) = unqtDot i
- unqtDot (Dbl d) = unqtDot d
- unqtDot (HTML u) = unqtDot u
-
- toDot (Str str) = toDot str
- toDot gID = unqtDot gID
-
-instance ParseDot GraphID where
- parseUnqt = liftM HTML parseUnqt
- `onFail`
- liftM stringNum parseUnqt
-
- parse = liftM HTML parse
- `onFail`
- liftM stringNum parse
- `adjustErr`
- (++ "\nNot a valid GraphID")
-
-stringNum :: String -> GraphID
-stringNum str = maybe checkDbl Int $ stringToInt str
- where
- checkDbl = if isNumString str
- then Dbl $ toDouble str
- else Str str
-
--- -----------------------------------------------------------------------------
-
data DotStatements a = DotStmts { attrStmts :: [GlobalAttributes]
, subGraphs :: [DotSubGraph a]
, nodeStmts :: [DotNode a]
@@ -258,10 +208,10 @@
deriving (Eq, Ord, Show, Read)
instance (PrintDot a) => PrintDot (DotStatements a) where
- unqtDot stmts = vcat [ toDot $ attrStmts stmts
- , toDot $ subGraphs stmts
- , toDot $ nodeStmts stmts
- , toDot $ edgeStmts stmts
+ unqtDot stmts = vcat [ unqtDot $ attrStmts stmts
+ , unqtDot $ subGraphs stmts
+ , unqtDot $ nodeStmts stmts
+ , unqtDot $ edgeStmts stmts
]
instance (ParseDot a) => ParseDot (DotStatements a) where
@@ -284,37 +234,6 @@
, edgeStmts = map (fmap f) $ edgeStmts stmts
}
-printStmtBased :: (PrintDot n) => (a -> DotCode)
- -> (a -> DotStatements n) -> a -> DotCode
-printStmtBased ff fss a = vcat [ ff a <+> lbrace
- , ind stmts
- , rbrace
- ]
- where
- ind = nest 4
- stmts = toDot $ fss a
-
-printStmtBasedList :: (PrintDot n) => (a -> DotCode)
- -> (a -> DotStatements n) -> [a] -> DotCode
-printStmtBasedList ff fss = vcat . map (printStmtBased ff fss)
-
-parseStmtBased :: (ParseDot n) => Parse (DotStatements n -> a) -> Parse a
-parseStmtBased p = do f <- p
- whitespace'
- character '{'
- newline'
- stmts <- parse
- newline'
- whitespace'
- character '}'
- return $ f stmts
- `adjustErr`
- (++ "\n\nNot a valid statement-based structure")
-
-parseStmtBasedList :: (ParseDot n) => Parse (DotStatements n -> a)
- -> Parse [a]
-parseStmtBasedList p = sepBy (whitespace' >> parseStmtBased p) newline'
-
-- | The function represents which function to use to check the
-- 'GraphAttrs' values.
invalidStmts :: (Attribute -> Bool) -> DotStatements a -> [DotError a]
@@ -403,103 +322,26 @@
deriving (Eq, Ord, Show, Read)
instance (PrintDot a) => PrintDot (DotSubGraph a) where
- unqtDot = printStmtBased printSubGraphID subGraphStmts
+ unqtDot = printStmtBased printSubGraphID' subGraphStmts toDot
- unqtListToDot = printStmtBasedList printSubGraphID subGraphStmts
+ unqtListToDot = printStmtBasedList printSubGraphID' subGraphStmts toDot
listToDot = unqtListToDot
-printSubGraphID :: DotSubGraph a -> DotCode
-printSubGraphID s = sGraph'
- <+> maybe cl dtID (subGraphID s)
- where
- isCl = isCluster s
- cl = bool empty clust' isCl
- dtID = printSGID isCl
-
--- | Print the actual ID for a 'DotSubGraph'.
-printSGID :: Bool -> GraphID -> DotCode
-printSGID isCl sID = bool noClust addClust isCl
- where
- noClust = toDot sID
- -- Have to manually render it as we need the un-quoted form.
- addClust = toDot . (++) clust . (:) '_'
- . renderDot $ mkDot sID
- mkDot (Str str) = text str -- Quotes will be escaped later
- mkDot gid = unqtDot gid
+printSubGraphID' :: DotSubGraph a -> DotCode
+printSubGraphID' = printSubGraphID (\sg -> (isCluster sg, subGraphID sg))
instance (ParseDot a) => ParseDot (DotSubGraph a) where
- parseUnqt = parseStmtBased parseSubGraphID
+ parseUnqt = parseStmtBased parseUnqt (parseSubGraphID DotSG)
parse = parseUnqt -- Don't want the option of quoting
`adjustErr`
(++ "\n\nNot a valid Sub Graph")
- parseUnqtList = parseStmtBasedList parseSubGraphID
+ parseUnqtList = parseStmtBasedList parseUnqt (parseSubGraphID DotSG)
parseList = parseUnqtList
-parseSubGraphID :: Parse (DotStatements a -> DotSubGraph a)
-parseSubGraphID = do string sGraph
- whitespace
- liftM (uncurry DotSG) parseSGID
-
-parseSGID :: Parse (Bool, Maybe GraphID)
-parseSGID = oneOf [ liftM getClustFrom $ parseAndSpace parse
- , return (False, Nothing)
- ]
- where
- -- If it's a String value, check to see if it's actually a
- -- cluster_Blah value; thus need to manually re-parse it.
- getClustFrom (Str str) = fst $ runParser pStr str
- getClustFrom gid = (False, Just gid)
-
- checkCl = stringRep True clust
- pStr = do isCl <- checkCl
- `onFail`
- return False
- when isCl $ optional (character '_') >> return ()
- sID <- optional pID
- let sID' = if sID == emptyID
- then Nothing
- else sID
- return (isCl, sID')
-
- emptyID = Just $ Str ""
-
- -- For Strings, there are no more quotes to unescape, so consume
- -- what you can.
- pID = liftM HTML parseUnqt
- `onFail`
- liftM stringNum (many next)
-
-{- This is a much nicer result, but unfortunately it doesn't work.
- The problem is that Graphviz decides that a subgraph is a cluster
- if the ID starts with "cluster" (no quotes); thus, we _have_ to do
- the double layer of parsing to get it to work :@
-
- do isCl <- stringRep True clust
- `onFail`
- return False
- sID <- optional $ do when isCl
- $ optional (character '_') >> return ()
- parseUnqt
- when (isCl || isJust sID) $ whitespace >> return ()
- return (isCl, sID)
--}
-
-sGraph :: String
-sGraph = "subgraph"
-
-sGraph' :: DotCode
-sGraph' = text sGraph
-
-clust :: String
-clust = "cluster"
-
-clust' :: DotCode
-clust' = text clust
-
instance Functor DotSubGraph where
fmap f sg = sg { subGraphStmts = fmap f $ subGraphStmts sg }
@@ -516,9 +358,7 @@
-- -----------------------------------------------------------------------------
--- | A node in 'DotGraph' is either a singular node, or a cluster
--- containing nodes (or more clusters) within it.
--- At the moment, clusters are not parsed.
+-- | A node in 'DotGraph'.
data DotNode a = DotNode { nodeID :: a
, nodeAttributes :: Attributes
}
diff --git a/Data/GraphViz/Types/Common.hs b/Data/GraphViz/Types/Common.hs
new file mode 100644
--- /dev/null
+++ b/Data/GraphViz/Types/Common.hs
@@ -0,0 +1,216 @@
+{-# OPTIONS_HADDOCK hide #-}
+
+{- |
+ Module : Data.GraphViz.Types.Common
+ Description : Common internal functions for dealing with overall types.
+ Copyright : (c) Ivan Lazar Miljenovic
+ License : 3-Clause BSD-style
+ Maintainer : Ivan.Miljenovic@gmail.com
+
+ This module provides common functions used by both
+ "Data.GraphViz.Types" as well as "Data.GraphViz.Types.Generalised".
+-}
+module Data.GraphViz.Types.Common where
+
+import Data.GraphViz.Parsing
+import Data.GraphViz.Printing
+import Data.GraphViz.Util
+import Data.GraphViz.Attributes(URL)
+
+import Data.Maybe(isJust)
+import Control.Monad(liftM, when)
+
+-- -----------------------------------------------------------------------------
+-- This is re-exported by Data.GraphViz.Types
+
+-- | A polymorphic type that covers all possible ID values allowed by
+-- Dot syntax. Note that whilst the 'ParseDot' and 'PrintDot'
+-- instances for 'String' will properly take care of the special
+-- cases for numbers, they are treated differently here.
+data GraphID = Str String
+ | Int Int
+ | Dbl Double
+ | HTML URL
+ deriving (Eq, Ord, Show, Read)
+
+instance PrintDot GraphID where
+ unqtDot (Str str) = unqtDot str
+ unqtDot (Int i) = unqtDot i
+ unqtDot (Dbl d) = unqtDot d
+ unqtDot (HTML u) = unqtDot u
+
+ toDot (Str str) = toDot str
+ toDot gID = unqtDot gID
+
+instance ParseDot GraphID where
+ parseUnqt = liftM HTML parseUnqt
+ `onFail`
+ liftM stringNum parseUnqt
+
+ parse = liftM HTML parse
+ `onFail`
+ liftM stringNum parse
+ `adjustErr`
+ (++ "\nNot a valid GraphID")
+
+stringNum :: String -> GraphID
+stringNum str = maybe checkDbl Int $ stringToInt str
+ where
+ checkDbl = if isNumString str
+ then Dbl $ toDouble str
+ else Str str
+
+-- -----------------------------------------------------------------------------
+-- Labels
+
+dirGraph :: String
+dirGraph = "digraph"
+
+dirGraph' :: DotCode
+dirGraph' = text dirGraph
+
+undirGraph :: String
+undirGraph = "graph"
+
+undirGraph' :: DotCode
+undirGraph' = text undirGraph
+
+strGraph :: String
+strGraph = "strict"
+
+strGraph' :: DotCode
+strGraph' = text strGraph
+
+sGraph :: String
+sGraph = "subgraph"
+
+sGraph' :: DotCode
+sGraph' = text sGraph
+
+clust :: String
+clust = "cluster"
+
+clust' :: DotCode
+clust' = text clust
+
+-- -----------------------------------------------------------------------------
+
+printGraphID :: (a -> Bool) -> (a -> Bool)
+ -> (a -> Maybe GraphID)
+ -> a -> DotCode
+printGraphID str isDir mID g = bool empty strGraph' (str g)
+ <+> bool undirGraph' dirGraph' (isDir g)
+ <+> maybe empty toDot (mID g)
+
+parseGraphID :: (Bool -> Bool -> Maybe GraphID -> a) -> Parse a
+parseGraphID f = do str <- liftM isJust
+ $ optional (parseAndSpace $ string strGraph)
+ dir <- parseAndSpace ( stringRep True dirGraph
+ `onFail`
+ stringRep False undirGraph
+ )
+ gID <- optional $ parseAndSpace parse
+ return $ f str dir gID
+
+printStmtBased :: (a -> DotCode) -> (a -> b) -> (b -> DotCode)
+ -> a -> DotCode
+printStmtBased f r dr a = printBracesBased (f a) (dr $ r a)
+
+printStmtBasedList :: (a -> DotCode) -> (a -> b) -> (b -> DotCode)
+ -> [a] -> DotCode
+printStmtBasedList f r dr = vcat . map (printStmtBased f r dr)
+
+parseStmtBased :: Parse stmt -> Parse (stmt -> a) -> Parse a
+parseStmtBased = flip apply . parseBracesBased
+
+parseStmtBasedList :: Parse stmt -> Parse (stmt -> a) -> Parse [a]
+parseStmtBasedList ps pr = sepBy (whitespace' >> parseStmtBased ps pr) newline'
+
+printBracesBased :: DotCode -> DotCode -> DotCode
+printBracesBased h i = vcat [ h <+> lbrace
+ , ind i
+ , rbrace
+ ]
+ where
+ ind = nest 4
+
+parseBracesBased :: Parse a -> Parse a
+parseBracesBased p = do whitespace'
+ character '{'
+ newline'
+ a <- p
+ newline'
+ whitespace'
+ character '}'
+ return a
+ `adjustErr`
+ (++ "\nNot a valid value wrapped in braces.")
+
+
+printSubGraphID :: (a -> (Bool, Maybe GraphID)) -> a -> DotCode
+printSubGraphID f a = sGraph'
+ <+> maybe cl dtID mID
+ where
+ (isCl, mID) = f a
+ cl = bool empty clust' isCl
+ dtID = printSGID isCl
+
+-- | Print the actual ID for a 'DotSubGraph'.
+printSGID :: Bool -> GraphID -> DotCode
+printSGID isCl sID = bool noClust addClust isCl
+ where
+ noClust = toDot sID
+ -- Have to manually render it as we need the un-quoted form.
+ addClust = toDot . (++) clust . (:) '_'
+ . renderDot $ mkDot sID
+ mkDot (Str str) = text str -- Quotes will be escaped later
+ mkDot gid = unqtDot gid
+
+parseSubGraphID :: (Bool -> Maybe GraphID -> c) -> Parse c
+parseSubGraphID f = do string sGraph
+ whitespace
+ liftM (uncurry f) parseSGID
+
+parseSGID :: Parse (Bool, Maybe GraphID)
+parseSGID = oneOf [ liftM getClustFrom $ parseAndSpace parse
+ , return (False, Nothing)
+ ]
+ where
+ -- If it's a String value, check to see if it's actually a
+ -- cluster_Blah value; thus need to manually re-parse it.
+ getClustFrom (Str str) = fst $ runParser pStr str
+ getClustFrom gid = (False, Just gid)
+
+ checkCl = stringRep True clust
+ pStr = do isCl <- checkCl
+ `onFail`
+ return False
+ when isCl $ optional (character '_') >> return ()
+ sID <- optional pID
+ let sID' = if sID == emptyID
+ then Nothing
+ else sID
+ return (isCl, sID')
+
+ emptyID = Just $ Str ""
+
+ -- For Strings, there are no more quotes to unescape, so consume
+ -- what you can.
+ pID = liftM HTML parseUnqt
+ `onFail`
+ liftM stringNum (many next)
+
+{- This is a much nicer definition, but unfortunately it doesn't work.
+ The problem is that Graphviz decides that a subgraph is a cluster
+ if the ID starts with "cluster" (no quotes); thus, we _have_ to do
+ the double layer of parsing to get it to work :@
+
+ do isCl <- stringRep True clust
+ `onFail`
+ return False
+ sID <- optional $ do when isCl
+ $ optional (character '_') >> return ()
+ parseUnqt
+ when (isCl || isJust sID) $ whitespace >> return ()
+ return (isCl, sID)
+-}
diff --git a/Data/GraphViz/Types/Generalised.hs b/Data/GraphViz/Types/Generalised.hs
new file mode 100644
--- /dev/null
+++ b/Data/GraphViz/Types/Generalised.hs
@@ -0,0 +1,205 @@
+{-# LANGUAGE MultiParamTypeClasses
+ , FlexibleInstances
+ #-}
+
+{- |
+ Module : Data.GraphViz.Types.Generalised.
+ Description : Alternate definition of the Graphviz types.
+ Copyright : (c) Ivan Lazar Miljenovic
+ License : 3-Clause BSD-style
+ Maintainer : Ivan.Miljenovic@gmail.com
+
+ This module provides an alternate definition of the types found in
+ "Data.GraphViz.Types", in that the ordering constraint found in
+ 'DotStatements' is no longer present. All other
+ limitations\/constraints are still present however.
+
+ The types here have the same names as those in
+ "Data.GraphViz.Types" but with a prefix of @\"G\"@.
+
+ This module is partially experimental, and may change in the
+ future.
+-}
+module Data.GraphViz.Types.Generalised
+ ( -- * The overall representation of a graph in generalised /Dot/ format.
+ GDotGraph(..)
+ -- * Sub-components of a @GDotGraph@.
+ , GDotStatements
+ , GDotStatement(..)
+ , GDotSubGraph(..)
+ -- ** Re-exported from @Data.GraphViz.Types@.
+ , GraphID(..)
+ , GlobalAttributes(..)
+ , DotNode(..)
+ , DotEdge(..)
+ -- * Conversion from a @DotGraph@.
+ , generaliseDotGraph
+ ) where
+
+import Data.GraphViz.Types hiding (GraphID(..))
+import Data.GraphViz.Types.Common
+import Data.GraphViz.Parsing
+import Data.GraphViz.Printing
+
+import qualified Data.Sequence as Seq
+import Data.Sequence(Seq, (><))
+import qualified Data.Foldable as F
+import Control.Monad(liftM)
+
+-- -----------------------------------------------------------------------------
+
+-- | The internal representation of a generalised graph in Dot form.
+data GDotGraph a = GDotGraph { gStrictGraph :: Bool -- ^ If 'True', no multiple edges are drawn.
+ , gDirectedGraph :: Bool
+ , gGraphID :: Maybe GraphID
+ , gGraphStatements :: GDotStatements a
+ }
+ deriving (Eq, Ord, Show, Read)
+
+instance (PrintDot n, ParseDot n) => DotRepr GDotGraph n where
+ graphIsDirected = gDirectedGraph
+
+ makeStrict g = g { gStrictGraph = True }
+
+ setID i g = g { gGraphID = Just i }
+
+ graphNodes = statementNodes . gGraphStatements
+
+ graphEdges = statementEdges . gGraphStatements
+
+instance (PrintDot a) => PrintDot (GDotGraph a) where
+ unqtDot = printStmtBased printGraphID' gGraphStatements printGStmts
+ where
+ printGraphID' = printGraphID gStrictGraph gDirectedGraph gGraphID
+
+instance (ParseDot a) => ParseDot (GDotGraph a) where
+ parseUnqt = parseStmtBased parseGStmts (parseGraphID GDotGraph)
+
+ parse = parseUnqt -- Don't want the option of quoting
+ `adjustErr`
+ (++ "\n\nNot a valid DotGraph")
+
+instance Functor GDotGraph where
+ fmap f g = g { gGraphStatements = (fmap . fmap) f $ gGraphStatements g }
+
+-- | Convert a 'DotGraph' to a 'GDotGraph', keeping the same order of
+-- statements.
+generaliseDotGraph :: DotGraph a -> GDotGraph a
+generaliseDotGraph dg = GDotGraph { gStrictGraph = strictGraph dg
+ , gDirectedGraph = directedGraph dg
+ , gGraphID = graphID dg
+ , gGraphStatements = generaliseStatements
+ $ graphStatements dg
+ }
+
+-- -----------------------------------------------------------------------------
+
+type GDotStatements a = Seq (GDotStatement a)
+
+printGStmts :: (PrintDot a) => GDotStatements a -> DotCode
+printGStmts = vcat . map toDot . F.toList
+
+parseGStmts :: (ParseDot a) => Parse (GDotStatements a)
+parseGStmts = liftM Seq.fromList $ many p
+ where
+ p = whitespace' >> parse `discard` newline'
+
+statementNodes :: GDotStatements a -> [DotNode a]
+statementNodes = concatMap stmtNodes . F.toList
+
+statementEdges :: GDotStatements a -> [DotEdge a]
+statementEdges = concatMap stmtEdges . F.toList
+
+generaliseStatements :: DotStatements a -> GDotStatements a
+generaliseStatements stmts = atts >< sgs >< ns >< es
+ where
+ atts = Seq.fromList . map GA $ attrStmts stmts
+ sgs = Seq.fromList . map (SG . generaliseSubGraph) $ subGraphs stmts
+ ns = Seq.fromList . map DN $ nodeStmts stmts
+ es = Seq.fromList . map DE $ edgeStmts stmts
+
+
+data GDotStatement a = GA GlobalAttributes
+ | SG (GDotSubGraph a)
+ | DN (DotNode a)
+ | DE (DotEdge a)
+ deriving (Eq, Ord, Show, Read)
+
+instance (PrintDot a) => PrintDot (GDotStatement a) where
+ unqtDot (GA ga) = unqtDot ga
+ unqtDot (SG sg) = unqtDot sg
+ unqtDot (DN dn) = unqtDot dn
+ unqtDot (DE de) = unqtDot de
+
+instance (ParseDot a) => ParseDot (GDotStatement a) where
+ parseUnqt = oneOf [ liftM GA parseUnqt
+ , liftM SG parseUnqt
+ , liftM DN parseUnqt
+ , liftM DE parseUnqt
+ ]
+
+ parse = parseUnqt -- Don't want the option of quoting
+ `adjustErr`
+ (++ "Not a valid statement")
+
+instance Functor GDotStatement where
+ fmap _ (GA ga) = GA ga -- Have to re-make this to make the type checker happy.
+ fmap f (SG sg) = SG $ fmap f sg
+ fmap f (DN dn) = DN $ fmap f dn
+ fmap f (DE de) = DE $ fmap f de
+
+stmtNodes :: GDotStatement a -> [DotNode a]
+stmtNodes (SG sg) = subGraphNodes sg
+stmtNodes (DN dn) = [dn]
+stmtNodes _ = []
+
+stmtEdges :: (GDotStatement a) -> [DotEdge a]
+stmtEdges (SG sg) = subGraphEdges sg
+stmtEdges (DE de) = [de]
+stmtEdges _ = []
+
+-- -----------------------------------------------------------------------------
+
+data GDotSubGraph a = GDotSG { gIsCluster :: Bool
+ , gSubGraphID :: Maybe GraphID
+ , gSubGraphStmts :: GDotStatements a
+ }
+ deriving (Eq, Ord, Show, Read)
+
+instance (PrintDot a) => PrintDot (GDotSubGraph a) where
+ unqtDot = printStmtBased printSubGraphID' gSubGraphStmts printGStmts
+
+ unqtListToDot = printStmtBasedList printSubGraphID' gSubGraphStmts printGStmts
+
+ listToDot = unqtListToDot
+
+printSubGraphID' :: GDotSubGraph a -> DotCode
+printSubGraphID' = printSubGraphID (\sg -> (gIsCluster sg, gSubGraphID sg))
+
+instance (ParseDot a) => ParseDot (GDotSubGraph a) where
+ parseUnqt = parseStmtBased parseGStmts (parseSubGraphID GDotSG)
+
+ parse = parseUnqt -- Don't want the option of quoting
+ `adjustErr`
+ (++ "\n\nNot a valid Sub Graph")
+
+ parseUnqtList = parseStmtBasedList parseGStmts (parseSubGraphID GDotSG)
+
+ parseList = parseUnqtList
+
+instance Functor GDotSubGraph where
+ fmap f sg = sg { gSubGraphStmts = (fmap . fmap) f $ gSubGraphStmts sg }
+
+subGraphNodes :: GDotSubGraph a -> [DotNode a]
+subGraphNodes = statementNodes . gSubGraphStmts
+
+subGraphEdges :: GDotSubGraph a -> [DotEdge a]
+subGraphEdges = statementEdges . gSubGraphStmts
+
+generaliseSubGraph :: DotSubGraph a -> GDotSubGraph a
+generaliseSubGraph (DotSG isC mID stmts) = GDotSG { gIsCluster = isC
+ , gSubGraphID = mID
+ , gSubGraphStmts = stmts'
+ }
+ where
+ stmts' = generaliseStatements stmts
diff --git a/Data/GraphViz/Types/Internal.hs b/Data/GraphViz/Types/Internal.hs
deleted file mode 100644
--- a/Data/GraphViz/Types/Internal.hs
+++ /dev/null
@@ -1,119 +0,0 @@
-{- |
- Module : Data.GraphViz.Types.Internal
- Description : Internal functions
- Copyright : (c) Ivan Lazar Miljenovic
- License : 3-Clause BSD-style
- Maintainer : Ivan.Miljenovic@gmail.com
-
- This module defines internal functions.
--}
-module Data.GraphViz.Types.Internal where
-
-import Data.Char( isAsciiUpper
- , isAsciiLower
- , isDigit
- , toLower
- )
-
-import Data.Maybe(isJust)
-import qualified Data.Set as Set
-import Data.Set(Set)
-import Control.Monad(liftM2)
-
-isIDString :: String -> Bool
-isIDString [] = True
-isIDString (f:os) = frstIDString f
- && all restIDString os
-
--- | First character of a non-quoted 'String' must match this.
-frstIDString :: Char -> Bool
-frstIDString c = any ($c) [ isAsciiUpper
- , isAsciiLower
- , (==) '_'
- , liftM2 (&&) (>= '\200') (<= '\377')
- ]
-
--- | The rest of a non-quoted 'String' must match this.
-restIDString :: Char -> Bool
-restIDString c = frstIDString c || isDigit c
-
--- | Determine if this String represents a number.
-isNumString :: String -> Bool
-isNumString "" = False
-isNumString "-" = False
-isNumString str = case str of
- ('-':str') -> go str'
- _ -> go str
- where
- go s = case span isDigit (map toLower s) of
- (ds@(_:_),[]) -> all isDigit ds
- ([],'.':[]) -> False
- ([],'.':d:ds) -> isDigit d && checkEs' ds
- (_,'.':ds) -> checkEs $ dropWhile isDigit ds
- ([],_) -> False
- (_,ds) -> checkEs ds
- checkEs' s = case break ((==) 'e') s of
- ([], _) -> False
- (ds,es) -> all isDigit ds && checkEs es
- checkEs [] = True
- checkEs ('e':ds) = isIntString ds
- checkEs _ = False
-
--- | This assumes that 'isNumString' is 'True'.
-toDouble :: String -> Double
-toDouble str = case str of
- ('-':str') -> read $ '-' : adj str'
- _ -> read $ adj str
- where
- adj s = (:) '0'
- $ case span ((==) '.') (map toLower s) of
- (ds@(_:_), '.':[]) -> ds ++ '.' : '0' : []
- (ds, '.':es@('e':_)) -> ds ++ '.' : '0' : es
- _ -> s
-
-isIntString :: String -> Bool
-isIntString = isJust . stringToInt
-
--- | Determine if this String represents an integer.
-stringToInt :: String -> Maybe Int
-stringToInt str = if isNum
- then Just (read str)
- else Nothing
- where
- isNum = case str of
- "" -> False
- ['-'] -> False
- ('-':num) -> isNum' num
- _ -> isNum' str
- isNum' = all isDigit
-
--- | Graphviz requires double quotes to be explicitly escaped.
-escapeQuotes :: String -> String
-escapeQuotes [] = []
-escapeQuotes ('"':str) = '\\':'"': escapeQuotes str
-escapeQuotes (c:str) = c : escapeQuotes str
-
--- | Remove explicit escaping of double quotes.
-descapeQuotes :: String -> String
-descapeQuotes [] = []
-descapeQuotes ('\\':'"':str) = '"' : descapeQuotes str
-descapeQuotes (c:str) = c : descapeQuotes str
-
-isKeyword :: String -> Bool
-isKeyword = flip Set.member keywords . map toLower
-
--- | The following are Dot keywords and are not valid as labels, etc. unquoted.
-keywords :: Set String
-keywords = Set.fromList [ "node"
- , "edge"
- , "graph"
- , "digraph"
- , "subgraph"
- , "strict"
- ]
-
--- | Fold over 'Bool's; first param is for 'False', second for 'True'.
-bool :: a -> a -> Bool -> a
-bool f t b = if b
- then t
- else f
diff --git a/Data/GraphViz/Types/Parsing.hs b/Data/GraphViz/Types/Parsing.hs
deleted file mode 100644
--- a/Data/GraphViz/Types/Parsing.hs
+++ /dev/null
@@ -1,395 +0,0 @@
-{- |
- Module : Data.GraphViz.Types.Parsing
- Description : Helper functions for Parsing.
- Copyright : (c) Matthew Sackman, Ivan Lazar Miljenovic
- License : 3-Clause BSD-style
- Maintainer : Ivan.Miljenovic@gmail.com
-
- This module defines simple helper functions for use with
- "Text.ParserCombinators.Poly.Lazy".
-
- Note that the 'ParseDot' instances for 'Bool', etc. match those
- specified for use with Graphviz (e.g. non-zero integers are
- equivalent to 'True').
-
- You should not be using this module; rather, it is here for
- informative/documentative reasons. If you want to parse a
- @'Data.GraphViz.Types.DotGraph'@, you should use
- @'Data.GraphViz.Types.parseDotGraph'@ rather than its 'ParseDot'
- instance.
--}
-module Data.GraphViz.Types.Parsing
- ( -- * Re-exporting pertinent parts of Polyparse.
- module Text.ParserCombinators.Poly.Lazy
- -- * The ParseDot class.
- , Parse
- , ParseDot(..)
- , parseIt
- -- * Convenience parsing combinators.
- , onlyBool
- , stringBlock
- , numString
- , isNumString
- , isIntString
- , quotedString
- , parseAndSpace
- , string
- , strings
- , hasString
- , character
- , parseStrictFloat
- , noneOf
- , whitespace
- , whitespace'
- , optionalQuotedString
- , optionalQuoted
- , quotedParse
- , orQuote
- , quoteChar
- , newline
- , newline'
- , parseComma
- , tryParseList
- , tryParseList'
- , skipToNewline
- , parseField
- , parseFields
- , parseFieldBool
- , parseFieldsBool
- , parseFieldDef
- , parseFieldsDef
- , commaSep
- , commaSepUnqt
- , commaSep'
- , stringRep
- , stringReps
- -- * Pre-processing of Dot code to remove comments, etc.
- , preProcess
- ) where
-
-import Data.GraphViz.Types.Internal
-
-import Text.ParserCombinators.Poly.Lazy
-import Data.Char( digitToInt
- , isDigit
- , isSpace
- , toLower
- )
-import Data.Function(on)
-import Data.Maybe(isJust, fromMaybe, isNothing)
-import Data.Ratio((%))
-import Data.Word(Word8)
-import Control.Monad(liftM, when)
-
--- -----------------------------------------------------------------------------
--- Based off code from Text.Parse in the polyparse library
-
--- | A @ReadS@-like type alias.
-type Parse a = Parser Char a
-
-class ParseDot a where
- parseUnqt :: Parse a
-
- parse :: Parse a
- parse = optionalQuoted parseUnqt
-
- parseUnqtList :: Parse [a]
- parseUnqtList = bracketSep (parseAndSpace $ character '[')
- (parseAndSpace $ parseComma)
- (parseAndSpace $ character ']')
- (parseAndSpace parse)
-
- parseList :: Parse [a]
- parseList = quotedParse parseUnqtList
-
--- | Parse the required value, returning also the rest of the input
--- 'String' that hasn't been parsed.
-parseIt :: (ParseDot a) => String -> (a, String)
-parseIt = runParser parse
-
-instance ParseDot Int where
- parseUnqt = parseInt'
-
-instance ParseDot Word8 where
- parseUnqt = parseInt
-
-instance ParseDot Double where
- parseUnqt = parseFloat'
-
-instance ParseDot Bool where
- parseUnqt = onlyBool
- `onFail`
- liftM (zero /=) parseInt'
- where
- zero :: Int
- zero = 0
-
--- | Use this when you do not want numbers to be treated as 'Bool' values.
-onlyBool :: Parse Bool
-onlyBool = oneOf [ stringRep True "true"
- , stringRep False "false"
- ]
-
-instance ParseDot Char where
- -- Can't be a quote character.
- parseUnqt = satisfy ((/=) quoteChar)
-
- parse = satisfy restIDString
- `onFail`
- quotedParse parseUnqt
-
- -- Too many problems with using this within other parsers where
- -- using numString or stringBlock will cause a parse failure. As
- -- such, this will successfully parse all un-quoted Strings.
- parseUnqtList = quotedString
-
- parseList = oneOf [numString, stringBlock]
- `onFail`
- -- This will also take care of quoted versions of
- -- above.
- quotedParse quotedString
-
-instance (ParseDot a) => ParseDot [a] where
- parseUnqt = parseUnqtList
-
- parse = parseList
-
-numString :: Parse String
-numString = liftM show parseStrictFloat
- `onFail`
- liftM show parseInt'
-
-stringBlock :: Parse String
-stringBlock = do frst <- satisfy frstIDString
- rest <- many (satisfy restIDString)
- return $ frst : rest
-
--- | Used when quotes are explicitly required;
-quotedString :: Parse String
-quotedString = many stringInterior
-
-stringInterior :: Parse Char
-stringInterior = orQuote $ satisfy ((/=) quoteChar)
-
-parseSigned :: Real a => Parse a -> Parse a
-parseSigned p = (character '-' >> liftM negate p)
- `onFail`
- p
-
-parseInt :: (Integral a) => Parse a
-parseInt = do cs <- many1 (satisfy isDigit)
- return (foldl1 (\n d-> n*radix+d)
- (map (fromIntegral . digitToInt) cs))
- `adjustErr` (++ "\nexpected one or more digits")
- where
- radix = 10
-
-parseInt' :: Parse Int
-parseInt' = parseSigned parseInt
-
--- | Parse a floating point number that actually contains decimals.
-parseStrictFloat :: Parse Double
-parseStrictFloat = parseSigned parseFloat
-
-parseFloat :: (RealFrac a) => Parse a
-parseFloat = do ds <- many (satisfy isDigit)
- frac <- optional
- $ do character '.'
- many1 (satisfy isDigit)
- `adjustErr` (++ "\nexpected digit after .")
- when (isNothing frac && null ds)
- (fail "No actual digits in floating point number!")
- expn <- optional parseExp
- when (isNothing frac && isNothing expn)
- (fail "This is an integer, not a floating point number!")
- let frac' = fromMaybe "" frac
- expn' = fromMaybe 0 expn
- ( return . fromRational . (* (10^^(expn' - length frac')))
- . (%1) . fst
- . runParser parseInt) (ds++frac')
- `onFail`
- fail "Expected a floating point number"
- where parseExp = do character 'e'
- ((character '+' >> parseInt)
- `onFail`
- parseInt')
-
-parseFloat' :: Parse Double
-parseFloat' = parseSigned ( parseFloat
- `onFail`
- liftM fI parseInt
- )
- where
- fI :: Integer -> Double
- fI = fromIntegral
-
--- -----------------------------------------------------------------------------
-
-parseAndSpace :: Parse a -> Parse a
-parseAndSpace p = p `discard` whitespace'
-
-string :: String -> Parse String
-string = mapM character
-
-stringRep :: a -> String -> Parse a
-stringRep v = stringReps v . return
-
-stringReps :: a -> [String] -> Parse a
-stringReps v ss = oneOf (map string ss) >> return v
-
-strings :: [String] -> Parse String
-strings = oneOf . map string
-
-hasString :: String -> Parse Bool
-hasString = liftM isJust . optional . string
-
-character :: Char -> Parse Char
-character c = satisfy (((==) `on` toLower) c)
- `adjustErr`
- (++ "\nnot the expected char: " ++ [c])
-
-noneOf :: (Eq a) => [a] -> Parser a a
-noneOf t = satisfy (\x -> all (/= x) t)
-
-whitespace :: Parse String
-whitespace = many1 (satisfy isSpace)
-
-whitespace' :: Parse String
-whitespace' = many (satisfy isSpace)
-
-optionalQuotedString :: String -> Parse String
-optionalQuotedString = optionalQuoted . string
-
-optionalQuoted :: Parse a -> Parse a
-optionalQuoted p = quotedParse p
- `onFail`
- p
-
-quotedParse :: Parse a -> Parse a
-quotedParse = bracket parseQuote parseQuote
-
-parseQuote :: Parse Char
-parseQuote = character quoteChar
-
-orQuote :: Parse Char -> Parse Char
-orQuote p = stringRep quoteChar "\\\""
- `onFail`
- p
-
-quoteChar :: Char
-quoteChar = '"'
-
-newline :: Parse String
-newline = oneOf $ map string ["\r\n", "\n", "\r"]
-
--- | Consume all whitespace and newlines until a line with
--- non-whitespace is reached. The whitespace on that line is
--- not consumed.
-newline' :: Parse ()
-newline' = many (whitespace' >> newline) >> return ()
-
--- | Parses and returns all characters up till the end of the line,
--- then skips to the beginning of the next line.
-skipToNewline :: Parse String
-skipToNewline = many (noneOf ['\n','\r']) `discard` newline
-
-parseField :: (ParseDot a) => String -> Parse a
-parseField fld = do string fld
- whitespace'
- character '='
- whitespace'
- parse
-
-parseFields :: (ParseDot a) => [String] -> Parse a
-parseFields = oneOf . map parseField
-
-parseFieldBool :: String -> Parse Bool
-parseFieldBool = parseFieldDef True
-
-parseFieldsBool :: [String] -> Parse Bool
-parseFieldsBool = oneOf . map parseFieldBool
-
--- | For 'Bool'-like data structures where the presence of the field
--- name without a value implies a default value.
-parseFieldDef :: (ParseDot a) => a -> String -> Parse a
-parseFieldDef d fld = parseField fld
- `onFail`
- stringRep d fld
-
-parseFieldsDef :: (ParseDot a) => a -> [String] -> Parse a
-parseFieldsDef d = oneOf . map (parseFieldDef d)
-
-commaSep :: (ParseDot a, ParseDot b) => Parse (a, b)
-commaSep = commaSep' parse parse
-
-commaSepUnqt :: (ParseDot a, ParseDot b) => Parse (a, b)
-commaSepUnqt = commaSep' parseUnqt parseUnqt
-
-commaSep' :: Parse a -> Parse b -> Parse (a,b)
-commaSep' pa pb = do a <- pa
- whitespace'
- parseComma
- whitespace'
- b <- pb
- return (a,b)
-
-parseComma :: Parse Char
-parseComma = character ','
-
-tryParseList :: (ParseDot a) => Parse [a]
-tryParseList = tryParseList' parse
-
-tryParseList' :: Parse [a] -> Parse [a]
-tryParseList' = liftM (fromMaybe []) . optional
-
--- -----------------------------------------------------------------------------
--- Filtering out unwanted Dot items such as comments
-
--- | Remove unparseable features of Dot, such as comments and
--- multi-line strings (which are converted to single-line strings).
-preProcess :: String -> String
-preProcess = fst . runParser parseOutUnwanted
- -- snd should be null
-
--- | Parse out comments and make quoted strings spread over multiple
--- lines only over a single line. Should parse the /entire/ input
--- 'String'.
-parseOutUnwanted :: Parse String
-parseOutUnwanted = liftM concat (many getNext)
- where
- getNext :: Parse String
- getNext = parseSplitStrings
- `onFail`
- (oneOf [ parseLineComment, parseMultiLineComment ] >> return [])
- `onFail`
- liftM return next
-
--- | Parse @//@-style comments.
-parseLineComment :: Parse String
-parseLineComment = string "//" >> newline
-
--- | Parse @/* ... */@-style comments.
-parseMultiLineComment :: Parse String
-parseMultiLineComment = bracket start end (liftM concat $ many inner)
- where
- start = string "/*"
- end = string "*/"
- inner = many1 (satisfy ((/=) '*'))
- `onFail`
- do ast <- character '*'
- n <- satisfy ((/=) '/')
- liftM ((:) ast . (:) n) inner
-
--- | Parse out @\@ from a quoted string.
-parseSplitStrings :: Parse String
-parseSplitStrings = do oq <- parseQuote
- inner <- liftM concat $ many parseInner
- cq <- parseQuote
- return $ oq : inner ++ [cq]
- where
- parseInner = string "\\\""
- `onFail`
- (character '\\' >> newline >> return [])
- `onFail`
- liftM return (satisfy ((/=) quoteChar))
-
diff --git a/Data/GraphViz/Types/Printing.hs b/Data/GraphViz/Types/Printing.hs
deleted file mode 100644
--- a/Data/GraphViz/Types/Printing.hs
+++ /dev/null
@@ -1,175 +0,0 @@
-{- |
- Module : Data.GraphViz.Types.Printing
- Description : Helper functions for converting to Dot format.
- Copyright : (c) Ivan Lazar Miljenovic
- License : 3-Clause BSD-style
- Maintainer : Ivan.Miljenovic@gmail.com
-
- This module defines simple helper functions for use with
- "Text.PrettyPrint". It also re-exports all the pretty-printing
- combinators from that module.
-
- Note that the 'PrintDot' instances for 'Bool', etc. match those
- specified for use with Graphviz.
-
- You should only be using this module if you are writing custom node
- types for use with "Data.GraphViz.Types". For actual printing of
- code, use @'Data.GraphViz.Types.printDotGraph'@ (which produces a
- 'String' value).
-
- The Dot language specification specifies that any identifier is in
- one of four forms:
-
- * Any string of alphabetic ([a-zA-Z\200-\377]) characters, underscores ('_') or digits ([0-9]), not beginning with a digit;
-
- * a number [-]?(.[0-9]+ | [0-9]+(.[0-9]*)? );
-
- * any double-quoted string (\"...\") possibly containing escaped quotes (\\\");
-
- * an HTML string (<...>).
-
- Due to these restrictions, you should only use 'text' when you are
- sure that the 'String' in question is static and quotes are
- definitely needed/unneeded; it is better to use the 'String'
- instance for 'PrintDot'. For more information, see the
- specification page:
-
--}
-module Data.GraphViz.Types.Printing
- ( module Text.PrettyPrint
- , DotCode
- , renderDot -- Exported for Data.GraphViz.Types.printSGID
- , PrintDot(..)
- , printIt
- , addQuotes
- , wrap
- , commaDel
- , printField
- ) where
-
-import Data.GraphViz.Types.Internal
-
--- Only implicitly import and re-export combinators.
-import Text.PrettyPrint hiding ( Style(..)
- , Mode(..)
- , TextDetails(..)
- , render
- , style
- , renderStyle
- , fullRender
- )
-
-import qualified Text.PrettyPrint as PP
-
-import Data.Word(Word8)
-
--- -----------------------------------------------------------------------------
-
--- | A type alias to indicate what is being produced.
-type DotCode = Doc
-
--- | Correctly render Graphviz output.
-renderDot :: DotCode -> String
-renderDot = PP.renderStyle style'
- where
- style' = PP.style { PP.mode = PP.LeftMode }
-
--- | A class used to correctly print parts of the Graphviz Dot language.
--- Minimal implementation is 'unqtDot'.
-class PrintDot a where
- -- | The unquoted representation, for use when composing values to
- -- produce a larger printing value.
- unqtDot :: a -> DotCode
-
- -- | The actual quoted representation; this should be quoted if it
- -- contains characters not permitted a plain ID String, a number
- -- or it is not an HTML string.
- -- Defaults to 'unqtDot'.
- toDot :: a -> DotCode
- toDot = unqtDot
-
- -- | The correct way of representing a list of this value when
- -- printed; not all Dot values require this to be implemented.
- -- Defaults to Haskell-like list representation.
- unqtListToDot :: [a] -> DotCode
- unqtListToDot = brackets . hsep . punctuate comma
- . map unqtDot
-
- -- | The quoted form of 'unqtListToDot'; defaults to wrapping
- -- double quotes around the result of 'unqtListToDot' (since the
- -- default implementation has characters that must be quoted).
- listToDot :: [a] -> DotCode
- listToDot = doubleQuotes . unqtListToDot
-
--- | Convert to DotCode; note that this has no indentation, as we can
--- only have one of indentation and (possibly) infinite line lengths.
-printIt :: (PrintDot a) => a -> String
-printIt = renderDot . toDot
-
-instance PrintDot Int where
- unqtDot = int
-
-instance PrintDot Word8 where
- unqtDot = int . fromIntegral
-
-instance PrintDot Double where
- -- If it's an "integral" double, then print as an integer.
- -- This seems to match how Graphviz apps use Dot.
- unqtDot d = if d == fromIntegral di
- then int di
- else double d
- where
- di = round d
-
-instance PrintDot Bool where
- unqtDot True = text "true"
- unqtDot False = text "false"
-
-instance PrintDot Char where
- unqtDot = char
-
- toDot = qtChar
-
- unqtListToDot = unqtString
-
- listToDot = qtString
-
--- | Check to see if this 'Char' needs to be quoted or not.
-qtChar :: Char -> DotCode
-qtChar c
- | restIDString c = char c -- Could be a number as well.
- | otherwise = doubleQuotes $ char c
-
-needsQuotes :: String -> Bool
-needsQuotes str
- | null str = True
- | isKeyword str = True
- | isIDString str = False
- | isNumString str = False
- | otherwise = True
-
-addQuotes :: String -> DotCode -> DotCode
-addQuotes = bool id doubleQuotes . needsQuotes
-
--- | Escape quotes in Strings that need them.
-unqtString :: String -> DotCode
-unqtString "" = empty
-unqtString str = text $ escapeQuotes str -- no quotes? no worries!
-
--- | Escape quotes and quote Strings that need them (including keywords).
-qtString :: String -> DotCode
-qtString str = addQuotes str $ unqtString str
-
-instance (PrintDot a) => PrintDot [a] where
- unqtDot = unqtListToDot
-
- toDot = listToDot
-
-wrap :: DotCode -> DotCode -> DotCode -> DotCode
-wrap b a d = b <> d <> a
-
-commaDel :: (PrintDot a, PrintDot b) => a -> b -> DotCode
-commaDel a b = unqtDot a <> comma <> unqtDot b
-
-printField :: (PrintDot a) => String -> a -> DotCode
-printField f v = text f <> equals <> toDot v
diff --git a/Data/GraphViz/Util.hs b/Data/GraphViz/Util.hs
new file mode 100644
--- /dev/null
+++ b/Data/GraphViz/Util.hs
@@ -0,0 +1,133 @@
+{-# OPTIONS_HADDOCK hide #-}
+
+{- |
+ Module : Data.GraphViz.Util
+ Description : Internal utility functions
+ Copyright : (c) Ivan Lazar Miljenovic
+ License : 3-Clause BSD-style
+ Maintainer : Ivan.Miljenovic@gmail.com
+
+ This module defines internal utility functions.
+-}
+module Data.GraphViz.Util where
+
+import Data.Char( isAsciiUpper
+ , isAsciiLower
+ , isDigit
+ , toLower
+ )
+
+import Data.List(groupBy, sortBy)
+import Data.Maybe(isJust)
+import Data.Function(on)
+import qualified Data.Set as Set
+import Data.Set(Set)
+import Control.Monad(liftM2)
+
+-- -----------------------------------------------------------------------------
+
+isIDString :: String -> Bool
+isIDString [] = True
+isIDString (f:os) = frstIDString f
+ && all restIDString os
+
+-- | First character of a non-quoted 'String' must match this.
+frstIDString :: Char -> Bool
+frstIDString c = any ($c) [ isAsciiUpper
+ , isAsciiLower
+ , (==) '_'
+ , liftM2 (&&) (>= '\200') (<= '\377')
+ ]
+
+-- | The rest of a non-quoted 'String' must match this.
+restIDString :: Char -> Bool
+restIDString c = frstIDString c || isDigit c
+
+-- | Determine if this String represents a number.
+isNumString :: String -> Bool
+isNumString "" = False
+isNumString "-" = False
+isNumString str = case str of
+ ('-':str') -> go str'
+ _ -> go str
+ where
+ go s = case span isDigit (map toLower s) of
+ (ds@(_:_),[]) -> all isDigit ds
+ ([],'.':[]) -> False
+ ([],'.':d:ds) -> isDigit d && checkEs' ds
+ (_,'.':ds) -> checkEs $ dropWhile isDigit ds
+ ([],_) -> False
+ (_,ds) -> checkEs ds
+ checkEs' s = case break ((==) 'e') s of
+ ([], _) -> False
+ (ds,es) -> all isDigit ds && checkEs es
+ checkEs [] = True
+ checkEs ('e':ds) = isIntString ds
+ checkEs _ = False
+
+-- | This assumes that 'isNumString' is 'True'.
+toDouble :: String -> Double
+toDouble str = case str of
+ ('-':str') -> read $ '-' : adj str'
+ _ -> read $ adj str
+ where
+ adj s = (:) '0'
+ $ case span ((==) '.') (map toLower s) of
+ (ds@(_:_), '.':[]) -> ds ++ '.' : '0' : []
+ (ds, '.':es@('e':_)) -> ds ++ '.' : '0' : es
+ _ -> s
+
+isIntString :: String -> Bool
+isIntString = isJust . stringToInt
+
+-- | Determine if this String represents an integer.
+stringToInt :: String -> Maybe Int
+stringToInt str = if isNum
+ then Just (read str)
+ else Nothing
+ where
+ isNum = case str of
+ "" -> False
+ ['-'] -> False
+ ('-':num) -> isNum' num
+ _ -> isNum' str
+ isNum' = all isDigit
+
+-- | Graphviz requires double quotes to be explicitly escaped.
+escapeQuotes :: String -> String
+escapeQuotes [] = []
+escapeQuotes ('"':str) = '\\':'"': escapeQuotes str
+escapeQuotes (c:str) = c : escapeQuotes str
+
+-- | Remove explicit escaping of double quotes.
+descapeQuotes :: String -> String
+descapeQuotes [] = []
+descapeQuotes ('\\':'"':str) = '"' : descapeQuotes str
+descapeQuotes (c:str) = c : descapeQuotes str
+
+isKeyword :: String -> Bool
+isKeyword = flip Set.member keywords . map toLower
+
+-- | The following are Dot keywords and are not valid as labels, etc. unquoted.
+keywords :: Set String
+keywords = Set.fromList [ "node"
+ , "edge"
+ , "graph"
+ , "digraph"
+ , "subgraph"
+ , "strict"
+ ]
+
+-- -----------------------------------------------------------------------------
+
+uniq :: (Ord a) => [a] -> [a]
+uniq = uniqBy id
+
+uniqBy :: (Ord b) => (a -> b) -> [a] -> [a]
+uniqBy f = map head . groupBy ((==) `on` f) . sortBy (compare `on` f)
+
+-- | Fold over 'Bool's; first param is for 'False', second for 'True'.
+bool :: a -> a -> Bool -> a
+bool f t b = if b
+ then t
+ else f
diff --git a/README b/README
--- a/README
+++ b/README
@@ -21,16 +21,15 @@
* Functions for running a Graphviz layout tool with all specified
output types.
-* The ability to not only generate but also parse Dot code (note that
- currently this is limited to a rather strict ordering of
- statements).
+* The ability to not only generate but also parse Dot code with two
+ options: strict and liberal (in terms of ordering of statements).
* Functions to convert FGL graphs to Dot code - including support to
group them into clusters - with a high degree of customisation by
specifying which attributes to use.
* Round-trip support for passing an FGL graph through Graphviz to
- augment node and edge labels with positional information.
+ augment node and edge labels with positional information, etc.
Please note that currently the convenience functions are only
available for FGL [3] graphs; this will be extended in future once a
diff --git a/TODO b/TODO
--- a/TODO
+++ b/TODO
@@ -2,8 +2,5 @@
* Utilise the generic graph class once it is finalised.
-* Add generic versions (that is, order isn't important) of
- Data.GraphViz.Types
-
* Encoding: Graphviz uses UTF-8 by default, Latin1 when set; should
graphviz use utf8-string and disable changing the encoding?
diff --git a/graphviz.cabal b/graphviz.cabal
--- a/graphviz.cabal
+++ b/graphviz.cabal
@@ -1,18 +1,39 @@
Name: graphviz
-Version: 2999.7.0.0
+Version: 2999.8.0.0
Stability: Beta
Synopsis: Graphviz bindings for Haskell.
-Description: This library provides bindings for the Dot language
- used by the Graphviz ()
- suite of programs. Also provided are
- convenience functions to convert FGL graphs into
- Dot code with a large degree of customisation
- for layout, etc.
+Description: {
+This library provides bindings for the Dot language used by the
+Graphviz () suite of programs, as well as
+functions to call the Grapvhiz programs.
+.
+Features of this library are:
+.
+* Almost complete coverage of all Graphviz attributes, etc. for
+ graphs, sub-graphs, clusters, nodes and edges:
+
+.
+* Thorough documentation on known problems with the library and how it
+ differs from the actual Dot specification.
+.
+* Support for specifying clusters.
+.
+* The ability to use a custom node type.
+.
+* Functions for running a Graphviz layout tool with all specified
+ output types.
+.
+* The ability to not only generate but also parse Dot code with two
+ options: strict and liberal (in terms of ordering of statements).
+.
+* Functions to convert FGL graphs to Dot code - including support to
+ group them into clusters - with a high degree of customisation by
+ specifying which attributes to use.
+.
+* Round-trip support for passing an FGL graph through Graphviz to
+ augment node and edge labels with positional information, etc.
+}
- Also allows a limited amount of parsing of Dot,
- and round-trip usage of Graphviz to attach
- positional data to each node and edge in the
- graph.
Category: Graphs, Graphics
License: BSD3
License-File: LICENSE
@@ -48,14 +69,16 @@
Exposed-Modules: Data.GraphViz
Data.GraphViz.Types
- Data.GraphViz.Types.Parsing
- Data.GraphViz.Types.Printing
+ Data.GraphViz.Types.Generalised
+ Data.GraphViz.Parsing
+ Data.GraphViz.Printing
Data.GraphViz.Commands
Data.GraphViz.Attributes
Data.GraphViz.Attributes.Colors
Other-Modules: Data.GraphViz.Types.Clustering
- Data.GraphViz.Types.Internal
+ Data.GraphViz.Types.Common
+ Data.GraphViz.Util
if flag(test)
Build-Depends: QuickCheck >= 2.1 && < 2.2