graphviz 2999.7.0.0 → 2999.8.0.0

raw patch · 21 files changed

+1673/−1100 lines, 21 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Changelog +30/−0
• Data/GraphViz.hs +236/−102
• Data/GraphViz/Attributes.hs +7/−3
• Data/GraphViz/Attributes/Colors.hs +2/−2
• Data/GraphViz/Commands.hs +25/−18
• Data/GraphViz/Parsing.hs +395/−0
• Data/GraphViz/Printing.hs +175/−0
• Data/GraphViz/Testing.hs +51/−10
• Data/GraphViz/Testing/Instances.hs +61/−6
• Data/GraphViz/Testing/Instances/FGL.hs +4/−5
• Data/GraphViz/Testing/Properties.hs +15/−6
• Data/GraphViz/Types.hs +78/−238
• Data/GraphViz/Types/Common.hs +216/−0
• Data/GraphViz/Types/Generalised.hs +205/−0
• Data/GraphViz/Types/Internal.hs +0/−119
• Data/GraphViz/Types/Parsing.hs +0/−395
• Data/GraphViz/Types/Printing.hs +0/−175
• Data/GraphViz/Util.hs +133/−0
• README +3/−4
• TODO +0/−3
• graphviz.cabal +37/−14

@@ -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 ===================== 

@@ -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:    <http://graphviz.org/> -   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?"

@@ -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)

@@ -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)

@@ -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 

@@ -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 @\<newline>@ 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))+

@@ -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:+      <http://graphviz.org/doc/info/lang.html>+-}+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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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                          }

@@ -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)+-}

@@ -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

@@ -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

@@ -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 @\<newline>@ 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))-

@@ -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:-      <http://graphviz.org/doc/info/lang.html>--}-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

@@ -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

@@ -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

@@ -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?

@@ -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 (<http://graphviz.org/>)-                      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 (<http://graphviz.org/>) 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:+  <http://graphviz.org/doc/info/attrs.html>+.+* 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