graphviz 2999.9.0.0 → 2999.10.0.0
raw patch · 21 files changed
+1940/−1082 lines, 21 filesdep +transformersdep ~fgldep ~polyparse
Dependencies added: transformers
Dependency ranges changed: fgl, polyparse
Files
- Changelog +63/−2
- Data/GraphViz.hs +159/−202
- Data/GraphViz/AttributeGenerator.hs +0/−512
- Data/GraphViz/Attributes.hs +163/−21
- Data/GraphViz/Commands.hs +1/−1
- Data/GraphViz/Parsing.hs +1/−1
- Data/GraphViz/PreProcessing.hs +3/−3
- Data/GraphViz/Testing.hs +172/−38
- Data/GraphViz/Testing/Instances/FGL.hs +1/−1
- Data/GraphViz/Testing/Properties.hs +104/−9
- Data/GraphViz/Types.hs +73/−157
- Data/GraphViz/Types/Clustering.hs +13/−8
- Data/GraphViz/Types/Common.hs +133/−1
- Data/GraphViz/Types/Generalised.hs +47/−23
- Data/GraphViz/Types/State.hs +283/−0
- FAQ +1/−1
- RunTests.hs +73/−2
- TestParsing.hs +0/−94
- graphviz.cabal +8/−6
- utils/AttributeGenerator.hs +548/−0
- utils/TestParsing.hs +94/−0
Changelog view
@@ -7,6 +7,67 @@ The following is information about what major changes have gone into each release. +Changes in 2999.10.0.0+----------------------++* Conversion of `FGL`-style graphs to `DotRepr` values is now achieved+ using the new `GraphvizParams` configuration type. This allows us+ to define a single parameter that stores all the conversion+ functions to pass around rather than having to pass around several+ functions. This also allows all the non-clustered and clustered+ functions to be collapsed together, whereas what used to be handled+ by the primed functions is now achieved by using the+ `setDirectedness` function.++ There are three default `GraphvizParams` available:++ - `defaultParams` provides some sensible defaults (no attributes+ or clustering).++ - `nonClusteredParams` is an alias of `defaultParams` where the+ clustering type is explicitly set to be `()` for cases where you+ don't want any clustering at all (whereas `defaultParams` allows+ you to set your own clustering functions).++ - `blankParams` sets all fields to be `undefined`; this is useful+ for situations where you have functions that will set some+ values for you and there is no sensible default you can use+ (mainly for the clustering function).++* Expansion of the `DotRepr` class:++ - More common functions are now defined as methods (`getID`,+ etc.).++ - The ability to get more information about the structure of the+ `DotRepr` graph, as well as where all the `DotNode`s are, etc.++ - `graphNodes` now returns `DotNode`s defined only as part of+ `DotEdge`s, and will also merge duplicate `DotNode`s together.++ - `graphNodes` and `graphEdges` also return `GlobalAttributes`+ that apply to them.++* The `Point` type now only has one constructor: `Point Double+ Double`. The `Int`-only constructor was present due to historical+ purposes and I thought that the `Pos` value for a `DotNode` would+ always be a pair of `Int`s; this turns out not to be the case.++* `SortV` and `PrismOverlap` now only take `Word16` values rather than+ `Int`s, as they're not meant to allow negative values (the choice of+ using `Word16` rather than `Word` was arbitrary, and because it's+ unlikely those values will be large enough to require the larger+ values available in `Word`).++* `NodeCluster` has been generalised to not have to take an `LNode`+ for the node type; the type alias `LNodeCluster` is available if you+ still want this.++* Several documentation typos fixed, including one spotted by **Kevin+ Quick**.++* The test-suite now allows running individual tests.+ Changes in 2999.9.0.0 --------------------- @@ -50,8 +111,8 @@ UTF-8). **Thanks to Jules Bean (aka quicksilver) for working out how to do this.** - More specifically: almost all Dot files that ship with Graphviz, as- documentation in the Linux kernel, etc. are now parseable.+ More specifically: almost all Dot files that ship with Graphviz, as+ documentation in the Linux kernel, etc. are now parseable. * A new script to assist in testing whether "real-world" Dot graphs are parseable.
Data/GraphViz.hs view
@@ -20,13 +20,17 @@ -} module Data.GraphViz ( -- * Conversion from graphs to /Dot/ format.- -- $conversion- graphToDot- , graphToDot'+ -- ** Specifying parameters.+ GraphvizParams(..)+ , defaultParams+ , nonClusteredParams+ , blankParams+ , setDirectedness+ -- ** Converting graphs.+ , graphToDot -- ** Conversion with support for clusters.+ , LNodeCluster , NodeCluster(..)- , clusterGraphToDot- , clusterGraphToDot' -- ** Pseudo-inverse conversion. , dotToGraph -- * Graph augmentation.@@ -36,15 +40,8 @@ , AttributeEdge -- ** Customisable augmentation. , graphToGraph- , graphToGraph'- , clusterGraphToGraph- , clusterGraphToGraph' -- ** Quick augmentation.- -- $quickAugment , dotizeGraph- , dotizeGraph'- , dotizeClusterGraph- , dotizeClusterGraph' -- ** Manual augmentation. -- $manualAugment , EdgeID@@ -89,51 +86,118 @@ hasFlip e = Set.member (flippedEdge e) eSet flippedEdge (f,t,l) = (t,f,l) --- | Determine if the given graph is directed.-isDirected :: (Ord b, Graph g) => g a b -> Bool-isDirected = not . isUndirected- -- ----------------------------------------------------------------------------- -{- $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).+-- | Defines the parameters used to convert a 'Graph' into a 'DotRepr'.+--+-- A value of type @'GraphvizParams' nl el cl l@ indicates that the+-- 'Graph' has node labels of type @nl@, edge labels of type @el@,+-- corresponding clusters of type @cl@ and after clustering the+-- nodes have a label of type @l@ (which may or may not be the same+-- as @nl@).+--+-- The clustering in 'clusterBy' can be to arbitrary depth.+data GraphvizParams nl el cl l+ = Params { -- | 'True' if the 'Graph' is directed; 'False'+ -- otherwise.+ isDirected :: Bool+ -- | The top-level global 'Attributes' for the entire+ -- 'Graph'.+ , globalAttributes :: [GlobalAttributes]+ -- | A function to specify which cluster a particular+ -- 'LNode' is in.+ , clusterBy :: (LNode nl -> LNodeCluster cl l)+ -- | The 'GraphID' for a cluster.+ , clusterID :: (cl -> Maybe GraphID)+ -- | Specify which global attributes are applied in+ -- the given cluster.+ , fmtCluster :: (cl -> [GlobalAttributes])+ -- | The specific 'Attributes' for that 'LNode'.+ , fmtNode :: (LNode l -> Attributes)+ -- | The specific 'Attributes' for that 'LEdge'.+ , fmtEdge :: (LEdge el -> Attributes)+ } - 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).--}+-- | A default 'GraphvizParams' value which assumes the graph is+-- directed, contains no clusters and has no 'Attribute's set.+--+-- If you wish to have the labels of the nodes after applying+-- 'clusterBy' to have a different from before clustering, then you+-- will have to specify your own 'GraphvizParams' value from scratch.+defaultParams :: GraphvizParams nl el cl nl+defaultParams = Params { isDirected = True+ , globalAttributes = []+ , clusterBy = N+ , clusterID = const Nothing+ , fmtCluster = const []+ , fmtNode = const []+ , fmtEdge = const []+ } --- | Convert a graph to Graphviz's /Dot/ format.-graphToDot :: (Graph gr) => Bool -> gr a b -> [GlobalAttributes]- -> (LNode a -> Attributes) -> (LEdge b -> Attributes)- -> DotGraph Node-graphToDot isDir graph gAttributes- = clusterGraphToDot isDir graph gAttributes clustBy cID fmtClust- where- clustBy :: LNode a -> NodeCluster () a- clustBy = N- cID = const Nothing- fmtClust = const []+-- | A variant of 'defaultParams' that enforces that the clustering+-- type is @'()'@; this avoids problems when using 'defaultParams'+-- internally within a function without any constraint on what the+-- clustering type is.+nonClusteredParams :: GraphvizParams nl el () nl+nonClusteredParams = defaultParams --- | Convert a graph to Graphviz's /Dot/ format with automatic--- direction detection.-graphToDot' :: (Ord b, Graph gr) => gr a b -> [GlobalAttributes]- -> (LNode a -> Attributes) -> (LEdge b -> Attributes)- -> DotGraph Node-graphToDot' graph = graphToDot (isDirected graph) graph+-- | A 'GraphvizParams' value where every field is set to+-- @'undefined'@. This is useful when you have a function that will+-- set some of the values for you (e.g. 'setDirectedness') but you+-- don't want to bother thinking of default values to set in the+-- meantime.+blankParams :: GraphvizParams nl el cl l+blankParams = Params { isDirected = undefined+ , globalAttributes = undefined+ , clusterBy = undefined+ , clusterID = undefined+ , fmtCluster = undefined+ , fmtNode = undefined+ , fmtEdge = undefined+ } --- | A pseudo-inverse to 'graphToDot' and 'graphToDot''; \"pseudo\" in--- the sense that the original node and edge labels aren't able to--- be reconstructed.+-- | Determine if the provided 'Graph' is directed or not and set the+-- value of 'isDirected' appropriately.+setDirectedness :: (Ord el, Graph gr)+ => (GraphvizParams nl el cl l -> gr nl el -> a)+ -> GraphvizParams nl el cl l -> gr nl el -> a+setDirectedness f params gr = f params' gr+ where+ params' = params { isDirected = not $ isUndirected gr }++-- | Convert a graph to /Dot/ format, using the specified parameters+-- to cluster the graph, etc.+graphToDot :: (Ord cl, Graph gr) => GraphvizParams nl el cl l+ -> gr nl el -> DotGraph Node+graphToDot params graph+ = DotGraph { strictGraph = False+ , directedGraph = dirGraph+ , graphID = Nothing+ , graphStatements = stmts+ }+ where+ dirGraph = isDirected params+ stmts = DotStmts { attrStmts = globalAttributes params+ , subGraphs = cs+ , nodeStmts = ns+ , edgeStmts = es+ }+ (cs, ns) = clustersToNodes (clusterBy params) (clusterID params)+ (fmtCluster params) (fmtNode params)+ graph+ es = mapMaybe mkDotEdge . labEdges $ graph+ mkDotEdge e@(f,t,_) = if dirGraph || f <= t+ then Just+ DotEdge { edgeFromNodeID = f+ , edgeToNodeID = t+ , edgeAttributes = fmtEdge params e+ , directedEdge = dirGraph+ }+ else Nothing++-- | A pseudo-inverse to '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@@ -146,55 +210,13 @@ nSet = Set.fromList $ map fst ns nEs = map (flip (,) []) . uniq- . filter (flip Set.notMember nSet)+ . filter (`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.-clusterGraphToDot :: (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)- -> DotGraph Node-clusterGraphToDot dirGraph graph gAttrs clusterBy cID fmtCluster fmtNode fmtEdge- = DotGraph { strictGraph = False- , directedGraph = dirGraph- , graphID = Nothing- , graphStatements = stmts- }- where- stmts = DotStmts { attrStmts = gAttrs- , subGraphs = cs- , nodeStmts = ns- , edgeStmts = es- }- (cs, ns) = clustersToNodes clusterBy cID fmtCluster fmtNode graph- es = mapMaybe mkDotEdge . labEdges $ graph- mkDotEdge e@(f,t,_) = if dirGraph || f <= t- then Just DotEdge { edgeFromNodeID = f- , edgeToNodeID = t- , edgeAttributes = fmtEdge e- , directedEdge = dirGraph- }- else Nothing---- | Convert a graph to /Dot/ format, using the specified clustering function--- to group nodes into clusters.--- Clusters can be nested to arbitrary depth.--- Graph direction is automatically inferred.-clusterGraphToDot' :: (Ord c, Ord b, Graph gr) => gr a b- -> [GlobalAttributes] -> (LNode a -> NodeCluster c l)- -> (c -> Maybe GraphID) -> (c -> [GlobalAttributes])- -> (LNode l -> Attributes) -> (LEdge b -> Attributes)- -> DotGraph Node-clusterGraphToDot' gr = clusterGraphToDot (isDirected gr) gr- -- ----------------------------------------------------------------------------- {- $augment@@ -207,13 +229,9 @@ '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:+ Note that the reason that most of these functions do not have+ 'unsafePerformIO' applied to them is because if you set a global+ 'Attribute' of: @ 'Start' ('StartStyle' 'RandomStyle')@@ -226,103 +244,42 @@ use 'unsafePerformIO' directly in your own code. -} -type AttributeNode a = (Attributes, a)-type AttributeEdge b = (Attributes, b)+-- | Augment the current node label type with the 'Attributes' applied+-- to that node.+type AttributeNode nl = (Attributes, nl) --- | Run the appropriate Graphviz command on the graph to get--- positional information and then combine that information back--- 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 (setEdgeComment fmtEdge)- gr' = addEdgeIDs gr+-- | Augment the current edge label type with the 'Attributes' applied+-- to that edge.+type AttributeEdge el = (Attributes, el) -- | 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)- -> IO (gr (AttributeNode a) (AttributeEdge b))-graphToGraph' gr = graphToGraph (isDirected gr) gr---- | Run the appropriate Graphviz command on the clustered graph to--- get positional information and then combine that information back--- 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+graphToGraph :: (Ord cl, Graph gr) => GraphvizParams nl el cl l -> gr nl el+ -> IO (gr (AttributeNode nl) (AttributeEdge el))+graphToGraph params gr = dotAttributes (isDirected params) gr' dot where- dot = clusterGraphToDot isDir gr' gAtts clBy cID fmtClust fmtNode fmtEdge'+ dot = graphToDot params' gr'+ params' = params { fmtEdge = setEdgeComment $ fmtEdge params } 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)- -> (c -> Maybe GraphID) -> (c -> [GlobalAttributes])- -> (LNode l -> Attributes) -> (LEdge b -> Attributes)- -> IO (gr (AttributeNode a) (AttributeEdge b))-clusterGraphToGraph' gr = clusterGraphToGraph (isDirected gr) gr- -- ----------------------------------------------------------------------------- -{- $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- $ graphToGraph isDir g gAttrs noAttrs noAttrs- where- gAttrs = []- noAttrs = const []---- | 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.-dotizeClusterGraph :: (Ord c, Graph gr) => Bool -> gr a b- -> (LNode a -> NodeCluster c l)- -> gr (AttributeNode a) (AttributeEdge b)-dotizeClusterGraph isDir g clustBy = unsafePerformIO- $ clusterGraphToGraph isDir g- gAttrs clustBy- cID cAttrs- noAttrs noAttrs+-- | This is a \"quick-and-dirty\" graph augmentation function that+-- sets no 'Attributes' and thus should be referentially transparent+-- and is wrapped in 'unsafePerformIO'.+--+-- Note that the provided 'GraphvizParams' is only used for+-- 'isDirected', 'clusterBy' and 'clusterID'.+dotizeGraph :: (Ord cl, Graph gr) => GraphvizParams nl el cl l+ -> gr nl el -> gr (AttributeNode nl) (AttributeEdge el)+dotizeGraph params gr = unsafePerformIO+ $ graphToGraph params' gr where- gAttrs = []- cID = const Nothing- cAttrs = const gAttrs- noAttrs = const []---- | 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)- -> gr (AttributeNode a) (AttributeEdge b)-dotizeClusterGraph' g = dotizeClusterGraph (isDirected g) g+ params' = params { fmtCluster = const []+ , fmtNode = const []+ , fmtEdge = const []+ } -- ----------------------------------------------------------------------------- @@ -353,17 +310,17 @@ -} -- | Used to augment an edge label with a unique identifier.-data EdgeID b = EID { eID :: String- , eLbl :: b- }- deriving (Eq, Ord, Show)+data EdgeID el = EID { eID :: String+ , eLbl :: el+ }+ 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 :: (Graph gr) => gr nl el -> gr nl (EdgeID el) addEdgeIDs g = mkGraph ns es' where ns = labNodes g@@ -373,18 +330,18 @@ -- | 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 :: (LEdge el -> Attributes)+ -> (LEdge (EdgeID el) -> 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 :: LEdge (EdgeID el) -> LEdge el stripID (f,t,eid) = (f,t, eLbl eid) -- | Pass the 'DotRepr' 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 :: (Graph gr, DotRepr dg Node) => Bool -> gr nl (EdgeID el)+ -> dg Node -> IO (gr (AttributeNode nl) (AttributeEdge el)) dotAttributes isDir gr dot = liftM (augmentGraph gr . parseDG . fromDotResult) $ graphvizWithHandle command dot DotOutput hGetContents'@@ -401,14 +358,14 @@ -- 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 :: (Graph gr, DotRepr dg Node) => gr nl (EdgeID el)+ -> dg Node -> gr (AttributeNode nl) (AttributeEdge el) 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))+ 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@@ -459,10 +416,10 @@ canonicalise = liftM parseDotGraph . prettyPrint -- | Quickly visualise a graph using the 'Xlib' 'GraphvizCanvas'.-preview :: (Ord b, Graph gr) => gr a b -> IO ()+preview :: (Ord el, Graph gr) => gr nl el -> IO () preview g = ign $ forkIO (ign $ runGraphvizCanvas' dg Xlib) where- dg = graphToDot' g [] (const []) (const [])+ dg = setDirectedness graphToDot nonClusteredParams g ign = (>> return ()) -- | Used for obtaining results from 'graphvizWithHandle', etc. when
− Data/GraphViz/AttributeGenerator.hs
@@ -1,512 +0,0 @@-{- |- Module : Data.GraphViz.AttributeGenerator- Description : Definition of the Graphviz attributes.- Copyright : (c) Ivan Lazar Miljenovic- License : 3-Clause BSD-style- Maintainer : Ivan.Miljenovic@gmail.com-- This module is a stand-alone that generates the correct code for- Data.GraphViz.Attributes.- -}-module Data.GraphViz.AttributeGenerator where--import Text.PrettyPrint-import Data.List(transpose)-import Data.Maybe(catMaybes, isJust, fromJust)-import Control.Monad(liftM)-import System.Environment(getArgs)--type Code = Doc---- If any args are passed in, then generate the Arbitrary instance--- instead of the definition.-main :: IO ()-main = do args <- getArgs- let f = if null args- then genCode- else genArbitrary- print $ f att- where- att = AS { tpNm = text "Attribute"- , atts = attributes- }--genCode :: Atts -> Doc-genCode att = vsep $ map ($att) cds- where- cds = [ createDefn- , createAlias- , showInstance- , parseInstance- , usedByFunc "Graphs" forGraphs- , usedByFunc "Clusters" forClusters- , usedByFunc "SubGraphs" forSubGraphs- , usedByFunc "Nodes" forNodes- , usedByFunc "Edges" forEdges- ]--genArbitrary :: Atts -> Doc-genArbitrary = arbitraryInstance---- --------------------------------------------------------------------------------- Defining data structures--data Atts = AS { tpNm :: Code- , atts :: [Attribute]- }--data Attribute = A { cnst :: Code- , name :: Code- , parseNames :: [Code]- , valtype :: VType- , parseDef :: Maybe Code- , forGraphs :: Bool- , forClusters :: Bool- , forSubGraphs :: Bool- , forNodes :: Bool- , forEdges :: Bool- , comment :: Doc- }--makeAttr :: Constructor -> [Name] -> UsedBy -> VType- -> Maybe Default -- Used when parsing the field- -> Maybe Default -> Maybe Minimum -> Maybe Comment- -> Attribute-makeAttr c ns u v df d m cm = A { cnst = text c- , name = head ns'- , parseNames = ns'- , valtype = v -- just in case need to do fancy- -- stuff- , parseDef = liftM text df- , forGraphs = isFor 'G'- , forClusters = isFor 'C' || forSG- , forSubGraphs = forSG- , forNodes = isFor 'N'- , forEdges = isFor 'E'- , comment = cm'- }- where- ns' = map text ns- isFor f = f `elem` u- forSG = isFor 'S'- df' = if v == Bl then Just "'True'" else fmap ( \ t -> '\'' : t ++ "'") df- mDoc (f,fc) = f <> colon <+> text fc- addF f = fmap (\ dc -> (wrap (char '/') (text f), dc))- cm' = hsep- . punctuate semi- . map mDoc- $ catMaybes [ addF "Valid for" (Just u)- , addF "Default" d- , addF "Parsing Default" df'- , addF "Minimum" m- , addF "Notes" cm- ]--type Constructor = String-type Name = String-type UsedBy = String -- should only contain subset of "ENGCS"-type Default = String-type Minimum = String-type Comment = String--data VType = Dbl- | Integ- | Strng- | EStrng- | Bl- | Cust String- deriving (Eq, Ord, Show, Read)--vtype :: VType -> Doc-vtype Dbl = text "Double"-vtype Integ = text "Int"-vtype Strng = text "String"-vtype EStrng = text "EscString"-vtype Bl = text "Bool"-vtype (Cust t) = text t--vtypeCode :: Attribute -> Code-vtypeCode = vtype . valtype---- -------------------------------------------------------------------------------createDefn :: Atts -> Code-createDefn att = hdr $+$ constructors $+$ derivs- where- hdr = text "data" <+> tpNm att- constructors = nest tab- . asRows- . firstOthers equals (char '|')- . (++ [defUnknown])- . map createDefn- $ atts att- derivs = nest (tab + 2) $ text "deriving (Eq, Ord, Show, Read)"- createDefn a = [cnst a <+> vtypeCode a- , if isEmpty cm- then empty- else text "-- ^" <+> cm- ]- where- cm = comment a- defUnknown = [ unknownAttr <+> vtype Strng <+> vtype Strng- , text "-- ^ /Valid for/: Assumed valid for all; the fields are 'Attribute' name and value respectively."- ]--createAlias :: Atts -> Code-createAlias att = text "type"- <+> tp <> char 's'- <+> equals- <+> brackets tp- where- tp = tpNm att--showInstance :: Atts -> Code-showInstance att = hdr $+$ insts'- where- hdr = text "instance" <+> text "PrintDot" <+> tpNm att <+> text "where"- var = char 'v'- sFunc = text "unqtDot"- cnct = text "<>"- insts = asRows- . (++ [unknownInst])- . map mkInstance- $ atts att- mkInstance a = [ sFunc <+> parens (cnst a <+> var)- , equals <+> text "printField" <+> doubleQuotes (name a)- <+> var- ]- unknownInst = [ sFunc <+> parens (unknownAttr <+> char 'a' <+> var)- , equals <+> text "toDot" <+> char 'a'- <+> text "<> equals <>" <+> text "toDot" <+> var- ]- insts' = nest tab- $ vsep [ insts- , text "listToDot" <+> equals <+> text "unqtListToDot"- ]--parseInstance :: Atts -> Code-parseInstance att = hdr $+$ nest tab fns- where- hdr = text "instance" <+> text "ParseDot" <+> tpNm att <+> text "where"- fn = pFunc <+> equals <+> text "oneOf" <+> ops- fns = vsep [ fn- , text "parse" <+> equals <+> pFunc- , text "parseList" <+> equals <+> text "parseUnqtList"- ]- ops = flip ($$) rbrack- . asRows- . firstOthers lbrack comma- . map return- . (++ [pUnknown])- . map parseAttr- $ atts att- pFunc = text "parseUnqt"- pType b a- | valtype a == Bl = pFld <> text "Bool" <+> cnst a- | isJust $ parseDef a = pFld <> text "Def" <+> cnst a <+> fromJust (parseDef a)- | otherwise = pFld <+> cnst a- where- pFld = text "parseField" <> if b then char 's' else empty-- parseAttr a = case map doubleQuotes $ parseNames a of- [n] -> pType False a <+> n- ns -> pType True a <+> docList ns- pUnknown = text "liftM2" <+> unknownAttr <+> text "stringBlock"- <+> parens (text "parseEq >> parse")--arbitraryInstance :: Atts -> Code-arbitraryInstance att = vsep [hdr $+$ fns, kFunc]- where- hdr = text "instance" <+> text "Arbitrary" <+> tpNm att <+> text "where"- fns = nest tab $ vsep [aFn, sFn]- aFn = aFunc <+> equals <+> text "oneof" <+> ops- ops = flip ($$) rbrack- . asRows- . firstOthers lbrack comma- . (++ [[aUnknown]])- . map (return . arbAttr)- $ atts att- aFunc = text "arbitrary"- arbAttr a = text "liftM" <+> cnst a <+> arbitraryFor' a- sFn = asRows- . (++ [sUnknown])- . map shrinkAttr- $ atts att- sFunc = text "shrink"- var = char 'v'- shrinkAttr a = [ sFunc <+> parens (cnst a <+> var)- , equals <+> text "map" <+> cnst a- , dollar <+> shrinkFor (valtype a) <+> var- ]- aUnknown = text "liftM2" <+> unknownAttr- <+> parens (text "suchThat" <+> text "arbIDString" <+> kFuncNm)- <+> arbitraryFor Strng- sUnknown = [ sFunc <+> parens (unknownAttr <+> char 'a' <+> var)- , equals <+> text "liftM2" <+> unknownAttr- , parens (text "liftM" <+> parens (text "filter" <+> kFuncNm)- <+> shrinkFor Strng <+> char 'a')- <+> parens (shrinkFor Strng <+> var)- ]-- kFunc = asRows (kTpSig : kTrs ++ [kOth])- kFuncNm = text "validUnknown"- kTpSig = [ kFuncNm- , colon <> colon <+> text "String -> Bool"- ]- kTrs = map kTr . concatMap parseNames $ atts att- kTr pn = [ kFuncNm <+> doubleQuotes pn- , equals <+> text "False"- ]- kOth = [ kFuncNm <+> char '_'- , equals <+> text "True"- ]--arbitraryFor :: VType -> Doc-arbitraryFor Strng = text "arbString"-arbitraryFor EStrng = text "arbString"-arbitraryFor (Cust ('[':_)) = text "arbList"-arbitraryFor _ = text "arbitrary"--arbitraryFor' :: Attribute -> Doc-arbitraryFor' = arbitraryFor . valtype--shrinkFor :: VType -> Doc-shrinkFor (Cust ('[':_)) = text "nonEmptyShrinks"-shrinkFor Strng = text "shrinkString"-shrinkFor EStrng = text "shrinkString"-shrinkFor _ = text "shrink"--usedByFunc :: String -> (Attribute -> Bool) -> Atts -> Code-usedByFunc nm p att = cmnt $$ asRows (tpSig : trs ++ [fls])- where- nm' = text nm- dt = tpNm att- cmnt = text "-- | Determine if this" <+> dt- <+> text "is valid for use with" <+> nm' <> dot- tpSig = [ fn- , colon <> colon- <+> dt <+> text "->" <+> text "Bool"- ]- fn = text "usedBy" <> nm'- tr = text "True"- trs = map aTr as' ++ [unknownATr]- fl = text "False"- fls = [ fn <+> char '_'- , equals <+> fl- ]- as' = filter p $ atts att- aTr a = [ fn <+> cnst a <> braces empty- , equals <+> tr- ]- unknownATr = [ fn <+> unknownAttr <> braces empty- , equals <+> tr- ]----- --------------------------------------------------------------------------------- Helper functions---- Size of a tab character-tab :: Int-tab = 4--firstOthers :: Doc -> Doc -> [[Doc]] -> [[Doc]]-firstOthers _ _ [] = []-firstOthers f o (d:ds) = (f : d) : map ((:) o) ds--wrap :: Doc -> Doc -> Doc-wrap w d = w <> d <> w--vsep :: [Doc] -> Doc-vsep = vcat . punctuate newline- where- newline = char '\n'--asRows :: [[Doc]] -> Doc-asRows as = vcat $ map padR asL- where- asL = map (map (\d -> (d, docLen d))) as- cWidths = map (maximum . map snd) $ transpose asL- shiftLen rls = let (rs,ls) = unzip rls- in zip rs (0:ls)- padR = hsep . zipWith append (0 : cWidths) . shiftLen- append l' (d,l) = hcat (repl (l' - l) space) <> d- repl n xs | n <= 0 = []- | otherwise = replicate n xs---- A really hacky thing to do, but oh well...--- Don't use this for multi-line Docs!-docLen :: Doc -> Int-docLen = length . render--docList :: [Doc] -> Doc-docList = brackets . hsep . punctuate comma--dot :: Doc-dot = char '.'---- --------------------------------------------------------------------------------- The actual attributes--attributes :: [Attribute]-attributes = [ makeAttr "Damping" ["Damping"] "G" Dbl Nothing (Just "@0.99@") (Just "@0.0@") (Just "neato only")- , makeAttr "K" ["K"] "GC" Dbl Nothing (Just "@0.3@") (Just "@0@") (Just "sfdp, fdp only")- , makeAttr "URL" ["URL", "href"] "ENGC" EStrng Nothing (Just "none") Nothing (Just "svg, postscript, map only")- , makeAttr "ArrowHead" ["arrowhead"] "E" (Cust "ArrowType") Nothing (Just "@'normal'@") Nothing Nothing- , makeAttr "ArrowSize" ["arrowsize"] "E" Dbl Nothing (Just "@1.0@") (Just "@0.0@") Nothing- , makeAttr "ArrowTail" ["arrowtail"] "E" (Cust "ArrowType") Nothing (Just "@'normal'@") Nothing Nothing- , makeAttr "Aspect" ["aspect"] "G" (Cust "AspectType") Nothing Nothing Nothing (Just "dot only")- , makeAttr "Bb" ["bb"] "G" (Cust "Rect") Nothing Nothing Nothing (Just "write only")- , makeAttr "BgColor" ["bgcolor"] "GC" (Cust "Color") Nothing (Just "X11Color 'Transparent'") Nothing Nothing- , makeAttr "Center" ["center"] "G" Bl (Just "True") (Just "@'False'@") Nothing Nothing- , makeAttr "Charset" ["charset"] "G" Strng Nothing (Just "@\\\"UTF-8\\\"@") Nothing Nothing- , makeAttr "ClusterRank" ["clusterrank"] "G" (Cust "ClusterMode") Nothing (Just "@'Local'@") Nothing (Just "dot only")- , makeAttr "ColorScheme" ["colorscheme"] "ENCG" (Cust "ColorScheme") Nothing (Just "@'X11'@") Nothing Nothing- , makeAttr "Color" ["color"] "ENC" (Cust "[Color]") Nothing (Just "@X11Color 'Black'@") Nothing Nothing- , makeAttr "Comment" ["comment"] "ENG" Strng Nothing (Just "@\\\"\\\"@") Nothing Nothing- , makeAttr "Compound" ["compound"] "G" Bl (Just "True") (Just "@'False'@") Nothing (Just "dot only")- , makeAttr "Concentrate" ["concentrate"] "G" Bl (Just "True") (Just "@'False'@") Nothing Nothing- , makeAttr "Constraint" ["constraint"] "E" Bl (Just "True") (Just "@'True'@") Nothing (Just "dot only")- , makeAttr "Decorate" ["decorate"] "E" Bl (Just "True") (Just "@'False'@") Nothing Nothing- , makeAttr "DefaultDist" ["defaultdist"] "G" Dbl Nothing (Just "@1+(avg. len)*sqrt(|V|)@") (Just "@epsilon@") (Just "neato only")- , makeAttr "Dimen" ["dimen"] "G" Integ Nothing (Just "@2@") (Just "@2@") (Just "sfdp, fdp, neato only")- , makeAttr "Dim" ["dim"] "G" Integ Nothing (Just "@2@") (Just "@2@") (Just "sfdp, fdp, neato only")- , makeAttr "Dir" ["dir"] "E" (Cust "DirType") Nothing (Just "@'Forward'@ (directed), @'NoDir'@ (undirected)") Nothing Nothing- , makeAttr "DirEdgeConstraints" ["diredgeconstraints"] "G" (Cust "DEConstraints") (Just "EdgeConstraints") (Just "@'NoConstraints'@") Nothing (Just "neato only")- , makeAttr "Distortion" ["distortion"] "N" Dbl Nothing (Just "@0.0@") (Just "@-100.0@") Nothing- , makeAttr "DPI" ["dpi", "resolution"] "G" Dbl Nothing (Just "@96.0@, @0.0@") Nothing (Just "svg, bitmap output only; \\\"resolution\\\" is a synonym")- , makeAttr "EdgeURL" ["edgeURL", "edgehref"] "E" EStrng Nothing (Just "@\\\"\\\"@") Nothing (Just "svg, map only")- , makeAttr "EdgeTarget" ["edgetarget"] "E" EStrng Nothing (Just "none") Nothing (Just "svg, map only")- , makeAttr "EdgeTooltip" ["edgetooltip"] "E" EStrng Nothing (Just "@\\\"\\\"@") Nothing (Just "svg, cmap only")- , makeAttr "Epsilon" ["epsilon"] "G" Dbl Nothing (Just "@.0001 * # nodes@ (@mode == 'KK'@), @.0001@ (@mode == 'Major'@)") Nothing (Just "neato only")- , makeAttr "ESep" ["esep"] "G" (Cust "DPoint") Nothing (Just "@+3@") Nothing (Just "not dot")- , makeAttr "FillColor" ["fillcolor"] "NC" (Cust "Color") Nothing (Just "@X11Color 'LightGray'@ (nodes), @X11Color 'Black'@ (clusters)") Nothing Nothing- , makeAttr "FixedSize" ["fixedsize"] "N" Bl (Just "True") (Just "@'False'@") Nothing Nothing- , makeAttr "FontColor" ["fontcolor"] "ENGC" (Cust "Color") Nothing (Just "@X11Color 'Black'@") Nothing Nothing- , makeAttr "FontName" ["fontname"] "ENGC" Strng Nothing (Just "@\\\"Times-Roman\\\"@") Nothing Nothing- , makeAttr "FontNames" ["fontnames"] "G" Strng Nothing (Just "@\\\"\\\"@") Nothing (Just "svg only")- , makeAttr "FontPath" ["fontpath"] "G" Strng Nothing (Just "system-dependent") Nothing Nothing- , makeAttr "FontSize" ["fontsize"] "ENGC" Dbl Nothing (Just "@14.0@") (Just "@1.0@") Nothing- , makeAttr "Group" ["group"] "N" Strng Nothing (Just "@\\\"\\\"@") Nothing (Just "dot only")- , makeAttr "HeadURL" ["headURL", "headhref"] "E" EStrng Nothing (Just "@\\\"\\\"@") Nothing (Just "svg, map only")- , makeAttr "HeadClip" ["headclip"] "E" Bl (Just "True") (Just "@'True'@") Nothing Nothing- , makeAttr "HeadLabel" ["headlabel"] "E" (Cust "Label") Nothing (Just "@\\\"\\\"@") Nothing Nothing- , makeAttr "HeadPort" ["headport"] "E" (Cust "PortPos") Nothing (Just "@'PP' 'CenterPoint'@") Nothing Nothing- , makeAttr "HeadTarget" ["headtarget"] "E" EStrng Nothing (Just "none") Nothing (Just "svg, map only")- , makeAttr "HeadTooltip" ["headtooltip"] "E" EStrng Nothing (Just "@\\\"\\\"@") Nothing (Just "svg, cmap only")- , makeAttr "Height" ["height"] "N" Dbl Nothing (Just "@0.5@") (Just "@0.02@") Nothing- , makeAttr "ID" ["id"] "GNE" (Cust "Label") Nothing (Just "@\\\"\\\"@") Nothing (Just "svg, postscript, map only")- , makeAttr "Image" ["image"] "N" Strng Nothing (Just "@\\\"\\\"@") Nothing Nothing- , makeAttr "ImageScale" ["imagescale"] "N" (Cust "ScaleType") (Just "UniformScale") (Just "@'NoScale'@") Nothing Nothing- , makeAttr "LabelURL" ["labelURL", "labelhref"] "E" EStrng Nothing (Just "@\\\"\\\"@") Nothing (Just "svg, map only")- , makeAttr "LabelAngle" ["labelangle"] "E" Dbl Nothing (Just "@-25.0@") (Just "@-180.0@") Nothing- , makeAttr "LabelDistance" ["labeldistance"] "E" Dbl Nothing (Just "@1.0@") (Just "@0.0@") Nothing- , makeAttr "LabelFloat" ["labelfloat"] "E" Bl (Just "True") (Just "@'False'@") Nothing Nothing- , makeAttr "LabelFontColor" ["labelfontcolor"] "E" (Cust "Color") Nothing (Just "@X11Color 'Black'@") Nothing Nothing- , makeAttr "LabelFontName" ["labelfontname"] "E" Strng Nothing (Just "@\\\"Times-Roman\\\"@") Nothing Nothing- , makeAttr "LabelFontSize" ["labelfontsize"] "E" Dbl Nothing (Just "@14.0@") (Just "@1.0@") Nothing- , makeAttr "LabelJust" ["labeljust"] "GC" (Cust "Justification") Nothing (Just "@'JCenter'@") Nothing Nothing- , makeAttr "LabelLoc" ["labelloc"] "GCN" (Cust "VerticalPlacement") Nothing (Just "@'VTop'@ (clusters), @'VBottom'@ (root graphs), @'VCenter'@ (nodes)") Nothing Nothing- , makeAttr "LabelTarget" ["labeltarget"] "E" EStrng Nothing (Just "none") Nothing (Just "svg, map only")- , makeAttr "LabelTooltip" ["labeltooltip"] "E" EStrng Nothing (Just "@\\\"\\\"@") Nothing (Just "svg, cmap only")- , makeAttr "Label" ["label"] "ENGC" (Cust "Label") Nothing (Just "@'StrLabel' \\\"\\N\\\"@ (nodes), @'StrLabel' \\\"\\\"@ (otherwise)") Nothing Nothing- , makeAttr "Landscape" ["landscape"] "G" Bl (Just "True") (Just "@'False'@") Nothing Nothing- , makeAttr "LayerSep" ["layersep"] "G" Strng Nothing (Just "@\\\" :\\t\\\"@") Nothing Nothing- , makeAttr "Layers" ["layers"] "G" (Cust "LayerList") Nothing (Just "@\\\"\\\"@") Nothing Nothing- , makeAttr "Layer" ["layer"] "EN" (Cust "LayerRange") Nothing (Just "@\\\"\\\"@") Nothing Nothing- , makeAttr "Layout" ["layout"] "G" Strng Nothing (Just "@\\\"\\\"@") Nothing Nothing- , makeAttr "Len" ["len"] "E" Dbl Nothing (Just "@1.0@ (neato), @0.3@ (fdp)") Nothing (Just "fdp, neato only")- , makeAttr "LevelsGap" ["levelsgap"] "G" Dbl Nothing (Just "@0.0@") Nothing (Just "neato only")- , makeAttr "Levels" ["levels"] "G" Integ Nothing (Just "@MAXINT@") (Just "@0@") (Just "sfdp only")- , makeAttr "LHead" ["lhead"] "E" Strng Nothing (Just "@\\\"\\\"@") Nothing (Just "dot only")- , makeAttr "LPos" ["lp"] "EGC" (Cust "Point") Nothing Nothing Nothing (Just "write only")- , makeAttr "LTail" ["ltail"] "E" Strng Nothing (Just "@\\\"\\\"@") Nothing (Just "dot only")- , makeAttr "Margin" ["margin"] "NG" (Cust "DPoint") Nothing (Just "device-dependent") Nothing Nothing- , makeAttr "MaxIter" ["maxiter"] "G" Integ Nothing (Just "@100 * # nodes@ (@mode == 'KK'@), @200@ (@mode == 'Major'@), @600@ (fdp)") Nothing (Just "fdp, neato only")- , makeAttr "MCLimit" ["mclimit"] "G" Dbl Nothing (Just "@1.0@") Nothing (Just "dot only")- , makeAttr "MinDist" ["mindist"] "G" Dbl Nothing (Just "@1.0@") (Just "@0.0@") (Just "circo only")- , makeAttr "MinLen" ["minlen"] "E" Integ Nothing (Just "@1@") (Just "@0@") (Just "dot only")- , makeAttr "Model" ["model"] "G" (Cust "Model") Nothing (Just "@'ShortPath'@") Nothing (Just "neato only")- , makeAttr "Mode" ["mode"] "G" (Cust "ModeType") Nothing (Just "@'Major'@") Nothing (Just "neato only")- , makeAttr "Mosek" ["mosek"] "G" Bl (Just "True") (Just "@'False'@") Nothing (Just "neato only; requires the Mosek software")- , makeAttr "NodeSep" ["nodesep"] "G" Dbl Nothing (Just "@0.25@") (Just "@0.02@") (Just "dot only")- , makeAttr "NoJustify" ["nojustify"] "GCNE" Bl (Just "True") (Just "@'False'@") Nothing Nothing- , makeAttr "Normalize" ["normalize"] "G" Bl (Just "True") (Just "@'False'@") Nothing (Just "not dot")- , makeAttr "Nslimit1" ["nslimit1"] "G" Dbl Nothing Nothing Nothing (Just "dot only")- , makeAttr "Nslimit" ["nslimit"] "G" Dbl Nothing Nothing Nothing (Just "dot only")- , makeAttr "Ordering" ["ordering"] "G" Strng Nothing (Just "@\\\"\\\"@") Nothing (Just "dot only")- , makeAttr "Orientation" ["orientation"] "N" Dbl Nothing (Just "@0.0@") (Just "@360.0@") Nothing- , makeAttr "OutputOrder" ["outputorder"] "G" (Cust "OutputMode") Nothing (Just "@'BreadthFirst'@") Nothing Nothing- , makeAttr "OverlapScaling" ["overlap_scaling"] "G" Dbl Nothing (Just "@-4@") (Just "@-1.0e10@") (Just "prism only")- , makeAttr "Overlap" ["overlap"] "G" (Cust "Overlap") (Just "KeepOverlaps") (Just "@'KeepOverlaps'@") Nothing (Just "not dot")- , makeAttr "PackMode" ["packmode"] "G" (Cust "PackMode") Nothing (Just "@'PackNode'@") Nothing (Just "not dot")- , makeAttr "Pack" ["pack"] "G" (Cust "Pack") (Just "DoPack") (Just "@'False'@") Nothing (Just "not dot")- , makeAttr "Pad" ["pad"] "G" (Cust "DPoint") Nothing (Just "@'DVal' 0.0555@ (4 points)") Nothing Nothing- , makeAttr "PageDir" ["pagedir"] "G" (Cust "PageDir") Nothing (Just "@'BL'@") Nothing Nothing- , makeAttr "Page" ["page"] "G" (Cust "Point") Nothing Nothing Nothing Nothing- , makeAttr "PenColor" ["pencolor"] "C" (Cust "Color") Nothing (Just "@X11Color 'Black'@") Nothing Nothing- , makeAttr "PenWidth" ["penwidth"] "CNE" Dbl Nothing (Just "@1.0@") (Just "@0.0@") Nothing- , makeAttr "Peripheries" ["peripheries"] "NC" Integ Nothing (Just "shape default (nodes), @1@ (clusters)") (Just "0") Nothing- , makeAttr "Pin" ["pin"] "N" Bl (Just "True") (Just "@'False'@") Nothing (Just "fdp, neato only")- , makeAttr "Pos" ["pos"] "EN" (Cust "Pos") Nothing Nothing Nothing Nothing- , makeAttr "QuadTree" ["quadtree"] "G" (Cust "QuadType") (Just "NormalQT") (Just "@'NormalQT'@") Nothing (Just "sfdp only")- , makeAttr "Quantum" ["quantum"] "G" Dbl Nothing (Just "@0.0@") (Just "@0.0@") Nothing- , makeAttr "RankDir" ["rankdir"] "G" (Cust "RankDir") Nothing (Just "@'TB'@") Nothing (Just "dot only")- , makeAttr "RankSep" ["ranksep"] "G" (Cust "[Double]") Nothing (Just "@0.5@ (dot), @1.0@ (twopi)") (Just "0.02") (Just "twopi, dot only")- , makeAttr "Rank" ["rank"] "S" (Cust "RankType") Nothing Nothing Nothing (Just "dot only")- , makeAttr "Ratio" ["ratio"] "G" (Cust "Ratios") Nothing Nothing Nothing Nothing- , makeAttr "Rects" ["rects"] "N" (Cust "Rect") Nothing Nothing Nothing (Just "write only")- , makeAttr "Regular" ["regular"] "N" Bl (Just "True") (Just "@'False'@") Nothing Nothing- , makeAttr "ReMinCross" ["remincross"] "G" Bl (Just "True") (Just "@'False'@") Nothing (Just "dot only")- , makeAttr "RepulsiveForce" ["repulsiveforce"] "G" Dbl Nothing (Just "@1.0@") (Just "@0.0@") (Just "sfdp only")- , makeAttr "Root" ["root"] "GN" (Cust "Root") (Just "IsCentral") (Just "@'NodeName' \\\"\\\"@ (graphs), @'NotCentral'@ (nodes)") Nothing (Just "circo, twopi only")- , makeAttr "Rotate" ["rotate"] "G" Integ Nothing (Just "@0@") Nothing Nothing- , makeAttr "SameHead" ["samehead"] "E" Strng Nothing (Just "@\\\"\\\"@") Nothing (Just "dot only")- , makeAttr "SameTail" ["sametail"] "E" Strng Nothing (Just "@\\\"\\\"@") Nothing (Just "dot only")- , makeAttr "SamplePoints" ["samplepoints"] "N" Integ Nothing (Just "@8@ (output), @20@ (overlap and image maps)") Nothing Nothing- , makeAttr "SearchSize" ["searchsize"] "G" Integ Nothing (Just "@30@") Nothing (Just "dot only")- , makeAttr "Sep" ["sep"] "G" (Cust "DPoint") Nothing (Just "@+4@") Nothing (Just "not dot")- , makeAttr "ShapeFile" ["shapefile"] "N" Strng Nothing (Just "@\\\"\\\"@") Nothing Nothing- , makeAttr "Shape" ["shape"] "N" (Cust "Shape") Nothing (Just "@'Ellipse'@") Nothing Nothing- , makeAttr "ShowBoxes" ["showboxes"] "ENG" Integ Nothing (Just "@0@") (Just "@0@") (Just "dot only")- , makeAttr "Sides" ["sides"] "N" Integ Nothing (Just "@4@") (Just "@0@") Nothing- , makeAttr "Size" ["size"] "G" (Cust "Point") Nothing Nothing Nothing Nothing- , makeAttr "Skew" ["skew"] "N" Dbl Nothing (Just "@0.0@") (Just "@-100.0@") Nothing- , makeAttr "Smoothing" ["smoothing"] "G" (Cust "SmoothType") Nothing (Just "@'NoSmooth'@") Nothing (Just "sfdp only")- , makeAttr "SortV" ["sortv"] "GCN" Integ Nothing (Just "@0@") (Just "@0@") Nothing- , makeAttr "Splines" ["splines"] "G" (Cust "EdgeType") (Just "SplineEdges") Nothing Nothing Nothing- , makeAttr "Start" ["start"] "G" (Cust "StartType") Nothing (Just "@\\\"\\\"@") Nothing (Just "fdp, neato only")- , makeAttr "StyleSheet" ["stylesheet"] "G" Strng Nothing (Just "@\\\"\\\"@") Nothing (Just "svg only")- , makeAttr "Style" ["style"] "ENC" (Cust "[StyleItem]") Nothing Nothing Nothing Nothing- , makeAttr "TailURL" ["tailURL", "tailhref"] "E" EStrng Nothing (Just "@\\\"\\\"@") Nothing (Just "svg, map only")- , makeAttr "TailClip" ["tailclip"] "E" Bl (Just "True") (Just "@'True'@") Nothing Nothing- , makeAttr "TailLabel" ["taillabel"] "E" (Cust "Label") Nothing (Just "@\\\"\\\"@") Nothing Nothing- , makeAttr "TailPort" ["tailport"] "E" (Cust "PortPos") Nothing (Just "center") Nothing Nothing- , makeAttr "TailTarget" ["tailtarget"] "E" EStrng Nothing (Just "none") Nothing (Just "svg, map only")- , makeAttr "TailTooltip" ["tailtooltip"] "E" EStrng Nothing (Just "@\\\"\\\"@") Nothing (Just "svg, cmap only")- , makeAttr "Target" ["target"] "ENGC" EStrng Nothing (Just "none") Nothing (Just "svg, map only")- , makeAttr "Tooltip" ["tooltip"] "NEC" EStrng Nothing (Just "@\\\"\\\"@") Nothing (Just "svg, cmap only")- , makeAttr "TrueColor" ["truecolor"] "G" Bl (Just "True") Nothing Nothing (Just "bitmap output only")- , makeAttr "Vertices" ["vertices"] "N" (Cust "[Point]") Nothing Nothing Nothing (Just "write only")- , makeAttr "ViewPort" ["viewport"] "G" (Cust "ViewPort") Nothing (Just "none") Nothing Nothing- , makeAttr "VoroMargin" ["voro_margin"] "G" Dbl Nothing (Just "@0.05@") (Just "@0.0@") (Just "not dot")- , makeAttr "Weight" ["weight"] "E" Dbl Nothing (Just "@1.0@") (Just "@0@ (dot), @1@ (neato,fdp,sfdp)") Nothing- , makeAttr "Width" ["width"] "N" Dbl Nothing (Just "@0.75@") (Just "@0.01@") Nothing- , makeAttr "Z" ["z"] "N" Dbl Nothing (Just "@0.0@") (Just "@-MAXFLOAT@, @-1000@") Nothing- ]--unknownAttr :: Doc-unknownAttr = text "UnknownAttribute"--attrs = take 10 $ drop 5 attributes--attrs' = AS (text "Attribute") attrs--bool :: a -> a -> Bool -> a-bool f t b = if b then t else f--dollar :: Doc-dollar = char '$'
Data/GraphViz/Attributes.hs view
@@ -72,6 +72,7 @@ ( -- * The actual /Dot/ attributes. Attribute(..) , Attributes+ , sameAttribute -- ** Validity functions on @Attribute@ values. , usedByGraphs , usedBySubGraphs@@ -173,7 +174,7 @@ import Data.Char(toLower) import Data.Maybe(isJust)-import Control.Arrow(first)+import Data.Word(Word16) import Control.Monad(liftM, liftM2) -- -----------------------------------------------------------------------------@@ -339,7 +340,7 @@ | Size Point -- ^ /Valid for/: G | Skew Double -- ^ /Valid for/: N; /Default/: @0.0@; /Minimum/: @-100.0@ | Smoothing SmoothType -- ^ /Valid for/: G; /Default/: @'NoSmooth'@; /Notes/: sfdp only- | SortV Int -- ^ /Valid for/: GCN; /Default/: @0@; /Minimum/: @0@+ | SortV Word16 -- ^ /Valid for/: GCN; /Default/: @0@; /Minimum/: @0@ | Splines EdgeType -- ^ /Valid for/: G; /Parsing Default/: 'SplineEdges' | Start StartType -- ^ /Valid for/: G; /Default/: @\"\"@; /Notes/: fdp, neato only | StyleSheet String -- ^ /Valid for/: G; /Default/: @\"\"@; /Notes/: svg only@@ -665,7 +666,7 @@ parseList = parseUnqtList --- | Determine if this Attribute is valid for use with Graphs.+-- | Determine if this 'Attribute' is valid for use with Graphs. usedByGraphs :: Attribute -> Bool usedByGraphs Damping{} = True usedByGraphs K{} = True@@ -749,7 +750,7 @@ usedByGraphs UnknownAttribute{} = True usedByGraphs _ = False --- | Determine if this Attribute is valid for use with Clusters.+-- | Determine if this 'Attribute' is valid for use with Clusters. usedByClusters :: Attribute -> Bool usedByClusters K{} = True usedByClusters URL{} = True@@ -776,13 +777,13 @@ usedByClusters UnknownAttribute{} = True usedByClusters _ = False --- | Determine if this Attribute is valid for use with SubGraphs.+-- | Determine if this 'Attribute' is valid for use with SubGraphs. usedBySubGraphs :: Attribute -> Bool usedBySubGraphs Rank{} = True usedBySubGraphs UnknownAttribute{} = True usedBySubGraphs _ = False --- | Determine if this Attribute is valid for use with Nodes.+-- | Determine if this 'Attribute' is valid for use with Nodes. usedByNodes :: Attribute -> Bool usedByNodes URL{} = True usedByNodes ColorScheme{} = True@@ -828,7 +829,7 @@ usedByNodes UnknownAttribute{} = True usedByNodes _ = False --- | Determine if this Attribute is valid for use with Edges.+-- | Determine if this 'Attribute' is valid for use with Edges. usedByEdges :: Attribute -> Bool usedByEdges URL{} = True usedByEdges ArrowHead{} = True@@ -887,6 +888,155 @@ usedByEdges Weight{} = True usedByEdges UnknownAttribute{} = True usedByEdges _ = False++-- | Determine if two 'Attributes' are the same type of 'Attribute'.+sameAttribute :: Attribute -> Attribute -> Bool+sameAttribute Damping{} Damping{} = True+sameAttribute K{} K{} = True+sameAttribute URL{} URL{} = True+sameAttribute ArrowHead{} ArrowHead{} = True+sameAttribute ArrowSize{} ArrowSize{} = True+sameAttribute ArrowTail{} ArrowTail{} = True+sameAttribute Aspect{} Aspect{} = True+sameAttribute Bb{} Bb{} = True+sameAttribute BgColor{} BgColor{} = True+sameAttribute Center{} Center{} = True+sameAttribute Charset{} Charset{} = True+sameAttribute ClusterRank{} ClusterRank{} = True+sameAttribute ColorScheme{} ColorScheme{} = True+sameAttribute Color{} Color{} = True+sameAttribute Comment{} Comment{} = True+sameAttribute Compound{} Compound{} = True+sameAttribute Concentrate{} Concentrate{} = True+sameAttribute Constraint{} Constraint{} = True+sameAttribute Decorate{} Decorate{} = True+sameAttribute DefaultDist{} DefaultDist{} = True+sameAttribute Dimen{} Dimen{} = True+sameAttribute Dim{} Dim{} = True+sameAttribute Dir{} Dir{} = True+sameAttribute DirEdgeConstraints{} DirEdgeConstraints{} = True+sameAttribute Distortion{} Distortion{} = True+sameAttribute DPI{} DPI{} = True+sameAttribute EdgeURL{} EdgeURL{} = True+sameAttribute EdgeTarget{} EdgeTarget{} = True+sameAttribute EdgeTooltip{} EdgeTooltip{} = True+sameAttribute Epsilon{} Epsilon{} = True+sameAttribute ESep{} ESep{} = True+sameAttribute FillColor{} FillColor{} = True+sameAttribute FixedSize{} FixedSize{} = True+sameAttribute FontColor{} FontColor{} = True+sameAttribute FontName{} FontName{} = True+sameAttribute FontNames{} FontNames{} = True+sameAttribute FontPath{} FontPath{} = True+sameAttribute FontSize{} FontSize{} = True+sameAttribute Group{} Group{} = True+sameAttribute HeadURL{} HeadURL{} = True+sameAttribute HeadClip{} HeadClip{} = True+sameAttribute HeadLabel{} HeadLabel{} = True+sameAttribute HeadPort{} HeadPort{} = True+sameAttribute HeadTarget{} HeadTarget{} = True+sameAttribute HeadTooltip{} HeadTooltip{} = True+sameAttribute Height{} Height{} = True+sameAttribute ID{} ID{} = True+sameAttribute Image{} Image{} = True+sameAttribute ImageScale{} ImageScale{} = True+sameAttribute LabelURL{} LabelURL{} = True+sameAttribute LabelAngle{} LabelAngle{} = True+sameAttribute LabelDistance{} LabelDistance{} = True+sameAttribute LabelFloat{} LabelFloat{} = True+sameAttribute LabelFontColor{} LabelFontColor{} = True+sameAttribute LabelFontName{} LabelFontName{} = True+sameAttribute LabelFontSize{} LabelFontSize{} = True+sameAttribute LabelJust{} LabelJust{} = True+sameAttribute LabelLoc{} LabelLoc{} = True+sameAttribute LabelTarget{} LabelTarget{} = True+sameAttribute LabelTooltip{} LabelTooltip{} = True+sameAttribute Label{} Label{} = True+sameAttribute Landscape{} Landscape{} = True+sameAttribute LayerSep{} LayerSep{} = True+sameAttribute Layers{} Layers{} = True+sameAttribute Layer{} Layer{} = True+sameAttribute Layout{} Layout{} = True+sameAttribute Len{} Len{} = True+sameAttribute LevelsGap{} LevelsGap{} = True+sameAttribute Levels{} Levels{} = True+sameAttribute LHead{} LHead{} = True+sameAttribute LPos{} LPos{} = True+sameAttribute LTail{} LTail{} = True+sameAttribute Margin{} Margin{} = True+sameAttribute MaxIter{} MaxIter{} = True+sameAttribute MCLimit{} MCLimit{} = True+sameAttribute MinDist{} MinDist{} = True+sameAttribute MinLen{} MinLen{} = True+sameAttribute Model{} Model{} = True+sameAttribute Mode{} Mode{} = True+sameAttribute Mosek{} Mosek{} = True+sameAttribute NodeSep{} NodeSep{} = True+sameAttribute NoJustify{} NoJustify{} = True+sameAttribute Normalize{} Normalize{} = True+sameAttribute Nslimit1{} Nslimit1{} = True+sameAttribute Nslimit{} Nslimit{} = True+sameAttribute Ordering{} Ordering{} = True+sameAttribute Orientation{} Orientation{} = True+sameAttribute OutputOrder{} OutputOrder{} = True+sameAttribute OverlapScaling{} OverlapScaling{} = True+sameAttribute Overlap{} Overlap{} = True+sameAttribute PackMode{} PackMode{} = True+sameAttribute Pack{} Pack{} = True+sameAttribute Pad{} Pad{} = True+sameAttribute PageDir{} PageDir{} = True+sameAttribute Page{} Page{} = True+sameAttribute PenColor{} PenColor{} = True+sameAttribute PenWidth{} PenWidth{} = True+sameAttribute Peripheries{} Peripheries{} = True+sameAttribute Pin{} Pin{} = True+sameAttribute Pos{} Pos{} = True+sameAttribute QuadTree{} QuadTree{} = True+sameAttribute Quantum{} Quantum{} = True+sameAttribute RankDir{} RankDir{} = True+sameAttribute RankSep{} RankSep{} = True+sameAttribute Rank{} Rank{} = True+sameAttribute Ratio{} Ratio{} = True+sameAttribute Rects{} Rects{} = True+sameAttribute Regular{} Regular{} = True+sameAttribute ReMinCross{} ReMinCross{} = True+sameAttribute RepulsiveForce{} RepulsiveForce{} = True+sameAttribute Root{} Root{} = True+sameAttribute Rotate{} Rotate{} = True+sameAttribute SameHead{} SameHead{} = True+sameAttribute SameTail{} SameTail{} = True+sameAttribute SamplePoints{} SamplePoints{} = True+sameAttribute SearchSize{} SearchSize{} = True+sameAttribute Sep{} Sep{} = True+sameAttribute ShapeFile{} ShapeFile{} = True+sameAttribute Shape{} Shape{} = True+sameAttribute ShowBoxes{} ShowBoxes{} = True+sameAttribute Sides{} Sides{} = True+sameAttribute Size{} Size{} = True+sameAttribute Skew{} Skew{} = True+sameAttribute Smoothing{} Smoothing{} = True+sameAttribute SortV{} SortV{} = True+sameAttribute Splines{} Splines{} = True+sameAttribute Start{} Start{} = True+sameAttribute StyleSheet{} StyleSheet{} = True+sameAttribute Style{} Style{} = True+sameAttribute TailURL{} TailURL{} = True+sameAttribute TailClip{} TailClip{} = True+sameAttribute TailLabel{} TailLabel{} = True+sameAttribute TailPort{} TailPort{} = True+sameAttribute TailTarget{} TailTarget{} = True+sameAttribute TailTooltip{} TailTooltip{} = True+sameAttribute Target{} Target{} = True+sameAttribute Tooltip{} Tooltip{} = True+sameAttribute TrueColor{} TrueColor{} = True+sameAttribute Vertices{} Vertices{} = True+sameAttribute ViewPort{} ViewPort{} = True+sameAttribute VoroMargin{} VoroMargin{} = True+sameAttribute Weight{} Weight{} = True+sameAttribute Width{} Width{} = True+sameAttribute Z{} Z{} = True+sameAttribute (UnknownAttribute a1 _) (UnknownAttribute a2 _) = a1 == a2+sameAttribute _ _ = False {- Delete to here -} -- -----------------------------------------------------------------------------@@ -1349,13 +1499,11 @@ -- ----------------------------------------------------------------------------- -data Point = Point Int Int- | PointD Double Double+data Point = Point Double Double deriving (Eq, Ord, Show, Read) instance PrintDot Point where unqtDot (Point x y) = commaDel x y- unqtDot (PointD x y) = commaDel x y toDot = doubleQuotes . unqtDot @@ -1368,16 +1516,7 @@ -- integer, second a double: if Point parsing first, then it won't -- parse the second number properly; but if PointD first then it -- will treat Int/Int as Double/Double.- parseUnqt = intDblPoint- `onFail`- liftM (uncurry Point) commaSepUnqt- `onFail`- liftM (uncurry PointD) commaSepUnqt- where- intDblPoint = liftM (uncurry PointD . first fI)- $ commaSep' parseUnqt parseStrictFloat- fI :: Int -> Double- fI = fromIntegral+ parseUnqt = liftM (uncurry Point) commaSepUnqt parse = quotedParse parseUnqt @@ -1389,7 +1528,10 @@ | RemoveOverlaps | ScaleOverlaps | ScaleXYOverlaps- | PrismOverlap (Maybe Int) -- ^ Only when sfdp is available, 'Int' is non-negative+ | PrismOverlap (Maybe Word16) -- ^ Only when sfdp is+ -- available, @'Nothing'@+ -- is equivalent to+ -- @'Just' 1000@. | CompressOverlap | VpscOverlap | IpsepOverlap -- ^ Only when @mode == 'IpSep'@
Data/GraphViz/Commands.hs view
@@ -154,7 +154,7 @@ | PlainExt -- ^ As for 'Plain', but provides port -- names on head and tail nodes when -- applicable.- | Png -- ^ Portable Network Graphvics format.+ | Png -- ^ Portable Network Graphics format. | Ps -- ^ PostScript. | Ps2 -- ^ PostScript for PDF. | Svg -- ^ Scalable Vector Graphics format.
Data/GraphViz/Parsing.hs view
@@ -166,7 +166,7 @@ instance ParseDot Char where -- Can't be a quote character.- parseUnqt = satisfy ((/=) quoteChar)+ parseUnqt = satisfy (quoteChar /=) parse = satisfy restIDString `onFail`
Data/GraphViz/PreProcessing.hs view
@@ -81,10 +81,10 @@ where start = string "/*" end = string "*/"- inner = many1 (satisfy ((/=) '*'))+ inner = many1 (satisfy ('*' /=)) `onFail` do ast <- character '*'- n <- satisfy ((/=) '/')+ n <- satisfy ('/' /=) liftM ((:) ast . (:) n) inner parseConcatStrings :: Parse String@@ -96,7 +96,7 @@ `onFail` parseSplitLine -- in case there's a split mid-quote `onFail`- liftM return (satisfy ((/=) quoteChar))+ liftM return (satisfy (quoteChar /=)) parseConcat = parseSep >> character '+' >> parseSep parseSep = many $ allWhitespace `onFail` parseUnwanted wrapQuotes str = quoteChar : str ++ [quoteChar]
Data/GraphViz/Testing.hs view
@@ -40,11 +40,12 @@ -} module Data.GraphViz.Testing ( -- * Running the test suite.- runDefaultTests+ runChosenTests , runTests , runTest -- ** The tests themselves , Test(..)+ , defaultTests , test_printParseID_Attributes , test_generalisedSameDot , test_printParseID@@ -91,19 +92,16 @@ -- ----------------------------------------------------------------------------- -runDefaultTests :: IO ()-runDefaultTests = do putStrLn msg- blankLn- runTests defaultTests- spacerLn- putStrLn successMsg+runChosenTests :: [Test] -> IO ()+runChosenTests tests = do putStrLn msg+ blankLn+ runTests tests+ spacerLn+ putStrLn successMsg where msg = "This is the test suite for the graphviz library.\n\ \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 55 minutes to run on a\n\- \2 GHz Mobile Core 2 Duo (running with a single thread)."+ \including full output of this test suite." successMsg = "All tests were successful!" @@ -112,9 +110,10 @@ -- Defining a Test structure and how to run tests. -- | Defines the test structure being used.-data Test = Test { name :: String- , desc :: String- , test :: IO Result -- ^ QuickCheck test.+data Test = Test { name :: String+ , lookupName :: String -- ^ Should be lowercase+ , desc :: String+ , test :: IO Result -- ^ QuickCheck test. } -- | Run all of the provided tests.@@ -168,14 +167,23 @@ -- , test_parsePrettyID , test_dotizeAugment , test_dotizeAugmentUniq+ , test_findAllNodes+ , test_findAllNodesG+ , test_findAllNodesE+ , test_findAllNodesEG+ , test_findAllEdges+ , test_findAllEdgesG+ , test_noGraphInfo+ , test_noGraphInfoG ] -- | Test that 'Attributes' can be printed and then parsed back. test_printParseID_Attributes :: Test test_printParseID_Attributes- = Test { name = "Printing and parsing of Attributes"- , desc = dsc- , test = quickCheckWithResult args prop+ = Test { name = "Printing and parsing of Attributes"+ , lookupName = "attributes"+ , desc = dsc+ , test = quickCheckWithResult args prop } where prop :: Attributes -> Property@@ -192,9 +200,10 @@ test_generalisedSameDot :: Test test_generalisedSameDot- = Test { name = "Printing generalised Dot code"- , desc = dsc- , test = quickCheckResult prop+ = Test { name = "Printing generalised Dot code"+ , lookupName = "makegeneralised"+ , desc = dsc+ , test = quickCheckResult prop } where prop :: DotGraph Int -> Bool@@ -205,9 +214,10 @@ test_printParseID :: Test test_printParseID- = Test { name = "Printing and Parsing DotGraphs"- , desc = dsc- , test = quickCheckResult prop+ = Test { name = "Printing and Parsing DotGraphs"+ , lookupName = "printparseid"+ , desc = dsc+ , test = quickCheckResult prop } where prop :: DotGraph Int -> Bool@@ -219,9 +229,10 @@ test_printParseGID :: Test test_printParseGID- = Test { name = "Printing and Parsing Generalised DotGraphs"- , desc = dsc- , test = quickCheckResult prop+ = Test { name = "Printing and Parsing Generalised DotGraphs"+ , lookupName = "printparseidg"+ , desc = dsc+ , test = quickCheckResult prop } where prop :: GDotGraph Int -> Bool@@ -233,9 +244,10 @@ test_preProcessingID :: Test test_preProcessingID- = Test { name = "Pre-processing Dot code"- , desc = dsc- , test = quickCheckResult prop+ = Test { name = "Pre-processing Dot code"+ , lookupName = "preprocessing"+ , desc = dsc+ , test = quickCheckResult prop } where prop :: DotGraph Int -> Bool@@ -251,9 +263,10 @@ -- | This test is not valid for use until valid DotGraphs can be generated. test_parsePrettyID :: Test test_parsePrettyID- = Test { name = "Parsing pretty-printed code"- , desc = dsc- , test = quickCheckResult prop+ = Test { name = "Parsing pretty-printed code"+ , lookupName = "parsepretty"+ , desc = dsc+ , test = quickCheckResult prop } where prop :: DotGraph Int -> Bool@@ -267,9 +280,10 @@ test_dotizeAugment :: Test test_dotizeAugment- = Test { name = "Augmenting FGL Graphs"- , desc = dsc- , test = quickCheckResult prop+ = Test { name = "Augmenting FGL Graphs"+ , lookupName = "augment"+ , desc = dsc+ , test = quickCheckResult prop } where prop :: Gr Char Double -> Bool@@ -282,9 +296,10 @@ test_dotizeAugmentUniq :: Test test_dotizeAugmentUniq- = Test { name = "Unique edges in augmented FGL Graphs"- , desc = dsc- , test = quickCheckResult prop+ = Test { name = "Unique edges in augmented FGL Graphs"+ , lookupName = "augmentuniq"+ , desc = dsc+ , test = quickCheckResult prop } where prop :: Gr Char Double -> Bool@@ -295,3 +310,122 @@ \then each edge between two nodes should have a unique position\n\ \Attribute, etc." +test_findAllNodes :: Test+test_findAllNodes+ = Test { name = "Ensure all nodes are found in a DotGraph"+ , lookupName = "findnodes"+ , desc = dsc+ , test = quickCheckResult prop+ }+ where+ prop :: Gr () () -> Bool+ prop = prop_findAllNodes++ dsc = "nodeInformation should find all nodes in a DotGraph;\n\+ \this is tested by converting an FGL graph and comparing\n\+ \the nodes it should have to those that are found."++test_findAllNodesG :: Test+test_findAllNodesG+ = Test { name = "Ensure all nodes are found in a GDotGraph"+ , lookupName = "findnodesg"+ , desc = dsc+ , test = quickCheckResult prop+ }+ where+ prop :: Gr () () -> Bool+ prop = prop_findAllNodesG++ dsc = "nodeInformation should find all nodes in a GDotGraph;\n\+ \this is tested by converting an FGL graph and comparing\n\+ \the nodes it should have to those that are found."++test_findAllNodesE :: Test+test_findAllNodesE+ = Test { name = "Ensure all nodes are found in a node-less DotGraph"+ , lookupName = "findedgelessnodes"+ , desc = dsc+ , test = quickCheckResult prop+ }+ where+ prop :: Gr () () -> Bool+ prop = prop_findAllNodesE++ dsc = "nodeInformation should find all nodes in a DotGraph,\n\+ \even if there are no explicit nodes in that graph.\n\+ \This is tested by converting an FGL graph and comparing\n\+ \the nodes it should have to those that are found."++test_findAllNodesEG :: Test+test_findAllNodesEG+ = Test { name = "Ensure all nodes are found in a node-less GDotGraph"+ , lookupName = "findedgelessnodesg"+ , desc = dsc+ , test = quickCheckResult prop+ }+ where+ prop :: Gr () () -> Bool+ prop = prop_findAllNodesEG++ dsc = "nodeInformation should find all nodes in a GDotGraph,\n\+ \even if there are no explicit nodes in that graph.\n\+ \This is tested by converting an FGL graph and comparing\n\+ \the nodes it should have to those that are found."++test_findAllEdges :: Test+test_findAllEdges+ = Test { name = "Ensure all edges are found in a DotGraph"+ , lookupName = "findedges"+ , desc = dsc+ , test = quickCheckResult prop+ }+ where+ prop :: Gr () () -> Bool+ prop = prop_findAllEdges++ dsc = "nodeInformation should find all edges in a DotGraph;\n\+ \this is tested by converting an FGL graph and comparing\n\+ \the edges it should have to those that are found."++test_findAllEdgesG :: Test+test_findAllEdgesG+ = Test { name = "Ensure all edges are found in a GDotGraph"+ , lookupName = "findedgesg"+ , desc = dsc+ , test = quickCheckResult prop+ }+ where+ prop :: Gr () () -> Bool+ prop = prop_findAllEdgesG++ dsc = "nodeInformation should find all edges in a GDotGraph;\n\+ \this is tested by converting an FGL graph and comparing\n\+ \the edges it should have to those that are found."++test_noGraphInfo :: Test+test_noGraphInfo+ = Test { name = "Plain DotGraphs should have no structural information"+ , lookupName = "nographinfo"+ , desc = dsc+ , test = quickCheckResult prop+ }+ where+ prop :: Gr () () -> Bool+ prop = prop_noGraphInfo++ dsc = "When converting a Graph to a DotGraph, there should be no\n\+ \clusters or global attributes."++test_noGraphInfoG :: Test+test_noGraphInfoG+ = Test { name = "Plain GDotGraphs should have no structural information"+ , lookupName = "nographinfog"+ , desc = dsc+ , test = quickCheckResult prop+ }+ where+ prop :: Gr () () -> Bool+ prop = prop_noGraphInfoG++ dsc = "When converting a Graph to a GDotGraph, there should be no\n\+ \clusters or global attributes."
Data/GraphViz/Testing/Instances/FGL.hs view
@@ -43,5 +43,5 @@ shrink gr = case nodes gr of -- Need to have at least 2 nodes before we delete one!- ns@(_:_:_) -> map (flip delNode gr) ns+ ns@(_:_:_) -> map (`delNode` gr) ns _ -> []
Data/GraphViz/Testing/Properties.hs view
@@ -9,8 +9,12 @@ -} module Data.GraphViz.Testing.Properties where -import Data.GraphViz(dotizeGraph', prettyPrint')-import Data.GraphViz.Types(DotRepr, DotGraph, printDotGraph)+import Data.GraphViz( dotizeGraph, graphToDot+ , setDirectedness, nonClusteredParams, prettyPrint')+import Data.GraphViz.Types( DotRepr, DotGraph(..), DotStatements(..)+ , DotNode(..), DotEdge(..), GlobalAttributes(..)+ , printDotGraph, graphNodes, graphEdges+ , graphStructureInformation) import Data.GraphViz.Types.Generalised(generaliseDotGraph) import Data.GraphViz.Printing(PrintDot(..), printIt) import Data.GraphViz.Parsing(ParseDot(..), parseIt, parseIt')@@ -19,8 +23,13 @@ import Test.QuickCheck -import Data.Graph.Inductive(DynGraph, equal, nmap, emap, labEdges)-import Data.List(nub)+import Data.Graph.Inductive( Graph, DynGraph+ , equal, nmap, emap, labEdges, nodes, edges)+import Data.List(nub, sort)+import Data.Function(on)+import qualified Data.Map as Map+import qualified Data.Set as Set+import Control.Arrow((&&&)) -- ----------------------------------------------------------------------------- -- The properties to test for@@ -38,7 +47,8 @@ -- | 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 :: (Ord n, ParseDot n, PrintDot n)+ => DotGraph n -> Bool prop_generalisedSameDot dg = printDotGraph dg == printDotGraph gdg where gdg = generaliseDotGraph dg@@ -57,16 +67,16 @@ => dg n -> Bool prop_parsePrettyID dg = (parseIt' . prettyPrint') dg == dg --- | This property verifies that 'dotizeGraph'', 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+-- each remain unchanged. Whilst 'dotize', etc. only require -- 'Graph' instances, this property requires 'DynGraph' (which is a -- sub-class of 'Graph') instances to be able to strip off the -- 'Attributes' augmentations. prop_dotizeAugment :: (DynGraph g, Eq n, Ord e) => g n e -> Bool prop_dotizeAugment g = equal g (unAugment g') where- g' = dotizeGraph' g+ g' = setDirectedness dotizeGraph nonClusteredParams g unAugment = nmap snd . emap snd -- | When a graph with multiple edges is augmented, then all edges@@ -76,11 +86,96 @@ prop_dotizeAugmentUniq :: (DynGraph g, Eq n, Ord e) => g n e -> Bool prop_dotizeAugmentUniq g = all uniqLs lss where- g' = dotizeGraph' g+ g' = setDirectedness dotizeGraph nonClusteredParams g les = map (\(f,t,l) -> ((f,t),l)) $ labEdges g' lss = map (map snd) . filter (not . isSingle) $ groupSortBy fst les uniqLs ls = ls == nub ls++-- | Ensure that the definition of 'nodeInformation' for 'DotGraph'+-- finds all the nodes.+prop_findAllNodes :: (Ord el, Graph g) => g nl el -> Bool+prop_findAllNodes g = ((==) `on` sort) gns dgns+ where+ gns = nodes g+ dg = setDirectedness graphToDot nonClusteredParams g+ dgns = map nodeID $ graphNodes dg++-- | Ensure that the definition of 'nodeInformation' for 'GDotGraph'+-- finds all the nodes.+prop_findAllNodesG :: (Ord el, Graph g) => g nl el -> Bool+prop_findAllNodesG g = ((==) `on` sort) gns dgns+ where+ gns = nodes g+ dg = generaliseDotGraph $ setDirectedness graphToDot nonClusteredParams g+ dgns = map nodeID $ graphNodes dg++-- | Ensure that the definition of 'nodeInformation' for 'DotGraph'+-- finds all the nodes when the explicit 'DotNode' definitions are+-- removed.+prop_findAllNodesE :: (Ord el, Graph g) => g nl el -> Bool+prop_findAllNodesE g = ((==) `on` sort) gns dgns+ where+ gns = nodes g+ dg = removeNodes $ setDirectedness graphToDot nonClusteredParams g+ dgns = map nodeID $ graphNodes dg+ removeNodes dot@DotGraph{graphStatements = stmts}+ = dot { graphStatements+ = stmts {nodeStmts = filter notInEdge $ nodeStmts stmts}+ }+ gnes = Set.fromList . concatMap (\(f,t) -> [f,t]) $ edges g+ notInEdge dn = nodeID dn `Set.notMember` gnes++-- | Ensure that the definition of 'nodeInformation' for 'GDotGraph'+-- finds all the nodes when the explicit 'DotNode' definitions are+-- removed.+prop_findAllNodesEG :: (Ord el, Graph g) => g nl el -> Bool+prop_findAllNodesEG g = ((==) `on` sort) gns dgns+ where+ gns = nodes g+ dg = generaliseDotGraph . removeNodes+ $ setDirectedness graphToDot nonClusteredParams g+ dgns = map nodeID $ graphNodes dg+ removeNodes dot@DotGraph{graphStatements = stmts}+ = dot { graphStatements+ = stmts {nodeStmts = filter notInEdge $ nodeStmts stmts}+ }+ gnes = Set.fromList . concatMap (\(f,t) -> [f,t]) $ edges g+ notInEdge dn = nodeID dn `Set.notMember` gnes++-- | Ensure that the definition of 'edgeInformation' for 'DotGraph'+-- finds all the nodes.+prop_findAllEdges :: (Ord el, Graph g) => g nl el -> Bool+prop_findAllEdges g = ((==) `on` sort) ges dges+ where+ ges = edges g+ dg = graphToDot nonClusteredParams g+ dges = map (edgeFromNodeID &&& edgeToNodeID) $ graphEdges dg++-- | Ensure that the definition of 'edgeInformation' for 'GDotGraph'+-- finds all the nodes.+prop_findAllEdgesG :: (Ord el, Graph g) => g nl el -> Bool+prop_findAllEdgesG g = ((==) `on` sort) ges dges+ where+ ges = edges g+ dg = generaliseDotGraph $ graphToDot nonClusteredParams g+ dges = map (edgeFromNodeID &&& edgeToNodeID) $ graphEdges dg++-- | There should be no clusters or global attributes when converting+-- a 'Graph' to a 'DotGraph' without any formatting or clustering.+prop_noGraphInfo :: (Ord el, Graph g) => g nl el -> Bool+prop_noGraphInfo g = info == (GraphAttrs [], Map.empty)+ where+ dg = setDirectedness graphToDot nonClusteredParams g+ info = graphStructureInformation dg++-- | There should be no clusters or global attributes when converting+-- a 'Graph' to a 'GDotGraph' without any formatting or clustering.+prop_noGraphInfoG :: (Ord el, Graph g) => g nl el -> Bool+prop_noGraphInfoG g = info == (GraphAttrs [], Map.empty)+ where+ dg = generaliseDotGraph $ setDirectedness graphToDot nonClusteredParams g+ info = graphStructureInformation dg -- ----------------------------------------------------------------------------- -- Helper utility functions
Data/GraphViz/Types.hs view
@@ -88,6 +88,13 @@ module Data.GraphViz.Types ( -- * Abstraction from the representation type DotRepr(..)+ -- ** Helper types for looking up information within a @DotRepr@.+ , ClusterLookup+ , NodeLookup+ , Path+ -- ** Obtaining the @DotNode@s and @DotEdges@.+ , graphNodes+ , graphEdges -- ** Printing and parsing a @DotRepr@. , printDotGraph , parseDotGraph@@ -100,21 +107,22 @@ -- * Sub-components of a @DotGraph@. , GraphID(..) -- Re-exported from Data.GraphViz.Types.Common , DotStatements(..)- , GlobalAttributes(..)+ , GlobalAttributes(..) -- Re-exported from Data.GraphViz.Types.Common , DotSubGraph(..) , DotNode(..) , DotEdge(..) -- Re-exported from Data.GraphViz.Types.Common ) where import Data.GraphViz.Types.Common-import Data.GraphViz.Attributes( Attributes, Attribute- , usedByGraphs, usedByClusters, usedBySubGraphs- , usedByNodes, usedByEdges)+import Data.GraphViz.Types.State+import Data.GraphViz.Attributes( Attribute+ , usedByGraphs, usedByClusters, usedBySubGraphs) import Data.GraphViz.Util import Data.GraphViz.Parsing import Data.GraphViz.PreProcessing import Data.GraphViz.Printing +import Control.Arrow((&&&)) import Control.Monad(liftM) -- -----------------------------------------------------------------------------@@ -122,23 +130,46 @@ -- | 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+ -- | Return the ID of the graph.+ getID :: dg n -> Maybe GraphID+ -- | Is this graph directed? graphIsDirected :: dg n -> Bool + -- | Is this graph strict?+ graphIsStrict :: 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 information on all the clusters contained within this+ -- 'DotRepr', as well as the top-level 'GraphAttrs' for the+ -- overall graph.+ graphStructureInformation :: dg n -> (GlobalAttributes, ClusterLookup) - -- | Return all the 'DotEdge's contained within this 'DotRepr'.- graphEdges :: dg n -> [DotEdge n]+ -- | Return information on the 'DotNode's contained within this+ -- 'DotRepr'. The 'Bool' parameter indicates if applicable+ -- 'NodeAttrs' should be included.+ nodeInformation :: Bool -> dg n -> NodeLookup n + -- | Return information on the 'DotEdge's contained within this+ -- 'DotRepr'. The 'Bool' parameter indicates if applicable+ -- 'EdgeAttrs' should be included.+ edgeInformation :: Bool -> dg n -> [DotEdge n]++-- | Returns all resultant 'DotNode's in the 'DotRepr' (not including+-- 'NodeAttr's).+graphNodes :: (DotRepr dg n, Ord n) => dg n -> [DotNode n]+graphNodes = toDotNodes . nodeInformation True++-- | Returns all resultant 'DotEdge's in the 'DotRepr' (not including+-- 'EdgeAttr's).+graphEdges :: (DotRepr dg n) => dg n -> [DotEdge n]+graphEdges = edgeInformation True+ -- | 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@@ -164,17 +195,26 @@ } deriving (Eq, Ord, Show, Read) -instance (PrintDot n, ParseDot n) => DotRepr DotGraph n where+instance (Ord n, PrintDot n, ParseDot n) => DotRepr DotGraph n where+ getID = graphID+ graphIsDirected = directedGraph + graphIsStrict = strictGraph+ makeStrict g = g { strictGraph = True } setID i g = g { graphID = Just i } - graphNodes = statementNodes . graphStatements+ graphStructureInformation = getGraphInfo+ . statementStructure . graphStatements - graphEdges = statementEdges . graphStatements+ nodeInformation wGlobal = getNodeLookup wGlobal+ . statementNodes . graphStatements + edgeInformation wGlobal = getDotEdges wGlobal+ . statementEdges . graphStatements+ -- | Check if all the 'Attribute's are being used correctly. isValidGraph :: DotGraph a -> Bool isValidGraph = null . graphErrors@@ -200,16 +240,6 @@ -- ----------------------------------------------------------------------------- --- | Used to record invalid 'Attribute' usage. A 'Just' value denotes--- that it was used in an explicit 'DotNode' or 'DotEdge' usage;--- 'Nothing' means that it was used in a 'GlobalAttributes' value.-data DotError a = GraphError Attribute- | NodeError (Maybe a) Attribute- | EdgeError (Maybe (a,a)) Attribute- deriving (Eq, Ord, Show, Read)---- ------------------------------------------------------------------------------ data DotStatements a = DotStmts { attrStmts :: [GlobalAttributes] , subGraphs :: [DotSubGraph a] , nodeStmts :: [DotNode a]@@ -252,81 +282,23 @@ ++ concatMap invalidNode (nodeStmts stmts) ++ concatMap invalidEdge (edgeStmts stmts) -statementNodes :: DotStatements a -> [DotNode a]-statementNodes stmts = concatMap subGraphNodes (subGraphs stmts)- ++ nodeStmts stmts--statementEdges :: DotStatements a -> [DotEdge a]-statementEdges stmts = concatMap subGraphEdges (subGraphs stmts)- ++ edgeStmts stmts---- --------------------------------------------------------------------------------- | Represents a list of top-level list of 'Attribute's for the--- entire graph/sub-graph. Note that 'GraphAttrs' also applies to--- 'DotSubGraph's.------ Note that Dot allows a single 'Attribute' to be listen on a line;--- if this is the case then when parsing, the type of 'Attribute' it--- is determined and that type of 'GlobalAttribute' is created.-data GlobalAttributes = GraphAttrs { attrs :: Attributes }- | NodeAttrs { attrs :: Attributes }- | EdgeAttrs { attrs :: Attributes }- deriving (Eq, Ord, Show, Read)--instance PrintDot GlobalAttributes where- -- Can't use printAttrBased because an empty list still must be printed.- unqtDot ga = printGlobAttrType ga <+> toDot (attrs ga) <> semi-- unqtListToDot = printAttrBasedList printGlobAttrType attrs-- listToDot = unqtListToDot--printGlobAttrType :: GlobalAttributes -> DotCode-printGlobAttrType GraphAttrs{} = text "graph"-printGlobAttrType NodeAttrs{} = text "node"-printGlobAttrType EdgeAttrs{} = text "edge"--instance ParseDot GlobalAttributes where- -- Not using parseAttrBased here because we want to force usage of- -- Attributes.- parseUnqt = do gat <- parseGlobAttrType- as <- whitespace' >> parse- return $ gat as- `onFail`- liftM determineType parse-- parse = parseUnqt -- Don't want the option of quoting- `adjustErr`- (++ "\n\nNot a valid listing of global attributes")-- -- Have to do this manually because of the special case- parseUnqtList = parseStatements parse-- parseList = parseUnqtList--parseGlobAttrType :: Parse (Attributes -> GlobalAttributes)-parseGlobAttrType = oneOf [ stringRep GraphAttrs "graph"- , stringRep NodeAttrs "node"- , stringRep EdgeAttrs "edge"- ]+statementStructure :: DotStatements n -> GraphState ()+statementStructure stmts+ = do mapM_ addGraphGlobals $ attrStmts stmts+ mapM_ (withSubGraphID addSubGraph statementStructure) $ subGraphs stmts -determineType :: Attribute -> GlobalAttributes-determineType attr- | usedByGraphs attr = GraphAttrs attr'- | usedByClusters attr = GraphAttrs attr' -- Also covers SubGraph case- | usedByNodes attr = NodeAttrs attr'- | otherwise = EdgeAttrs attr' -- Must be for edges.- where- attr' = [attr]+statementNodes :: (Ord a) => DotStatements a -> NodeState a ()+statementNodes stmts+ = do mapM_ addNodeGlobals $ attrStmts stmts+ mapM_ (withSubGraphID recursiveCall statementNodes) $ subGraphs stmts+ mapM_ addNode $ nodeStmts stmts+ mapM_ addEdgeNodes $ edgeStmts stmts -invalidGlobal :: (Attribute -> Bool) -> GlobalAttributes- -> [DotError a]-invalidGlobal f (GraphAttrs as) = map GraphError $ filter (not . f) as-invalidGlobal _ (NodeAttrs as) = map (NodeError Nothing)- $ filter (not . usedByNodes) as-invalidGlobal _ (EdgeAttrs as) = map (EdgeError Nothing)- $ filter (not . usedByEdges) as+statementEdges :: DotStatements a -> EdgeState a ()+statementEdges stmts+ = do mapM_ addEdgeGlobals $ attrStmts stmts+ mapM_ (withSubGraphID recursiveCall statementEdges) $ subGraphs stmts+ mapM_ addEdge $ edgeStmts stmts -- ----------------------------------------------------------------------------- @@ -344,7 +316,7 @@ listToDot = unqtListToDot printSubGraphID' :: DotSubGraph a -> DotCode-printSubGraphID' = printSubGraphID (\sg -> (isCluster sg, subGraphID sg))+printSubGraphID' = printSubGraphID (isCluster &&& subGraphID) instance (ParseDot a) => ParseDot (DotSubGraph a) where parseUnqt = parseStmtBased parseUnqt (parseSubGraphID DotSG)@@ -368,64 +340,8 @@ where valFunc = bool usedBySubGraphs usedByClusters (isCluster sg) -subGraphNodes :: DotSubGraph a -> [DotNode a]-subGraphNodes = statementNodes . subGraphStmts--subGraphEdges :: DotSubGraph a -> [DotEdge a]-subGraphEdges = statementEdges . subGraphStmts---- --------------------------------------------------------------------------------- | A node in 'DotGraph'.-data DotNode a = DotNode { nodeID :: a- , nodeAttributes :: Attributes- }- deriving (Eq, Ord, Show, Read)--instance (PrintDot a) => PrintDot (DotNode a) where- unqtDot = printAttrBased printNodeID nodeAttributes-- unqtListToDot = printAttrBasedList printNodeID nodeAttributes-- listToDot = unqtListToDot--printNodeID :: (PrintDot a) => DotNode a -> DotCode-printNodeID = toDot . nodeID--instance (ParseDot a) => ParseDot (DotNode a) where- parseUnqt = parseAttrBased parseNodeID-- parse = parseUnqt -- Don't want the option of quoting-- parseUnqtList = parseAttrBasedList parseNodeID-- parseList = parseUnqtList--parseNodeID :: (ParseDot a) => Parse (Attributes -> DotNode a)-parseNodeID = liftM DotNode parseAndCheck+withSubGraphID :: (Maybe (Maybe GraphID) -> b -> a)+ -> (DotStatements n -> b) -> DotSubGraph n -> a+withSubGraphID f g sg = f mid . g $ subGraphStmts sg where- parseAndCheck = do a <- parse- me <- optional parseUnwanted- maybe (return a) (const notANode) me- notANode = fail "This appears to be an edge, not a node"- parseUnwanted = oneOf [ parseEdgeType >> return ()- , character ':' >> return () -- PortPos value- ]--instance Functor DotNode where- fmap f n = n { nodeID = f $ nodeID n }--invalidNode :: DotNode a -> [DotError a]-invalidNode n = map (NodeError (Just $ nodeID n))- $ filter (not . usedByNodes) (nodeAttributes n)---- --------------------------------------------------------------------------------- Defined here rather than in Common with the rest of the Edge stuff--- because all the DotError stuff is here.--invalidEdge :: DotEdge a -> [DotError a]-invalidEdge e = map (EdgeError eID)- $ filter (not . usedByEdges) (edgeAttributes e)- where- eID = Just (edgeFromNodeID e, edgeToNodeID e)+ mid = bool Nothing (Just $ subGraphID sg) $ isCluster sg
Data/GraphViz/Types/Clustering.hs view
@@ -10,7 +10,8 @@ This module defines types for creating clusters. -} module Data.GraphViz.Types.Clustering- ( NodeCluster(..)+ ( LNodeCluster+ , NodeCluster(..) , clustersToNodes ) where @@ -23,16 +24,20 @@ -- ----------------------------------------------------------------------------- +-- | A type alias for 'NodeCluster' that specifies that the node value+-- is an 'LNode'.+type LNodeCluster c a = NodeCluster c (LNode a)+ -- | Define into which cluster a particular node belongs. -- Clusters can be nested to arbitrary depth.-data NodeCluster c a = N (LNode a) -- ^ Indicates the actual Node in the Graph.+data NodeCluster c a = N a -- ^ Indicates the actual Node in the Graph. | C c (NodeCluster c a) -- ^ Indicates that the -- 'NodeCluster' is in -- the Cluster /c/. deriving (Show) -- | Create the /Dot/ representation for the given graph.-clustersToNodes :: (Ord c, Graph gr) => (LNode a -> NodeCluster c l)+clustersToNodes :: (Ord c, Graph gr) => (LNode a -> NodeCluster c (LNode l)) -> (c -> Maybe GraphID) -> (c -> [GlobalAttributes]) -> (LNode l -> Attributes) -> gr a b -> ([DotSubGraph Node], [DotNode Node])@@ -45,7 +50,7 @@ -- ----------------------------------------------------------------------------- -- | A tree representation of a cluster.-data ClusterTree c a = NT (LNode a)+data ClusterTree c a = NT a | CT c [ClusterTree c a] deriving (Show) @@ -80,14 +85,14 @@ . sortBy clustOrder where grpCls [] = []- grpCls ns@((NT _):_) = ns- grpCls cs@((CT c _):_) = [CT c (collapseNClusts $ concatMap getNodes cs)]+ grpCls ns@(NT _ : _) = ns+ grpCls cs@(CT c _ : _) = [CT c (collapseNClusts $ concatMap getNodes cs)] -- | Convert the cluster representation of the trees into 'DotNode's -- and 'DotSubGraph's (with @'isCluster' = 'True'@, and -- @'subGraphID' = 'Nothing'@). treesToDot :: (c -> Maybe GraphID) -> (c -> [GlobalAttributes])- -> (LNode a -> Attributes) -> [ClusterTree c a]+ -> (LNode a -> Attributes) -> [ClusterTree c (LNode a)] -> ([DotSubGraph Node], [DotNode Node]) treesToDot cID fmtCluster fmtNode = partitionEithers@@ -95,7 +100,7 @@ -- | Convert this 'ClusterTree' into its /Dot/ representation. treeToDot :: (c -> Maybe GraphID) -> (c -> [GlobalAttributes])- -> (LNode a -> Attributes) -> ClusterTree c a+ -> (LNode a -> Attributes) -> ClusterTree c (LNode a) -> Either (DotSubGraph Node) (DotNode Node) treeToDot _ _ fmtNode (NT ln) = Right DotNode { nodeID = fst ln
Data/GraphViz/Types/Common.hs view
@@ -15,7 +15,9 @@ import Data.GraphViz.Parsing import Data.GraphViz.Printing import Data.GraphViz.Util-import Data.GraphViz.Attributes(Attributes, Attribute(HeadPort, TailPort))+import Data.GraphViz.Attributes( Attributes, Attribute(HeadPort, TailPort)+ , usedByGraphs, usedByClusters+ , usedByNodes, usedByEdges) import Data.GraphViz.Attributes.Internal(PortPos, parseEdgeBasedPP) import Data.Maybe(isJust)@@ -55,9 +57,133 @@ then Dbl $ toDouble str else Str str +-- ----------------------------------------------------------------------------- +-- | Used to record invalid 'Attribute' usage. A 'Just' value denotes+-- that it was used in an explicit 'DotNode' or 'DotEdge' usage;+-- 'Nothing' means that it was used in a 'GlobalAttributes' value.+data DotError a = GraphError Attribute+ | NodeError (Maybe a) Attribute+ | EdgeError (Maybe (a,a)) Attribute+ deriving (Eq, Ord, Show, Read)+ -- ----------------------------------------------------------------------------- +-- Re-exported by Data.GraphViz.Types and Data.GraphViz.Types.Generalised++-- | Represents a list of top-level list of 'Attribute's for the+-- entire graph/sub-graph. Note that 'GraphAttrs' also applies to+-- 'DotSubGraph's.+--+-- Note that Dot allows a single 'Attribute' to be listen on a line;+-- if this is the case then when parsing, the type of 'Attribute' it+-- is determined and that type of 'GlobalAttribute' is created.+data GlobalAttributes = GraphAttrs { attrs :: Attributes }+ | NodeAttrs { attrs :: Attributes }+ | EdgeAttrs { attrs :: Attributes }+ deriving (Eq, Ord, Show, Read)++instance PrintDot GlobalAttributes where+ -- Can't use printAttrBased because an empty list still must be printed.+ unqtDot ga = printGlobAttrType ga <+> toDot (attrs ga) <> semi++ unqtListToDot = printAttrBasedList printGlobAttrType attrs++ listToDot = unqtListToDot++printGlobAttrType :: GlobalAttributes -> DotCode+printGlobAttrType GraphAttrs{} = text "graph"+printGlobAttrType NodeAttrs{} = text "node"+printGlobAttrType EdgeAttrs{} = text "edge"++instance ParseDot GlobalAttributes where+ -- Not using parseAttrBased here because we want to force usage of+ -- Attributes.+ parseUnqt = do gat <- parseGlobAttrType+ as <- whitespace' >> parse+ return $ gat as+ `onFail`+ liftM determineType parse++ parse = parseUnqt -- Don't want the option of quoting+ `adjustErr`+ (++ "\n\nNot a valid listing of global attributes")++ -- Have to do this manually because of the special case+ parseUnqtList = parseStatements parse++ parseList = parseUnqtList++parseGlobAttrType :: Parse (Attributes -> GlobalAttributes)+parseGlobAttrType = oneOf [ stringRep GraphAttrs "graph"+ , stringRep NodeAttrs "node"+ , stringRep EdgeAttrs "edge"+ ]++determineType :: Attribute -> GlobalAttributes+determineType attr+ | usedByGraphs attr = GraphAttrs attr'+ | usedByClusters attr = GraphAttrs attr' -- Also covers SubGraph case+ | usedByNodes attr = NodeAttrs attr'+ | otherwise = EdgeAttrs attr' -- Must be for edges.+ where+ attr' = [attr]++invalidGlobal :: (Attribute -> Bool) -> GlobalAttributes+ -> [DotError a]+invalidGlobal f (GraphAttrs as) = map GraphError $ filter (not . f) as+invalidGlobal _ (NodeAttrs as) = map (NodeError Nothing)+ $ filter (not . usedByNodes) as+invalidGlobal _ (EdgeAttrs as) = map (EdgeError Nothing)+ $ filter (not . usedByEdges) as++-- -----------------------------------------------------------------------------++-- | A node in 'DotGraph'.+data DotNode a = DotNode { nodeID :: a+ , nodeAttributes :: Attributes+ }+ deriving (Eq, Ord, Show, Read)++instance (PrintDot a) => PrintDot (DotNode a) where+ unqtDot = printAttrBased printNodeID nodeAttributes++ unqtListToDot = printAttrBasedList printNodeID nodeAttributes++ listToDot = unqtListToDot++printNodeID :: (PrintDot a) => DotNode a -> DotCode+printNodeID = toDot . nodeID++instance (ParseDot a) => ParseDot (DotNode a) where+ parseUnqt = parseAttrBased parseNodeID++ parse = parseUnqt -- Don't want the option of quoting++ parseUnqtList = parseAttrBasedList parseNodeID++ parseList = parseUnqtList++parseNodeID :: (ParseDot a) => Parse (Attributes -> DotNode a)+parseNodeID = liftM DotNode parseAndCheck+ where+ parseAndCheck = do a <- parse+ me <- optional parseUnwanted+ maybe (return a) (const notANode) me+ notANode = fail "This appears to be an edge, not a node"+ parseUnwanted = oneOf [ parseEdgeType >> return ()+ , character ':' >> return () -- PortPos value+ ]++instance Functor DotNode where+ fmap f n = n { nodeID = f $ nodeID n }++invalidNode :: DotNode a -> [DotError a]+invalidNode n = map (NodeError (Just $ nodeID n))+ $ filter (not . usedByNodes) (nodeAttributes n)++-- -----------------------------------------------------------------------------+ -- This is re-exported in Data.GraphViz.Types; defined here so that -- Generalised can access and use parseEdgeLine (needed for "a -> b -> -- c"-style edge statements).@@ -163,6 +289,12 @@ undirEdge' :: DotCode undirEdge' = text undirEdge++invalidEdge :: DotEdge a -> [DotError a]+invalidEdge e = map (EdgeError eID)+ $ filter (not . usedByEdges) (edgeAttributes e)+ where+ eID = Just (edgeFromNodeID e, edgeToNodeID e) -- ----------------------------------------------------------------------------- -- Labels
Data/GraphViz/Types/Generalised.hs view
@@ -36,14 +36,19 @@ , generaliseDotGraph ) where -import Data.GraphViz.Types hiding (GraphID(..), DotEdge(..))+import Data.GraphViz.Types hiding ( GraphID(..)+ , GlobalAttributes(..)+ , DotEdge(..)) import Data.GraphViz.Types.Common+import Data.GraphViz.Types.State import Data.GraphViz.Parsing import Data.GraphViz.Printing+import Data.GraphViz.Util(bool) import qualified Data.Sequence as Seq import Data.Sequence(Seq, (><)) import qualified Data.Foldable as F+import Control.Arrow((&&&)) import Control.Monad(liftM) -- -----------------------------------------------------------------------------@@ -56,17 +61,26 @@ } deriving (Eq, Ord, Show, Read) -instance (PrintDot n, ParseDot n) => DotRepr GDotGraph n where+instance (Ord n, PrintDot n, ParseDot n) => DotRepr GDotGraph n where+ getID = gGraphID+ graphIsDirected = gDirectedGraph + graphIsStrict = gStrictGraph+ makeStrict g = g { gStrictGraph = True } setID i g = g { gGraphID = Just i } - graphNodes = statementNodes . gGraphStatements+ graphStructureInformation = getGraphInfo+ . statementStructure . gGraphStatements - graphEdges = statementEdges . gGraphStatements+ nodeInformation wGlobal = getNodeLookup wGlobal+ . statementNodes . gGraphStatements + edgeInformation wGlobal = getDotEdges wGlobal+ . statementEdges . gGraphStatements+ instance (PrintDot a) => PrintDot (GDotGraph a) where unqtDot = printStmtBased printGraphID' gGraphStatements printGStmts where@@ -102,12 +116,15 @@ parseGStmts :: (ParseDot a) => Parse (GDotStatements a) parseGStmts = liftM Seq.fromList parse -statementNodes :: GDotStatements a -> [DotNode a]-statementNodes = concatMap stmtNodes . F.toList+statementStructure :: GDotStatements a -> GraphState ()+statementStructure = F.mapM_ stmtStructure -statementEdges :: GDotStatements a -> [DotEdge a]-statementEdges = concatMap stmtEdges . F.toList+statementNodes :: (Ord a) => GDotStatements a -> NodeState a ()+statementNodes = F.mapM_ stmtNodes +statementEdges :: GDotStatements a -> EdgeState a ()+statementEdges = F.mapM_ stmtEdges+ generaliseStatements :: DotStatements a -> GDotStatements a generaliseStatements stmts = atts >< sgs >< ns >< es where@@ -161,16 +178,23 @@ 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 _ = []+stmtStructure :: GDotStatement n -> GraphState ()+stmtStructure (GA ga) = addGraphGlobals ga+stmtStructure (SG sg) = withSubGraphID addSubGraph statementStructure sg+stmtStructure _ = return () -stmtEdges :: (GDotStatement a) -> [DotEdge a]-stmtEdges (SG sg) = subGraphEdges sg-stmtEdges (DE de) = [de]-stmtEdges _ = []+stmtNodes :: (Ord a) => GDotStatement a -> NodeState a ()+stmtNodes (GA ga) = addNodeGlobals ga+stmtNodes (SG sg) = withSubGraphID recursiveCall statementNodes sg+stmtNodes (DN dn) = addNode dn+stmtNodes (DE de) = addEdgeNodes de +stmtEdges :: GDotStatement a -> EdgeState a ()+stmtEdges (GA ga) = addEdgeGlobals ga+stmtEdges (SG sg) = withSubGraphID recursiveCall statementEdges sg+stmtEdges (DE de) = addEdge de+stmtEdges _ = return ()+ -- ----------------------------------------------------------------------------- data GDotSubGraph a = GDotSG { gIsCluster :: Bool@@ -187,7 +211,7 @@ listToDot = unqtListToDot printSubGraphID' :: GDotSubGraph a -> DotCode-printSubGraphID' = printSubGraphID (\sg -> (gIsCluster sg, gSubGraphID sg))+printSubGraphID' = printSubGraphID (gIsCluster &&& gSubGraphID) instance (ParseDot a) => ParseDot (GDotSubGraph a) where parseUnqt = parseStmtBased parseGStmts (parseSubGraphID GDotSG)@@ -206,12 +230,6 @@ 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@@ -219,3 +237,9 @@ } where stmts' = generaliseStatements stmts++withSubGraphID :: (Maybe (Maybe GraphID) -> b -> a)+ -> (GDotStatements n -> b) -> GDotSubGraph n -> a+withSubGraphID f g sg = f mid . g $ gSubGraphStmts sg+ where+ mid = bool Nothing (Just $ gSubGraphID sg) $ gIsCluster sg
+ Data/GraphViz/Types/State.hs view
@@ -0,0 +1,283 @@+{-# OPTIONS_HADDOCK hide #-}++{- |+ Module : Data.GraphViz.Types.State+ Description : Create lookups for 'Attribute's.+ Copyright : (c) Ivan Lazar Miljenovic+ License : 3-Clause BSD-style+ Maintainer : Ivan.Miljenovic@gmail.com++ This module provides functions to assist with building 'Attribute'+ lookups.+-}+module Data.GraphViz.Types.State+ ( Path+ , recursiveCall+ --+ , GraphState+ , ClusterLookup+ , getGraphInfo+ , addSubGraph+ , addGraphGlobals+ --+ , NodeState+ , NodeLookup+ , getNodeLookup+ , toDotNodes+ , addNodeGlobals+ , addNode+ , addEdgeNodes+ --+ , EdgeState+ , getDotEdges+ , addEdgeGlobals+ , addEdge+ ) where++import Data.GraphViz.Types.Common+import Data.GraphViz.Attributes(Attributes, Attribute, sameAttribute)++import Data.Function(on)+import qualified Data.Map as Map+import Data.Map(Map)+import qualified Data.Set as Set+import Data.Set(Set)+import qualified Data.Sequence as Seq+import Data.Sequence(Seq, (|>), ViewL(..))+import Control.Arrow((&&&), (***))+import Control.Monad(when)+import Control.Monad.Trans.State++-- -----------------------------------------------------------------------------++type GVState s a = State (StateValue s) a++data StateValue a = SV { globalAttrs :: SAttrs+ , useGlobals :: Bool+ , globalPath :: Path+ , value :: a+ }+ deriving (Eq, Ord, Show, Read)++-- | The path of clusters that must be traversed to reach this spot.+type Path = Seq (Maybe GraphID)++modifyGlobal :: (SAttrs -> SAttrs) -> GVState s ()+modifyGlobal f = modify f'+ where+ f' sv@(SV{globalAttrs = gas}) = sv{globalAttrs = f gas}++modifyValue :: (s -> s) -> GVState s ()+modifyValue f = modify f'+ where+ f' sv@(SV{value = s}) = sv{value = f s}++addGlobals :: Attributes -> GVState s ()+addGlobals as = do addG <- gets useGlobals+ when addG $ modifyGlobal (`unionWith` as)++getGlobals :: GVState s SAttrs+getGlobals = gets globalAttrs++getPath :: GVState s Path+getPath = gets globalPath++modifyPath :: (Path -> Path) -> GVState s ()+modifyPath f = modify f'+ where+ f' sv@(SV{globalPath = p}) = sv{globalPath = f p}++-- When calling recursively, back-up and restore the global attrs+-- since they shouldn't change.+--+-- Outer Maybe: Nothing for subgraphs, Just for clusters+recursiveCall :: Maybe (Maybe GraphID) -> GVState s () -> GVState s ()+recursiveCall mc s = do gas <- getGlobals+ p <- getPath+ maybe (return ()) (modifyPath . flip (|>)) mc+ s+ modifyGlobal (const gas)+ modifyPath (const p)++-- -----------------------------------------------------------------------------++-- | Defined as a wrapper around 'Attribute' where equality is based+-- solely upon the constructor, not the contents.+newtype SameAttr = SA { getAttr :: Attribute }+ deriving (Show, Read)++instance Eq SameAttr where+ (==) = sameAttribute `on` getAttr++instance Ord SameAttr where+ compare sa1 sa2+ | sa1 == sa2 = EQ+ | otherwise = (compare `on` getAttr) sa1 sa2++type SAttrs = Set SameAttr++toSAttr :: Attributes -> SAttrs+toSAttr = Set.fromList . map SA++unionWith :: SAttrs -> Attributes -> SAttrs+unionWith sas as = Set.fromList (map SA as) `Set.union` sas++unSame :: SAttrs -> Attributes+unSame = map getAttr . Set.toList++-- -----------------------------------------------------------------------------+-- Dealing with sub-graphs++type GraphState a = GVState ClusterLookup' a++-- | The available information for each cluster; the @['Path']@+-- denotes all locations where that particular cluster is located+-- (more than one location can indicate possible problems).+type ClusterLookup = Map (Maybe GraphID) ([Path], GlobalAttributes)++type ClusterLookup' = Map (Maybe GraphID) ClusterInfo++type ClusterInfo = (DList Path, SAttrs)++getGraphInfo :: GraphState a -> (GlobalAttributes, ClusterLookup)+getGraphInfo = (toGlobal . (globalAttrs &&& convert) . value)+ . flip execState initState+ where+ convert = Map.map ((uniq . toList) *** toGlobal)+ toGlobal = GraphAttrs . unSame+ initState = SV Set.empty True Seq.empty Map.empty+ uniq = Set.toList . Set.fromList++mergeCInfos :: ClusterInfo -> ClusterInfo -> ClusterInfo+mergeCInfos (p1,as1) = append p1 *** Set.union as1++addCluster :: Maybe (Maybe GraphID) -> Path -> SAttrs+ -> GraphState ()+addCluster Nothing _ _ = return ()+addCluster (Just gid) p as = modifyValue $ Map.insertWith mergeCInfos gid ci+ where+ ci = (singleton p, as)++-- Use this instead of recursiveCall+addSubGraph :: Maybe (Maybe GraphID) -> GraphState a -> GraphState ()+addSubGraph mid cntns = do pth <- getPath -- Want path before we add it...+ recursiveCall mid $ do cntns+ -- But want attrs after we+ -- finish it.+ gas <- getGlobals+ addCluster mid pth gas++addGraphGlobals :: GlobalAttributes -> GraphState ()+addGraphGlobals (GraphAttrs as) = addGlobals as+addGraphGlobals _ = return ()++-- -----------------------------------------------------------------------------+-- Dealing with DotNodes++-- | The available information on each 'DotNode' (both explicit and implicit).+type NodeLookup n = Map n (Path, Attributes)++type NodeLookup' n = Map n NodeInfo++data NodeInfo = NI { atts :: SAttrs+ , gAtts :: SAttrs -- from globals+ , location :: Path+ }+ deriving (Eq, Ord, Show, Read)++type NodeState n a = GVState (NodeLookup' n) a++toDotNodes :: (Ord n) => NodeLookup n -> [DotNode n]+toDotNodes = map (\(n,(_,as)) -> DotNode n as) . Map.assocs++getNodeLookup :: (Ord n) => Bool -> NodeState n a -> NodeLookup n+getNodeLookup addGs = Map.map combine . value . flip execState initState+ where+ initState = SV Set.empty addGs Seq.empty Map.empty+ combine ni = (location ni, unSame $ atts ni `Set.union` gAtts ni)++-- New -> Old -> Inserted+--+-- For specific attributes, newer one takes precedence; for global+-- attributes and path, older one takes precedence.+mergeNInfos :: NodeInfo -> NodeInfo -> NodeInfo+mergeNInfos (NI a1 ga1 p1) (NI a2 ga2 p2) = NI (a1 `Set.union` a2)+ -- old one takes precendence+ (ga2 `Set.union` ga1)+ -- old one takes precendence+ (mergePs p2 p1)++-- | If one 'Path' is a prefix of another, then take the longer one;+-- otherwise, take the first 'Path'.+mergePs :: Path -> Path -> Path+mergePs p1 p2 = mrg' p1 p2+ where+ mrg' = mrg `on` Seq.viewl+ mrg EmptyL _ = p2+ mrg _ EmptyL = p1+ mrg (c1 :< p1') (c2 :< p2')+ | c1 == c2 = mrg' p1' p2'+ | otherwise = p1++addNodeGlobals :: GlobalAttributes -> NodeState n ()+addNodeGlobals (NodeAttrs as) = addGlobals as+addNodeGlobals _ = return ()++mergeNode :: (Ord n) => n -> Attributes -> SAttrs -> Path+ -> NodeState n ()+mergeNode n as gas p = modifyValue $ Map.insertWith mergeNInfos n ni+ where+ ni = NI (toSAttr as) gas p++addNode :: (Ord n) => DotNode n -> NodeState n ()+addNode (DotNode n as) = do gas <- getGlobals+ p <- getPath+ -- insertWith takes func (new -> old -> inserted)+ mergeNode n as gas p++addEdgeNodes :: (Ord n) => DotEdge n -> NodeState n ()+addEdgeNodes (DotEdge f t _ _) = do gas <- getGlobals+ p <- getPath+ addEN f gas p+ addEN t gas p+ where+ addEN n = mergeNode n []++-- -----------------------------------------------------------------------------+-- Dealing with DotEdges++type EdgeState n a = GVState (DList (DotEdge n)) a++getDotEdges :: Bool -> EdgeState n a -> [DotEdge n]+getDotEdges addGs = toList . value . flip execState initState+ where+ initState = SV Set.empty addGs Seq.empty empty++addEdgeGlobals :: GlobalAttributes -> EdgeState n ()+addEdgeGlobals (EdgeAttrs as) = addGlobals as+addEdgeGlobals _ = return ()++addEdge :: DotEdge n -> EdgeState n ()+addEdge de@DotEdge{edgeAttributes = as}+ = do gas <- getGlobals+ let de' = de { edgeAttributes = unSame $ unionWith gas as }+ modifyValue $ snoc de'++-- -----------------------------------------------------------------------------++type DList a = [a] -> [a]++snoc :: a -> DList a -> DList a+snoc a da = da . (a:)++empty :: DList a+empty = id++toList :: DList a -> [a]+toList = ($[])++append :: DList a -> DList a -> DList a+append xs ys = xs . ys++singleton :: a -> DList a+singleton = (:)
FAQ view
@@ -120,7 +120,7 @@ `layerRange` and `layerList` values; this will be fixed in a future release (when state-based printing and parsing is implemented). -* The `/ssss/yyyy` and `//yyyy` forms of printing and prsing `color`s+* The `/ssss/yyyy` and `//yyyy` forms of printing and parsing `color`s are not yet available. #### Available items of note ####
RunTests.hs view
@@ -10,7 +10,78 @@ -} module Main where -import Data.GraphViz.Testing(runDefaultTests)+import Data.GraphViz.Testing( Test(name, lookupName)+ , defaultTests, runChosenTests) +import Data.Char(toLower)+import Data.List(maximum)+import Data.Maybe(mapMaybe)+import qualified Data.Map as Map+import Data.Map(Map)+import Control.Arrow((&&&))+import Control.Monad(when)+import System.Environment(getArgs, getProgName)+import System.Exit(ExitCode(ExitSuccess), exitWith)++-- -----------------------------------------------------------------------------+ main :: IO ()-main = runDefaultTests+main = do opts <- getArgs+ let opts' = map (map toLower) opts+ hasArg arg = any (arg==) opts'+ when (hasArg "help") helpMsg+ let tests = if hasArg "all"+ then defaultTests+ else mapMaybe getTest opts'+ tests' = if null tests+ then defaultTests+ else tests+ runChosenTests tests'++testLookup :: Map String Test+testLookup = Map.fromList+ $ map (lookupName &&& id) defaultTests++getTest :: String -> Maybe Test+getTest = (`Map.lookup` testLookup)++helpMsg :: IO ()+helpMsg = getProgName >>= (putStr . msg) >> exitWith ExitSuccess+ where+ msg nm = unlines+ [ "This utility is the test-suite for the graphviz library for Haskell."+ , "Various tests are available; see the table below for a complete list."+ , "There are several ways of running this program:"+ , ""+ , " " ++ nm ++ " Run all of the tests"+ , " " ++ nm ++ " all Run all of the tests"+ , " " ++ nm ++ " help Get this help message"+ , " " ++ nm ++ " <key> Run the test associated with each key,"+ , " (where <key> denotes a space-separated list of keys"+ , " from the table below)."+ , ""+ , "The entire test suite takes approximately 50 minutes to run on a"+ , "2 GHz Mobile Core 2 Duo (running with a single thread)."+ , ""+ , helpTable+ ]++helpTable :: String+helpTable = unlines $ fmtName ((lnHeader,lnHeaderLen),(nHeader,nHeaderLen))+ : line+ : map fmtName testNames+ where+ andLen = ((id &&& length) .)+ testNames = map (andLen lookupName &&& andLen name) defaultTests+ fmtName ((ln,lnl),(n,nl)) = concat [ ln+ , replicate (maxLN-lnl+spacerLen) ' '+ , n+ ]+ line = replicate (maxLN + spacerLen + maxN) '-'+ maxLN = maximum $ map (snd . fst) testNames+ maxN = maximum $ map (snd . snd) testNames+ spacerLen = 3+ lnHeader = "Key"+ lnHeaderLen = length lnHeader+ nHeader = "Description"+ nHeaderLen = length nHeader
− TestParsing.hs
@@ -1,94 +0,0 @@-#!/usr/bin/runhaskell--{- |- Module : TestParsing- Description : Check if the graphviz parser can parse "real world" Dot code.- Copyright : (c) Ivan Lazar Miljenovic- License : 3-Clause BSD-style- Maintainer : Ivan.Miljenovic@gmail.com-- This module defines a program that determines if the provided files- containing Dot code can be properly parsed using graphviz's parsers- (with the assumption that the provided code is valid).---}-module Main where--import Data.GraphViz-import Data.GraphViz.Types.Generalised-import Data.GraphViz.Parsing(runParser, parse, discard, allWhitespace', eof)-import Data.GraphViz.PreProcessing(preProcess)--import Control.Exception(try, ErrorCall(..), IOException)-import Control.Monad(liftM)-import System.Environment(getArgs)-import System.IO(openFile, IOMode(ReadMode))---- -------------------------------------------------------------------------------main :: IO ()-main = tryParsing =<< getArgs- where- tryParsing [] = putStrLn "Test that the graphviz library can parse\- \ \"real life\" Dot code by passing a list\n\- \of files in which contain Dot graphs.\n\- \\n\- \One way of using this file:\n\t\- \$ locate -r \".*\\.\\(gv\\|dot\\)$\" -0\- \ | xargs -0 runhaskell TestParsing.hs"- tryParsing fs = mapM_ tryParseFile fs---- --------------------------------------------------------------------------------withParse :: (DotRepr dg n) => (a -> IO String) -> (dg n -> IO ())- -> (ErrMsg -> String) -> a -> IO ()-withParse toStr withDG cmbErr a = do dc <- toStr a- edg <- tryParse dc- case edg of- (Right dg) -> withDG dg- (Left err) -> do putStrLn "Parsing problem!"- putStrLn $ cmbErr err- putStrLn ""--type DG = DotGraph String-type GDG = GDotGraph String-type ErrMsg = String--tryParseFile :: FilePath -> IO ()-tryParseFile fp = readFile' fp >>= maybeParse- where- maybeParse (Left err) = putStrLn $ "Error parsing \"" ++ fp ++ "\":\n\t"- ++ err ++ "\n"- maybeParse (Right dot) = withParse (const $ return dot)- (tryParseCanon fp)- (\ e -> fp ++ ": Cannot parse as a GDotGraph:\n"- ++ e)- fp---tryParseCanon :: FilePath -> GDG -> IO ()-tryParseCanon fp = withParse prettyPrint- (const (return ()) . asDG)- (\ e -> fp ++ ": Canonical Form not a DotGraph:\n"- ++ e)- where- asDG = flip asTypeOf emptDG- emptDG = DotGraph False False Nothing $ DotStmts [] [] [] [] :: DG--tryParse :: (DotRepr dg n) => String -> IO (Either ErrMsg (dg n))-tryParse dc = liftM getErrMsg . try- $ let (dg, rst) = runParser parse $ preProcess dc- in length rst `seq` return dg--getErrMsg :: Either ErrorCall a -> Either ErrMsg a-getErrMsg = either getEC Right- where- getEC (ErrorCall e) = Left e--readFile' :: FilePath -> IO (Either ErrMsg String)-readFile' fp = liftM getMsg . try- $ openFile fp ReadMode >>= hGetContents'- where- getMsg :: Either IOException String -> Either ErrMsg String- getMsg = either (Left . show) Right
graphviz.cabal view
@@ -1,5 +1,5 @@ Name: graphviz-Version: 2999.9.0.0+Version: 2999.10.0.0 Stability: Beta Synopsis: Graphviz bindings for Haskell. Description: {@@ -43,8 +43,8 @@ Changelog README FAQ- Data/GraphViz/AttributeGenerator.hs- TestParsing.hs+ utils/AttributeGenerator.hs+ utils/TestParsing.hs Source-Repository head Type: darcs@@ -59,12 +59,13 @@ extensible-exceptions, containers, process,- fgl,+ fgl == 5.4.*, filepath,- polyparse >= 1.4,+ polyparse == 1.4.*, pretty, bytestring < 0.10,- colour >= 2.3 && < 2.4+ colour >= 2.3 && < 2.4,+ transformers == 0.2.* Exposed-Modules: Data.GraphViz Data.GraphViz.Types@@ -80,6 +81,7 @@ Other-Modules: Data.GraphViz.Attributes.Internal Data.GraphViz.Types.Clustering Data.GraphViz.Types.Common+ Data.GraphViz.Types.State Data.GraphViz.Util if flag(test) Build-Depends: QuickCheck >= 2.1 && < 2.2
+ utils/AttributeGenerator.hs view
@@ -0,0 +1,548 @@+#!/usr/bin/runhaskell++{- |+ Module : AttributeGenerator+ Description : Definition of the Graphviz attributes.+ Copyright : (c) Ivan Lazar Miljenovic+ License : 3-Clause BSD-style+ Maintainer : Ivan.Miljenovic@gmail.com++ This module is a stand-alone that generates the correct code for+ Data.GraphViz.Attributes.+ -}+module Data.GraphViz.AttributeGenerator where++import Text.PrettyPrint+import Data.List(transpose)+import Data.Maybe(catMaybes, isJust, fromJust)+import Control.Monad(liftM)+import System.Environment(getArgs)++type Code = Doc++-- If any args are passed in, then generate the Arbitrary instance+-- instead of the definition.+main :: IO ()+main = do args <- getArgs+ let f = if null args+ then genCode+ else genArbitrary+ print $ f att+ where+ att = AS { tpNm = text "Attribute"+ , atts = attributes+ }++genCode :: Atts -> Doc+genCode att = vsep $ map ($att) cds+ where+ cds = [ createDefn+ , createAlias+ , showInstance+ , parseInstance+ , usedByFunc "Graphs" forGraphs+ , usedByFunc "Clusters" forClusters+ , usedByFunc "SubGraphs" forSubGraphs+ , usedByFunc "Nodes" forNodes+ , usedByFunc "Edges" forEdges+ , sameAttributeFunc+ ]++genArbitrary :: Atts -> Doc+genArbitrary = arbitraryInstance++-- -----------------------------------------------------------------------------++-- Defining data structures++data Atts = AS { tpNm :: Code+ , atts :: [Attribute]+ }++data Attribute = A { cnst :: Code+ , name :: Code+ , parseNames :: [Code]+ , valtype :: VType+ , parseDef :: Maybe Code+ , forGraphs :: Bool+ , forClusters :: Bool+ , forSubGraphs :: Bool+ , forNodes :: Bool+ , forEdges :: Bool+ , comment :: Doc+ }++makeAttr :: Constructor -> [Name] -> UsedBy -> VType+ -> Maybe Default -- Used when parsing the field+ -> Maybe Default -> Maybe Minimum -> Maybe Comment+ -> Attribute+makeAttr c ns u v df d m cm = A { cnst = text c+ , name = head ns'+ , parseNames = ns'+ , valtype = v -- just in case need to do fancy+ -- stuff+ , parseDef = liftM text df+ , forGraphs = isFor 'G'+ , forClusters = isFor 'C' || forSG+ , forSubGraphs = forSG+ , forNodes = isFor 'N'+ , forEdges = isFor 'E'+ , comment = cm'+ }+ where+ ns' = map text ns+ isFor f = f `elem` u+ forSG = isFor 'S'+ df' = if v == Bl then Just "'True'" else fmap ( \ t -> '\'' : t ++ "'") df+ mDoc (f,fc) = f <> colon <+> text fc+ addF f = fmap (\ dc -> (wrap (char '/') (text f), dc))+ cm' = hsep+ . punctuate semi+ . map mDoc+ $ catMaybes [ addF "Valid for" (Just u)+ , addF "Default" d+ , addF "Parsing Default" df'+ , addF "Minimum" m+ , addF "Notes" cm+ ]++type Constructor = String+type Name = String+type UsedBy = String -- should only contain subset of "ENGCS"+type Default = String+type Minimum = String+type Comment = String++data VType = Dbl+ | Integ+ | Strng+ | EStrng+ | Bl+ | Cust String+ deriving (Eq, Ord, Show, Read)++vtype :: VType -> Doc+vtype Dbl = text "Double"+vtype Integ = text "Int"+vtype Strng = text "String"+vtype EStrng = text "EscString"+vtype Bl = text "Bool"+vtype (Cust t) = text t++vtypeCode :: Attribute -> Code+vtypeCode = vtype . valtype++-- -----------------------------------------------------------------------------++createDefn :: Atts -> Code+createDefn att = hdr $+$ constructors $+$ derivs+ where+ hdr = text "data" <+> tpNm att+ constructors = nest tab+ . asRows+ . firstOthers equals (char '|')+ . (++ [defUnknown])+ . map createDefn+ $ atts att+ derivs = nest (tab + 2) $ text "deriving (Eq, Ord, Show, Read)"+ createDefn a = [cnst a <+> vtypeCode a+ , if isEmpty cm+ then empty+ else text "-- ^" <+> cm+ ]+ where+ cm = comment a+ defUnknown = [ unknownAttr <+> vtype Strng <+> vtype Strng+ , text "-- ^ /Valid for/: Assumed valid for all; the fields are 'Attribute' name and value respectively."+ ]++createAlias :: Atts -> Code+createAlias att = text "type"+ <+> tp <> char 's'+ <+> equals+ <+> brackets tp+ where+ tp = tpNm att++showInstance :: Atts -> Code+showInstance att = hdr $+$ insts'+ where+ hdr = text "instance" <+> text "PrintDot" <+> tpNm att <+> text "where"+ var = char 'v'+ sFunc = text "unqtDot"+ cnct = text "<>"+ insts = asRows+ . (++ [unknownInst])+ . map mkInstance+ $ atts att+ mkInstance a = [ sFunc <+> parens (cnst a <+> var)+ , equals <+> text "printField" <+> doubleQuotes (name a)+ <+> var+ ]+ unknownInst = [ sFunc <+> parens (unknownAttr <+> char 'a' <+> var)+ , equals <+> text "toDot" <+> char 'a'+ <+> text "<> equals <>" <+> text "toDot" <+> var+ ]+ insts' = nest tab+ $ vsep [ insts+ , text "listToDot" <+> equals <+> text "unqtListToDot"+ ]++parseInstance :: Atts -> Code+parseInstance att = hdr $+$ nest tab fns+ where+ hdr = text "instance" <+> text "ParseDot" <+> tpNm att <+> text "where"+ fn = pFunc <+> equals <+> text "oneOf" <+> ops+ fns = vsep [ fn+ , text "parse" <+> equals <+> pFunc+ , text "parseList" <+> equals <+> text "parseUnqtList"+ ]+ ops = flip ($$) rbrack+ . asRows+ . firstOthers lbrack comma+ . map return+ . (++ [pUnknown])+ . map parseAttr+ $ atts att+ pFunc = text "parseUnqt"+ pType b a+ | valtype a == Bl = pFld <> text "Bool" <+> cnst a+ | isJust $ parseDef a = pFld <> text "Def" <+> cnst a <+> fromJust (parseDef a)+ | otherwise = pFld <+> cnst a+ where+ pFld = text "parseField" <> if b then char 's' else empty++ parseAttr a = case map doubleQuotes $ parseNames a of+ [n] -> pType False a <+> n+ ns -> pType True a <+> docList ns+ pUnknown = text "liftM2" <+> unknownAttr <+> text "stringBlock"+ <+> parens (text "parseEq >> parse")++arbitraryInstance :: Atts -> Code+arbitraryInstance att = vsep [hdr $+$ fns, kFunc]+ where+ hdr = text "instance" <+> text "Arbitrary" <+> tpNm att <+> text "where"+ fns = nest tab $ vsep [aFn, sFn]+ aFn = aFunc <+> equals <+> text "oneof" <+> ops+ ops = flip ($$) rbrack+ . asRows+ . firstOthers lbrack comma+ . (++ [[aUnknown]])+ . map (return . arbAttr)+ $ atts att+ aFunc = text "arbitrary"+ arbAttr a = text "liftM" <+> cnst a <+> arbitraryFor' a+ sFn = asRows+ . (++ [sUnknown])+ . map shrinkAttr+ $ atts att+ sFunc = text "shrink"+ var = char 'v'+ shrinkAttr a = [ sFunc <+> parens (cnst a <+> var)+ , equals <+> text "map" <+> cnst a+ , dollar <+> shrinkFor (valtype a) <+> var+ ]+ aUnknown = text "liftM2" <+> unknownAttr+ <+> parens (text "suchThat" <+> text "arbIDString" <+> kFuncNm)+ <+> arbitraryFor Strng+ sUnknown = [ sFunc <+> parens (unknownAttr <+> char 'a' <+> var)+ , equals <+> text "liftM2" <+> unknownAttr+ , parens (text "liftM" <+> parens (text "filter" <+> kFuncNm)+ <+> shrinkFor Strng <+> char 'a')+ <+> parens (shrinkFor Strng <+> var)+ ]++ kFunc = asRows (kTpSig : kTrs ++ [kOth])+ kFuncNm = text "validUnknown"+ kTpSig = [ kFuncNm+ , colon <> colon <+> text "String -> Bool"+ ]+ kTrs = map kTr . concatMap parseNames $ atts att+ kTr pn = [ kFuncNm <+> doubleQuotes pn+ , equals <+> text "False"+ ]+ kOth = [ kFuncNm <+> char '_'+ , equals <+> text "True"+ ]++arbitraryFor :: VType -> Doc+arbitraryFor Strng = text "arbString"+arbitraryFor EStrng = text "arbString"+arbitraryFor (Cust ('[':_)) = text "arbList"+arbitraryFor _ = text "arbitrary"++arbitraryFor' :: Attribute -> Doc+arbitraryFor' = arbitraryFor . valtype++shrinkFor :: VType -> Doc+shrinkFor (Cust ('[':_)) = text "nonEmptyShrinks"+shrinkFor Strng = text "shrinkString"+shrinkFor EStrng = text "shrinkString"+shrinkFor _ = text "shrink"++usedByFunc :: String -> (Attribute -> Bool) -> Atts -> Code+usedByFunc nm p att = cmnt $$ asRows (tpSig : trs ++ [fls])+ where+ nm' = text nm+ dt = tpNm att+ cmnt = text "-- | Determine if this '" <> dt+ <> text "' is valid for use with" <+> nm' <> dot+ tpSig = [ fn+ , colon <> colon+ <+> dt <+> text "->" <+> text "Bool"+ ]+ fn = text "usedBy" <> nm'+ tr = text "True"+ trs = map aTr as' ++ [unknownATr]+ fl = text "False"+ fls = [ fn <+> char '_'+ , equals <+> fl+ ]+ as' = filter p $ atts att+ aTr a = [ fn <+> cnst a <> braces empty+ , equals <+> tr+ ]+ unknownATr = [ fn <+> unknownAttr <> braces empty+ , equals <+> tr+ ]++sameAttributeFunc :: Atts -> Code+sameAttributeFunc att = cmnt $$ asRows (tpSig : stmts ++ [unknownAtr, rst])+ where+ cmnt = text "-- | Determine if two '" <> dt+ <> text "s' are the same type of '"<> dt <> text"'."+ sFunc = text "sameAttribute"+ dt = tpNm att+ tpSig = [ sFunc+ , char ' ' -- first arg, for some reason won't line up+ -- properly if its empty+ , empty -- second arg+ , colon <> colon+ <+> dt <+> text "->" <+> dt <+> text "->" <+> text "Bool"+ ]+ stmts = map sf $ atts att+ sf a = [ sFunc+ , cnst a <> braces empty+ , cnst a <> braces empty+ , equals <+> tr+ ]+ tr = text "True"+ catchAll = char '_'+ unknownAtr = [ sFunc+ , parens $ unknownAttr <+> text "a1" <+> catchAll+ , parens $ unknownAttr <+> text "a2" <+> catchAll+ , equals <+> text "a1" <+> equals <> equals <+> text "a2"+ ]+ rst = [ sFunc+ , catchAll+ , catchAll+ , equals <+> text "False"+ ]+++-- -----------------------------------------------------------------------------++-- Helper functions++-- Size of a tab character+tab :: Int+tab = 4++firstOthers :: Doc -> Doc -> [[Doc]] -> [[Doc]]+firstOthers _ _ [] = []+firstOthers f o (d:ds) = (f : d) : map ((:) o) ds++wrap :: Doc -> Doc -> Doc+wrap w d = w <> d <> w++vsep :: [Doc] -> Doc+vsep = vcat . punctuate newline+ where+ newline = char '\n'++asRows :: [[Doc]] -> Doc+asRows as = vcat $ map padR asL+ where+ asL = map (map (\d -> (d, docLen d))) as+ cWidths = map (maximum . map snd) $ transpose asL+ shiftLen rls = let (rs,ls) = unzip rls+ in zip rs (0:ls)+ padR = hsep . zipWith append (0 : cWidths) . shiftLen+ append l' (d,l) = hcat (repl (l' - l) space) <> d+ repl n xs | n <= 0 = []+ | otherwise = replicate n xs++-- A really hacky thing to do, but oh well...+-- Don't use this for multi-line Docs!+docLen :: Doc -> Int+docLen = length . render++docList :: [Doc] -> Doc+docList = brackets . hsep . punctuate comma++dot :: Doc+dot = char '.'++-- -----------------------------------------------------------------------------++-- The actual attributes++attributes :: [Attribute]+attributes = [ makeAttr "Damping" ["Damping"] "G" Dbl Nothing (Just "@0.99@") (Just "@0.0@") (Just "neato only")+ , makeAttr "K" ["K"] "GC" Dbl Nothing (Just "@0.3@") (Just "@0@") (Just "sfdp, fdp only")+ , makeAttr "URL" ["URL", "href"] "ENGC" EStrng Nothing (Just "none") Nothing (Just "svg, postscript, map only")+ , makeAttr "ArrowHead" ["arrowhead"] "E" (Cust "ArrowType") Nothing (Just "@'normal'@") Nothing Nothing+ , makeAttr "ArrowSize" ["arrowsize"] "E" Dbl Nothing (Just "@1.0@") (Just "@0.0@") Nothing+ , makeAttr "ArrowTail" ["arrowtail"] "E" (Cust "ArrowType") Nothing (Just "@'normal'@") Nothing Nothing+ , makeAttr "Aspect" ["aspect"] "G" (Cust "AspectType") Nothing Nothing Nothing (Just "dot only")+ , makeAttr "Bb" ["bb"] "G" (Cust "Rect") Nothing Nothing Nothing (Just "write only")+ , makeAttr "BgColor" ["bgcolor"] "GC" (Cust "Color") Nothing (Just "X11Color 'Transparent'") Nothing Nothing+ , makeAttr "Center" ["center"] "G" Bl (Just "True") (Just "@'False'@") Nothing Nothing+ , makeAttr "Charset" ["charset"] "G" Strng Nothing (Just "@\\\"UTF-8\\\"@") Nothing Nothing+ , makeAttr "ClusterRank" ["clusterrank"] "G" (Cust "ClusterMode") Nothing (Just "@'Local'@") Nothing (Just "dot only")+ , makeAttr "ColorScheme" ["colorscheme"] "ENCG" (Cust "ColorScheme") Nothing (Just "@'X11'@") Nothing Nothing+ , makeAttr "Color" ["color"] "ENC" (Cust "[Color]") Nothing (Just "@X11Color 'Black'@") Nothing Nothing+ , makeAttr "Comment" ["comment"] "ENG" Strng Nothing (Just "@\\\"\\\"@") Nothing Nothing+ , makeAttr "Compound" ["compound"] "G" Bl (Just "True") (Just "@'False'@") Nothing (Just "dot only")+ , makeAttr "Concentrate" ["concentrate"] "G" Bl (Just "True") (Just "@'False'@") Nothing Nothing+ , makeAttr "Constraint" ["constraint"] "E" Bl (Just "True") (Just "@'True'@") Nothing (Just "dot only")+ , makeAttr "Decorate" ["decorate"] "E" Bl (Just "True") (Just "@'False'@") Nothing Nothing+ , makeAttr "DefaultDist" ["defaultdist"] "G" Dbl Nothing (Just "@1+(avg. len)*sqrt(|V|)@") (Just "@epsilon@") (Just "neato only")+ , makeAttr "Dimen" ["dimen"] "G" Integ Nothing (Just "@2@") (Just "@2@") (Just "sfdp, fdp, neato only")+ , makeAttr "Dim" ["dim"] "G" Integ Nothing (Just "@2@") (Just "@2@") (Just "sfdp, fdp, neato only")+ , makeAttr "Dir" ["dir"] "E" (Cust "DirType") Nothing (Just "@'Forward'@ (directed), @'NoDir'@ (undirected)") Nothing Nothing+ , makeAttr "DirEdgeConstraints" ["diredgeconstraints"] "G" (Cust "DEConstraints") (Just "EdgeConstraints") (Just "@'NoConstraints'@") Nothing (Just "neato only")+ , makeAttr "Distortion" ["distortion"] "N" Dbl Nothing (Just "@0.0@") (Just "@-100.0@") Nothing+ , makeAttr "DPI" ["dpi", "resolution"] "G" Dbl Nothing (Just "@96.0@, @0.0@") Nothing (Just "svg, bitmap output only; \\\"resolution\\\" is a synonym")+ , makeAttr "EdgeURL" ["edgeURL", "edgehref"] "E" EStrng Nothing (Just "@\\\"\\\"@") Nothing (Just "svg, map only")+ , makeAttr "EdgeTarget" ["edgetarget"] "E" EStrng Nothing (Just "none") Nothing (Just "svg, map only")+ , makeAttr "EdgeTooltip" ["edgetooltip"] "E" EStrng Nothing (Just "@\\\"\\\"@") Nothing (Just "svg, cmap only")+ , makeAttr "Epsilon" ["epsilon"] "G" Dbl Nothing (Just "@.0001 * # nodes@ (@mode == 'KK'@), @.0001@ (@mode == 'Major'@)") Nothing (Just "neato only")+ , makeAttr "ESep" ["esep"] "G" (Cust "DPoint") Nothing (Just "@+3@") Nothing (Just "not dot")+ , makeAttr "FillColor" ["fillcolor"] "NC" (Cust "Color") Nothing (Just "@X11Color 'LightGray'@ (nodes), @X11Color 'Black'@ (clusters)") Nothing Nothing+ , makeAttr "FixedSize" ["fixedsize"] "N" Bl (Just "True") (Just "@'False'@") Nothing Nothing+ , makeAttr "FontColor" ["fontcolor"] "ENGC" (Cust "Color") Nothing (Just "@X11Color 'Black'@") Nothing Nothing+ , makeAttr "FontName" ["fontname"] "ENGC" Strng Nothing (Just "@\\\"Times-Roman\\\"@") Nothing Nothing+ , makeAttr "FontNames" ["fontnames"] "G" Strng Nothing (Just "@\\\"\\\"@") Nothing (Just "svg only")+ , makeAttr "FontPath" ["fontpath"] "G" Strng Nothing (Just "system-dependent") Nothing Nothing+ , makeAttr "FontSize" ["fontsize"] "ENGC" Dbl Nothing (Just "@14.0@") (Just "@1.0@") Nothing+ , makeAttr "Group" ["group"] "N" Strng Nothing (Just "@\\\"\\\"@") Nothing (Just "dot only")+ , makeAttr "HeadURL" ["headURL", "headhref"] "E" EStrng Nothing (Just "@\\\"\\\"@") Nothing (Just "svg, map only")+ , makeAttr "HeadClip" ["headclip"] "E" Bl (Just "True") (Just "@'True'@") Nothing Nothing+ , makeAttr "HeadLabel" ["headlabel"] "E" (Cust "Label") Nothing (Just "@\\\"\\\"@") Nothing Nothing+ , makeAttr "HeadPort" ["headport"] "E" (Cust "PortPos") Nothing (Just "@'PP' 'CenterPoint'@") Nothing Nothing+ , makeAttr "HeadTarget" ["headtarget"] "E" EStrng Nothing (Just "none") Nothing (Just "svg, map only")+ , makeAttr "HeadTooltip" ["headtooltip"] "E" EStrng Nothing (Just "@\\\"\\\"@") Nothing (Just "svg, cmap only")+ , makeAttr "Height" ["height"] "N" Dbl Nothing (Just "@0.5@") (Just "@0.02@") Nothing+ , makeAttr "ID" ["id"] "GNE" (Cust "Label") Nothing (Just "@\\\"\\\"@") Nothing (Just "svg, postscript, map only")+ , makeAttr "Image" ["image"] "N" Strng Nothing (Just "@\\\"\\\"@") Nothing Nothing+ , makeAttr "ImageScale" ["imagescale"] "N" (Cust "ScaleType") (Just "UniformScale") (Just "@'NoScale'@") Nothing Nothing+ , makeAttr "LabelURL" ["labelURL", "labelhref"] "E" EStrng Nothing (Just "@\\\"\\\"@") Nothing (Just "svg, map only")+ , makeAttr "LabelAngle" ["labelangle"] "E" Dbl Nothing (Just "@-25.0@") (Just "@-180.0@") Nothing+ , makeAttr "LabelDistance" ["labeldistance"] "E" Dbl Nothing (Just "@1.0@") (Just "@0.0@") Nothing+ , makeAttr "LabelFloat" ["labelfloat"] "E" Bl (Just "True") (Just "@'False'@") Nothing Nothing+ , makeAttr "LabelFontColor" ["labelfontcolor"] "E" (Cust "Color") Nothing (Just "@X11Color 'Black'@") Nothing Nothing+ , makeAttr "LabelFontName" ["labelfontname"] "E" Strng Nothing (Just "@\\\"Times-Roman\\\"@") Nothing Nothing+ , makeAttr "LabelFontSize" ["labelfontsize"] "E" Dbl Nothing (Just "@14.0@") (Just "@1.0@") Nothing+ , makeAttr "LabelJust" ["labeljust"] "GC" (Cust "Justification") Nothing (Just "@'JCenter'@") Nothing Nothing+ , makeAttr "LabelLoc" ["labelloc"] "GCN" (Cust "VerticalPlacement") Nothing (Just "@'VTop'@ (clusters), @'VBottom'@ (root graphs), @'VCenter'@ (nodes)") Nothing Nothing+ , makeAttr "LabelTarget" ["labeltarget"] "E" EStrng Nothing (Just "none") Nothing (Just "svg, map only")+ , makeAttr "LabelTooltip" ["labeltooltip"] "E" EStrng Nothing (Just "@\\\"\\\"@") Nothing (Just "svg, cmap only")+ , makeAttr "Label" ["label"] "ENGC" (Cust "Label") Nothing (Just "@'StrLabel' \\\"\\N\\\"@ (nodes), @'StrLabel' \\\"\\\"@ (otherwise)") Nothing Nothing+ , makeAttr "Landscape" ["landscape"] "G" Bl (Just "True") (Just "@'False'@") Nothing Nothing+ , makeAttr "LayerSep" ["layersep"] "G" Strng Nothing (Just "@\\\" :\\t\\\"@") Nothing Nothing+ , makeAttr "Layers" ["layers"] "G" (Cust "LayerList") Nothing (Just "@\\\"\\\"@") Nothing Nothing+ , makeAttr "Layer" ["layer"] "EN" (Cust "LayerRange") Nothing (Just "@\\\"\\\"@") Nothing Nothing+ , makeAttr "Layout" ["layout"] "G" Strng Nothing (Just "@\\\"\\\"@") Nothing Nothing+ , makeAttr "Len" ["len"] "E" Dbl Nothing (Just "@1.0@ (neato), @0.3@ (fdp)") Nothing (Just "fdp, neato only")+ , makeAttr "LevelsGap" ["levelsgap"] "G" Dbl Nothing (Just "@0.0@") Nothing (Just "neato only")+ , makeAttr "Levels" ["levels"] "G" Integ Nothing (Just "@MAXINT@") (Just "@0@") (Just "sfdp only")+ , makeAttr "LHead" ["lhead"] "E" Strng Nothing (Just "@\\\"\\\"@") Nothing (Just "dot only")+ , makeAttr "LPos" ["lp"] "EGC" (Cust "Point") Nothing Nothing Nothing (Just "write only")+ , makeAttr "LTail" ["ltail"] "E" Strng Nothing (Just "@\\\"\\\"@") Nothing (Just "dot only")+ , makeAttr "Margin" ["margin"] "NG" (Cust "DPoint") Nothing (Just "device-dependent") Nothing Nothing+ , makeAttr "MaxIter" ["maxiter"] "G" Integ Nothing (Just "@100 * # nodes@ (@mode == 'KK'@), @200@ (@mode == 'Major'@), @600@ (fdp)") Nothing (Just "fdp, neato only")+ , makeAttr "MCLimit" ["mclimit"] "G" Dbl Nothing (Just "@1.0@") Nothing (Just "dot only")+ , makeAttr "MinDist" ["mindist"] "G" Dbl Nothing (Just "@1.0@") (Just "@0.0@") (Just "circo only")+ , makeAttr "MinLen" ["minlen"] "E" Integ Nothing (Just "@1@") (Just "@0@") (Just "dot only")+ , makeAttr "Model" ["model"] "G" (Cust "Model") Nothing (Just "@'ShortPath'@") Nothing (Just "neato only")+ , makeAttr "Mode" ["mode"] "G" (Cust "ModeType") Nothing (Just "@'Major'@") Nothing (Just "neato only")+ , makeAttr "Mosek" ["mosek"] "G" Bl (Just "True") (Just "@'False'@") Nothing (Just "neato only; requires the Mosek software")+ , makeAttr "NodeSep" ["nodesep"] "G" Dbl Nothing (Just "@0.25@") (Just "@0.02@") (Just "dot only")+ , makeAttr "NoJustify" ["nojustify"] "GCNE" Bl (Just "True") (Just "@'False'@") Nothing Nothing+ , makeAttr "Normalize" ["normalize"] "G" Bl (Just "True") (Just "@'False'@") Nothing (Just "not dot")+ , makeAttr "Nslimit1" ["nslimit1"] "G" Dbl Nothing Nothing Nothing (Just "dot only")+ , makeAttr "Nslimit" ["nslimit"] "G" Dbl Nothing Nothing Nothing (Just "dot only")+ , makeAttr "Ordering" ["ordering"] "G" Strng Nothing (Just "@\\\"\\\"@") Nothing (Just "dot only")+ , makeAttr "Orientation" ["orientation"] "N" Dbl Nothing (Just "@0.0@") (Just "@360.0@") Nothing+ , makeAttr "OutputOrder" ["outputorder"] "G" (Cust "OutputMode") Nothing (Just "@'BreadthFirst'@") Nothing Nothing+ , makeAttr "OverlapScaling" ["overlap_scaling"] "G" Dbl Nothing (Just "@-4@") (Just "@-1.0e10@") (Just "prism only")+ , makeAttr "Overlap" ["overlap"] "G" (Cust "Overlap") (Just "KeepOverlaps") (Just "@'KeepOverlaps'@") Nothing (Just "not dot")+ , makeAttr "PackMode" ["packmode"] "G" (Cust "PackMode") Nothing (Just "@'PackNode'@") Nothing (Just "not dot")+ , makeAttr "Pack" ["pack"] "G" (Cust "Pack") (Just "DoPack") (Just "@'False'@") Nothing (Just "not dot")+ , makeAttr "Pad" ["pad"] "G" (Cust "DPoint") Nothing (Just "@'DVal' 0.0555@ (4 points)") Nothing Nothing+ , makeAttr "PageDir" ["pagedir"] "G" (Cust "PageDir") Nothing (Just "@'BL'@") Nothing Nothing+ , makeAttr "Page" ["page"] "G" (Cust "Point") Nothing Nothing Nothing Nothing+ , makeAttr "PenColor" ["pencolor"] "C" (Cust "Color") Nothing (Just "@X11Color 'Black'@") Nothing Nothing+ , makeAttr "PenWidth" ["penwidth"] "CNE" Dbl Nothing (Just "@1.0@") (Just "@0.0@") Nothing+ , makeAttr "Peripheries" ["peripheries"] "NC" Integ Nothing (Just "shape default (nodes), @1@ (clusters)") (Just "0") Nothing+ , makeAttr "Pin" ["pin"] "N" Bl (Just "True") (Just "@'False'@") Nothing (Just "fdp, neato only")+ , makeAttr "Pos" ["pos"] "EN" (Cust "Pos") Nothing Nothing Nothing Nothing+ , makeAttr "QuadTree" ["quadtree"] "G" (Cust "QuadType") (Just "NormalQT") (Just "@'NormalQT'@") Nothing (Just "sfdp only")+ , makeAttr "Quantum" ["quantum"] "G" Dbl Nothing (Just "@0.0@") (Just "@0.0@") Nothing+ , makeAttr "RankDir" ["rankdir"] "G" (Cust "RankDir") Nothing (Just "@'TB'@") Nothing (Just "dot only")+ , makeAttr "RankSep" ["ranksep"] "G" (Cust "[Double]") Nothing (Just "@0.5@ (dot), @1.0@ (twopi)") (Just "0.02") (Just "twopi, dot only")+ , makeAttr "Rank" ["rank"] "S" (Cust "RankType") Nothing Nothing Nothing (Just "dot only")+ , makeAttr "Ratio" ["ratio"] "G" (Cust "Ratios") Nothing Nothing Nothing Nothing+ , makeAttr "Rects" ["rects"] "N" (Cust "Rect") Nothing Nothing Nothing (Just "write only")+ , makeAttr "Regular" ["regular"] "N" Bl (Just "True") (Just "@'False'@") Nothing Nothing+ , makeAttr "ReMinCross" ["remincross"] "G" Bl (Just "True") (Just "@'False'@") Nothing (Just "dot only")+ , makeAttr "RepulsiveForce" ["repulsiveforce"] "G" Dbl Nothing (Just "@1.0@") (Just "@0.0@") (Just "sfdp only")+ , makeAttr "Root" ["root"] "GN" (Cust "Root") (Just "IsCentral") (Just "@'NodeName' \\\"\\\"@ (graphs), @'NotCentral'@ (nodes)") Nothing (Just "circo, twopi only")+ , makeAttr "Rotate" ["rotate"] "G" Integ Nothing (Just "@0@") Nothing Nothing+ , makeAttr "SameHead" ["samehead"] "E" Strng Nothing (Just "@\\\"\\\"@") Nothing (Just "dot only")+ , makeAttr "SameTail" ["sametail"] "E" Strng Nothing (Just "@\\\"\\\"@") Nothing (Just "dot only")+ , makeAttr "SamplePoints" ["samplepoints"] "N" Integ Nothing (Just "@8@ (output), @20@ (overlap and image maps)") Nothing Nothing+ , makeAttr "SearchSize" ["searchsize"] "G" Integ Nothing (Just "@30@") Nothing (Just "dot only")+ , makeAttr "Sep" ["sep"] "G" (Cust "DPoint") Nothing (Just "@+4@") Nothing (Just "not dot")+ , makeAttr "ShapeFile" ["shapefile"] "N" Strng Nothing (Just "@\\\"\\\"@") Nothing Nothing+ , makeAttr "Shape" ["shape"] "N" (Cust "Shape") Nothing (Just "@'Ellipse'@") Nothing Nothing+ , makeAttr "ShowBoxes" ["showboxes"] "ENG" Integ Nothing (Just "@0@") (Just "@0@") (Just "dot only")+ , makeAttr "Sides" ["sides"] "N" Integ Nothing (Just "@4@") (Just "@0@") Nothing+ , makeAttr "Size" ["size"] "G" (Cust "Point") Nothing Nothing Nothing Nothing+ , makeAttr "Skew" ["skew"] "N" Dbl Nothing (Just "@0.0@") (Just "@-100.0@") Nothing+ , makeAttr "Smoothing" ["smoothing"] "G" (Cust "SmoothType") Nothing (Just "@'NoSmooth'@") Nothing (Just "sfdp only")+ , makeAttr "SortV" ["sortv"] "GCN" (Cust "Word16") Nothing (Just "@0@") (Just "@0@") Nothing+ , makeAttr "Splines" ["splines"] "G" (Cust "EdgeType") (Just "SplineEdges") Nothing Nothing Nothing+ , makeAttr "Start" ["start"] "G" (Cust "StartType") Nothing (Just "@\\\"\\\"@") Nothing (Just "fdp, neato only")+ , makeAttr "StyleSheet" ["stylesheet"] "G" Strng Nothing (Just "@\\\"\\\"@") Nothing (Just "svg only")+ , makeAttr "Style" ["style"] "ENC" (Cust "[StyleItem]") Nothing Nothing Nothing Nothing+ , makeAttr "TailURL" ["tailURL", "tailhref"] "E" EStrng Nothing (Just "@\\\"\\\"@") Nothing (Just "svg, map only")+ , makeAttr "TailClip" ["tailclip"] "E" Bl (Just "True") (Just "@'True'@") Nothing Nothing+ , makeAttr "TailLabel" ["taillabel"] "E" (Cust "Label") Nothing (Just "@\\\"\\\"@") Nothing Nothing+ , makeAttr "TailPort" ["tailport"] "E" (Cust "PortPos") Nothing (Just "center") Nothing Nothing+ , makeAttr "TailTarget" ["tailtarget"] "E" EStrng Nothing (Just "none") Nothing (Just "svg, map only")+ , makeAttr "TailTooltip" ["tailtooltip"] "E" EStrng Nothing (Just "@\\\"\\\"@") Nothing (Just "svg, cmap only")+ , makeAttr "Target" ["target"] "ENGC" EStrng Nothing (Just "none") Nothing (Just "svg, map only")+ , makeAttr "Tooltip" ["tooltip"] "NEC" EStrng Nothing (Just "@\\\"\\\"@") Nothing (Just "svg, cmap only")+ , makeAttr "TrueColor" ["truecolor"] "G" Bl (Just "True") Nothing Nothing (Just "bitmap output only")+ , makeAttr "Vertices" ["vertices"] "N" (Cust "[Point]") Nothing Nothing Nothing (Just "write only")+ , makeAttr "ViewPort" ["viewport"] "G" (Cust "ViewPort") Nothing (Just "none") Nothing Nothing+ , makeAttr "VoroMargin" ["voro_margin"] "G" Dbl Nothing (Just "@0.05@") (Just "@0.0@") (Just "not dot")+ , makeAttr "Weight" ["weight"] "E" Dbl Nothing (Just "@1.0@") (Just "@0@ (dot), @1@ (neato,fdp,sfdp)") Nothing+ , makeAttr "Width" ["width"] "N" Dbl Nothing (Just "@0.75@") (Just "@0.01@") Nothing+ , makeAttr "Z" ["z"] "N" Dbl Nothing (Just "@0.0@") (Just "@-MAXFLOAT@, @-1000@") Nothing+ ]++unknownAttr :: Doc+unknownAttr = text "UnknownAttribute"++attrs = take 10 $ drop 5 attributes++attrs' = AS (text "Attribute") attrs++bool :: a -> a -> Bool -> a+bool f t b = if b then t else f++dollar :: Doc+dollar = char '$'
+ utils/TestParsing.hs view
@@ -0,0 +1,94 @@+#!/usr/bin/runhaskell++{- |+ Module : TestParsing+ Description : Check if the graphviz parser can parse "real world" Dot code.+ Copyright : (c) Ivan Lazar Miljenovic+ License : 3-Clause BSD-style+ Maintainer : Ivan.Miljenovic@gmail.com++ This module defines a program that determines if the provided files+ containing Dot code can be properly parsed using graphviz's parsers+ (with the assumption that the provided code is valid).++-}+module Main where++import Data.GraphViz+import Data.GraphViz.Types.Generalised+import Data.GraphViz.Parsing(runParser, parse, discard, allWhitespace', eof)+import Data.GraphViz.PreProcessing(preProcess)++import Control.Exception(try, ErrorCall(..), IOException)+import Control.Monad(liftM)+import System.Environment(getArgs)+import System.IO(openFile, IOMode(ReadMode))++-- -----------------------------------------------------------------------------++main :: IO ()+main = tryParsing =<< getArgs+ where+ tryParsing [] = putStrLn "Test that the graphviz library can parse\+ \ \"real life\" Dot code by passing a list\n\+ \of files in which contain Dot graphs.\n\+ \\n\+ \One way of using this file:\n\t\+ \$ locate -r \".*\\.\\(gv\\|dot\\)$\" -0\+ \ | xargs -0 runhaskell TestParsing.hs"+ tryParsing fs = mapM_ tryParseFile fs++-- -----------------------------------------------------------------------------+++withParse :: (DotRepr dg n) => (a -> IO String) -> (dg n -> IO ())+ -> (ErrMsg -> String) -> a -> IO ()+withParse toStr withDG cmbErr a = do dc <- toStr a+ edg <- tryParse dc+ case edg of+ (Right dg) -> withDG dg+ (Left err) -> do putStrLn "Parsing problem!"+ putStrLn $ cmbErr err+ putStrLn ""++type DG = DotGraph String+type GDG = GDotGraph String+type ErrMsg = String++tryParseFile :: FilePath -> IO ()+tryParseFile fp = readFile' fp >>= maybeParse+ where+ maybeParse (Left err) = putStrLn $ "Error parsing \"" ++ fp ++ "\":\n\t"+ ++ err ++ "\n"+ maybeParse (Right dot) = withParse (const $ return dot)+ (tryParseCanon fp)+ (\ e -> fp ++ ": Cannot parse as a GDotGraph:\n"+ ++ e)+ fp+++tryParseCanon :: FilePath -> GDG -> IO ()+tryParseCanon fp = withParse prettyPrint+ (const (return ()) . asDG)+ (\ e -> fp ++ ": Canonical Form not a DotGraph:\n"+ ++ e)+ where+ asDG = flip asTypeOf emptDG+ emptDG = DotGraph False False Nothing $ DotStmts [] [] [] [] :: DG++tryParse :: (DotRepr dg n) => String -> IO (Either ErrMsg (dg n))+tryParse dc = liftM getErrMsg . try+ $ let (dg, rst) = runParser parse $ preProcess dc+ in length rst `seq` return dg++getErrMsg :: Either ErrorCall a -> Either ErrMsg a+getErrMsg = either getEC Right+ where+ getEC (ErrorCall e) = Left e++readFile' :: FilePath -> IO (Either ErrMsg String)+readFile' fp = liftM getMsg . try+ $ openFile fp ReadMode >>= hGetContents'+ where+ getMsg :: Either IOException String -> Either ErrMsg String+ getMsg = either (Left . show) Right