diff --git a/Changelog b/Changelog deleted file mode 100644 --- a/Changelog +++ /dev/null @@ -1,623 +0,0 @@ -% Changelog -% Ivan Lazar Miljenovic - -Release History and Changelog -============================= - -The following is information about what major changes have gone into -each release. - -Changes in 2999.13.0.3 ----------------------- - -* Allow usage of transformers-0.3.*. Spotted by **Peter Simons**. - -Changes in 2999.13.0.2 ----------------------- - -* The `String` instance for `ToGraphID` requires the - `TypeSynonymInstances` pragma (at least on GHC < 7.4). Spotted by - **Gregory Guthrie**. - -Changes in 2999.13.0.1 ----------------------- - -* Fixed Haddock typos. - -Changes in 2999.13.0.0 ----------------------- - -* Added support for the `osage` and `patchwork` visualisation tools, - available as of Graphviz-2.28.0. - -* Updated attributes as of Graphviz-2.28.0: - - - `SVG` colors are now supported, and the support for different - colors has been revamped. - - - `overlap=false` is now equivalent to `overlap=prism` and the - `RemoveOverlaps` option has been removed. - - - `LabelScheme` and `Rotation` are new attributes for use with - `sfdp`. - - - `Scale` is a new attribute for use with `twopi`. - - - Add new italics, bold, underline, superscript and subscript - options for HTML-like labels. - - - `LHeight` and `LWidth` for getting the height and width of the - root graph and clusters. - -* Updated attributes from the current development branch of Graphviz - (i.e. 2.29.*). Please note that these will probably not work yet, - but are implemented now for future-proofing. - - - A new style for edges: `Tapered`. - - - `XLabel` allows you to specify labels external to a node or - edge. `ForceLabels` allow you to specify that these should be - drawn even when they will cause overlaps. - - - `ImagePath` allows you to specify where to search for images. - - - HTML-like labels now support `ID` values as well as horizontal - and vertical rules. - - - `BgColor` and `FillColor` now take a list of colors: this allows - gradient fills for graphs, clusters and nodes. The `Radial` - style and `GradientAngle` are also used for this purpose. - - - `FillColor` is now used by edges to set the color of any arrows. - - - [WebP](http://en.wikipedia.org/wiki/WebP) output support added. - -* Other attribute changes: - - - Use a specified data type for the `Ordering` attribute rather - than an arbitrary `Text` value, and provide a documented wrapper - in `Data.GraphViz.Attributes`. - - - `Bb` has been renamed `BoundingBox`. - - - `ID` now only takes `EscString` (a type alias for `Text`) values - rather than arbitrary `Label`s. - - - The `Data.GraphViz.Attributes.HTML` module has had all values - re-named and is now meant to be imported qualified. It is also - no longer re-exported from `Data.GraphViz.Attributes.Complete`. - -* The `ToGraphID` class provides a common wrapper to help create - cluster identifiers, etc. - -* Cabal's `Test-Suite` functionality is now used. As part of this, - the `Data.GraphViz.Testing` module and sub-modules are no longer - exported by the library. - -* The new `Benchmark` support in Cabal-1.14 is now used for the - benchmark script. - -* Dropped support for base-3. - -* The `Data.GraphViz.State` module is no longer exposed, as there's no - need for users to use it. - -* Bugfixes: - - - Some corner cases in canonicalisation prevented it from being - idempotent. - - - The `TestParsing` script will no longer crash and refuse to - continue if an IO-based error (e.g. unable to successfully call - `dot`) occurs. - - - A typo was spotted by **Gabor Greif**. - -Changes in 2999.12.0.4 ----------------------- - -* Parsing error messages have been cleared up, especially when parsing - Dot graphs. This came about from trying to help **Uri J. Braun** - with an error in his code (which took a while to diagnose as a - problem with the node type). - -* Made more clear to people looking in `Data.GraphViz` who want to - create Dot graphs by hand to look in `Data.GraphViz.Types` (came - about when **Rustom Mody** stated he got confused trying to work out - how to do this). - -* Fixed up augmentation; bug and fix spotted by **Max Rabkin**. - -* Fix up the TestParsing script to actually use the new type setup. - It can also now take a single directory as an argument, and will try - to parse all (non-recursive) files in that directory. - -Changes in 2999.12.0.3 ----------------------- - -* Fixes various mistakes in the Haddock documentation that slipped - through (either in the `String -> Text` conversion or adding new - modules and not checking their documentation thoroughly enough). - -Changes in 2999.12.0.2 ----------------------- - -* Forgot to explicitly list the module for Arbitrary instance for the - graph representation. - -Changes in 2999.12.0.1 ----------------------- - -* Fix a bug that prevented graphviz from being built with GHC 7.2. - -Changes in 2999.12.0.0 ----------------------- - -Many large-level changes were done in this release; in rough -categories these are: - -### Conversions from other types - -* Can now more easily create Dot graphs from other graph-like data - structures with the new `graphElemsToDot` function, which takes a - list of nodes and edges. - -* It is now no longer possible to use `graphToDot`, etc. to create Dot - graphs with anonymous clusters; all clusters must now have explicit - names (note that uniqueness is not enforced, and it is still - possible to directly create Dot graphs with anonymous clusters). - -### Dot graph representations - -* The canonical graph representation has been moved to its own module: - `Data.GraphViz.Types.Canonical`. - -* The generalised representation has had all its "G" and "g" prefixes - removed. - -* Two new representations: - - - `Data.GraphViz.Types.Graph` allows graph-like manipulation of - Dot code. - - - `Data.GraphViz.Types.Monadic` provides a monadic interface into - building relatively static graphs, based upon the - [_dotgen_](http://hackage.haskell.org/package/dotgen) library by - Andy Gill. - -* The `DotRepr` class has been expanded, and three pseudo-classes have - been provided to reduce type-class contexts in type signatures. - -### Using and manipulation Dot graphs - -* Pure Haskell implementations of `dot -Tcanon` and `tred` are - available in `Data.GraphViz.Algorithms`. - -* A new module is available for more direct low-level I/O with Dot - graphs, including the ability to run custom commands as opposed to - being limited to the standard dot, neato, etc. - -### Attributes - -* `Data.GraphViz.Attributes` now contains a slimmed-down recommended - list of attributes; the complete list can still be found in - `Data.GraphViz.Attributes.Complete`. - -* The `charset` attribute is no longer available. - -* Functions for specifying custom attributes (for pre-processors, - etc.) are available. - -### Implementation - -* Now uses [`Text`](http://hackage.haskell.org/package/text) values - rather than `String`s. Whilst performing this migration, the - improvements in speed for both printing and parsing improved - dramatically. - - - As part of this, human-readable Dot code is now produced by - default. As such, the `prettyPrint` and `prettyPrint'` - functions have been removed. - -* Now uses state-based printing and parsing, so that things like graph - directedness, layer separators and color schemes can be taken into - account. - -* Parsing large data-types (e.g. `Attributes`) now uses less - back-tracking. - -* Now has a benchmarking script for testing printing and parsing - speed. - -* Uses a custom exception type rather than a mish-mash of error, - `Maybe`, `Either`, exception types from used libraries, etc. - -* Usage of UTF-8 is now enforced when doing I/O. If another encoding - is required, the `Text` value that's printed/parsed has to be - written/read from disk/network/etc. manually. - -### Bug-Fixes - -* The `Rects` `Attribute` should be able to take a list of `Rect` - values; error spotted by **Henning Gunther**. - -* In some cases, global attribute names were being printed without - even an empty list (which doesn't match what dot, etc. expect). - -Changes in 2999.11.0.0 ----------------------- - -* Addition of the `Labellable` class (and its method `toLabel`) to - make it easier to construct labels. - -* Backslashes (i.e. the `\` character) are now escaped/unescaped - properly (bug spotted by **Han Joosten**). As part of this: - - - Dot-specific escapes such as `\N` are now also handled - correctly, so the slash does not need to be escaped. - - - Newline (`'\n'`) characters in labels, etc. are escaped to - centred-newlines in Dot code, but not unescaped. - -* `Point` values can now have the optional third dimension and end in - a `!` to indicate that that position should be used (as input to - Graphviz). - -* `LayerList` uses `LayerID` values, and now has a proper `shrink` - implementation in the test suite. - -Changes in 2999.10.0.1 ----------------------- - -* Fixed a mistake in one of the source files that was made just to - make - [haskell-src-exts](http://hackage.haskell.org/package/haskell-src-exts) - happier. - -* Fix the `Arbitrary` instance for `Point` in the testsuite (since - there's only one constructor now). - -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 ---------------------- - -* graphviz now has an FAQ and an improved README as well as its own - [homepage](http://projects.haskell.org/graphviz/). - -* Canonicalisation of `DotRepr` values is now available with the - `canonicalise` function. - -* Add support for record labels; values are automatically - escaped/unescaped. The `Record` and `MRecord` shapes have been - added for use with these labels. **Requested by Minh Thu and Eric - Kow.** - -* Add support for HTML-like values (this replaces the wrong and - completely broken URL datatype). Strings are automatically - escaped/unescaped. - -* Named `PortPos` values are now accepted (as required for record and - HTML-like labels). - -* `GraphID` no longer allows HTML-like values (since Graphviz doesn't - seem to allow it). - -* `RankSep` takes a list of `Double` values as required. - -* `Attribute` has a new constructor `UnknownAttribute` for use when - parsing deprecated Graphviz attributes in old Dot code. - -* Various parsing fixes; of special note: - - - Statements no longer need to end in a semi-colon; - - - Anonymous sub-graphs are now supported. - - - Edge statements can now handle node groupings (e.g. ` a -> {b - c}`) as well as `portPos` values (e.g. `a:from -> b:to`). - - - Unquoted `String`s containing non-ASCII characters are now - parsed properly (though they are assumed to be encoded with - 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. - -* A new script to assist in testing whether "real-world" Dot graphs - are parseable. - -* Slight performance increase when parsing: whereas parsing is done - case-insensitively, the "correct" case is now checked by default - which has a moderate affect on parsing times. - -* Split lines are now able to be handled when parsing. - -Changes in 2999.8.0.0 ---------------------- - -* Added support for generalised `DotGraph`s; this optional - representation removes the restriction of ordering of Dot - statements. This allows for greater flexibility of how to specify - Dot code. As an offshoot from this, most relevant functions now - utilise a new `DotRepr` class that work with both `DotGraph`s and - the new `GDotGraph`s; this shouldn't affect any code already in use. - -* With the **prompting of Noam Lewis**, the augmentation functions - have been revamped in two ways: - - - Now contains support for multiple edges. - - - The ability to perform "manual" augmentation if greater control is - desired. - -* Add a preview function to quickly render and visualise an `FGL` - graph using the `Xlib` canvas. - -* Added a pseudo-inverse of the `FGL -> Dot` functions (a graph is - created, but the original node and edge labels are unrecoverable). - -* The `Printing` and `Parsing` modules have been moved (from - `Data.GraphViz.Types` to `Data.GraphViz`). - -* Reworked file-generating commands such that they return the filename - of the created file if successful. - -Changes in 2999.7.0.0 ---------------------- - -* Updated and extended functions to interact with the Graphviz tools. - This now includes: - - - a better listing of available output types; - - - distinguishing file outputs from canvas outputs; - - - ability to automatically add the correct file extension to file - outputs - - - Return any errors if calling Graphviz failed rather than just - printing them to stderr - -* Improved `Color` support: - - - fixed `ColorScheme` values - - - explicitly named `X11` colors - - - conversion to/from values from the [colour] library - - [colour]: http://www.haskell.org/haskellwiki/Colour - -* Removed `OrientationGraph`; problems with distinguishing it when - parsing from node-based `Orientation` values; its functionality is - duplicated by `Rotate`. - -* By default, the generated Dot code is now no longer indented; you - can now use the `prettyPrint` functions in `Data.GraphViz` to - produce readable Dot code. - -* Added a testsuite; this is buildable by building with - `--flags-test`. Numerous printing and parsing bugs were picked up - with this. - -Changes in 2999.6.0.0 ---------------------- - -* Remove some `Shape` aliases and change capitalisation of others. - -* Properly parse and print IDs of clusters. - -* Allow `NodeCluster` values to have node types different from the - `LNode` they come from. - -Changes in 2999.5.1.1 ---------------------- - -* When used as labels, etc., the Dot keywords `node`, `edge`, `graph`, - `digraph`, `subgraph`, and `strict` need to be quoted. **Spotted by - Kathleen Fisher.** - -Changes in 2999.5.1.0 ---------------------- - -* Potentially fixed the `graphvizWithHandle` bug; correct approach - **spotted by Nikolas Mayr**. - -* Fixed up `Parsing` of various `Attribute` sub-values, especially - `Point` and `Spline` (and hence `Pos`, which uses them). - -* Pre-process out comments and join together multi-line strings before - parsing. - -* Properly parse `Doubles` like `".2"`. - -Changes in 2999.5.0.0 ---------------------- - -A major re-write occured; these are the highlights: - -* Re-write parsing and printing of Dot code using the new `ParseDot` - and `PrintDot` classes. This should finally fix all quoting issues, - as well as leaving `Show` as the code representation for hacking - purposes. As part of this, the `Data.GraphViz.ParserCombinators` - module has been moved to `Data.GraphViz.Types.Parsing`. - -* Re-write the various `Dot*` datatypes in `Data.GraphViz.Types`. - Sub-graphs/clusters are now their own entity rather than being part - of `DotNode` and the Node ID type is now a type parameter rather - than being just `Int`. Sub-graphs/clusters can now also be parsed. - -* The various conversion functions in `Data.GraphViz` now come in two - flavours: the unprimed versions take in a `Bool` indicating if the - graph is directed or not; the primed versions attempt to - automatically detect this. - -* Add cluster support for the graph augmentation functions, **as - requested by Nikolas Mayr**. - -* Allow custom arrow types as supported by GraphViz; **as requested by - Han Joosten**. - -* Fixed a bug in HSV-style `Color` values where `Int` was used instead of - `Double`; **spotted by Michael deLorimier**. - -* Properly resolved the situation initially spotted by Neil Brown: - Matthew Sackman was following Dot terminology for an edge `a -> b` - when using _head_ for `b` and _tail_ for `a` (this is presumably - because the head/tail of the arrow are at those nodes). `DotEdge` - now uses _from_ and _to_ avoid ambiguity; the various `Attribute` - values still follow upstream usage. - -Changes in 2999.1.0.2 ---------------------- - -* Fix a bug **spotted by Srihari Ramanathan** where `Color` values - were double-quoted. - -Changes in 2999.1.0.1 ---------------------- - -* The `Color` `Attribute` should take `[Color]`, not just a single - `Color`. - -Changes in 2999.1.0.0 ---------------------- - -* Stop using `Either` for composite `Attributes` and use a custom - type: this avoids problems with the `Show` instance. - -Changes in 2999.0.0.0 ---------------------- - -* Fixed a bug where the Show instance and read function for `DotEdge` - had the from/to nodes the wrong way round. This was not immediately - noticed since the `Graph` to `DotGraph` functions created them the - wrong way round, so for those users who only used these this was not - apparent. **Spotted by Neil Brown.** - -* Greatly improved `Attribute` usage: almost all attributes are now - covered with allowed values. - -* Extend DotGraph to include whether a graph is strict or not and if - it has an ID. Also move the directedGraph field. - -* Make `Dot` refer to the actual dot command and `DotArrow` refer to - the `ArrowType` (rather than `DotCmd` and `Dot` as before). - -* Make the `Data.GraphViz.ParserCombinators` module available to end - users again, but not re-exported by `Data.GraphViz`; it has a - warning message up the top not to be used. It is there purely for - documentative purposes. - -* Use [extensible-exceptions] so that `base-3.x` is once again - supported. - - [extensible-exceptions]: http://hackage.haskell.org/package/extensible-exceptions - -* Follow the [Package Versioning Policy] rather than using dates for - versions. - - [Package Versioning Policy]: http://www.haskell.org/haskellwiki/Package_versioning_policy - - -Changes in 2009.5.1 -------------------- - -* New maintainer: Ivan Lazar Miljenovic. - -* Support `polyparse >= 1.1` (as opposed to `< 1.3`) - -* Require `base == 4.*` (i.e. `GHC 6.10.*`) due to new exception handling. - -* Include functions from [Graphalyze-0.5] for running GraphViz - commands, etc. - - [Graphalyze-0.5]: http://hackage.haskell.org/package/Graphalyze-0.5 - -* Module re-organisation. - -* The `Data.GraphViz.ParserCombinators` module is no longer available - to end users. - -* Improved Haddock documentation. - -Changes in 2008.9.20 --------------------- - -* Differentiate between undirected and directed graphs (previously - only directed graphs were supported). - -* Clustering support was added. - -Older versions --------------- - -For versions of graphviz older than `2008.9.20`, the exact differences -between versions is unknown. - - diff --git a/Changelog.md b/Changelog.md new file mode 100644 --- /dev/null +++ b/Changelog.md @@ -0,0 +1,1019 @@ + +Release History and Changelog +============================= + +The following is information about what major changes have gone into +each release. + +Changes in 2999.20.2.0 +---------------------- + +* Metadata update. +* Relax QuickCheck upper boundary. + +Changes in 2999.20.2.0 +---------------------- + +* Add `PrintDot` instances for `Word32` and `Word64`. +* Dependency bumps. + +Changes in 2999.20.1.0 +---------------------- + +* Add `MonadFix` instance for `DotM` (thanks to **George Wilson**) + +* Fix exception catching for missing executables (thanks to **Kostas + Dermentzis**) + +* Dependency bumps. + +Changes in 2999.20.0.4 +---------------------- + +* Dependency bumps. + +Changes in 2999.20.0.3 +---------------------- + +* Dependency bumps. + +Changes in 2999.20.0.2 +---------------------- + +* Fix Haddock issue (thanks to **Moritz Kiefer**) + +* Bump HSpec upper bound (thanks to **Moritz Kiefer**) + +* Make Hackage happier with Cabal-Version field + +Changes in 2999.20.0.1 +---------------------- + +* Allow building with temporary-1.3.*. + +Changes in 2999.20.0.0 +---------------------- + +* Can now create subgraphs using the Monadic representation. + +* Allow unescaped `-` and `'` in HTML labels (thanks to **Andrey + Kartashov**) + +* Support for strict `Text` instances for printing/parsing. + +* Creating a Graph representation with `mkGraph` was not adding edges + correctly (reported by **Joshua Chia**). + +* Test suite now uses HSpec, making it a lot easier to add tests for + specific issues. + +* Builds with GHC 8.4.* (thanks to **Tony Day**). + +* Monoid and Semigroup instances for Monadic representation (thanks to + **Chris Martin**). + +* Be more lenient in parsing some attributes (e.g. allow `top` instead + of just `t` for `VerticalPlacement`). + +* Add new HTML attributes: `Columns`, `GradientAngle`, `Rows`, `Sides` + and `Style`. + +* Improve/update the TestParsing executable to work on being able to + parse all the sample `Dot` graphs shipped with Graphviz. + +* Bump dependencies. + +Changes in 2999.19.0.0 +---------------------- + +* Roll back change in 2999.18.1.0 for Monadic graphs, as they turn out + to not actually work in practice (reported by **Lennart Spitzner**). + +* Add a `quickParams` value to help with testing graphs in ghci + (requested by **Ian Jeffries**). + +* Fix parsing of edge chains (reported by **Jonas Collberg**). + +* Fix how seemingly numeric text literals are quoted (reported by + **Joey Hess**). + +Changes in 2999.18.1.2 +---------------------- + +* Allow dlist-0.8, thanks to **Sean Leather**. + +* Properly allow QuickCheck-2.9. + +Changes in 2999.18.1.1 +---------------------- + +* Bump allowed version of QuickCheck for the test suite. + +Changes in 2999.18.1.0 +---------------------- + +* Monadic graphs can now have edges to and from lists of nodes, as + requested by **Harold Carr**. + +* Compatible with GHC-8.* pre-releases. + + - Please note that there is currently a warning emitted on + compilation by GHC-8.*; this has been reported + [here](https://ghc.haskell.org/trac/ghc/ticket/11822). + +Changes in 2999.18.0.2 +---------------------- + +* Match new behaviour of `dot`, etc. in supporting edge specifications + like `a, b -> c, d` (spotted by **Dilawar Singh**). + +Changes in 2999.18.0.1 +---------------------- + +* Loosened bound on `fgl-arbitrary`. + +Changes in 2999.18.0.0 +---------------------- + +* Now builds on GHC 7.10.*. + +* Attribute changes: + + - Added the `NoTranslate` attribute. + + - Add support for overlines in HTML labels. + + Both of these are available as of Graphviz 2.38.0, but were + somehow overlooked in previous releases of this library. + +* Uses new `fgl-arbitrary` library for testing rather than custom + instances for FGL graphs. + +* Migrated to git; central repository now on + [GitHub](https://github.com/ivan-m/graphviz). + +Changes in 2999.17.0.2 +---------------------- + +* Augmentation tests are no longer run by default. This avoids + problems where Graphviz is not installed/configured properly. + +* Use `.gv` for temporary files instead of `.dot`. + +Changes in 2999.17.0.1 +---------------------- + +* Allow usage of `transformers-0.4.*`, by **Sergei Trofimovich**. + +Changes in 2999.17.0.0 +---------------------- + +* Add support for Graphviz 2.32.0, 2.32.1, 2.34.0, 2.36.0 and 2.38.0: + + - **WARNING**: at least as of Graphviz-2.32.0, `dot -Tcanon` no + longer produces Dot code that is in the format expected by the + Canonical Dot representation in this library. As such, unless + you're very sure of your sources you should _always_ use the + Generalised representation for parsing (see also the new + `FromGeneralisedDot` class mentioned below). + + - New attributes: + + + `XDotVersion` (as of 2.34.0) + + + `InputScale` (as of 2.36.0) + + + `OverlapShrink` (as of 2.36.0) + + - Changed attributes: + + + `Aspect` no longer available (as of 2.36.0) + + + New `ModeType` values for use with `sfdp`: `SpringMode` and + `MaxEnt`. + + + `Weight` now takes a value of type `Number`, that explicitly + distinguishes between `Doubles` and `Ints`. + + + `FixedSize` and `Normalize` now have their own types. + + + New `Shape`s: `Star` and `Underline` (as well as `Square` + which seems to have been omitted from previous versions). + + - Other relevant changes: + + + `XDot` now takes an optional version. Note that this + doesn't have any effect on how _graphviz_ works. + + + The default extension for Dot-graphs is now `.gv` rather + than `.dot` to reflect Graphviz's changed conventions. + +* Other changes to the API: + + - Add the `FromGeneralisedDot` class, which provides a + semi-inverse to `fromCanonical` in `DotRepr`. + + - `GraphID` now uses `Number` rather than separate `Int` and + `Double` constructors; this only matters if you manually + constructed or de-constructed `GraphID` values (`ToGraphID` + still works). + + - Add the ability to parse a Dot graph "liberally": that is, if an + `Attribute` doesn't match the specification, then let it fall + back to an `UnknownAttribute`. This is still experimental, and + requires more manual usage than the in-built commands (e.g. it + isn't supported in the default round-tripping). + + - Now using the definition of `bracket` from `polyparse >= 1.9`. + + - Monadic representation now has `Functor` and `Applicative` + instances to satisfy the up-coming changes in GHC 7.10. + +* Compilation time has been reduced in two ways: + + - The `Data.GraphViz.Attributes.Complete` module has been split up + (but still exports the same API, so no need to import more + modules). Whilst I haven't measured it, this should also reduce + memory requirements for compilation. + + - The testsuite now uses the library explicitly, and thus no + longer needs to re-compile half the library. + +* Bug-fixes: + + - Double values are now longer parseable without double quotes if + they have an exponential term (to better match the definition). + + - It is no longer assumed when round-tripping that `dot -Tdot` + generates canonicalised Dot graphs. + +* The `TestParsing` script is now directly buildable by Cabal using + the `test-parsing` flag (the resulting executable is called + `graphviz-testparsing`). This is not made an actual test-suite as + not all files found will be actual Dot graphs, and it's known that + it fails on some. Instead it's meant to be used as an indication of + how well this library parses "real-world" Dot code. + +Changes in 2999.16.0.0 +---------------------- + +* Add support for Graphviz-2.30.0: + + - New attributes: + + + `Area` + + `Head_LP` + + `LayerListSep` + + `LayerSelect` + + `Tail_LP` + + `XLP` + + - `BgColor`, `Color` and `FillColor` now take a list of colors + with optional weightings. + + - Layer handling now supports layer sub-ranges. + + - Added the voronoi-based option to `Overlap`. + + - Added the `Striped` and `Wedged` styles. + +* Updates to attributes and their values: + + - The following attributes have had their values changed to better + reflect what they represent: + + + `FontPath` takes a `Path` value. + + + `Layout` takes a `GraphvizCommand` (and thus + `GraphvizCommand` has been moved to + `Data.GraphViz.Attributes.Complete`). + + - Added `MDS` to `Model` (which had somehow been overlooked). + + - Various attributes now have defaults added/updated/removed if + wrong. + + - Removed the following deprecated attributes: + + + `ShapeFile` + + + `Z` + +* Now any value that has a defined default can be parsed when the Dot + code just has `attribute=""` (which `dot -Tcanon` is fond of doing + to "reset" attributes). + +* `GraphvizCommand` now defines `Sfdp` (which had somehow been + overlooked up till now). + +* The `canonicalise` and related functions have been re-written; + whilst there might be some cases where their behaviour does not + fully match how `dot -Tcanon` and `tred` behave (due to the + interaction of various attributes), the new implementation is much + more sane. + +* Use temporary files rather than pipes when running dot, etc. + + Makes it more portable, and also avoids issues where dot, etc. use + 100% CPU when a graph is passed in via stdin. + + Original patch by **Henning Thielemann**. + +* `renderCompactDot` now outputs to just one line (which means it's + shorter, but more difficult to read for a human). + +* The QuickCheck instances are a bit smarter now to avoid having such + ugly huge outputs when a test fails. + +* More documentation to help you understand what certain data types + are for, etc. + +Changes in 2999.15.0.1 +---------------------- + +* Fixed bug where `canonicalise` and related functions did not + properly deal with attributes of a single node or edge within a + sub-graph. + +Changes in 2999.15.0.0 +---------------------- + +* The repository is now hosted on + [hub.darcs.net](http://hub.darcs.net/ivanm/graphviz), and using the + bug-tracker there. + +* Updates to various `Attribute` definitions: + + - The list of available shapes has been expanded to take into + account the new synthetic biology shapes. + + - The `Size` and `FontNames` attributes now have specified data types. + + - The optional start and end points for `Spline`s were previously + the wrong way round; this has now been fixed. + + - Explicitly only print 2-dimensional `Point` values for `Rect` + and `DPoint` (previously only 2-dimensional values where parsed, + but it was possible to print a 3-dimensional value). + + - HTML-like labels previously disallowed empty textual label + components when parsing; spotted by **Daniel Hummel**. + +* `GraphvizParams` now lets you specify whether a "cluster" is + actually a cluster or a sub-graph. Requested by **Gabor Greif**. + +* Fixed an error where printing edges whose attributes contained a + `ColorScheme` attribute, that attribute would stay in the state and + the old color scheme would override the _parent's_ state. + +* Previously, some malformed attributes were accepted when being + parsed as they silently became parsed as an `UnknownAttribute`. + Now, attributes where the attribute name and the equal sign are + successfully parsed **but** the value of the attribute is _not_ + successfully parse will throw an unrecoverable error. + + **Note**: this does mean that some Dot graphs that are accepted by + Graphviz (as they separate tokenizing from parsing; as such + something like `"0.1"` is successfully accepted as an integer, + specifically `0`) are no longer accepted when parsing them in. + +* Miscellaneous parsing improvements: + + - Whilst not specified anywhere, Graphviz seems to treat empty + quotes as values for attributes expecting a number as their + default; as such, this is now taken into account when parsing. + + - `DPoint` values can now parse an optional `+` prefix. + + - Whitespaces after commas in HSV colors are now accepted. + +* Error messages from parsing are improved to help you track down + where the parsing error occurred (in that it's easier to find which + attribute failed to parse, etc.). + +* Some parsing combinators are no longer publicly accessible, but + shouldn't be needed by end users anyway (as they were there for + parsing the Attribute data type). + +Changes in 2999.14.1.0 +---------------------- + +* Add `isGraphvizInstalled` and `quitWithoutGraphviz` for programs to + test whether Graphviz has been installed (as previous attempts at + doing so via actual calls to dot, neato, etc. weren't working and + would be too verbose anyway). + +Changes in 2999.14.0.0 +---------------------- + +* Added an instance of `Labellable` for strict `Text` values, as + requested by **Erik Rantapaa**. + +Changes in 2999.13.0.3 +---------------------- + +* Allow usage of transformers-0.3.*. Spotted by **Peter Simons**. + +Changes in 2999.13.0.2 +---------------------- + +* The `String` instance for `ToGraphID` requires the + `TypeSynonymInstances` pragma (at least on GHC < 7.4). Spotted by + **Gregory Guthrie**. + +Changes in 2999.13.0.1 +---------------------- + +* Fixed Haddock typos. + +Changes in 2999.13.0.0 +---------------------- + +* Added support for the `osage` and `patchwork` visualisation tools, + available as of Graphviz-2.28.0. + +* Updated attributes as of Graphviz-2.28.0: + + - `SVG` colors are now supported, and the support for different + colors has been revamped. + + - `overlap=false` is now equivalent to `overlap=prism` and the + `RemoveOverlaps` option has been removed. + + - `LabelScheme` and `Rotation` are new attributes for use with + `sfdp`. + + - `Scale` is a new attribute for use with `twopi`. + + - Add new italics, bold, underline, superscript and subscript + options for HTML-like labels. + + - `LHeight` and `LWidth` for getting the height and width of the + root graph and clusters. + +* Updated attributes from the current development branch of Graphviz + (i.e. 2.29.*). Please note that these will probably not work yet, + but are implemented now for future-proofing. + + - A new style for edges: `Tapered`. + + - `XLabel` allows you to specify labels external to a node or + edge. `ForceLabels` allow you to specify that these should be + drawn even when they will cause overlaps. + + - `ImagePath` allows you to specify where to search for images. + + - HTML-like labels now support `ID` values as well as horizontal + and vertical rules. + + - `BgColor` and `FillColor` now take a list of colors: this allows + gradient fills for graphs, clusters and nodes. The `Radial` + style and `GradientAngle` are also used for this purpose. + + - `FillColor` is now used by edges to set the color of any arrows. + + - [WebP](http://en.wikipedia.org/wiki/WebP) output support added. + +* Other attribute changes: + + - Use a specified data type for the `Ordering` attribute rather + than an arbitrary `Text` value, and provide a documented wrapper + in `Data.GraphViz.Attributes`. + + - `Bb` has been renamed `BoundingBox`. + + - `ID` now only takes `EscString` (a type alias for `Text`) values + rather than arbitrary `Label`s. + + - The `Data.GraphViz.Attributes.HTML` module has had all values + re-named and is now meant to be imported qualified. It is also + no longer re-exported from `Data.GraphViz.Attributes.Complete`. + +* The `ToGraphID` class provides a common wrapper to help create + cluster identifiers, etc. + +* Cabal's `Test-Suite` functionality is now used. As part of this, + the `Data.GraphViz.Testing` module and sub-modules are no longer + exported by the library. + +* The new `Benchmark` support in Cabal-1.14 is now used for the + benchmark script. + +* Dropped support for base-3. + +* The `Data.GraphViz.State` module is no longer exposed, as there's no + need for users to use it. + +* Bugfixes: + + - Some corner cases in canonicalisation prevented it from being + idempotent. + + - The `TestParsing` script will no longer crash and refuse to + continue if an IO-based error (e.g. unable to successfully call + `dot`) occurs. + + - A typo was spotted by **Gabor Greif**. + +Changes in 2999.12.0.4 +---------------------- + +* Parsing error messages have been cleared up, especially when parsing + Dot graphs. This came about from trying to help **Uri J. Braun** + with an error in his code (which took a while to diagnose as a + problem with the node type). + +* Made more clear to people looking in `Data.GraphViz` who want to + create Dot graphs by hand to look in `Data.GraphViz.Types` (came + about when **Rustom Mody** stated he got confused trying to work out + how to do this). + +* Fixed up augmentation; bug and fix spotted by **Max Rabkin**. + +* Fix up the TestParsing script to actually use the new type setup. + It can also now take a single directory as an argument, and will try + to parse all (non-recursive) files in that directory. + +Changes in 2999.12.0.3 +---------------------- + +* Fixes various mistakes in the Haddock documentation that slipped + through (either in the `String -> Text` conversion or adding new + modules and not checking their documentation thoroughly enough). + +Changes in 2999.12.0.2 +---------------------- + +* Forgot to explicitly list the module for Arbitrary instance for the + graph representation. + +Changes in 2999.12.0.1 +---------------------- + +* Fix a bug that prevented graphviz from being built with GHC 7.2. + +Changes in 2999.12.0.0 +---------------------- + +Many large-level changes were done in this release; in rough +categories these are: + +### Conversions from other types + +* Can now more easily create Dot graphs from other graph-like data + structures with the new `graphElemsToDot` function, which takes a + list of nodes and edges. + +* It is now no longer possible to use `graphToDot`, etc. to create Dot + graphs with anonymous clusters; all clusters must now have explicit + names (note that uniqueness is not enforced, and it is still + possible to directly create Dot graphs with anonymous clusters). + +### Dot graph representations + +* The canonical graph representation has been moved to its own module: + `Data.GraphViz.Types.Canonical`. + +* The generalised representation has had all its "G" and "g" prefixes + removed. + +* Two new representations: + + - `Data.GraphViz.Types.Graph` allows graph-like manipulation of + Dot code. + + - `Data.GraphViz.Types.Monadic` provides a monadic interface into + building relatively static graphs, based upon the + [_dotgen_](http://hackage.haskell.org/package/dotgen) library by + Andy Gill. + +* The `DotRepr` class has been expanded, and three pseudo-classes have + been provided to reduce type-class contexts in type signatures. + +### Using and manipulation Dot graphs + +* Pure Haskell implementations of `dot -Tcanon` and `tred` are + available in `Data.GraphViz.Algorithms`. + +* A new module is available for more direct low-level I/O with Dot + graphs, including the ability to run custom commands as opposed to + being limited to the standard dot, neato, etc. + +### Attributes + +* `Data.GraphViz.Attributes` now contains a slimmed-down recommended + list of attributes; the complete list can still be found in + `Data.GraphViz.Attributes.Complete`. + +* The `charset` attribute is no longer available. + +* Functions for specifying custom attributes (for pre-processors, + etc.) are available. + +### Implementation + +* Now uses [`Text`](http://hackage.haskell.org/package/text) values + rather than `String`s. Whilst performing this migration, the + improvements in speed for both printing and parsing improved + dramatically. + + - As part of this, human-readable Dot code is now produced by + default. As such, the `prettyPrint` and `prettyPrint'` + functions have been removed. + +* Now uses state-based printing and parsing, so that things like graph + directedness, layer separators and color schemes can be taken into + account. + +* Parsing large data-types (e.g. `Attributes`) now uses less + back-tracking. + +* Now has a benchmarking script for testing printing and parsing + speed. + +* Uses a custom exception type rather than a mish-mash of error, + `Maybe`, `Either`, exception types from used libraries, etc. + +* Usage of UTF-8 is now enforced when doing I/O. If another encoding + is required, the `Text` value that's printed/parsed has to be + written/read from disk/network/etc. manually. + +### Bug-Fixes + +* The `Rects` `Attribute` should be able to take a list of `Rect` + values; error spotted by **Henning Gunther**. + +* In some cases, global attribute names were being printed without + even an empty list (which doesn't match what dot, etc. expect). + +Changes in 2999.11.0.0 +---------------------- + +* Addition of the `Labellable` class (and its method `toLabel`) to + make it easier to construct labels. + +* Backslashes (i.e. the `\` character) are now escaped/unescaped + properly (bug spotted by **Han Joosten**). As part of this: + + - Dot-specific escapes such as `\N` are now also handled + correctly, so the slash does not need to be escaped. + + - Newline (`'\n'`) characters in labels, etc. are escaped to + centred-newlines in Dot code, but not unescaped. + +* `Point` values can now have the optional third dimension and end in + a `!` to indicate that that position should be used (as input to + Graphviz). + +* `LayerList` uses `LayerID` values, and now has a proper `shrink` + implementation in the test suite. + +Changes in 2999.10.0.1 +---------------------- + +* Fixed a mistake in one of the source files that was made just to + make + [haskell-src-exts](http://hackage.haskell.org/package/haskell-src-exts) + happier. + +* Fix the `Arbitrary` instance for `Point` in the testsuite (since + there's only one constructor now). + +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 +--------------------- + +* graphviz now has an FAQ and an improved README as well as its own + [homepage](http://projects.haskell.org/graphviz/). + +* Canonicalisation of `DotRepr` values is now available with the + `canonicalise` function. + +* Add support for record labels; values are automatically + escaped/unescaped. The `Record` and `MRecord` shapes have been + added for use with these labels. **Requested by Minh Thu and Eric + Kow.** + +* Add support for HTML-like values (this replaces the wrong and + completely broken URL datatype). Strings are automatically + escaped/unescaped. + +* Named `PortPos` values are now accepted (as required for record and + HTML-like labels). + +* `GraphID` no longer allows HTML-like values (since Graphviz doesn't + seem to allow it). + +* `RankSep` takes a list of `Double` values as required. + +* `Attribute` has a new constructor `UnknownAttribute` for use when + parsing deprecated Graphviz attributes in old Dot code. + +* Various parsing fixes; of special note: + + - Statements no longer need to end in a semi-colon; + + - Anonymous sub-graphs are now supported. + + - Edge statements can now handle node groupings (e.g. ` a -> {b + c}`) as well as `portPos` values (e.g. `a:from -> b:to`). + + - Unquoted `String`s containing non-ASCII characters are now + parsed properly (though they are assumed to be encoded with + 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. + +* A new script to assist in testing whether "real-world" Dot graphs + are parseable. + +* Slight performance increase when parsing: whereas parsing is done + case-insensitively, the "correct" case is now checked by default + which has a moderate affect on parsing times. + +* Split lines are now able to be handled when parsing. + +Changes in 2999.8.0.0 +--------------------- + +* Added support for generalised `DotGraph`s; this optional + representation removes the restriction of ordering of Dot + statements. This allows for greater flexibility of how to specify + Dot code. As an offshoot from this, most relevant functions now + utilise a new `DotRepr` class that work with both `DotGraph`s and + the new `GDotGraph`s; this shouldn't affect any code already in use. + +* With the **prompting of Noam Lewis**, the augmentation functions + have been revamped in two ways: + + - Now contains support for multiple edges. + + - The ability to perform "manual" augmentation if greater control is + desired. + +* Add a preview function to quickly render and visualise an `FGL` + graph using the `Xlib` canvas. + +* Added a pseudo-inverse of the `FGL -> Dot` functions (a graph is + created, but the original node and edge labels are unrecoverable). + +* The `Printing` and `Parsing` modules have been moved (from + `Data.GraphViz.Types` to `Data.GraphViz`). + +* Reworked file-generating commands such that they return the filename + of the created file if successful. + +Changes in 2999.7.0.0 +--------------------- + +* Updated and extended functions to interact with the Graphviz tools. + This now includes: + + - a better listing of available output types; + + - distinguishing file outputs from canvas outputs; + + - ability to automatically add the correct file extension to file + outputs + + - Return any errors if calling Graphviz failed rather than just + printing them to stderr + +* Improved `Color` support: + + - fixed `ColorScheme` values + + - explicitly named `X11` colors + + - conversion to/from values from the [colour] library + + [colour]: http://www.haskell.org/haskellwiki/Colour + +* Removed `OrientationGraph`; problems with distinguishing it when + parsing from node-based `Orientation` values; its functionality is + duplicated by `Rotate`. + +* By default, the generated Dot code is now no longer indented; you + can now use the `prettyPrint` functions in `Data.GraphViz` to + produce readable Dot code. + +* Added a testsuite; this is buildable by building with + `--flags-test`. Numerous printing and parsing bugs were picked up + with this. + +Changes in 2999.6.0.0 +--------------------- + +* Remove some `Shape` aliases and change capitalisation of others. + +* Properly parse and print IDs of clusters. + +* Allow `NodeCluster` values to have node types different from the + `LNode` they come from. + +Changes in 2999.5.1.1 +--------------------- + +* When used as labels, etc., the Dot keywords `node`, `edge`, `graph`, + `digraph`, `subgraph`, and `strict` need to be quoted. **Spotted by + Kathleen Fisher.** + +Changes in 2999.5.1.0 +--------------------- + +* Potentially fixed the `graphvizWithHandle` bug; correct approach + **spotted by Nikolas Mayr**. + +* Fixed up `Parsing` of various `Attribute` sub-values, especially + `Point` and `Spline` (and hence `Pos`, which uses them). + +* Pre-process out comments and join together multi-line strings before + parsing. + +* Properly parse `Doubles` like `".2"`. + +Changes in 2999.5.0.0 +--------------------- + +A major re-write occured; these are the highlights: + +* Re-write parsing and printing of Dot code using the new `ParseDot` + and `PrintDot` classes. This should finally fix all quoting issues, + as well as leaving `Show` as the code representation for hacking + purposes. As part of this, the `Data.GraphViz.ParserCombinators` + module has been moved to `Data.GraphViz.Types.Parsing`. + +* Re-write the various `Dot*` datatypes in `Data.GraphViz.Types`. + Sub-graphs/clusters are now their own entity rather than being part + of `DotNode` and the Node ID type is now a type parameter rather + than being just `Int`. Sub-graphs/clusters can now also be parsed. + +* The various conversion functions in `Data.GraphViz` now come in two + flavours: the unprimed versions take in a `Bool` indicating if the + graph is directed or not; the primed versions attempt to + automatically detect this. + +* Add cluster support for the graph augmentation functions, **as + requested by Nikolas Mayr**. + +* Allow custom arrow types as supported by GraphViz; **as requested by + Han Joosten**. + +* Fixed a bug in HSV-style `Color` values where `Int` was used instead of + `Double`; **spotted by Michael deLorimier**. + +* Properly resolved the situation initially spotted by Neil Brown: + Matthew Sackman was following Dot terminology for an edge `a -> b` + when using _head_ for `b` and _tail_ for `a` (this is presumably + because the head/tail of the arrow are at those nodes). `DotEdge` + now uses _from_ and _to_ avoid ambiguity; the various `Attribute` + values still follow upstream usage. + +Changes in 2999.1.0.2 +--------------------- + +* Fix a bug **spotted by Srihari Ramanathan** where `Color` values + were double-quoted. + +Changes in 2999.1.0.1 +--------------------- + +* The `Color` `Attribute` should take `[Color]`, not just a single + `Color`. + +Changes in 2999.1.0.0 +--------------------- + +* Stop using `Either` for composite `Attributes` and use a custom + type: this avoids problems with the `Show` instance. + +Changes in 2999.0.0.0 +--------------------- + +* Fixed a bug where the Show instance and read function for `DotEdge` + had the from/to nodes the wrong way round. This was not immediately + noticed since the `Graph` to `DotGraph` functions created them the + wrong way round, so for those users who only used these this was not + apparent. **Spotted by Neil Brown.** + +* Greatly improved `Attribute` usage: almost all attributes are now + covered with allowed values. + +* Extend DotGraph to include whether a graph is strict or not and if + it has an ID. Also move the directedGraph field. + +* Make `Dot` refer to the actual dot command and `DotArrow` refer to + the `ArrowType` (rather than `DotCmd` and `Dot` as before). + +* Make the `Data.GraphViz.ParserCombinators` module available to end + users again, but not re-exported by `Data.GraphViz`; it has a + warning message up the top not to be used. It is there purely for + documentative purposes. + +* Use [extensible-exceptions] so that `base-3.x` is once again + supported. + + [extensible-exceptions]: http://hackage.haskell.org/package/extensible-exceptions + +* Follow the [Package Versioning Policy] rather than using dates for + versions. + + [Package Versioning Policy]: http://www.haskell.org/haskellwiki/Package_versioning_policy + + +Changes in 2009.5.1 +------------------- + +* New maintainer: Ivan Lazar Miljenovic. + +* Support `polyparse >= 1.1` (as opposed to `< 1.3`) + +* Require `base == 4.*` (i.e. `GHC 6.10.*`) due to new exception handling. + +* Include functions from [Graphalyze-0.5] for running GraphViz + commands, etc. + + [Graphalyze-0.5]: http://hackage.haskell.org/package/Graphalyze-0.5 + +* Module re-organisation. + +* The `Data.GraphViz.ParserCombinators` module is no longer available + to end users. + +* Improved Haddock documentation. + +Changes in 2008.9.20 +-------------------- + +* Differentiate between undirected and directed graphs (previously + only directed graphs were supported). + +* Clustering support was added. + +Older versions +-------------- + +For versions of graphviz older than `2008.9.20`, the exact differences +between versions is unknown. diff --git a/Data/GraphViz.hs b/Data/GraphViz.hs --- a/Data/GraphViz.hs +++ b/Data/GraphViz.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, OverloadedStrings #-} +{-# LANGUAGE CPP, FlexibleContexts, MultiParamTypeClasses, OverloadedStrings #-} {- | Module : Data.GraphViz @@ -9,8 +9,8 @@ This is the top-level module for the graphviz library. It provides functions to convert 'Data.Graph.Inductive.Graph.Graph's into the - /Dot/ language used by the /Graphviz/ suite of programs (as well as - a limited ability to perform the reverse operation). + /Dot/ language used by the /Graphviz/ suite of programs (as well as a + limited ability to perform the reverse operation). If you wish to construct a Haskell representation of a Dot graph yourself rather than using the conversion functions here, please @@ -19,13 +19,14 @@ Information about Graphviz and the Dot language can be found at: - -} + module Data.GraphViz ( -- * Conversion from graphs to /Dot/ format. -- ** Specifying parameters. -- $params GraphvizParams(..) + , quickParams , defaultParams , nonClusteredParams , blankParams @@ -63,29 +64,33 @@ , module Data.GraphViz.Commands ) where -import Data.GraphViz.Types -import Data.GraphViz.Types.Canonical( DotGraph(..), DotStatements(..) - , DotSubGraph(..)) import Data.GraphViz.Algorithms.Clustering -import Data.GraphViz.Util(uniq, uniqBy) import Data.GraphViz.Attributes -import Data.GraphViz.Attributes.Complete(CustomAttribute, AttributeName - , customAttribute, findSpecifiedCustom - , customValue) +import Data.GraphViz.Attributes.Complete (AttributeName, CustomAttribute, + customAttribute, customValue, + findSpecifiedCustom) import Data.GraphViz.Commands -import Data.GraphViz.Commands.IO(hGetDot) +import Data.GraphViz.Commands.IO (hGetDot) +import Data.GraphViz.Internal.Util (uniq, uniqBy) +import Data.GraphViz.Types +import Data.GraphViz.Types.Canonical (DotGraph (..), DotStatements (..), + DotSubGraph (..)) +import Data.GraphViz.Types.Generalised (FromGeneralisedDot (..)) -import Data.Graph.Inductive.Graph -import qualified Data.Set as Set -import Control.Arrow((&&&), first) -import Data.Maybe(mapMaybe, fromJust) -import qualified Data.Map as Map -import qualified Data.Text.Lazy as T -import Data.Text.Lazy(Text) -import Control.Monad(liftM) -import System.IO.Unsafe(unsafePerformIO) -import Control.Concurrent(forkIO) +import Control.Arrow (first, (&&&)) +import Control.Concurrent (forkIO) +import Data.Graph.Inductive.Graph +import qualified Data.Map as Map +import Data.Maybe (fromJust, mapMaybe) +import qualified Data.Set as Set +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as T +import System.IO.Unsafe (unsafePerformIO) +#if !(MIN_VERSION_base (4,8,0)) +import Data.Functor ((<$>)) +#endif + -- ----------------------------------------------------------------------------- -- | Determine if the given graph is undirected. @@ -143,7 +148,7 @@ > where > params = blankParams { globalAttributes = [] > , clusterBy = clustBy - > , clusterID = Int + > , clusterID = Num . Int > , fmtCluster = clFmt > , fmtNode = const [] > , fmtEdge = const [] @@ -169,6 +174,11 @@ -- These correspond to 'LNode' and 'LEdge' in FGL graphs. -- -- The clustering in 'clusterBy' can be to arbitrary depth. +-- +-- Note that the term \"cluster\" is slightly conflated here: in +-- terms of @GraphvizParams@ values, a cluster is a grouping of +-- nodes; the 'isDotCluster' function lets you specify whether it is +-- a cluster in the Dot sense or just a sub-graph. data GraphvizParams n nl el cl l = Params { -- | @True@ if the graph is directed; @False@ -- otherwise. @@ -179,6 +189,9 @@ -- | A function to specify which cluster a particular -- node is in. , clusterBy :: ((n,nl) -> NodeCluster cl (n,l)) + -- | Is this \"cluster\" actually a cluster, or just a + -- sub-graph? + , isDotCluster :: (cl -> Bool) -- | The name/identifier for a cluster. , clusterID :: (cl -> GraphID) -- | Specify which global attributes are applied in @@ -190,9 +203,19 @@ , fmtEdge :: ((n,n,el) -> Attributes) } + -- | An alias for 'NodeCluster' when dealing with FGL graphs. type LNodeCluster cl l = NodeCluster cl (Node,l) +-- | Especially useful for quick explorations in ghci, this is a "do +-- what I mean" set of parameters that prints the specified labels +-- of a non-clustered graph. +quickParams :: (Labellable nl, Labellable el) => GraphvizParams n nl el () nl +quickParams = nonClusteredParams { fmtNode = nodeFmt, fmtEdge = edgeFmt } + where + nodeFmt (_,l) = [toLabel l] + edgeFmt (_,_,l) = [toLabel l] + -- | A default 'GraphvizParams' value which assumes the graph is -- directed, contains no clusters and has no 'Attribute's set. -- @@ -208,7 +231,8 @@ defaultParams = Params { isDirected = True , globalAttributes = [] , clusterBy = N - , clusterID = const (Int 0) + , isDotCluster = const True + , clusterID = const (Num $ Int 0) , fmtCluster = const [] , fmtNode = const [] , fmtEdge = const [] @@ -229,13 +253,14 @@ -- programmatically setting the clustering function (and as such do -- not know what the types might be). blankParams :: GraphvizParams n nl el cl l -blankParams = Params { isDirected = undefined - , globalAttributes = undefined - , clusterBy = undefined - , clusterID = undefined - , fmtCluster = undefined - , fmtNode = undefined - , fmtEdge = undefined +blankParams = Params { isDirected = error "Unspecified definition of isDirected" + , globalAttributes = error "Unspecified definition of globalAttributes" + , clusterBy = error "Unspecified definition of clusterBy" + , isDotCluster = error "Unspecified definition of isDotCluster" + , clusterID = error "Unspecified definition of clusterID" + , fmtCluster = error "Unspecified definition of fmtCluster" + , fmtNode = error "Unspecified definition of fmtNode" + , fmtEdge = error "Unspecified definition of fmtEdge" } -- | Determine if the provided 'Graph' is directed or not and set the @@ -271,8 +296,8 @@ , nodeStmts = ns , edgeStmts = es } - (cs, ns) = clustersToNodes (clusterBy params) (clusterID params) - (fmtCluster params) (fmtNode params) + (cs, ns) = clustersToNodes (clusterBy params) (isDotCluster params) + (clusterID params) (fmtCluster params) (fmtNode params) lns es = mapMaybe mkDotEdge les mkDotEdge e@(f,t,_) = if dirGraph || f <= t @@ -294,7 +319,7 @@ -- Applying uniqBy just in case... ns = uniqBy fst . map toLN $ graphNodes dg es = concatMap toLE $ graphEdges dg - -- Need to ensure that for some reason there are node IDs in an + -- Need to check that for some reason there aren't node IDs in an -- edge but not on their own. nSet = Set.fromList $ map fst ns nEs = map (flip (,) []) @@ -415,8 +440,8 @@ es' = zipWith addID es ([1..] :: [Int]) addID (f,t,l) i = (f,t,EID (T.pack $ show i) l) --- | Add the 'Comment' to the list of attributes containing the value --- of the unique edge identifier. +-- | Add a custom attribute to the list of attributes containing the +-- value of the unique edge identifier. setEdgeIDAttribute :: (LEdge el -> Attributes) -> (LEdge (EdgeID el) -> Attributes) setEdgeIDAttribute f = \ e@(_,_,eid) -> identifierAttribute (eID eid) @@ -434,13 +459,13 @@ -- | Pass the 'DotRepr' through the relevant command and then augment -- the 'Graph' that it came from. -dotAttributes :: (Graph gr, PPDotRepr dg Node) => Bool -> gr nl (EdgeID el) +dotAttributes :: (Graph gr, PPDotRepr dg Node, FromGeneralisedDot dg Node) + => Bool -> gr nl (EdgeID el) -> dg Node -> IO (gr (AttributeNode nl) (AttributeEdge el)) dotAttributes isDir gr dot - = liftM (augmentGraph gr . parseDG) - $ graphvizWithHandle command dot DotOutput hGetDot + = augmentGraph gr . parseDG <$> graphvizWithHandle command dot DotOutput hGetDot where - parseDG = (`asTypeOf` dot) + parseDG = (`asTypeOf` dot) . fromGeneralised command = if isDir then dirCommand else undirCommand -- | Use the 'Attributes' in the provided 'DotGraph' to augment the diff --git a/Data/GraphViz/Algorithms.hs b/Data/GraphViz/Algorithms.hs --- a/Data/GraphViz/Algorithms.hs +++ b/Data/GraphViz/Algorithms.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE MonadComprehensions, MultiParamTypeClasses #-} + {- | Module : Data.GraphViz.Algorithms Description : Various algorithms on Graphviz graphs. @@ -8,6 +10,10 @@ Defines various algorithms for use on 'DotRepr' graphs. These are typically re-implementations of behaviour found in existing Graphviz tools but without the I/O requirement. + + Note that one way that these algorithms differ from those found in + Graphviz is that the order of clusters is /not/ maintained, which may + affect layout in some cases. -} module Data.GraphViz.Algorithms ( -- * Canonicalisation Options @@ -16,31 +22,35 @@ , defaultCanonOptions , dotLikeOptions -- * Canonicalisation + -- $canonicalisation , canonicalise , canonicaliseOptions -- * Dealing with transitive edges + -- $transitive , transitiveReduction , transitiveReductionOptions ) where -import Data.GraphViz.Attributes.Complete( Attributes, usedByClusters - , defaultAttributeValue) +import Data.GraphViz.Attributes.Complete (Attributes, defaultAttributeValue) import Data.GraphViz.Attributes.Same +import Data.GraphViz.Internal.Util (bool) import Data.GraphViz.Types import Data.GraphViz.Types.Canonical +import Data.GraphViz.Types.Internal.Common -import Data.Function(on) -import Data.List(groupBy, sortBy, partition, (\\), sort, deleteBy) -import Data.Maybe(listToMaybe, mapMaybe, fromMaybe) -import qualified Data.DList as DList -import qualified Data.Map as Map -import Data.Map(Map) -import qualified Data.Set as Set -import Data.Set(Set) -import qualified Data.Foldable as F -import Control.Arrow(first, second, (***)) -import Control.Monad(unless) -import Control.Monad.Trans.State +import Control.Arrow (first, second, (***)) +import Control.Monad (unless) +import Control.Monad.State (State, execState, gets, modify) +import qualified Data.DList as DList +import qualified Data.Foldable as F +import Data.Function (on) +import Data.List (deleteBy, groupBy, partition, sortBy, + (\\)) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) +import Data.Set (Set) +import qualified Data.Set as Set -- ----------------------------------------------------------------------------- @@ -73,14 +83,38 @@ -- ----------------------------------------------------------------------------- --- | Implements similar functionality to @dot -Tcanon@. However, this --- method requires no IO and doesn't care about image locations, etc. --- --- This function will create a single explicit definition for every --- node in the original graph and place it in the appropriate --- position in the cluster hierarchy. All edges are found in the --- deepest cluster that contains both nodes. Currently node and --- edge attributes are not grouped into global ones. +{- $canonicalisation + +These functions implement similar functionality to @dot -Tcanon@ +(i.e. creates a canonical form of any 'DotRepr' graph). without +requiring IO. + +Note that due to implementation specifics the behaviour is not +identical; in particular: + +* Any specified 'Attributes' that equal the defaults are stripped out + (unless required to override a previous attribute that doesn't apply + here). + +* Grouping of attributes (when @'groupAttributes = True'@) is much + more conservative; only those node/edge attributes that are common to + /all/ nodes and edges within that cluster (and within sub-clusters) + are made global. + +* Sub-graphs aren't kept, only clusters. + +* 'ColorScheme' Attributes are removed (as all @Color@ values embed + any needed color scheme anyway) as the output order of attributes may + change (and this matters for the Haskell side of things). + +In particular, note that this function will create a single explicit +definition for every node in the original graph and place it in the +appropriate position in the cluster hierarchy. All edges are found in +the deepest cluster that contains both nodes. + +-} + +-- | Canonicalise with some sensible defaults. canonicalise :: (DotRepr dg n) => dg n -> DotGraph n canonicalise = canonicaliseOptions defaultCanonOptions @@ -89,127 +123,172 @@ -> dg n -> DotGraph n canonicaliseOptions opts dg = cdg { strictGraph = graphIsStrict dg , directedGraph = graphIsDirected dg - , graphID = getID dg } where - cdg = createCanonical opts gas cl nl es + cdg = createCanonical opts (getID dg) gas cl nl es - (gas, cl) = graphStructureInformation dg - nl = nodeInformation True dg - es = edgeInformation True dg + (gas, cl) = graphStructureInformationClean dg + nl = nodeInformationClean True dg + es = edgeInformationClean True dg -createCanonical :: (Ord n) => CanonicaliseOptions -> GlobalAttributes +type NodePath n = ([Maybe GraphID], DotNode n) +type NodePaths n = [NodePath n] +type EdgeClusters n = Map (Maybe GraphID) [DotEdge n] +type EdgeLocations n = (EdgeClusters n, [DotEdge n]) + +data CanonControl n = CC { cOpts :: !CanonicaliseOptions + , isGraph :: !Bool + , clusters :: !ClusterLookup + , clustEs :: !(EdgeLocations n) + , topID :: !(Maybe GraphID) + , topAttrs :: !Attributes + } + +createCanonical :: (Ord n) => CanonicaliseOptions -> Maybe GraphID -> GlobalAttributes -> ClusterLookup -> NodeLookup n -> [DotEdge n] -> DotGraph n -createCanonical opts gas cl nl es - = DotGraph { strictGraph = undefined - , directedGraph = undefined - , graphID = undefined - , graphStatements = gStmts - } +createCanonical opts gid gas cl nl es = promoteDSG $ makeGrouping cc ns where - gStmts = DotStmts { attrStmts = gas' - , subGraphs = sgs - , nodeStmts = topNs' - , edgeStmts = topEs' - } - - gas' = nonEmptyGAs [ gas - , NodeAttrs topNAs - , EdgeAttrs topEAs - ] nUnlook (n,(p,as)) = (F.toList p, DotNode n as) -- DotNodes paired and sorted by their paths ns = sortBy (compLists `on` fst) . map nUnlook $ Map.toList nl - -- nodes in clusters vs top-level - (clustNs, topNs) = thisLevel ns - -- edges in clusters vs top-level - (clustEL, topEs) = if edgesInClusters opts - then edgeClusters nl es - else (Map.empty, es) - -- The global attributes that are also applicable to clusters. - topClustAs = filter usedByClusters $ attrs gas - topClustAs' = toSAttr topClustAs + es' = if edgesInClusters opts + then edgeClusters nl es + else (Map.empty, es) - topNAs = mCommon nodeAttributes topNs - topNAs' = toSAttr topNAs - topNs' = map (\dn -> dn {nodeAttributes = nodeAttributes dn \\ topNAs}) topNs + cc = CC { cOpts = opts + , isGraph = True + , clusters = cl + , clustEs = es' + , topID = gid + , topAttrs = attrs gas + } - topEAs = mCommon edgeAttributes topEs - topEAs' = toSAttr topEAs - topEs' = map (\de -> de {edgeAttributes = edgeAttributes de \\ topEAs}) topEs +thisLevel :: NodePaths n -> (NodePaths n, [DotNode n]) +thisLevel = second (map snd) . span (not . null . fst) - sgs = clusts topClustAs topClustAs' topNAs topNAs' topEAs topEAs' clustNs +makeGrouping :: CanonControl n -> NodePaths n -> DotSubGraph n +makeGrouping cc cns = DotSG { isCluster = True + , subGraphID = cID + , subGraphStmts = stmts + } + where + cID | isGraph cc = topID cc + | otherwise = head . fst . head $ cns - clusts oAs oAsS nAs nAsS eAs eAsS = map (toClust oAs oAsS nAs nAsS eAs eAsS) - . groupBy ((==) `on` (listToMaybe . fst)) + (nestedNs, ns) = thisLevel + . bool (map $ first tail) id (isGraph cc) + $ cns - -- Create a new cluster. - -- oAs - outer cluster attributes - -- nAs - outer node attributes - -- eAs - outer edge attributes - -- (*S variants are same thing but as sets; premature optimisation?) - -- cns - nodes in this cluster - toClust oAs oAsS nAs nAsS eAs eAsS cns - = DotSG { isCluster = True - , subGraphID = cID - , subGraphStmts = stmts - } - where - -- Find the ID for this cluster. - cID = head . fst $ head cns + es = bool (fromMaybe [] . Map.lookup cID . fst) snd (isGraph cc) + $ clustEs cc - -- Get the nodes that are deeper and the ones that belong - -- here. - (nested, here) = thisLevel $ map (first tail) cns + gas | isGraph cc = topAttrs cc + | otherwise = attrs . snd $ clusters cc Map.! cID + subGs = map (makeGrouping $ cc { isGraph = False }) + . groupBy ((==) `on` (listToMaybe . fst)) + $ nestedNs - stmts = DotStmts { attrStmts = sgAs - , subGraphs = subSGs - , nodeStmts = here' - , edgeStmts = edges' - } + stmts = setGlobal (cOpts cc) gas + $ DotStmts { attrStmts = [] + , subGraphs = subGs + , nodeStmts = ns + , edgeStmts = es + } - -- Starting global attributes - sgAs = nonEmptyGAs [ GraphAttrs as' - , NodeAttrs nas' - , EdgeAttrs eas' - ] +setGlobal :: CanonicaliseOptions + -> Attributes -- Specified cluster attributes + -> DotStatements n + -> DotStatements n +setGlobal opts as stmts = stmts { attrStmts = globs' + , subGraphs = sgs' + , nodeStmts = ns' + , edgeStmts = es' + } + where + sgs = subGraphs stmts + sStmts = map subGraphStmts sgs + ns = nodeStmts stmts + es = edgeStmts stmts - -- Sub-clusters - subSGs = clusts as asS nas nasS eas easS nested + sGlobs = map (partitionGlobal . attrStmts) sStmts - -- The attributes attached to this cluster ID in the original. - as = attrs . snd $ cl Map.! cID - asS = toSAttr as + (sgas,snas,seas) = unzip3 sGlobs - -- Get the global attributes that apply to this cluster, - -- ignoring ones set globally. - as' = fst $ innerAttributes oAs oAsS as + gas' = as -- Can't change graph attrs! Need these! + nas' = getCommonGlobs opts nodeStmts snas sStmts $ map nodeAttributes ns + eas' = getCommonGlobs opts edgeStmts seas sStmts $ map edgeAttributes es - -- The node attributes that can be stated globally. - nas = mCommon nodeAttributes here - nasS = toSAttr nas - (nas',nOv) = innerAttributes nAs nAsS nas + globs' = nonEmptyGAs [ GraphAttrs gas' + , NodeAttrs nas' + , EdgeAttrs eas' + ] + ns' = map (\dn -> dn { nodeAttributes = nodeAttributes dn \\ nas' }) ns + es' = map (\de -> de { edgeAttributes = edgeAttributes de \\ eas' }) es - -- The nodes that belong here, with updated attributes. - here' = map (\dn -> dn {nodeAttributes = nodeAttributes dn \\ (nas ++ nOv)}) here + sgas' = updateGraphGlobs gas' sgas + snas' = map (\\ nas') snas + seas' = map (\\ eas') seas - eas = mCommon edgeAttributes edges - easS = toSAttr eas - (eas',eOv) = innerAttributes eAs eAsS eas - edges' = map (\de -> de {edgeAttributes = edgeAttributes de \\ (eas ++ eOv)}) edges + sGlobs' = zip3 sgas' snas' seas' + sStmts' = zipWith (\ sSt sGl -> sSt { attrStmts = nonEmptyGAs $ unPartitionGlobal sGl }) + sStmts + sGlobs' - -- Find edges that belong here - edges = fromMaybe [] $ cID `Map.lookup` clustEL + sgs' = zipWith (\ sg sSt -> sg { subGraphStmts = sSt }) sgs sStmts' - thisLevel = second (map snd) . span (not . null . fst) +updateGraphGlobs :: Attributes -> [Attributes] -> [Attributes] +updateGraphGlobs gas = map go + where + gasS = Set.fromList gas - mCommon f = if groupAttributes opts - then commonAttrs f - else const [] + override = toSAttr $ nonSameDefaults gas + -- * Remove any identical values + -- * Override any different values + go = Set.toList + . (`Set.difference` gasS) -- Remove identical values + . unSameSet + . (`Set.union` override) -- Keeps existing values of constructors + . toSAttr +nonSameDefaults :: Attributes -> Attributes +nonSameDefaults = mapMaybe (\ a -> [ a' | a' <- defaultAttributeValue a, a' /= a] ) + +getCommonGlobs :: CanonicaliseOptions + -> (DotStatements n -> [a]) + -> [Attributes] -- ^ From sub-graphs + -> [DotStatements n] -- ^ Statements from the sub-graphs for testing. + -> [Attributes] -- ^ From nodes/edges + -> Attributes +getCommonGlobs opts f sas stmts as + | not $ groupAttributes opts = [] + | otherwise = case sas' ++ as of + [] -> [] + [_] -> [] + as' -> Set.toList . foldr1 Set.intersection + $ map Set.fromList as' + where + sas' = keepIfAny f sas stmts + +-- Used to distinguish between having empty list of global attributes +-- for nodes or edges because there aren't any nodes/edges, or because +-- there aren't any common attributes +keepIfAny :: (DotStatements n -> [a]) -> [Attributes] -> [DotStatements n] + -> [Attributes] +keepIfAny f sas = map fst . filter snd . zip sas . map (hasAny f) + +hasAny :: (DotStatements n -> [a]) -> DotStatements n -> Bool +hasAny f ds = not (null $ f ds) || any (hasAny f . subGraphStmts) (subGraphs ds) + +promoteDSG :: DotSubGraph n -> DotGraph n +promoteDSG dsg = DotGraph { strictGraph = undefined + , directedGraph = undefined + , graphID = subGraphID dsg + , graphStatements = subGraphStmts dsg + } + -- Same as compare for lists, except shorter lists are GT compLists :: (Ord a) => [a] -> [a] -> Ordering compLists [] [] = EQ @@ -222,20 +301,14 @@ nonEmptyGAs :: [GlobalAttributes] -> [GlobalAttributes] nonEmptyGAs = filter (not . null . attrs) --- Return all attributes found in every value. -commonAttrs :: (a -> Attributes) -> [a] -> Attributes -commonAttrs _ [] = [] -commonAttrs _ [_] = [] -commonAttrs f xs = Set.toList . foldr1 Set.intersection - $ map (Set.fromList . f) xs - -- Assign each edge into the cluster it belongs in. edgeClusters :: (Ord n) => NodeLookup n -> [DotEdge n] - -> (Map (Maybe GraphID) [DotEdge n], [DotEdge n]) + -> EdgeLocations n edgeClusters nl = (toM *** map snd) . partition (not . null . fst) . map inClust where nl' = Map.map (F.toList . fst) nl + -- DotEdge n -> (Path, DotEdge n) inClust de@(DotEdge n1 n2 _) = (flip (,) de) . map fst . takeWhile (uncurry (==)) $ zip (nl' Map.! n1) (nl' Map.! n2) @@ -243,25 +316,6 @@ . Map.fromListWith (flip DList.append) . map (last *** DList.singleton) --- Return only those attributes that are required within the inner --- sub-graph. Also returns the overrides. -innerAttributes :: Attributes -> SAttrs - -> Attributes -> (Attributes, Attributes) -innerAttributes outer outerS inner = (sort $ inner' ++ override, override) - where - -- Remove all Attributes that are also defined in the outer cluster - inner' = inner \\ outer - - -- Need to consider those Attributes that were defined /after/ this value - override = mapMaybe defAttr . unSame - $ outerS `Set.difference` toSAttr inner - - -- A version of defaultAttributeValue that returns Nothing if the - -- value it is replacing /is/ the default. - defAttr a = case defaultAttributeValue a of - Just a' | a == a' -> Nothing - ma' -> ma' - -- ----------------------------------------------------------------------------- {- $transitive @@ -300,6 +354,8 @@ Note that transitive reduction only makes sense for directed graphs; for undirected graphs these functions are identical to the canonicalisation functions above. + + The caveats for the canonicalisation functions also apply. -} transitiveReduction :: (DotRepr dg n) => dg n -> DotGraph n @@ -309,13 +365,12 @@ -> dg n -> DotGraph n transitiveReductionOptions opts dg = cdg { strictGraph = graphIsStrict dg , directedGraph = graphIsDirected dg - , graphID = getID dg } where - cdg = createCanonical opts gas cl nl es' - (gas, cl) = graphStructureInformation dg - nl = nodeInformation True dg - es = edgeInformation True dg + cdg = createCanonical opts (getID dg) gas cl nl es' + (gas, cl) = graphStructureInformationClean dg + nl = nodeInformationClean True dg + es = edgeInformationClean True dg es' | graphIsDirected dg = rmTransEdges es | otherwise = es @@ -327,7 +382,7 @@ esMS = do edgeGraph tes ns <- getsMap Map.keys - mapM_ (traverse zeroTag) ns + mapM_ (traverseTag zeroTag) ns esM = fst $ execState esMS (Map.empty, Set.empty) @@ -387,13 +442,12 @@ } -- Perform a DFS to determine whether or not to keep each edge. -traverse :: (Ord n) => Tag -> n -> TagState n () -traverse t n = do setMark True - checkIncoming - outEs <- getsMap (maybe [] outgoing . Map.lookup n) - mapM_ maybeRecurse outEs - setMark False - +traverseTag :: (Ord n) => Tag -> n -> TagState n () +traverseTag t n = do setMark True + checkIncoming + outEs <- getsMap (maybe [] outgoing . Map.lookup n) + mapM_ maybeRecurse outEs + setMark False where setMark mrk = modifyMap (Map.adjust (\tv -> tv { marked = mrk }) n) @@ -416,4 +470,4 @@ delSet <- getSet let n' = toNode e unless (isMarked m n' || t' `Set.member` delSet) - $ traverse t' n' + $ traverseTag t' n' diff --git a/Data/GraphViz/Algorithms/Clustering.hs b/Data/GraphViz/Algorithms/Clustering.hs --- a/Data/GraphViz/Algorithms/Clustering.hs +++ b/Data/GraphViz/Algorithms/Clustering.hs @@ -32,11 +32,11 @@ -- | Extract the clusters and nodes from the list of nodes. clustersToNodes :: (Ord c) => ((n,a) -> NodeCluster c (n,l)) - -> (c -> GraphID) -> (c -> [GlobalAttributes]) + -> (c -> Bool) -> (c -> GraphID) -> (c -> [GlobalAttributes]) -> ((n,l) -> Attributes) -> [(n,a)] -> ([DotSubGraph n], [DotNode n]) -clustersToNodes clusterBy cID fmtCluster fmtNode - = treesToDot cID fmtCluster fmtNode +clustersToNodes clusterBy isC cID fmtCluster fmtNode + = treesToDot isC cID fmtCluster fmtNode . collapseNClusts . map (clustToTree . clusterBy) @@ -84,23 +84,23 @@ -- | Convert the cluster representation of the trees into 'DotNode's -- and 'DotSubGraph's (with @'isCluster' = 'True'@, and -- @'subGraphID' = 'Nothing'@). -treesToDot :: (c -> GraphID) -> (c -> [GlobalAttributes]) +treesToDot :: (c -> Bool) -> (c -> GraphID) -> (c -> [GlobalAttributes]) -> ((n,a) -> Attributes) -> [ClusterTree c (n,a)] -> ([DotSubGraph n], [DotNode n]) -treesToDot cID fmtCluster fmtNode +treesToDot isC cID fmtCluster fmtNode = partitionEithers - . map (treeToDot cID fmtCluster fmtNode) + . map (treeToDot isC cID fmtCluster fmtNode) -- | Convert this 'ClusterTree' into its /Dot/ representation. -treeToDot :: (c -> GraphID) -> (c -> [GlobalAttributes]) +treeToDot :: (c -> Bool) -> (c -> GraphID) -> (c -> [GlobalAttributes]) -> ((n,a) -> Attributes) -> ClusterTree c (n,a) -> Either (DotSubGraph n) (DotNode n) -treeToDot _ _ fmtNode (NT ln) +treeToDot _ _ _ fmtNode (NT ln) = Right DotNode { nodeID = fst ln , nodeAttributes = fmtNode ln } -treeToDot cID fmtCluster fmtNode (CT c nts) - = Left DotSG { isCluster = True +treeToDot isC cID fmtCluster fmtNode (CT c nts) + = Left DotSG { isCluster = isC c , subGraphID = Just $ cID c , subGraphStmts = stmts } @@ -110,4 +110,4 @@ , nodeStmts = ns , edgeStmts = [] } - (cs, ns) = treesToDot cID fmtCluster fmtNode nts + (cs, ns) = treesToDot isC cID fmtCluster fmtNode nts diff --git a/Data/GraphViz/Attributes.hs b/Data/GraphViz/Attributes.hs --- a/Data/GraphViz/Attributes.hs +++ b/Data/GraphViz/Attributes.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} {- | Module : Data.GraphViz.Attributes @@ -54,6 +54,8 @@ , invis , filled , diagonals + , striped + , wedged , rounded , tapered , radial @@ -91,12 +93,18 @@ , RankType(..) ) where -import Data.GraphViz.Attributes.Complete -import Data.GraphViz.Attributes.Colors.X11 -import qualified Data.GraphViz.Attributes.HTML as Html +import Data.GraphViz.Attributes.Arrows +import Data.GraphViz.Attributes.Colors +import Data.GraphViz.Attributes.Colors.X11 +import Data.GraphViz.Attributes.Complete (Attribute (..), + Attributes) +import qualified Data.GraphViz.Attributes.HTML as Html +import Data.GraphViz.Attributes.Internal +import Data.GraphViz.Attributes.Values +import qualified Data.Text as ST +import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as T -import Data.Text.Lazy(Text) -- ----------------------------------------------------------------------------- @@ -145,7 +153,7 @@ textLabel = toLabel -- | Create a label /outside/ of a node\/edge. Currently only in the --- | Graphviz development branch (2.29.*). +-- Graphviz development branch (2.29.*). xLabel :: (Labellable a) => a -> Attribute xLabel = XLabel . toLabelValue @@ -165,6 +173,9 @@ instance Labellable Text where toLabelValue = StrLabel +instance Labellable ST.Text where + toLabelValue = toLabelValue . T.fromStrict + instance Labellable Char where toLabelValue = toLabelValue . T.singleton @@ -222,24 +233,24 @@ -- clusters, if @'style' 'filled'@ is used, then 'fillColor' will -- override it. bgColor :: (NamedColor nc) => nc -> Attribute -bgColor = BgColor . (:[]) . toColor +bgColor = BgColor . toColorList . (:[]) . toColor -- | As with 'bgColor', but add a second color to create a gradient -- effect. Requires Graphviz >= 2.29.0. bgColors :: (NamedColor nc) => nc -> nc -> Attribute -bgColors c1 c2 = BgColor $ map toColor [c1,c2] +bgColors c1 c2 = BgColor . toColorList $ map toColor [c1,c2] -- | Specify the fill color of a node, cluster or arrowhead. Requires -- @'style' 'filled'@ for nodes and clusters. For nodes and edges, -- if this isn't set then the 'color' value is used instead; for -- clusters, 'bgColor' is used. fillColor :: (NamedColor nc) => nc -> Attribute -fillColor = FillColor . (:[]) . toColor +fillColor = FillColor . toColorList . (:[]) . toColor -- | As with 'fillColor', but add a second color to create a gradient -- effect. Requires Graphviz >= 2.29.0. fillColors :: (NamedColor nc) => nc -> nc -> Attribute -fillColors c1 c2 = FillColor $ map toColor [c1,c2] +fillColors c1 c2 = FillColor . toColorList $ map toColor [c1,c2] -- | Specify the color of text. fontColor :: (NamedColor nc) => nc -> Attribute @@ -263,7 +274,7 @@ -- background color of nodes and clusters unless 'fillColor' or -- 'bgColor' respectively is set. color :: (NamedColor nc) => nc -> Attribute -color = Color . (:[]) . toColor +color = Color . toColorList . (:[]) . toColor -- ----------------------------------------------------------------------------- @@ -316,6 +327,16 @@ diagonals :: Style diagonals = SItem Diagonals [] +-- | Only available for rectangularly-shaped nodes and +-- clusters. Requires Graphviz >= 2.30.0. +striped :: Style +striped = SItem Striped [] + +-- | Only available for elliptically-shaped nodes. Requires Graphviz +-- >= 2.30.0. +wedged :: Style +wedged = SItem Wedged [] + -- | Only available for edges; creates a tapered edge between the two -- nodes. Requires Graphviz >= 2.29.0. tapered :: Style @@ -362,10 +383,9 @@ edgeEnds :: DirType -> Attribute edgeEnds = Dir -box, crow, diamond, dotArrow, inv, noArrow, normal, tee, vee :: Arrow +box, crow, diamond, dotArrow, inv, noArrow, tee, vee :: Arrow oDot, invDot, invODot, oBox, oDiamond :: Arrow -normal = AType [(noMods, Normal)] inv = AType [(noMods, Inv)] dotArrow = AType [(noMods, DotArrow)] invDot = AType [ (noMods, Inv) diff --git a/Data/GraphViz/Attributes/Arrows.hs b/Data/GraphViz/Attributes/Arrows.hs new file mode 100644 --- /dev/null +++ b/Data/GraphViz/Attributes/Arrows.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE CPP, OverloadedStrings #-} +{-# OPTIONS_HADDOCK hide #-} +{- | + Module : Data.GraphViz.Attributes.Arrows + Description : Arrow types + Copyright : (c) Ivan Lazar Miljenovic + License : 3-Clause BSD-style + Maintainer : Ivan.Miljenovic@gmail.com + + + + -} +module Data.GraphViz.Attributes.Arrows where + +import Data.GraphViz.Internal.Util (bool) +import Data.GraphViz.Parsing +import Data.GraphViz.Printing + +import Data.Maybe (isJust) + +#if !MIN_VERSION_base (4,13,0) +import Data.Monoid ((<>)) +#endif + +-- ----------------------------------------------------------------------------- + +-- | /Dot/ has a basic grammar of arrow shapes which allows usage of +-- up to 1,544,761 different shapes from 9 different basic +-- 'ArrowShape's. Note that whilst an explicit list is used in the +-- definition of 'ArrowType', there must be at least one tuple and a +-- maximum of 4 (since that is what is required by Dot). For more +-- information, see: +-- +-- The 19 basic arrows shown on the overall attributes page have +-- been defined below as a convenience. Parsing of the 5 +-- backward-compatible special cases is also supported. +newtype ArrowType = AType [(ArrowModifier, ArrowShape)] + deriving (Eq, Ord, Show, Read) + +-- Used for default +normal :: ArrowType +normal = AType [(noMods, Normal)] + +-- Used for backward-compatible parsing +eDiamond, openArr, halfOpen, emptyArr, invEmpty :: ArrowType + +eDiamond = AType [(openMod, Diamond)] +openArr = AType [(noMods, Vee)] +halfOpen = AType [(ArrMod FilledArrow LeftSide, Vee)] +emptyArr = AType [(openMod, Normal)] +invEmpty = AType [ (noMods, Inv) + , (openMod, Normal)] + +instance PrintDot ArrowType where + unqtDot (AType mas) = hcat $ mapM appMod mas + where + appMod (m, a) = unqtDot m <> unqtDot a + +instance ParseDot ArrowType where + parseUnqt = specialArrowParse + `onFail` + (AType <$> many1 (liftA2 (,) parseUnqt parseUnqt)) + +specialArrowParse :: Parse ArrowType +specialArrowParse = stringValue [ ("ediamond", eDiamond) + , ("open", openArr) + , ("halfopen", halfOpen) + , ("empty", emptyArr) + , ("invempty", invEmpty) + ] + +data ArrowShape = Box + | Crow + | Diamond + | DotArrow + | Inv + | NoArrow + | Normal + | Tee + | Vee + deriving (Eq, Ord, Bounded, Enum, Show, Read) + +instance PrintDot ArrowShape where + unqtDot Box = text "box" + unqtDot Crow = text "crow" + unqtDot Diamond = text "diamond" + unqtDot DotArrow = text "dot" + unqtDot Inv = text "inv" + unqtDot NoArrow = text "none" + unqtDot Normal = text "normal" + unqtDot Tee = text "tee" + unqtDot Vee = text "vee" + +instance ParseDot ArrowShape where + parseUnqt = stringValue [ ("box", Box) + , ("crow", Crow) + , ("diamond", Diamond) + , ("dot", DotArrow) + , ("inv", Inv) + , ("none", NoArrow) + , ("normal", Normal) + , ("tee", Tee) + , ("vee", Vee) + ] + +-- | What modifications to apply to an 'ArrowShape'. +data ArrowModifier = ArrMod { arrowFill :: ArrowFill + , arrowSide :: ArrowSide + } + deriving (Eq, Ord, Show, Read) + +-- | Apply no modifications to an 'ArrowShape'. +noMods :: ArrowModifier +noMods = ArrMod FilledArrow BothSides + +-- | 'OpenArrow' and 'BothSides' +openMod :: ArrowModifier +openMod = ArrMod OpenArrow BothSides + +instance PrintDot ArrowModifier where + unqtDot (ArrMod f s) = unqtDot f <> unqtDot s + +instance ParseDot ArrowModifier where + parseUnqt = liftA2 ArrMod parseUnqt parseUnqt + +data ArrowFill = OpenArrow + | FilledArrow + deriving (Eq, Ord, Bounded, Enum, Show, Read) + +instance PrintDot ArrowFill where + unqtDot OpenArrow = char 'o' + unqtDot FilledArrow = empty + +instance ParseDot ArrowFill where + parseUnqt = bool FilledArrow OpenArrow . isJust <$> optional (character 'o') + + -- Not used individually + parse = parseUnqt + +-- | Represents which side (when looking towards the node the arrow is +-- pointing to) is drawn. +data ArrowSide = LeftSide + | RightSide + | BothSides + deriving (Eq, Ord, Bounded, Enum, Show, Read) + +instance PrintDot ArrowSide where + unqtDot LeftSide = char 'l' + unqtDot RightSide = char 'r' + unqtDot BothSides = empty + +instance ParseDot ArrowSide where + parseUnqt = getSideType <$> optional (oneOf $ map character ['l', 'r']) + where + getSideType = maybe BothSides + (bool RightSide LeftSide . (==) 'l') + + -- Not used individually + parse = parseUnqt diff --git a/Data/GraphViz/Attributes/Colors.hs b/Data/GraphViz/Attributes/Colors.hs --- a/Data/GraphViz/Attributes/Colors.hs +++ b/Data/GraphViz/Attributes/Colors.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP, OverloadedStrings #-} {- | Module : Data.GraphViz.Attributes.Colors @@ -24,36 +24,44 @@ ColorScheme(..) -- * Colors , Color(..) + , ColorList + , WeightedColor(..) + , toWC + , toColorList , NamedColor(toColor) + , toWColor -- * Conversion to\/from @Colour@. , toColour , fromColour , fromAColour ) where +import Data.GraphViz.Attributes.Colors.Brewer (BrewerColor(..)) +import Data.GraphViz.Attributes.Colors.SVG (SVGColor, svgColour) +import Data.GraphViz.Attributes.Colors.X11 (X11Color(Transparent), x11Colour) +import Data.GraphViz.Attributes.ColorScheme (ColorScheme(..)) +import Data.GraphViz.Exception +import Data.GraphViz.Internal.State +import Data.GraphViz.Internal.Util (bool) import Data.GraphViz.Parsing import Data.GraphViz.Printing -import Data.GraphViz.State -import Data.GraphViz.Attributes.ColorScheme(ColorScheme(..)) -import Data.GraphViz.Attributes.Colors.X11(X11Color(Transparent), x11Colour) -import Data.GraphViz.Attributes.Colors.SVG(SVGColor, svgColour) -import Data.GraphViz.Attributes.Colors.Brewer(BrewerColor(..)) -import Data.GraphViz.Util(bool) -import Data.GraphViz.Exception -import Data.Colour( AlphaColour, opaque, withOpacity - , over, black, alphaChannel, darken) -import Data.Colour.SRGB(Colour, sRGB, sRGB24, toSRGB24) -import Data.Colour.RGBSpace(uncurryRGB) -import Data.Colour.RGBSpace.HSV(hsv) +import Data.Colour (AlphaColour, alphaChannel, black, darken, + opaque, over, withOpacity) +import Data.Colour.RGBSpace (uncurryRGB) +import Data.Colour.RGBSpace.HSV (hsv) +import Data.Colour.SRGB (Colour, sRGB, sRGB24, toSRGB24) -import Data.Char(isHexDigit) -import Numeric(showHex, readHex) -import Data.Maybe(isJust) -import Data.Word(Word8) +import Data.Char (isHexDigit) +import Data.Maybe (isJust) import qualified Data.Text.Lazy as T -import Control.Monad(liftM) +import Data.Word (Word8) +import Numeric (readHex, showHex) +#if !MIN_VERSION_base (4,13,0) +import Data.Monoid ((<>)) +#endif + -- ----------------------------------------------------------------------------- -- | Defining a color for use with Graphviz. Note that named colors @@ -122,25 +130,25 @@ , parseNC (undefined :: SVGColor) False , parseX11Color False ] + `onFail` + fail "Could not parse Color" where parseHexBased - = do character '#' - cs <- many1 parse2Hex + = character '#' *> + do cs <- many1 parse2Hex return $ case cs of [r,g,b] -> RGB r g b [r,g,b,a] -> RGBA r g b a _ -> throw . NotDotCode $ "Not a valid hex Color specification: " ++ show cs - parseHSV = do h <- parse - parseSep - s <- parse - parseSep - v <- parse - return $ HSV h s v - parseSep = oneOf [ string "," - , whitespace1 - ] + parseHSV = HSV <$> parseUnqt + <* parseSep + <*> parseUnqt + <* parseSep + <*> parseUnqt + parseSep = character ',' *> whitespace <|> whitespace1 + parse2Hex = do c1 <- satisfy isHexDigit c2 <- satisfy isHexDigit let [(n, [])] = readHex [c1, c2] @@ -152,11 +160,17 @@ , parseNC (undefined :: SVGColor) True , parseX11Color True ] + `onFail` + fail "Could not parse Color" parseUnqtList = sepBy1 parseUnqt (character ':') + `onFail` + do cs <- getColorScheme + failBad $ "Error parsing list of Colors with color scheme of " + ++ show cs - parseList = liftM (:[]) - -- Unquoted single color + parseList = fmap (:[]) + -- Potentially unquoted single color (oneOf [ parseNC (undefined :: BrewerColor) True , parseNC (undefined :: SVGColor) True , parseX11Color True @@ -164,7 +178,66 @@ ) `onFail` quotedParse parseUnqtList + `onFail` + do cs <- getColorScheme + failBad $ "Error parsing list of Colors with color scheme of " + ++ show cs +-- | The sum of the optional weightings /must/ sum to at most @1@. +type ColorList = [WeightedColor] + +-- | A 'Color' tagged with an optional weighting. +data WeightedColor = WC { wColor :: Color + -- | Must be in range @0 <= W <= 1@. + , weighting :: Maybe Double + } + deriving (Eq, Ord, Show, Read) + +-- | For colors without weightings. +toWC :: Color -> WeightedColor +toWC = (`WC` Nothing) + +-- | For a list of colors without weightings. +toColorList :: [Color] -> ColorList +toColorList = map toWC + +instance PrintDot WeightedColor where + unqtDot (WC c mw) = unqtDot c + <> maybe empty ((semi<>) . unqtDot) mw + + toDot (WC c Nothing) = toDot c + toDot wc = dquotes $ unqtDot wc + + unqtListToDot = hcat . punctuate colon . mapM unqtDot + + -- Might not need quoting + listToDot [wc] = toDot wc + listToDot wcs = dquotes $ unqtListToDot wcs + +instance ParseDot WeightedColor where + parseUnqt = WC <$> parseUnqt <*> optional (character ';' *> parseUnqt) + + parse = quotedParse parseUnqt + `onFail` + -- Using parse rather than parseUnqt as there shouldn't be + -- any quotes, but to avoid copy-pasting the oneOf block. + (toWC <$> parse) + + parseUnqtList = sepBy1 parseUnqt (character ':') + `onFail` + do cs <- getColorScheme + failBad $ "Error parsing a ColorList with color scheme of " + ++ show cs + + parseList = quotedParse parseUnqtList + `onFail` + ((:[]) . toWC <$> parse) + -- Potentially unquoted un-weighted single color + `onFail` + do cs <- getColorScheme + failBad $ "Error parsing ColorList with color scheme of " + ++ show cs + -- ----------------------------------------------------------------------------- -- | More easily convert named colors to an overall 'Color' value. @@ -175,11 +248,15 @@ printNC :: Bool -> nc -> DotCode + -- | Bool is for whether quoting is needed. parseNC' :: Bool -> Parse nc +toWColor :: (NamedColor nc) => nc -> WeightedColor +toWColor = toWC . toColor + -- First value just used for type parseNC :: (NamedColor nc) => nc -> Bool -> Parse Color -parseNC nc q = fmap (toColor . flip asTypeOf nc) +parseNC nc q = fmap (toColor . (`asTypeOf` nc)) $ parseNC' q instance NamedColor BrewerColor where @@ -230,11 +307,11 @@ cs = colorScheme c lv = fl c -parseNamedColor :: (NamedColor nc, ParseDot lv) +parseNamedColor :: (ParseDot lv) => (ColorScheme -> Maybe cs) -> Parse cs -> (cs -> Bool) -> (cs -> lv -> nc) -> Bool -> Parse nc parseNamedColor gcs parseCS vcs mkC q - = do Just cs <- gcs `fmap` getColorScheme + = do Just cs <- gcs <$> getColorScheme lv <- bool parseUnqt parse q `onFail` mQts (string "//" *> parseUnqt) @@ -244,8 +321,7 @@ cs <- parseCS character '/' if vcs cs - then do lv <- parseUnqt - return $ mkC cs lv + then mkC cs <$> parseUnqt else fail "Explicit colorscheme not as expected." ) where @@ -256,16 +332,16 @@ -- X11 has a special case when parsing: '/yyyy' parseX11Color :: Bool -> Parse Color -parseX11Color q = fmap X11Color - $ parseNC' q - `onFail` - bool id quotedParse q (character '/' *> parseUnqt) - `onFail` - -- Can use X11 colors within brewer colorscheme. - do cs <- getColorScheme - case cs of - Brewer{} -> bool parseUnqt parse q - _ -> fail "Unable to parse an X11 color within Brewer" +parseX11Color q = X11Color + <$> parseNC' q + `onFail` + bool id quotedParse q (character '/' *> parseUnqt) + `onFail` + -- Can use X11 colors within brewer colorscheme. + do cs <- getColorScheme + case cs of + Brewer{} -> bool parseUnqt parse q + _ -> fail "Unable to parse an X11 color within Brewer" -- ----------------------------------------------------------------------------- diff --git a/Data/GraphViz/Attributes/Complete.hs b/Data/GraphViz/Attributes/Complete.hs --- a/Data/GraphViz/Attributes/Complete.hs +++ b/Data/GraphViz/Attributes/Complete.hs @@ -1,2892 +1,1606 @@ -{-# LANGUAGE OverloadedStrings #-} - -{- | - Module : Data.GraphViz.Attributes.Complete - Description : Definition of the Graphviz attributes. - Copyright : (c) Matthew Sackman, Ivan Lazar Miljenovic - License : 3-Clause BSD-style - Maintainer : Ivan.Miljenovic@gmail.com - - If you are just using graphviz to create basic Dot graphs, then you - probably want to use "Data.GraphViz.Attributes" rather than this - module. - - This module defines the various attributes that different parts of - a Graphviz graph can have. These attributes are based on the - documentation found at: - - - For more information on usage, etc. please see that document. - - A summary of known current constraints\/limitations\/differences: - - * Note that for an edge, in /Dot/ parlance if the edge goes from - /A/ to /B/, then /A/ is the tail node and /B/ is the head node - (since /A/ is at the tail end of the arrow). - - * @ColorList@, @DoubleList@ and @PointfList@ are defined as actual - lists (@'LayerList'@ needs a newtype for other reasons). All of these - are assumed to be non-empty lists. - - * For the various @*Color@ attributes that take in a list of - 'Color' values, usually only one color is used. The @Color@ - attribute for edges allows multiple values; for other attributes, - two values are supported for gradient fills in Graphviz >= - 2.29.0. - - * Style is implemented as a list of 'StyleItem' values; note that - empty lists are not allowed. - - * A lot of values have a possible value of @none@. These now - have custom constructors. In fact, most constructors have been - expanded upon to give an idea of what they represent rather than - using generic terms. - - * @PointF@ and 'Point' have been combined. The optional '!' and - third value for Point are also available. - - * 'Rect' uses two 'Point' values to denote the lower-left and - top-right corners. - - * The two 'LabelLoc' attributes have been combined. - - * @SplineType@ has been replaced with @['Spline']@. - - * Only polygon-based 'Shape's are available. - - * Not every 'Attribute' is fully documented/described. However, - all those which have specific allowed values should be covered. - - * Deprecated 'Overlap' algorithms are not defined. - - * The global @Orientation@ attribute is not defined, as it is - difficult to distinguish from the node-based 'Orientation' - 'Attribute'; also, its behaviour is duplicated by 'Rotate'. - - * The @charset@ attribute is not available, as graphviz only - supports UTF-8 encoding (as it is not currently feasible nor needed to - also support Latin1 encoding). - - * In Graphviz, when a node or edge has a list of attributes, the - colorscheme which is used to identify a color can be set /after/ - that color (e.g. @[colorscheme=x11,color=grey,colorscheme=svg]@ - uses the svg colorscheme's definition of grey, which is different - from the x11 one. Instead, graphviz parses them in order. - - -} -module Data.GraphViz.Attributes.Complete - ( -- * The actual /Dot/ attributes. - -- $attributes - Attribute(..) - , Attributes - , sameAttribute - , defaultAttributeValue - -- ** Validity functions on @Attribute@ values. - , usedByGraphs - , usedBySubGraphs - , usedByClusters - , usedByNodes - , usedByEdges - , validUnknown - - -- ** Custom attributes. - , AttributeName - , CustomAttribute - , customAttribute - , isCustom - , isSpecifiedCustom - , customValue - , customName - , findCustoms - , findSpecifiedCustom - , deleteCustomAttributes - , deleteSpecifiedCustom - - -- * Value types for @Attribute@s. - , module Data.GraphViz.Attributes.Colors - - -- ** Labels - , EscString - , Label(..) - , VerticalPlacement(..) - , LabelScheme(..) - -- *** Types representing the Dot grammar for records. - , RecordFields - , RecordField(..) - , Rect(..) - , Justification(..) - - -- ** Nodes - , Shape(..) - , Paths(..) - , ScaleType(..) - - -- ** Edges - , DirType(..) - , EdgeType(..) - -- *** Modifying where edges point - , PortName(..) - , PortPos(..) - , CompassPoint(..) - -- *** Arrows - , ArrowType(..) - , ArrowShape(..) - , ArrowModifier(..) - , ArrowFill(..) - , ArrowSide(..) - -- **** @ArrowModifier@ values - , noMods - , openMod - - -- ** Positioning - , Point(..) - , createPoint - , Pos(..) - , Spline(..) - , DPoint(..) - - -- ** Layout - , AspectType(..) - , ClusterMode(..) - , Model(..) - , Overlap(..) - , Root(..) - , Order(..) - , OutputMode(..) - , Pack(..) - , PackMode(..) - , PageDir(..) - , QuadType(..) - , RankType(..) - , RankDir(..) - , StartType(..) - , ViewPort(..) - , FocusType(..) - , Ratios(..) - - -- ** Modes - , ModeType(..) - , DEConstraints(..) - - -- ** Layers - , LayerSep(..) - , LayerRange(..) - , LayerID(..) - , LayerList(..) - - -- ** Stylistic - , SmoothType(..) - , STStyle(..) - , StyleItem(..) - , StyleName(..) - ) where - -import Data.GraphViz.Attributes.Colors -import Data.GraphViz.Attributes.Colors.X11(X11Color(Transparent, Black)) -import qualified Data.GraphViz.Attributes.HTML as Html -import Data.GraphViz.Attributes.Internal -import Data.GraphViz.Util -import Data.GraphViz.Parsing -import Data.GraphViz.Printing -import Data.GraphViz.State(getLayerSep, setLayerSep) -import Data.GraphViz.Exception(GraphvizException(NotCustomAttr), throw) - -import Data.List(partition, intercalate) -import Data.Maybe(isJust) -import Data.Word(Word16) -import qualified Data.Set as S -import qualified Data.Text.Lazy as T -import Data.Text.Lazy(Text) -import Control.Monad(liftM, liftM2) -import System.FilePath(searchPathSeparator, splitSearchPath) - --- ----------------------------------------------------------------------------- - -{- $attributes - - These attributes have been implemented in a /permissive/ manner: - that is, rather than split them up based on which type of value - they are allowed, they have all been included in the one data type, - with functions to determine if they are indeed valid for what - they're being applied to. - - To interpret the /Valid for/ listings: - - [@G@] Valid for Graphs. - - [@C@] Valid for Clusters. - - [@S@] Valid for Sub-Graphs (and also Clusters). - - [@N@] Valid for Nodes. - - [@E@] Valid for Edges. - - The /Default/ listings are those that the various Graphviz commands - use if that 'Attribute' isn't specified (in cases where this is - /none/, this is equivalent to a 'Nothing' value; that is, no value - is used). The /Parsing Default/ listings represent what value is - used (i.e. corresponds to 'True') when the 'Attribute' name is - listed on its own in /Dot/ source code. - - Please note that the 'UnknownAttribute' 'Attribute' is defined - primarily for backwards-compatibility purposes. It is possible to use - it directly for custom purposes; for more information, please see - 'CustomAttribute'. The 'deleteCustomAttributes' can be used to delete - these values. - - -} - --- | Attributes are used to customise the layout and design of Dot --- graphs. Care must be taken to ensure that the attribute you use --- is valid, as not all attributes can be used everywhere. -data Attribute - = Damping Double -- ^ /Valid for/: G; /Default/: @0.99@; /Minimum/: @0.0@; /Notes/: neato only - | K Double -- ^ /Valid for/: GC; /Default/: @0.3@; /Minimum/: @0@; /Notes/: sfdp, fdp only - | URL EscString -- ^ /Valid for/: ENGC; /Default/: none; /Notes/: svg, postscript, map only - | ArrowHead ArrowType -- ^ /Valid for/: E; /Default/: @'AType' [('noMods', 'Normal')]@ - | ArrowSize Double -- ^ /Valid for/: E; /Default/: @1.0@; /Minimum/: @0.0@ - | ArrowTail ArrowType -- ^ /Valid for/: E; /Default/: @'AType' [('noMods', 'Normal')]@ - | Aspect AspectType -- ^ /Valid for/: G; /Notes/: dot only - | BoundingBox Rect -- ^ /Valid for/: G; /Notes/: write only - | ColorScheme ColorScheme -- ^ /Valid for/: ENCG; /Default/: @'X11'@ - | BgColor [Color] -- ^ /Valid for/: GC; /Default/: @['X11Color' 'Transparent']@ - | Center Bool -- ^ /Valid for/: G; /Default/: @'False'@; /Parsing Default/: 'True' - | ClusterRank ClusterMode -- ^ /Valid for/: G; /Default/: @'Local'@; /Notes/: dot only - | Color [Color] -- ^ /Valid for/: ENC; /Default/: @['X11Color' 'Black']@ - | Comment Text -- ^ /Valid for/: ENG; /Default/: @\"\"@ - | Compound Bool -- ^ /Valid for/: G; /Default/: @'False'@; /Parsing Default/: 'True'; /Notes/: dot only - | Concentrate Bool -- ^ /Valid for/: G; /Default/: @'False'@; /Parsing Default/: 'True' - | Constraint Bool -- ^ /Valid for/: E; /Default/: @'True'@; /Parsing Default/: 'True'; /Notes/: dot only - | Decorate Bool -- ^ /Valid for/: E; /Default/: @'False'@; /Parsing Default/: 'True' - | DefaultDist Double -- ^ /Valid for/: G; /Default/: @1+(avg. len)*sqrt(|V|)@; /Minimum/: @epsilon@; /Notes/: neato only, only if @'Pack' 'DontPack'@ - | Dim Int -- ^ /Valid for/: G; /Default/: @2@; /Minimum/: @2@; /Notes/: sfdp, fdp, neato only - | Dimen Int -- ^ /Valid for/: G; /Default/: @2@; /Minimum/: @2@; /Notes/: sfdp, fdp, neato only - | Dir DirType -- ^ /Valid for/: E; /Default/: @'Forward'@ (directed), @'NoDir'@ (undirected) - | DirEdgeConstraints DEConstraints -- ^ /Valid for/: G; /Default/: @'NoConstraints'@; /Parsing Default/: 'EdgeConstraints'; /Notes/: neato only - | Distortion Double -- ^ /Valid for/: N; /Default/: @0.0@; /Minimum/: @-100.0@ - | DPI Double -- ^ /Valid for/: G; /Default/: @96.0@, @0.0@; /Notes/: svg, bitmap output only; \"resolution\" is a synonym - | EdgeURL EscString -- ^ /Valid for/: E; /Default/: @\"\"@; /Notes/: svg, map only - | EdgeTarget EscString -- ^ /Valid for/: E; /Default/: none; /Notes/: svg, map only - | EdgeTooltip EscString -- ^ /Valid for/: E; /Default/: @\"\"@; /Notes/: svg, cmap only - | Epsilon Double -- ^ /Valid for/: G; /Default/: @.0001 * # nodes@ (@mode == 'KK'@), @.0001@ (@mode == 'Major'@); /Notes/: neato only - | ESep DPoint -- ^ /Valid for/: G; /Default/: @'DVal' 3@; /Notes/: not dot - | FillColor [Color] -- ^ /Valid for/: NEC; /Default/: @['X11Color' 'LightGray']@ (nodes), @['X11Color' 'Black']@ (clusters) - | FixedSize Bool -- ^ /Valid for/: N; /Default/: @'False'@; /Parsing Default/: 'True' - | FontColor Color -- ^ /Valid for/: ENGC; /Default/: @'X11Color' 'Black'@ - | FontName Text -- ^ /Valid for/: ENGC; /Default/: @\"Times-Roman\"@ - | FontNames Text -- ^ /Valid for/: G; /Default/: @\"\"@; /Notes/: svg only - | FontPath Text -- ^ /Valid for/: G; /Default/: system dependent - | FontSize Double -- ^ /Valid for/: ENGC; /Default/: @14.0@; /Minimum/: @1.0@ - | ForceLabels Bool -- ^ /Valid for/: G; /Default/: @'False'@; /Parsing Default/: 'True'; /Notes/: Only for 'XLabel' attributes, requires Graphviz >= 2.29.0 - | GradientAngle Int -- ^ /Valid for/: NCG; /Default/: 0; /Notes/: requires Graphviz >= 2.29.0 - | Group Text -- ^ /Valid for/: N; /Default/: @\"\"@; /Notes/: dot only - | HeadURL EscString -- ^ /Valid for/: E; /Default/: @\"\"@; /Notes/: svg, map only - | HeadClip Bool -- ^ /Valid for/: E; /Default/: @'True'@; /Parsing Default/: 'True' - | HeadLabel Label -- ^ /Valid for/: E; /Default/: @'StrLabel' \"\"@ - | HeadPort PortPos -- ^ /Valid for/: E; /Default/: @'CompassPoint' 'CenterPoint'@ - | HeadTarget EscString -- ^ /Valid for/: E; /Default/: none; /Notes/: svg, map only - | HeadTooltip EscString -- ^ /Valid for/: E; /Default/: @\"\"@; /Notes/: svg, cmap only - | Height Double -- ^ /Valid for/: N; /Default/: @0.5@; /Minimum/: @0.02@ - | ID EscString -- ^ /Valid for/: GNE; /Default/: @\"\"@; /Notes/: svg, postscript, map only - | Image Text -- ^ /Valid for/: N; /Default/: @\"\"@ - | ImagePath Paths -- ^ /Valid for/: G; /Default/: @'Paths' []@; /Notes/: Printing and parsing is OS-specific, requires Graphviz >= 2.29.0 - | ImageScale ScaleType -- ^ /Valid for/: N; /Default/: @'NoScale'@; /Parsing Default/: 'UniformScale' - | Label Label -- ^ /Valid for/: ENGC; /Default/: @'StrLabel' \"\\N\"@ (nodes), @'StrLabel' \"\"@ (otherwise) - | LabelURL EscString -- ^ /Valid for/: E; /Default/: @\"\"@; /Notes/: svg, map only - | LabelScheme LabelScheme -- ^ /Valid for/: G; /Default/: @'NotEdgeLabel'@; /Notes/: sfdp only, requires Graphviz >= 2.28.0 - | LabelAngle Double -- ^ /Valid for/: E; /Default/: @-25.0@; /Minimum/: @-180.0@ - | LabelDistance Double -- ^ /Valid for/: E; /Default/: @1.0@; /Minimum/: @0.0@ - | LabelFloat Bool -- ^ /Valid for/: E; /Default/: @'False'@; /Parsing Default/: 'True' - | LabelFontColor Color -- ^ /Valid for/: E; /Default/: @'X11Color' 'Black'@ - | LabelFontName Text -- ^ /Valid for/: E; /Default/: @\"Times-Roman\"@ - | LabelFontSize Double -- ^ /Valid for/: E; /Default/: @14.0@; /Minimum/: @1.0@ - | LabelJust Justification -- ^ /Valid for/: GC; /Default/: @'JCenter'@ - | LabelLoc VerticalPlacement -- ^ /Valid for/: GCN; /Default/: @'VTop'@ (clusters), @'VBottom'@ (root graphs), @'VCenter'@ (nodes) - | LabelTarget EscString -- ^ /Valid for/: E; /Default/: none; /Notes/: svg, map only - | LabelTooltip EscString -- ^ /Valid for/: E; /Default/: @\"\"@; /Notes/: svg, cmap only - | Landscape Bool -- ^ /Valid for/: G; /Default/: @'False'@; /Parsing Default/: 'True' - | Layer LayerRange -- ^ /Valid for/: EN - | Layers LayerList -- ^ /Valid for/: G; /Default/: @'LL' []@ - | LayerSep LayerSep -- ^ /Valid for/: G; /Default/: @'LSep' \" :\t\"@ - | Layout Text -- ^ /Valid for/: G; /Default/: @\"\"@ - | Len Double -- ^ /Valid for/: E; /Default/: @1.0@ (neato), @0.3@ (fdp); /Notes/: fdp, neato only - | LevelsGap Double -- ^ /Valid for/: G; /Default/: @0.0@; /Notes/: neato only - | Levels Int -- ^ /Valid for/: G; /Default/: @'maxBound'@; /Minimum/: @0@; /Notes/: sfdp only - | LHead Text -- ^ /Valid for/: E; /Default/: @\"\"@; /Notes/: dot only - | LHeight Double -- ^ /Valid for/: GC; /Notes/: write only, requires Graphviz >= 2.28.0 - | LPos Point -- ^ /Valid for/: EGC; /Notes/: write only - | LTail Text -- ^ /Valid for/: E; /Default/: @\"\"@; /Notes/: dot only - | LWidth Double -- ^ /Valid for/: GC; /Notes/: write only, requires Graphviz >= 2.28.0 - | Margin DPoint -- ^ /Valid for/: NG; /Default/: device dependent - | MaxIter Int -- ^ /Valid for/: G; /Default/: @100 * # nodes@ (@mode == 'KK'@), @200@ (@mode == 'Major'@), @600@ (fdp); /Notes/: fdp, neato only - | MCLimit Double -- ^ /Valid for/: G; /Default/: @1.0@; /Notes/: dot only - | MinDist Double -- ^ /Valid for/: G; /Default/: @1.0@; /Minimum/: @0.0@; /Notes/: circo only - | MinLen Int -- ^ /Valid for/: E; /Default/: @1@; /Minimum/: @0@; /Notes/: dot only - | Mode ModeType -- ^ /Valid for/: G; /Default/: @'Major'@; /Notes/: neato only - | Model Model -- ^ /Valid for/: G; /Default/: @'ShortPath'@; /Notes/: neato only - | Mosek Bool -- ^ /Valid for/: G; /Default/: @'False'@; /Parsing Default/: 'True'; /Notes/: neato only; requires the Mosek software - | NodeSep Double -- ^ /Valid for/: G; /Default/: @0.25@; /Minimum/: @0.02@; /Notes/: dot only - | NoJustify Bool -- ^ /Valid for/: GCNE; /Default/: @'False'@; /Parsing Default/: 'True' - | Normalize Bool -- ^ /Valid for/: G; /Default/: @'False'@; /Parsing Default/: 'True'; /Notes/: not dot - | Nslimit Double -- ^ /Valid for/: G; /Notes/: dot only - | Nslimit1 Double -- ^ /Valid for/: G; /Notes/: dot only - | Ordering Order -- ^ /Valid for/: GN; /Default/: none; /Notes/: dot only - | Orientation Double -- ^ /Valid for/: N; /Default/: @0.0@; /Minimum/: @360.0@ - | OutputOrder OutputMode -- ^ /Valid for/: G; /Default/: @'BreadthFirst'@ - | Overlap Overlap -- ^ /Valid for/: G; /Default/: @'KeepOverlaps'@; /Parsing Default/: 'KeepOverlaps'; /Notes/: not dot - | OverlapScaling Double -- ^ /Valid for/: G; /Default/: @-4@; /Minimum/: @-1.0e10@; /Notes/: prism only - | Pack Pack -- ^ /Valid for/: G; /Default/: @'DontPack'@; /Parsing Default/: 'DoPack'; /Notes/: not dot - | PackMode PackMode -- ^ /Valid for/: G; /Default/: @'PackNode'@; /Notes/: not dot - | Pad DPoint -- ^ /Valid for/: G; /Default/: @'DVal' 0.0555@ (4 points) - | Page Point -- ^ /Valid for/: G - | PageDir PageDir -- ^ /Valid for/: G; /Default/: @'Bl'@ - | PenColor Color -- ^ /Valid for/: C; /Default/: @'X11Color' 'Black'@ - | PenWidth Double -- ^ /Valid for/: CNE; /Default/: @1.0@; /Minimum/: @0.0@ - | Peripheries Int -- ^ /Valid for/: NC; /Default/: shape default (nodes), @1@ (clusters); /Minimum/: 0 - | Pin Bool -- ^ /Valid for/: N; /Default/: @'False'@; /Parsing Default/: 'True'; /Notes/: fdp, neato only - | Pos Pos -- ^ /Valid for/: EN - | QuadTree QuadType -- ^ /Valid for/: G; /Default/: @'NormalQT'@; /Parsing Default/: 'NormalQT'; /Notes/: sfdp only - | Quantum Double -- ^ /Valid for/: G; /Default/: @0.0@; /Minimum/: @0.0@ - | Rank RankType -- ^ /Valid for/: S; /Notes/: dot only - | RankDir RankDir -- ^ /Valid for/: G; /Default/: @'FromTop'@; /Notes/: dot only - | RankSep [Double] -- ^ /Valid for/: G; /Default/: @[0.5]@ (dot), @[1.0]@ (twopi); /Minimum/: [0.02]; /Notes/: twopi, dot only - | Ratio Ratios -- ^ /Valid for/: G - | Rects [Rect] -- ^ /Valid for/: N; /Notes/: write only - | Regular Bool -- ^ /Valid for/: N; /Default/: @'False'@; /Parsing Default/: 'True' - | ReMinCross Bool -- ^ /Valid for/: G; /Default/: @'False'@; /Parsing Default/: 'True'; /Notes/: dot only - | RepulsiveForce Double -- ^ /Valid for/: G; /Default/: @1.0@; /Minimum/: @0.0@; /Notes/: sfdp only - | Root Root -- ^ /Valid for/: GN; /Default/: @'NodeName' \"\"@ (graphs), @'NotCentral'@ (nodes); /Parsing Default/: 'IsCentral'; /Notes/: circo, twopi only - | Rotate Int -- ^ /Valid for/: G; /Default/: @0@ - | Rotation Double -- ^ /Valid for/: G; /Default/: @0@; /Notes/: sfdp only, requires Graphviz >= 2.28.0 - | SameHead Text -- ^ /Valid for/: E; /Default/: @\"\"@; /Notes/: dot only - | SameTail Text -- ^ /Valid for/: E; /Default/: @\"\"@; /Notes/: dot only - | SamplePoints Int -- ^ /Valid for/: N; /Default/: @8@ (output), @20@ (overlap and image maps) - | Scale DPoint -- ^ /Valid for/: G; /Notes/: twopi only, requires Graphviz >= 2.28.0 - | SearchSize Int -- ^ /Valid for/: G; /Default/: @30@; /Notes/: dot only - | Sep DPoint -- ^ /Valid for/: G; /Default/: @'DVal' 4@; /Notes/: not dot - | Shape Shape -- ^ /Valid for/: N; /Default/: @'Ellipse'@ - | ShapeFile Text -- ^ /Valid for/: N; /Default/: @\"\"@ - | ShowBoxes Int -- ^ /Valid for/: ENG; /Default/: @0@; /Minimum/: @0@; /Notes/: dot only - | Sides Int -- ^ /Valid for/: N; /Default/: @4@; /Minimum/: @0@ - | 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 Word16 -- ^ /Valid for/: GCN; /Default/: @0@; /Minimum/: @0@ - | Splines EdgeType -- ^ /Valid for/: G; /Parsing Default/: 'SplineEdges' - | Start StartType -- ^ /Valid for/: G; /Notes/: fdp, neato only - | Style [StyleItem] -- ^ /Valid for/: ENC - | StyleSheet Text -- ^ /Valid for/: G; /Default/: @\"\"@; /Notes/: svg only - | TailURL EscString -- ^ /Valid for/: E; /Default/: @\"\"@; /Notes/: svg, map only - | TailClip Bool -- ^ /Valid for/: E; /Default/: @'True'@; /Parsing Default/: 'True' - | TailLabel Label -- ^ /Valid for/: E; /Default/: @'StrLabel' \"\"@ - | TailPort PortPos -- ^ /Valid for/: E; /Default/: @'CompassPoint' 'CenterPoint'@ - | TailTarget EscString -- ^ /Valid for/: E; /Default/: none; /Notes/: svg, map only - | TailTooltip EscString -- ^ /Valid for/: E; /Default/: @\"\"@; /Notes/: svg, cmap only - | Target EscString -- ^ /Valid for/: ENGC; /Default/: none; /Notes/: svg, map only - | Tooltip EscString -- ^ /Valid for/: NEC; /Default/: @\"\"@; /Notes/: svg, cmap only - | TrueColor Bool -- ^ /Valid for/: G; /Parsing Default/: 'True'; /Notes/: bitmap output only - | Vertices [Point] -- ^ /Valid for/: N; /Notes/: write only - | ViewPort ViewPort -- ^ /Valid for/: G; /Default/: none - | VoroMargin Double -- ^ /Valid for/: G; /Default/: @0.05@; /Minimum/: @0.0@; /Notes/: not dot - | Weight Double -- ^ /Valid for/: E; /Default/: @1.0@; /Minimum/: @0@ (dot), @1@ (neato,fdp,sfdp) - | Width Double -- ^ /Valid for/: N; /Default/: @0.75@; /Minimum/: @0.01@ - | XLabel Label -- ^ /Valid for/: EN; /Default/: @'StrLabel' \"\"@; /Notes/: requires Graphviz >= 2.29.0 - | Z Double -- ^ /Valid for/: N; /Default/: @0.0@; /Minimum/: @-MAXFLOAT@, @-1000@ - | UnknownAttribute AttributeName Text -- ^ /Valid for/: Assumed valid for all; the fields are 'Attribute' name and value respectively. - deriving (Eq, Ord, Show, Read) - -type Attributes = [Attribute] - --- | The name for an UnknownAttribute; must satisfy 'validUnknown'. -type AttributeName = Text - -instance PrintDot Attribute where - unqtDot (Damping v) = printField "Damping" v - unqtDot (K v) = printField "K" v - unqtDot (URL v) = printField "URL" v - unqtDot (ArrowHead v) = printField "arrowhead" v - unqtDot (ArrowSize v) = printField "arrowsize" v - unqtDot (ArrowTail v) = printField "arrowtail" v - unqtDot (Aspect v) = printField "aspect" v - unqtDot (BoundingBox v) = printField "bb" v - unqtDot (ColorScheme v) = printField "colorscheme" v - unqtDot (BgColor v) = printField "bgcolor" v - unqtDot (Center v) = printField "center" v - unqtDot (ClusterRank v) = printField "clusterrank" v - unqtDot (Color v) = printField "color" v - unqtDot (Comment v) = printField "comment" v - unqtDot (Compound v) = printField "compound" v - unqtDot (Concentrate v) = printField "concentrate" v - unqtDot (Constraint v) = printField "constraint" v - unqtDot (Decorate v) = printField "decorate" v - unqtDot (DefaultDist v) = printField "defaultdist" v - unqtDot (Dim v) = printField "dim" v - unqtDot (Dimen v) = printField "dimen" v - unqtDot (Dir v) = printField "dir" v - unqtDot (DirEdgeConstraints v) = printField "diredgeconstraints" v - unqtDot (Distortion v) = printField "distortion" v - unqtDot (DPI v) = printField "dpi" v - unqtDot (EdgeURL v) = printField "edgeURL" v - unqtDot (EdgeTarget v) = printField "edgetarget" v - unqtDot (EdgeTooltip v) = printField "edgetooltip" v - unqtDot (Epsilon v) = printField "epsilon" v - unqtDot (ESep v) = printField "esep" v - unqtDot (FillColor v) = printField "fillcolor" v - unqtDot (FixedSize v) = printField "fixedsize" v - unqtDot (FontColor v) = printField "fontcolor" v - unqtDot (FontName v) = printField "fontname" v - unqtDot (FontNames v) = printField "fontnames" v - unqtDot (FontPath v) = printField "fontpath" v - unqtDot (FontSize v) = printField "fontsize" v - unqtDot (ForceLabels v) = printField "forcelabels" v - unqtDot (GradientAngle v) = printField "gradientangle" v - unqtDot (Group v) = printField "group" v - unqtDot (HeadURL v) = printField "headURL" v - unqtDot (HeadClip v) = printField "headclip" v - unqtDot (HeadLabel v) = printField "headlabel" v - unqtDot (HeadPort v) = printField "headport" v - unqtDot (HeadTarget v) = printField "headtarget" v - unqtDot (HeadTooltip v) = printField "headtooltip" v - unqtDot (Height v) = printField "height" v - unqtDot (ID v) = printField "id" v - unqtDot (Image v) = printField "image" v - unqtDot (ImagePath v) = printField "imagepath" v - unqtDot (ImageScale v) = printField "imagescale" v - unqtDot (Label v) = printField "label" v - unqtDot (LabelURL v) = printField "labelURL" v - unqtDot (LabelScheme v) = printField "label_scheme" v - unqtDot (LabelAngle v) = printField "labelangle" v - unqtDot (LabelDistance v) = printField "labeldistance" v - unqtDot (LabelFloat v) = printField "labelfloat" v - unqtDot (LabelFontColor v) = printField "labelfontcolor" v - unqtDot (LabelFontName v) = printField "labelfontname" v - unqtDot (LabelFontSize v) = printField "labelfontsize" v - unqtDot (LabelJust v) = printField "labeljust" v - unqtDot (LabelLoc v) = printField "labelloc" v - unqtDot (LabelTarget v) = printField "labeltarget" v - unqtDot (LabelTooltip v) = printField "labeltooltip" v - unqtDot (Landscape v) = printField "landscape" v - unqtDot (Layer v) = printField "layer" v - unqtDot (Layers v) = printField "layers" v - unqtDot (LayerSep v) = printField "layersep" v - unqtDot (Layout v) = printField "layout" v - unqtDot (Len v) = printField "len" v - unqtDot (LevelsGap v) = printField "levelsgap" v - unqtDot (Levels v) = printField "levels" v - unqtDot (LHead v) = printField "lhead" v - unqtDot (LHeight v) = printField "LHeight" v - unqtDot (LPos v) = printField "lp" v - unqtDot (LTail v) = printField "ltail" v - unqtDot (LWidth v) = printField "lwidth" v - unqtDot (Margin v) = printField "margin" v - unqtDot (MaxIter v) = printField "maxiter" v - unqtDot (MCLimit v) = printField "mclimit" v - unqtDot (MinDist v) = printField "mindist" v - unqtDot (MinLen v) = printField "minlen" v - unqtDot (Mode v) = printField "mode" v - unqtDot (Model v) = printField "model" v - unqtDot (Mosek v) = printField "mosek" v - unqtDot (NodeSep v) = printField "nodesep" v - unqtDot (NoJustify v) = printField "nojustify" v - unqtDot (Normalize v) = printField "normalize" v - unqtDot (Nslimit v) = printField "nslimit" v - unqtDot (Nslimit1 v) = printField "nslimit1" v - unqtDot (Ordering v) = printField "ordering" v - unqtDot (Orientation v) = printField "orientation" v - unqtDot (OutputOrder v) = printField "outputorder" v - unqtDot (Overlap v) = printField "overlap" v - unqtDot (OverlapScaling v) = printField "overlap_scaling" v - unqtDot (Pack v) = printField "pack" v - unqtDot (PackMode v) = printField "packmode" v - unqtDot (Pad v) = printField "pad" v - unqtDot (Page v) = printField "page" v - unqtDot (PageDir v) = printField "pagedir" v - unqtDot (PenColor v) = printField "pencolor" v - unqtDot (PenWidth v) = printField "penwidth" v - unqtDot (Peripheries v) = printField "peripheries" v - unqtDot (Pin v) = printField "pin" v - unqtDot (Pos v) = printField "pos" v - unqtDot (QuadTree v) = printField "quadtree" v - unqtDot (Quantum v) = printField "quantum" v - unqtDot (Rank v) = printField "rank" v - unqtDot (RankDir v) = printField "rankdir" v - unqtDot (RankSep v) = printField "ranksep" v - unqtDot (Ratio v) = printField "ratio" v - unqtDot (Rects v) = printField "rects" v - unqtDot (Regular v) = printField "regular" v - unqtDot (ReMinCross v) = printField "remincross" v - unqtDot (RepulsiveForce v) = printField "repulsiveforce" v - unqtDot (Root v) = printField "root" v - unqtDot (Rotate v) = printField "rotate" v - unqtDot (Rotation v) = printField "rotation" v - unqtDot (SameHead v) = printField "samehead" v - unqtDot (SameTail v) = printField "sametail" v - unqtDot (SamplePoints v) = printField "samplepoints" v - unqtDot (Scale v) = printField "scale" v - unqtDot (SearchSize v) = printField "searchsize" v - unqtDot (Sep v) = printField "sep" v - unqtDot (Shape v) = printField "shape" v - unqtDot (ShapeFile v) = printField "shapefile" v - unqtDot (ShowBoxes v) = printField "showboxes" v - unqtDot (Sides v) = printField "sides" v - unqtDot (Size v) = printField "size" v - unqtDot (Skew v) = printField "skew" v - unqtDot (Smoothing v) = printField "smoothing" v - unqtDot (SortV v) = printField "sortv" v - unqtDot (Splines v) = printField "splines" v - unqtDot (Start v) = printField "start" v - unqtDot (Style v) = printField "style" v - unqtDot (StyleSheet v) = printField "stylesheet" v - unqtDot (TailURL v) = printField "tailURL" v - unqtDot (TailClip v) = printField "tailclip" v - unqtDot (TailLabel v) = printField "taillabel" v - unqtDot (TailPort v) = printField "tailport" v - unqtDot (TailTarget v) = printField "tailtarget" v - unqtDot (TailTooltip v) = printField "tailtooltip" v - unqtDot (Target v) = printField "target" v - unqtDot (Tooltip v) = printField "tooltip" v - unqtDot (TrueColor v) = printField "truecolor" v - unqtDot (Vertices v) = printField "vertices" v - unqtDot (ViewPort v) = printField "viewport" v - unqtDot (VoroMargin v) = printField "voro_margin" v - unqtDot (Weight v) = printField "weight" v - unqtDot (Width v) = printField "width" v - unqtDot (XLabel v) = printField "xlabel" v - unqtDot (Z v) = printField "z" v - unqtDot (UnknownAttribute a v) = toDot a <> equals <> toDot v - - listToDot = unqtListToDot - -instance ParseDot Attribute where - parseUnqt = stringParse (concat [ parseField Damping "Damping" - , parseField K "K" - , parseFields URL ["URL", "href"] - , parseField ArrowHead "arrowhead" - , parseField ArrowSize "arrowsize" - , parseField ArrowTail "arrowtail" - , parseField Aspect "aspect" - , parseField BoundingBox "bb" - , parseField ColorScheme "colorscheme" - , parseField BgColor "bgcolor" - , parseFieldBool Center "center" - , parseField ClusterRank "clusterrank" - , parseField Color "color" - , parseField Comment "comment" - , parseFieldBool Compound "compound" - , parseFieldBool Concentrate "concentrate" - , parseFieldBool Constraint "constraint" - , parseFieldBool Decorate "decorate" - , parseField DefaultDist "defaultdist" - , parseField Dim "dim" - , parseField Dimen "dimen" - , parseField Dir "dir" - , parseFieldDef DirEdgeConstraints EdgeConstraints "diredgeconstraints" - , parseField Distortion "distortion" - , parseFields DPI ["dpi", "resolution"] - , parseFields EdgeURL ["edgeURL", "edgehref"] - , parseField EdgeTarget "edgetarget" - , parseField EdgeTooltip "edgetooltip" - , parseField Epsilon "epsilon" - , parseField ESep "esep" - , parseField FillColor "fillcolor" - , parseFieldBool FixedSize "fixedsize" - , parseField FontColor "fontcolor" - , parseField FontName "fontname" - , parseField FontNames "fontnames" - , parseField FontPath "fontpath" - , parseField FontSize "fontsize" - , parseFieldBool ForceLabels "forcelabels" - , parseField GradientAngle "gradientangle" - , parseField Group "group" - , parseFields HeadURL ["headURL", "headhref"] - , parseFieldBool HeadClip "headclip" - , parseField HeadLabel "headlabel" - , parseField HeadPort "headport" - , parseField HeadTarget "headtarget" - , parseField HeadTooltip "headtooltip" - , parseField Height "height" - , parseField ID "id" - , parseField Image "image" - , parseField ImagePath "imagepath" - , parseFieldDef ImageScale UniformScale "imagescale" - , parseField Label "label" - , parseFields LabelURL ["labelURL", "labelhref"] - , parseField LabelScheme "label_scheme" - , parseField LabelAngle "labelangle" - , parseField LabelDistance "labeldistance" - , parseFieldBool LabelFloat "labelfloat" - , parseField LabelFontColor "labelfontcolor" - , parseField LabelFontName "labelfontname" - , parseField LabelFontSize "labelfontsize" - , parseField LabelJust "labeljust" - , parseField LabelLoc "labelloc" - , parseField LabelTarget "labeltarget" - , parseField LabelTooltip "labeltooltip" - , parseFieldBool Landscape "landscape" - , parseField Layer "layer" - , parseField Layers "layers" - , parseField LayerSep "layersep" - , parseField Layout "layout" - , parseField Len "len" - , parseField LevelsGap "levelsgap" - , parseField Levels "levels" - , parseField LHead "lhead" - , parseField LHeight "LHeight" - , parseField LPos "lp" - , parseField LTail "ltail" - , parseField LWidth "lwidth" - , parseField Margin "margin" - , parseField MaxIter "maxiter" - , parseField MCLimit "mclimit" - , parseField MinDist "mindist" - , parseField MinLen "minlen" - , parseField Mode "mode" - , parseField Model "model" - , parseFieldBool Mosek "mosek" - , parseField NodeSep "nodesep" - , parseFieldBool NoJustify "nojustify" - , parseFieldBool Normalize "normalize" - , parseField Nslimit "nslimit" - , parseField Nslimit1 "nslimit1" - , parseField Ordering "ordering" - , parseField Orientation "orientation" - , parseField OutputOrder "outputorder" - , parseFieldDef Overlap KeepOverlaps "overlap" - , parseField OverlapScaling "overlap_scaling" - , parseFieldDef Pack DoPack "pack" - , parseField PackMode "packmode" - , parseField Pad "pad" - , parseField Page "page" - , parseField PageDir "pagedir" - , parseField PenColor "pencolor" - , parseField PenWidth "penwidth" - , parseField Peripheries "peripheries" - , parseFieldBool Pin "pin" - , parseField Pos "pos" - , parseFieldDef QuadTree NormalQT "quadtree" - , parseField Quantum "quantum" - , parseField Rank "rank" - , parseField RankDir "rankdir" - , parseField RankSep "ranksep" - , parseField Ratio "ratio" - , parseField Rects "rects" - , parseFieldBool Regular "regular" - , parseFieldBool ReMinCross "remincross" - , parseField RepulsiveForce "repulsiveforce" - , parseFieldDef Root IsCentral "root" - , parseField Rotate "rotate" - , parseField Rotation "rotation" - , parseField SameHead "samehead" - , parseField SameTail "sametail" - , parseField SamplePoints "samplepoints" - , parseField Scale "scale" - , parseField SearchSize "searchsize" - , parseField Sep "sep" - , parseField Shape "shape" - , parseField ShapeFile "shapefile" - , parseField ShowBoxes "showboxes" - , parseField Sides "sides" - , parseField Size "size" - , parseField Skew "skew" - , parseField Smoothing "smoothing" - , parseField SortV "sortv" - , parseFieldDef Splines SplineEdges "splines" - , parseField Start "start" - , parseField Style "style" - , parseField StyleSheet "stylesheet" - , parseFields TailURL ["tailURL", "tailhref"] - , parseFieldBool TailClip "tailclip" - , parseField TailLabel "taillabel" - , parseField TailPort "tailport" - , parseField TailTarget "tailtarget" - , parseField TailTooltip "tailtooltip" - , parseField Target "target" - , parseField Tooltip "tooltip" - , parseFieldBool TrueColor "truecolor" - , parseField Vertices "vertices" - , parseField ViewPort "viewport" - , parseField VoroMargin "voro_margin" - , parseField Weight "weight" - , parseField Width "width" - , parseField XLabel "xlabel" - , parseField Z "z" - ]) - `onFail` - liftM2 UnknownAttribute stringBlock (parseEq >> parse) - - parse = parseUnqt - - parseList = parseUnqtList - --- | Determine if this 'Attribute' is valid for use with Graphs. -usedByGraphs :: Attribute -> Bool -usedByGraphs Damping{} = True -usedByGraphs K{} = True -usedByGraphs URL{} = True -usedByGraphs Aspect{} = True -usedByGraphs BoundingBox{} = True -usedByGraphs ColorScheme{} = True -usedByGraphs BgColor{} = True -usedByGraphs Center{} = True -usedByGraphs ClusterRank{} = True -usedByGraphs Comment{} = True -usedByGraphs Compound{} = True -usedByGraphs Concentrate{} = True -usedByGraphs DefaultDist{} = True -usedByGraphs Dim{} = True -usedByGraphs Dimen{} = True -usedByGraphs DirEdgeConstraints{} = True -usedByGraphs DPI{} = True -usedByGraphs Epsilon{} = True -usedByGraphs ESep{} = True -usedByGraphs FontColor{} = True -usedByGraphs FontName{} = True -usedByGraphs FontNames{} = True -usedByGraphs FontPath{} = True -usedByGraphs FontSize{} = True -usedByGraphs ForceLabels{} = True -usedByGraphs GradientAngle{} = True -usedByGraphs ID{} = True -usedByGraphs ImagePath{} = True -usedByGraphs Label{} = True -usedByGraphs LabelScheme{} = True -usedByGraphs LabelJust{} = True -usedByGraphs LabelLoc{} = True -usedByGraphs Landscape{} = True -usedByGraphs Layers{} = True -usedByGraphs LayerSep{} = True -usedByGraphs Layout{} = True -usedByGraphs LevelsGap{} = True -usedByGraphs Levels{} = True -usedByGraphs LHeight{} = True -usedByGraphs LPos{} = True -usedByGraphs LWidth{} = True -usedByGraphs Margin{} = True -usedByGraphs MaxIter{} = True -usedByGraphs MCLimit{} = True -usedByGraphs MinDist{} = True -usedByGraphs Mode{} = True -usedByGraphs Model{} = True -usedByGraphs Mosek{} = True -usedByGraphs NodeSep{} = True -usedByGraphs NoJustify{} = True -usedByGraphs Normalize{} = True -usedByGraphs Nslimit{} = True -usedByGraphs Nslimit1{} = True -usedByGraphs Ordering{} = True -usedByGraphs OutputOrder{} = True -usedByGraphs Overlap{} = True -usedByGraphs OverlapScaling{} = True -usedByGraphs Pack{} = True -usedByGraphs PackMode{} = True -usedByGraphs Pad{} = True -usedByGraphs Page{} = True -usedByGraphs PageDir{} = True -usedByGraphs QuadTree{} = True -usedByGraphs Quantum{} = True -usedByGraphs RankDir{} = True -usedByGraphs RankSep{} = True -usedByGraphs Ratio{} = True -usedByGraphs ReMinCross{} = True -usedByGraphs RepulsiveForce{} = True -usedByGraphs Root{} = True -usedByGraphs Rotate{} = True -usedByGraphs Rotation{} = True -usedByGraphs Scale{} = True -usedByGraphs SearchSize{} = True -usedByGraphs Sep{} = True -usedByGraphs ShowBoxes{} = True -usedByGraphs Size{} = True -usedByGraphs Smoothing{} = True -usedByGraphs SortV{} = True -usedByGraphs Splines{} = True -usedByGraphs Start{} = True -usedByGraphs StyleSheet{} = True -usedByGraphs Target{} = True -usedByGraphs TrueColor{} = True -usedByGraphs ViewPort{} = True -usedByGraphs VoroMargin{} = True -usedByGraphs UnknownAttribute{} = True -usedByGraphs _ = False - --- | Determine if this 'Attribute' is valid for use with Clusters. -usedByClusters :: Attribute -> Bool -usedByClusters K{} = True -usedByClusters URL{} = True -usedByClusters ColorScheme{} = True -usedByClusters BgColor{} = True -usedByClusters Color{} = True -usedByClusters FillColor{} = True -usedByClusters FontColor{} = True -usedByClusters FontName{} = True -usedByClusters FontSize{} = True -usedByClusters GradientAngle{} = True -usedByClusters Label{} = True -usedByClusters LabelJust{} = True -usedByClusters LabelLoc{} = True -usedByClusters LHeight{} = True -usedByClusters LPos{} = True -usedByClusters LWidth{} = True -usedByClusters NoJustify{} = True -usedByClusters PenColor{} = True -usedByClusters PenWidth{} = True -usedByClusters Peripheries{} = True -usedByClusters Rank{} = True -usedByClusters SortV{} = True -usedByClusters Style{} = True -usedByClusters Target{} = True -usedByClusters Tooltip{} = True -usedByClusters UnknownAttribute{} = True -usedByClusters _ = False - --- | 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. -usedByNodes :: Attribute -> Bool -usedByNodes URL{} = True -usedByNodes ColorScheme{} = True -usedByNodes Color{} = True -usedByNodes Comment{} = True -usedByNodes Distortion{} = True -usedByNodes FillColor{} = True -usedByNodes FixedSize{} = True -usedByNodes FontColor{} = True -usedByNodes FontName{} = True -usedByNodes FontSize{} = True -usedByNodes GradientAngle{} = True -usedByNodes Group{} = True -usedByNodes Height{} = True -usedByNodes ID{} = True -usedByNodes Image{} = True -usedByNodes ImageScale{} = True -usedByNodes Label{} = True -usedByNodes LabelLoc{} = True -usedByNodes Layer{} = True -usedByNodes Margin{} = True -usedByNodes NoJustify{} = True -usedByNodes Ordering{} = True -usedByNodes Orientation{} = True -usedByNodes PenWidth{} = True -usedByNodes Peripheries{} = True -usedByNodes Pin{} = True -usedByNodes Pos{} = True -usedByNodes Rects{} = True -usedByNodes Regular{} = True -usedByNodes Root{} = True -usedByNodes SamplePoints{} = True -usedByNodes Shape{} = True -usedByNodes ShapeFile{} = True -usedByNodes ShowBoxes{} = True -usedByNodes Sides{} = True -usedByNodes Skew{} = True -usedByNodes SortV{} = True -usedByNodes Style{} = True -usedByNodes Target{} = True -usedByNodes Tooltip{} = True -usedByNodes Vertices{} = True -usedByNodes Width{} = True -usedByNodes XLabel{} = True -usedByNodes Z{} = True -usedByNodes UnknownAttribute{} = True -usedByNodes _ = False - --- | Determine if this 'Attribute' is valid for use with Edges. -usedByEdges :: Attribute -> Bool -usedByEdges URL{} = True -usedByEdges ArrowHead{} = True -usedByEdges ArrowSize{} = True -usedByEdges ArrowTail{} = True -usedByEdges ColorScheme{} = True -usedByEdges Color{} = True -usedByEdges Comment{} = True -usedByEdges Constraint{} = True -usedByEdges Decorate{} = True -usedByEdges Dir{} = True -usedByEdges EdgeURL{} = True -usedByEdges EdgeTarget{} = True -usedByEdges EdgeTooltip{} = True -usedByEdges FillColor{} = True -usedByEdges FontColor{} = True -usedByEdges FontName{} = True -usedByEdges FontSize{} = True -usedByEdges HeadURL{} = True -usedByEdges HeadClip{} = True -usedByEdges HeadLabel{} = True -usedByEdges HeadPort{} = True -usedByEdges HeadTarget{} = True -usedByEdges HeadTooltip{} = True -usedByEdges ID{} = True -usedByEdges Label{} = True -usedByEdges LabelURL{} = True -usedByEdges LabelAngle{} = True -usedByEdges LabelDistance{} = True -usedByEdges LabelFloat{} = True -usedByEdges LabelFontColor{} = True -usedByEdges LabelFontName{} = True -usedByEdges LabelFontSize{} = True -usedByEdges LabelTarget{} = True -usedByEdges LabelTooltip{} = True -usedByEdges Layer{} = True -usedByEdges Len{} = True -usedByEdges LHead{} = True -usedByEdges LPos{} = True -usedByEdges LTail{} = True -usedByEdges MinLen{} = True -usedByEdges NoJustify{} = True -usedByEdges PenWidth{} = True -usedByEdges Pos{} = True -usedByEdges SameHead{} = True -usedByEdges SameTail{} = True -usedByEdges ShowBoxes{} = True -usedByEdges Style{} = True -usedByEdges TailURL{} = True -usedByEdges TailClip{} = True -usedByEdges TailLabel{} = True -usedByEdges TailPort{} = True -usedByEdges TailTarget{} = True -usedByEdges TailTooltip{} = True -usedByEdges Target{} = True -usedByEdges Tooltip{} = True -usedByEdges Weight{} = True -usedByEdges XLabel{} = 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 BoundingBox{} BoundingBox{} = True -sameAttribute ColorScheme{} ColorScheme{} = True -sameAttribute BgColor{} BgColor{} = True -sameAttribute Center{} Center{} = True -sameAttribute ClusterRank{} ClusterRank{} = 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 Dim{} Dim{} = True -sameAttribute Dimen{} Dimen{} = 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 ForceLabels{} ForceLabels{} = True -sameAttribute GradientAngle{} GradientAngle{} = 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 ImagePath{} ImagePath{} = True -sameAttribute ImageScale{} ImageScale{} = True -sameAttribute Label{} Label{} = True -sameAttribute LabelURL{} LabelURL{} = True -sameAttribute LabelScheme{} LabelScheme{} = 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 Landscape{} Landscape{} = True -sameAttribute Layer{} Layer{} = True -sameAttribute Layers{} Layers{} = True -sameAttribute LayerSep{} LayerSep{} = True -sameAttribute Layout{} Layout{} = True -sameAttribute Len{} Len{} = True -sameAttribute LevelsGap{} LevelsGap{} = True -sameAttribute Levels{} Levels{} = True -sameAttribute LHead{} LHead{} = True -sameAttribute LHeight{} LHeight{} = True -sameAttribute LPos{} LPos{} = True -sameAttribute LTail{} LTail{} = True -sameAttribute LWidth{} LWidth{} = True -sameAttribute Margin{} Margin{} = True -sameAttribute MaxIter{} MaxIter{} = True -sameAttribute MCLimit{} MCLimit{} = True -sameAttribute MinDist{} MinDist{} = True -sameAttribute MinLen{} MinLen{} = True -sameAttribute Mode{} Mode{} = True -sameAttribute Model{} Model{} = True -sameAttribute Mosek{} Mosek{} = True -sameAttribute NodeSep{} NodeSep{} = True -sameAttribute NoJustify{} NoJustify{} = True -sameAttribute Normalize{} Normalize{} = True -sameAttribute Nslimit{} Nslimit{} = True -sameAttribute Nslimit1{} Nslimit1{} = True -sameAttribute Ordering{} Ordering{} = True -sameAttribute Orientation{} Orientation{} = True -sameAttribute OutputOrder{} OutputOrder{} = True -sameAttribute Overlap{} Overlap{} = True -sameAttribute OverlapScaling{} OverlapScaling{} = True -sameAttribute Pack{} Pack{} = True -sameAttribute PackMode{} PackMode{} = True -sameAttribute Pad{} Pad{} = True -sameAttribute Page{} Page{} = True -sameAttribute PageDir{} PageDir{} = 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 Rank{} Rank{} = True -sameAttribute RankDir{} RankDir{} = True -sameAttribute RankSep{} RankSep{} = 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 Rotation{} Rotation{} = True -sameAttribute SameHead{} SameHead{} = True -sameAttribute SameTail{} SameTail{} = True -sameAttribute SamplePoints{} SamplePoints{} = True -sameAttribute Scale{} Scale{} = True -sameAttribute SearchSize{} SearchSize{} = True -sameAttribute Sep{} Sep{} = True -sameAttribute Shape{} Shape{} = True -sameAttribute ShapeFile{} ShapeFile{} = 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 Style{} Style{} = True -sameAttribute StyleSheet{} StyleSheet{} = 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 XLabel{} XLabel{} = True -sameAttribute Z{} Z{} = True -sameAttribute (UnknownAttribute a1 _) (UnknownAttribute a2 _) = a1 == a2 -sameAttribute _ _ = False - --- | Return the default value for a specific 'Attribute' if possible; graph/cluster values are preferred over node/edge values. -defaultAttributeValue :: Attribute -> Maybe Attribute -defaultAttributeValue Damping{} = Just $ Damping 0.99 -defaultAttributeValue K{} = Just $ K 0.3 -defaultAttributeValue URL{} = Just $ URL "" -defaultAttributeValue ArrowHead{} = Just $ ArrowHead normal -defaultAttributeValue ArrowSize{} = Just $ ArrowSize 1 -defaultAttributeValue ArrowTail{} = Just $ ArrowTail normal -defaultAttributeValue ColorScheme{} = Just $ ColorScheme X11 -defaultAttributeValue BgColor{} = Just $ BgColor [X11Color Transparent] -defaultAttributeValue Center{} = Just $ Center False -defaultAttributeValue ClusterRank{} = Just $ ClusterRank Local -defaultAttributeValue Color{} = Just $ Color [X11Color Black] -defaultAttributeValue Comment{} = Just $ Comment "" -defaultAttributeValue Compound{} = Just $ Compound False -defaultAttributeValue Concentrate{} = Just $ Concentrate False -defaultAttributeValue Constraint{} = Just $ Constraint True -defaultAttributeValue Decorate{} = Just $ Decorate False -defaultAttributeValue Dim{} = Just $ Dim 2 -defaultAttributeValue Dimen{} = Just $ Dimen 2 -defaultAttributeValue DirEdgeConstraints{} = Just $ DirEdgeConstraints NoConstraints -defaultAttributeValue Distortion{} = Just $ Distortion 0 -defaultAttributeValue EdgeURL{} = Just $ EdgeURL "" -defaultAttributeValue ESep{} = Just $ ESep (DVal 3) -defaultAttributeValue FillColor{} = Just $ FillColor [X11Color Black] -defaultAttributeValue FixedSize{} = Just $ FixedSize False -defaultAttributeValue FontColor{} = Just $ FontColor (X11Color Black) -defaultAttributeValue FontName{} = Just $ FontName "Times-Roman" -defaultAttributeValue FontNames{} = Just $ FontNames "" -defaultAttributeValue FontSize{} = Just $ FontSize 14 -defaultAttributeValue ForceLabels{} = Just $ ForceLabels False -defaultAttributeValue GradientAngle{} = Just $ GradientAngle 0 -defaultAttributeValue Group{} = Just $ Group "" -defaultAttributeValue HeadURL{} = Just $ HeadURL "" -defaultAttributeValue HeadClip{} = Just $ HeadClip True -defaultAttributeValue HeadLabel{} = Just $ HeadLabel (StrLabel "") -defaultAttributeValue HeadPort{} = Just $ HeadPort (CompassPoint CenterPoint) -defaultAttributeValue HeadTarget{} = Just $ HeadTarget "" -defaultAttributeValue HeadTooltip{} = Just $ HeadTooltip "" -defaultAttributeValue Height{} = Just $ Height 0.5 -defaultAttributeValue ID{} = Just $ ID "" -defaultAttributeValue Image{} = Just $ Image "" -defaultAttributeValue ImagePath{} = Just $ ImagePath (Paths []) -defaultAttributeValue ImageScale{} = Just $ ImageScale NoScale -defaultAttributeValue Label{} = Just $ Label (StrLabel "") -defaultAttributeValue LabelURL{} = Just $ LabelURL "" -defaultAttributeValue LabelScheme{} = Just $ LabelScheme NotEdgeLabel -defaultAttributeValue LabelAngle{} = Just $ LabelAngle (-25) -defaultAttributeValue LabelDistance{} = Just $ LabelDistance 1 -defaultAttributeValue LabelFloat{} = Just $ LabelFloat False -defaultAttributeValue LabelFontColor{} = Just $ LabelFontColor (X11Color Black) -defaultAttributeValue LabelFontName{} = Just $ LabelFontName "Times-Roman" -defaultAttributeValue LabelFontSize{} = Just $ LabelFontSize 14 -defaultAttributeValue LabelJust{} = Just $ LabelJust JCenter -defaultAttributeValue LabelLoc{} = Just $ LabelLoc VTop -defaultAttributeValue LabelTarget{} = Just $ LabelTarget "" -defaultAttributeValue LabelTooltip{} = Just $ LabelTooltip "" -defaultAttributeValue Landscape{} = Just $ Landscape False -defaultAttributeValue Layers{} = Just $ Layers (LL []) -defaultAttributeValue LayerSep{} = Just $ LayerSep (LSep " :\t") -defaultAttributeValue Layout{} = Just $ Layout "" -defaultAttributeValue LevelsGap{} = Just $ LevelsGap 0 -defaultAttributeValue Levels{} = Just $ Levels maxBound -defaultAttributeValue LHead{} = Just $ LHead "" -defaultAttributeValue LTail{} = Just $ LTail "" -defaultAttributeValue MCLimit{} = Just $ MCLimit 1 -defaultAttributeValue MinDist{} = Just $ MinDist 1 -defaultAttributeValue MinLen{} = Just $ MinLen 1 -defaultAttributeValue Mode{} = Just $ Mode Major -defaultAttributeValue Model{} = Just $ Model ShortPath -defaultAttributeValue Mosek{} = Just $ Mosek False -defaultAttributeValue NodeSep{} = Just $ NodeSep 0.25 -defaultAttributeValue NoJustify{} = Just $ NoJustify False -defaultAttributeValue Normalize{} = Just $ Normalize False -defaultAttributeValue Orientation{} = Just $ Orientation 0 -defaultAttributeValue OutputOrder{} = Just $ OutputOrder BreadthFirst -defaultAttributeValue Overlap{} = Just $ Overlap KeepOverlaps -defaultAttributeValue OverlapScaling{} = Just $ OverlapScaling (-4) -defaultAttributeValue Pack{} = Just $ Pack DontPack -defaultAttributeValue PackMode{} = Just $ PackMode PackNode -defaultAttributeValue Pad{} = Just $ Pad (DVal 0.0555) -defaultAttributeValue PageDir{} = Just $ PageDir Bl -defaultAttributeValue PenColor{} = Just $ PenColor (X11Color Black) -defaultAttributeValue PenWidth{} = Just $ PenWidth 1 -defaultAttributeValue Peripheries{} = Just $ Peripheries 1 -defaultAttributeValue Pin{} = Just $ Pin False -defaultAttributeValue QuadTree{} = Just $ QuadTree NormalQT -defaultAttributeValue Quantum{} = Just $ Quantum 0 -defaultAttributeValue RankDir{} = Just $ RankDir FromTop -defaultAttributeValue Regular{} = Just $ Regular False -defaultAttributeValue ReMinCross{} = Just $ ReMinCross False -defaultAttributeValue RepulsiveForce{} = Just $ RepulsiveForce 1 -defaultAttributeValue Root{} = Just $ Root (NodeName "") -defaultAttributeValue Rotate{} = Just $ Rotate 0 -defaultAttributeValue Rotation{} = Just $ Rotation 0 -defaultAttributeValue SameHead{} = Just $ SameHead "" -defaultAttributeValue SameTail{} = Just $ SameTail "" -defaultAttributeValue SearchSize{} = Just $ SearchSize 30 -defaultAttributeValue Sep{} = Just $ Sep (DVal 4) -defaultAttributeValue Shape{} = Just $ Shape Ellipse -defaultAttributeValue ShapeFile{} = Just $ ShapeFile "" -defaultAttributeValue ShowBoxes{} = Just $ ShowBoxes 0 -defaultAttributeValue Sides{} = Just $ Sides 4 -defaultAttributeValue Skew{} = Just $ Skew 0 -defaultAttributeValue Smoothing{} = Just $ Smoothing NoSmooth -defaultAttributeValue SortV{} = Just $ SortV 0 -defaultAttributeValue Splines{} = Just $ Splines SplineEdges -defaultAttributeValue StyleSheet{} = Just $ StyleSheet "" -defaultAttributeValue TailURL{} = Just $ TailURL "" -defaultAttributeValue TailClip{} = Just $ TailClip True -defaultAttributeValue TailLabel{} = Just $ TailLabel (StrLabel "") -defaultAttributeValue TailPort{} = Just $ TailPort (CompassPoint CenterPoint) -defaultAttributeValue TailTarget{} = Just $ TailTarget "" -defaultAttributeValue TailTooltip{} = Just $ TailTooltip "" -defaultAttributeValue Target{} = Just $ Target "" -defaultAttributeValue Tooltip{} = Just $ Tooltip "" -defaultAttributeValue VoroMargin{} = Just $ VoroMargin 0.05 -defaultAttributeValue Width{} = Just $ Width 0.75 -defaultAttributeValue XLabel{} = Just $ XLabel (StrLabel "") -defaultAttributeValue Z{} = Just $ Z 0 -defaultAttributeValue _ = Nothing - --- | Determine if the provided 'Text' value is a valid name for an 'UnknownAttribute'. -validUnknown :: AttributeName -> Bool -validUnknown txt = T.toLower txt `S.notMember` names - && isIDString txt - where - names = (S.fromList . map T.toLower - $ [ "Damping" - , "K" - , "URL" - , "href" - , "arrowhead" - , "arrowsize" - , "arrowtail" - , "aspect" - , "bb" - , "colorscheme" - , "bgcolor" - , "center" - , "clusterrank" - , "color" - , "comment" - , "compound" - , "concentrate" - , "constraint" - , "decorate" - , "defaultdist" - , "dim" - , "dimen" - , "dir" - , "diredgeconstraints" - , "distortion" - , "dpi" - , "resolution" - , "edgeURL" - , "edgehref" - , "edgetarget" - , "edgetooltip" - , "epsilon" - , "esep" - , "fillcolor" - , "fixedsize" - , "fontcolor" - , "fontname" - , "fontnames" - , "fontpath" - , "fontsize" - , "forcelabels" - , "gradientangle" - , "group" - , "headURL" - , "headhref" - , "headclip" - , "headlabel" - , "headport" - , "headtarget" - , "headtooltip" - , "height" - , "id" - , "image" - , "imagepath" - , "imagescale" - , "label" - , "labelURL" - , "labelhref" - , "label_scheme" - , "labelangle" - , "labeldistance" - , "labelfloat" - , "labelfontcolor" - , "labelfontname" - , "labelfontsize" - , "labeljust" - , "labelloc" - , "labeltarget" - , "labeltooltip" - , "landscape" - , "layer" - , "layers" - , "layersep" - , "layout" - , "len" - , "levelsgap" - , "levels" - , "lhead" - , "LHeight" - , "lp" - , "ltail" - , "lwidth" - , "margin" - , "maxiter" - , "mclimit" - , "mindist" - , "minlen" - , "mode" - , "model" - , "mosek" - , "nodesep" - , "nojustify" - , "normalize" - , "nslimit" - , "nslimit1" - , "ordering" - , "orientation" - , "outputorder" - , "overlap" - , "overlap_scaling" - , "pack" - , "packmode" - , "pad" - , "page" - , "pagedir" - , "pencolor" - , "penwidth" - , "peripheries" - , "pin" - , "pos" - , "quadtree" - , "quantum" - , "rank" - , "rankdir" - , "ranksep" - , "ratio" - , "rects" - , "regular" - , "remincross" - , "repulsiveforce" - , "root" - , "rotate" - , "rotation" - , "samehead" - , "sametail" - , "samplepoints" - , "scale" - , "searchsize" - , "sep" - , "shape" - , "shapefile" - , "showboxes" - , "sides" - , "size" - , "skew" - , "smoothing" - , "sortv" - , "splines" - , "start" - , "style" - , "stylesheet" - , "tailURL" - , "tailhref" - , "tailclip" - , "taillabel" - , "tailport" - , "tailtarget" - , "tailtooltip" - , "target" - , "tooltip" - , "truecolor" - , "vertices" - , "viewport" - , "voro_margin" - , "weight" - , "width" - , "xlabel" - , "z" - , "charset" -- Defined upstream, just not used here. - ]) - `S.union` - keywords -{- Delete to here -} - --- ----------------------------------------------------------------------------- - -{- | If performing any custom pre-/post-processing on Dot code, you - may wish to utilise some custom 'Attributes'. These are wrappers - around the 'UnknownAttribute' constructor (and thus 'CustomAttribute' - is just an alias for 'Attribute'). - - You should ensure that 'validUnknown' is 'True' for any potential - custom attribute name. - --} -type CustomAttribute = Attribute - --- | Create a custom attribute. -customAttribute :: AttributeName -> Text -> CustomAttribute -customAttribute = UnknownAttribute - --- | Determines whether or not this is a custom attribute. -isCustom :: Attribute -> Bool -isCustom UnknownAttribute{} = True -isCustom _ = False - -isSpecifiedCustom :: AttributeName -> Attribute -> Bool -isSpecifiedCustom nm (UnknownAttribute nm' _) = nm == nm' -isSpecifiedCustom _ _ = False - --- | The value of a custom attribute. Will throw a --- 'GraphvizException' if the provided 'Attribute' isn't a custom --- one. -customValue :: CustomAttribute -> Text -customValue (UnknownAttribute _ v) = v -customValue attr = throw . NotCustomAttr . T.unpack - $ printIt attr - --- | The name of a custom attribute. Will throw a --- 'GraphvizException' if the provided 'Attribute' isn't a custom --- one. -customName :: CustomAttribute -> AttributeName -customName (UnknownAttribute nm _) = nm -customName attr = throw . NotCustomAttr . T.unpack - $ printIt attr - --- | Returns all custom attributes and the list of non-custom Attributes. -findCustoms :: Attributes -> ([CustomAttribute], Attributes) -findCustoms = partition isCustom - --- | Find the (first instance of the) specified custom attribute and --- returns it along with all other Attributes. -findSpecifiedCustom :: AttributeName -> Attributes - -> Maybe (CustomAttribute, Attributes) -findSpecifiedCustom nm attrs - = case break (isSpecifiedCustom nm) attrs of - (bf,cust:aft) -> Just (cust, bf ++ aft) - _ -> Nothing - --- | Delete all custom attributes (actually, this will delete all --- 'UnknownAttribute' values; as such it can also be used to remove --- legacy attributes). -deleteCustomAttributes :: Attributes -> Attributes -deleteCustomAttributes = filter (not . isCustom) - --- | Removes all instances of the specified custom attribute. -deleteSpecifiedCustom :: AttributeName -> Attributes -> Attributes -deleteSpecifiedCustom nm = filter (not . isSpecifiedCustom nm) - --- ----------------------------------------------------------------------------- - -{- | - - Some 'Attribute's (mainly label-like ones) take a 'String' argument - that allows for extra escape codes. This library doesn't do any - extra checks or special parsing for these escape codes, but usage - of 'EscString' rather than 'Text' indicates that the Graphviz - tools will recognise these extra escape codes for these - 'Attribute's. - - The extra escape codes include (note that these are all Strings): - - [@\\N@] Replace with the name of the node (for Node 'Attribute's). - - [@\\G@] Replace with the name of the graph (for Node 'Attribute's) - or the name of the graph or cluster, whichever is - applicable (for Graph, Cluster and Edge 'Attribute's). - - [@\\E@] Replace with the name of the edge, formed by the two - adjoining nodes and the edge type (for Edge 'Attribute's). - - [@\\T@] Replace with the name of the tail node (for Edge - 'Attribute's). - - [@\\H@] Replace with the name of the head node (for Edge - 'Attribute's). - - [@\\L@] Replace with the object's label (for all 'Attribute's). - - Also, if the 'Attribute' in question is 'Label', 'HeadLabel' or - 'TailLabel', then @\\n@, @\\l@ and @\\r@ split the label into lines - centered, left-justified and right-justified respectively. - - -} -type EscString = Text - --- ----------------------------------------------------------------------------- - --- | /Dot/ has a basic grammar of arrow shapes which allows usage of --- up to 1,544,761 different shapes from 9 different basic --- 'ArrowShape's. Note that whilst an explicit list is used in the --- definition of 'ArrowType', there must be at least one tuple and a --- maximum of 4 (since that is what is required by Dot). For more --- information, see: --- --- The 19 basic arrows shown on the overall attributes page have --- been defined below as a convenience. Parsing of the 5 --- backward-compatible special cases is also supported. -newtype ArrowType = AType [(ArrowModifier, ArrowShape)] - deriving (Eq, Ord, Show, Read) - --- Used for default -normal :: ArrowType -normal = AType [(noMods, Normal)] - --- Used for backward-compatible parsing -eDiamond, openArr, halfOpen, emptyArr, invEmpty :: ArrowType - -eDiamond = AType [(openMod, Diamond)] -openArr = AType [(noMods, Vee)] -halfOpen = AType [(ArrMod FilledArrow LeftSide, Vee)] -emptyArr = AType [(openMod, Normal)] -invEmpty = AType [ (noMods, Inv) - , (openMod, Normal)] - -instance PrintDot ArrowType where - unqtDot (AType mas) = hcat $ mapM appMod mas - where - appMod (m, a) = unqtDot m <> unqtDot a - -instance ParseDot ArrowType where - parseUnqt = specialArrowParse - `onFail` - do mas <- many1 $ do m <- parseUnqt - a <- parseUnqt - return (m,a) - return $ AType mas - -specialArrowParse :: Parse ArrowType -specialArrowParse = stringValue [ ("ediamond", eDiamond) - , ("open", openArr) - , ("halfopen", halfOpen) - , ("empty", emptyArr) - , ("invempty", invEmpty) - ] - -data ArrowShape = Box - | Crow - | Diamond - | DotArrow - | Inv - | NoArrow - | Normal - | Tee - | Vee - deriving (Eq, Ord, Bounded, Enum, Show, Read) - -instance PrintDot ArrowShape where - unqtDot Box = unqtText "box" - unqtDot Crow = unqtText "crow" - unqtDot Diamond = unqtText "diamond" - unqtDot DotArrow = unqtText "dot" - unqtDot Inv = unqtText "inv" - unqtDot NoArrow = unqtText "none" - unqtDot Normal = unqtText "normal" - unqtDot Tee = unqtText "tee" - unqtDot Vee = unqtText "vee" - -instance ParseDot ArrowShape where - parseUnqt = stringValue [ ("box", Box) - , ("crow", Crow) - , ("diamond", Diamond) - , ("dot", DotArrow) - , ("inv", Inv) - , ("none", NoArrow) - , ("normal", Normal) - , ("tee", Tee) - , ("vee", Vee) - ] - --- | What modifications to apply to an 'ArrowShape'. -data ArrowModifier = ArrMod { arrowFill :: ArrowFill - , arrowSide :: ArrowSide - } - deriving (Eq, Ord, Show, Read) - --- | Apply no modifications to an 'ArrowShape'. -noMods :: ArrowModifier -noMods = ArrMod FilledArrow BothSides - --- | 'OpenArrow' and 'BothSides' -openMod :: ArrowModifier -openMod = ArrMod OpenArrow BothSides - -instance PrintDot ArrowModifier where - unqtDot (ArrMod f s) = unqtDot f <> unqtDot s - -instance ParseDot ArrowModifier where - parseUnqt = do f <- parseUnqt - s <- parseUnqt - return $ ArrMod f s - -data ArrowFill = OpenArrow - | FilledArrow - deriving (Eq, Ord, Bounded, Enum, Show, Read) - -instance PrintDot ArrowFill where - unqtDot OpenArrow = char 'o' - unqtDot FilledArrow = empty - -instance ParseDot ArrowFill where - parseUnqt = liftM (bool FilledArrow OpenArrow . isJust) - $ optional (character 'o') - - -- Not used individually - parse = parseUnqt - --- | Represents which side (when looking towards the node the arrow is --- pointing to) is drawn. -data ArrowSide = LeftSide - | RightSide - | BothSides - deriving (Eq, Ord, Bounded, Enum, Show, Read) - -instance PrintDot ArrowSide where - unqtDot LeftSide = char 'l' - unqtDot RightSide = char 'r' - unqtDot BothSides = empty - -instance ParseDot ArrowSide where - parseUnqt = liftM getSideType - $ optional (oneOf $ map character ['l', 'r']) - where - getSideType = maybe BothSides - (bool RightSide LeftSide . (==) 'l') - - -- Not used individually - parse = parseUnqt - --- ----------------------------------------------------------------------------- - -data AspectType = RatioOnly Double - | RatioPassCount Double Int - deriving (Eq, Ord, Show, Read) - -instance PrintDot AspectType where - unqtDot (RatioOnly r) = unqtDot r - unqtDot (RatioPassCount r p) = commaDel r p - - toDot at@RatioOnly{} = unqtDot at - toDot at@RatioPassCount{} = dquotes $ unqtDot at - -instance ParseDot AspectType where - parseUnqt = liftM (uncurry RatioPassCount) commaSepUnqt - `onFail` - liftM RatioOnly parseUnqt - - - parse = quotedParse (liftM (uncurry RatioPassCount) commaSepUnqt) - `onFail` - liftM RatioOnly parse - --- ----------------------------------------------------------------------------- - --- | Should only have 2D points (i.e. created with 'createPoint'). -data Rect = Rect Point Point - deriving (Eq, Ord, Show, Read) - -instance PrintDot Rect where - unqtDot (Rect p1 p2) = commaDel p1 p2 - - toDot = dquotes . unqtDot - - unqtListToDot = hsep . mapM unqtDot - -instance ParseDot Rect where - parseUnqt = liftM (uncurry Rect) $ commaSep' parsePoint2D parsePoint2D - - parse = quotedParse parseUnqt - - parseUnqtList = sepBy1 parseUnqt whitespace1 - --- ----------------------------------------------------------------------------- - -data ClusterMode = Local - | Global - | NoCluster - deriving (Eq, Ord, Bounded, Enum, Show, Read) - -instance PrintDot ClusterMode where - unqtDot Local = unqtText "local" - unqtDot Global = unqtText "global" - unqtDot NoCluster = unqtText "none" - -instance ParseDot ClusterMode where - parseUnqt = oneOf [ stringRep Local "local" - , stringRep Global "global" - , stringRep NoCluster "none" - ] - --- ----------------------------------------------------------------------------- - --- | Specify where to place arrow heads on an edge. -data DirType = Forward -- ^ Draw a directed edge with an arrow to the - -- node it's pointing go. - | Back -- ^ Draw a reverse directed edge with an arrow - -- to the node it's coming from. - | Both -- ^ Draw arrows on both ends of the edge. - | NoDir -- ^ Draw an undirected edge. - deriving (Eq, Ord, Bounded, Enum, Show, Read) - -instance PrintDot DirType where - unqtDot Forward = unqtText "forward" - unqtDot Back = unqtText "back" - unqtDot Both = unqtText "both" - unqtDot NoDir = unqtText "none" - -instance ParseDot DirType where - parseUnqt = oneOf [ stringRep Forward "forward" - , stringRep Back "back" - , stringRep Both "both" - , stringRep NoDir "none" - ] - --- ----------------------------------------------------------------------------- - --- | Only when @mode == 'IpSep'@. -data DEConstraints = EdgeConstraints - | NoConstraints - | HierConstraints - deriving (Eq, Ord, Bounded, Enum, Show, Read) - -instance PrintDot DEConstraints where - unqtDot EdgeConstraints = unqtDot True - unqtDot NoConstraints = unqtDot False - unqtDot HierConstraints = text "hier" - -instance ParseDot DEConstraints where - parseUnqt = liftM (bool NoConstraints EdgeConstraints) parse - `onFail` - stringRep HierConstraints "hier" - --- ----------------------------------------------------------------------------- - --- | Either a 'Double' or a (2D) 'Point' (i.e. created with --- 'createPoint'). -data DPoint = DVal Double - | PVal Point - deriving (Eq, Ord, Show, Read) - -instance PrintDot DPoint where - unqtDot (DVal d) = unqtDot d - unqtDot (PVal p) = unqtDot p - - toDot (DVal d) = toDot d - toDot (PVal p) = toDot p - -instance ParseDot DPoint where - parseUnqt = liftM PVal parsePoint2D - `onFail` - liftM DVal parseUnqt - - parse = quotedParse parseUnqt - `onFail` - liftM DVal parseUnqt - --- ----------------------------------------------------------------------------- - -data ModeType = Major - | KK - | Hier - | IpSep - deriving (Eq, Ord, Bounded, Enum, Show, Read) - -instance PrintDot ModeType where - unqtDot Major = text "major" - unqtDot KK = text "KK" - unqtDot Hier = text "hier" - unqtDot IpSep = text "ipsep" - -instance ParseDot ModeType where - parseUnqt = oneOf [ stringRep Major "major" - , stringRep KK "KK" - , stringRep Hier "hier" - , stringRep IpSep "ipsep" - ] - --- ----------------------------------------------------------------------------- - -data Model = ShortPath - | SubSet - | Circuit - deriving (Eq, Ord, Bounded, Enum, Show, Read) - -instance PrintDot Model where - unqtDot ShortPath = text "shortpath" - unqtDot SubSet = text "subset" - unqtDot Circuit = text "circuit" - -instance ParseDot Model where - parseUnqt = oneOf [ stringRep ShortPath "shortpath" - , stringRep SubSet "subset" - , stringRep Circuit "circuit" - ] - --- ----------------------------------------------------------------------------- - -data Label = StrLabel EscString - | HtmlLabel Html.Label -- ^ If 'PlainText' is used, the - -- 'Html.Label' value is the entire - -- \"shape\"; if anything else - -- except 'PointShape' is used then - -- the 'Html.Label' is embedded - -- within the shape. - | RecordLabel RecordFields -- ^ For nodes only; requires - -- either 'Record' or - -- 'MRecord' as the shape. - deriving (Eq, Ord, Show, Read) - -instance PrintDot Label where - unqtDot (StrLabel s) = unqtDot s - unqtDot (HtmlLabel h) = angled $ unqtDot h - unqtDot (RecordLabel fs) = unqtDot fs - - toDot (StrLabel s) = toDot s - toDot h@HtmlLabel{} = unqtDot h - toDot (RecordLabel fs) = toDot fs - -instance ParseDot Label where - -- Don't have to worry about being able to tell the difference - -- between an HtmlLabel and a RecordLabel starting with a PortPos, - -- since the latter will be in quotes and the former won't. - - parseUnqt = oneOf [ liftM HtmlLabel $ parseAngled parseUnqt - , liftM RecordLabel parseUnqt - , liftM StrLabel parseUnqt - ] - - parse = oneOf [ liftM HtmlLabel $ parseAngled parse - , liftM RecordLabel parse - , liftM StrLabel parse - ] - --- ----------------------------------------------------------------------------- - --- | A RecordFields value should never be empty. -type RecordFields = [RecordField] - --- | Specifies the sub-values of a record-based label. By default, --- the cells are laid out horizontally; use 'FlipFields' to change --- the orientation of the fields (can be applied recursively). To --- change the default orientation, use 'RankDir'. -data RecordField = LabelledTarget PortName EscString - | PortName PortName -- ^ Will result in no label for - -- that cell. - | FieldLabel EscString - | FlipFields RecordFields - deriving (Eq, Ord, Show, Read) - -instance PrintDot RecordField where - -- Have to use 'printPortName' to add the @\'<\'@ and @\'>\'@. - unqtDot (LabelledTarget t s) = printPortName t <+> unqtRecordString s - unqtDot (PortName t) = printPortName t - unqtDot (FieldLabel s) = unqtRecordString s - unqtDot (FlipFields rs) = braces $ unqtDot rs - - toDot (FieldLabel s) = printEscaped recordEscChars s - toDot rf = dquotes $ unqtDot rf - - unqtListToDot [f] = unqtDot f - unqtListToDot fs = hcat . punctuate (char '|') $ mapM unqtDot fs - - listToDot [f] = toDot f - listToDot fs = dquotes $ unqtListToDot fs - -instance ParseDot RecordField where - parseUnqt = do t <- liftM PN $ parseAngled parseRecord - ml <- optional (whitespace1 >> parseRecord) - return $ maybe (PortName t) - (LabelledTarget t) - ml - `onFail` - liftM FieldLabel parseRecord - `onFail` - liftM FlipFields (parseBraced parseUnqt) - - parse = quotedParse parseUnqt - - parseUnqtList = wrapWhitespace $ sepBy1 parseUnqt (wrapWhitespace $ character '|') - - -- Note: a singleton unquoted 'FieldLabel' is /not/ valid, as it - -- will cause parsing problems for other 'Label' types. - parseList = do rfs <- quotedParse parseUnqtList - if validRFs rfs - then return rfs - else fail "This is a StrLabel, not a RecordLabel" - where - validRFs [FieldLabel str] = T.any (`elem` recordEscChars) str - validRFs _ = True - --- | Print a 'PortName' value as expected within a Record data --- structure. -printPortName :: PortName -> DotCode -printPortName = angled . unqtRecordString . portName - -parseRecord :: Parse Text -parseRecord = parseEscaped False recordEscChars [] - -unqtRecordString :: Text -> DotCode -unqtRecordString = unqtEscaped recordEscChars - -recordEscChars :: [Char] -recordEscChars = ['{', '}', '|', ' ', '<', '>'] - --- ----------------------------------------------------------------------------- - --- | How to treat a node whose name is of the form @|edgelabel|*@" as a --- special node representing an edge label. -data LabelScheme = NotEdgeLabel -- ^ No effect - | CloseToCenter -- ^ Make node close to center of neighbor - | CloseToOldCenter -- ^ Make node close to old center of neighbor - | RemoveAndStraighten -- ^ Use a two-step process. - deriving (Eq, Ord, Bounded, Enum, Show, Read) - -instance PrintDot LabelScheme where - unqtDot NotEdgeLabel = int 0 - unqtDot CloseToCenter = int 1 - unqtDot CloseToOldCenter = int 2 - unqtDot RemoveAndStraighten = int 3 - -instance ParseDot LabelScheme where - -- Use string-based parsing rather than parsing an integer just to make it easier - parseUnqt = stringValue [ ("0", NotEdgeLabel) - , ("1", CloseToCenter) - , ("2", CloseToOldCenter) - , ("3", RemoveAndStraighten) - ] - --- ----------------------------------------------------------------------------- - -data Point = Point { xCoord :: Double - , yCoord :: Double - -- | Can only be 'Just' for @'Dim' 3@ or greater. - , zCoord :: Maybe Double - -- | Input to Graphviz only: specify that the - -- node position should not change. - , forcePos :: Bool - } - deriving (Eq, Ord, Show, Read) - --- | Create a point with only @x@ and @y@ values. -createPoint :: Double -> Double -> Point -createPoint x y = Point x y Nothing False - -parsePoint2D :: Parse Point -parsePoint2D = liftM (uncurry createPoint) commaSepUnqt - -instance PrintDot Point where - unqtDot (Point x y mz frs) = bool id (<> char '!') frs - . maybe id (\ z -> (<> unqtDot z) . (<> comma)) mz - $ commaDel x y - - toDot = dquotes . unqtDot - - unqtListToDot = hsep . mapM unqtDot - - listToDot = dquotes . unqtListToDot - -instance ParseDot Point where - parseUnqt = do (x,y) <- commaSepUnqt - mz <- optional $ parseComma >> parseUnqt - bng <- liftM isJust . optional $ character '!' - return $ Point x y mz bng - - parse = quotedParse parseUnqt - - parseUnqtList = sepBy1 parseUnqt whitespace1 - --- ----------------------------------------------------------------------------- - -data Overlap = KeepOverlaps - | ScaleOverlaps - | ScaleXYOverlaps - | PrismOverlap (Maybe Word16) -- ^ Only when sfdp is - -- available, @'Nothing'@ - -- is equivalent to - -- @'Just' 1000@. - | CompressOverlap - | VpscOverlap - | IpsepOverlap -- ^ Only when @mode == 'IpSep'@ - deriving (Eq, Ord, Show, Read) - -instance PrintDot Overlap where - unqtDot KeepOverlaps = unqtDot True - unqtDot ScaleOverlaps = text "scale" - unqtDot ScaleXYOverlaps = text "scalexy" - unqtDot (PrismOverlap i) = maybe id (flip (<>) . unqtDot) i $ text "prism" - unqtDot CompressOverlap = text "compress" - unqtDot VpscOverlap = text "vpsc" - unqtDot IpsepOverlap = text "ipsep" - -instance ParseDot Overlap where - parseUnqt = oneOf [ stringRep KeepOverlaps "true" - , stringRep ScaleXYOverlaps "scalexy" - , stringRep ScaleOverlaps "scale" - , string "prism" >> liftM PrismOverlap (optional parse) - , stringRep (PrismOverlap Nothing) "false" - , stringRep CompressOverlap "compress" - , stringRep VpscOverlap "vpsc" - , stringRep IpsepOverlap "ipsep" - ] - --- ----------------------------------------------------------------------------- - -newtype LayerSep = LSep Text - deriving (Eq, Ord, Show, Read) - -instance PrintDot LayerSep where - unqtDot (LSep ls) = do setLayerSep $ T.unpack ls - unqtDot ls - - toDot (LSep ls) = do setLayerSep $ T.unpack ls - toDot ls - -instance ParseDot LayerSep where - parseUnqt = do ls <- parseUnqt - setLayerSep $ T.unpack ls - return $ LSep ls - - parse = do ls <- parse - setLayerSep $ T.unpack ls - return $ LSep ls - -data LayerRange = LRID LayerID - | LRS LayerID LayerID - deriving (Eq, Ord, Show, Read) - -instance PrintDot LayerRange where - unqtDot (LRID lid) = unqtDot lid - unqtDot (LRS id1 id2) = do ls <- getLayerSep - let s = unqtDot $ head ls - unqtDot id1 <> s <> unqtDot id2 - - toDot (LRID lid) = toDot lid - toDot lrs = dquotes $ unqtDot lrs - -instance ParseDot LayerRange where - parseUnqt = do id1 <- parseUnqt - _ <- parseLayerSep - id2 <- parseUnqt - return $ LRS id1 id2 - `onFail` - liftM LRID parseUnqt - - - parse = quotedParse ( do id1 <- parseUnqt - _ <- parseLayerSep - id2 <- parseUnqt - return $ LRS id1 id2 - ) - `onFail` - liftM LRID parse - -parseLayerSep :: Parse () -parseLayerSep = do ls <- getLayerSep - many1Satisfy (`elem` ls) - return () - -parseLayerName :: Parse Text -parseLayerName = parseEscaped False [] =<< getLayerSep - -parseLayerName' :: Parse Text -parseLayerName' = stringBlock - `onFail` - quotedParse parseLayerName - --- | You should not have any layer separator characters for the --- 'LRName' option, as they won't be parseable. -data LayerID = AllLayers - | LRInt Int - | LRName Text -- ^ Should not be a number of @"all"@. - deriving (Eq, Ord, Show, Read) - -instance PrintDot LayerID where - unqtDot AllLayers = text "all" - unqtDot (LRInt n) = unqtDot n - unqtDot (LRName nm) = unqtDot nm - - toDot (LRName nm) = toDot nm - -- Other two don't need quotes - toDot li = unqtDot li - - unqtListToDot ll = do ls <- getLayerSep - let s = unqtDot $ head ls - hcat . punctuate s $ mapM unqtDot ll - - listToDot [l] = toDot l - -- Might not need quotes, but probably will. Can't tell either - -- way since we don't know what the separator character will be. - listToDot ll = dquotes $ unqtDot ll - -instance ParseDot LayerID where - parseUnqt = liftM checkLayerName parseLayerName -- tests for Int and All - - parse = oneOf [ liftM checkLayerName parseLayerName' - , liftM LRInt parse -- Mainly for unquoted case. - ] - -checkLayerName :: Text -> LayerID -checkLayerName str = maybe checkAll LRInt $ stringToInt str - where - checkAll = if T.toLower str == "all" - then AllLayers - else LRName str - --- | A list of layer names. The names should all be 'LRName' values, --- and when printed will use an arbitrary character from --- 'defLayerSep'. -newtype LayerList = LL [LayerID] - deriving (Eq, Ord, Show, Read) - -instance PrintDot LayerList where - unqtDot (LL ll) = unqtDot ll - - toDot (LL ll) = toDot ll - -instance ParseDot LayerList where - parseUnqt = liftM LL $ sepBy1 parseUnqt parseLayerSep - - parse = quotedParse parseUnqt - `onFail` - liftM (LL . (:[]) . LRName) stringBlock - `onFail` - quotedParse (stringRep (LL []) "") - --- ----------------------------------------------------------------------------- - -data Order = OutEdges -- ^ Draw outgoing edges in order specified. - | InEdges -- ^ Draw incoming edges in order specified. - deriving (Eq, Ord, Bounded, Enum, Show, Read) - -instance PrintDot Order where - unqtDot OutEdges = text "out" - unqtDot InEdges = text "in" - -instance ParseDot Order where - parseUnqt = oneOf [ stringRep OutEdges "out" - , stringRep InEdges "in" - ] - --- ----------------------------------------------------------------------------- - -data OutputMode = BreadthFirst | NodesFirst | EdgesFirst - deriving (Eq, Ord, Bounded, Enum, Show, Read) - -instance PrintDot OutputMode where - unqtDot BreadthFirst = text "breadthfirst" - unqtDot NodesFirst = text "nodesfirst" - unqtDot EdgesFirst = text "edgesfirst" - -instance ParseDot OutputMode where - parseUnqt = oneOf [ stringRep BreadthFirst "breadthfirst" - , stringRep NodesFirst "nodesfirst" - , stringRep EdgesFirst "edgesfirst" - ] - --- ----------------------------------------------------------------------------- - -data Pack = DoPack - | DontPack - | PackMargin Int -- ^ If non-negative, then packs; otherwise doesn't. - deriving (Eq, Ord, Show, Read) - -instance PrintDot Pack where - unqtDot DoPack = unqtDot True - unqtDot DontPack = unqtDot False - unqtDot (PackMargin m) = unqtDot m - -instance ParseDot Pack where - -- What happens if it parses 0? It's non-negative, but parses as False - parseUnqt = oneOf [ liftM PackMargin parseUnqt - , liftM (bool DontPack DoPack) onlyBool - ] - --- ----------------------------------------------------------------------------- - -data PackMode = PackNode - | PackClust - | PackGraph - | PackArray Bool Bool (Maybe Int) -- ^ Sort by cols, sort - -- by user, number of - -- rows/cols - deriving (Eq, Ord, Show, Read) - -instance PrintDot PackMode where - unqtDot PackNode = text "node" - unqtDot PackClust = text "clust" - unqtDot PackGraph = text "graph" - unqtDot (PackArray c u mi) = addNum . isU . isC . isUnder - $ text "array" - where - addNum = maybe id (flip (<>) . unqtDot) mi - isUnder = if c || u - then flip (<>) $ char '_' - else id - isC = if c - then flip (<>) $ char 'c' - else id - isU = if u - then flip (<>) $ char 'u' - else id - -instance ParseDot PackMode where - parseUnqt = oneOf [ stringRep PackNode "node" - , stringRep PackClust "clust" - , stringRep PackGraph "graph" - , do string "array" - mcu <- optional $ do character '_' - many1 $ satisfy isCU - let c = hasCharacter mcu 'c' - u = hasCharacter mcu 'u' - mi <- optional parseUnqt - return $ PackArray c u mi - ] - where - hasCharacter ms c = maybe False (elem c) ms - -- Also checks and removes quote characters - isCU = flip elem ['c', 'u'] - --- ----------------------------------------------------------------------------- - -data Pos = PointPos Point - | SplinePos [Spline] - deriving (Eq, Ord, Show, Read) - -instance PrintDot Pos where - unqtDot (PointPos p) = unqtDot p - unqtDot (SplinePos ss) = unqtDot ss - - toDot (PointPos p) = toDot p - toDot (SplinePos ss) = toDot ss - -instance ParseDot Pos where - -- Have to be careful with this: if we try to parse points first, - -- then a spline with no start and end points will erroneously get - -- parsed as a point and then the parser will crash as it expects a - -- closing quote character... - parseUnqt = do splns <- parseUnqt - case splns of - [Spline Nothing Nothing [p]] -> return $ PointPos p - _ -> return $ SplinePos splns - - parse = quotedParse parseUnqt - --- ----------------------------------------------------------------------------- - --- | Controls how (and if) edges are represented. -data EdgeType = SplineEdges - | LineEdges - | NoEdges - | PolyLine - | CompoundEdge -- ^ fdp only - deriving (Eq, Ord, Bounded, Enum, Show, Read) - -instance PrintDot EdgeType where - unqtDot SplineEdges = toDot True - unqtDot LineEdges = toDot False - unqtDot NoEdges = empty - unqtDot PolyLine = text "polyline" - unqtDot CompoundEdge = text "compound" - - toDot NoEdges = dquotes empty - toDot et = unqtDot et - -instance ParseDot EdgeType where - -- Can't parse NoEdges without quotes. - parseUnqt = oneOf [ liftM (bool LineEdges SplineEdges) parse - , stringRep SplineEdges "spline" - , stringRep LineEdges "line" - , stringRep PolyLine "polyline" - , stringRep CompoundEdge "compound" - ] - - parse = stringRep NoEdges "\"\"" - `onFail` - optionalQuoted parseUnqt - --- ----------------------------------------------------------------------------- - --- | Upper-case first character is major order; --- lower-case second character is minor order. -data PageDir = Bl | Br | Tl | Tr | Rb | Rt | Lb | Lt - deriving (Eq, Ord, Bounded, Enum, Show, Read) - -instance PrintDot PageDir where - unqtDot Bl = text "BL" - unqtDot Br = text "BR" - unqtDot Tl = text "TL" - unqtDot Tr = text "TR" - unqtDot Rb = text "RB" - unqtDot Rt = text "RT" - unqtDot Lb = text "LB" - unqtDot Lt = text "LT" - -instance ParseDot PageDir where - parseUnqt = stringValue [ ("BL", Bl) - , ("BR", Br) - , ("TL", Tl) - , ("TR", Tr) - , ("RB", Rb) - , ("RT", Rt) - , ("LB", Lb) - , ("LT", Lt) - ] - --- ----------------------------------------------------------------------------- - --- | The number of points in the list must be equivalent to 1 mod 3; --- note that this is not checked. -data Spline = Spline (Maybe Point) (Maybe Point) [Point] - deriving (Eq, Ord, Show, Read) - -instance PrintDot Spline where - unqtDot (Spline ms me ps) = addS . addE - . hsep - $ mapM unqtDot ps - where - addP t = maybe id ((<+>) . commaDel t) - addS = addP 's' ms - addE = addP 'e' me - - toDot = dquotes . unqtDot - - unqtListToDot = hcat . punctuate semi . mapM unqtDot - - listToDot = dquotes . unqtListToDot - -instance ParseDot Spline where - parseUnqt = do ms <- parseP 's' - me <- parseP 'e' - ps <- sepBy1 parseUnqt whitespace1 - return $ Spline ms me ps - where - parseP t = optional $ do character t - parseComma - parseUnqt `discard` whitespace1 - - parse = quotedParse parseUnqt - - parseUnqtList = sepBy1 parseUnqt (character ';') - --- ----------------------------------------------------------------------------- - -data QuadType = NormalQT - | FastQT - | NoQT - deriving (Eq, Ord, Bounded, Enum, Show, Read) - -instance PrintDot QuadType where - unqtDot NormalQT = text "normal" - unqtDot FastQT = text "fast" - unqtDot NoQT = text "none" - -instance ParseDot QuadType where - -- Have to take into account the slightly different interpretation - -- of Bool used as an option for parsing QuadType - parseUnqt = oneOf [ stringRep NormalQT "normal" - , stringRep FastQT "fast" - , stringRep NoQT "none" - , character '2' >> return FastQT -- weird bool - , liftM (bool NoQT NormalQT) parse - ] - --- ----------------------------------------------------------------------------- - --- | Specify the root node either as a Node attribute or a Graph attribute. -data Root = IsCentral -- ^ For Nodes only - | NotCentral -- ^ For Nodes only - | NodeName Text -- ^ For Graphs only - deriving (Eq, Ord, Show, Read) - -instance PrintDot Root where - unqtDot IsCentral = unqtDot True - unqtDot NotCentral = unqtDot False - unqtDot (NodeName n) = unqtDot n - - toDot (NodeName n) = toDot n - toDot r = unqtDot r - -instance ParseDot Root where - parseUnqt = liftM (bool NotCentral IsCentral) onlyBool - `onFail` - liftM NodeName parseUnqt - - parse = optionalQuoted (liftM (bool NotCentral IsCentral) onlyBool) - `onFail` - liftM NodeName parse - --- ----------------------------------------------------------------------------- - -data RankType = SameRank - | MinRank - | SourceRank - | MaxRank - | SinkRank - deriving (Eq, Ord, Bounded, Enum, Show, Read) - -instance PrintDot RankType where - unqtDot SameRank = text "same" - unqtDot MinRank = text "min" - unqtDot SourceRank = text "source" - unqtDot MaxRank = text "max" - unqtDot SinkRank = text "sink" - -instance ParseDot RankType where - parseUnqt = stringValue [ ("same", SameRank) - , ("min", MinRank) - , ("source", SourceRank) - , ("max", MaxRank) - , ("sink", SinkRank) - ] - --- ----------------------------------------------------------------------------- - -data RankDir = FromTop - | FromLeft - | FromBottom - | FromRight - deriving (Eq, Ord, Bounded, Enum, Show, Read) - -instance PrintDot RankDir where - unqtDot FromTop = text "TB" - unqtDot FromLeft = text "LR" - unqtDot FromBottom = text "BT" - unqtDot FromRight = text "RL" - -instance ParseDot RankDir where - parseUnqt = oneOf [ stringRep FromTop "TB" - , stringRep FromLeft "LR" - , stringRep FromBottom "BT" - , stringRep FromRight "RL" - ] - --- ----------------------------------------------------------------------------- - -data Shape - = BoxShape -- ^ Has synonyms of /rect/ and /rectangle/. - | Polygon - | Ellipse - | Circle - | PointShape - | Egg - | Triangle - | PlainText -- ^ Has synonym of /none/. - | DiamondShape - | Trapezium - | Parallelogram - | House - | Pentagon - | Hexagon - | Septagon - | Octagon - | DoubleCircle - | DoubleOctagon - | TripleOctagon - | InvTriangle - | InvTrapezium - | InvHouse - | MDiamond - | MSquare - | MCircle - | Note - | Tab - | Folder - | Box3D - | Component - | Record -- ^ Must specify the record shape with a 'Label'. - | MRecord -- ^ Must specify the record shape with a 'Label'. - deriving (Eq, Ord, Bounded, Enum, Show, Read) - -instance PrintDot Shape where - unqtDot BoxShape = text "box" - unqtDot Polygon = text "polygon" - unqtDot Ellipse = text "ellipse" - unqtDot Circle = text "circle" - unqtDot PointShape = text "point" - unqtDot Egg = text "egg" - unqtDot Triangle = text "triangle" - unqtDot PlainText = text "plaintext" - unqtDot DiamondShape = text "diamond" - unqtDot Trapezium = text "trapezium" - unqtDot Parallelogram = text "parallelogram" - unqtDot House = text "house" - unqtDot Pentagon = text "pentagon" - unqtDot Hexagon = text "hexagon" - unqtDot Septagon = text "septagon" - unqtDot Octagon = text "octagon" - unqtDot DoubleCircle = text "doublecircle" - unqtDot DoubleOctagon = text "doubleoctagon" - unqtDot TripleOctagon = text "tripleoctagon" - unqtDot InvTriangle = text "invtriangle" - unqtDot InvTrapezium = text "invtrapezium" - unqtDot InvHouse = text "invhouse" - unqtDot MDiamond = text "Mdiamond" - unqtDot MSquare = text "Msquare" - unqtDot MCircle = text "Mcircle" - unqtDot Note = text "note" - unqtDot Tab = text "tab" - unqtDot Folder = text "folder" - unqtDot Box3D = text "box3d" - unqtDot Component = text "component" - unqtDot Record = text "record" - unqtDot MRecord = text "Mrecord" - -instance ParseDot Shape where - parseUnqt = stringValue [ ("box3d", Box3D) - , ("box", BoxShape) - , ("rectangle", BoxShape) - , ("rect", BoxShape) - , ("polygon", Polygon) - , ("ellipse", Ellipse) - , ("circle", Circle) - , ("point", PointShape) - , ("egg", Egg) - , ("triangle", Triangle) - , ("plaintext", PlainText) - , ("none", PlainText) - , ("diamond", DiamondShape) - , ("trapezium", Trapezium) - , ("parallelogram", Parallelogram) - , ("house", House) - , ("pentagon", Pentagon) - , ("hexagon", Hexagon) - , ("septagon", Septagon) - , ("octagon", Octagon) - , ("doublecircle", DoubleCircle) - , ("doubleoctagon", DoubleOctagon) - , ("tripleoctagon", TripleOctagon) - , ("invtriangle", InvTriangle) - , ("invtrapezium", InvTrapezium) - , ("invhouse", InvHouse) - , ("Mdiamond", MDiamond) - , ("Msquare", MSquare) - , ("Mcircle", MCircle) - , ("note", Note) - , ("tab", Tab) - , ("folder", Folder) - , ("component", Component) - , ("record", Record) - , ("Mrecord", MRecord) - ] - --- ----------------------------------------------------------------------------- - -data SmoothType = NoSmooth - | AvgDist - | GraphDist - | PowerDist - | RNG - | Spring - | TriangleSmooth - deriving (Eq, Ord, Bounded, Enum, Show, Read) - -instance PrintDot SmoothType where - unqtDot NoSmooth = text "none" - unqtDot AvgDist = text "avg_dist" - unqtDot GraphDist = text "graph_dist" - unqtDot PowerDist = text "power_dist" - unqtDot RNG = text "rng" - unqtDot Spring = text "spring" - unqtDot TriangleSmooth = text "triangle" - -instance ParseDot SmoothType where - parseUnqt = oneOf [ stringRep NoSmooth "none" - , stringRep AvgDist "avg_dist" - , stringRep GraphDist "graph_dist" - , stringRep PowerDist "power_dist" - , stringRep RNG "rng" - , stringRep Spring "spring" - , stringRep TriangleSmooth "triangle" - ] - --- ----------------------------------------------------------------------------- - -data StartType = StartStyle STStyle - | StartSeed Int - | StartStyleSeed STStyle Int - deriving (Eq, Ord, Show, Read) - -instance PrintDot StartType where - unqtDot (StartStyle ss) = unqtDot ss - unqtDot (StartSeed s) = unqtDot s - unqtDot (StartStyleSeed ss s) = unqtDot ss <> unqtDot s - -instance ParseDot StartType where - parseUnqt = oneOf [ do ss <- parseUnqt - s <- parseUnqt - return $ StartStyleSeed ss s - , liftM StartStyle parseUnqt - , liftM StartSeed parseUnqt - ] - -data STStyle = RegularStyle - | SelfStyle - | RandomStyle - deriving (Eq, Ord, Bounded, Enum, Show, Read) - -instance PrintDot STStyle where - unqtDot RegularStyle = text "regular" - unqtDot SelfStyle = text "self" - unqtDot RandomStyle = text "random" - -instance ParseDot STStyle where - parseUnqt = oneOf [ stringRep RegularStyle "regular" - , stringRep SelfStyle "self" - , stringRep RandomStyle "random" - ] - --- ----------------------------------------------------------------------------- - --- | An individual style item. Except for 'DD', the @['String']@ --- should be empty. -data StyleItem = SItem StyleName [Text] - deriving (Eq, Ord, Show, Read) - -instance PrintDot StyleItem where - unqtDot (SItem nm args) - | null args = dnm - | otherwise = dnm <> parens args' - where - dnm = unqtDot nm - args' = hcat . punctuate comma $ mapM unqtDot args - - toDot si@(SItem nm args) - | null args = toDot nm - | otherwise = dquotes $ unqtDot si - - unqtListToDot = hcat . punctuate comma . mapM unqtDot - - listToDot [SItem nm []] = toDot nm - listToDot sis = dquotes $ unqtListToDot sis - -instance ParseDot StyleItem where - parseUnqt = do nm <- parseUnqt - args <- tryParseList' parseArgs - return $ SItem nm args - - parse = quotedParse (liftM2 SItem parseUnqt parseArgs) - `onFail` - liftM (flip SItem []) parse - - parseUnqtList = sepBy1 parseUnqt parseComma - - parseList = quotedParse parseUnqtList - `onFail` - -- Might not necessarily need to be quoted if a singleton... - liftM return parse - -parseArgs :: Parse [Text] -parseArgs = bracketSep (character '(') - parseComma - (character ')') - parseStyleName - -data StyleName = Dashed -- ^ Nodes and Edges - | Dotted -- ^ Nodes and Edges - | Solid -- ^ Nodes and Edges - | Bold -- ^ Nodes and Edges - | Invisible -- ^ Nodes and Edges - | Filled -- ^ Nodes and Clusters - | Diagonals -- ^ Nodes only - | Rounded -- ^ Nodes and Clusters - | Tapered -- ^ Edges only; requires Graphviz >= - -- 2.29.0. - | Radial -- ^ Nodes, Clusters and Graphs, for use - -- with 'GradientAngle'; requires - -- Graphviz >= 2.29.0. - | DD Text -- ^ Device Dependent - deriving (Eq, Ord, Show, Read) - -instance PrintDot StyleName where - unqtDot Dashed = text "dashed" - unqtDot Dotted = text "dotted" - unqtDot Solid = text "solid" - unqtDot Bold = text "bold" - unqtDot Invisible = text "invis" - unqtDot Filled = text "filled" - unqtDot Diagonals = text "diagonals" - unqtDot Rounded = text "rounded" - unqtDot Tapered = text "tapered" - unqtDot Radial = text "radial" - unqtDot (DD nm) = unqtDot nm - - toDot (DD nm) = toDot nm - toDot sn = unqtDot sn - -instance ParseDot StyleName where - parseUnqt = liftM checkDD parseStyleName - - parse = quotedParse parseUnqt - `onFail` - liftM checkDD quotelessString - -checkDD :: Text -> StyleName -checkDD str = case T.toLower str of - "dashed" -> Dashed - "dotted" -> Dotted - "solid" -> Solid - "bold" -> Bold - "invis" -> Invisible - "filled" -> Filled - "diagonals" -> Diagonals - "rounded" -> Rounded - "tapered" -> Tapered - "radial" -> Radial - _ -> DD str - -parseStyleName :: Parse Text -parseStyleName = do f <- orEscaped . noneOf $ ' ' : disallowedChars - r <- parseEscaped True [] disallowedChars - return $ f `T.cons` r - where - disallowedChars = [quoteChar, '(', ')', ','] - -- Used because the first character has slightly stricter requirements than the rest. - orSlash p = stringRep '\\' "\\\\" `onFail` p - orEscaped = orQuote . orSlash - --- ----------------------------------------------------------------------------- - -data ViewPort = VP { wVal :: Double - , hVal :: Double - , zVal :: Double - , focus :: Maybe FocusType - } - deriving (Eq, Ord, Show, Read) - -instance PrintDot ViewPort where - unqtDot vp = maybe vs ((<>) (vs <> comma) . unqtDot) - $ focus vp - where - vs = hcat . punctuate comma - $ mapM (unqtDot . flip ($) vp) [wVal, hVal, zVal] - - toDot = dquotes . unqtDot - -instance ParseDot ViewPort where - parseUnqt = do wv <- parseUnqt - parseComma - hv <- parseUnqt - parseComma - zv <- parseUnqt - mf <- optional $ parseComma >> parseUnqt - return $ VP wv hv zv mf - - parse = quotedParse parseUnqt - --- | For use with 'ViewPort'. -data FocusType = XY Point - | NodeFocus Text - deriving (Eq, Ord, Show, Read) - -instance PrintDot FocusType where - unqtDot (XY p) = unqtDot p - unqtDot (NodeFocus nm) = unqtDot nm - - toDot (XY p) = toDot p - toDot (NodeFocus nm) = toDot nm - -instance ParseDot FocusType where - parseUnqt = liftM XY parseUnqt - `onFail` - liftM NodeFocus parseUnqt - - parse = liftM XY parse - `onFail` - liftM NodeFocus parse - --- ----------------------------------------------------------------------------- - -data VerticalPlacement = VTop - | VCenter -- ^ Only valid for Nodes. - | VBottom - deriving (Eq, Ord, Bounded, Enum, Show, Read) - -instance PrintDot VerticalPlacement where - unqtDot VTop = char 't' - unqtDot VCenter = char 'c' - unqtDot VBottom = char 'b' - -instance ParseDot VerticalPlacement where - parseUnqt = oneOf [ stringRep VTop "t" - , stringRep VCenter "c" - , stringRep VBottom "b" - ] - --- ----------------------------------------------------------------------------- - -newtype Paths = Paths { paths :: [FilePath] } - deriving (Eq, Ord, Show, Read) - -instance PrintDot Paths where - unqtDot = unqtDot . intercalate [searchPathSeparator] . paths - - toDot (Paths [p]) = toDot p - toDot ps = dquotes $ unqtDot ps - -instance ParseDot Paths where - parseUnqt = liftM (Paths . splitSearchPath) parseUnqt - - parse = quotedParse parseUnqt - `onFail` - liftM (Paths . (:[]) . T.unpack) quotelessString - --- ----------------------------------------------------------------------------- - -data ScaleType = UniformScale - | NoScale - | FillWidth - | FillHeight - | FillBoth - deriving (Eq, Ord, Bounded, Enum, Show, Read) - -instance PrintDot ScaleType where - unqtDot UniformScale = unqtDot True - unqtDot NoScale = unqtDot False - unqtDot FillWidth = text "width" - unqtDot FillHeight = text "height" - unqtDot FillBoth = text "both" - -instance ParseDot ScaleType where - parseUnqt = oneOf [ stringRep UniformScale "true" - , stringRep NoScale "false" - , stringRep FillWidth "width" - , stringRep FillHeight "height" - , stringRep FillBoth "both" - ] - --- ----------------------------------------------------------------------------- - -data Justification = JLeft - | JRight - | JCenter - deriving (Eq, Ord, Bounded, Enum, Show, Read) - -instance PrintDot Justification where - unqtDot JLeft = char 'l' - unqtDot JRight = char 'r' - unqtDot JCenter = char 'c' - -instance ParseDot Justification where - parseUnqt = oneOf [ stringRep JLeft "l" - , stringRep JRight "r" - , stringRep JCenter "c" - ] - --- ----------------------------------------------------------------------------- - -data Ratios = AspectRatio Double - | FillRatio - | CompressRatio - | ExpandRatio - | AutoRatio - deriving (Eq, Ord, Show, Read) - -instance PrintDot Ratios where - unqtDot (AspectRatio r) = unqtDot r - unqtDot FillRatio = text "fill" - unqtDot CompressRatio = text "compress" - unqtDot ExpandRatio = text "expand" - unqtDot AutoRatio = text "auto" - -instance ParseDot Ratios where - parseUnqt = oneOf [ liftM AspectRatio parseUnqt - , stringRep FillRatio "fill" - , stringRep CompressRatio "compress" - , stringRep ExpandRatio "expand" - , stringRep AutoRatio "auto" - ] +{-# LANGUAGE CPP, OverloadedStrings #-} + +{- | + Module : Data.GraphViz.Attributes.Complete + Description : Definition of the Graphviz attributes. + Copyright : (c) Matthew Sackman, Ivan Lazar Miljenovic + License : 3-Clause BSD-style + Maintainer : Ivan.Miljenovic@gmail.com + + If you are just using graphviz to create basic Dot graphs, then you + probably want to use "Data.GraphViz.Attributes" rather than this + module. + + This module defines the various attributes that different parts of + a Graphviz graph can have. These attributes are based on the + documentation found at: + + + For more information on usage, etc. please see that document. + + A summary of known current constraints\/limitations\/differences: + + * Note that for an edge, in /Dot/ parlance if the edge goes from + /A/ to /B/, then /A/ is the tail node and /B/ is the head node + (since /A/ is at the tail end of the arrow). + + * @ColorList@, @DoubleList@ and @PointfList@ are defined as actual + lists (@'LayerList'@ needs a newtype for other reasons). All of these + are assumed to be non-empty lists. + + * For the various @*Color@ attributes that take in a list of + 'Color' values, usually only one color is used. The @Color@ + attribute for edges allows multiple values; for other attributes, + two values are supported for gradient fills in Graphviz >= + 2.29.0. + + * Style is implemented as a list of 'StyleItem' values; note that + empty lists are not allowed. + + * A lot of values have a possible value of @none@. These now + have custom constructors. In fact, most constructors have been + expanded upon to give an idea of what they represent rather than + using generic terms. + + * 'Rect' uses two 'Point' values to denote the lower-left and + top-right corners. + + * The two 'LabelLoc' attributes have been combined. + + * @SplineType@ has been replaced with @['Spline']@. + + * Only polygon-based 'Shape's are available. + + * Not every 'Attribute' is fully documented/described. However, + all those which have specific allowed values should be covered. + + * Deprecated 'Overlap' algorithms are not defined. Furthermore, + the ability to specify an integer prefix for use with the fdp layout + is /not/ supported. + + * The global @Orientation@ attribute is not defined, as it is + difficult to distinguish from the node-based 'Orientation' + 'Attribute'; also, its behaviour is duplicated by 'Rotate'. + + * The @charset@ attribute is not available, as graphviz only + supports UTF-8 encoding (as it is not currently feasible nor needed to + also support Latin1 encoding). + + * In Graphviz, when a node or edge has a list of attributes, the + colorscheme which is used to identify a color can be set /after/ + that color (e.g. @[colorscheme=x11,color=grey,colorscheme=svg]@ + uses the svg colorscheme's definition of grey, which is different + from the x11 one. Instead, graphviz parses them in order. + + -} +module Data.GraphViz.Attributes.Complete + ( -- * The actual /Dot/ attributes. + -- $attributes + Attribute(..) + , Attributes + , sameAttribute + , defaultAttributeValue + , rmUnwantedAttributes + -- ** Validity functions on @Attribute@ values. + , usedByGraphs + , usedBySubGraphs + , usedByClusters + , usedByNodes + , usedByEdges + , validUnknown + + -- ** Custom attributes. + , AttributeName + , CustomAttribute + , customAttribute + , isCustom + , isSpecifiedCustom + , customValue + , customName + , findCustoms + , findSpecifiedCustom + , deleteCustomAttributes + , deleteSpecifiedCustom + + -- * Value types for @Attribute@s. + , module Data.GraphViz.Attributes.Colors + + -- ** Generic types + , Number (..) + + -- ** Labels + , EscString + , Label(..) + , VerticalPlacement(..) + , LabelScheme(..) + , SVGFontNames(..) + -- *** Types representing the Dot grammar for records. + , RecordFields + , RecordField(..) + , Rect(..) + , Justification(..) + + -- ** Nodes + , Shape(..) + , Paths(..) + , ScaleType(..) + , NodeSize(..) + + -- ** Edges + , DirType(..) + , EdgeType(..) + -- *** Modifying where edges point + , PortName(..) + , PortPos(..) + , CompassPoint(..) + -- *** Arrows + , ArrowType(..) + , ArrowShape(..) + , ArrowModifier(..) + , ArrowFill(..) + , ArrowSide(..) + -- **** @ArrowModifier@ values + , noMods + , openMod + + -- ** Positioning + , Point(..) + , createPoint + , Pos(..) + , Spline(..) + , DPoint(..) + , Normalized (..) + + -- ** Layout + , GraphvizCommand(..) + , GraphSize(..) + , ClusterMode(..) + , Model(..) + , Overlap(..) + , Root(..) + , Order(..) + , OutputMode(..) + , Pack(..) + , PackMode(..) + , PageDir(..) + , QuadType(..) + , RankType(..) + , RankDir(..) + , StartType(..) + , ViewPort(..) + , FocusType(..) + , Ratios(..) + + -- ** Modes + , ModeType(..) + , DEConstraints(..) + + -- ** Layers + , LayerSep(..) + , LayerListSep(..) + , LayerRange + , LayerRangeElem(..) + , LayerID(..) + , LayerList(..) + + -- ** Stylistic + , SmoothType(..) + , STStyle(..) + , StyleItem(..) + , StyleName(..) + ) where + +import Data.GraphViz.Attributes.Arrows +import Data.GraphViz.Attributes.Colors +import Data.GraphViz.Attributes.Colors.X11 (X11Color(Black)) +import Data.GraphViz.Attributes.Internal +import Data.GraphViz.Attributes.Values +import Data.GraphViz.Commands.Available +import Data.GraphViz.Exception (GraphvizException(NotCustomAttr), + throw) +import Data.GraphViz.Internal.State (getsGS, parseStrictly) +import Data.GraphViz.Internal.Util (bool, isIDString, keywords, + restIDString) +import Data.GraphViz.Parsing +import Data.GraphViz.Printing + +import Data.List (partition) +import Data.Maybe (isNothing) +import qualified Data.Set as S +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as T +import Data.Version (Version(..)) +import Data.Word (Word16) + +#if !MIN_VERSION_base (4,13,0) +import Data.Monoid ((<>)) +#endif + +-- ----------------------------------------------------------------------------- + +{- $attributes + + These attributes have been implemented in a /permissive/ manner: + that is, rather than split them up based on which type of value + they are allowed, they have all been included in the one data type, + with functions to determine if they are indeed valid for what + they're being applied to. + + To interpret the /Valid for/ listings: + + [@G@] Valid for Graphs. + + [@C@] Valid for Clusters. + + [@S@] Valid for Sub-Graphs (and also Clusters). + + [@N@] Valid for Nodes. + + [@E@] Valid for Edges. + + The /Default/ listings are those that the various Graphviz commands + use if that 'Attribute' isn't specified (in cases where this is + /none/, this is equivalent to a 'Nothing' value; that is, no value + is used). The /Parsing Default/ listings represent what value is + used (i.e. corresponds to 'True') when the 'Attribute' name is + listed on its own in /Dot/ source code. + + Please note that the 'UnknownAttribute' 'Attribute' is defined + primarily for backwards-compatibility purposes. It is possible to use + it directly for custom purposes; for more information, please see + 'CustomAttribute'. The 'deleteCustomAttributes' can be used to delete + these values. + + -} + +-- | Attributes are used to customise the layout and design of Dot +-- graphs. Care must be taken to ensure that the attribute you use +-- is valid, as not all attributes can be used everywhere. +data Attribute + = Damping Double -- ^ /Valid for/: G; /Default/: @0.99@; /Minimum/: @0.0@; /Notes/: 'Neato' only + | K Double -- ^ /Valid for/: GC; /Default/: @0.3@; /Minimum/: @0@; /Notes/: 'Sfdp', 'Fdp' only + | URL EscString -- ^ /Valid for/: ENGC; /Default/: none; /Notes/: svg, postscript, map only + | Area Double -- ^ /Valid for/: NC; /Default/: @1.0@; /Minimum/: @>0@; /Notes/: 'Patchwork' only, requires Graphviz >= 2.30.0 + | ArrowHead ArrowType -- ^ /Valid for/: E; /Default/: @'normal'@ + | ArrowSize Double -- ^ /Valid for/: E; /Default/: @1.0@; /Minimum/: @0.0@ + | ArrowTail ArrowType -- ^ /Valid for/: E; /Default/: @'normal'@ + | Background Text -- ^ /Valid for/: G; /Default/: none; /Notes/: xdot only + | BoundingBox Rect -- ^ /Valid for/: G; /Notes/: write only + | BgColor ColorList -- ^ /Valid for/: GC; /Default/: @[]@ + | Center Bool -- ^ /Valid for/: G; /Default/: @'False'@; /Parsing Default/: 'True' + | ClusterRank ClusterMode -- ^ /Valid for/: G; /Default/: @'Local'@; /Notes/: 'Dot' only + | Color ColorList -- ^ /Valid for/: ENC; /Default/: @['WC' ('X11Color' 'Black') Nothing]@ + | ColorScheme ColorScheme -- ^ /Valid for/: ENCG; /Default/: @'X11'@ + | Comment Text -- ^ /Valid for/: ENG; /Default/: @\"\"@ + | Compound Bool -- ^ /Valid for/: G; /Default/: @'False'@; /Parsing Default/: 'True'; /Notes/: 'Dot' only + | Concentrate Bool -- ^ /Valid for/: G; /Default/: @'False'@; /Parsing Default/: 'True' + | Constraint Bool -- ^ /Valid for/: E; /Default/: @'True'@; /Parsing Default/: 'True'; /Notes/: 'Dot' only + | Decorate Bool -- ^ /Valid for/: E; /Default/: @'False'@; /Parsing Default/: 'True' + | DefaultDist Double -- ^ /Valid for/: G; /Default/: @1+(avg. len)*sqrt(abs(V))@ (unable to statically define); /Minimum/: The value of 'Epsilon'.; /Notes/: 'Neato' only, only if @'Pack' 'DontPack'@ + | Dim Int -- ^ /Valid for/: G; /Default/: @2@; /Minimum/: @2@; /Notes/: maximum of @10@; 'Sfdp', 'Fdp', 'Neato' only + | Dimen Int -- ^ /Valid for/: G; /Default/: @2@; /Minimum/: @2@; /Notes/: maximum of @10@; 'Sfdp', 'Fdp', 'Neato' only + | Dir DirType -- ^ /Valid for/: E; /Default/: @'Forward'@ (directed), @'NoDir'@ (undirected) + | DirEdgeConstraints DEConstraints -- ^ /Valid for/: G; /Default/: @'NoConstraints'@; /Parsing Default/: 'EdgeConstraints'; /Notes/: 'Neato' only + | Distortion Double -- ^ /Valid for/: N; /Default/: @0.0@; /Minimum/: @-100.0@ + | DPI Double -- ^ /Valid for/: G; /Default/: @96.0@, @0.0@; /Notes/: svg, bitmap output only; \"resolution\" is a synonym + | EdgeURL EscString -- ^ /Valid for/: E; /Default/: @\"\"@; /Notes/: svg, map only + | EdgeTarget EscString -- ^ /Valid for/: E; /Default/: none; /Notes/: svg, map only + | EdgeTooltip EscString -- ^ /Valid for/: E; /Default/: @\"\"@; /Notes/: svg, cmap only + | Epsilon Double -- ^ /Valid for/: G; /Default/: @.0001 * # nodes@ (@mode == 'KK'@), @.0001@ (@mode == 'Major'@); /Notes/: 'Neato' only + | ESep DPoint -- ^ /Valid for/: G; /Default/: @'DVal' 3@; /Notes/: not 'Dot' + | FillColor ColorList -- ^ /Valid for/: NEC; /Default/: @['WC' ('X11Color' 'LightGray') Nothing]@ (nodes), @['WC' ('X11Color' 'Black') Nothing]@ (clusters) + | FixedSize NodeSize -- ^ /Valid for/: N; /Default/: @'GrowAsNeeded'@; /Parsing Default/: 'SetNodeSize' + | FontColor Color -- ^ /Valid for/: ENGC; /Default/: @'X11Color' 'Black'@ + | FontName Text -- ^ /Valid for/: ENGC; /Default/: @\"Times-Roman\"@ + | FontNames SVGFontNames -- ^ /Valid for/: G; /Default/: @'SvgNames'@; /Notes/: svg only + | FontPath Paths -- ^ /Valid for/: G; /Default/: system dependent + | FontSize Double -- ^ /Valid for/: ENGC; /Default/: @14.0@; /Minimum/: @1.0@ + | ForceLabels Bool -- ^ /Valid for/: G; /Default/: @'True'@; /Parsing Default/: 'True'; /Notes/: only for 'XLabel' attributes, requires Graphviz >= 2.29.0 + | GradientAngle Int -- ^ /Valid for/: NCG; /Default/: 0; /Notes/: requires Graphviz >= 2.29.0 + | Group Text -- ^ /Valid for/: N; /Default/: @\"\"@; /Notes/: 'Dot' only + | HeadURL EscString -- ^ /Valid for/: E; /Default/: @\"\"@; /Notes/: svg, map only + | Head_LP Point -- ^ /Valid for/: E; /Notes/: write only, requires Graphviz >= 2.30.0 + | HeadClip Bool -- ^ /Valid for/: E; /Default/: @'True'@; /Parsing Default/: 'True' + | HeadLabel Label -- ^ /Valid for/: E; /Default/: @'StrLabel' \"\"@ + | HeadPort PortPos -- ^ /Valid for/: E; /Default/: @'CompassPoint' 'CenterPoint'@ + | HeadTarget EscString -- ^ /Valid for/: E; /Default/: none; /Notes/: svg, map only + | HeadTooltip EscString -- ^ /Valid for/: E; /Default/: @\"\"@; /Notes/: svg, cmap only + | Height Double -- ^ /Valid for/: N; /Default/: @0.5@; /Minimum/: @0.02@ + | ID EscString -- ^ /Valid for/: GNE; /Default/: @\"\"@; /Notes/: svg, postscript, map only + | Image Text -- ^ /Valid for/: N; /Default/: @\"\"@ + | ImagePath Paths -- ^ /Valid for/: G; /Default/: @'Paths' []@; /Notes/: Printing and parsing is OS-specific, requires Graphviz >= 2.29.0 + | ImageScale ScaleType -- ^ /Valid for/: N; /Default/: @'NoScale'@; /Parsing Default/: 'UniformScale' + | InputScale Double -- ^ /Valid for/: N; /Default/: none; /Notes/: 'Fdp', 'Neato' only, a value of @0@ is equivalent to being @72@, requires Graphviz >= 2.36.0 + | Label Label -- ^ /Valid for/: ENGC; /Default/: @'StrLabel' \"\\N\"@ (nodes), @'StrLabel' \"\"@ (otherwise) + | LabelURL EscString -- ^ /Valid for/: E; /Default/: @\"\"@; /Notes/: svg, map only + | LabelScheme LabelScheme -- ^ /Valid for/: G; /Default/: @'NotEdgeLabel'@; /Notes/: 'Sfdp' only, requires Graphviz >= 2.28.0 + | LabelAngle Double -- ^ /Valid for/: E; /Default/: @-25.0@; /Minimum/: @-180.0@ + | LabelDistance Double -- ^ /Valid for/: E; /Default/: @1.0@; /Minimum/: @0.0@ + | LabelFloat Bool -- ^ /Valid for/: E; /Default/: @'False'@; /Parsing Default/: 'True' + | LabelFontColor Color -- ^ /Valid for/: E; /Default/: @'X11Color' 'Black'@ + | LabelFontName Text -- ^ /Valid for/: E; /Default/: @\"Times-Roman\"@ + | LabelFontSize Double -- ^ /Valid for/: E; /Default/: @14.0@; /Minimum/: @1.0@ + | LabelJust Justification -- ^ /Valid for/: GC; /Default/: @'JCenter'@ + | LabelLoc VerticalPlacement -- ^ /Valid for/: GCN; /Default/: @'VTop'@ (clusters), @'VBottom'@ (root graphs), @'VCenter'@ (nodes) + | LabelTarget EscString -- ^ /Valid for/: E; /Default/: none; /Notes/: svg, map only + | LabelTooltip EscString -- ^ /Valid for/: E; /Default/: @\"\"@; /Notes/: svg, cmap only + | Landscape Bool -- ^ /Valid for/: G; /Default/: @'False'@; /Parsing Default/: 'True' + | Layer LayerRange -- ^ /Valid for/: ENC; /Default/: @[]@ + | LayerListSep LayerListSep -- ^ /Valid for/: G; /Default/: @'LLSep' \",\"@; /Notes/: requires Graphviz >= 2.30.0 + | Layers LayerList -- ^ /Valid for/: G; /Default/: @'LL' []@ + | LayerSelect LayerRange -- ^ /Valid for/: G; /Default/: @[]@ + | LayerSep LayerSep -- ^ /Valid for/: G; /Default/: @'LSep' \" :\t\"@ + | Layout GraphvizCommand -- ^ /Valid for/: G + | Len Double -- ^ /Valid for/: E; /Default/: @1.0@ ('Neato'), @0.3@ ('Fdp'); /Notes/: 'Fdp', 'Neato' only + | Levels Int -- ^ /Valid for/: G; /Default/: @'maxBound'@; /Minimum/: @0@; /Notes/: 'Sfdp' only + | LevelsGap Double -- ^ /Valid for/: G; /Default/: @0.0@; /Notes/: 'Neato' only + | LHead Text -- ^ /Valid for/: E; /Default/: @\"\"@; /Notes/: 'Dot' only + | LHeight Double -- ^ /Valid for/: GC; /Notes/: write only, requires Graphviz >= 2.28.0 + | LPos Point -- ^ /Valid for/: EGC; /Notes/: write only + | LTail Text -- ^ /Valid for/: E; /Default/: @\"\"@; /Notes/: 'Dot' only + | LWidth Double -- ^ /Valid for/: GC; /Notes/: write only, requires Graphviz >= 2.28.0 + | Margin DPoint -- ^ /Valid for/: NGC; /Default/: device dependent + | MaxIter Int -- ^ /Valid for/: G; /Default/: @100 * # nodes@ (@mode == 'KK'@), @200@ (@mode == 'Major'@), @600@ ('Fdp'); /Notes/: 'Fdp', 'Neato' only + | MCLimit Double -- ^ /Valid for/: G; /Default/: @1.0@; /Notes/: 'Dot' only + | MinDist Double -- ^ /Valid for/: G; /Default/: @1.0@; /Minimum/: @0.0@; /Notes/: 'Circo' only + | MinLen Int -- ^ /Valid for/: E; /Default/: @1@; /Minimum/: @0@; /Notes/: 'Dot' only + | Mode ModeType -- ^ /Valid for/: G; /Default/: @'Major'@ (actually @'Spring'@ for 'Sfdp', but this isn't used as a default in this library); /Notes/: 'Neato', 'Sfdp' only + | Model Model -- ^ /Valid for/: G; /Default/: @'ShortPath'@; /Notes/: 'Neato' only + | Mosek Bool -- ^ /Valid for/: G; /Default/: @'False'@; /Parsing Default/: 'True'; /Notes/: 'Neato' only; requires the Mosek software + | NodeSep Double -- ^ /Valid for/: G; /Default/: @0.25@; /Minimum/: @0.02@ + | NoJustify Bool -- ^ /Valid for/: GCNE; /Default/: @'False'@; /Parsing Default/: 'True' + | Normalize Normalized -- ^ /Valid for/: G; /Default/: @'NotNormalized'@; /Parsing Default/: 'IsNormalized'; /Notes/: not 'Dot' + | NoTranslate Bool -- ^ /Valid for/: G; /Default/: @'False'@; /Parsing Default/: 'True'; /Notes/: 'Neato' only, requires Graphviz >= 2.38.0 + | Nslimit Double -- ^ /Valid for/: G; /Notes/: 'Dot' only + | Nslimit1 Double -- ^ /Valid for/: G; /Notes/: 'Dot' only + | Ordering Order -- ^ /Valid for/: GN; /Default/: none; /Notes/: 'Dot' only + | Orientation Double -- ^ /Valid for/: N; /Default/: @0.0@; /Minimum/: @360.0@ + | OutputOrder OutputMode -- ^ /Valid for/: G; /Default/: @'BreadthFirst'@ + | Overlap Overlap -- ^ /Valid for/: G; /Default/: @'KeepOverlaps'@; /Parsing Default/: 'KeepOverlaps'; /Notes/: not 'Dot' + | OverlapScaling Double -- ^ /Valid for/: G; /Default/: @-4@; /Minimum/: @-1.0e10@; /Notes/: 'PrismOverlap' only + | OverlapShrink Bool -- ^ /Valid for/: G; /Default/: @'True'@; /Parsing Default/: 'True'; /Notes/: 'PrismOverlap' only, requires Graphviz >= 2.36.0 + | Pack Pack -- ^ /Valid for/: G; /Default/: @'DontPack'@; /Parsing Default/: 'DoPack' + | PackMode PackMode -- ^ /Valid for/: G; /Default/: @'PackNode'@ + | Pad DPoint -- ^ /Valid for/: G; /Default/: @'DVal' 0.0555@ (4 points) + | Page Point -- ^ /Valid for/: G + | PageDir PageDir -- ^ /Valid for/: G; /Default/: @'Bl'@ + | PenColor Color -- ^ /Valid for/: C; /Default/: @'X11Color' 'Black'@ + | PenWidth Double -- ^ /Valid for/: CNE; /Default/: @1.0@; /Minimum/: @0.0@ + | Peripheries Int -- ^ /Valid for/: NC; /Default/: shape default (nodes), @1@ (clusters); /Minimum/: 0 + | Pin Bool -- ^ /Valid for/: N; /Default/: @'False'@; /Parsing Default/: 'True'; /Notes/: 'Fdp', 'Neato' only + | Pos Pos -- ^ /Valid for/: EN + | QuadTree QuadType -- ^ /Valid for/: G; /Default/: @'NormalQT'@; /Parsing Default/: 'NormalQT'; /Notes/: 'Sfdp' only + | Quantum Double -- ^ /Valid for/: G; /Default/: @0.0@; /Minimum/: @0.0@ + | Rank RankType -- ^ /Valid for/: S; /Notes/: 'Dot' only + | RankDir RankDir -- ^ /Valid for/: G; /Default/: @'FromTop'@; /Notes/: 'Dot' only + | RankSep [Double] -- ^ /Valid for/: G; /Default/: @[0.5]@ ('Dot'), @[1.0]@ ('Twopi'); /Minimum/: @[0.02]@; /Notes/: 'Twopi', 'Dot' only + | Ratio Ratios -- ^ /Valid for/: G + | Rects [Rect] -- ^ /Valid for/: N; /Notes/: write only + | Regular Bool -- ^ /Valid for/: N; /Default/: @'False'@; /Parsing Default/: 'True' + | ReMinCross Bool -- ^ /Valid for/: G; /Default/: @'False'@; /Parsing Default/: 'True'; /Notes/: 'Dot' only + | RepulsiveForce Double -- ^ /Valid for/: G; /Default/: @1.0@; /Minimum/: @0.0@; /Notes/: 'Sfdp' only + | Root Root -- ^ /Valid for/: GN; /Default/: @'NodeName' \"\"@ (graphs), @'NotCentral'@ (nodes); /Parsing Default/: 'IsCentral'; /Notes/: 'Circo', 'Twopi' only + | Rotate Int -- ^ /Valid for/: G; /Default/: @0@ + | Rotation Double -- ^ /Valid for/: G; /Default/: @0@; /Notes/: 'Sfdp' only, requires Graphviz >= 2.28.0 + | SameHead Text -- ^ /Valid for/: E; /Default/: @\"\"@; /Notes/: 'Dot' only + | SameTail Text -- ^ /Valid for/: E; /Default/: @\"\"@; /Notes/: 'Dot' only + | SamplePoints Int -- ^ /Valid for/: N; /Default/: @8@ (output), @20@ (overlap and image maps) + | Scale DPoint -- ^ /Valid for/: G; /Notes/: Not 'Dot', requires Graphviz >= 2.28.0 (>= 2.38.0 for anything except 'TwoPi') + | SearchSize Int -- ^ /Valid for/: G; /Default/: @30@; /Notes/: 'Dot' only + | Sep DPoint -- ^ /Valid for/: G; /Default/: @'DVal' 4@; /Notes/: not 'Dot' + | Shape Shape -- ^ /Valid for/: N; /Default/: @'Ellipse'@ + | ShowBoxes Int -- ^ /Valid for/: ENG; /Default/: @0@; /Minimum/: @0@; /Notes/: 'Dot' only; used for debugging by printing PostScript guide boxes + | Sides Int -- ^ /Valid for/: N; /Default/: @4@; /Minimum/: @0@ + | Size GraphSize -- ^ /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 Word16 -- ^ /Valid for/: GCN; /Default/: @0@; /Minimum/: @0@ + | Splines EdgeType -- ^ /Valid for/: G; /Default/: @'SplineEdges'@ ('Dot'), @'LineEdges'@ (other); /Parsing Default/: 'SplineEdges' + | Start StartType -- ^ /Valid for/: G; /Default/: @'StartStyleSeed' 'RandomStyle' seed@ for some unknown fixed seed.; /Notes/: 'Fdp', 'Neato' only + | Style [StyleItem] -- ^ /Valid for/: ENCG + | StyleSheet Text -- ^ /Valid for/: G; /Default/: @\"\"@; /Notes/: svg only + | TailURL EscString -- ^ /Valid for/: E; /Default/: @\"\"@; /Notes/: svg, map only + | Tail_LP Point -- ^ /Valid for/: E; /Notes/: write only, requires Graphviz >= 2.30.0 + | TailClip Bool -- ^ /Valid for/: E; /Default/: @'True'@; /Parsing Default/: 'True' + | TailLabel Label -- ^ /Valid for/: E; /Default/: @'StrLabel' \"\"@ + | TailPort PortPos -- ^ /Valid for/: E; /Default/: @'CompassPoint' 'CenterPoint'@ + | TailTarget EscString -- ^ /Valid for/: E; /Default/: none; /Notes/: svg, map only + | TailTooltip EscString -- ^ /Valid for/: E; /Default/: @\"\"@; /Notes/: svg, cmap only + | Target EscString -- ^ /Valid for/: ENGC; /Default/: none; /Notes/: svg, map only + | Tooltip EscString -- ^ /Valid for/: NEC; /Default/: @\"\"@; /Notes/: svg, cmap only + | TrueColor Bool -- ^ /Valid for/: G; /Parsing Default/: 'True'; /Notes/: bitmap output only + | Vertices [Point] -- ^ /Valid for/: N; /Notes/: write only + | ViewPort ViewPort -- ^ /Valid for/: G; /Default/: none + | VoroMargin Double -- ^ /Valid for/: G; /Default/: @0.05@; /Minimum/: @0.0@; /Notes/: not 'Dot' + | Weight Number -- ^ /Valid for/: E; /Default/: @'Int' 1@; /Minimum/: @'Int' 0@ ('Dot'), @'Int' 1@ ('Neato','Fdp','Sfdp'); /Notes/: as of Graphviz 2.30: weights for dot need to be 'Int's + | Width Double -- ^ /Valid for/: N; /Default/: @0.75@; /Minimum/: @0.01@ + | XDotVersion Version -- ^ /Valid for/: G; /Notes/: xdot only, requires Graphviz >= 2.34.0, equivalent to specifying version of xdot to be used + | XLabel Label -- ^ /Valid for/: EN; /Default/: @'StrLabel' \"\"@; /Notes/: requires Graphviz >= 2.29.0 + | XLP Point -- ^ /Valid for/: EN; /Notes/: write only, requires Graphviz >= 2.29.0 + | UnknownAttribute AttributeName Text -- ^ /Valid for/: Assumed valid for all; the fields are 'Attribute' name and value respectively. + deriving (Eq, Ord, Show, Read) + +type Attributes = [Attribute] + +-- | The name for an UnknownAttribute; must satisfy 'validUnknown'. +type AttributeName = Text + +instance PrintDot Attribute where + unqtDot (Damping v) = printField "Damping" v + unqtDot (K v) = printField "K" v + unqtDot (URL v) = printField "URL" v + unqtDot (Area v) = printField "area" v + unqtDot (ArrowHead v) = printField "arrowhead" v + unqtDot (ArrowSize v) = printField "arrowsize" v + unqtDot (ArrowTail v) = printField "arrowtail" v + unqtDot (Background v) = printField "_background" v + unqtDot (BoundingBox v) = printField "bb" v + unqtDot (BgColor v) = printField "bgcolor" v + unqtDot (Center v) = printField "center" v + unqtDot (ClusterRank v) = printField "clusterrank" v + unqtDot (Color v) = printField "color" v + unqtDot (ColorScheme v) = printField "colorscheme" v + unqtDot (Comment v) = printField "comment" v + unqtDot (Compound v) = printField "compound" v + unqtDot (Concentrate v) = printField "concentrate" v + unqtDot (Constraint v) = printField "constraint" v + unqtDot (Decorate v) = printField "decorate" v + unqtDot (DefaultDist v) = printField "defaultdist" v + unqtDot (Dim v) = printField "dim" v + unqtDot (Dimen v) = printField "dimen" v + unqtDot (Dir v) = printField "dir" v + unqtDot (DirEdgeConstraints v) = printField "diredgeconstraints" v + unqtDot (Distortion v) = printField "distortion" v + unqtDot (DPI v) = printField "dpi" v + unqtDot (EdgeURL v) = printField "edgeURL" v + unqtDot (EdgeTarget v) = printField "edgetarget" v + unqtDot (EdgeTooltip v) = printField "edgetooltip" v + unqtDot (Epsilon v) = printField "epsilon" v + unqtDot (ESep v) = printField "esep" v + unqtDot (FillColor v) = printField "fillcolor" v + unqtDot (FixedSize v) = printField "fixedsize" v + unqtDot (FontColor v) = printField "fontcolor" v + unqtDot (FontName v) = printField "fontname" v + unqtDot (FontNames v) = printField "fontnames" v + unqtDot (FontPath v) = printField "fontpath" v + unqtDot (FontSize v) = printField "fontsize" v + unqtDot (ForceLabels v) = printField "forcelabels" v + unqtDot (GradientAngle v) = printField "gradientangle" v + unqtDot (Group v) = printField "group" v + unqtDot (HeadURL v) = printField "headURL" v + unqtDot (Head_LP v) = printField "head_lp" v + unqtDot (HeadClip v) = printField "headclip" v + unqtDot (HeadLabel v) = printField "headlabel" v + unqtDot (HeadPort v) = printField "headport" v + unqtDot (HeadTarget v) = printField "headtarget" v + unqtDot (HeadTooltip v) = printField "headtooltip" v + unqtDot (Height v) = printField "height" v + unqtDot (ID v) = printField "id" v + unqtDot (Image v) = printField "image" v + unqtDot (ImagePath v) = printField "imagepath" v + unqtDot (ImageScale v) = printField "imagescale" v + unqtDot (InputScale v) = printField "inputscale" v + unqtDot (Label v) = printField "label" v + unqtDot (LabelURL v) = printField "labelURL" v + unqtDot (LabelScheme v) = printField "label_scheme" v + unqtDot (LabelAngle v) = printField "labelangle" v + unqtDot (LabelDistance v) = printField "labeldistance" v + unqtDot (LabelFloat v) = printField "labelfloat" v + unqtDot (LabelFontColor v) = printField "labelfontcolor" v + unqtDot (LabelFontName v) = printField "labelfontname" v + unqtDot (LabelFontSize v) = printField "labelfontsize" v + unqtDot (LabelJust v) = printField "labeljust" v + unqtDot (LabelLoc v) = printField "labelloc" v + unqtDot (LabelTarget v) = printField "labeltarget" v + unqtDot (LabelTooltip v) = printField "labeltooltip" v + unqtDot (Landscape v) = printField "landscape" v + unqtDot (Layer v) = printField "layer" v + unqtDot (LayerListSep v) = printField "layerlistsep" v + unqtDot (Layers v) = printField "layers" v + unqtDot (LayerSelect v) = printField "layerselect" v + unqtDot (LayerSep v) = printField "layersep" v + unqtDot (Layout v) = printField "layout" v + unqtDot (Len v) = printField "len" v + unqtDot (Levels v) = printField "levels" v + unqtDot (LevelsGap v) = printField "levelsgap" v + unqtDot (LHead v) = printField "lhead" v + unqtDot (LHeight v) = printField "LHeight" v + unqtDot (LPos v) = printField "lp" v + unqtDot (LTail v) = printField "ltail" v + unqtDot (LWidth v) = printField "lwidth" v + unqtDot (Margin v) = printField "margin" v + unqtDot (MaxIter v) = printField "maxiter" v + unqtDot (MCLimit v) = printField "mclimit" v + unqtDot (MinDist v) = printField "mindist" v + unqtDot (MinLen v) = printField "minlen" v + unqtDot (Mode v) = printField "mode" v + unqtDot (Model v) = printField "model" v + unqtDot (Mosek v) = printField "mosek" v + unqtDot (NodeSep v) = printField "nodesep" v + unqtDot (NoJustify v) = printField "nojustify" v + unqtDot (Normalize v) = printField "normalize" v + unqtDot (NoTranslate v) = printField "notranslate" v + unqtDot (Nslimit v) = printField "nslimit" v + unqtDot (Nslimit1 v) = printField "nslimit1" v + unqtDot (Ordering v) = printField "ordering" v + unqtDot (Orientation v) = printField "orientation" v + unqtDot (OutputOrder v) = printField "outputorder" v + unqtDot (Overlap v) = printField "overlap" v + unqtDot (OverlapScaling v) = printField "overlap_scaling" v + unqtDot (OverlapShrink v) = printField "overlap_shrink" v + unqtDot (Pack v) = printField "pack" v + unqtDot (PackMode v) = printField "packmode" v + unqtDot (Pad v) = printField "pad" v + unqtDot (Page v) = printField "page" v + unqtDot (PageDir v) = printField "pagedir" v + unqtDot (PenColor v) = printField "pencolor" v + unqtDot (PenWidth v) = printField "penwidth" v + unqtDot (Peripheries v) = printField "peripheries" v + unqtDot (Pin v) = printField "pin" v + unqtDot (Pos v) = printField "pos" v + unqtDot (QuadTree v) = printField "quadtree" v + unqtDot (Quantum v) = printField "quantum" v + unqtDot (Rank v) = printField "rank" v + unqtDot (RankDir v) = printField "rankdir" v + unqtDot (RankSep v) = printField "ranksep" v + unqtDot (Ratio v) = printField "ratio" v + unqtDot (Rects v) = printField "rects" v + unqtDot (Regular v) = printField "regular" v + unqtDot (ReMinCross v) = printField "remincross" v + unqtDot (RepulsiveForce v) = printField "repulsiveforce" v + unqtDot (Root v) = printField "root" v + unqtDot (Rotate v) = printField "rotate" v + unqtDot (Rotation v) = printField "rotation" v + unqtDot (SameHead v) = printField "samehead" v + unqtDot (SameTail v) = printField "sametail" v + unqtDot (SamplePoints v) = printField "samplepoints" v + unqtDot (Scale v) = printField "scale" v + unqtDot (SearchSize v) = printField "searchsize" v + unqtDot (Sep v) = printField "sep" v + unqtDot (Shape v) = printField "shape" v + unqtDot (ShowBoxes v) = printField "showboxes" v + unqtDot (Sides v) = printField "sides" v + unqtDot (Size v) = printField "size" v + unqtDot (Skew v) = printField "skew" v + unqtDot (Smoothing v) = printField "smoothing" v + unqtDot (SortV v) = printField "sortv" v + unqtDot (Splines v) = printField "splines" v + unqtDot (Start v) = printField "start" v + unqtDot (Style v) = printField "style" v + unqtDot (StyleSheet v) = printField "stylesheet" v + unqtDot (TailURL v) = printField "tailURL" v + unqtDot (Tail_LP v) = printField "tail_lp" v + unqtDot (TailClip v) = printField "tailclip" v + unqtDot (TailLabel v) = printField "taillabel" v + unqtDot (TailPort v) = printField "tailport" v + unqtDot (TailTarget v) = printField "tailtarget" v + unqtDot (TailTooltip v) = printField "tailtooltip" v + unqtDot (Target v) = printField "target" v + unqtDot (Tooltip v) = printField "tooltip" v + unqtDot (TrueColor v) = printField "truecolor" v + unqtDot (Vertices v) = printField "vertices" v + unqtDot (ViewPort v) = printField "viewport" v + unqtDot (VoroMargin v) = printField "voro_margin" v + unqtDot (Weight v) = printField "weight" v + unqtDot (Width v) = printField "width" v + unqtDot (XDotVersion v) = printField "xdotversion" v + unqtDot (XLabel v) = printField "xlabel" v + unqtDot (XLP v) = printField "xlp" v + unqtDot (UnknownAttribute a v) = toDot a <> equals <> toDot v + + listToDot = unqtListToDot + +instance ParseDot Attribute where + parseUnqt = stringParse (concat [ parseField Damping "Damping" + , parseField K "K" + , parseFields URL ["URL", "href"] + , parseField Area "area" + , parseField ArrowHead "arrowhead" + , parseField ArrowSize "arrowsize" + , parseField ArrowTail "arrowtail" + , parseField Background "_background" + , parseField BoundingBox "bb" + , parseField BgColor "bgcolor" + , parseFieldBool Center "center" + , parseField ClusterRank "clusterrank" + , parseField Color "color" + , parseField ColorScheme "colorscheme" + , parseField Comment "comment" + , parseFieldBool Compound "compound" + , parseFieldBool Concentrate "concentrate" + , parseFieldBool Constraint "constraint" + , parseFieldBool Decorate "decorate" + , parseField DefaultDist "defaultdist" + , parseField Dim "dim" + , parseField Dimen "dimen" + , parseField Dir "dir" + , parseFieldDef DirEdgeConstraints EdgeConstraints "diredgeconstraints" + , parseField Distortion "distortion" + , parseFields DPI ["dpi", "resolution"] + , parseFields EdgeURL ["edgeURL", "edgehref"] + , parseField EdgeTarget "edgetarget" + , parseField EdgeTooltip "edgetooltip" + , parseField Epsilon "epsilon" + , parseField ESep "esep" + , parseField FillColor "fillcolor" + , parseFieldDef FixedSize SetNodeSize "fixedsize" + , parseField FontColor "fontcolor" + , parseField FontName "fontname" + , parseField FontNames "fontnames" + , parseField FontPath "fontpath" + , parseField FontSize "fontsize" + , parseFieldBool ForceLabels "forcelabels" + , parseField GradientAngle "gradientangle" + , parseField Group "group" + , parseFields HeadURL ["headURL", "headhref"] + , parseField Head_LP "head_lp" + , parseFieldBool HeadClip "headclip" + , parseField HeadLabel "headlabel" + , parseField HeadPort "headport" + , parseField HeadTarget "headtarget" + , parseField HeadTooltip "headtooltip" + , parseField Height "height" + , parseField ID "id" + , parseField Image "image" + , parseField ImagePath "imagepath" + , parseFieldDef ImageScale UniformScale "imagescale" + , parseField InputScale "inputscale" + , parseField Label "label" + , parseFields LabelURL ["labelURL", "labelhref"] + , parseField LabelScheme "label_scheme" + , parseField LabelAngle "labelangle" + , parseField LabelDistance "labeldistance" + , parseFieldBool LabelFloat "labelfloat" + , parseField LabelFontColor "labelfontcolor" + , parseField LabelFontName "labelfontname" + , parseField LabelFontSize "labelfontsize" + , parseField LabelJust "labeljust" + , parseField LabelLoc "labelloc" + , parseField LabelTarget "labeltarget" + , parseField LabelTooltip "labeltooltip" + , parseFieldBool Landscape "landscape" + , parseField Layer "layer" + , parseField LayerListSep "layerlistsep" + , parseField Layers "layers" + , parseField LayerSelect "layerselect" + , parseField LayerSep "layersep" + , parseField Layout "layout" + , parseField Len "len" + , parseField Levels "levels" + , parseField LevelsGap "levelsgap" + , parseField LHead "lhead" + , parseField LHeight "LHeight" + , parseField LPos "lp" + , parseField LTail "ltail" + , parseField LWidth "lwidth" + , parseField Margin "margin" + , parseField MaxIter "maxiter" + , parseField MCLimit "mclimit" + , parseField MinDist "mindist" + , parseField MinLen "minlen" + , parseField Mode "mode" + , parseField Model "model" + , parseFieldBool Mosek "mosek" + , parseField NodeSep "nodesep" + , parseFieldBool NoJustify "nojustify" + , parseFieldDef Normalize IsNormalized "normalize" + , parseFieldBool NoTranslate "notranslate" + , parseField Nslimit "nslimit" + , parseField Nslimit1 "nslimit1" + , parseField Ordering "ordering" + , parseField Orientation "orientation" + , parseField OutputOrder "outputorder" + , parseFieldDef Overlap KeepOverlaps "overlap" + , parseField OverlapScaling "overlap_scaling" + , parseFieldBool OverlapShrink "overlap_shrink" + , parseFieldDef Pack DoPack "pack" + , parseField PackMode "packmode" + , parseField Pad "pad" + , parseField Page "page" + , parseField PageDir "pagedir" + , parseField PenColor "pencolor" + , parseField PenWidth "penwidth" + , parseField Peripheries "peripheries" + , parseFieldBool Pin "pin" + , parseField Pos "pos" + , parseFieldDef QuadTree NormalQT "quadtree" + , parseField Quantum "quantum" + , parseField Rank "rank" + , parseField RankDir "rankdir" + , parseField RankSep "ranksep" + , parseField Ratio "ratio" + , parseField Rects "rects" + , parseFieldBool Regular "regular" + , parseFieldBool ReMinCross "remincross" + , parseField RepulsiveForce "repulsiveforce" + , parseFieldDef Root IsCentral "root" + , parseField Rotate "rotate" + , parseField Rotation "rotation" + , parseField SameHead "samehead" + , parseField SameTail "sametail" + , parseField SamplePoints "samplepoints" + , parseField Scale "scale" + , parseField SearchSize "searchsize" + , parseField Sep "sep" + , parseField Shape "shape" + , parseField ShowBoxes "showboxes" + , parseField Sides "sides" + , parseField Size "size" + , parseField Skew "skew" + , parseField Smoothing "smoothing" + , parseField SortV "sortv" + , parseFieldDef Splines SplineEdges "splines" + , parseField Start "start" + , parseField Style "style" + , parseField StyleSheet "stylesheet" + , parseFields TailURL ["tailURL", "tailhref"] + , parseField Tail_LP "tail_lp" + , parseFieldBool TailClip "tailclip" + , parseField TailLabel "taillabel" + , parseField TailPort "tailport" + , parseField TailTarget "tailtarget" + , parseField TailTooltip "tailtooltip" + , parseField Target "target" + , parseField Tooltip "tooltip" + , parseFieldBool TrueColor "truecolor" + , parseField Vertices "vertices" + , parseField ViewPort "viewport" + , parseField VoroMargin "voro_margin" + , parseField Weight "weight" + , parseField Width "width" + , parseField XDotVersion "xdotversion" + , parseField XLabel "xlabel" + , parseField XLP "xlp" + ]) + `onFail` + do attrName <- stringBlock + liftEqParse ("UnknownAttribute (" ++ T.unpack attrName ++ ")") + (UnknownAttribute attrName) + + parse = parseUnqt + + parseList = parseUnqtList + +-- | Determine if this 'Attribute' is valid for use with Graphs. +usedByGraphs :: Attribute -> Bool +usedByGraphs Damping{} = True +usedByGraphs K{} = True +usedByGraphs URL{} = True +usedByGraphs Background{} = True +usedByGraphs BoundingBox{} = True +usedByGraphs BgColor{} = True +usedByGraphs Center{} = True +usedByGraphs ClusterRank{} = True +usedByGraphs ColorScheme{} = True +usedByGraphs Comment{} = True +usedByGraphs Compound{} = True +usedByGraphs Concentrate{} = True +usedByGraphs DefaultDist{} = True +usedByGraphs Dim{} = True +usedByGraphs Dimen{} = True +usedByGraphs DirEdgeConstraints{} = True +usedByGraphs DPI{} = True +usedByGraphs Epsilon{} = True +usedByGraphs ESep{} = True +usedByGraphs FontColor{} = True +usedByGraphs FontName{} = True +usedByGraphs FontNames{} = True +usedByGraphs FontPath{} = True +usedByGraphs FontSize{} = True +usedByGraphs ForceLabels{} = True +usedByGraphs GradientAngle{} = True +usedByGraphs ID{} = True +usedByGraphs ImagePath{} = True +usedByGraphs Label{} = True +usedByGraphs LabelScheme{} = True +usedByGraphs LabelJust{} = True +usedByGraphs LabelLoc{} = True +usedByGraphs Landscape{} = True +usedByGraphs LayerListSep{} = True +usedByGraphs Layers{} = True +usedByGraphs LayerSelect{} = True +usedByGraphs LayerSep{} = True +usedByGraphs Layout{} = True +usedByGraphs Levels{} = True +usedByGraphs LevelsGap{} = True +usedByGraphs LHeight{} = True +usedByGraphs LPos{} = True +usedByGraphs LWidth{} = True +usedByGraphs Margin{} = True +usedByGraphs MaxIter{} = True +usedByGraphs MCLimit{} = True +usedByGraphs MinDist{} = True +usedByGraphs Mode{} = True +usedByGraphs Model{} = True +usedByGraphs Mosek{} = True +usedByGraphs NodeSep{} = True +usedByGraphs NoJustify{} = True +usedByGraphs Normalize{} = True +usedByGraphs NoTranslate{} = True +usedByGraphs Nslimit{} = True +usedByGraphs Nslimit1{} = True +usedByGraphs Ordering{} = True +usedByGraphs OutputOrder{} = True +usedByGraphs Overlap{} = True +usedByGraphs OverlapScaling{} = True +usedByGraphs OverlapShrink{} = True +usedByGraphs Pack{} = True +usedByGraphs PackMode{} = True +usedByGraphs Pad{} = True +usedByGraphs Page{} = True +usedByGraphs PageDir{} = True +usedByGraphs QuadTree{} = True +usedByGraphs Quantum{} = True +usedByGraphs RankDir{} = True +usedByGraphs RankSep{} = True +usedByGraphs Ratio{} = True +usedByGraphs ReMinCross{} = True +usedByGraphs RepulsiveForce{} = True +usedByGraphs Root{} = True +usedByGraphs Rotate{} = True +usedByGraphs Rotation{} = True +usedByGraphs Scale{} = True +usedByGraphs SearchSize{} = True +usedByGraphs Sep{} = True +usedByGraphs ShowBoxes{} = True +usedByGraphs Size{} = True +usedByGraphs Smoothing{} = True +usedByGraphs SortV{} = True +usedByGraphs Splines{} = True +usedByGraphs Start{} = True +usedByGraphs Style{} = True +usedByGraphs StyleSheet{} = True +usedByGraphs Target{} = True +usedByGraphs TrueColor{} = True +usedByGraphs ViewPort{} = True +usedByGraphs VoroMargin{} = True +usedByGraphs XDotVersion{} = True +usedByGraphs UnknownAttribute{} = True +usedByGraphs _ = False + +-- | Determine if this 'Attribute' is valid for use with Clusters. +usedByClusters :: Attribute -> Bool +usedByClusters K{} = True +usedByClusters URL{} = True +usedByClusters Area{} = True +usedByClusters BgColor{} = True +usedByClusters Color{} = True +usedByClusters ColorScheme{} = True +usedByClusters FillColor{} = True +usedByClusters FontColor{} = True +usedByClusters FontName{} = True +usedByClusters FontSize{} = True +usedByClusters GradientAngle{} = True +usedByClusters Label{} = True +usedByClusters LabelJust{} = True +usedByClusters LabelLoc{} = True +usedByClusters Layer{} = True +usedByClusters LHeight{} = True +usedByClusters LPos{} = True +usedByClusters LWidth{} = True +usedByClusters Margin{} = True +usedByClusters NoJustify{} = True +usedByClusters PenColor{} = True +usedByClusters PenWidth{} = True +usedByClusters Peripheries{} = True +usedByClusters Rank{} = True +usedByClusters SortV{} = True +usedByClusters Style{} = True +usedByClusters Target{} = True +usedByClusters Tooltip{} = True +usedByClusters UnknownAttribute{} = True +usedByClusters _ = False + +-- | 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. +usedByNodes :: Attribute -> Bool +usedByNodes URL{} = True +usedByNodes Area{} = True +usedByNodes Color{} = True +usedByNodes ColorScheme{} = True +usedByNodes Comment{} = True +usedByNodes Distortion{} = True +usedByNodes FillColor{} = True +usedByNodes FixedSize{} = True +usedByNodes FontColor{} = True +usedByNodes FontName{} = True +usedByNodes FontSize{} = True +usedByNodes GradientAngle{} = True +usedByNodes Group{} = True +usedByNodes Height{} = True +usedByNodes ID{} = True +usedByNodes Image{} = True +usedByNodes ImageScale{} = True +usedByNodes InputScale{} = True +usedByNodes Label{} = True +usedByNodes LabelLoc{} = True +usedByNodes Layer{} = True +usedByNodes Margin{} = True +usedByNodes NoJustify{} = True +usedByNodes Ordering{} = True +usedByNodes Orientation{} = True +usedByNodes PenWidth{} = True +usedByNodes Peripheries{} = True +usedByNodes Pin{} = True +usedByNodes Pos{} = True +usedByNodes Rects{} = True +usedByNodes Regular{} = True +usedByNodes Root{} = True +usedByNodes SamplePoints{} = True +usedByNodes Shape{} = True +usedByNodes ShowBoxes{} = True +usedByNodes Sides{} = True +usedByNodes Skew{} = True +usedByNodes SortV{} = True +usedByNodes Style{} = True +usedByNodes Target{} = True +usedByNodes Tooltip{} = True +usedByNodes Vertices{} = True +usedByNodes Width{} = True +usedByNodes XLabel{} = True +usedByNodes XLP{} = True +usedByNodes UnknownAttribute{} = True +usedByNodes _ = False + +-- | Determine if this 'Attribute' is valid for use with Edges. +usedByEdges :: Attribute -> Bool +usedByEdges URL{} = True +usedByEdges ArrowHead{} = True +usedByEdges ArrowSize{} = True +usedByEdges ArrowTail{} = True +usedByEdges Color{} = True +usedByEdges ColorScheme{} = True +usedByEdges Comment{} = True +usedByEdges Constraint{} = True +usedByEdges Decorate{} = True +usedByEdges Dir{} = True +usedByEdges EdgeURL{} = True +usedByEdges EdgeTarget{} = True +usedByEdges EdgeTooltip{} = True +usedByEdges FillColor{} = True +usedByEdges FontColor{} = True +usedByEdges FontName{} = True +usedByEdges FontSize{} = True +usedByEdges HeadURL{} = True +usedByEdges Head_LP{} = True +usedByEdges HeadClip{} = True +usedByEdges HeadLabel{} = True +usedByEdges HeadPort{} = True +usedByEdges HeadTarget{} = True +usedByEdges HeadTooltip{} = True +usedByEdges ID{} = True +usedByEdges Label{} = True +usedByEdges LabelURL{} = True +usedByEdges LabelAngle{} = True +usedByEdges LabelDistance{} = True +usedByEdges LabelFloat{} = True +usedByEdges LabelFontColor{} = True +usedByEdges LabelFontName{} = True +usedByEdges LabelFontSize{} = True +usedByEdges LabelTarget{} = True +usedByEdges LabelTooltip{} = True +usedByEdges Layer{} = True +usedByEdges Len{} = True +usedByEdges LHead{} = True +usedByEdges LPos{} = True +usedByEdges LTail{} = True +usedByEdges MinLen{} = True +usedByEdges NoJustify{} = True +usedByEdges PenWidth{} = True +usedByEdges Pos{} = True +usedByEdges SameHead{} = True +usedByEdges SameTail{} = True +usedByEdges ShowBoxes{} = True +usedByEdges Style{} = True +usedByEdges TailURL{} = True +usedByEdges Tail_LP{} = True +usedByEdges TailClip{} = True +usedByEdges TailLabel{} = True +usedByEdges TailPort{} = True +usedByEdges TailTarget{} = True +usedByEdges TailTooltip{} = True +usedByEdges Target{} = True +usedByEdges Tooltip{} = True +usedByEdges Weight{} = True +usedByEdges XLabel{} = True +usedByEdges XLP{} = 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 Area{} Area{} = True +sameAttribute ArrowHead{} ArrowHead{} = True +sameAttribute ArrowSize{} ArrowSize{} = True +sameAttribute ArrowTail{} ArrowTail{} = True +sameAttribute Background{} Background{} = True +sameAttribute BoundingBox{} BoundingBox{} = True +sameAttribute BgColor{} BgColor{} = True +sameAttribute Center{} Center{} = True +sameAttribute ClusterRank{} ClusterRank{} = True +sameAttribute Color{} Color{} = True +sameAttribute ColorScheme{} ColorScheme{} = 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 Dim{} Dim{} = True +sameAttribute Dimen{} Dimen{} = 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 ForceLabels{} ForceLabels{} = True +sameAttribute GradientAngle{} GradientAngle{} = True +sameAttribute Group{} Group{} = True +sameAttribute HeadURL{} HeadURL{} = True +sameAttribute Head_LP{} Head_LP{} = 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 ImagePath{} ImagePath{} = True +sameAttribute ImageScale{} ImageScale{} = True +sameAttribute InputScale{} InputScale{} = True +sameAttribute Label{} Label{} = True +sameAttribute LabelURL{} LabelURL{} = True +sameAttribute LabelScheme{} LabelScheme{} = 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 Landscape{} Landscape{} = True +sameAttribute Layer{} Layer{} = True +sameAttribute LayerListSep{} LayerListSep{} = True +sameAttribute Layers{} Layers{} = True +sameAttribute LayerSelect{} LayerSelect{} = True +sameAttribute LayerSep{} LayerSep{} = True +sameAttribute Layout{} Layout{} = True +sameAttribute Len{} Len{} = True +sameAttribute Levels{} Levels{} = True +sameAttribute LevelsGap{} LevelsGap{} = True +sameAttribute LHead{} LHead{} = True +sameAttribute LHeight{} LHeight{} = True +sameAttribute LPos{} LPos{} = True +sameAttribute LTail{} LTail{} = True +sameAttribute LWidth{} LWidth{} = True +sameAttribute Margin{} Margin{} = True +sameAttribute MaxIter{} MaxIter{} = True +sameAttribute MCLimit{} MCLimit{} = True +sameAttribute MinDist{} MinDist{} = True +sameAttribute MinLen{} MinLen{} = True +sameAttribute Mode{} Mode{} = True +sameAttribute Model{} Model{} = True +sameAttribute Mosek{} Mosek{} = True +sameAttribute NodeSep{} NodeSep{} = True +sameAttribute NoJustify{} NoJustify{} = True +sameAttribute Normalize{} Normalize{} = True +sameAttribute NoTranslate{} NoTranslate{} = True +sameAttribute Nslimit{} Nslimit{} = True +sameAttribute Nslimit1{} Nslimit1{} = True +sameAttribute Ordering{} Ordering{} = True +sameAttribute Orientation{} Orientation{} = True +sameAttribute OutputOrder{} OutputOrder{} = True +sameAttribute Overlap{} Overlap{} = True +sameAttribute OverlapScaling{} OverlapScaling{} = True +sameAttribute OverlapShrink{} OverlapShrink{} = True +sameAttribute Pack{} Pack{} = True +sameAttribute PackMode{} PackMode{} = True +sameAttribute Pad{} Pad{} = True +sameAttribute Page{} Page{} = True +sameAttribute PageDir{} PageDir{} = 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 Rank{} Rank{} = True +sameAttribute RankDir{} RankDir{} = True +sameAttribute RankSep{} RankSep{} = 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 Rotation{} Rotation{} = True +sameAttribute SameHead{} SameHead{} = True +sameAttribute SameTail{} SameTail{} = True +sameAttribute SamplePoints{} SamplePoints{} = True +sameAttribute Scale{} Scale{} = True +sameAttribute SearchSize{} SearchSize{} = True +sameAttribute Sep{} Sep{} = 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 Style{} Style{} = True +sameAttribute StyleSheet{} StyleSheet{} = True +sameAttribute TailURL{} TailURL{} = True +sameAttribute Tail_LP{} Tail_LP{} = 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 XDotVersion{} XDotVersion{} = True +sameAttribute XLabel{} XLabel{} = True +sameAttribute XLP{} XLP{} = True +sameAttribute (UnknownAttribute a1 _) (UnknownAttribute a2 _) = a1 == a2 +sameAttribute _ _ = False + +-- | Return the default value for a specific 'Attribute' if possible; graph/cluster values are preferred over node/edge values. +defaultAttributeValue :: Attribute -> Maybe Attribute +defaultAttributeValue Damping{} = Just $ Damping 0.99 +defaultAttributeValue K{} = Just $ K 0.3 +defaultAttributeValue URL{} = Just $ URL "" +defaultAttributeValue Area{} = Just $ Area 1.0 +defaultAttributeValue ArrowHead{} = Just $ ArrowHead normal +defaultAttributeValue ArrowSize{} = Just $ ArrowSize 1.0 +defaultAttributeValue ArrowTail{} = Just $ ArrowTail normal +defaultAttributeValue Background{} = Just $ Background "" +defaultAttributeValue BgColor{} = Just $ BgColor [] +defaultAttributeValue Center{} = Just $ Center False +defaultAttributeValue ClusterRank{} = Just $ ClusterRank Local +defaultAttributeValue Color{} = Just $ Color [toWColor Black] +defaultAttributeValue ColorScheme{} = Just $ ColorScheme X11 +defaultAttributeValue Comment{} = Just $ Comment "" +defaultAttributeValue Compound{} = Just $ Compound False +defaultAttributeValue Concentrate{} = Just $ Concentrate False +defaultAttributeValue Constraint{} = Just $ Constraint True +defaultAttributeValue Decorate{} = Just $ Decorate False +defaultAttributeValue Dim{} = Just $ Dim 2 +defaultAttributeValue Dimen{} = Just $ Dimen 2 +defaultAttributeValue DirEdgeConstraints{} = Just $ DirEdgeConstraints NoConstraints +defaultAttributeValue Distortion{} = Just $ Distortion 0.0 +defaultAttributeValue DPI{} = Just $ DPI 96.0 +defaultAttributeValue EdgeURL{} = Just $ EdgeURL "" +defaultAttributeValue EdgeTooltip{} = Just $ EdgeTooltip "" +defaultAttributeValue ESep{} = Just $ ESep (DVal 3) +defaultAttributeValue FillColor{} = Just $ FillColor [toWColor Black] +defaultAttributeValue FixedSize{} = Just $ FixedSize GrowAsNeeded +defaultAttributeValue FontColor{} = Just $ FontColor (X11Color Black) +defaultAttributeValue FontName{} = Just $ FontName "Times-Roman" +defaultAttributeValue FontNames{} = Just $ FontNames SvgNames +defaultAttributeValue FontSize{} = Just $ FontSize 14.0 +defaultAttributeValue ForceLabels{} = Just $ ForceLabels True +defaultAttributeValue GradientAngle{} = Just $ GradientAngle 0 +defaultAttributeValue Group{} = Just $ Group "" +defaultAttributeValue HeadURL{} = Just $ HeadURL "" +defaultAttributeValue HeadClip{} = Just $ HeadClip True +defaultAttributeValue HeadLabel{} = Just $ HeadLabel (StrLabel "") +defaultAttributeValue HeadPort{} = Just $ HeadPort (CompassPoint CenterPoint) +defaultAttributeValue HeadTarget{} = Just $ HeadTarget "" +defaultAttributeValue HeadTooltip{} = Just $ HeadTooltip "" +defaultAttributeValue Height{} = Just $ Height 0.5 +defaultAttributeValue ID{} = Just $ ID "" +defaultAttributeValue Image{} = Just $ Image "" +defaultAttributeValue ImagePath{} = Just $ ImagePath (Paths []) +defaultAttributeValue ImageScale{} = Just $ ImageScale NoScale +defaultAttributeValue Label{} = Just $ Label (StrLabel "") +defaultAttributeValue LabelURL{} = Just $ LabelURL "" +defaultAttributeValue LabelScheme{} = Just $ LabelScheme NotEdgeLabel +defaultAttributeValue LabelAngle{} = Just $ LabelAngle (-25.0) +defaultAttributeValue LabelDistance{} = Just $ LabelDistance 1.0 +defaultAttributeValue LabelFloat{} = Just $ LabelFloat False +defaultAttributeValue LabelFontColor{} = Just $ LabelFontColor (X11Color Black) +defaultAttributeValue LabelFontName{} = Just $ LabelFontName "Times-Roman" +defaultAttributeValue LabelFontSize{} = Just $ LabelFontSize 14.0 +defaultAttributeValue LabelJust{} = Just $ LabelJust JCenter +defaultAttributeValue LabelLoc{} = Just $ LabelLoc VTop +defaultAttributeValue LabelTarget{} = Just $ LabelTarget "" +defaultAttributeValue LabelTooltip{} = Just $ LabelTooltip "" +defaultAttributeValue Landscape{} = Just $ Landscape False +defaultAttributeValue Layer{} = Just $ Layer [] +defaultAttributeValue LayerListSep{} = Just $ LayerListSep (LLSep ",") +defaultAttributeValue Layers{} = Just $ Layers (LL []) +defaultAttributeValue LayerSelect{} = Just $ LayerSelect [] +defaultAttributeValue LayerSep{} = Just $ LayerSep (LSep " :\t") +defaultAttributeValue Levels{} = Just $ Levels maxBound +defaultAttributeValue LevelsGap{} = Just $ LevelsGap 0.0 +defaultAttributeValue LHead{} = Just $ LHead "" +defaultAttributeValue LTail{} = Just $ LTail "" +defaultAttributeValue MCLimit{} = Just $ MCLimit 1.0 +defaultAttributeValue MinDist{} = Just $ MinDist 1.0 +defaultAttributeValue MinLen{} = Just $ MinLen 1 +defaultAttributeValue Mode{} = Just $ Mode Major +defaultAttributeValue Model{} = Just $ Model ShortPath +defaultAttributeValue Mosek{} = Just $ Mosek False +defaultAttributeValue NodeSep{} = Just $ NodeSep 0.25 +defaultAttributeValue NoJustify{} = Just $ NoJustify False +defaultAttributeValue Normalize{} = Just $ Normalize NotNormalized +defaultAttributeValue NoTranslate{} = Just $ NoTranslate False +defaultAttributeValue Orientation{} = Just $ Orientation 0.0 +defaultAttributeValue OutputOrder{} = Just $ OutputOrder BreadthFirst +defaultAttributeValue Overlap{} = Just $ Overlap KeepOverlaps +defaultAttributeValue OverlapScaling{} = Just $ OverlapScaling (-4) +defaultAttributeValue OverlapShrink{} = Just $ OverlapShrink True +defaultAttributeValue Pack{} = Just $ Pack DontPack +defaultAttributeValue PackMode{} = Just $ PackMode PackNode +defaultAttributeValue Pad{} = Just $ Pad (DVal 0.0555) +defaultAttributeValue PageDir{} = Just $ PageDir Bl +defaultAttributeValue PenColor{} = Just $ PenColor (X11Color Black) +defaultAttributeValue PenWidth{} = Just $ PenWidth 1.0 +defaultAttributeValue Peripheries{} = Just $ Peripheries 1 +defaultAttributeValue Pin{} = Just $ Pin False +defaultAttributeValue QuadTree{} = Just $ QuadTree NormalQT +defaultAttributeValue Quantum{} = Just $ Quantum 0 +defaultAttributeValue RankDir{} = Just $ RankDir FromTop +defaultAttributeValue Regular{} = Just $ Regular False +defaultAttributeValue ReMinCross{} = Just $ ReMinCross False +defaultAttributeValue RepulsiveForce{} = Just $ RepulsiveForce 1.0 +defaultAttributeValue Root{} = Just $ Root (NodeName "") +defaultAttributeValue Rotate{} = Just $ Rotate 0 +defaultAttributeValue Rotation{} = Just $ Rotation 0 +defaultAttributeValue SameHead{} = Just $ SameHead "" +defaultAttributeValue SameTail{} = Just $ SameTail "" +defaultAttributeValue SearchSize{} = Just $ SearchSize 30 +defaultAttributeValue Sep{} = Just $ Sep (DVal 4) +defaultAttributeValue Shape{} = Just $ Shape Ellipse +defaultAttributeValue ShowBoxes{} = Just $ ShowBoxes 0 +defaultAttributeValue Sides{} = Just $ Sides 4 +defaultAttributeValue Skew{} = Just $ Skew 0.0 +defaultAttributeValue Smoothing{} = Just $ Smoothing NoSmooth +defaultAttributeValue SortV{} = Just $ SortV 0 +defaultAttributeValue StyleSheet{} = Just $ StyleSheet "" +defaultAttributeValue TailURL{} = Just $ TailURL "" +defaultAttributeValue TailClip{} = Just $ TailClip True +defaultAttributeValue TailLabel{} = Just $ TailLabel (StrLabel "") +defaultAttributeValue TailPort{} = Just $ TailPort (CompassPoint CenterPoint) +defaultAttributeValue TailTarget{} = Just $ TailTarget "" +defaultAttributeValue TailTooltip{} = Just $ TailTooltip "" +defaultAttributeValue Target{} = Just $ Target "" +defaultAttributeValue Tooltip{} = Just $ Tooltip "" +defaultAttributeValue VoroMargin{} = Just $ VoroMargin 0.05 +defaultAttributeValue Weight{} = Just $ Weight (Int 1) +defaultAttributeValue Width{} = Just $ Width 0.75 +defaultAttributeValue XLabel{} = Just $ XLabel (StrLabel "") +defaultAttributeValue _ = Nothing + +-- | Determine if the provided 'Text' value is a valid name for an 'UnknownAttribute'. +validUnknown :: AttributeName -> Bool +validUnknown txt = T.toLower txt `S.notMember` names + && isIDString txt + where + names = (S.fromList . map T.toLower + $ [ "Damping" + , "K" + , "URL" + , "href" + , "area" + , "arrowhead" + , "arrowsize" + , "arrowtail" + , "_background" + , "bb" + , "bgcolor" + , "center" + , "clusterrank" + , "color" + , "colorscheme" + , "comment" + , "compound" + , "concentrate" + , "constraint" + , "decorate" + , "defaultdist" + , "dim" + , "dimen" + , "dir" + , "diredgeconstraints" + , "distortion" + , "dpi" + , "resolution" + , "edgeURL" + , "edgehref" + , "edgetarget" + , "edgetooltip" + , "epsilon" + , "esep" + , "fillcolor" + , "fixedsize" + , "fontcolor" + , "fontname" + , "fontnames" + , "fontpath" + , "fontsize" + , "forcelabels" + , "gradientangle" + , "group" + , "headURL" + , "headhref" + , "head_lp" + , "headclip" + , "headlabel" + , "headport" + , "headtarget" + , "headtooltip" + , "height" + , "id" + , "image" + , "imagepath" + , "imagescale" + , "inputscale" + , "label" + , "labelURL" + , "labelhref" + , "label_scheme" + , "labelangle" + , "labeldistance" + , "labelfloat" + , "labelfontcolor" + , "labelfontname" + , "labelfontsize" + , "labeljust" + , "labelloc" + , "labeltarget" + , "labeltooltip" + , "landscape" + , "layer" + , "layerlistsep" + , "layers" + , "layerselect" + , "layersep" + , "layout" + , "len" + , "levels" + , "levelsgap" + , "lhead" + , "LHeight" + , "lp" + , "ltail" + , "lwidth" + , "margin" + , "maxiter" + , "mclimit" + , "mindist" + , "minlen" + , "mode" + , "model" + , "mosek" + , "nodesep" + , "nojustify" + , "normalize" + , "notranslate" + , "nslimit" + , "nslimit1" + , "ordering" + , "orientation" + , "outputorder" + , "overlap" + , "overlap_scaling" + , "overlap_shrink" + , "pack" + , "packmode" + , "pad" + , "page" + , "pagedir" + , "pencolor" + , "penwidth" + , "peripheries" + , "pin" + , "pos" + , "quadtree" + , "quantum" + , "rank" + , "rankdir" + , "ranksep" + , "ratio" + , "rects" + , "regular" + , "remincross" + , "repulsiveforce" + , "root" + , "rotate" + , "rotation" + , "samehead" + , "sametail" + , "samplepoints" + , "scale" + , "searchsize" + , "sep" + , "shape" + , "showboxes" + , "sides" + , "size" + , "skew" + , "smoothing" + , "sortv" + , "splines" + , "start" + , "style" + , "stylesheet" + , "tailURL" + , "tailhref" + , "tail_lp" + , "tailclip" + , "taillabel" + , "tailport" + , "tailtarget" + , "tailtooltip" + , "target" + , "tooltip" + , "truecolor" + , "vertices" + , "viewport" + , "voro_margin" + , "weight" + , "width" + , "xdotversion" + , "xlabel" + , "xlp" + , "charset" -- Defined upstream, just not used here. + ]) + `S.union` + keywords +{- Delete to here -} + +-- | Remove attributes that we don't want to consider: +-- +-- * Those that are defaults +-- * colorscheme (as the colors embed it anyway) +rmUnwantedAttributes :: Attributes -> Attributes +rmUnwantedAttributes = filter (not . (`any` tests) . flip ($)) + where + tests = [isDefault, isColorScheme] + + isDefault a = maybe False (a==) $ defaultAttributeValue a + + isColorScheme ColorScheme{} = True + isColorScheme _ = False + +-- ----------------------------------------------------------------------------- +-- These parsing combinators are defined here for customisation purposes. + +parseField :: (ParseDot a) => (a -> Attribute) -> String + -> [(String, Parse Attribute)] +parseField c fld = [(fld, liftEqParse fld c)] + +parseFields :: (ParseDot a) => (a -> Attribute) -> [String] + -> [(String, Parse Attribute)] +parseFields c = concatMap (parseField c) + +parseFieldBool :: (Bool -> Attribute) -> String -> [(String, Parse Attribute)] +parseFieldBool = (`parseFieldDef` True) + +-- | For 'Bool'-like data structures where the presence of the field +-- name without a value implies a default value. +parseFieldDef :: (ParseDot a) => (a -> Attribute) -> a -> String + -> [(String, Parse Attribute)] +parseFieldDef c d fld = [(fld, p)] + where + p = liftEqParse fld c + `onFail` + do nxt <- optional $ satisfy restIDString + bool (fail "Not actually the field you were after") + (return $ c d) + (isNothing nxt) + +-- | Attempt to parse the @\"=value\"@ part of a @key=value@ pair. If +-- there is an equal sign but the @value@ part doesn't parse, throw +-- an un-recoverable error. +liftEqParse :: (ParseDot a) => String -> (a -> Attribute) -> Parse Attribute +liftEqParse k c = do pStrict <- getsGS parseStrictly + let adjErr = bool adjustErr adjustErrBad pStrict + parseEq + *> ( hasDef (fmap c parse) + `adjErr` + (("Unable to parse key=value with key of " ++ k + ++ "\n\t") ++) + ) + where + hasDef p = maybe p (onFail p . (`stringRep` "\"\"")) + . defaultAttributeValue $ c undefined + +-- ----------------------------------------------------------------------------- + +{- | If performing any custom pre-/post-processing on Dot code, you + may wish to utilise some custom 'Attributes'. These are wrappers + around the 'UnknownAttribute' constructor (and thus 'CustomAttribute' + is just an alias for 'Attribute'). + + You should ensure that 'validUnknown' is 'True' for any potential + custom attribute name. + +-} +type CustomAttribute = Attribute + +-- | Create a custom attribute. +customAttribute :: AttributeName -> Text -> CustomAttribute +customAttribute = UnknownAttribute + +-- | Determines whether or not this is a custom attribute. +isCustom :: Attribute -> Bool +isCustom UnknownAttribute{} = True +isCustom _ = False + +isSpecifiedCustom :: AttributeName -> Attribute -> Bool +isSpecifiedCustom nm (UnknownAttribute nm' _) = nm == nm' +isSpecifiedCustom _ _ = False + +-- | The value of a custom attribute. Will throw a +-- 'GraphvizException' if the provided 'Attribute' isn't a custom +-- one. +customValue :: CustomAttribute -> Text +customValue (UnknownAttribute _ v) = v +customValue attr = throw . NotCustomAttr . T.unpack + $ printIt attr + +-- | The name of a custom attribute. Will throw a +-- 'GraphvizException' if the provided 'Attribute' isn't a custom +-- one. +customName :: CustomAttribute -> AttributeName +customName (UnknownAttribute nm _) = nm +customName attr = throw . NotCustomAttr . T.unpack + $ printIt attr + +-- | Returns all custom attributes and the list of non-custom Attributes. +findCustoms :: Attributes -> ([CustomAttribute], Attributes) +findCustoms = partition isCustom + +-- | Find the (first instance of the) specified custom attribute and +-- returns it along with all other Attributes. +findSpecifiedCustom :: AttributeName -> Attributes + -> Maybe (CustomAttribute, Attributes) +findSpecifiedCustom nm attrs + = case break (isSpecifiedCustom nm) attrs of + (bf,cust:aft) -> Just (cust, bf ++ aft) + _ -> Nothing + +-- | Delete all custom attributes (actually, this will delete all +-- 'UnknownAttribute' values; as such it can also be used to remove +-- legacy attributes). +deleteCustomAttributes :: Attributes -> Attributes +deleteCustomAttributes = filter (not . isCustom) + +-- | Removes all instances of the specified custom attribute. +deleteSpecifiedCustom :: AttributeName -> Attributes -> Attributes +deleteSpecifiedCustom nm = filter (not . isSpecifiedCustom nm) diff --git a/Data/GraphViz/Attributes/HTML.hs b/Data/GraphViz/Attributes/HTML.hs --- a/Data/GraphViz/Attributes/HTML.hs +++ b/Data/GraphViz/Attributes/HTML.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, PatternGuards #-} +{-# LANGUAGE CPP, OverloadedStrings, PatternGuards #-} {- | Module : Data.GraphViz.Attributes.HTML @@ -64,25 +64,31 @@ , Attribute(..) , Align(..) , VAlign(..) + , CellFormat(..) , Scale(..) + , Side(..) + , Style(..) ) where -import Data.GraphViz.Parsing -import Data.GraphViz.Printing import Data.GraphViz.Attributes.Colors import Data.GraphViz.Attributes.Internal -import Data.GraphViz.Util(bool) +import Data.GraphViz.Internal.Util (bool) +import Data.GraphViz.Parsing +import Data.GraphViz.Printing -import Numeric(readHex) -import Data.Char(chr, ord, isSpace) -import Data.Function(on) -import Data.List(delete) -import Data.Maybe(catMaybes, listToMaybe) -import Data.Word(Word8, Word16) -import qualified Data.Map as Map +import Data.Char (chr, isSpace, ord) +import Data.Function (on) +import Data.List (delete) +import qualified Data.Map as Map +import Data.Maybe (catMaybes, listToMaybe) import qualified Data.Text.Lazy as T -import Control.Monad(liftM, liftM2) +import Data.Word (Word16, Word8) +import Numeric (readHex) +#if !MIN_VERSION_base (4,13,0) +import Data.Monoid ((<>)) +#endif + -- ----------------------------------------------------------------------------- -- | The overall type for HTML-like labels. Fundamentally, HTML-like @@ -99,9 +105,9 @@ instance ParseDot Label where -- Try parsing Table first in case of a FONT tag being used. - parseUnqt = liftM Table parseUnqt + parseUnqt = fmap Table parseUnqt `onFail` - liftM Text parseUnqt + fmap Text parseUnqt `adjustErr` ("Can't parse Html.Label\n\t"++) @@ -140,7 +146,7 @@ listToDot = unqtListToDot instance ParseDot TextItem where - parseUnqt = oneOf [ liftM Str unescapeValue + parseUnqt = oneOf [ fmap Str unescapeValue , parseEmptyTag Newline "BR" , parseFontTag Font parseUnqt , parseTagRep Format parseUnqt parseUnqt @@ -150,21 +156,23 @@ parse = parseUnqt - parseUnqtList = many1 parseUnqt -- sepBy1 parseUnqt whitespace + parseUnqtList = many parseUnqt parseList = parseUnqtList data Format = Italics - | Bold - | Underline - | Subscript - | Superscript - deriving (Eq, Ord, Bounded, Enum, Show, Read) + | Bold + | Underline + | Overline -- ^ Requires Graphviz >= 2.38.0. + | Subscript + | Superscript + deriving (Eq, Ord, Bounded, Enum, Show, Read) instance PrintDot Format where unqtDot Italics = text "I" unqtDot Bold = text "B" unqtDot Underline = text "U" + unqtDot Overline = text "O" unqtDot Subscript = text "SUB" unqtDot Superscript = text "SUP" @@ -172,6 +180,7 @@ parseUnqt = stringValue [ ("I", Italics) , ("B", Bold) , ("U", Underline) + , ("O", Overline) , ("SUB", Subscript) , ("SUP", Superscript) ] @@ -264,13 +273,13 @@ instance ParseDot Cell where parseUnqt = oneOf [ parseCell LabelCell parse - , parseCell ImgCell $ wrapWhitespace parseUnqt + , parseCell ImgCell $ wrapWhitespace parse , parseEmptyTag (const VerticalRule) "VR" ] `adjustErr` ("Can't parse Html.Cell\n\t"++) where - parseCell = flip parseTag "TD" + parseCell = (`parseTag` "TD") parse = parseUnqt @@ -299,55 +308,65 @@ -- | Note that not all 'Attribute' values are valid everywhere: -- see the comments for each one on where it is valid. -data Attribute = Align Align -- ^ Valid for: 'Table', 'Cell', 'Newline'. - | BAlign Align -- ^ Valid for: 'Cell'. - | BGColor Color -- ^ Valid for: 'Table' (including 'tableFontAttrs'), 'Cell', 'Font'. - | Border Word8 -- ^ Valid for: 'Table', 'Cell'. Default is @1@; @0@ represents no border. - | CellBorder Word8 -- ^ Valid for: 'Table'. Default is @1@; @0@ represents no border. - | CellPadding Word8 -- ^ Valid for: 'Table', 'Cell'. Default is @2@. - | CellSpacing Word8 -- ^ Valid for: 'Table', 'Cell'. Default is @2@; maximum is @127@. - | Color Color -- ^ Valid for: 'Table', 'Cell'. - | ColSpan Word16 -- ^ Valid for: 'Cell'. Default is @1@. - | Face T.Text -- ^ Valid for: 'tableFontAttrs', 'Font'. - | FixedSize Bool -- ^ Valid for: 'Table', 'Cell'. Default is @'False'@. - | Height Word16 -- ^ Valid for: 'Table', 'Cell'. - | HRef T.Text -- ^ Valid for: 'Table', 'Cell'. - | ID T.Text -- ^ Valid for: 'Table', 'Cell'. Requires Graphviz >= 2.29.0 - | PointSize Double -- ^ Valid for: 'tableFontAttrs', 'Font'. - | Port PortName -- ^ Valid for: 'Table', 'Cell'. - | RowSpan Word16 -- ^ Valid for: 'Cell'. - | Scale Scale -- ^ Valid for: 'Img'. - | Src FilePath -- ^ Valid for: 'Img'. - | Target T.Text -- ^ Valid for: 'Table', 'Cell'. - | Title T.Text -- ^ Valid for: 'Table', 'Cell'. Has an alias of @TOOLTIP@. - | VAlign VAlign -- ^ Valid for: 'Table', 'Cell'. - | Width Word16 -- ^ Valid for: 'Table', 'Cell'. +data Attribute = Align Align -- ^ Valid for: 'Table', 'Cell', 'Newline'. + | BAlign Align -- ^ Valid for: 'Cell'. + | BGColor Color -- ^ Valid for: 'Table' (including 'tableFontAttrs'), 'Cell', 'Font'. + | Border Word8 -- ^ Valid for: 'Table', 'Cell'. Default is @1@; @0@ represents no border. + | CellBorder Word8 -- ^ Valid for: 'Table'. Default is @1@; @0@ represents no border. + | CellPadding Word8 -- ^ Valid for: 'Table', 'Cell'. Default is @2@. + | CellSpacing Word8 -- ^ Valid for: 'Table', 'Cell'. Default is @2@; maximum is @127@. + | Color Color -- ^ Valid for: 'Table', 'Cell'. + | ColSpan Word16 -- ^ Valid for: 'Cell'. Default is @1@. + | Columns CellFormat -- ^ Valid for: 'Table'. Requires Graphviz >= 2.40.1 + | Face T.Text -- ^ Valid for: 'tableFontAttrs', 'Font'. + | FixedSize Bool -- ^ Valid for: 'Table', 'Cell'. Default is @'False'@. + | GradientAngle Int -- ^ Valid for: 'Table', 'Cell'. Default is @0@. Requires Graphviz >= 2.40.1 + | Height Word16 -- ^ Valid for: 'Table', 'Cell'. + | HRef T.Text -- ^ Valid for: 'Table', 'Cell'. + | ID T.Text -- ^ Valid for: 'Table', 'Cell'. Requires Graphviz >= 2.29.0 + | PointSize Double -- ^ Valid for: 'tableFontAttrs', 'Font'. + | Port PortName -- ^ Valid for: 'Table', 'Cell'. + | Rows CellFormat -- ^ Valid for: 'Table'. Requires Graphviz >= 2.40.1 + | RowSpan Word16 -- ^ Valid for: 'Cell'. + | Scale Scale -- ^ Valid for: 'Img'. + | Sides [Side] -- ^ Valid for: 'Table', 'Cell'. Default is @['LeftSide', 'TopSide', 'RightSide', 'BottomSide']@. Requires Graphviz >= 2.40.1 + | Src FilePath -- ^ Valid for: 'Img'. + | Style Style -- ^ Valid for: 'Table', 'Cell'. Requires Graphviz >= 2.40.1 + | Target T.Text -- ^ Valid for: 'Table', 'Cell'. + | Title T.Text -- ^ Valid for: 'Table', 'Cell'. Has an alias of @TOOLTIP@. + | VAlign VAlign -- ^ Valid for: 'Table', 'Cell'. + | Width Word16 -- ^ Valid for: 'Table', 'Cell'. deriving (Eq, Ord, Show, Read) instance PrintDot Attribute where - unqtDot (Align v) = printHtmlField "ALIGN" v - unqtDot (BAlign v) = printHtmlField "BALIGN" v - unqtDot (BGColor v) = printHtmlField "BGCOLOR" v - unqtDot (Border v) = printHtmlField "BORDER" v - unqtDot (CellBorder v) = printHtmlField "CELLBORDER" v - unqtDot (CellPadding v) = printHtmlField "CELLPADDING" v - unqtDot (CellSpacing v) = printHtmlField "CELLSPACING" v - unqtDot (Color v) = printHtmlField "COLOR" v - unqtDot (ColSpan v) = printHtmlField "COLSPAN" v - unqtDot (Face v) = printHtmlField' "FACE" $ escapeAttribute v - unqtDot (FixedSize v) = printHtmlField' "FIXEDSIZE" $ printBoolHtml v - unqtDot (Height v) = printHtmlField "HEIGHT" v - unqtDot (HRef v) = printHtmlField' "HREF" $ escapeAttribute v - unqtDot (ID v) = printHtmlField' "ID" $ escapeAttribute v - unqtDot (PointSize v) = printHtmlField "POINT-SIZE" v - unqtDot (Port v) = printHtmlField' "PORT" . escapeAttribute $ portName v - unqtDot (RowSpan v) = printHtmlField "ROWSPAN" v - unqtDot (Scale v) = printHtmlField "SCALE" v - unqtDot (Src v) = printHtmlField' "SRC" . escapeAttribute $ T.pack v - unqtDot (Target v) = printHtmlField' "TARGET" $ escapeAttribute v - unqtDot (Title v) = printHtmlField' "TITLE" $ escapeAttribute v - unqtDot (VAlign v) = printHtmlField "VALIGN" v - unqtDot (Width v) = printHtmlField "WIDTH" v + unqtDot (Align v) = printHtmlField "ALIGN" v + unqtDot (BAlign v) = printHtmlField "BALIGN" v + unqtDot (BGColor v) = printHtmlField "BGCOLOR" v + unqtDot (Border v) = printHtmlField "BORDER" v + unqtDot (CellBorder v) = printHtmlField "CELLBORDER" v + unqtDot (CellPadding v) = printHtmlField "CELLPADDING" v + unqtDot (CellSpacing v) = printHtmlField "CELLSPACING" v + unqtDot (Color v) = printHtmlField "COLOR" v + unqtDot (ColSpan v) = printHtmlField "COLSPAN" v + unqtDot (Columns v) = printHtmlField "COLUMNS" v + unqtDot (Face v) = printHtmlField' "FACE" $ escapeAttribute v + unqtDot (FixedSize v) = printHtmlField' "FIXEDSIZE" $ printBoolHtml v + unqtDot (GradientAngle v) = printHtmlField "GRADIENTANGLE" v + unqtDot (Height v) = printHtmlField "HEIGHT" v + unqtDot (HRef v) = printHtmlField' "HREF" $ escapeAttribute v + unqtDot (ID v) = printHtmlField' "ID" $ escapeAttribute v + unqtDot (PointSize v) = printHtmlField "POINT-SIZE" v + unqtDot (Port v) = printHtmlField' "PORT" . escapeAttribute $ portName v + unqtDot (Rows v) = printHtmlField "ROWS" v + unqtDot (RowSpan v) = printHtmlField "ROWSPAN" v + unqtDot (Scale v) = printHtmlField "SCALE" v + unqtDot (Sides v) = printHtmlField "SIDES" v + unqtDot (Src v) = printHtmlField' "SRC" . escapeAttribute $ T.pack v + unqtDot (Style v) = printHtmlField "STYLE" v + unqtDot (Target v) = printHtmlField' "TARGET" $ escapeAttribute v + unqtDot (Title v) = printHtmlField' "TITLE" $ escapeAttribute v + unqtDot (VAlign v) = printHtmlField "VALIGN" v + unqtDot (Width v) = printHtmlField "WIDTH" v unqtListToDot = hsep . mapM unqtDot @@ -372,16 +391,21 @@ , parseHtmlField CellSpacing "CELLSPACING" , parseHtmlField Color "COLOR" , parseHtmlField ColSpan "COLSPAN" + , parseHtmlField Columns "COLUMNS" , parseHtmlField' Face "FACE" unescapeAttribute , parseHtmlField' FixedSize "FIXEDSIZE" parseBoolHtml + , parseHtmlField GradientAngle "GRADIENTANGLE" , parseHtmlField Height "HEIGHT" , parseHtmlField' HRef "HREF" unescapeAttribute , parseHtmlField' ID "ID" unescapeAttribute , parseHtmlField PointSize "POINT-SIZE" , parseHtmlField' (Port . PN) "PORT" unescapeAttribute + , parseHtmlField Rows "ROWS" , parseHtmlField RowSpan "ROWSPAN" , parseHtmlField Scale "SCALE" - , parseHtmlField' Src "SRC" $ liftM T.unpack unescapeAttribute + , parseHtmlField Sides "SIDES" + , parseHtmlField' Src "SRC" $ fmap T.unpack unescapeAttribute + , parseHtmlField Style "STYLE" , parseHtmlField' Target "TARGET" unescapeAttribute , parseHtmlField' Title "TITLE" unescapeAttribute `onFail` @@ -404,9 +428,17 @@ parseHtmlField' :: (a -> Attribute) -> String -> Parse a -> Parse Attribute -parseHtmlField' c f p = do string f - parseEq - liftM c $ quotedParse p +parseHtmlField' c f p = string f + *> parseEq + *> ( c <$> ( quotedParse p + `adjustErr` + (("Can't parse HTML.Attribute." ++ f ++ "\n\t")++) + ) + ) +-- Can't use liftEqParse, etc. here because it causes backtracking +-- problems when the attributes could apply to multiple constructors. +-- This includes using commit! (Example: if it starts with a FONT tag, +-- is it a Table or Text? -- | Specifies horizontal placement. When an object is allocated more -- space than required, this value determines where the extra space @@ -456,15 +488,26 @@ parse = parseUnqt +data CellFormat = RuleBetween + deriving (Eq, Ord, Bounded, Enum, Show, Read) + +instance PrintDot CellFormat where + unqtDot RuleBetween = text "*" + +instance ParseDot CellFormat where + parseUnqt = stringRep RuleBetween "*" + + parse = parseUnqt + -- | Specifies how an image will use any extra space available in its -- cell. If undefined, the image inherits the value of the -- @ImageScale@ attribute. data Scale = NaturalSize -- ^ Default value. - | ScaleUniformly - | ExpandWidth - | ExpandHeight - | ExpandBoth - deriving (Eq, Ord, Bounded, Enum, Show, Read) + | ScaleUniformly + | ExpandWidth + | ExpandHeight + | ExpandBoth + deriving (Eq, Ord, Bounded, Enum, Show, Read) instance PrintDot Scale where unqtDot NaturalSize = text "FALSE" @@ -483,6 +526,52 @@ parse = parseUnqt +-- | Which sides of a border in a cell or table should be drawn, if a +-- border is drawn. +data Side = LeftSide + | RightSide + | TopSide + | BottomSide + deriving (Eq, Ord, Bounded, Enum, Show, Read) + +instance PrintDot Side where + unqtDot LeftSide = text "L" + unqtDot RightSide = text "R" + unqtDot TopSide = text "T" + unqtDot BottomSide = text "B" + + unqtListToDot = hcat . mapM unqtDot + + listToDot = unqtListToDot + +instance ParseDot Side where + parseUnqt = oneOf [ stringRep LeftSide "L" + , stringRep RightSide "R" + , stringRep TopSide "T" + , stringRep BottomSide "B" + ] + + parse = parseUnqt + + parseUnqtList = many parseUnqt + + parseList = parseUnqtList + +data Style = Rounded -- ^ Valid for 'Table' + | Radial -- ^ Valid for 'Table', 'Cell'. + deriving (Eq, Ord, Bounded, Enum, Show, Read) + +instance PrintDot Style where + unqtDot Rounded = text "ROUNDED" + unqtDot Radial = text "RADIAL" + +instance ParseDot Style where + parseUnqt = oneOf [ stringRep Rounded "ROUNDED" + , stringRep Radial "RADIAL" + ] + + parse = parseUnqt + -- ----------------------------------------------------------------------------- escapeAttribute :: T.Text -> DotCode @@ -492,14 +581,14 @@ escapeValue = escapeHtml True escapeHtml :: Bool -> T.Text -> DotCode -escapeHtml quotesAllowed = hcat . liftM concat +escapeHtml quotesAllowed = hcat . fmap concat . mapM (escapeSegment . T.unpack) . T.groupBy ((==) `on` isSpace) where -- Note: use numeric version of space rather than nbsp, since this -- matches what Graphviz does (since Inkscape apparently can't -- cope with nbsp). - escapeSegment (s:sps) | isSpace s = liftM2 (:) (char s) $ mapM numEscape sps + escapeSegment (s:sps) | isSpace s = liftA2 (:) (char s) $ mapM numEscape sps escapeSegment txt = mapM xmlChar txt allowQuotes = if quotesAllowed @@ -523,7 +612,7 @@ -- Note: this /will/ fail if an unknown non-numeric HTML-escape is -- used. unescapeHtml :: Bool -> Parse T.Text -unescapeHtml quotesAllowed = liftM (T.pack . catMaybes) +unescapeHtml quotesAllowed = fmap (T.pack . catMaybes) . many1 . oneOf $ [ parseEscpd , validChars ] @@ -551,7 +640,7 @@ escMap = Map.fromList htmlUnescapes - validChars = liftM Just $ satisfy (`notElem` needEscaping) + validChars = fmap Just $ satisfy (`notElem` needEscaping) needEscaping = allowQuotes $ map fst htmlEscapes -- | The characters that need to be escaped and what they need to be @@ -562,9 +651,6 @@ , ('>', "gt") , ('&', "amp") ] - ++ map numEscape ['-', '\''] - where - numEscape c = (c, T.pack $ '#' : show (ord c)) -- | Flip the order and add extra values that might be escaped. More -- specifically, provide the escape code for spaces (@\"nbsp\"@) and @@ -572,7 +658,7 @@ htmlUnescapes :: [(T.Text, Char)] htmlUnescapes = maybeEscaped ++ - map (uncurry (flip (,))) htmlEscapes + map (uncurry $ flip (,)) htmlEscapes where maybeEscaped = [("nbsp", ' '), ("apos", '\'')] @@ -610,32 +696,38 @@ -- | Parse something like @value<\/FOO>@ parseTag :: (Attributes -> val -> tag) -> String -> Parse val -> Parse tag -parseTag c t pv = do as <- parseAngled openingTag - v <- pv - parseAngled $ character '/' >> t' >> whitespace - return $ c as v +parseTag c t pv = c <$> parseAngled openingTag + <*> wrapWhitespace pv + <* parseAngled (character '/' *> t' *> whitespace) + `adjustErr` + (("Can't parse Html tag: " ++ t ++ "\n\t")++) where t' = string t - openingTag = do t' - as <- tryParseList' $ whitespace1 >> parse - whitespace - return as - -parseTagRep :: (tagName -> val -> tag) -> Parse tagName -> Parse val -> Parse tag -parseTagRep c pt pv = do tn <- parseAngled (pt `discard` whitespace) - v <- pv - parseAngled $ character '/' >> pt >> whitespace - return $ c tn v + openingTag :: Parse Attributes + openingTag = t' + *> tryParseList' (whitespace1 >> parse) + <* whitespace parseFontTag :: (Attributes -> val -> tag) -> Parse val -> Parse tag -parseFontTag = flip parseTag "FONT" +parseFontTag = (`parseTag` "FONT") +-- Should this just be specialised for tagName ~ Format ? + +-- | Parse something like @value<\/FOO>@. +parseTagRep :: (tagName -> val -> tag) -> Parse tagName -> Parse val -> Parse tag +parseTagRep c pt pv = c <$> parseAngled (pt `discard` whitespace) + <*> pv + <* parseAngled (character '/' *> pt *> whitespace) + `adjustErr` + ("Can't parse attribute-less Html tag\n\t"++) + -- | Parse something like @@ parseEmptyTag :: (Attributes -> tag) -> String -> Parse tag -parseEmptyTag c t = parseAngled - ( do string t - as <- tryParseList' $ whitespace1 >> parse - whitespace - character '/' - return $ c as +parseEmptyTag c t = c <$> parseAngled + ( string t + *> tryParseList' (whitespace1 *> parse) + <* whitespace + <* character '/' ) + `adjustErr` + (("Can't parse empty Html tag: " ++ t ++ "\n\t")++) diff --git a/Data/GraphViz/Attributes/Internal.hs b/Data/GraphViz/Attributes/Internal.hs --- a/Data/GraphViz/Attributes/Internal.hs +++ b/Data/GraphViz/Attributes/Internal.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP, OverloadedStrings #-} {-# OPTIONS_HADDOCK hide #-} {- | @@ -9,7 +9,8 @@ Maintainer : Ivan.Miljenovic@gmail.com This module is defined so as to avoid exposing internal functions - in the external API. + in the external API. These are those that are needed for the + testsuite. -} @@ -24,12 +25,15 @@ import Data.GraphViz.Parsing import Data.GraphViz.Printing -import Data.Maybe(isNothing) -import qualified Data.Map as Map -import Data.Map(Map) -import Data.Text.Lazy(Text) -import Control.Monad(liftM, liftM2) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (isNothing) +import Data.Text.Lazy (Text) +#if !MIN_VERSION_base (4,13,0) +import Data.Monoid ((<>)) +#endif + -- ----------------------------------------------------------------------------- -- Note that printing and parsing of PortName values is specific to @@ -52,15 +56,14 @@ toDot = toDot . portName instance ParseDot PortName where - parseUnqt = liftM PN - $ parseEscaped False [] ['"', ':'] + parseUnqt = PN <$> parseEscaped False [] ['"', ':'] parse = quotedParse parseUnqt `onFail` unqtPortName unqtPortName :: Parse PortName -unqtPortName = liftM PN quotelessString +unqtPortName = PN <$> quotelessString -- ----------------------------------------------------------------------------- @@ -86,17 +89,17 @@ parse = quotedParse parseUnqt `onFail` - liftM checkPortName unqtPortName + fmap checkPortName unqtPortName checkPortName :: PortName -> PortPos checkPortName pn = maybe (LabelledPort pn Nothing) CompassPoint - . flip Map.lookup compassLookup + . (`Map.lookup` compassLookup) $ portName pn -- | When attached to a node in a DotEdge definition, the 'PortName' -- and the 'CompassPoint' can be in separate quotes. parseEdgeBasedPP :: Parse PortPos -parseEdgeBasedPP = liftM2 LabelledPort parse (liftM Just $ character ':' >> parse) +parseEdgeBasedPP = liftA2 LabelledPort parse (fmap Just $ character ':' *> parse) `onFail` parse diff --git a/Data/GraphViz/Attributes/Same.hs b/Data/GraphViz/Attributes/Same.hs --- a/Data/GraphViz/Attributes/Same.hs +++ b/Data/GraphViz/Attributes/Same.hs @@ -16,6 +16,7 @@ , SAttrs , toSAttr , unSame + , unSameSet ) where import Data.GraphViz.Attributes.Complete(Attribute, Attributes, sameAttribute) @@ -47,3 +48,6 @@ unSame :: SAttrs -> Attributes unSame = map getAttr . Set.toList + +unSameSet :: SAttrs -> Set Attribute +unSameSet = Set.mapMonotonic getAttr diff --git a/Data/GraphViz/Attributes/Values.hs b/Data/GraphViz/Attributes/Values.hs new file mode 100644 --- /dev/null +++ b/Data/GraphViz/Attributes/Values.hs @@ -0,0 +1,1635 @@ +{-# LANGUAGE CPP, OverloadedStrings #-} +{-# OPTIONS_HADDOCK hide #-} +{- | + Module : Data.GraphViz.Attributes.Values + Description : Values for use with the Attribute data type + Copyright : (c) Ivan Lazar Miljenovic + License : 3-Clause BSD-style + Maintainer : Ivan.Miljenovic@gmail.com + + Defined to have smaller modules and thus faster compilation times. + + -} +module Data.GraphViz.Attributes.Values where + +import qualified Data.GraphViz.Attributes.HTML as Html +import Data.GraphViz.Attributes.Internal +import Data.GraphViz.Internal.State (getLayerListSep, + getLayerSep, + setLayerListSep, + setLayerSep) +import Data.GraphViz.Internal.Util (bool, stringToInt) +import Data.GraphViz.Parsing +import Data.GraphViz.Printing + +import Data.List (intercalate) +import Data.Maybe (isJust) +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as T +import Data.Word (Word16) +import System.FilePath (searchPathSeparator, splitSearchPath) + +#if !MIN_VERSION_base (4,13,0) +import Data.Monoid ((<>)) +#endif + +-- ----------------------------------------------------------------------------- + +{- | + + Some 'Attribute's (mainly label-like ones) take a 'String' argument + that allows for extra escape codes. This library doesn't do any + extra checks or special parsing for these escape codes, but usage + of 'EscString' rather than 'Text' indicates that the Graphviz + tools will recognise these extra escape codes for these + 'Attribute's. + + The extra escape codes include (note that these are all Strings): + + [@\\N@] Replace with the name of the node (for Node 'Attribute's). + + [@\\G@] Replace with the name of the graph (for Node 'Attribute's) + or the name of the graph or cluster, whichever is + applicable (for Graph, Cluster and Edge 'Attribute's). + + [@\\E@] Replace with the name of the edge, formed by the two + adjoining nodes and the edge type (for Edge 'Attribute's). + + [@\\T@] Replace with the name of the tail node (for Edge + 'Attribute's). + + [@\\H@] Replace with the name of the head node (for Edge + 'Attribute's). + + [@\\L@] Replace with the object's label (for all 'Attribute's). + + Also, if the 'Attribute' in question is 'Label', 'HeadLabel' or + 'TailLabel', then @\\n@, @\\l@ and @\\r@ split the label into lines + centered, left-justified and right-justified respectively. + + -} +type EscString = Text + +-- ----------------------------------------------------------------------------- + +-- | Should only have 2D points (i.e. created with 'createPoint'). +data Rect = Rect Point Point + deriving (Eq, Ord, Show, Read) + +instance PrintDot Rect where + unqtDot (Rect p1 p2) = printPoint2DUnqt p1 <> comma <> printPoint2DUnqt p2 + + toDot = dquotes . unqtDot + + unqtListToDot = hsep . mapM unqtDot + +instance ParseDot Rect where + parseUnqt = uncurry Rect <$> commaSep' parsePoint2D parsePoint2D + + parse = quotedParse parseUnqt + + parseUnqtList = sepBy1 parseUnqt whitespace1 + +-- ----------------------------------------------------------------------------- + +-- | If 'Local', then sub-graphs that are clusters are given special +-- treatment. 'Global' and 'NoCluster' currently appear to be +-- identical and turn off the special cluster processing. +data ClusterMode = Local + | Global + | NoCluster + deriving (Eq, Ord, Bounded, Enum, Show, Read) + +instance PrintDot ClusterMode where + unqtDot Local = text "local" + unqtDot Global = text "global" + unqtDot NoCluster = text "none" + +instance ParseDot ClusterMode where + parseUnqt = oneOf [ stringRep Local "local" + , stringRep Global "global" + , stringRep NoCluster "none" + ] + +-- ----------------------------------------------------------------------------- + +-- | Specify where to place arrow heads on an edge. +data DirType = Forward -- ^ Draw a directed edge with an arrow to the + -- node it's pointing go. + | Back -- ^ Draw a reverse directed edge with an arrow + -- to the node it's coming from. + | Both -- ^ Draw arrows on both ends of the edge. + | NoDir -- ^ Draw an undirected edge. + deriving (Eq, Ord, Bounded, Enum, Show, Read) + +instance PrintDot DirType where + unqtDot Forward = text "forward" + unqtDot Back = text "back" + unqtDot Both = text "both" + unqtDot NoDir = text "none" + +instance ParseDot DirType where + parseUnqt = oneOf [ stringRep Forward "forward" + , stringRep Back "back" + , stringRep Both "both" + , stringRep NoDir "none" + ] + +-- ----------------------------------------------------------------------------- + +-- | Only when @mode == 'IpSep'@. +data DEConstraints = EdgeConstraints + | NoConstraints + | HierConstraints + deriving (Eq, Ord, Bounded, Enum, Show, Read) + +instance PrintDot DEConstraints where + unqtDot EdgeConstraints = unqtDot True + unqtDot NoConstraints = unqtDot False + unqtDot HierConstraints = text "hier" + +instance ParseDot DEConstraints where + parseUnqt = fmap (bool NoConstraints EdgeConstraints) parse + `onFail` + stringRep HierConstraints "hier" + +-- ----------------------------------------------------------------------------- + +-- | Either a 'Double' or a (2D) 'Point' (i.e. created with +-- 'createPoint'). +-- +-- Whilst it is possible to create a 'Point' value with either a +-- third co-ordinate or a forced position, these are ignored for +-- printing/parsing. +-- +-- An optional prefix of @\'+\'@ is allowed when parsing. +data DPoint = DVal Double + | PVal Point + deriving (Eq, Ord, Show, Read) + +instance PrintDot DPoint where + unqtDot (DVal d) = unqtDot d + unqtDot (PVal p) = printPoint2DUnqt p + + toDot (DVal d) = toDot d + toDot (PVal p) = printPoint2D p + +instance ParseDot DPoint where + parseUnqt = optional (character '+') + *> oneOf [ PVal <$> parsePoint2D + , DVal <$> parseUnqt + ] + + parse = quotedParse parseUnqt -- A `+' would need to be quoted. + `onFail` + fmap DVal (parseSignedFloat False) -- Don't use parseUnqt! + +-- ----------------------------------------------------------------------------- + +-- | The mapping used for 'FontName' values in SVG output. +-- +-- More information can be found at . +data SVGFontNames = SvgNames -- ^ Use the legal generic SVG font names. + | PostScriptNames -- ^ Use PostScript font names. + | FontConfigNames -- ^ Use fontconfig font conventions. + deriving (Eq, Ord, Bounded, Enum, Show, Read) + +instance PrintDot SVGFontNames where + unqtDot SvgNames = text "svg" + unqtDot PostScriptNames = text "ps" + unqtDot FontConfigNames = text "gd" + +instance ParseDot SVGFontNames where + parseUnqt = oneOf [ stringRep SvgNames "svg" + , stringRep PostScriptNames "ps" + , stringRep FontConfigNames "gd" + ] + + parse = stringRep SvgNames "\"\"" + `onFail` + optionalQuoted parseUnqt + +-- ----------------------------------------------------------------------------- + +-- | Maximum width and height of drawing in inches. +data GraphSize = GSize { width :: Double + -- | If @Nothing@, then the height is the + -- same as the width. + , height :: Maybe Double + -- | If drawing is smaller than specified + -- size, this value determines whether it + -- is scaled up. + , desiredSize :: Bool + } + deriving (Eq, Ord, Show, Read) + +instance PrintDot GraphSize where + unqtDot (GSize w mh ds) = bool id (<> char '!') ds + . maybe id (\h -> (<> unqtDot h) . (<> comma)) mh + $ unqtDot w + + toDot (GSize w Nothing False) = toDot w + toDot gs = dquotes $ unqtDot gs + +instance ParseDot GraphSize where + parseUnqt = GSize <$> parseUnqt + <*> optional (parseComma *> whitespace *> parseUnqt) + <*> (isJust <$> optional (character '!')) + + parse = quotedParse parseUnqt + `onFail` + fmap (\ w -> GSize w Nothing False) (parseSignedFloat False) + +-- ----------------------------------------------------------------------------- + +-- | For 'Neato' unless indicated otherwise. +data ModeType = Major + | KK + | Hier + | IpSep + | SpringMode -- ^ For 'Sfdp', requires Graphviz >= 2.32.0. + | MaxEnt -- ^ For 'Sfdp', requires Graphviz >= 2.32.0. + deriving (Eq, Ord, Bounded, Enum, Show, Read) + +instance PrintDot ModeType where + unqtDot Major = text "major" + unqtDot KK = text "KK" + unqtDot Hier = text "hier" + unqtDot IpSep = text "ipsep" + unqtDot SpringMode = text "spring" + unqtDot MaxEnt = text "maxent" + +instance ParseDot ModeType where + parseUnqt = oneOf [ stringRep Major "major" + , stringRep KK "KK" + , stringRep Hier "hier" + , stringRep IpSep "ipsep" + , stringRep SpringMode "spring" + , stringRep MaxEnt "maxent" + ] + +-- ----------------------------------------------------------------------------- + +data Model = ShortPath + | SubSet + | Circuit + | MDS + deriving (Eq, Ord, Bounded, Enum, Show, Read) + +instance PrintDot Model where + unqtDot ShortPath = text "shortpath" + unqtDot SubSet = text "subset" + unqtDot Circuit = text "circuit" + unqtDot MDS = text "mds" + +instance ParseDot Model where + parseUnqt = oneOf [ stringRep ShortPath "shortpath" + , stringRep SubSet "subset" + , stringRep Circuit "circuit" + , stringRep MDS "mds" + ] + +-- ----------------------------------------------------------------------------- + +data Label = StrLabel EscString + | HtmlLabel Html.Label -- ^ If 'PlainText' is used, the + -- 'Html.Label' value is the entire + -- \"shape\"; if anything else + -- except 'PointShape' is used then + -- the 'Html.Label' is embedded + -- within the shape. + | RecordLabel RecordFields -- ^ For nodes only; requires + -- either 'Record' or + -- 'MRecord' as the shape. + deriving (Eq, Ord, Show, Read) + +instance PrintDot Label where + unqtDot (StrLabel s) = unqtDot s + unqtDot (HtmlLabel h) = angled $ unqtDot h + unqtDot (RecordLabel fs) = unqtDot fs + + toDot (StrLabel s) = toDot s + toDot h@HtmlLabel{} = unqtDot h + toDot (RecordLabel fs) = toDot fs + +instance ParseDot Label where + -- Don't have to worry about being able to tell the difference + -- between an HtmlLabel and a RecordLabel starting with a PortPos, + -- since the latter will be in quotes and the former won't. + + parseUnqt = oneOf [ HtmlLabel <$> parseAngled parseUnqt + , RecordLabel <$> parseUnqt + , StrLabel <$> parseUnqt + ] + + parse = oneOf [ HtmlLabel <$> parseAngled parse + , RecordLabel <$> parse + , StrLabel <$> parse + ] + +-- ----------------------------------------------------------------------------- + +-- | A RecordFields value should never be empty. +type RecordFields = [RecordField] + +-- | Specifies the sub-values of a record-based label. By default, +-- the cells are laid out horizontally; use 'FlipFields' to change +-- the orientation of the fields (can be applied recursively). To +-- change the default orientation, use 'RankDir'. +data RecordField = LabelledTarget PortName EscString + | PortName PortName -- ^ Will result in no label for + -- that cell. + | FieldLabel EscString + | FlipFields RecordFields + deriving (Eq, Ord, Show, Read) + +instance PrintDot RecordField where + -- Have to use 'printPortName' to add the @\'<\'@ and @\'>\'@. + unqtDot (LabelledTarget t s) = printPortName t <+> unqtRecordString s + unqtDot (PortName t) = printPortName t + unqtDot (FieldLabel s) = unqtRecordString s + unqtDot (FlipFields rs) = braces $ unqtDot rs + + toDot (FieldLabel s) = printEscaped recordEscChars s + toDot rf = dquotes $ unqtDot rf + + unqtListToDot [f] = unqtDot f + unqtListToDot fs = hcat . punctuate (char '|') $ mapM unqtDot fs + + listToDot [f] = toDot f + listToDot fs = dquotes $ unqtListToDot fs + +instance ParseDot RecordField where + parseUnqt = (liftA2 maybe PortName LabelledTarget + <$> (PN <$> parseAngled parseRecord) + <*> optional (whitespace1 *> parseRecord) + ) + `onFail` + fmap FieldLabel parseRecord + `onFail` + fmap FlipFields (parseBraced parseUnqt) + `onFail` + fail "Unable to parse RecordField" + + parse = quotedParse parseUnqt + + parseUnqtList = wrapWhitespace $ sepBy1 parseUnqt (wrapWhitespace $ character '|') + + -- Note: a singleton unquoted 'FieldLabel' is /not/ valid, as it + -- will cause parsing problems for other 'Label' types. + parseList = do rfs <- quotedParse parseUnqtList + if validRFs rfs + then return rfs + else fail "This is a StrLabel, not a RecordLabel" + where + validRFs [FieldLabel str] = T.any (`elem` recordEscChars) str + validRFs _ = True + +-- | Print a 'PortName' value as expected within a Record data +-- structure. +printPortName :: PortName -> DotCode +printPortName = angled . unqtRecordString . portName + +parseRecord :: Parse Text +parseRecord = parseEscaped False recordEscChars [] + +unqtRecordString :: Text -> DotCode +unqtRecordString = unqtEscaped recordEscChars + +recordEscChars :: [Char] +recordEscChars = ['{', '}', '|', ' ', '<', '>'] + +-- ----------------------------------------------------------------------------- + +-- | How to treat a node whose name is of the form \"@|edgelabel|*@\" +-- as a special node representing an edge label. +data LabelScheme = NotEdgeLabel -- ^ No effect + | CloseToCenter -- ^ Make node close to center of neighbor + | CloseToOldCenter -- ^ Make node close to old center of neighbor + | RemoveAndStraighten -- ^ Use a two-step process. + deriving (Eq, Ord, Bounded, Enum, Show, Read) + +instance PrintDot LabelScheme where + unqtDot NotEdgeLabel = int 0 + unqtDot CloseToCenter = int 1 + unqtDot CloseToOldCenter = int 2 + unqtDot RemoveAndStraighten = int 3 + +instance ParseDot LabelScheme where + -- Use string-based parsing rather than parsing an integer just to make it easier + parseUnqt = stringValue [ ("0", NotEdgeLabel) + , ("1", CloseToCenter) + , ("2", CloseToOldCenter) + , ("3", RemoveAndStraighten) + ] + +-- ----------------------------------------------------------------------------- + +data Point = Point { xCoord :: Double + , yCoord :: Double + -- | Can only be 'Just' for @'Dim' 3@ or greater. + , zCoord :: Maybe Double + -- | Input to Graphviz only: specify that the + -- node position should not change. + , forcePos :: Bool + } + deriving (Eq, Ord, Show, Read) + +-- | Create a point with only @x@ and @y@ values. +createPoint :: Double -> Double -> Point +createPoint x y = Point x y Nothing False + +printPoint2DUnqt :: Point -> DotCode +printPoint2DUnqt p = commaDel (xCoord p) (yCoord p) + +printPoint2D :: Point -> DotCode +printPoint2D = dquotes . printPoint2DUnqt + +parsePoint2D :: Parse Point +parsePoint2D = uncurry createPoint <$> commaSepUnqt + +instance PrintDot Point where + unqtDot (Point x y mz frs) = bool id (<> char '!') frs + . maybe id (\ z -> (<> unqtDot z) . (<> comma)) mz + $ commaDel x y + + toDot = dquotes . unqtDot + + unqtListToDot = hsep . mapM unqtDot + + listToDot = dquotes . unqtListToDot + +instance ParseDot Point where + parseUnqt = uncurry Point + <$> commaSepUnqt + <*> optional (parseComma *> parseUnqt) + <*> (isJust <$> optional (character '!')) + + parse = quotedParse parseUnqt + + parseUnqtList = sepBy1 parseUnqt whitespace1 + +-- ----------------------------------------------------------------------------- + +-- | How to deal with node overlaps. +-- +-- Defaults to 'KeepOverlaps' /except/ for 'Fdp' and 'Sfdp'. +-- +-- The ability to specify the number of tries for 'Fdp''s initial +-- force-directed technique is /not/ supported (by default, 'Fdp' uses +-- @9@ passes of its in-built technique, and then @'PrismOverlap' +-- Nothing@). +-- +-- For 'Sfdp', the default is @'PrismOverlap' (Just 0)@. +data Overlap = KeepOverlaps + | ScaleOverlaps -- ^ Remove overlaps by uniformly scaling in x and y. + | ScaleXYOverlaps -- ^ Remove overlaps by separately scaling x and y. + | PrismOverlap (Maybe Word16) -- ^ Requires the Prism + -- library to be + -- available (if not, + -- this is equivalent to + -- 'VoronoiOverlap'). @'Nothing'@ + -- is equivalent to + -- @'Just' 1000@. + -- Influenced by + -- 'OverlapScaling'. + | VoronoiOverlap -- ^ Requires Graphviz >= 2.30.0. + | CompressOverlap -- ^ Scale layout down as much as + -- possible without introducing + -- overlaps, assuming none to begin + -- with. + | VpscOverlap -- ^ Uses quadratic optimization to + -- minimize node displacement. + | IpsepOverlap -- ^ Only when @mode == 'IpSep'@ + deriving (Eq, Ord, Show, Read) + +instance PrintDot Overlap where + unqtDot KeepOverlaps = unqtDot True + unqtDot ScaleOverlaps = text "scale" + unqtDot ScaleXYOverlaps = text "scalexy" + unqtDot (PrismOverlap i) = maybe id (flip (<>) . unqtDot) i $ text "prism" + unqtDot VoronoiOverlap = text "voronoi" + unqtDot CompressOverlap = text "compress" + unqtDot VpscOverlap = text "vpsc" + unqtDot IpsepOverlap = text "ipsep" + +-- | Note that @overlap=false@ defaults to @'PrismOverlap' Nothing@, +-- but if the Prism library isn't available then it is equivalent to +-- 'VoronoiOverlap'. +instance ParseDot Overlap where + parseUnqt = oneOf [ stringRep KeepOverlaps "true" + , stringRep ScaleXYOverlaps "scalexy" + , stringRep ScaleOverlaps "scale" + , string "prism" *> fmap PrismOverlap (optional parse) + , stringRep (PrismOverlap Nothing) "false" + , stringRep VoronoiOverlap "voronoi" + , stringRep CompressOverlap "compress" + , stringRep VpscOverlap "vpsc" + , stringRep IpsepOverlap "ipsep" + ] + +-- ----------------------------------------------------------------------------- + +newtype LayerSep = LSep Text + deriving (Eq, Ord, Show, Read) + +instance PrintDot LayerSep where + unqtDot (LSep ls) = setLayerSep (T.unpack ls) *> unqtDot ls + + toDot (LSep ls) = setLayerSep (T.unpack ls) *> toDot ls + +instance ParseDot LayerSep where + parseUnqt = do ls <- parseUnqt + setLayerSep $ T.unpack ls + return $ LSep ls + + parse = do ls <- parse + setLayerSep $ T.unpack ls + return $ LSep ls + +newtype LayerListSep = LLSep Text + deriving (Eq, Ord, Show, Read) + +instance PrintDot LayerListSep where + unqtDot (LLSep ls) = setLayerListSep (T.unpack ls) *> unqtDot ls + + toDot (LLSep ls) = setLayerListSep (T.unpack ls) *> toDot ls + +instance ParseDot LayerListSep where + parseUnqt = do ls <- parseUnqt + setLayerListSep $ T.unpack ls + return $ LLSep ls + + parse = do ls <- parse + setLayerListSep $ T.unpack ls + return $ LLSep ls + +type LayerRange = [LayerRangeElem] + +data LayerRangeElem = LRID LayerID + | LRS LayerID LayerID + deriving (Eq, Ord, Show, Read) + +instance PrintDot LayerRangeElem where + unqtDot (LRID lid) = unqtDot lid + unqtDot (LRS id1 id2) = do ls <- getLayerSep + let s = unqtDot $ head ls + unqtDot id1 <> s <> unqtDot id2 + + toDot (LRID lid) = toDot lid + toDot lrs = dquotes $ unqtDot lrs + + unqtListToDot lr = do lls <- getLayerListSep + let s = unqtDot $ head lls + hcat . punctuate s $ mapM unqtDot lr + + listToDot [lre] = toDot lre + listToDot lrs = dquotes $ unqtListToDot lrs + +instance ParseDot LayerRangeElem where + parseUnqt = ignoreSep LRS parseUnqt parseLayerSep parseUnqt + `onFail` + fmap LRID parseUnqt + + parse = quotedParse (ignoreSep LRS parseUnqt parseLayerSep parseUnqt) + `onFail` + fmap LRID parse + + parseUnqtList = sepBy parseUnqt parseLayerListSep + + parseList = quotedParse parseUnqtList + `onFail` + fmap ((:[]) . LRID) parse + +parseLayerSep :: Parse () +parseLayerSep = do ls <- getLayerSep + many1Satisfy (`elem` ls) *> return () + +parseLayerName :: Parse Text +parseLayerName = parseEscaped False [] =<< liftA2 (++) getLayerSep getLayerListSep + +parseLayerName' :: Parse Text +parseLayerName' = stringBlock + `onFail` + quotedParse parseLayerName + +parseLayerListSep :: Parse () +parseLayerListSep = do lls <- getLayerListSep + many1Satisfy (`elem` lls) *> return () + +-- | You should not have any layer separator characters for the +-- 'LRName' option, as they won't be parseable. +data LayerID = AllLayers + | LRInt Int + | LRName Text -- ^ Should not be a number or @"all"@. + deriving (Eq, Ord, Show, Read) + +instance PrintDot LayerID where + unqtDot AllLayers = text "all" + unqtDot (LRInt n) = unqtDot n + unqtDot (LRName nm) = unqtDot nm + + toDot (LRName nm) = toDot nm + -- Other two don't need quotes + toDot li = unqtDot li + + unqtListToDot ll = do ls <- getLayerSep + let s = unqtDot $ head ls + hcat . punctuate s $ mapM unqtDot ll + + listToDot [l] = toDot l + -- Might not need quotes, but probably will. Can't tell either + -- way since we don't know what the separator character will be. + listToDot ll = dquotes $ unqtDot ll + +instance ParseDot LayerID where + parseUnqt = checkLayerName <$> parseLayerName -- tests for Int and All + + parse = oneOf [ checkLayerName <$> parseLayerName' + , LRInt <$> parse -- Mainly for unquoted case. + ] + +checkLayerName :: Text -> LayerID +checkLayerName str = maybe checkAll LRInt $ stringToInt str + where + checkAll = if T.toLower str == "all" + then AllLayers + else LRName str + +-- Remember: this /must/ be a newtype as we can't use arbitrary +-- LayerID values! + +-- | A list of layer names. The names should all be unique 'LRName' +-- values, and when printed will use an arbitrary character from +-- 'defLayerSep'. The values in the list are implicitly numbered +-- @1, 2, ...@. +newtype LayerList = LL [LayerID] + deriving (Eq, Ord, Show, Read) + +instance PrintDot LayerList where + unqtDot (LL ll) = unqtDot ll + + toDot (LL ll) = toDot ll + +instance ParseDot LayerList where + parseUnqt = LL <$> sepBy1 parseUnqt parseLayerSep + + parse = quotedParse parseUnqt + `onFail` + fmap (LL . (:[]) . LRName) stringBlock + `onFail` + quotedParse (stringRep (LL []) "") + +-- ----------------------------------------------------------------------------- + +data Order = OutEdges -- ^ Draw outgoing edges in order specified. + | InEdges -- ^ Draw incoming edges in order specified. + deriving (Eq, Ord, Bounded, Enum, Show, Read) + +instance PrintDot Order where + unqtDot OutEdges = text "out" + unqtDot InEdges = text "in" + +instance ParseDot Order where + parseUnqt = oneOf [ stringRep OutEdges "out" + , stringRep InEdges "in" + ] + +-- ----------------------------------------------------------------------------- + +data OutputMode = BreadthFirst | NodesFirst | EdgesFirst + deriving (Eq, Ord, Bounded, Enum, Show, Read) + +instance PrintDot OutputMode where + unqtDot BreadthFirst = text "breadthfirst" + unqtDot NodesFirst = text "nodesfirst" + unqtDot EdgesFirst = text "edgesfirst" + +instance ParseDot OutputMode where + parseUnqt = oneOf [ stringRep BreadthFirst "breadthfirst" + , stringRep NodesFirst "nodesfirst" + , stringRep EdgesFirst "edgesfirst" + ] + +-- ----------------------------------------------------------------------------- + +data Pack = DoPack + | DontPack + | PackMargin Int -- ^ If non-negative, then packs; otherwise doesn't. + deriving (Eq, Ord, Show, Read) + +instance PrintDot Pack where + unqtDot DoPack = unqtDot True + unqtDot DontPack = unqtDot False + unqtDot (PackMargin m) = unqtDot m + +instance ParseDot Pack where + -- What happens if it parses 0? It's non-negative, but parses as False + parseUnqt = oneOf [ PackMargin <$> parseUnqt + , bool DontPack DoPack <$> onlyBool + ] + +-- ----------------------------------------------------------------------------- + +data PackMode = PackNode + | PackClust + | PackGraph + | PackArray Bool Bool (Maybe Int) -- ^ Sort by cols, sort + -- by user, number of + -- rows/cols + deriving (Eq, Ord, Show, Read) + +instance PrintDot PackMode where + unqtDot PackNode = text "node" + unqtDot PackClust = text "clust" + unqtDot PackGraph = text "graph" + unqtDot (PackArray c u mi) = addNum . isU . isC . isUnder + $ text "array" + where + addNum = maybe id (flip (<>) . unqtDot) mi + isUnder = if c || u + then (<> char '_') + else id + isC = if c + then (<> char 'c') + else id + isU = if u + then (<> char 'u') + else id + +instance ParseDot PackMode where + parseUnqt = oneOf [ stringRep PackNode "node" + , stringRep PackClust "clust" + , stringRep PackGraph "graph" + , do string "array" + mcu <- optional $ character '_' *> many1 (satisfy isCU) + let c = hasCharacter mcu 'c' + u = hasCharacter mcu 'u' + mi <- optional parseUnqt + return $ PackArray c u mi + ] + where + hasCharacter ms c = maybe False (elem c) ms + -- Also checks and removes quote characters + isCU = (`elem` ['c', 'u']) + +-- ----------------------------------------------------------------------------- + +data Pos = PointPos Point + | SplinePos [Spline] + deriving (Eq, Ord, Show, Read) + +instance PrintDot Pos where + unqtDot (PointPos p) = unqtDot p + unqtDot (SplinePos ss) = unqtDot ss + + toDot (PointPos p) = toDot p + toDot (SplinePos ss) = toDot ss + +instance ParseDot Pos where + -- Have to be careful with this: if we try to parse points first, + -- then a spline with no start and end points will erroneously get + -- parsed as a point and then the parser will crash as it expects a + -- closing quote character... + parseUnqt = do splns <- parseUnqt + case splns of + [Spline Nothing Nothing [p]] -> return $ PointPos p + _ -> return $ SplinePos splns + + parse = quotedParse parseUnqt + +-- ----------------------------------------------------------------------------- + +-- | Controls how (and if) edges are represented. +-- +-- For 'Dot', the default is 'SplineEdges'; for all other layouts +-- the default is 'LineEdges'. +data EdgeType = SplineEdges -- ^ Except for 'Dot', requires + -- non-overlapping nodes (see + -- 'Overlap'). + | LineEdges + | NoEdges + | PolyLine + | Ortho -- ^ Does not handle ports or edge labels in 'Dot'. + | Curved -- ^ Requires Graphviz >= 2.30.0. + | CompoundEdge -- ^ 'Fdp' only + deriving (Eq, Ord, Bounded, Enum, Show, Read) + +instance PrintDot EdgeType where + unqtDot SplineEdges = text "spline" + unqtDot LineEdges = text "line" + unqtDot NoEdges = empty + unqtDot PolyLine = text "polyline" + unqtDot Ortho = text "ortho" + unqtDot Curved = text "curved" + unqtDot CompoundEdge = text "compound" + + toDot NoEdges = dquotes empty + toDot et = unqtDot et + +instance ParseDot EdgeType where + -- Can't parse NoEdges without quotes. + parseUnqt = oneOf [ bool LineEdges SplineEdges <$> parse + , stringRep SplineEdges "spline" + , stringRep LineEdges "line" + , stringRep NoEdges "none" + , stringRep PolyLine "polyline" + , stringRep Ortho "ortho" + , stringRep Curved "curved" + , stringRep CompoundEdge "compound" + ] + + parse = stringRep NoEdges "\"\"" + `onFail` + optionalQuoted parseUnqt + +-- ----------------------------------------------------------------------------- + +-- | Upper-case first character is major order; +-- lower-case second character is minor order. +data PageDir = Bl | Br | Tl | Tr | Rb | Rt | Lb | Lt + deriving (Eq, Ord, Bounded, Enum, Show, Read) + +instance PrintDot PageDir where + unqtDot Bl = text "BL" + unqtDot Br = text "BR" + unqtDot Tl = text "TL" + unqtDot Tr = text "TR" + unqtDot Rb = text "RB" + unqtDot Rt = text "RT" + unqtDot Lb = text "LB" + unqtDot Lt = text "LT" + +instance ParseDot PageDir where + parseUnqt = stringValue [ ("BL", Bl) + , ("BR", Br) + , ("TL", Tl) + , ("TR", Tr) + , ("RB", Rb) + , ("RT", Rt) + , ("LB", Lb) + , ("LT", Lt) + ] + +-- ----------------------------------------------------------------------------- + +-- | The number of points in the list must be equivalent to 1 mod 3; +-- note that this is not checked. +data Spline = Spline { endPoint :: Maybe Point + , startPoint :: Maybe Point + , splinePoints :: [Point] + } + deriving (Eq, Ord, Show, Read) + +instance PrintDot Spline where + unqtDot (Spline me ms ps) = addE . addS + . hsep + $ mapM unqtDot ps + where + addP t = maybe id ((<+>) . commaDel t) + addS = addP 's' ms + addE = addP 'e' me + + toDot = dquotes . unqtDot + + unqtListToDot = hcat . punctuate semi . mapM unqtDot + + listToDot = dquotes . unqtListToDot + +instance ParseDot Spline where + parseUnqt = Spline <$> parseP 'e' <*> parseP 's' + <*> sepBy1 parseUnqt whitespace1 + where + parseP t = optional (character t *> parseComma *> parseUnqt <* whitespace1) + + parse = quotedParse parseUnqt + + parseUnqtList = sepBy1 parseUnqt (character ';') + +-- ----------------------------------------------------------------------------- + +data QuadType = NormalQT + | FastQT + | NoQT + deriving (Eq, Ord, Bounded, Enum, Show, Read) + +instance PrintDot QuadType where + unqtDot NormalQT = text "normal" + unqtDot FastQT = text "fast" + unqtDot NoQT = text "none" + +instance ParseDot QuadType where + -- Have to take into account the slightly different interpretation + -- of Bool used as an option for parsing QuadType + parseUnqt = oneOf [ stringRep NormalQT "normal" + , stringRep FastQT "fast" + , stringRep NoQT "none" + , character '2' *> return FastQT -- weird bool + , bool NoQT NormalQT <$> parse + ] + +-- ----------------------------------------------------------------------------- + +-- | Specify the root node either as a Node attribute or a Graph attribute. +data Root = IsCentral -- ^ For Nodes only + | NotCentral -- ^ For Nodes only + | NodeName Text -- ^ For Graphs only + deriving (Eq, Ord, Show, Read) + +instance PrintDot Root where + unqtDot IsCentral = unqtDot True + unqtDot NotCentral = unqtDot False + unqtDot (NodeName n) = unqtDot n + + toDot (NodeName n) = toDot n + toDot r = unqtDot r + +instance ParseDot Root where + parseUnqt = fmap (bool NotCentral IsCentral) onlyBool + `onFail` + fmap NodeName parseUnqt + + parse = optionalQuoted (bool NotCentral IsCentral <$> onlyBool) + `onFail` + fmap NodeName parse + +-- ----------------------------------------------------------------------------- + +data RankType = SameRank + | MinRank + | SourceRank + | MaxRank + | SinkRank + deriving (Eq, Ord, Bounded, Enum, Show, Read) + +instance PrintDot RankType where + unqtDot SameRank = text "same" + unqtDot MinRank = text "min" + unqtDot SourceRank = text "source" + unqtDot MaxRank = text "max" + unqtDot SinkRank = text "sink" + +instance ParseDot RankType where + parseUnqt = stringValue [ ("same", SameRank) + , ("min", MinRank) + , ("source", SourceRank) + , ("max", MaxRank) + , ("sink", SinkRank) + ] + +-- ----------------------------------------------------------------------------- + +data RankDir = FromTop + | FromLeft + | FromBottom + | FromRight + deriving (Eq, Ord, Bounded, Enum, Show, Read) + +instance PrintDot RankDir where + unqtDot FromTop = text "TB" + unqtDot FromLeft = text "LR" + unqtDot FromBottom = text "BT" + unqtDot FromRight = text "RL" + +instance ParseDot RankDir where + parseUnqt = oneOf [ stringRep FromTop "TB" + , stringRep FromLeft "LR" + , stringRep FromBottom "BT" + , stringRep FromRight "RL" + ] + +-- ----------------------------------------------------------------------------- + +-- | Geometries of shapes are affected by the attributes 'Regular', +-- 'Peripheries' and 'Orientation'. +data Shape + = BoxShape -- ^ Has synonyms of /rect/ and /rectangle/. + | Polygon -- ^ Also affected by 'Sides', 'Skew' and 'Distortion'. + | Ellipse -- ^ Has synonym of /oval/. + | Circle + | PointShape -- ^ Only affected by 'Peripheries', 'Width' and + -- 'Height'. + | Egg + | Triangle + | PlainText -- ^ Has synonym of /none/. Recommended for + -- 'HtmlLabel's. + | DiamondShape + | Trapezium + | Parallelogram + | House + | Pentagon + | Hexagon + | Septagon + | Octagon + | DoubleCircle + | DoubleOctagon + | TripleOctagon + | InvTriangle + | InvTrapezium + | InvHouse + | MDiamond + | MSquare + | MCircle + | Square + | Star -- ^ Requires Graphviz >= 2.32.0. + | Underline -- ^ Requires Graphviz >= 2.36.0. + | Note + | Tab + | Folder + | Box3D + | Component + | Promoter -- ^ Requires Graphviz >= 2.30.0. + | CDS -- ^ Requires Graphviz >= 2.30.0. + | Terminator -- ^ Requires Graphviz >= 2.30.0. + | UTR -- ^ Requires Graphviz >= 2.30.0. + | PrimerSite -- ^ Requires Graphviz >= 2.30.0. + | RestrictionSite -- ^ Requires Graphviz >= 2.30.0. + | FivePovOverhang -- ^ Requires Graphviz >= 2.30.0. + | ThreePovOverhang -- ^ Requires Graphviz >= 2.30.0. + | NoOverhang -- ^ Requires Graphviz >= 2.30.0. + | Assembly -- ^ Requires Graphviz >= 2.30.0. + | Signature -- ^ Requires Graphviz >= 2.30.0. + | Insulator -- ^ Requires Graphviz >= 2.30.0. + | Ribosite -- ^ Requires Graphviz >= 2.30.0. + | RNAStab -- ^ Requires Graphviz >= 2.30.0. + | ProteaseSite -- ^ Requires Graphviz >= 2.30.0. + | ProteinStab -- ^ Requires Graphviz >= 2.30.0. + | RPromoter -- ^ Requires Graphviz >= 2.30.0. + | RArrow -- ^ Requires Graphviz >= 2.30.0. + | LArrow -- ^ Requires Graphviz >= 2.30.0. + | LPromoter -- ^ Requires Graphviz >= 2.30.0. + | Record -- ^ Must specify the record shape with a 'Label'. + | MRecord -- ^ Must specify the record shape with a 'Label'. + deriving (Eq, Ord, Bounded, Enum, Show, Read) + +instance PrintDot Shape where + unqtDot BoxShape = text "box" + unqtDot Polygon = text "polygon" + unqtDot Ellipse = text "ellipse" + unqtDot Circle = text "circle" + unqtDot PointShape = text "point" + unqtDot Egg = text "egg" + unqtDot Triangle = text "triangle" + unqtDot PlainText = text "plaintext" + unqtDot DiamondShape = text "diamond" + unqtDot Trapezium = text "trapezium" + unqtDot Parallelogram = text "parallelogram" + unqtDot House = text "house" + unqtDot Pentagon = text "pentagon" + unqtDot Hexagon = text "hexagon" + unqtDot Septagon = text "septagon" + unqtDot Octagon = text "octagon" + unqtDot DoubleCircle = text "doublecircle" + unqtDot DoubleOctagon = text "doubleoctagon" + unqtDot TripleOctagon = text "tripleoctagon" + unqtDot InvTriangle = text "invtriangle" + unqtDot InvTrapezium = text "invtrapezium" + unqtDot InvHouse = text "invhouse" + unqtDot MDiamond = text "Mdiamond" + unqtDot MSquare = text "Msquare" + unqtDot MCircle = text "Mcircle" + unqtDot Square = text "square" + unqtDot Star = text "star" + unqtDot Underline = text "underline" + unqtDot Note = text "note" + unqtDot Tab = text "tab" + unqtDot Folder = text "folder" + unqtDot Box3D = text "box3d" + unqtDot Component = text "component" + unqtDot Promoter = text "promoter" + unqtDot CDS = text "cds" + unqtDot Terminator = text "terminator" + unqtDot UTR = text "utr" + unqtDot PrimerSite = text "primersite" + unqtDot RestrictionSite = text "restrictionsite" + unqtDot FivePovOverhang = text "fivepovoverhang" + unqtDot ThreePovOverhang = text "threepovoverhang" + unqtDot NoOverhang = text "nooverhang" + unqtDot Assembly = text "assembly" + unqtDot Signature = text "signature" + unqtDot Insulator = text "insulator" + unqtDot Ribosite = text "ribosite" + unqtDot RNAStab = text "rnastab" + unqtDot ProteaseSite = text "proteasesite" + unqtDot ProteinStab = text "proteinstab" + unqtDot RPromoter = text "rpromoter" + unqtDot RArrow = text "rarrow" + unqtDot LArrow = text "larrow" + unqtDot LPromoter = text "lpromoter" + unqtDot Record = text "record" + unqtDot MRecord = text "Mrecord" + +instance ParseDot Shape where + parseUnqt = stringValue [ ("box3d", Box3D) + , ("box", BoxShape) + , ("rectangle", BoxShape) + , ("rect", BoxShape) + , ("polygon", Polygon) + , ("ellipse", Ellipse) + , ("oval", Ellipse) + , ("circle", Circle) + , ("point", PointShape) + , ("egg", Egg) + , ("triangle", Triangle) + , ("plaintext", PlainText) + , ("none", PlainText) + , ("diamond", DiamondShape) + , ("trapezium", Trapezium) + , ("parallelogram", Parallelogram) + , ("house", House) + , ("pentagon", Pentagon) + , ("hexagon", Hexagon) + , ("septagon", Septagon) + , ("octagon", Octagon) + , ("doublecircle", DoubleCircle) + , ("doubleoctagon", DoubleOctagon) + , ("tripleoctagon", TripleOctagon) + , ("invtriangle", InvTriangle) + , ("invtrapezium", InvTrapezium) + , ("invhouse", InvHouse) + , ("Mdiamond", MDiamond) + , ("Msquare", MSquare) + , ("Mcircle", MCircle) + , ("square", Square) + , ("star", Star) + , ("underline", Underline) + , ("note", Note) + , ("tab", Tab) + , ("folder", Folder) + , ("component", Component) + , ("promoter", Promoter) + , ("cds", CDS) + , ("terminator", Terminator) + , ("utr", UTR) + , ("primersite", PrimerSite) + , ("restrictionsite", RestrictionSite) + , ("fivepovoverhang", FivePovOverhang) + , ("threepovoverhang", ThreePovOverhang) + , ("nooverhang", NoOverhang) + , ("assembly", Assembly) + , ("signature", Signature) + , ("insulator", Insulator) + , ("ribosite", Ribosite) + , ("rnastab", RNAStab) + , ("proteasesite", ProteaseSite) + , ("proteinstab", ProteinStab) + , ("rpromoter", RPromoter) + , ("rarrow", RArrow) + , ("larrow", LArrow) + , ("lpromoter", LPromoter) + , ("record", Record) + , ("Mrecord", MRecord) + ] + +-- ----------------------------------------------------------------------------- + +data SmoothType = NoSmooth + | AvgDist + | GraphDist + | PowerDist + | RNG + | Spring + | TriangleSmooth + deriving (Eq, Ord, Bounded, Enum, Show, Read) + +instance PrintDot SmoothType where + unqtDot NoSmooth = text "none" + unqtDot AvgDist = text "avg_dist" + unqtDot GraphDist = text "graph_dist" + unqtDot PowerDist = text "power_dist" + unqtDot RNG = text "rng" + unqtDot Spring = text "spring" + unqtDot TriangleSmooth = text "triangle" + +instance ParseDot SmoothType where + parseUnqt = oneOf [ stringRep NoSmooth "none" + , stringRep AvgDist "avg_dist" + , stringRep GraphDist "graph_dist" + , stringRep PowerDist "power_dist" + , stringRep RNG "rng" + , stringRep Spring "spring" + , stringRep TriangleSmooth "triangle" + ] + +-- ----------------------------------------------------------------------------- + +data StartType = StartStyle STStyle + | StartSeed Int + | StartStyleSeed STStyle Int + deriving (Eq, Ord, Show, Read) + +instance PrintDot StartType where + unqtDot (StartStyle ss) = unqtDot ss + unqtDot (StartSeed s) = unqtDot s + unqtDot (StartStyleSeed ss s) = unqtDot ss <> unqtDot s + +instance ParseDot StartType where + parseUnqt = oneOf [ liftA2 StartStyleSeed parseUnqt parseUnqt + , StartStyle <$> parseUnqt + , StartSeed <$> parseUnqt + ] + +data STStyle = RegularStyle + | SelfStyle + | RandomStyle + deriving (Eq, Ord, Bounded, Enum, Show, Read) + +instance PrintDot STStyle where + unqtDot RegularStyle = text "regular" + unqtDot SelfStyle = text "self" + unqtDot RandomStyle = text "random" + +instance ParseDot STStyle where + parseUnqt = oneOf [ stringRep RegularStyle "regular" + , stringRep SelfStyle "self" + , stringRep RandomStyle "random" + ] + +-- ----------------------------------------------------------------------------- + +-- | An individual style item. Except for 'DD', the @['String']@ +-- should be empty. +data StyleItem = SItem StyleName [Text] + deriving (Eq, Ord, Show, Read) + +instance PrintDot StyleItem where + unqtDot (SItem nm args) + | null args = dnm + | otherwise = dnm <> parens args' + where + dnm = unqtDot nm + args' = hcat . punctuate comma $ mapM unqtDot args + + toDot si@(SItem nm args) + | null args = toDot nm + | otherwise = dquotes $ unqtDot si + + unqtListToDot = hcat . punctuate comma . mapM unqtDot + + listToDot [SItem nm []] = toDot nm + listToDot sis = dquotes $ unqtListToDot sis + +instance ParseDot StyleItem where + parseUnqt = liftA2 SItem parseUnqt (tryParseList' parseArgs) + + parse = quotedParse (liftA2 SItem parseUnqt parseArgs) + `onFail` + fmap (`SItem` []) parse + + parseUnqtList = sepBy1 parseUnqt (wrapWhitespace parseComma) + + parseList = quotedParse parseUnqtList + `onFail` + -- Might not necessarily need to be quoted if a singleton... + fmap return parse + +parseArgs :: Parse [Text] +parseArgs = bracketSep (character '(') + parseComma + (character ')') + parseStyleName + +data StyleName = Dashed -- ^ Nodes and Edges + | Dotted -- ^ Nodes and Edges + | Solid -- ^ Nodes and Edges + | Bold -- ^ Nodes and Edges + | Invisible -- ^ Nodes and Edges + | Filled -- ^ Nodes and Clusters + | Striped -- ^ Rectangularly-shaped Nodes and + -- Clusters; requires Graphviz >= 2.30.0 + | Wedged -- ^ Elliptically-shaped Nodes only; + -- requires Graphviz >= 2.30.0 + | Diagonals -- ^ Nodes only + | Rounded -- ^ Nodes and Clusters + | Tapered -- ^ Edges only; requires Graphviz >= + -- 2.29.0 + | Radial -- ^ Nodes, Clusters and Graphs, for use + -- with 'GradientAngle'; requires + -- Graphviz >= 2.29.0 + | DD Text -- ^ Device Dependent + deriving (Eq, Ord, Show, Read) + +instance PrintDot StyleName where + unqtDot Dashed = text "dashed" + unqtDot Dotted = text "dotted" + unqtDot Solid = text "solid" + unqtDot Bold = text "bold" + unqtDot Invisible = text "invis" + unqtDot Filled = text "filled" + unqtDot Striped = text "striped" + unqtDot Wedged = text "wedged" + unqtDot Diagonals = text "diagonals" + unqtDot Rounded = text "rounded" + unqtDot Tapered = text "tapered" + unqtDot Radial = text "radial" + unqtDot (DD nm) = unqtDot nm + + toDot (DD nm) = toDot nm + toDot sn = unqtDot sn + +instance ParseDot StyleName where + parseUnqt = checkDD <$> parseStyleName + + parse = quotedParse parseUnqt + `onFail` + fmap checkDD quotelessString + +checkDD :: Text -> StyleName +checkDD str = case T.toLower str of + "dashed" -> Dashed + "dotted" -> Dotted + "solid" -> Solid + "bold" -> Bold + "invis" -> Invisible + "filled" -> Filled + "striped" -> Striped + "wedged" -> Wedged + "diagonals" -> Diagonals + "rounded" -> Rounded + "tapered" -> Tapered + "radial" -> Radial + _ -> DD str + +parseStyleName :: Parse Text +parseStyleName = liftA2 T.cons (orEscaped . noneOf $ ' ' : disallowedChars) + (parseEscaped True [] disallowedChars) + where + disallowedChars = [quoteChar, '(', ')', ','] + -- Used because the first character has slightly stricter requirements than the rest. + orSlash p = stringRep '\\' "\\\\" `onFail` p + orEscaped = orQuote . orSlash + +-- ----------------------------------------------------------------------------- + +data ViewPort = VP { wVal :: Double + , hVal :: Double + , zVal :: Double + , focus :: Maybe FocusType + } + deriving (Eq, Ord, Show, Read) + +instance PrintDot ViewPort where + unqtDot vp = maybe vs ((<>) (vs <> comma) . unqtDot) + $ focus vp + where + vs = hcat . punctuate comma + $ mapM (unqtDot . ($vp)) [wVal, hVal, zVal] + + toDot = dquotes . unqtDot + +instance ParseDot ViewPort where + parseUnqt = VP <$> parseUnqt + <* parseComma + <*> parseUnqt + <* parseComma + <*> parseUnqt + <*> optional (parseComma *> parseUnqt) + + parse = quotedParse parseUnqt + +-- | For use with 'ViewPort'. +data FocusType = XY Point + | NodeFocus Text + deriving (Eq, Ord, Show, Read) + +instance PrintDot FocusType where + unqtDot (XY p) = unqtDot p + unqtDot (NodeFocus nm) = unqtDot nm + + toDot (XY p) = toDot p + toDot (NodeFocus nm) = toDot nm + +instance ParseDot FocusType where + parseUnqt = fmap XY parseUnqt + `onFail` + fmap NodeFocus parseUnqt + + parse = fmap XY parse + `onFail` + fmap NodeFocus parse + +-- ----------------------------------------------------------------------------- + +data VerticalPlacement = VTop + | VCenter -- ^ Only valid for Nodes. + | VBottom + deriving (Eq, Ord, Bounded, Enum, Show, Read) + +instance PrintDot VerticalPlacement where + unqtDot VTop = char 't' + unqtDot VCenter = char 'c' + unqtDot VBottom = char 'b' + +instance ParseDot VerticalPlacement where + parseUnqt = oneOf [ stringReps VTop ["top", "t"] + , stringReps VCenter ["centre", "center", "c"] + , stringReps VBottom ["bottom", "b"] + ] + +-- ----------------------------------------------------------------------------- + +-- | A list of search paths. +newtype Paths = Paths { paths :: [FilePath] } + deriving (Eq, Ord, Show, Read) + +instance PrintDot Paths where + unqtDot = unqtDot . intercalate [searchPathSeparator] . paths + + toDot (Paths [p]) = toDot p + toDot ps = dquotes $ unqtDot ps + +instance ParseDot Paths where + parseUnqt = Paths . splitSearchPath <$> parseUnqt + + parse = quotedParse parseUnqt + `onFail` + fmap (Paths . (:[]) . T.unpack) quotelessString + +-- ----------------------------------------------------------------------------- + +data ScaleType = UniformScale + | NoScale + | FillWidth + | FillHeight + | FillBoth + deriving (Eq, Ord, Bounded, Enum, Show, Read) + +instance PrintDot ScaleType where + unqtDot UniformScale = unqtDot True + unqtDot NoScale = unqtDot False + unqtDot FillWidth = text "width" + unqtDot FillHeight = text "height" + unqtDot FillBoth = text "both" + +instance ParseDot ScaleType where + parseUnqt = oneOf [ stringRep UniformScale "true" + , stringRep NoScale "false" + , stringRep FillWidth "width" + , stringRep FillHeight "height" + , stringRep FillBoth "both" + ] + +-- ----------------------------------------------------------------------------- + +data Justification = JLeft + | JRight + | JCenter + deriving (Eq, Ord, Bounded, Enum, Show, Read) + +instance PrintDot Justification where + unqtDot JLeft = char 'l' + unqtDot JRight = char 'r' + unqtDot JCenter = char 'c' + +instance ParseDot Justification where + parseUnqt = oneOf [ stringReps JLeft ["left", "l"] + , stringReps JRight ["right", "r"] + , stringReps JCenter ["center", "centre", "c"] + ] + +-- ----------------------------------------------------------------------------- + +data Ratios = AspectRatio Double + | FillRatio + | CompressRatio + | ExpandRatio + | AutoRatio + deriving (Eq, Ord, Show, Read) + +instance PrintDot Ratios where + unqtDot (AspectRatio r) = unqtDot r + unqtDot FillRatio = text "fill" + unqtDot CompressRatio = text "compress" + unqtDot ExpandRatio = text "expand" + unqtDot AutoRatio = text "auto" + + toDot (AspectRatio r) = toDot r + toDot r = unqtDot r + +instance ParseDot Ratios where + parseUnqt = parseRatio True + + parse = quotedParse parseUnqt <|> parseRatio False + +parseRatio :: Bool -> Parse Ratios +parseRatio q = oneOf [ AspectRatio <$> parseSignedFloat q + , stringRep FillRatio "fill" + , stringRep CompressRatio "compress" + , stringRep ExpandRatio "expand" + , stringRep AutoRatio "auto" + ] + +-- ----------------------------------------------------------------------------- + +-- | A numeric type with an explicit separation between integers and +-- floating-point values. +data Number = Int Int + | Dbl Double + deriving (Eq, Ord, Show, Read) + +instance PrintDot Number where + unqtDot (Int i) = unqtDot i + unqtDot (Dbl d) = unqtDot d + + toDot (Int i) = toDot i + toDot (Dbl d) = toDot d + +instance ParseDot Number where + parseUnqt = parseNumber True + + parse = quotedParse parseUnqt + <|> + parseNumber False + +parseNumber :: Bool -> Parse Number +parseNumber q = Dbl <$> parseStrictFloat q + <|> + Int <$> parseUnqt + +-- ----------------------------------------------------------------------------- + +-- | If set, normalizes coordinates such that the first point is at +-- the origin and the first edge is at the angle if specified. +data Normalized = IsNormalized -- ^ Equivalent to @'NormalizedAngle' 0@. + | NotNormalized + | NormalizedAngle Double -- ^ Angle of first edge when + -- normalized. Requires + -- Graphviz >= 2.32.0. + deriving (Eq, Ord, Show, Read) + +instance PrintDot Normalized where + unqtDot IsNormalized = unqtDot True + unqtDot NotNormalized = unqtDot False + unqtDot (NormalizedAngle a) = unqtDot a + + toDot (NormalizedAngle a) = toDot a + toDot norm = unqtDot norm + +instance ParseDot Normalized where + parseUnqt = parseNormalized True + + parse = quotedParse parseUnqt <|> parseNormalized False + +parseNormalized :: Bool -> Parse Normalized +parseNormalized q = NormalizedAngle <$> parseSignedFloat q + <|> + bool NotNormalized IsNormalized <$> onlyBool + +-- ----------------------------------------------------------------------------- + +-- | Determine how the 'Width' and 'Height' attributes specify the +-- size of nodes. +data NodeSize = GrowAsNeeded + -- ^ Nodes will be the smallest width and height + -- needed to contain the label and any possible + -- image. 'Width' and 'Height' are the minimum + -- allowed sizes. + | SetNodeSize + -- ^ 'Width' and 'Height' dictate the size of the node + -- with a warning if the label cannot fit in this. + | SetShapeSize + -- ^ 'Width' and 'Height' dictate the size of the + -- shape only and the label can expand out of the + -- shape (with a warning). Requires Graphviz >= + -- 2.38.0. + deriving (Eq, Ord, Bounded, Enum, Show, Read) + +instance PrintDot NodeSize where + unqtDot GrowAsNeeded = unqtDot False + unqtDot SetNodeSize = unqtDot True + unqtDot SetShapeSize = text "shape" + +instance ParseDot NodeSize where + parseUnqt = bool GrowAsNeeded SetNodeSize <$> parseUnqt + <|> + stringRep SetShapeSize "shape" + +-- ----------------------------------------------------------------------------- + +{- + +As of Graphviz 2.36.0 this was commented out; as such it might come +back, so leave this here in case we need it again. + +data AspectType = RatioOnly Double + | RatioPassCount Double Int + deriving (Eq, Ord, Show, Read) + +instance PrintDot AspectType where + unqtDot (RatioOnly r) = unqtDot r + unqtDot (RatioPassCount r p) = commaDel r p + + toDot at@RatioOnly{} = unqtDot at + toDot at@RatioPassCount{} = dquotes $ unqtDot at + +instance ParseDot AspectType where + parseUnqt = fmap (uncurry RatioPassCount) commaSepUnqt + `onFail` + fmap RatioOnly parseUnqt + + + parse = quotedParse (uncurry RatioPassCount <$> commaSepUnqt) + `onFail` + fmap RatioOnly parse + +-} diff --git a/Data/GraphViz/Commands.hs b/Data/GraphViz/Commands.hs --- a/Data/GraphViz/Commands.hs +++ b/Data/GraphViz/Commands.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses, OverloadedStrings #-} {- | Module : Data.GraphViz.Commands @@ -40,48 +40,35 @@ , runGraphvizCanvas , runGraphvizCanvas' , graphvizWithHandle + -- * Testing if Graphviz is installed + , isGraphvizInstalled + , quitWithoutGraphviz ) where --- Want to use the extensible-exception version -import Prelude hiding (catch) - import Data.GraphViz.Types -- This is here just for Haddock linking purposes. -import Data.GraphViz.Attributes.Complete(Attribute(Z)) -import Data.GraphViz.Commands.IO(runCommand) +import Data.GraphViz.Commands.Available +import Data.GraphViz.Commands.IO (runCommand) import Data.GraphViz.Exception -import qualified Data.ByteString as SB -import System.IO(Handle, hSetBinaryMode) -import Control.Monad(liftM) -import System.FilePath((<.>)) +import Control.Monad (liftM, unless) +import qualified Data.ByteString as SB +import Data.Maybe (isJust) +import Data.Version (Version (..), showVersion) +import System.Directory (findExecutable) +import System.Exit (ExitCode (..), exitWith) +import System.FilePath ((<.>)) +import System.IO (Handle, hPutStrLn, hSetBinaryMode, stderr) -- ----------------------------------------------------------------------------- --- | The available Graphviz commands. The following directions are --- based upon those in the Graphviz man page (available online at --- , or if installed on your --- system @man graphviz@). Note that any command can be used on --- both directed and undirected graphs. -data GraphvizCommand = Dot -- ^ For hierachical graphs (ideal for - -- directed graphs). - | Neato -- ^ For symmetric layouts of graphs - -- (ideal for undirected graphs). - | TwoPi -- ^ For radial layout of graphs. - | Circo -- ^ For circular layout of graphs. - | Fdp -- ^ For symmetric layout of graphs. - | Osage -- ^ Filter for drawing clustered graphs, - -- requires Graphviz >= 2.28.0. - | Patchwork -- ^ Draw clustered graphs as treemaps, - -- requires Graphviz >= 2.28.0. - deriving (Eq, Ord, Show, Read) - showCmd :: GraphvizCommand -> String showCmd Dot = "dot" showCmd Neato = "neato" showCmd TwoPi = "twopi" showCmd Circo = "circo" showCmd Fdp = "fdp" +showCmd Sfdp = "sfdp" showCmd Osage = "osage" showCmd Patchwork = "patchwork" @@ -128,9 +115,11 @@ -- layout performed. | DotOutput -- ^ Reproduces the input along with -- layout information. - | XDot -- ^ As with 'DotOutput', but provides - -- even more information on how the - -- graph is drawn. + | XDot (Maybe Version) + -- ^ As with 'DotOutput', but provides even more + -- information on how the graph is drawn. The + -- optional 'Version' is the same as + -- specifying the @XDotVersion@ attribute. | Eps -- ^ Encapsulated PostScript. | Fig -- ^ FIG graphics language. | Gd -- ^ Internal GD library format. @@ -163,19 +152,21 @@ -- usually preferred. | Vrml -- ^ Virtual Reality Modeling Language -- format; requires nodes to have a - -- 'Z' attribute. + -- third dimension set via the @Pos@ + -- attribute (and with a @Dim@ value + -- of at least @3@). | WBmp -- ^ Wireless BitMap format; -- monochrome format usually used -- for mobile computing devices. | WebP -- ^ Google's WebP format; requires -- Graphviz >= 2.29.0. - deriving (Eq, Ord, Bounded, Enum, Show, Read) + deriving (Eq, Ord, Show, Read) instance GraphvizResult GraphvizOutput where outputCall Bmp = "bmp" outputCall Canon = "canon" outputCall DotOutput = "dot" - outputCall XDot = "xdot" + outputCall (XDot mv) = "xdot" ++ maybe "" showVersion mv outputCall Eps = "eps" outputCall Fig = "fig" outputCall Gd = "gd" @@ -205,9 +196,9 @@ -- | A default file extension for each 'GraphvizOutput'. defaultExtension :: GraphvizOutput -> String defaultExtension Bmp = "bmp" -defaultExtension Canon = "dot" -defaultExtension DotOutput = "dot" -defaultExtension XDot = "dot" +defaultExtension Canon = "gv" +defaultExtension DotOutput = "gv" +defaultExtension XDot{} = "gv" defaultExtension Eps = "eps" defaultExtension Fig = "fig" defaultExtension Gd = "gd" @@ -258,7 +249,7 @@ -> GraphvizOutput -> FilePath -> IO FilePath runGraphvizCommand cmd gr t fp - = mapException addExc $ graphvizWithHandle cmd gr t toFile + = handle (throwIO . addExc) $ graphvizWithHandle cmd gr t toFile where addFl = (++) ("Unable to create " ++ fp ++ "\n") toFile h = SB.hGetContents h >>= SB.writeFile fp >> return fp @@ -316,3 +307,17 @@ -- using the given canvas type. runGraphvizCanvas' :: (PrintDotRepr dg n) => dg n -> GraphvizCanvas -> IO () runGraphvizCanvas' d = runGraphvizCanvas (commandFor d) d + +-- ----------------------------------------------------------------------------- + +-- | Is the Graphviz suite of tools installed? This is determined by +-- whether @dot@ is available in the @PATH@. +isGraphvizInstalled :: IO Bool +isGraphvizInstalled = liftM isJust . findExecutable $ showCmd Dot + +-- | If Graphviz does not seem to be available, print the provided +-- error message and then exit fatally. +quitWithoutGraphviz :: String -> IO () +quitWithoutGraphviz err = do hasGraphviz <- isGraphvizInstalled + unless hasGraphviz + $ hPutStrLn stderr err >> exitWith (ExitFailure 1) diff --git a/Data/GraphViz/Commands/Available.hs b/Data/GraphViz/Commands/Available.hs new file mode 100644 --- /dev/null +++ b/Data/GraphViz/Commands/Available.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_HADDOCK hide #-} +{- | + Module : Data.GraphViz.Commands.Available + Description : Available command-line programs + Copyright : (c) Ivan Lazar Miljenovic + License : 3-Clause BSD-style + Maintainer : Ivan.Miljenovic@gmail.com + + These are the known programs that read in Dot graphs. + + -} +module Data.GraphViz.Commands.Available where + +import Data.GraphViz.Parsing +import Data.GraphViz.Printing + +-- ----------------------------------------------------------------------------- + +-- | The available Graphviz commands. The following directions are +-- based upon those in the Graphviz man page (available online at +-- , or if installed on your +-- system @man graphviz@). Note that any command can be used on +-- both directed and undirected graphs. +-- +-- When used with the 'Layout' attribute, it overrides any actual +-- command called on the dot graph. +data GraphvizCommand = Dot -- ^ For hierachical graphs (ideal for + -- directed graphs). + | Neato -- ^ For symmetric layouts of graphs + -- (ideal for undirected graphs). + | TwoPi -- ^ For radial layout of graphs. + | Circo -- ^ For circular layout of graphs. + | Fdp -- ^ Spring-model approach for + -- undirected graphs. + | Sfdp -- ^ As with Fdp, but ideal for large + -- graphs. + | Osage -- ^ Filter for drawing clustered graphs, + -- requires Graphviz >= 2.28.0. + | Patchwork -- ^ Draw clustered graphs as treemaps, + -- requires Graphviz >= 2.28.0. + deriving (Eq, Ord, Bounded, Enum, Show, Read) + +instance PrintDot GraphvizCommand where + unqtDot Dot = text "dot" + unqtDot Neato = text "neato" + unqtDot TwoPi = text "twopi" + unqtDot Circo = text "circo" + unqtDot Fdp = text "fdp" + unqtDot Sfdp = text "sfdp" + unqtDot Osage = text "osage" + unqtDot Patchwork = text "patchwork" + +instance ParseDot GraphvizCommand where + parseUnqt = stringValue [ ("dot", Dot) + , ("neato", Neato) + , ("twopi", TwoPi) + , ("circo", Circo) + , ("fdp", Fdp) + , ("sfdp", Sfdp) + , ("osage", Osage) + , ("patchwork", Patchwork) + ] diff --git a/Data/GraphViz/Commands/IO.hs b/Data/GraphViz/Commands/IO.hs --- a/Data/GraphViz/Commands/IO.hs +++ b/Data/GraphViz/Commands/IO.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + {- | Module : Data.GraphViz.Commands.IO Description : IO-related functions for graphviz. @@ -26,35 +28,39 @@ , runCommand ) where -import Data.GraphViz.State(initialState) -import Data.GraphViz.Types(PrintDotRepr, ParseDotRepr, printDotGraph, parseDotGraph) -import Data.GraphViz.Printing(toDot) import Data.GraphViz.Exception -import Text.PrettyPrint.Leijen.Text(displayT, renderCompact) +import Data.GraphViz.Printing (runDotCode, toDot) +import Data.GraphViz.Types (ParseDotRepr, PrintDotRepr, parseDotGraph, + printDotGraph) +import Text.PrettyPrint.Leijen.Text (displayT, renderOneLine) -import qualified Data.Text.Lazy.Encoding as T -import Data.Text.Encoding.Error(UnicodeException) -import Data.Text.Lazy(Text) -import qualified Data.ByteString as SB -import qualified Data.ByteString.Lazy as B -import Data.ByteString.Lazy(ByteString) -import Control.Monad(liftM) -import Control.Monad.Trans.State -import System.IO(Handle, IOMode(ReadMode,WriteMode) - , withFile, stdout, stdin, hPutChar - , hClose, hGetContents, hSetBinaryMode) -import System.Exit(ExitCode(ExitSuccess)) -import System.Process(runInteractiveProcess, waitForProcess) -import Control.Exception(IOException, evaluate) -import Control.Concurrent(MVar, forkIO, newEmptyMVar, putMVar, takeMVar) +import Control.Concurrent (MVar, forkIO, newEmptyMVar, putMVar, + takeMVar) +import Control.Exception (IOException, evaluate, finally) +import Control.Monad (liftM) +import qualified Data.ByteString as SB +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as B +import Data.Text.Encoding.Error (UnicodeException) +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy.Encoding as T +import System.Exit (ExitCode(ExitSuccess)) +import System.FilePath ((<.>)) +import System.IO (Handle, IOMode(ReadMode, WriteMode), + hClose, hGetContents, hPutChar, + stdin, stdout, withFile) +import System.IO.Temp (withSystemTempFile) +import System.Process (runInteractiveProcess, + waitForProcess) + -- ----------------------------------------------------------------------------- -- | Correctly render Graphviz output in a more machine-oriented form -- (i.e. more compact than the output of 'renderDot'). renderCompactDot :: (PrintDotRepr dg n) => dg n -> Text -renderCompactDot = displayT . renderCompact - . flip evalState initialState +renderCompactDot = displayT . renderOneLine + . runDotCode . toDot -- ----------------------------------------------------------------------------- @@ -95,8 +101,7 @@ hPutCompactDot :: (PrintDotRepr dg n) => Handle -> dg n -> IO () hPutCompactDot = toHandle renderCompactDot -toHandle :: (PrintDotRepr dg n) => (dg n -> Text) -> Handle -> dg n - -> IO () +toHandle :: (dg n -> Text) -> Handle -> dg n -> IO () toHandle f h dg = do B.hPutStr h . T.encodeUtf8 $ f dg hPutChar h '\n' @@ -133,6 +138,10 @@ -- -- If the command was unsuccessful, then a 'GraphvizException' is -- thrown. +-- +-- For performance reasons, a temporary file is used to store the +-- generated Dot code. As such, this is only suitable for local +-- commands. runCommand :: (PrintDotRepr dg n) => String -- ^ Command to run -> [String] -- ^ Command-line arguments @@ -140,17 +149,16 @@ -> dg n -> IO a runCommand cmd args hf dg - = mapException notRunnable - $ bracket - (runInteractiveProcess cmd args Nothing Nothing) + = handle (throwIO . notRunnable) $ + withSystemTempFile ("graphviz" <.> "gv") $ \dotFile dotHandle -> do + finally (hPutCompactDot dotHandle dg) (hClose dotHandle) + bracket + (runInteractiveProcess cmd (args ++ [dotFile]) Nothing Nothing) (\(inh,outh,errh,_) -> hClose inh >> hClose outh >> hClose errh) $ \(inp,outp,errp,prc) -> do - hSetBinaryMode inp True - hSetBinaryMode errp False - - -- Make sure we close the input or it will hang!!!!!!! - forkIO $ hPutCompactDot inp dg >> hClose inp + -- Not using it, so close it off directly. + hClose inp -- Need to make sure both the output and error handles are -- really fully consumed. @@ -181,7 +189,7 @@ ] -- Augmenting the hf function to let it work within the forkIO: - hf' = mapException fErr . hf + hf' = handle (throwIO . fErr) . hf fErr :: IOException -> GraphvizException fErr e = GVProgramExc $ "Error re-directing the output from " ++ cmd ++ ": " ++ show e diff --git a/Data/GraphViz/Exception.hs b/Data/GraphViz/Exception.hs --- a/Data/GraphViz/Exception.hs +++ b/Data/GraphViz/Exception.hs @@ -11,6 +11,7 @@ -- * Re-exported for convenience. , mapException , throw + , throwIO , handle , bracket ) where diff --git a/Data/GraphViz/Internal/State.hs b/Data/GraphViz/Internal/State.hs new file mode 100644 --- /dev/null +++ b/Data/GraphViz/Internal/State.hs @@ -0,0 +1,134 @@ +{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE FlexibleInstances #-} + +{- | + Module : Data.GraphViz.Internal.State + Description : Printing and parsing state. + Copyright : (c) Ivan Lazar Miljenovic + License : 3-Clause BSD-style + Maintainer : Ivan.Miljenovic@gmail.com + + When printing and parsing Dot code, some items depend on values + that are set earlier. +-} +module Data.GraphViz.Internal.State + ( GraphvizStateM(..) + , GraphvizState(..) + , AttributeType(..) + , setAttributeType + , getAttributeType + , initialState + , setDirectedness + , getDirectedness + , setLayerSep + , getLayerSep + , setLayerListSep + , getLayerListSep + , setColorScheme + , getColorScheme + ) where + +import Data.GraphViz.Attributes.ColorScheme + +import Text.ParserCombinators.Poly.StateText (Parser, stQuery, stUpdate) + +-- ----------------------------------------------------------------------------- + +class (Monad m) => GraphvizStateM m where + modifyGS :: (GraphvizState -> GraphvizState) -> m () + + getsGS :: (GraphvizState -> a) -> m a + +instance GraphvizStateM (Parser GraphvizState) where + modifyGS = stUpdate + + getsGS = stQuery + +data AttributeType = GraphAttribute + | SubGraphAttribute + | ClusterAttribute + | NodeAttribute + | EdgeAttribute + deriving (Eq, Ord, Show, Read) + +-- | Several aspects of Dot code are either global or mutable state. +data GraphvizState = GS { parseStrictly :: !Bool + -- ^ If 'False', allow fallbacks for + -- attributes that don't match known + -- specification when parsing. + , directedEdges :: !Bool + , layerSep :: [Char] + , layerListSep :: [Char] + , attributeType :: !AttributeType + , graphColor :: !ColorScheme + , clusterColor :: !ColorScheme + , nodeColor :: !ColorScheme + , edgeColor :: !ColorScheme + } + deriving (Eq, Ord, Show, Read) + +initialState :: GraphvizState +initialState = GS { parseStrictly = True + , directedEdges = True + , layerSep = defLayerSep + , layerListSep = defLayerListSep + , attributeType = GraphAttribute + , graphColor = X11 + , clusterColor = X11 + , nodeColor = X11 + , edgeColor = X11 + } + +setDirectedness :: (GraphvizStateM m) => Bool -> m () +setDirectedness d = modifyGS (\ gs -> gs { directedEdges = d } ) + +getDirectedness :: (GraphvizStateM m) => m Bool +getDirectedness = getsGS directedEdges + +setAttributeType :: (GraphvizStateM m) => AttributeType -> m () +setAttributeType tp = modifyGS $ \ gs -> gs { attributeType = tp } + +getAttributeType :: (GraphvizStateM m) => m AttributeType +getAttributeType = getsGS attributeType + +setLayerSep :: (GraphvizStateM m) => [Char] -> m () +setLayerSep sep = modifyGS (\ gs -> gs { layerSep = sep } ) + +getLayerSep :: (GraphvizStateM m) => m [Char] +getLayerSep = getsGS layerSep + +setLayerListSep :: (GraphvizStateM m) => [Char] -> m () +setLayerListSep sep = modifyGS (\ gs -> gs { layerListSep = sep } ) + +getLayerListSep :: (GraphvizStateM m) => m [Char] +getLayerListSep = getsGS layerListSep + +setColorScheme :: (GraphvizStateM m) => ColorScheme -> m () +setColorScheme cs = do tp <- getsGS attributeType + modifyGS $ \gs -> case tp of + GraphAttribute -> gs { graphColor = cs } + -- subgraphs don't have specified scheme + SubGraphAttribute -> gs { graphColor = cs } + ClusterAttribute -> gs { clusterColor = cs } + NodeAttribute -> gs { nodeColor = cs } + EdgeAttribute -> gs { edgeColor = cs } + +getColorScheme :: (GraphvizStateM m) => m ColorScheme +getColorScheme = do tp <- getsGS attributeType + getsGS $ case tp of + GraphAttribute -> graphColor + -- subgraphs don't have specified scheme + SubGraphAttribute -> graphColor + ClusterAttribute -> clusterColor + NodeAttribute -> nodeColor + EdgeAttribute -> edgeColor + +-- | The default separators for +-- 'Data.GraphViz.Attributes.Complete.LayerSep'. +defLayerSep :: [Char] +defLayerSep = [' ', ':', '\t'] + +-- | The default separators for +-- 'Data.GraphViz.Attributes.Complete.LayerListSep'. +defLayerListSep :: [Char] +defLayerListSep = [','] diff --git a/Data/GraphViz/Internal/Util.hs b/Data/GraphViz/Internal/Util.hs new file mode 100644 --- /dev/null +++ b/Data/GraphViz/Internal/Util.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE CPP, OverloadedStrings, PatternGuards #-} +{-# OPTIONS_HADDOCK hide #-} + +{- | + Module : Data.GraphViz.Internal.Util + Description : Internal utility functions + Copyright : (c) Ivan Lazar Miljenovic + License : 3-Clause BSD-style + Maintainer : Ivan.Miljenovic@gmail.com + + This module defines internal utility functions. +-} +module Data.GraphViz.Internal.Util where + +import Data.Char (isAsciiLower, isAsciiUpper, isDigit, ord) + +import Control.Monad (liftM2) +import Data.Function (on) +import Data.List (groupBy, sortBy) +import Data.Maybe (isJust) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as T +import qualified Data.Text.Lazy.Read as T + +#if MIN_VERSION_base(4,8,0) +import Data.Version (Version, makeVersion) +#else +import Data.Version (Version(..)) +#endif + +-- ----------------------------------------------------------------------------- + +isIDString :: Text -> Bool +isIDString = maybe False (\(f,os) -> frstIDString f && T.all restIDString os) + . T.uncons + +-- | First character of a non-quoted 'String' must match this. +frstIDString :: Char -> Bool +frstIDString c = any ($c) [ isAsciiUpper + , isAsciiLower + , (==) '_' + , (\ x -> ord x >= 128) + ] + +-- | The rest of a non-quoted 'String' must match this. +restIDString :: Char -> Bool +restIDString c = frstIDString c || isDigit c + +-- | Determine if this String represents a number. Boolean parameter +-- determines if exponents are considered part of numbers for this. +isNumString :: Bool -> Text -> Bool +isNumString _ "" = False +isNumString _ "-" = False +isNumString allowE str = case T.uncons $ T.toLower str of + Just ('-',str') -> go str' + _ -> go str + where + -- Can't use Data.Text.Lazy.Read.double as it doesn't cover all + -- possible cases + go s = uncurry go' $ T.span isDigit s + go' ds nds + | T.null nds = True + | T.null ds && nds == "." = False + | T.null ds + , Just ('.',nds') <- T.uncons nds + , Just (d,nds'') <- T.uncons nds' = isDigit d && checkEs' nds'' + | Just ('.',nds') <- T.uncons nds = checkEs $ T.dropWhile isDigit nds' + | T.null ds = False + | otherwise = checkEs nds + checkEs' s = case T.break ('e' ==) s of + ("", _) -> False + (ds,es) -> T.all isDigit ds && checkEs es + checkEs str' = case T.uncons str' of + Nothing -> True + Just ('e',ds) -> allowE && isIntString ds + _ -> False + +{- +-- | This assumes that 'isNumString' is 'True'. +toDouble :: Text -> Double +toDouble str = case T.uncons $ T.toLower str of + Just ('-', str') -> toD $ '-' `T.cons` adj str' + _ -> toD $ adj str + where + adj s = T.cons '0' + $ case T.span ('.' ==) s of + (ds, ".") | not $ T.null ds -> s `T.snoc` '0' + (ds, ds') | Just ('.',es) <- T.uncons ds' + , Just ('e',es') <- T.uncons es + -> ds `T.snoc` '.' `T.snoc` '0' + `T.snoc` 'e' `T.snoc` '0' `T.append` es' + _ -> s + toD = either (const $ error "Not a Double") fst . T.signed T.double +-} +-- | This assumes that 'isNumString' is 'True'. +toDouble :: Text -> Double +toDouble str = case T.uncons $ T.toLower str of + Just ('-', str') -> toD $ '-' `T.cons` adj str' + _ -> toD $ adj str + where + adj s = T.cons '0' + $ case T.span ('.' ==) s of + (ds, ".") | not $ T.null ds -> s `T.snoc` '0' + (ds, ds') | Just ('.',es) <- T.uncons ds' + , Just ('e',_) <- T.uncons es + -> ds `T.snoc` '.' `T.snoc` '0' `T.append` es + _ -> s + toD = read . T.unpack + +isIntString :: Text -> Bool +isIntString = isJust . stringToInt + +-- | Determine if this String represents an integer. +stringToInt :: Text -> Maybe Int +stringToInt str = case T.signed T.decimal str of + Right (n, "") -> Just n + _ -> Nothing + +-- | Graphviz requires double quotes to be explicitly escaped. +escapeQuotes :: String -> String +escapeQuotes [] = [] +escapeQuotes ('"':str) = '\\':'"': escapeQuotes str +escapeQuotes (c:str) = c : escapeQuotes str + +-- | Remove explicit escaping of double quotes. +descapeQuotes :: String -> String +descapeQuotes [] = [] +descapeQuotes ('\\':'"':str) = '"' : descapeQuotes str +descapeQuotes (c:str) = c : descapeQuotes str + +isKeyword :: Text -> Bool +isKeyword = (`Set.member` keywords) . T.toLower + +-- | The following are Dot keywords and are not valid as labels, etc. unquoted. +keywords :: Set Text +keywords = Set.fromList [ "node" + , "edge" + , "graph" + , "digraph" + , "subgraph" + , "strict" + ] + +createVersion :: [Int] -> Version +#if MIN_VERSION_base(4,8,0) +createVersion = makeVersion +#else +createVersion bs = Version { versionBranch = bs, versionTags = []} +#endif + +-- ----------------------------------------------------------------------------- + +uniq :: (Ord a) => [a] -> [a] +uniq = uniqBy id + +uniqBy :: (Ord b) => (a -> b) -> [a] -> [a] +uniqBy f = map head . groupSortBy f + +groupSortBy :: (Ord b) => (a -> b) -> [a] -> [[a]] +groupSortBy f = groupBy ((==) `on` f) . sortBy (compare `on` f) + +groupSortCollectBy :: (Ord b) => (a -> b) -> (a -> c) -> [a] -> [(b,[c])] +groupSortCollectBy f g = map (liftM2 (,) (f . head) (map g)) . groupSortBy f + +-- | Fold over 'Bool's; first param is for 'False', second for 'True'. +bool :: a -> a -> Bool -> a +bool f t b = if b + then t + else f + +isSingle :: [a] -> Bool +isSingle [_] = True +isSingle _ = False diff --git a/Data/GraphViz/Parsing.hs b/Data/GraphViz/Parsing.hs --- a/Data/GraphViz/Parsing.hs +++ b/Data/GraphViz/Parsing.hs @@ -30,9 +30,12 @@ , parseIt' , runParser , runParser' + , runParserWith + , parseLiberally , checkValidParse + , checkValidParseWithRest -- * Convenience parsing combinators. - , bracket + , ignoreSep , onlyBool , quotelessString , stringBlock @@ -46,6 +49,7 @@ , strings , character , parseStrictFloat + , parseSignedFloat , noneOf , whitespace1 , whitespace @@ -62,12 +66,6 @@ , tryParseList , tryParseList' , consumeLine - , parseField - , parseFields - , parseFieldBool - , parseFieldsBool - , parseFieldDef - , parseFieldsDef , commaSep , commaSepUnqt , commaSep' @@ -80,31 +78,33 @@ , parseColorScheme ) where -import Data.GraphViz.Util -import Data.GraphViz.State +import Data.GraphViz.Exception (GraphvizException(NotDotCode), throw) +import Data.GraphViz.Internal.State +import Data.GraphViz.Internal.Util + -- To avoid orphan instances and cyclic imports import Data.GraphViz.Attributes.ColorScheme -import Data.GraphViz.Exception(GraphvizException(NotDotCode), throw) -import Text.ParserCombinators.Poly.StateText hiding (bracket, empty, indent, runParser) +import Text.ParserCombinators.Poly.StateText hiding (empty, indent, + runParser) import qualified Text.ParserCombinators.Poly.StateText as P -import Data.Char( isDigit - , isSpace - , isLower - , toLower - , toUpper - ) -import Data.List(groupBy, sortBy) -import Data.Function(on) -import Data.Maybe(fromMaybe, isNothing, listToMaybe) -import Data.Ratio((%)) -import qualified Data.Set as Set -import qualified Data.Text.Lazy as T + +import Control.Arrow (first, second) +import Control.Monad (when) +import Data.Char (isDigit, isLower, isSpace, toLower, + toUpper) +import Data.Function (on) +import Data.List (groupBy, sortBy) +import Data.Maybe (fromMaybe, isJust, isNothing, listToMaybe, + maybeToList) +import Data.Ratio ((%)) +import qualified Data.Set as Set +import qualified Data.Text as ST +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as T import qualified Data.Text.Lazy.Read as T -import Data.Text.Lazy(Text) -import Data.Word(Word8, Word16) -import Control.Arrow(first, second) -import Control.Monad(liftM, liftM2, when) +import Data.Version (Version(..)) +import Data.Word (Word16, Word8) -- ----------------------------------------------------------------------------- -- Based off code from Text.Parse in the polyparse library @@ -112,17 +112,24 @@ -- | A @ReadS@-like type alias. type Parse a = Parser GraphvizState a -runParser :: Parse a -> Text -> (Either String a, Text) -runParser p t = let (r,_,t') = P.runParser p initialState t - in (r,t') +runParser :: Parse a -> Text -> (Either String a, Text) +runParser = runParserWith id +parseLiberally :: GraphvizState -> GraphvizState +parseLiberally gs = gs { parseStrictly = False } + +runParserWith :: (GraphvizState -> GraphvizState) -> Parse a -> Text + -> (Either String a, Text) +runParserWith f p t = let (r,_,t') = P.runParser p (f initialState) t + in (r,t') + -- | A variant of 'runParser' where it is assumed that the provided -- parsing function consumes all of the 'Text' input (with the -- exception of whitespace at the end). runParser' :: Parse a -> Text -> a -runParser' p = checkValidParse . fst . runParser p' +runParser' p = checkValidParseWithRest . runParser p' where - p' = p `discard` (whitespace >> eof) + p' = p `discard` (whitespace *> eof) class ParseDot a where parseUnqt :: Parse a @@ -136,14 +143,14 @@ `onFail` whitespace1 ) - (whitespace >> character ']') + (whitespace *> character ']') parseUnqt parseList :: Parse [a] parseList = quotedParse parseUnqtList -- | Parse the required value, returning also the rest of the input --- 'String' that hasn't been parsed (for debugging purposes). +-- 'Text' that hasn't been parsed (for debugging purposes). parseIt :: (ParseDot a) => Text -> (a, Text) parseIt = first checkValidParse . runParser parse @@ -153,13 +160,22 @@ checkValidParse (Left err) = throw (NotDotCode err) checkValidParse (Right a) = a +-- | If unable to parse /Dot/ code properly, 'throw' a +-- 'GraphvizException', with the error containing the remaining +-- unparsed code.. +checkValidParseWithRest :: (Either String a, Text) -> a +checkValidParseWithRest (Left err, rst) = throw (NotDotCode err') + where + err' = err ++ "\n\nRemaining input:\n\t" ++ show rst +checkValidParseWithRest (Right a,_) = a + -- | Parse the required value with the assumption that it will parse --- all of the input 'String'. +-- all of the input 'Text'. parseIt' :: (ParseDot a) => Text -> a parseIt' = runParser' parse instance ParseDot Int where - parseUnqt = parseInt' + parseUnqt = parseSignedInt instance ParseDot Integer where parseUnqt = parseSigned parseInt @@ -171,18 +187,21 @@ parseUnqt = parseInt instance ParseDot Double where - parseUnqt = parseFloat' + parseUnqt = parseSignedFloat True + parse = quotedParse parseUnqt + <|> parseSignedFloat False + parseUnqtList = sepBy1 parseUnqt (character ':') parseList = quotedParse parseUnqtList `onFail` - liftM return parse + fmap (:[]) parse instance ParseDot Bool where parseUnqt = onlyBool `onFail` - liftM (zero /=) parseInt' + fmap (zero /=) parseSignedInt where zero :: Int zero = 0 @@ -201,10 +220,24 @@ `onFail` quotedParse parseUnqt - parseUnqtList = liftM T.unpack parseUnqt + parseUnqtList = T.unpack <$> parseUnqt - parseList = liftM T.unpack parse + parseList = T.unpack <$> parse +-- | Ignores 'versionTags' and assumes 'not . null . versionBranch' +-- (usually you want 'length . versionBranch == 2') and that all +-- such values are non-negative. +instance ParseDot Version where + parseUnqt = createVersion <$> sepBy1 (parseIntCheck False) (character '.') + + parse = quotedParse parseUnqt + <|> + (createVersion .) . (. maybeToList) . (:) + <$> (parseIntCheck False) <*> optional (character '.' *> parseInt) + -- Leave the last one to check for possible decimals + -- afterwards as there should be at most two version + -- numbers here. + instance ParseDot Text where -- Too many problems with using this within other parsers where -- using numString or stringBlock will cause a parse failure. As @@ -217,97 +250,100 @@ -- above. quotedParse quotedString +instance ParseDot ST.Text where + parseUnqt = T.toStrict <$> parseUnqt + + parse = T.toStrict <$> parse + instance (ParseDot a) => ParseDot [a] where parseUnqt = parseUnqtList parse = parseList --- | Parse a 'String' that doesn't need to be quoted. +-- | Parse a 'Text' that doesn't need to be quoted. quotelessString :: Parse Text -quotelessString = numString `onFail` stringBlock +quotelessString = numString False `onFail` stringBlock -numString :: Parse Text -numString = liftM tShow parseStrictFloat - `onFail` - liftM tShow parseInt' +numString :: Bool -> Parse Text +numString q = fmap tShow (parseStrictFloat q) + `onFail` + fmap tShow parseSignedInt where tShow :: (Show a) => a -> Text tShow = T.pack . show stringBlock :: Parse Text -stringBlock = do frst <- satisfy frstIDString - rest <- manySatisfy restIDString - return $ frst `T.cons` rest +stringBlock = liftA2 T.cons (satisfy frstIDString) (manySatisfy restIDString) -- | Used when quotes are explicitly required; quotedString :: Parse Text quotedString = parseEscaped True [] [] parseSigned :: (Num a) => Parse a -> Parse a -parseSigned p = (character '-' >> liftM negate p) +parseSigned p = (character '-' *> fmap negate p) `onFail` p parseInt :: (Integral a) => Parse a -parseInt = do cs <- many1Satisfy isDigit - case T.decimal cs of - Right (n,"") -> return n - Right (_,txt) -> fail $ "Trailing digits not parsed as Integral: " ++ T.unpack txt - Left err -> fail $ "Could not read Integral: " ++ err - `adjustErr` ("Expected one or more digits\n\t"++) +parseInt = parseIntCheck True -parseInt' :: Parse Int -parseInt' = parseSigned parseInt +-- | Flag indicates whether to check whether the number is actually a +-- floating-point value. +parseIntCheck :: (Integral a) => Bool -> Parse a +parseIntCheck ch = do cs <- many1Satisfy isDigit + `adjustErr` ("Expected one or more digits\n\t"++) + case T.decimal cs of + Right (n,"") -> bool return checkInt ch n + -- This case should never actually happen... + Right (_,txt) -> fail $ "Trailing digits not parsed as Integral: " ++ T.unpack txt + Left err -> fail $ "Could not read Integral: " ++ err + where + checkInt n = do c <- optional $ oneOf [ character '.', character 'e' ] + if isJust c + then fail "This number is actually Floating, not Integral!" + else return n +parseSignedInt :: Parse Int +parseSignedInt = parseSigned parseInt + -- | Parse a floating point number that actually contains decimals. -parseStrictFloat :: Parse Double -parseStrictFloat = parseSigned parseFloat +-- Bool flag indicates whether values that need to be quoted are +-- parsed. +parseStrictFloat :: Bool -> Parse Double +parseStrictFloat = parseSigned . parseFloat -parseFloat :: (RealFrac a) => Parse a -parseFloat = do ds <- manySatisfy isDigit - frac <- optional - $ do character '.' - manySatisfy isDigit - when (T.null ds && noDec frac) - (fail "No actual digits in floating point number!") - expn <- optional parseExp - when (isNothing frac && isNothing expn) - (fail "This is an integer, not a floating point number!") - let frac' = fromMaybe "" frac - expn' = fromMaybe 0 expn - ( return . fromRational . (* (10^^(expn' - fromIntegral (T.length frac')))) - . (%1) . runParser' parseInt) (ds `T.append` frac') - `onFail` - fail "Expected a floating point number" +-- | Bool flag indicates whether to allow parsing exponentiated term, +-- as this is only allowed when quoted. +parseFloat :: (RealFrac a) => Bool -> Parse a +parseFloat q = do ds <- manySatisfy isDigit + frac <- optional $ character '.' *> manySatisfy isDigit + when (T.null ds && noDec frac) + (fail "No actual digits in floating point number!") + expn <- bool (pure Nothing) (optional parseExp) q + when (isNothing frac && isNothing expn) + (fail "This is an integer, not a floating point number!") + let frac' = fromMaybe "" frac + expn' = fromMaybe 0 expn + ( return . fromRational . (* (10^^(expn' - fromIntegral (T.length frac')))) + . (%1) . runParser' parseInt) (ds `T.append` frac') + `onFail` + fail "Expected a floating point number" where - parseExp = do character 'e' - ((character '+' >> parseInt) + parseExp = character 'e' + *> ((character '+' *> parseInt) `onFail` - parseInt') + parseSignedInt) noDec = maybe True T.null -parseFloat' :: Parse Double -parseFloat' = parseSigned ( parseFloat - `onFail` - liftM fI parseInt - ) +-- Bool indicates whether we can parse values that need quotes. +parseSignedFloat :: Bool -> Parse Double +parseSignedFloat q = parseSigned ( parseFloat q <|> fmap fI parseInt ) where fI :: Integer -> Double fI = fromIntegral -- ----------------------------------------------------------------------------- --- | Parse a bracketed item, discarding the brackets. --- --- The definition of @bracket@ defined in Polyparse uses --- 'adjustErrBad' and thus doesn't allow backtracking and trying the --- next possible parser. This is a version of @bracket@ that does. -bracket :: Parse bra -> Parse ket -> Parse a -> Parse a -bracket open close pa = do open `adjustErr` ("Missing opening bracket:\n\t"++) - pa `discard` - (close - `adjustErr` ("Missing closing bracket:\n\t"++)) - parseAndSpace :: Parse a -> Parse a parseAndSpace p = p `discard` whitespace @@ -318,7 +354,7 @@ stringRep v = stringReps v . return stringReps :: a -> [String] -> Parse a -stringReps v ss = oneOf (map string ss) >> return v +stringReps v ss = oneOf (map string ss) *> return v stringParse :: [(String, Parse a)] -> Parse a stringParse = toPM . sortBy (flip compare `on` fst) @@ -326,8 +362,8 @@ toPM = oneOf . map mkPM . groupBy ((==) `on` (listToMaybe . fst)) mkPM [("",p)] = p - mkPM [(str,p)] = string str >> p - mkPM kv = character (head . fst $ head kv) >> toPM (map (first tail) kv) + mkPM [(str,p)] = string str *> p + mkPM kv = character (head . fst $ head kv) *> toPM (map (first tail) kv) stringValue :: [(String, a)] -> Parse a stringValue = stringParse . map (second return) @@ -335,6 +371,8 @@ strings :: [String] -> Parse () strings = oneOf . map string +-- | Assumes that any letter is ASCII for case-insensitive +-- comparisons. character :: Char -> Parse Char character c = satisfy parseC `adjustErr` @@ -350,13 +388,13 @@ -- | Parses at least one whitespace character. whitespace1 :: Parse () -whitespace1 = many1Satisfy isSpace >> return () +whitespace1 = many1Satisfy isSpace *> return () -- | Parses zero or more whitespace characters. whitespace :: Parse () -whitespace = manySatisfy isSpace >> return () +whitespace = manySatisfy isSpace *> return () --- | Parse and discard optional whitespace. +-- | Parse and discard optional surrounding whitespace. wrapWhitespace :: Parse a -> Parse a wrapWhitespace = bracket whitespace whitespace @@ -371,8 +409,8 @@ quotedParse :: Parse a -> Parse a quotedParse = bracket parseQuote parseQuote -parseQuote :: Parse Char -parseQuote = character quoteChar +parseQuote :: Parse () +parseQuote = character quoteChar *> return () orQuote :: Parse Char -> Parse Char orQuote p = stringRep quoteChar "\\\"" @@ -382,13 +420,12 @@ quoteChar :: Char quoteChar = '"' --- | Parse a 'String' where the provided 'Char's (as well as @\"@ and +-- | Parse a 'Text' where the provided 'Char's (as well as @\"@ and -- @\\@) are escaped and the second list of 'Char's are those that -- are not permitted. Note: does not parse surrounding quotes. The --- 'Bool' value indicates whether empty 'String's are allowed or --- not. +-- 'Bool' value indicates whether empty 'Text's are allowed or not. parseEscaped :: Bool -> [Char] -> [Char] -> Parse Text -parseEscaped empt cs bnd = liftM T.pack . lots $ qPrs `onFail` oth +parseEscaped empt cs bnd = fmap T.pack . lots $ qPrs `onFail` oth where lots = if empt then many else many1 cs' = quoteChar : slash : cs @@ -396,9 +433,10 @@ bndSet = Set.fromList bnd `Set.union` csSet slash = '\\' -- Have to allow standard slashes - qPrs = do character slash - mE <- optional $ oneOf (map character cs') - return $ fromMaybe slash mE + qPrs = fromMaybe slash + <$> (character slash + *> optional (oneOf $ map character cs') + ) oth = satisfy (`Set.notMember` bndSet) -- | Parses a newline. @@ -409,7 +447,7 @@ -- non-whitespace is reached. The whitespace on that line is -- not consumed. newline' :: Parse () -newline' = many (whitespace >> newline) >> return () +newline' = many (whitespace *> newline) *> return () -- | Parses and returns all characters up till the end of the line, -- but does not touch the newline characters. @@ -417,34 +455,11 @@ consumeLine = manySatisfy (`notElem` ['\n','\r']) parseEq :: Parse () -parseEq = wrapWhitespace (character '=') >> return () - -parseField :: (ParseDot a) => (a -> b) -> String -> [(String, Parse b)] -parseField c fld = [(fld, parseEq >> liftM c parse)] - -parseFields :: (ParseDot a) => (a -> b) -> [String] -> [(String, Parse b)] -parseFields c = concatMap (parseField c) - -parseFieldBool :: (Bool -> b) -> String -> [(String, Parse b)] -parseFieldBool = flip parseFieldDef True - -parseFieldsBool :: (Bool -> b) -> [String] -> [(String, Parse b)] -parseFieldsBool c = concatMap (parseFieldBool c) - --- | For 'Bool'-like data structures where the presence of the field --- name without a value implies a default value. -parseFieldDef :: (ParseDot a) => (a -> b) -> a -> String -> [(String, Parse b)] -parseFieldDef c d fld = [(fld, p)] - where - p = (parseEq >> liftM c parse) - `onFail` - do nxt <- optional $ satisfy restIDString - bool (fail "Not actually the field you were after") - (return $ c d) - (isNothing nxt) +parseEq = wrapWhitespace (character '=') *> return () -parseFieldsDef :: (ParseDot a) => (a -> b) -> a -> [String] -> [(String, Parse b)] -parseFieldsDef c d = concatMap (parseFieldDef c d) +-- | The opposite of 'bracket'. +ignoreSep :: (a -> b -> c) -> Parse a -> Parse sep -> Parse b -> Parse c +ignoreSep f pa sep pb = f <$> pa <* sep <*> pb commaSep :: (ParseDot a, ParseDot b) => Parse (a, b) commaSep = commaSep' parse parse @@ -453,19 +468,19 @@ commaSepUnqt = commaSep' parseUnqt parseUnqt commaSep' :: Parse a -> Parse b -> Parse (a,b) -commaSep' pa pb = do a <- pa - wrapWhitespace parseComma - b <- pb - return (a,b) +commaSep' pa pb = ignoreSep (,) pa (wrapWhitespace parseComma) pb parseComma :: Parse () -parseComma = character ',' >> return () +parseComma = character ',' *> return () +-- | Try to parse a list of the specified type; returns an empty list +-- if parsing fails. tryParseList :: (ParseDot a) => Parse [a] tryParseList = tryParseList' parse +-- | Return an empty list if parsing a list fails. tryParseList' :: Parse [a] -> Parse [a] -tryParseList' = liftM (fromMaybe []) . optional +tryParseList' = fmap (fromMaybe []) . optional parseAngled :: Parse a -> Parse a parseAngled = bracket (character '<') (character '>') @@ -482,13 +497,13 @@ parseColorScheme :: Bool -> Parse ColorScheme parseColorScheme scs = do cs <- oneOf [ stringRep X11 "X11" , stringRep SVG "svg" - , liftM Brewer parseUnqt + , Brewer <$> parseUnqt ] when scs $ setColorScheme cs return cs instance ParseDot BrewerScheme where - parseUnqt = liftM2 BScheme parseUnqt parseUnqt + parseUnqt = liftA2 BScheme parseUnqt parseUnqt instance ParseDot BrewerName where -- The order is different from above to make sure longer names are diff --git a/Data/GraphViz/PreProcessing.hs b/Data/GraphViz/PreProcessing.hs --- a/Data/GraphViz/PreProcessing.hs +++ b/Data/GraphViz/PreProcessing.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + {- | Module : Data.GraphViz.PreProcessing Description : Pre-process imported Dot code. @@ -9,28 +11,30 @@ parseable by this library. This module defines the 'preProcess' function to remove these components, which include: - * Comments (both @\/* ... *\/@ style and @\/\/ ... @ style); + * Comments (both @\/\* ... *\/@ style and @\/\/ ... @ style); * Pre-processor lines (lines starting with a @#@); * Split lines (by inserting a @\\@ the rest of that \"line\" is continued on the next line). - * 'Text's concatenated together using @\"...\" + \"...\"@; these - are concatenated into one big 'Text'. + * Strings concatenated together using @\"...\" + \"...\"@; these + are concatenated into one big string. -} module Data.GraphViz.PreProcessing(preProcess) where +import Data.GraphViz.Exception (GraphvizException (NotDotCode), throw) import Data.GraphViz.Parsing -import Data.GraphViz.Exception(GraphvizException(NotDotCode), throw) -import qualified Data.Text.Lazy as T -import Data.Text.Lazy(Text) +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as T +import Data.Text.Lazy.Builder (Builder) import qualified Data.Text.Lazy.Builder as B -import Data.Text.Lazy.Builder(Builder) -import Data.Monoid(Monoid(..), mconcat) -import Control.Monad(liftM) +#if !(MIN_VERSION_base(4,8,0)) +import Data.Monoid (Monoid (..), mconcat) +#endif + -- ----------------------------------------------------------------------------- -- Filtering out unwanted Dot items such as comments @@ -46,7 +50,7 @@ -- lines only over a single line. Should parse the /entire/ input -- 'Text'. parseOutUnwanted :: Parse Builder -parseOutUnwanted = liftM mconcat (many getNext) +parseOutUnwanted = mconcat <$> many getNext where getNext = parseOK `onFail` @@ -56,10 +60,11 @@ `onFail` parseUnwanted `onFail` - liftM B.singleton next - parseOK = liftM B.fromLazyText - $ many1Satisfy (`notElem` ['\n', '\r', '\\', '/', '"', '<']) + fmap B.singleton next + parseOK = B.fromLazyText + <$> many1Satisfy (`notElem` ['\n', '\r', '\\', '/', '"', '<']) + -- | Parses an unwanted part of the Dot code (comments and -- pre-processor lines; also un-splits lines). parseUnwanted :: (Monoid m) => Parse m @@ -74,65 +79,58 @@ -- previous line, but will leave the one from the pre-processor line -- there (so in the end it just removes the line). parsePreProcessor :: (Monoid m) => Parse m -parsePreProcessor = do newline - character '#' - consumeLine - return mempty +parsePreProcessor = newline *> character '#' *> consumeLine *> pure mempty -- | Parse @//@-style comments. parseLineComment :: (Monoid m) => Parse m -parseLineComment = do string "//" - -- Note: do /not/ consume the newlines, as they're - -- needed in case the next line is a pre-processor - -- line. - consumeLine - return mempty +parseLineComment = string "//" + -- Note: do /not/ consume the newlines, as they're + -- needed in case the next line is a pre-processor + -- line. + *> consumeLine + *> pure mempty -- | Parse @/* ... */@-style comments. parseMultiLineComment :: (Monoid m) => Parse m -parseMultiLineComment = bracket start end (many inner) - >> return mempty +parseMultiLineComment = bracket start end (many inner) *> pure mempty where start = string "/*" end = string "*/" - inner = (many1Satisfy ('*' /=) >> return ()) + inner = (many1Satisfy ('*' /=) *> pure ()) `onFail` - do character '*' - satisfy ('/' /=) - inner + (character '*' *> satisfy ('/' /=) *> inner) parseConcatStrings :: Parse Builder -parseConcatStrings = liftM (wrapQuotes . mconcat) - $ sepBy1 parseString parseConcat +parseConcatStrings = wrapQuotes . mconcat <$> sepBy1 parseString parseConcat where qParse = bracket (character '"') (commit $ character '"') - parseString = qParse (liftM mconcat $ many parseInner) - parseInner = (string "\\\"" >> return (B.fromLazyText $ T.pack "\\\"")) + parseString = qParse (mconcat <$> many parseInner) + parseInner = (string "\\\"" *> pure (B.fromLazyText $ T.pack "\\\"")) `onFail` -- Need to parse an explicit `\', in case it ends the -- string (and thus the next step would get parsed by the -- previous option). - (string "\\\\" >> return (B.fromLazyText $ T.pack "\\\\")) + (string "\\\\" *> pure (B.fromLazyText $ T.pack "\\\\")) `onFail` parseSplitLine -- in case there's a split mid-quote `onFail` - liftM B.singleton (satisfy (quoteChar /=)) - parseConcat = parseSep >> character '+' >> parseSep + fmap B.singleton (satisfy (quoteChar /=)) + parseConcat = parseSep *> character '+' *> parseSep parseSep = many $ whitespace1 `onFail` parseUnwanted wrapQuotes str = qc `mappend` str `mappend` qc qc = B.singleton '"' -- | Lines can be split with a @\\@ at the end of the line. parseSplitLine :: (Monoid m) => Parse m -parseSplitLine = character '\\' >> newline >> return mempty +parseSplitLine = character '\\' *> newline *> pure mempty parseHTML :: Parse Builder -parseHTML = liftM (addAngled . mconcat) +parseHTML = fmap (addAngled . mconcat) . parseAngled $ many inner where inner = parseHTML `onFail` - (liftM B.fromLazyText $ many1Satisfy (\c -> c /= open && c /= close)) + (B.fromLazyText <$> many1Satisfy (\c -> c /= open && c /= close)) addAngled str = B.singleton open `mappend` str `mappend` B.singleton close open = '<' close = '>' diff --git a/Data/GraphViz/Printing.hs b/Data/GraphViz/Printing.hs --- a/Data/GraphViz/Printing.hs +++ b/Data/GraphViz/Printing.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE CPP, FlexibleInstances, GeneralizedNewtypeDeriving, + OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} {- | Module : Data.GraphViz.Printing @@ -47,7 +49,9 @@ module Data.GraphViz.Printing ( module Text.PrettyPrint.Leijen.Text.Monadic , DotCode - , renderDot -- Exported for Data.GraphViz.Types.printSGID + , DotCodeM + , runDotCode + , renderDot -- Exported for Data.GraphViz.Types.Internal.Common.printSGID , PrintDot(..) , unqtText , dotText @@ -63,44 +67,87 @@ , printColorScheme ) where -import Data.GraphViz.Util -import Data.GraphViz.State +import Data.GraphViz.Internal.State +import Data.GraphViz.Internal.Util -- To avoid orphan instances and cyclic imports import Data.GraphViz.Attributes.ColorScheme -- Only implicitly import and re-export combinators. -import Text.PrettyPrint.Leijen.Text.Monadic hiding ( SimpleDoc(..) - , renderPretty - , renderCompact - , displayT - , displayIO - , putDoc - , hPutDoc - , Pretty(..) - , bool - , string) +import qualified Data.Text as ST +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as T +import Text.PrettyPrint.Leijen.Text.Monadic hiding (Pretty(..), + SimpleDoc(..), bool, + displayIO, displayT, + hPutDoc, putDoc, + renderCompact, + renderPretty, string, + width, (<$>)) import qualified Text.PrettyPrint.Leijen.Text.Monadic as PP -import qualified Data.Text.Lazy as T -import Data.Text.Lazy(Text) -import Data.Char(toLower) -import qualified Data.Set as Set -import Data.Word(Word8, Word16) -import Control.Monad(ap, when) -import Control.Monad.Trans.State +import Control.Monad (ap, when) +import Control.Monad.State (MonadState, State, evalState, gets, + modify) +import Data.Char (toLower) +import qualified Data.Set as Set +import Data.String (IsString(..)) +import Data.Version (Version(..)) +import Data.Word (Word64, Word32, Word16, Word8) +#if !(MIN_VERSION_base (4,11,0)) + +#if !(MIN_VERSION_base (4,8,0)) +import Control.Applicative (Applicative) +import Data.Monoid (Monoid(..)) +#endif + +#if MIN_VERSION_base (4,9,0) && !MIN_VERSION_base (4,13,0) +import Data.Semigroup (Semigroup(..)) +#else +import Data.Monoid ((<>)) +#endif + +#endif + -- ----------------------------------------------------------------------------- -- | A type alias to indicate what is being produced. -type DotCode = State GraphvizState Doc +newtype DotCodeM a = DotCodeM { getDotCode :: State GraphvizState a } + deriving (Functor, Applicative, Monad, MonadState GraphvizState) +type DotCode = DotCodeM Doc + +runDotCode :: DotCode -> Doc +runDotCode = (`evalState` initialState) . getDotCode + instance Show DotCode where showsPrec d = showsPrec d . renderDot +instance IsString DotCode where + fromString = PP.string . fromString + +#if MIN_VERSION_base (4,9,0) +instance Semigroup DotCode where + (<>) = beside + +instance Monoid DotCode where + mempty = empty + mappend = (<>) +#else +instance Monoid DotCode where + mempty = empty + mappend = beside +#endif + +instance GraphvizStateM DotCodeM where + modifyGS = modify + + getsGS = gets + -- | Correctly render Graphviz output. renderDot :: DotCode -> Text renderDot = PP.displayT . PP.renderPretty 0.4 80 - . flip evalState initialState + . runDotCode -- | A class used to correctly print parts of the Graphviz Dot language. -- Minimal implementation is 'unqtDot'. @@ -144,6 +191,12 @@ instance PrintDot Word16 where unqtDot = int . fromIntegral +instance PrintDot Word32 where + unqtDot = unqtDot . toInteger + +instance PrintDot Word64 where + unqtDot = unqtDot . toInteger + instance PrintDot Double where -- If it's an "integral" double, then print as an integer. This -- seems to match how Graphviz apps use Dot. @@ -177,11 +230,24 @@ listToDot = toDot . T.pack +-- | Ignores 'versionTags' and assumes 'not . null . versionBranch' +-- (usually you want 'length . versionBranch == 2'). +instance PrintDot Version where + unqtDot = hcat . punctuate dot . mapM int . versionBranch + + toDot v = bool id dquotes (not . null . drop 2 . versionBranch $ v) + $ unqtDot v + instance PrintDot Text where unqtDot = unqtString toDot = qtString +instance PrintDot ST.Text where + unqtDot = unqtDot . T.fromStrict + + toDot = qtString . T.fromStrict + -- | For use with @OverloadedStrings@ to avoid ambiguous type variable errors. unqtText :: Text -> DotCode unqtText = unqtDot @@ -198,11 +264,11 @@ needsQuotes :: Text -> Bool needsQuotes str - | T.null str = True - | isKeyword str = True - | isIDString str = False - | isNumString str = False - | otherwise = True + | T.null str = True + | isKeyword str = True + | isIDString str = False + | isNumString False str = False + | otherwise = True addQuotes :: Text -> DotCode -> DotCode addQuotes = bool id dquotes . needsQuotes diff --git a/Data/GraphViz/State.hs b/Data/GraphViz/State.hs deleted file mode 100644 --- a/Data/GraphViz/State.hs +++ /dev/null @@ -1,118 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} - -{- | - Module : Data.GraphViz.State - Description : Printing and parsing state. - Copyright : (c) Ivan Lazar Miljenovic - License : 3-Clause BSD-style - Maintainer : Ivan.Miljenovic@gmail.com - - When printing and parsing Dot code, some items depend on values - that are set earlier. --} -module Data.GraphViz.State - ( GraphvizStateM(..) - , GraphvizState(..) - , AttributeType(..) - , setAttributeType - , getAttributeType - , initialState - , setDirectedness - , getDirectedness - , setLayerSep - , getLayerSep - , setColorScheme - , getColorScheme - ) where - -import Data.GraphViz.Attributes.ColorScheme - -import Control.Monad.Trans.State(State, modify, gets) -import Text.ParserCombinators.Poly.StateText(Parser, stUpdate, stQuery) - --- ----------------------------------------------------------------------------- - -class (Monad m) => GraphvizStateM m where - modifyGS :: (GraphvizState -> GraphvizState) -> m () - - getsGS :: (GraphvizState -> a) -> m a - -instance GraphvizStateM (State GraphvizState) where - modifyGS = modify - - getsGS = gets - -instance GraphvizStateM (Parser GraphvizState) where - modifyGS = stUpdate - - getsGS = stQuery - -data AttributeType = GraphAttribute - | SubGraphAttribute - | ClusterAttribute - | NodeAttribute - | EdgeAttribute - deriving (Eq, Ord, Show, Read) - --- | Several aspects of Dot code are either global or mutable state. -data GraphvizState = GS { directedEdges :: !Bool - , layerSep :: [Char] - , attributeType :: !AttributeType - , graphColor :: !ColorScheme - , clusterColor :: !ColorScheme - , nodeColor :: !ColorScheme - , edgeColor :: !ColorScheme - } - deriving (Eq, Ord, Show, Read) - -initialState :: GraphvizState -initialState = GS { directedEdges = True - , layerSep = defLayerSep - , attributeType = GraphAttribute - , graphColor = X11 - , clusterColor = X11 - , nodeColor = X11 - , edgeColor = X11 - } - -setDirectedness :: (GraphvizStateM m) => Bool -> m () -setDirectedness d = modifyGS (\ gs -> gs { directedEdges = d } ) - -getDirectedness :: (GraphvizStateM m) => m Bool -getDirectedness = getsGS directedEdges - -setAttributeType :: (GraphvizStateM m) => AttributeType -> m () -setAttributeType tp = modifyGS $ \ gs -> gs { attributeType = tp } - -getAttributeType :: (GraphvizStateM m) => m AttributeType -getAttributeType = getsGS attributeType - -setLayerSep :: (GraphvizStateM m) => [Char] -> m () -setLayerSep sep = modifyGS (\ gs -> gs { layerSep = sep } ) - -getLayerSep :: (GraphvizStateM m) => m [Char] -getLayerSep = getsGS layerSep - -setColorScheme :: (GraphvizStateM m) => ColorScheme -> m () -setColorScheme cs = do tp <- getsGS attributeType - modifyGS $ \gs -> case tp of - GraphAttribute -> gs { graphColor = cs } - -- subgraphs don't have specified scheme - SubGraphAttribute -> gs { graphColor = cs } - ClusterAttribute -> gs { clusterColor = cs } - NodeAttribute -> gs { nodeColor = cs } - EdgeAttribute -> gs { edgeColor = cs } - -getColorScheme :: (GraphvizStateM m) => m ColorScheme -getColorScheme = do tp <- getsGS attributeType - getsGS $ case tp of - GraphAttribute -> graphColor - -- subgraphs don't have specified scheme - SubGraphAttribute -> graphColor - ClusterAttribute -> clusterColor - NodeAttribute -> nodeColor - EdgeAttribute -> edgeColor - --- | The default separators for 'LayerSep'. -defLayerSep :: [Char] -defLayerSep = [' ', ':', '\t'] diff --git a/Data/GraphViz/Types.hs b/Data/GraphViz/Types.hs --- a/Data/GraphViz/Types.hs +++ b/Data/GraphViz/Types.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, + TypeSynonymInstances #-} {- | Module : Data.GraphViz.Types @@ -35,30 +36,30 @@ > digraph G { > - > subgraph cluster_0 { - > style=filled; - > color=lightgrey; - > node [style=filled,color=white]; - > a0 -> a1 -> a2 -> a3; - > label = "process #1"; - > } + > subgraph cluster_0 { + > style=filled; + > color=lightgrey; + > node [style=filled,color=white]; + > a0 -> a1 -> a2 -> a3; + > label = "process #1"; + > } > - > subgraph cluster_1 { - > node [style=filled]; - > b0 -> b1 -> b2 -> b3; - > label = "process #2"; - > color=blue - > } - > start -> a0; - > start -> b0; - > a1 -> b3; - > b2 -> a3; - > a3 -> a0; - > a3 -> end; - > b3 -> end; + > subgraph cluster_1 { + > node [style=filled]; + > b0 -> b1 -> b2 -> b3; + > label = "process #2"; + > color=blue + > } + > start -> a0; + > start -> b0; + > a1 -> b3; + > b2 -> a3; + > a3 -> a0; + > a3 -> end; + > b3 -> end; > - > start [shape=Mdiamond]; - > end [shape=Msquare]; + > start [shape=Mdiamond]; + > end [shape=Msquare]; > } Each representation is suited for different things: @@ -94,6 +95,7 @@ , PPDotRepr -- * Common sub-types , GraphID(..) + , Number (..) , ToGraphID(..) , textGraphID , GlobalAttributes(..) @@ -103,30 +105,41 @@ , ClusterLookup , NodeLookup , Path + , graphStructureInformationClean + , nodeInformationClean + , edgeInformationClean -- * Obtaining the @DotNode@s and @DotEdges@. , graphNodes , graphEdges -- * Printing and parsing a @DotRepr@. , printDotGraph , parseDotGraph + , parseDotGraphLiberally -- * Limitations and documentation -- $limitations ) where -import Data.GraphViz.Types.Canonical( DotGraph(..), DotStatements(..) - , DotSubGraph(..)) -import Data.GraphViz.Types.Common( GraphID(..), GlobalAttributes(..) - , DotNode(..), DotEdge(..), numericValue) +import Data.GraphViz.Attributes.Complete (rmUnwantedAttributes, + usedByClusters, usedByEdges, + usedByGraphs, usedByNodes) +import Data.GraphViz.Internal.State (GraphvizState) +import Data.GraphViz.Internal.Util (bool) +import Data.GraphViz.Parsing (ParseDot(..), adjustErr, + checkValidParseWithRest, parse, + parseLiberally, runParserWith) +import Data.GraphViz.PreProcessing (preProcess) +import Data.GraphViz.Printing (PrintDot(..), printIt) +import Data.GraphViz.Types.Canonical (DotGraph(..), DotStatements(..), + DotSubGraph(..)) +import Data.GraphViz.Types.Internal.Common (DotEdge(..), DotNode(..), + GlobalAttributes(..), GraphID(..), + Number(..), numericValue, withGlob) import Data.GraphViz.Types.State -import Data.GraphViz.Util(bool) -import Data.GraphViz.Parsing(ParseDot(..), runParser, checkValidParse, parse, adjustErr) -import Data.GraphViz.PreProcessing(preProcess) -import Data.GraphViz.Printing(PrintDot(..), printIt) -import qualified Data.Text.Lazy as T -import Data.Text.Lazy(Text) -import Control.Arrow(first) -import Control.Monad.Trans.State(get, put, modify, execState, evalState) +import Control.Arrow (second, (***)) +import Control.Monad.State (evalState, execState, get, modify, put) +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as T -- ----------------------------------------------------------------------------- @@ -142,6 +155,9 @@ class (Ord n) => DotRepr dg n where -- | Convert from a graph in canonical form. This is especially -- useful when using the functions from "Data.GraphViz.Algorithms". + -- + -- See @FromGeneralisedDot@ in "Data.GraphViz.Types.Generalised" + -- for a semi-inverse of this function. fromCanonical :: DotGraph n -> dg n -- | Return the ID of the graph. @@ -165,7 +181,7 @@ -- | Change the node values. This function is assumed to be -- /injective/, otherwise the resulting graph will not be -- identical to the original (modulo labels). - mapDotGraph :: (Ord n', DotRepr dg n') => (n -> n') -> dg n -> dg n' + mapDotGraph :: (DotRepr dg n') => (n -> n') -> dg n -> dg n' -- | Return information on all the clusters contained within this -- 'DotRepr', as well as the top-level 'GraphAttrs' for the @@ -187,6 +203,36 @@ -- from 'graphStructureInformation'). unAnonymise :: dg n -> dg n +-- | A variant of 'graphStructureInformation' with default attributes +-- removed and only attributes usable by graph/cluster kept (where +-- applicable). +graphStructureInformationClean :: (DotRepr dg n) => dg n + -> (GlobalAttributes, ClusterLookup) +graphStructureInformationClean = (globOnly *** fmap (second clustOnly)) + . graphStructureInformation + where + globOnly = withGlob $ filter usedByGraphs . rmUnwantedAttributes + + clustOnly = withGlob $ filter usedByClusters . rmUnwantedAttributes + + +-- | A variant of 'nodeInformation' with default attributes removed +-- and only attributes used by nodes kept. +nodeInformationClean :: (DotRepr dg n) => Bool -> dg n -> NodeLookup n +nodeInformationClean = (fmap (second nodeOnly) .) . nodeInformation + where + nodeOnly = filter usedByNodes . rmUnwantedAttributes + +-- | A variant of 'edgeInformation' with default attributes removed +-- and only attributes used by edges kept. +edgeInformationClean :: (DotRepr dg n) => Bool -> dg n -> [DotEdge n] +edgeInformationClean = (map rmEdgeAs .) . edgeInformation + where + rmEdgeAs de = de { edgeAttributes = edgeOnly $ edgeAttributes de } + + edgeOnly = filter usedByEdges . rmUnwantedAttributes + + -- | This class exists just to make type signatures nicer; all -- instances of 'DotRepr' should also be an instance of -- 'PrintDotRepr'. @@ -225,9 +271,23 @@ -- -- Also removes any comments, etc. before parsing. parseDotGraph :: (ParseDotRepr dg n) => Text -> dg n -parseDotGraph = fst . prs . preProcess +parseDotGraph = parseDotGraphWith id + +-- | As with 'parseDotGraph', but if an 'Attribute' cannot be parsed +-- strictly according to the known rules, let it fall back to being +-- parsed as an 'UnknownAttribute'. This is especially useful for +-- when using a version of Graphviz that is either newer (especially +-- for the XDot attributes) or older (when some attributes have +-- changed) but you'd still prefer it to parse rather than throwing +-- an error. +parseDotGraphLiberally :: (ParseDotRepr dg n) => Text -> dg n +parseDotGraphLiberally = parseDotGraphWith parseLiberally + +parseDotGraphWith :: (ParseDotRepr dg n) => (GraphvizState -> GraphvizState) + -> Text -> dg n +parseDotGraphWith f = prs . preProcess where - prs = first checkValidParse . runParser parse' + prs = checkValidParseWithRest . runParserWith f parse' parse' = parse `adjustErr` ("Unable to parse the Dot graph; usually this is because of either:\n\ @@ -307,7 +367,7 @@ sgRe sg = do sgid' <- case subGraphID sg of Nothing -> do n <- get put $ succ n - return . Just $ Int n + return . Just . Num $ Int n sgid -> return sgid stmts' <- stRe $ subGraphStmts sg return $ sg { subGraphID = sgid' @@ -316,7 +376,7 @@ maxSGInt :: DotGraph n -> Int maxSGInt dg = execState (stInt $ graphStatements dg) - . flip check 0 + . (`check` 0) $ graphID dg where check = maybe id max . (numericValue =<<) @@ -350,14 +410,14 @@ toGraphID = toGraphID . T.singleton instance ToGraphID Int where - toGraphID = Int + toGraphID = Num . Int -- | This instance loses precision by going via 'Int'. instance ToGraphID Integer where - toGraphID = Int . fromInteger + toGraphID = Num . Int . fromInteger instance ToGraphID Double where - toGraphID = Dbl + toGraphID = Num . Dbl -- ----------------------------------------------------------------------------- diff --git a/Data/GraphViz/Types/Canonical.hs b/Data/GraphViz/Types/Canonical.hs --- a/Data/GraphViz/Types/Canonical.hs +++ b/Data/GraphViz/Types/Canonical.hs @@ -32,11 +32,11 @@ > , graphID = Just (Str "G") > , graphStatements = DotStmts { attrStmts = [] > , subGraphs = [ DotSG { isCluster = True - > , subGraphID = Just (Int 0) + > , subGraphID = Just (Num (Int 0)) > , subGraphStmts = DotStmts { attrStmts = [ GraphAttrs [ style filled > , color LightGray > , textLabel "process #1"] - > , NodeAttrs [style filled, color White]]} + > , NodeAttrs [style filled, color White]] > , subGraphs = [] > , nodeStmts = [ DotNode "a0" [] > , DotNode "a1" [] @@ -47,7 +47,7 @@ > , DotEdge "a2" "a3" [] > , DotEdge "a3" "a0" []]}} > , DotSG { isCluster = True - > , subGraphID = Just (Int 1) + > , subGraphID = Just (Num (Int 1)) > , subGraphStmts = DotStmts { attrStmts = [ GraphAttrs [textLabel "process #2", color Blue] > , NodeAttrs [style filled]] > , subGraphs = [] @@ -84,14 +84,13 @@ , DotEdge(..) ) where -import Data.GraphViz.Types.Common +import Data.GraphViz.Internal.State (AttributeType (..)) +import Data.GraphViz.Internal.Util (bool) import Data.GraphViz.Parsing import Data.GraphViz.Printing -import Data.GraphViz.State(AttributeType(..)) -import Data.GraphViz.Util(bool) +import Data.GraphViz.Types.Internal.Common -import Control.Arrow((&&&)) -import Control.Monad(liftM) +import Control.Arrow ((&&&)) -- ----------------------------------------------------------------------------- @@ -182,8 +181,8 @@ parseUnqt = parseSubGraph DotSG parseUnqt `onFail` -- Take "anonymous" DotSubGraphs into account. - liftM (DotSG False Nothing) - (parseBracesBased SubGraphAttribute parseUnqt) + fmap (DotSG False Nothing) + (parseBracesBased SubGraphAttribute parseUnqt) parse = parseUnqt -- Don't want the option of quoting `adjustErr` diff --git a/Data/GraphViz/Types/Common.hs b/Data/GraphViz/Types/Common.hs deleted file mode 100644 --- a/Data/GraphViz/Types/Common.hs +++ /dev/null @@ -1,522 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_HADDOCK hide #-} - -{- | - Module : Data.GraphViz.Types.Common - Description : Common internal functions for dealing with overall types. - Copyright : (c) Ivan Lazar Miljenovic - License : 3-Clause BSD-style - Maintainer : Ivan.Miljenovic@gmail.com - - This module provides common functions used by both - "Data.GraphViz.Types" as well as "Data.GraphViz.Types.Generalised". --} -module Data.GraphViz.Types.Common where - -import Data.GraphViz.Parsing -import Data.GraphViz.Printing -import Data.GraphViz.State -import Data.GraphViz.Util -import Data.GraphViz.Attributes.Complete( Attributes, Attribute(HeadPort, TailPort) - , usedByGraphs, usedByClusters - , usedByNodes) -import Data.GraphViz.Attributes.Internal(PortPos, parseEdgeBasedPP) - -import Data.Maybe(isJust) -import qualified Data.Text.Lazy as T -import qualified Data.Text.Lazy.Read as T -import Data.Text.Lazy(Text) -import Control.Monad(liftM, liftM2, when) - --- ----------------------------------------------------------------------------- --- This is re-exported by Data.GraphViz.Types - --- | A polymorphic type that covers all possible ID values allowed by --- Dot syntax. Note that whilst the 'ParseDot' and 'PrintDot' --- instances for 'String' will properly take care of the special --- cases for numbers, they are treated differently here. -data GraphID = Str Text - | Int Int - | Dbl Double - deriving (Eq, Ord, Show, Read) - -instance PrintDot GraphID where - unqtDot (Str str) = unqtDot str - unqtDot (Int i) = unqtDot i - unqtDot (Dbl d) = unqtDot d - - toDot (Str str) = toDot str - toDot gID = unqtDot gID - -instance ParseDot GraphID where - parseUnqt = liftM stringNum parseUnqt - - parse = liftM stringNum parse - `adjustErr` - ("Not a valid GraphID\n\t"++) - -stringNum :: Text -> GraphID -stringNum str = maybe checkDbl Int $ stringToInt str - where - checkDbl = if isNumString str - then Dbl $ toDouble str - else Str str - -numericValue :: GraphID -> Maybe Int -numericValue (Str str) = either (const Nothing) (Just . round . fst) - $ T.signed T.double str -numericValue (Int n) = Just n -numericValue (Dbl x) = Just $ round x - --- ----------------------------------------------------------------------------- - --- Re-exported by Data.GraphViz.Types.* - --- | 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 listed 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 - unqtDot = printAttrBased True printGlobAttrType globAttrType attrs - - unqtListToDot = printAttrBasedList True printGlobAttrType globAttrType attrs - - listToDot = unqtListToDot - --- GraphAttrs, NodeAttrs and EdgeAttrs respectively -partitionGlobal :: [GlobalAttributes] -> (Attributes, Attributes, Attributes) -partitionGlobal = foldr select ([], [], []) - where - select globA ~(gs,ns,es) = case globA of - GraphAttrs as -> (as ++ gs, ns, es) - NodeAttrs as -> (gs, as ++ ns, es) - EdgeAttrs as -> (gs, ns, as ++ es) - -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 - - -- Determine if we need to set the attribute type. - let mtp = globAttrType $ gat [] -- Only need the constructor - oldTp <- getAttributeType - maybe (return ()) setAttributeType mtp - - as <- whitespace >> parse - - -- Safe to set back even if not changed. - setAttributeType oldTp - return $ gat as - `onFail` - liftM determineType parse - - parse = parseUnqt -- Don't want the option of quoting - `adjustErr` - ("Not a valid listing of global attributes\n\t"++) - - -- Have to do this manually because of the special case - parseUnqtList = parseStatements parseUnqt - - parseList = parseUnqtList - --- Cheat: rather than determine whether it's a graph, cluster or --- sub-graph just don't set it. -globAttrType :: GlobalAttributes -> Maybe AttributeType -globAttrType NodeAttrs{} = Just NodeAttribute -globAttrType EdgeAttrs{} = Just EdgeAttribute -globAttrType _ = Nothing - -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] - --- ----------------------------------------------------------------------------- - --- | A node in 'DotGraph'. -data DotNode n = DotNode { nodeID :: n - , nodeAttributes :: Attributes - } - deriving (Eq, Ord, Show, Read) - -instance (PrintDot n) => PrintDot (DotNode n) where - unqtDot = printAttrBased False printNodeID - (const $ Just NodeAttribute) nodeAttributes - - unqtListToDot = printAttrBasedList False printNodeID - (const $ Just NodeAttribute) nodeAttributes - - listToDot = unqtListToDot - -printNodeID :: (PrintDot n) => DotNode n -> DotCode -printNodeID = toDot . nodeID - -instance (ParseDot n) => ParseDot (DotNode n) where - parseUnqt = parseAttrBased NodeAttribute False parseNodeID - - parse = parseUnqt -- Don't want the option of quoting - - parseUnqtList = parseAttrBasedList NodeAttribute False parseNodeID - - parseList = parseUnqtList - -parseNodeID :: (ParseDot n) => Parse (Attributes -> DotNode n) -parseNodeID = liftM DotNode parseAndCheck - where - parseAndCheck = do n <- parse - me <- optional parseUnwanted - maybe (return n) (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 } - --- ----------------------------------------------------------------------------- - --- 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). - --- | An edge in 'DotGraph'. -data DotEdge n = DotEdge { fromNode :: n - , toNode :: n - , edgeAttributes :: Attributes - } - deriving (Eq, Ord, Show, Read) - -instance (PrintDot n) => PrintDot (DotEdge n) where - unqtDot = printAttrBased False printEdgeID - (const $ Just EdgeAttribute) edgeAttributes - - unqtListToDot = printAttrBasedList False printEdgeID - (const $ Just EdgeAttribute) edgeAttributes - - listToDot = unqtListToDot - -printEdgeID :: (PrintDot n) => DotEdge n -> DotCode -printEdgeID e = do isDir <- getDirectedness - toDot (fromNode e) - <+> bool undirEdge' dirEdge' isDir - <+> toDot (toNode e) - - -instance (ParseDot n) => ParseDot (DotEdge n) where - parseUnqt = parseAttrBased EdgeAttribute True parseEdgeID - - parse = parseUnqt -- Don't want the option of quoting - - -- Have to take into account edges of the type "n1 -> n2 -> n3", etc. - parseUnqtList = liftM concat - $ parseStatements parseEdgeLine - - parseList = parseUnqtList - -parseEdgeID :: (ParseDot n) => Parse (Attributes -> DotEdge n) -parseEdgeID = do eFrom <- parseEdgeNode - -- Parse both edge types just to be more liberal - parseEdgeType - eTo <- parseEdgeNode - return $ mkEdge eFrom eTo - -type EdgeNode n = (n, Maybe PortPos) - --- | Takes into account edge statements containing something like --- @a -> \{b c\}@. -parseEdgeNodes :: (ParseDot n) => Parse [EdgeNode n] -parseEdgeNodes = parseBraced ( wrapWhitespace - -- Should really use sepBy1, but this will do. - $ parseStatements parseEdgeNode - ) - `onFail` - liftM return parseEdgeNode - -parseEdgeNode :: (ParseDot n) => Parse (EdgeNode n) -parseEdgeNode = liftM2 (,) parse - (optional $ character ':' >> parseEdgeBasedPP) - -mkEdge :: EdgeNode n -> EdgeNode n -> Attributes -> DotEdge n -mkEdge (eFrom, mFP) (eTo, mTP) = DotEdge eFrom eTo - . addPortPos TailPort mFP - . addPortPos HeadPort mTP - -mkEdges :: [EdgeNode n] -> [EdgeNode n] - -> Attributes -> [DotEdge n] -mkEdges fs ts as = liftM2 (\f t -> mkEdge f t as) fs ts - -addPortPos :: (PortPos -> Attribute) -> Maybe PortPos - -> Attributes -> Attributes -addPortPos c = maybe id ((:) . c) - -parseEdgeType :: Parse Bool -parseEdgeType = wrapWhitespace $ stringRep True dirEdge - `onFail` - stringRep False undirEdge - -parseEdgeLine :: (ParseDot n) => Parse [DotEdge n] -parseEdgeLine = do n1 <- parseEdgeNodes - ens <- many1 $ do parseEdgeType - parseEdgeNodes - let ens' = n1 : ens - efs = zipWith mkEdges ens' (tail ens') - ef = return $ \ as -> concatMap ($as) efs - parseAttrBased EdgeAttribute True ef - -instance Functor DotEdge where - fmap f e = e { fromNode = f $ fromNode e - , toNode = f $ toNode e - } - -dirEdge :: String -dirEdge = "->" - -dirEdge' :: DotCode -dirEdge' = text $ T.pack dirEdge - -undirEdge :: String -undirEdge = "--" - -undirEdge' :: DotCode -undirEdge' = text $ T.pack undirEdge - --- ----------------------------------------------------------------------------- --- Labels - -dirGraph :: String -dirGraph = "digraph" - -dirGraph' :: DotCode -dirGraph' = text $ T.pack dirGraph - -undirGraph :: String -undirGraph = "graph" - -undirGraph' :: DotCode -undirGraph' = text $ T.pack undirGraph - -strGraph :: String -strGraph = "strict" - -strGraph' :: DotCode -strGraph' = text $ T.pack strGraph - -sGraph :: String -sGraph = "subgraph" - -sGraph' :: DotCode -sGraph' = text $ T.pack sGraph - -clust :: String -clust = "cluster" - -clust' :: DotCode -clust' = text $ T.pack clust - --- ----------------------------------------------------------------------------- - -printGraphID :: (a -> Bool) -> (a -> Bool) - -> (a -> Maybe GraphID) - -> a -> DotCode -printGraphID str isDir mID g = do setDirectedness isDir' - bool empty strGraph' (str g) - <+> bool undirGraph' dirGraph' isDir' - <+> maybe empty toDot (mID g) - where - isDir' = isDir g - -parseGraphID :: (Bool -> Bool -> Maybe GraphID -> a) -> Parse a -parseGraphID f = do whitespace - str <- liftM isJust - $ optional (parseAndSpace $ string strGraph) - dir <- parseAndSpace ( stringRep True dirGraph - `onFail` - stringRep False undirGraph - ) - setDirectedness dir - gID <- optional $ parseAndSpace parse - return $ f str dir gID - -printStmtBased :: (a -> DotCode) -> (a -> AttributeType) - -> (a -> stmts) -> (stmts -> DotCode) - -> a -> DotCode -printStmtBased f ftp r dr a = do gs <- getsGS id - setAttributeType $ ftp a - dc <- printBracesBased (f a) (dr $ r a) - modifyGS (const gs) - return dc - -printStmtBasedList :: (a -> DotCode) -> (a -> AttributeType) - -> (a -> stmts) -> (stmts -> DotCode) - -> [a] -> DotCode -printStmtBasedList f ftp r dr = vcat . mapM (printStmtBased f ftp r dr) - --- Can't use the 'braces' combinator here because we want the closing --- brace lined up with the h value, which due to indentation might not --- be the case with braces. -printBracesBased :: DotCode -> DotCode -> DotCode -printBracesBased h i = vcat $ sequence [ h <+> lbrace - , ind i - , rbrace - ] - where - ind = indent 4 - --- | This /must/ only be used for sub-graphs, etc. -parseBracesBased :: AttributeType -> Parse a -> Parse a -parseBracesBased tp p = do gs <- getsGS id - setAttributeType tp - a <- whitespace >> parseBraced (wrapWhitespace p) - modifyGS (const gs) - return a - `adjustErr` - ("Not a valid value wrapped in braces.\n\t"++) - -printSubGraphID :: (a -> (Bool, Maybe GraphID)) -> a -> DotCode -printSubGraphID f a = sGraph' - <+> maybe cl dtID mID - where - (isCl, mID) = f a - cl = bool empty clust' isCl - dtID = printSGID isCl - --- | Print the actual ID for a 'DotSubGraph'. -printSGID :: Bool -> GraphID -> DotCode -printSGID isCl sID = bool noClust addClust isCl - where - noClust = toDot sID - -- Have to manually render it as we need the un-quoted form. - addClust = toDot . T.append (T.pack clust) . T.cons '_' - . renderDot $ mkDot sID - mkDot (Str str) = text str -- Quotes will be escaped later - mkDot gid = unqtDot gid - -parseSubGraph :: (Bool -> Maybe GraphID -> stmt -> c) -> Parse stmt -> Parse c -parseSubGraph pid pst = do (isC, fID) <- parseSubGraphID pid - let tp = bool SubGraphAttribute ClusterAttribute isC - liftM fID $ parseBracesBased tp pst - -parseSubGraphID :: (Bool -> Maybe GraphID -> c) -> Parse (Bool,c) -parseSubGraphID f = do string sGraph - whitespace1 - (isC,mid) <- parseSGID - return (isC, f isC mid) - -parseSGID :: Parse (Bool, Maybe GraphID) -parseSGID = oneOf [ liftM getClustFrom $ parseAndSpace parse - , return (False, Nothing) - ] - where - -- If it's a String value, check to see if it's actually a - -- cluster_Blah value; thus need to manually re-parse it. - getClustFrom (Str str) = runParser' pStr str - getClustFrom gid = (False, Just gid) - - checkCl = stringRep True clust - pStr = do isCl <- checkCl - `onFail` - return False - when isCl $ optional (character '_') >> return () - sID <- optional pID - let sID' = if sID == emptyID - then Nothing - else sID - return (isCl, sID') - - emptyID = Just $ Str "" - - -- For Strings, there are no more quotes to unescape, so consume - -- what you can. - pID = liftM stringNum $ manySatisfy (const True) - -{- This is a much nicer definition, but unfortunately it doesn't work. - The problem is that Graphviz decides that a subgraph is a cluster - if the ID starts with "cluster" (no quotes); thus, we _have_ to do - the double layer of parsing to get it to work :@ - - do isCl <- stringRep True clust - `onFail` - return False - sID <- optional $ do when isCl - $ optional (character '_') >> return () - parseUnqt - when (isCl || isJust sID) $ whitespace1 >> return () - return (isCl, sID) --} - --- The Bool is True for global, False for local. -printAttrBased :: Bool -> (a -> DotCode) -> (a -> Maybe AttributeType) - -> (a -> Attributes) -> a -> DotCode -printAttrBased prEmp ff ftp fas a = do oldType <- getAttributeType - maybe (return ()) setAttributeType mtp - oldCS <- getColorScheme - (dc <> semi) <* setAttributeType oldType - <* when prEmp (setColorScheme oldCS) - where - mtp = ftp a - f = ff a - dc = case fas a of - [] | not prEmp -> f - as -> f <+> toDot as - --- The Bool is True for global, False for local. -printAttrBasedList :: Bool -> (a -> DotCode) -> (a -> Maybe AttributeType) - -> (a -> Attributes) -> [a] -> DotCode -printAttrBasedList prEmp ff ftp fas = vcat . mapM (printAttrBased prEmp ff ftp fas) - --- The Bool is True for global, False for local. -parseAttrBased :: AttributeType -> Bool -> Parse (Attributes -> a) -> Parse a -parseAttrBased tp lc p = do oldType <- getAttributeType - setAttributeType tp - oldCS <- getColorScheme - f <- p - atts <- tryParseList' (whitespace >> parse) - when lc $ setColorScheme oldCS - when (tp /= oldType) $ setAttributeType oldType - return $ f atts - `adjustErr` - ("Not a valid attribute-based structure\n\t"++) - --- The Bool is True for global, False for local. -parseAttrBasedList :: AttributeType -> Bool -> Parse (Attributes -> a) -> Parse [a] -parseAttrBasedList tp lc = parseStatements . parseAttrBased tp lc - --- | Parse the separator (and any other whitespace1 present) between statements. -statementEnd :: Parse () -statementEnd = parseSplit >> newline' - where - parseSplit = (whitespace >> oneOf [ character ';' >> return () - , newline - ] - ) - `onFail` - whitespace1 - -parseStatements :: Parse a -> Parse [a] -parseStatements p = sepBy (whitespace >> p) statementEnd - `discard` - optional statementEnd diff --git a/Data/GraphViz/Types/Generalised.hs b/Data/GraphViz/Types/Generalised.hs --- a/Data/GraphViz/Types/Generalised.hs +++ b/Data/GraphViz/Types/Generalised.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} {- | Module : Data.GraphViz.Types.Generalised. @@ -49,6 +49,7 @@ -} module Data.GraphViz.Types.Generalised ( DotGraph(..) + , FromGeneralisedDot (..) -- * Sub-components of a @DotGraph@. , DotStatements , DotStatement(..) @@ -60,22 +61,22 @@ , DotEdge(..) ) where -import Data.GraphViz.Types -import qualified Data.GraphViz.Types.Canonical as C -import Data.GraphViz.Types.Common -import Data.GraphViz.Types.State -import Data.GraphViz.Parsing -import Data.GraphViz.Printing -import Data.GraphViz.State(AttributeType(..)) -import Data.GraphViz.Util(bool) +import Data.GraphViz.Algorithms (canonicalise) +import Data.GraphViz.Internal.State (AttributeType(..)) +import Data.GraphViz.Internal.Util (bool) +import Data.GraphViz.Parsing +import Data.GraphViz.Printing +import Data.GraphViz.Types +import qualified Data.GraphViz.Types.Canonical as C +import Data.GraphViz.Types.Internal.Common +import Data.GraphViz.Types.State -import qualified Data.Sequence as Seq -import Data.Sequence(Seq, (><)) -import qualified Data.Foldable as F -import qualified Data.Traversable as T -import Control.Arrow((&&&)) -import Control.Monad(liftM) -import Control.Monad.Trans.State(get, put, modify, execState, evalState) +import Control.Arrow ((&&&)) +import Control.Monad.State (evalState, execState, get, modify, put) +import qualified Data.Foldable as F +import Data.Sequence (Seq, (><)) +import qualified Data.Sequence as Seq +import qualified Data.Traversable as T -- ----------------------------------------------------------------------------- @@ -131,6 +132,8 @@ <*> parseBracesBased GraphAttribute parseGStmts parse = parseUnqt -- Don't want the option of quoting + `adjustErr` + ("Not a valid generalised DotGraph\n\t"++) -- | Assumed to be an injective mapping function. instance Functor DotGraph where @@ -148,13 +151,31 @@ -- ----------------------------------------------------------------------------- +-- | This class is useful for being able to parse in a dot graph as a +-- generalised one, and then convert it to your preferred +-- representation. +-- +-- This can be seen as a semi-inverse of 'fromCanonical'. +class (DotRepr dg n) => FromGeneralisedDot dg n where + fromGeneralised :: DotGraph n -> dg n + +instance (Ord n) => FromGeneralisedDot C.DotGraph n where + fromGeneralised = canonicalise + +instance (Ord n) => FromGeneralisedDot DotGraph n where + fromGeneralised = id + +-- ----------------------------------------------------------------------------- + type DotStatements n = Seq (DotStatement n) printGStmts :: (PrintDot n) => DotStatements n -> DotCode printGStmts = toDot . F.toList parseGStmts :: (ParseDot n) => Parse (DotStatements n) -parseGStmts = liftM Seq.fromList parse +parseGStmts = (Seq.fromList <$> parse) + `adjustErr` + ("Not a valid generalised DotStatements\n\t"++) statementStructure :: DotStatements n -> GraphState () statementStructure = F.mapM_ stmtStructure @@ -191,24 +212,24 @@ listToDot = unqtListToDot instance (ParseDot n) => ParseDot (DotStatement n) where - parseUnqt = oneOf [ liftM GA parseUnqt - , liftM SG parseUnqt - , liftM DN parseUnqt - , liftM DE parseUnqt + parseUnqt = oneOf [ GA <$> parseUnqt + , SG <$> parseUnqt + , DN <$> parseUnqt + , DE <$> parseUnqt ] parse = parseUnqt -- Don't want the option of quoting `adjustErr` - (++ "Not a valid statement") + ("Not a valid statement\n\t"++) - parseUnqtList = liftM concat . wrapWhitespace + parseUnqtList = fmap concat . wrapWhitespace $ parseStatements p where -- Have to do something special here because of "a -> b -> c" -- syntax for edges. - p = liftM (map DE) parseEdgeLine + p = fmap (map DE) parseEdgeLine `onFail` - liftM return parse + fmap (:[]) parse parseList = parseUnqtList @@ -262,14 +283,14 @@ parseUnqt = parseSubGraph DotSG parseGStmts `onFail` -- Take anonymous DotSubGraphs into account - liftM (DotSG False Nothing) - (parseBracesBased SubGraphAttribute parseGStmts) + fmap (DotSG False Nothing) + (parseBracesBased SubGraphAttribute parseGStmts) parse = parseUnqt -- Don't want the option of quoting `adjustErr` - (++ "\n\nNot a valid Sub Graph") + ("Not a valid Sub Graph\n\t"++) - parseUnqtList = sepBy (whitespace >> parseUnqt) newline' + parseUnqtList = sepBy (whitespace *> parseUnqt) newline' parseList = parseUnqtList @@ -298,12 +319,12 @@ newStmts = evalState (stsRe $ graphStatements dg) startN stsRe = T.mapM stRe - stRe (SG sg) = liftM SG $ sgRe sg - stRe stmt = return stmt + stRe (SG sg) = SG <$> sgRe sg + stRe stmt = pure stmt sgRe sg = do sgid' <- case subGraphID sg of Nothing -> do n <- get put $ succ n - return . Just $ Int n + return . Just . Num $ Int n sgid -> return sgid stmts' <- stsRe $ subGraphStmts sg return $ sg { subGraphID = sgid' @@ -312,7 +333,7 @@ maxSGInt :: DotGraph n -> Int maxSGInt dg = execState (stsInt $ graphStatements dg) - . flip check 0 + . (`check` 0) $ graphID dg where check = maybe id max . (numericValue =<<) diff --git a/Data/GraphViz/Types/Graph.hs b/Data/GraphViz/Types/Graph.hs --- a/Data/GraphViz/Types/Graph.hs +++ b/Data/GraphViz/Types/Graph.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} +{-# LANGUAGE CPP, FlexibleInstances, MultiParamTypeClasses #-} {- | Module : Data.GraphViz.Types.Graph @@ -96,29 +96,37 @@ , removeEmptyClusters ) where -import Data.GraphViz.Types -import qualified Data.GraphViz.Types.Canonical as C -import qualified Data.GraphViz.Types.Generalised as G -import Data.GraphViz.Types.Common(partitionGlobal) -import qualified Data.GraphViz.Types.State as St -import Data.GraphViz.Attributes.Same -import Data.GraphViz.Attributes.Complete(Attributes) -import Data.GraphViz.Util(groupSortBy, groupSortCollectBy) -import Data.GraphViz.Algorithms(CanonicaliseOptions(..), canonicaliseOptions) -import Data.GraphViz.Algorithms.Clustering +import Data.GraphViz.Algorithms (CanonicaliseOptions(..), + canonicaliseOptions) +import Data.GraphViz.Algorithms.Clustering +import Data.GraphViz.Attributes.Complete (Attributes) +import Data.GraphViz.Attributes.Same +import Data.GraphViz.Internal.Util (groupSortBy, + groupSortCollectBy) +import Data.GraphViz.Types +import qualified Data.GraphViz.Types.Canonical as C +import qualified Data.GraphViz.Types.Generalised as G +import Data.GraphViz.Types.Internal.Common (partitionGlobal) +import qualified Data.GraphViz.Types.State as St -import Data.List(foldl', delete, unfoldr) -import qualified Data.Foldable as F -import Data.Maybe(mapMaybe, fromMaybe) -import qualified Data.Map as M -import Data.Map(Map) -import qualified Data.Set as S -import qualified Data.Sequence as Seq -import Control.Arrow((***)) -import Control.Monad(liftM, liftM2) -import Text.Read(Lexeme(Ident), lexP, parens, readPrec) -import Text.ParserCombinators.ReadPrec(prec) +import Control.Applicative (liftA2, (<|>)) +import Control.Arrow ((***)) +import qualified Data.Foldable as F +import Data.List (delete, foldl', unfoldr) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (fromMaybe, mapMaybe, + maybeToList) +import qualified Data.Sequence as Seq +import qualified Data.Set as S +import Text.ParserCombinators.ReadPrec (prec) +import Text.Read (Lexeme(Ident), lexP, parens, + readPrec) +#if !(MIN_VERSION_base (4,8,0)) +import Control.Applicative ((<$>), (<*>)) +#endif + -- ----------------------------------------------------------------------------- -- | A Dot graph that allows graph operations on it. @@ -133,7 +141,7 @@ -- | It should be safe to substitute 'unsafeFromCanonical' for -- 'fromCanonical' in the output of this. -instance (Ord n, Show n) => Show (DotGraph n) where +instance (Show n) => Show (DotGraph n) where showsPrec d dg = showParen (d > 10) $ showString "fromCanonical " . shows (toCanonical dg) @@ -182,7 +190,7 @@ deriving (Eq, Ord, Show, Read) adjacent :: Context n -> [DotEdge n] -adjacent c = mapU (flip DotEdge n) (predecessors c) +adjacent c = mapU (`DotEdge` n) (predecessors c) ++ mapU (DotEdge n) (successors c) where n = node c @@ -216,14 +224,16 @@ (Cntxt n mc as ps ss) & dg = withValues merge dg' where ps' = toMap ps - ps'' = M.delete n ps' + ps'' = fromMap (M.delete n ps') ss' = toMap ss - ss'' = M.delete n ss' + ss'' = fromMap (M.delete n ss') dg' = addNode n mc as dg - merge = addSucc n ps'' . addPred n ss'' + merge = addSuccRev n ps'' . addPredRev n ss'' + -- Add reverse edges . M.adjust (\ni -> ni { _predecessors = ps', _successors = ss' }) n + -- Add actual edges infixr 5 & @@ -233,26 +243,26 @@ composeList :: (Ord n) => [Context n] -> DotGraph n composeList = foldr (&) emptyGraph -addSucc :: (Ord n) => n -> EdgeMap n -> NodeMap n -> NodeMap n -addSucc = addPS niSucc +addSuccRev :: (Ord n) => n -> [(n, Attributes)] -> NodeMap n -> NodeMap n +addSuccRev = addEdgeLinks niSkip niSucc -addPred :: (Ord n) => n -> EdgeMap n -> NodeMap n -> NodeMap n -addPred = addPS niPred +addPredRev :: (Ord n) => n -> [(n, Attributes)] -> NodeMap n -> NodeMap n +addPredRev = addEdgeLinks niSkip niPred -addPS :: (Ord n) => ((EdgeMap n -> EdgeMap n) -> NodeInfo n -> NodeInfo n) - -> n -> EdgeMap n -> NodeMap n -> NodeMap n -addPS fni t fas nm = t `seq` foldl' addSucc' nm fas' +addEdgeLinks :: (Ord n) => UpdateEdgeMap n -> UpdateEdgeMap n + -> n -> [(n, Attributes)] -> NodeMap n -> NodeMap n +addEdgeLinks fwd rev f tas = updRev . updFwd where - fas' = fromMap fas + updFwd = M.adjust addFwd f - addSucc' nm' (f,as) = f `seq` M.alter (addS as) f nm' + addFwd ni = foldl' (\ni' (t,as) -> fwd (M.insertWith (++) t [as]) ni') ni tas - addS as = Just - . maybe (error "Node not in the graph!") - (fni (M.insertWith (++) t [as])) + updRev nm = foldl' (\nm' (t,as) -> M.adjust (addRev as) t nm') nm tas --- | Add a node to the current graph. Throws an error if the node --- already exists in the graph. + addRev as = rev (M.insertWith (++) f [as]) + +-- | Add a node to the current graph. Merges attributes and edges if +-- the node already exists in the graph. -- -- If the specified cluster does not yet exist in the graph, then it -- will be added (as a sub-graph of the overall graph and no @@ -264,13 +274,17 @@ -> Attributes -> DotGraph n -> DotGraph n -addNode n mc as dg - | n `M.member` ns = error "Node already exists in the graph" - | otherwise = addEmptyCluster mc - $ dg { values = ns' } +addNode n mc as dg = addEmptyCluster mc $ dg { values = ns' } where ns = values dg - ns' = M.insert n (NI mc as M.empty M.empty) ns + ns' = M.insertWith mergeLogic n (NI mc as M.empty M.empty) ns + mergeLogic (NI newClust newAttrs newPreds newSuccs) (NI oldClust oldAttrs oldPreds oldSuccs) = + NI resClust resAttrs resPreds resSuccs + where + resClust = newClust <|> oldClust + resAttrs = unSame $ S.union (toSAttr newAttrs) (toSAttr oldAttrs) + resPreds = M.unionWith (++) newPreds oldPreds + resSuccs = M.unionWith (++) newSuccs oldSuccs -- | A variant of 'addNode' that takes in a DotNode (not in a -- cluster). @@ -283,9 +297,7 @@ addEdge :: (Ord n) => n -> n -> Attributes -> DotGraph n -> DotGraph n addEdge f t as = withValues merge where - -- Add the edge assuming it's directed; let the getter functions - -- be smart regarding directedness. - merge = addPred t (M.singleton f [as]) . addSucc f (M.singleton t [as]) + merge = addEdgeLinks niSucc niPred f [(t,as)] -- | A variant of 'addEdge' that takes a 'DotEdge' value. addDotEdge :: (Ord n) => DotEdge n -> DotGraph n -> DotGraph n @@ -312,7 +324,7 @@ -- Used to make sure that the parent cluster exists addEmptyCluster :: Maybe GraphID -> DotGraph n -> DotGraph n -addEmptyCluster = maybe id (withClusters . flip dontReplace defCI) +addEmptyCluster = maybe id (withClusters . (`dontReplace` defCI)) where dontReplace = M.insertWith (const id) defCI = CI Nothing emptyGA @@ -335,12 +347,12 @@ -- | Create a graph with no clusters. mkGraph :: (Ord n) => [DotNode n] -> [DotEdge n] -> DotGraph n -mkGraph ns es = flip (foldl' (flip addDotEdge)) es +mkGraph ns es = flip (foldl' $ flip addDotEdge) es $ foldl' (flip addDotNode) emptyGraph ns -- | Convert this DotGraph into canonical form. All edges are found -- in the outer graph rather than in clusters. -toCanonical :: (Ord n) => DotGraph n -> C.DotGraph n +toCanonical :: DotGraph n -> C.DotGraph n toCanonical dg = C.DotGraph { C.strictGraph = strictGraph dg , C.directedGraph = directedGraph dg , C.graphID = graphID dg @@ -361,7 +373,7 @@ lns = map (\ (n,ni) -> (n,(_inCluster ni, _attributes ni))) . M.assocs $ values dg - (cs,ns) = clustersToNodes pathOf id clustAs snd lns + (cs,ns) = clustersToNodes pathOf (const True) id clustAs snd lns pathOf (n,(c,as)) = pathFrom c (n,as) pathFrom c ln = F.foldr C (N ln) . fromMaybe Seq.empty $ (`M.lookup`pM) =<< c @@ -445,7 +457,7 @@ -- | Delete the specified cluster, and makes any clusters or nodes -- within it be in its root cluster (or the overall graph if -- required). -deleteCluster :: (Ord n) => GraphID -> DotGraph n -> DotGraph n +deleteCluster :: GraphID -> DotGraph n -> DotGraph n deleteCluster c dg = withValues (M.map adjNode) . withClusters (M.map adjCluster . M.delete c) $ dg @@ -461,7 +473,7 @@ adjCluster ci = ci { parentCluster = adjParent $ parentCluster ci } -- | Remove clusters with no sub-clusters and no nodes within them. -removeEmptyClusters :: (Ord n) => DotGraph n -> DotGraph n +removeEmptyClusters :: DotGraph n -> DotGraph n removeEmptyClusters dg = dg { clusters = cM' } where cM = clusters dg @@ -471,7 +483,7 @@ invNs = usedClustsIn . M.map _inCluster $ values dg usedClustsIn = M.fromAscList - . map (liftM2 (,) (fst . head) (map snd)) + . map ((,) <$> fst . head <*> map snd) . groupSortBy fst . mapMaybe (uncurry (fmap . flip (,))) . M.assocs @@ -489,7 +501,7 @@ -- | Determine if this graph has nodes or clusters. isEmptyGraph :: DotGraph n -> Bool -isEmptyGraph = liftM2 (&&) isEmpty (not . hasClusters) +isEmptyGraph = liftA2 (&&) isEmpty (not . hasClusters) graphAttributes :: DotGraph n -> [GlobalAttributes] graphAttributes = fromGlobAttrs . graphAttrs @@ -506,7 +518,7 @@ -- equivalent to 'adjacentTo'. predecessorsOf :: (Ord n) => DotGraph n -> n -> [DotEdge n] predecessorsOf dg t - | directedGraph dg = emToDE (flip DotEdge t) + | directedGraph dg = emToDE (`DotEdge` t) . _predecessors $ values dg M.! t | otherwise = adjacentTo dg t @@ -524,10 +536,9 @@ where ni = values dg M.! n sucs = emToDE (DotEdge n) $ _successors ni - preds = emToDE (flip DotEdge n) $ n `M.delete` _predecessors ni + preds = emToDE (`DotEdge` n) $ n `M.delete` _predecessors ni -emToDE :: (Ord n) => (n -> Attributes -> DotEdge n) - -> EdgeMap n -> [DotEdge n] +emToDE :: (n -> Attributes -> DotEdge n) -> EdgeMap n -> [DotEdge n] emToDE f = map (uncurry f) . fromMap -- | Which cluster (or the root graph) is this cluster in? @@ -565,20 +576,23 @@ unAnonymise = id -- No anonymous clusters! +instance (Ord n) => G.FromGeneralisedDot DotGraph n where + fromGeneralised = fromDotRepr + instance (Ord n, PrintDot n) => PrintDotRepr DotGraph n instance (Ord n, ParseDot n) => ParseDotRepr DotGraph n instance (Ord n, PrintDot n, ParseDot n) => PPDotRepr DotGraph n -- | Uses the PrintDot instance for canonical 'C.DotGraph's. -instance (Ord n, PrintDot n) => PrintDot (DotGraph n) where +instance (PrintDot n) => PrintDot (DotGraph n) where unqtDot = unqtDot . toCanonical -- | Uses the ParseDot instance for generalised 'G.DotGraph's. instance (Ord n, ParseDot n) => ParseDot (DotGraph n) where - parseUnqt = liftM fromGDot $ parseUnqt + parseUnqt = fromGDot <$> parseUnqt where -- fromGDot :: G.DotGraph n -> DotGraph n - fromGDot = fromDotRepr . flip asTypeOf (undefined :: G.DotGraph n) + fromGDot = fromDotRepr . (`asTypeOf` (undefined :: G.DotGraph n)) parse = parseUnqt -- Don't want the option of quoting @@ -657,10 +671,10 @@ -> Map n (EdgeMap n) toEdgeMap f t = M.map eM . M.fromList . groupSortCollectBy f t' where - t' = liftM2 (,) t edgeAttributes + t' = liftA2 (,) t edgeAttributes eM = M.fromList . groupSortCollectBy fst snd -mapNs :: (Ord n, Ord n') => (n -> n') -> DotGraph n -> DotGraph n' +mapNs :: (Ord n') => (n -> n') -> DotGraph n -> DotGraph n' mapNs f (DG st d as mid cs vs) = DG st d as mid cs $ mapNM vs where @@ -677,7 +691,7 @@ cl = M.mapWithKey addPath $ M.mapKeysMonotonic Just cgs - addPath c as = ( maybe [] (:[]) $ c `M.lookup` pM + addPath c as = ( maybeToList $ c `M.lookup` pM , as ) @@ -685,8 +699,7 @@ (p' Seq.:> _) -> p' _ -> Seq.empty -getNodeInfo :: (Ord n) => Bool -> DotGraph n - -> NodeLookup n +getNodeInfo :: Bool -> DotGraph n -> NodeLookup n getNodeInfo withGlob dg = M.map toLookup ns where (gGlob, aM) = globAttrMap nodeAs dg @@ -699,11 +712,11 @@ as = _attributes ni mp = _inCluster ni pth = fromMaybe Seq.empty $ mp `M.lookup` pM - pAs = fromMaybe gGlob $ flip M.lookup aM =<< mp + pAs = fromMaybe gGlob $ (`M.lookup` aM) =<< mp as' | withGlob = unSame $ toSAttr as `S.union` pAs | otherwise = as -getEdgeInfo :: (Ord n) => Bool -> DotGraph n -> [DotEdge n] +getEdgeInfo :: Bool -> DotGraph n -> [DotEdge n] getEdgeInfo withGlob dg = concatMap (uncurry mkDotEdges) es where gGlob = edgeAs $ graphAttrs dg @@ -732,7 +745,7 @@ where as = af $ clusterAttrs ci p = parentCluster ci - pAs = fromMaybe gGlob $ flip M.lookup aM =<< p + pAs = fromMaybe gGlob $ (`M.lookup` aM) =<< p clusterPath :: DotGraph n -> Map (Maybe GraphID) St.Path clusterPath = M.mapKeysMonotonic Just . M.map (fmap Just) . clusterPath' @@ -747,12 +760,11 @@ pathOf c ci = pPth Seq.|> c where mp = parentCluster ci - pPth = fromMaybe Seq.empty $ flip M.lookup pM =<< mp + pPth = fromMaybe Seq.empty $ (`M.lookup` pM) =<< mp -- ----------------------------------------------------------------------------- -withValues :: (Ord n) => (NodeMap n -> NodeMap n) - -> DotGraph n -> DotGraph n +withValues :: (NodeMap n -> NodeMap n) -> DotGraph n -> DotGraph n withValues f dg = dg { values = f $ values dg } withClusters :: (Map GraphID ClusterInfo -> Map GraphID ClusterInfo) @@ -771,11 +783,16 @@ , EdgeAttrs $ unSame ea ] -niSucc :: (Ord n) => (EdgeMap n -> EdgeMap n) -> NodeInfo n -> NodeInfo n +type UpdateEdgeMap n = (EdgeMap n -> EdgeMap n) -> NodeInfo n -> NodeInfo n + +niSucc :: UpdateEdgeMap n niSucc f ni = ni { _successors = f $ _successors ni } -niPred :: (Ord n) => (EdgeMap n -> EdgeMap n) -> NodeInfo n -> NodeInfo n +niPred :: UpdateEdgeMap n niPred f ni = ni { _predecessors = f $ _predecessors ni } + +niSkip :: UpdateEdgeMap n +niSkip _ ni = ni toMap :: (Ord n) => [(n, Attributes)] -> EdgeMap n toMap = M.fromAscList . groupSortCollectBy fst snd diff --git a/Data/GraphViz/Types/Internal/Common.hs b/Data/GraphViz/Types/Internal/Common.hs new file mode 100644 --- /dev/null +++ b/Data/GraphViz/Types/Internal/Common.hs @@ -0,0 +1,551 @@ +{-# LANGUAGE CPP, OverloadedStrings #-} +{-# OPTIONS_HADDOCK hide #-} + +{- | + Module : Data.GraphViz.Types.Internal.Common + Description : Common internal functions for dealing with overall types. + Copyright : (c) Ivan Lazar Miljenovic + License : 3-Clause BSD-style + Maintainer : Ivan.Miljenovic@gmail.com + + This module provides common functions used by both + "Data.GraphViz.Types" as well as "Data.GraphViz.Types.Generalised". +-} +module Data.GraphViz.Types.Internal.Common + ( GraphID (..) + , Number (..) + , numericValue + , GlobalAttributes (..) + , partitionGlobal + , unPartitionGlobal + , withGlob + , DotNode (..) + , DotEdge (..) + , parseEdgeLine + , printGraphID + , parseGraphID + , printStmtBased + , printStmtBasedList + , printSubGraphID + , parseSubGraph + , parseBracesBased + , parseStatements + ) where + +import Data.GraphViz.Attributes.Complete (Attribute(HeadPort, TailPort), + Attributes, Number(..), + usedByClusters, usedByGraphs, + usedByNodes) +import Data.GraphViz.Attributes.Internal (PortPos, parseEdgeBasedPP) +import Data.GraphViz.Internal.State +import Data.GraphViz.Internal.Util +import Data.GraphViz.Parsing +import Data.GraphViz.Printing + +import Control.Monad (unless, when) +import Data.Maybe (isJust) +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as T +import qualified Data.Text.Lazy.Read as T + +#if !MIN_VERSION_base (4,13,0) +import Data.Monoid ((<>)) +#endif + +-- ----------------------------------------------------------------------------- +-- This is re-exported by Data.GraphViz.Types + +-- | A polymorphic type that covers all possible ID values allowed by +-- Dot syntax. Note that whilst the 'ParseDot' and 'PrintDot' +-- instances for 'String' will properly take care of the special +-- cases for numbers, they are treated differently here. +data GraphID = Str Text + | Num Number + deriving (Eq, Ord, Show, Read) + +instance PrintDot GraphID where + unqtDot (Str str) = unqtDot str + unqtDot (Num n) = unqtDot n + + toDot (Str str) = toDot str + toDot (Num n) = toDot n + +instance ParseDot GraphID where + parseUnqt = stringNum <$> parseUnqt + + parse = stringNum <$> parse + `adjustErr` + ("Not a valid GraphID\n\t"++) + +stringNum :: Text -> GraphID +stringNum str = maybe checkDbl (Num . Int) $ stringToInt str + where + checkDbl = if isNumString True str + then Num . Dbl $ toDouble str + else Str str + +numericValue :: GraphID -> Maybe Int +numericValue (Str str) = either (const Nothing) (Just . round . fst) + $ T.signed T.double str +numericValue (Num n) = case n of + Int i -> Just i + Dbl d -> Just $ round d + +-- ----------------------------------------------------------------------------- + +-- Re-exported by Data.GraphViz.Types.* + +-- | 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 listed 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 + unqtDot = printAttrBased True printGlobAttrType globAttrType attrs + + unqtListToDot = printAttrBasedList True printGlobAttrType globAttrType attrs + + listToDot = unqtListToDot + +-- GraphAttrs, NodeAttrs and EdgeAttrs respectively +partitionGlobal :: [GlobalAttributes] -> (Attributes, Attributes, Attributes) +partitionGlobal = foldr select ([], [], []) + where + select globA ~(gs,ns,es) = case globA of + GraphAttrs as -> (as ++ gs, ns, es) + NodeAttrs as -> (gs, as ++ ns, es) + EdgeAttrs as -> (gs, ns, as ++ es) + +unPartitionGlobal :: (Attributes, Attributes, Attributes) -> [GlobalAttributes] +unPartitionGlobal (gas,nas,eas) = [ GraphAttrs gas + , NodeAttrs nas + , EdgeAttrs eas + ] + +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 + + -- Determine if we need to set the attribute type. + let mtp = globAttrType $ gat [] -- Only need the constructor + oldTp <- getAttributeType + maybe (return ()) setAttributeType mtp + + as <- whitespace *> parse + + -- Safe to set back even if not changed. + setAttributeType oldTp + return $ gat as + `onFail` + fmap determineType parse + + parse = parseUnqt -- Don't want the option of quoting + `adjustErr` + ("Not a valid listing of global attributes\n\t"++) + + -- Have to do this manually because of the special case + parseUnqtList = parseStatements parseUnqt + + parseList = parseUnqtList + +-- Cheat: rather than determine whether it's a graph, cluster or +-- sub-graph just don't set it. +globAttrType :: GlobalAttributes -> Maybe AttributeType +globAttrType NodeAttrs{} = Just NodeAttribute +globAttrType EdgeAttrs{} = Just EdgeAttribute +globAttrType _ = Nothing + +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] + +withGlob :: (Attributes -> Attributes) -> GlobalAttributes -> GlobalAttributes +withGlob f (GraphAttrs as) = GraphAttrs $ f as +withGlob f (NodeAttrs as) = NodeAttrs $ f as +withGlob f (EdgeAttrs as) = EdgeAttrs $ f as + +-- ----------------------------------------------------------------------------- + +-- | A node in 'DotGraph'. +data DotNode n = DotNode { nodeID :: n + , nodeAttributes :: Attributes + } + deriving (Eq, Ord, Show, Read) + +instance (PrintDot n) => PrintDot (DotNode n) where + unqtDot = printAttrBased False printNodeID + (const $ Just NodeAttribute) nodeAttributes + + unqtListToDot = printAttrBasedList False printNodeID + (const $ Just NodeAttribute) nodeAttributes + + listToDot = unqtListToDot + +printNodeID :: (PrintDot n) => DotNode n -> DotCode +printNodeID = toDot . nodeID + +instance (ParseDot n) => ParseDot (DotNode n) where + parseUnqt = parseAttrBased NodeAttribute False parseNodeID + + parse = parseUnqt -- Don't want the option of quoting + + parseUnqtList = parseAttrBasedList NodeAttribute False parseNodeID + + parseList = parseUnqtList + +parseNodeID :: (ParseDot n) => Parse (Attributes -> DotNode n) +parseNodeID = DotNode <$> parseAndCheck + where + parseAndCheck = do n <- parse + me <- optional parseUnwanted + maybe (return n) (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 } + +-- ----------------------------------------------------------------------------- + +-- 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). + +-- | An edge in 'DotGraph'. +data DotEdge n = DotEdge { fromNode :: n + , toNode :: n + , edgeAttributes :: Attributes + } + deriving (Eq, Ord, Show, Read) + +instance (PrintDot n) => PrintDot (DotEdge n) where + unqtDot = printAttrBased False printEdgeID + (const $ Just EdgeAttribute) edgeAttributes + + unqtListToDot = printAttrBasedList False printEdgeID + (const $ Just EdgeAttribute) edgeAttributes + + listToDot = unqtListToDot + +printEdgeID :: (PrintDot n) => DotEdge n -> DotCode +printEdgeID e = do isDir <- getDirectedness + toDot (fromNode e) + <+> bool undirEdge' dirEdge' isDir + <+> toDot (toNode e) + + +instance (ParseDot n) => ParseDot (DotEdge n) where + parseUnqt = parseAttrBased EdgeAttribute False parseEdgeID + + parse = parseUnqt -- Don't want the option of quoting + + -- Have to take into account edges of the type "n1 -> n2 -> n3", etc. + parseUnqtList = concat <$> parseStatements parseEdgeLine + + parseList = parseUnqtList + +parseEdgeID :: (ParseDot n) => Parse (Attributes -> DotEdge n) +parseEdgeID = ignoreSep mkEdge parseEdgeNode parseEdgeType parseEdgeNode + `adjustErr` + ("Parsed beginning of DotEdge but could not parse Attributes:\n\t"++) + -- Parse both edge types just to be more liberal + +type EdgeNode n = (n, Maybe PortPos) + +-- | Takes into account edge statements containing something like +-- @a -> \{b c\}@. +parseEdgeNodes :: (ParseDot n) => Parse [EdgeNode n] +parseEdgeNodes = oneOf [ parseBraced (wrapWhitespace + -- Should really use sepBy1, but this will do. + $ parseStatements parseEdgeNode) + , sepBy1 parseEdgeNode (wrapWhitespace parseComma) + , (: []) <$> parseEdgeNode + ] + +parseEdgeNode :: (ParseDot n) => Parse (EdgeNode n) +parseEdgeNode = liftA2 (,) parse + (optional $ character ':' *> parseEdgeBasedPP) + +mkEdge :: EdgeNode n -> EdgeNode n -> Attributes -> DotEdge n +mkEdge (eFrom, mFP) (eTo, mTP) = DotEdge eFrom eTo + . addPortPos TailPort mFP + . addPortPos HeadPort mTP + +mkEdges :: [EdgeNode n] -> [EdgeNode n] + -> Attributes -> [DotEdge n] +mkEdges fs ts as = liftA2 (\f t -> mkEdge f t as) fs ts + +addPortPos :: (PortPos -> Attribute) -> Maybe PortPos + -> Attributes -> Attributes +addPortPos c = maybe id ((:) . c) + +parseEdgeType :: Parse Bool +parseEdgeType = wrapWhitespace $ stringRep True dirEdge + `onFail` + stringRep False undirEdge + +parseEdgeLine :: (ParseDot n) => Parse [DotEdge n] +parseEdgeLine = do n1 <- parseEdgeNodes + ens <- many1 $ parseEdgeType *> parseEdgeNodes + let ens' = n1 : ens + efs = zipWith mkEdges ens' (tail ens') + ef = return $ \ as -> concatMap ($as) efs + parseAttrBased EdgeAttribute False ef + +instance Functor DotEdge where + fmap f e = e { fromNode = f $ fromNode e + , toNode = f $ toNode e + } + +dirEdge :: String +dirEdge = "->" + +dirEdge' :: DotCode +dirEdge' = text $ T.pack dirEdge + +undirEdge :: String +undirEdge = "--" + +undirEdge' :: DotCode +undirEdge' = text $ T.pack undirEdge + +-- ----------------------------------------------------------------------------- +-- Labels + +dirGraph :: String +dirGraph = "digraph" + +dirGraph' :: DotCode +dirGraph' = text $ T.pack dirGraph + +undirGraph :: String +undirGraph = "graph" + +undirGraph' :: DotCode +undirGraph' = text $ T.pack undirGraph + +strGraph :: String +strGraph = "strict" + +strGraph' :: DotCode +strGraph' = text $ T.pack strGraph + +sGraph :: String +sGraph = "subgraph" + +sGraph' :: DotCode +sGraph' = text $ T.pack sGraph + +clust :: String +clust = "cluster" + +clust' :: DotCode +clust' = text $ T.pack clust + +-- ----------------------------------------------------------------------------- + +printGraphID :: (a -> Bool) -> (a -> Bool) + -> (a -> Maybe GraphID) + -> a -> DotCode +printGraphID str isDir mID g = do setDirectedness isDir' + bool empty strGraph' (str g) + <+> bool undirGraph' dirGraph' isDir' + <+> maybe empty toDot (mID g) + where + isDir' = isDir g + +parseGraphID :: (Bool -> Bool -> Maybe GraphID -> a) -> Parse a +parseGraphID f = do whitespace + str <- isJust <$> optional (parseAndSpace $ string strGraph) + dir <- parseAndSpace ( stringRep True dirGraph + `onFail` + stringRep False undirGraph + ) + setDirectedness dir + gID <- optional $ parseAndSpace parse + return $ f str dir gID + +printStmtBased :: (a -> DotCode) -> (a -> AttributeType) + -> (a -> stmts) -> (stmts -> DotCode) + -> a -> DotCode +printStmtBased f ftp r dr a = do gs <- getsGS id + setAttributeType $ ftp a + dc <- printBracesBased (f a) (dr $ r a) + modifyGS (const gs) + return dc + +printStmtBasedList :: (a -> DotCode) -> (a -> AttributeType) + -> (a -> stmts) -> (stmts -> DotCode) + -> [a] -> DotCode +printStmtBasedList f ftp r dr = vcat . mapM (printStmtBased f ftp r dr) + +-- Can't use the 'braces' combinator here because we want the closing +-- brace lined up with the h value, which due to indentation might not +-- be the case with braces. +printBracesBased :: DotCode -> DotCode -> DotCode +printBracesBased h i = vcat $ sequence [ h <+> lbrace + , ind i + , rbrace + ] + where + ind = indent 4 + +-- | This /must/ only be used for sub-graphs, etc. +parseBracesBased :: AttributeType -> Parse a -> Parse a +parseBracesBased tp p = do gs <- getsGS id + setAttributeType tp + a <- whitespace *> parseBraced (wrapWhitespace p) + modifyGS (const gs) + return a + `adjustErr` + ("Not a valid value wrapped in braces.\n\t"++) + +printSubGraphID :: (a -> (Bool, Maybe GraphID)) -> a -> DotCode +printSubGraphID f a = sGraph' + <+> maybe cl dtID mID + where + (isCl, mID) = f a + cl = bool empty clust' isCl + dtID = printSGID isCl + +-- | Print the actual ID for a 'DotSubGraph'. +printSGID :: Bool -> GraphID -> DotCode +printSGID isCl sID = bool noClust addClust isCl + where + noClust = toDot sID + -- Have to manually render it as we need the un-quoted form. + addClust = toDot . T.append (T.pack clust) . T.cons '_' + . renderDot $ mkDot sID + mkDot (Str str) = text str -- Quotes will be escaped later + mkDot gid = unqtDot gid + +parseSubGraph :: (Bool -> Maybe GraphID -> stmt -> c) -> Parse stmt -> Parse c +parseSubGraph pid pst = do (isC, fID) <- parseSubGraphID pid + let tp = bool SubGraphAttribute ClusterAttribute isC + fID <$> parseBracesBased tp pst + +parseSubGraphID :: (Bool -> Maybe GraphID -> c) -> Parse (Bool,c) +parseSubGraphID f = appl <$> (string sGraph *> whitespace1 *> parseSGID) + where + appl (isC, mid) = (isC, f isC mid) + +parseSGID :: Parse (Bool, Maybe GraphID) +parseSGID = oneOf [ getClustFrom <$> parseAndSpace parse + , return (False, Nothing) + ] + where + -- If it's a String value, check to see if it's actually a + -- cluster_Blah value; thus need to manually re-parse it. + getClustFrom (Str str) = runParser' pStr str + getClustFrom gid = (False, Just gid) + + checkCl = stringRep True clust + pStr = do isCl <- checkCl + `onFail` + return False + when isCl $ optional (character '_') *> return () + sID <- optional pID + let sID' = if sID == emptyID + then Nothing + else sID + return (isCl, sID') + + emptyID = Just $ Str "" + + -- For Strings, there are no more quotes to unescape, so consume + -- what you can. + pID = stringNum <$> manySatisfy (const True) + +{- This is a much nicer definition, but unfortunately it doesn't work. + The problem is that Graphviz decides that a subgraph is a cluster + if the ID starts with "cluster" (no quotes); thus, we _have_ to do + the double layer of parsing to get it to work :@ + + do isCl <- stringRep True clust + `onFail` + return False + sID <- optional $ do when isCl + $ optional (character '_') *> return () + parseUnqt + when (isCl || isJust sID) $ whitespace1 *> return () + return (isCl, sID) +-} + +-- The Bool is True for global, False for local. +printAttrBased :: Bool -> (a -> DotCode) -> (a -> Maybe AttributeType) + -> (a -> Attributes) -> a -> DotCode +printAttrBased prEmp ff ftp fas a = do oldType <- getAttributeType + maybe (return ()) setAttributeType mtp + oldCS <- getColorScheme + (dc <> semi) <* unless prEmp (setColorScheme oldCS) + <* setAttributeType oldType + where + mtp = ftp a + f = ff a + dc = case fas a of + [] | not prEmp -> f + as -> f <+> toDot as + +-- The Bool is True for global, False for local. +printAttrBasedList :: Bool -> (a -> DotCode) -> (a -> Maybe AttributeType) + -> (a -> Attributes) -> [a] -> DotCode +printAttrBasedList prEmp ff ftp fas = vcat . mapM (printAttrBased prEmp ff ftp fas) + +-- The Bool is True for global, False for local. +parseAttrBased :: AttributeType -> Bool -> Parse (Attributes -> a) -> Parse a +parseAttrBased tp lc p = do oldType <- getAttributeType + setAttributeType tp + oldCS <- getColorScheme + f <- p + atts <- tryParseList' (whitespace *> parse) + unless lc $ setColorScheme oldCS + when (tp /= oldType) $ setAttributeType oldType + return $ f atts + `adjustErr` + ("Not a valid attribute-based structure\n\t"++) + +-- The Bool is True for global, False for local. +parseAttrBasedList :: AttributeType -> Bool -> Parse (Attributes -> a) -> Parse [a] +parseAttrBasedList tp lc = parseStatements . parseAttrBased tp lc + +-- | Parse the separator (and any other whitespace1 present) between statements. +statementEnd :: Parse () +statementEnd = parseSplit *> newline' + where + parseSplit = (whitespace *> oneOf [ character ';' *> return () + , newline + ] + ) + `onFail` + whitespace1 + +parseStatements :: Parse a -> Parse [a] +parseStatements p = sepBy (whitespace *> p) statementEnd + `discard` + optional statementEnd diff --git a/Data/GraphViz/Types/Monadic.hs b/Data/GraphViz/Types/Monadic.hs --- a/Data/GraphViz/Types/Monadic.hs +++ b/Data/GraphViz/Types/Monadic.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} +{-# LANGUAGE CPP, FlexibleInstances, MultiParamTypeClasses #-} {- | Module : Data.GraphViz.Types.Monadic @@ -64,25 +64,38 @@ , nodeAttrs , edgeAttrs -- * Adding items to the graph. - -- ** Clusters + -- ** Subgraphs and clusters + , subgraph + , anonSubgraph , cluster -- ** Nodes , node , node' -- ** Edges + -- $edges , edge , (-->) , (<->) ) where -import Data.GraphViz.Attributes(Attributes) -import Data.GraphViz.Types.Common +import Data.GraphViz.Attributes (Attributes) import Data.GraphViz.Types.Generalised -import qualified Data.DList as DL -import Data.DList(DList) +import Data.DList (DList) +import qualified Data.DList as DL import qualified Data.Sequence as Seq +#if !(MIN_VERSION_base (4,8,0)) +import Control.Applicative (Applicative(..)) +import Data.Monoid (Monoid(..)) +#endif + +#if MIN_VERSION_base (4,9,0) && !MIN_VERSION_base (4,13,0) +import Data.Semigroup (Semigroup(..)) +#endif + +import Control.Monad.Fix (MonadFix (mfix)) + -- ----------------------------------------------------------------------------- -- The Dot monad. @@ -97,14 +110,35 @@ execDot :: DotM n a -> DotStmts n execDot = snd . runDot +instance Functor (DotM n) where + fmap f (DotM (a,stmts)) = DotM (f a, stmts) + +instance Applicative (DotM n) where + pure = DotM . flip (,) DL.empty + + (DotM (f,stmts1)) <*> (DotM (a,stmts2)) = DotM (f a, stmts1 `DL.append` stmts2) + instance Monad (DotM n) where - return a = DotM (a, DL.empty) + return = pure dt >>= f = DotM $ let ~(a,stmts) = runDot dt ~(b,stmts') = runDot $ f a in (b, stmts `DL.append` stmts') +instance MonadFix (DotM n) where + mfix m = let (a,n) = runDot $ m a + in DotM (a,n) + +#if MIN_VERSION_base (4,9,0) +instance Semigroup a => Semigroup (DotM n a) where + DotM x1 <> DotM x2 = DotM (x1 <> x2) +#endif + +instance Monoid a => Monoid (DotM n a) where + mappend (DotM x1) (DotM x2) = DotM (mappend x1 x2) + mempty = DotM mempty + tell :: DotStmts n -> Dot n tell = DotM . (,) () @@ -149,21 +183,21 @@ convertStatements = Seq.fromList . map convertStatement . DL.toList data DotStmt n = MA GlobalAttributes - | MC (Cluster n) + | MS (Subgraph n) | MN (DotNode n) | ME (DotEdge n) convertStatement :: DotStmt n -> DotStatement n convertStatement (MA gas) = GA gas -convertStatement (MC cl) = SG . DotSG True (Just $ clID cl) - . execStmts $ clStmts cl +convertStatement (MS sg) = SG . DotSG (sgIsClust sg) (sgID sg) + . execStmts $ sgStmts sg convertStatement (MN dn) = DN dn convertStatement (ME de) = DE de -- ----------------------------------------------------------------------------- -- Global Attributes --- | Add graph/sub-graph/cluster attributes. +-- | Add graph\/sub-graph\/cluster attributes. graphAttrs :: Attributes -> Dot n graphAttrs = tellStmt . MA . GraphAttrs @@ -176,15 +210,32 @@ edgeAttrs = tellStmt . MA . EdgeAttrs -- ----------------------------------------------------------------------------- --- Clusters +-- Subgraphs (including Clusters) -data Cluster n = Cl { clID :: GraphID - , clStmts :: Dot n - } +data Subgraph n = Sg { sgIsClust :: Bool + , sgID :: Maybe GraphID + , sgStmts :: Dot n + } +-- | Add a named subgraph to the graph. +subgraph :: GraphID -> DotM n a -> Dot n +subgraph = nonClust . Just + +-- | Add an anonymous subgraph to the graph. +-- +-- It is highly recommended you use 'subgraph' instead. +anonSubgraph :: DotM n a -> Dot n +anonSubgraph = nonClust Nothing + +nonClust :: Maybe GraphID -> DotM n a -> Dot n +nonClust = createSubGraph False + +createSubGraph :: Bool -> Maybe GraphID -> DotM n a -> Dot n +createSubGraph isCl mid = tellStmt . MS . Sg isCl mid . (>> return ()) + -- | Add a named cluster to the graph. -cluster :: GraphID -> DotM n a -> Dot n -cluster cid = tellStmt . MC . Cl cid . (>> return ()) +cluster :: GraphID -> DotM n a -> Dot n +cluster = createSubGraph True . Just -- ----------------------------------------------------------------------------- -- Nodes @@ -195,11 +246,28 @@ -- | Add a node with no attributes to the graph. node' :: n -> Dot n -node' = flip node [] +node' = (`node` []) -- ----------------------------------------------------------------------------- -- Edges +{- $edges + + If you wish to use something analogous to Dot's ability to write + multiple edges with in-line subgraphs such as: + + > {a b c} -> {d e f} + + Then you can use '-->' and '<->' in combination with monadic + traversal functions such as @traverse_@, @for_@, @mapM_@, @forM_@ + and @zipWithM_@; for example: + + > ("a" -->) `traverse_` ["d", "e", "f"] + > ["a", "b", "c"] `for_` (--> "d") + > zipWithM_ (-->) ["a", "b", "c"] ["d", "e", "f"] + + -} + -- | Add an edge to the graph. edge :: n -> n -> Attributes -> Dot n edge f t = tellStmt . ME . DotEdge f t @@ -217,4 +285,3 @@ infixr 9 <-> -- ----------------------------------------------------------------------------- - diff --git a/Data/GraphViz/Types/State.hs b/Data/GraphViz/Types/State.hs --- a/Data/GraphViz/Types/State.hs +++ b/Data/GraphViz/Types/State.hs @@ -34,22 +34,22 @@ , addEdge ) where -import Data.GraphViz.Types.Common -import Data.GraphViz.Attributes.Complete( Attributes - , usedByClusters, usedByGraphs) +import Data.GraphViz.Attributes.Complete (Attributes, usedByClusters, + usedByGraphs) import Data.GraphViz.Attributes.Same +import Data.GraphViz.Types.Internal.Common -import Data.Function(on) -import qualified Data.DList as DList -import Data.DList(DList) -import qualified Data.Map as Map -import Data.Map(Map) -import qualified Data.Set as Set -import qualified Data.Sequence as Seq -import Data.Sequence(Seq, (|>), ViewL(..)) -import Control.Arrow((&&&), (***)) -import Control.Monad(when) -import Control.Monad.Trans.State +import Control.Arrow ((&&&), (***)) +import Control.Monad (when) +import Control.Monad.State (State, execState, gets, modify) +import Data.DList (DList) +import qualified Data.DList as DList +import Data.Function (on) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Sequence (Seq, ViewL(..), (|>)) +import qualified Data.Sequence as Seq +import qualified Data.Set as Set -- ----------------------------------------------------------------------------- @@ -121,7 +121,7 @@ getGraphInfo :: GraphState a -> (GlobalAttributes, ClusterLookup) getGraphInfo = ((graphGlobal . globalAttrs) &&& (convert . value)) - . flip execState initState + . (`execState` initState) where convert = Map.map ((uniq . DList.toList) *** toGlobal) toGlobal = GraphAttrs . filter usedByClusters . unSame @@ -160,19 +160,19 @@ type NodeLookup' n = Map n NodeInfo -data NodeInfo = NI { atts :: SAttrs - , gAtts :: SAttrs -- from globals +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 :: 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 +getNodeLookup :: Bool -> NodeState n a -> NodeLookup n +getNodeLookup addGs = Map.map combine . value . (`execState` initState) where initState = SV Set.empty addGs Seq.empty Map.empty combine ni = (location ni, unSame $ atts ni `Set.union` gAtts ni) @@ -230,7 +230,7 @@ type EdgeState n a = GVState (DList (DotEdge n)) a getDotEdges :: Bool -> EdgeState n a -> [DotEdge n] -getDotEdges addGs = DList.toList . value . flip execState initState +getDotEdges addGs = DList.toList . value . (`execState` initState) where initState = SV Set.empty addGs Seq.empty DList.empty @@ -242,4 +242,4 @@ addEdge de@DotEdge{edgeAttributes = as} = do gas <- getGlobals let de' = de { edgeAttributes = unSame $ unionWith gas as } - modifyValue $ flip DList.snoc de' + modifyValue $ (`DList.snoc` de') diff --git a/Data/GraphViz/Util.hs b/Data/GraphViz/Util.hs deleted file mode 100644 --- a/Data/GraphViz/Util.hs +++ /dev/null @@ -1,165 +0,0 @@ -{-# LANGUAGE OverloadedStrings, PatternGuards #-} -{-# OPTIONS_HADDOCK hide #-} - -{- | - Module : Data.GraphViz.Util - Description : Internal utility functions - Copyright : (c) Ivan Lazar Miljenovic - License : 3-Clause BSD-style - Maintainer : Ivan.Miljenovic@gmail.com - - This module defines internal utility functions. --} -module Data.GraphViz.Util where - -import Data.Char( isAsciiUpper - , isAsciiLower - , isDigit - , ord - ) - -import Data.List(groupBy, sortBy) -import Data.Maybe(isJust) -import Data.Function(on) -import qualified Data.Set as Set -import Data.Set(Set) -import qualified Data.Text.Lazy as T -import qualified Data.Text.Lazy.Read as T -import Data.Text.Lazy(Text) -import Control.Monad(liftM2) - --- ----------------------------------------------------------------------------- - -isIDString :: Text -> Bool -isIDString = maybe False (\(f,os) -> frstIDString f && T.all restIDString os) - . T.uncons - --- | First character of a non-quoted 'String' must match this. -frstIDString :: Char -> Bool -frstIDString c = any ($c) [ isAsciiUpper - , isAsciiLower - , (==) '_' - , (\ x -> ord x >= 128) - ] - --- | The rest of a non-quoted 'String' must match this. -restIDString :: Char -> Bool -restIDString c = frstIDString c || isDigit c - --- | Determine if this String represents a number. -isNumString :: Text -> Bool -isNumString "" = False -isNumString "-" = False -isNumString str = case T.uncons $ T.toLower str of - Just ('-',str') -> go str' - _ -> go str - where - -- Can't use Data.Text.Lazy.Read.double as it doesn't cover all - -- possible cases - go s = uncurry go' $ T.span isDigit s - go' ds nds - | T.null nds = True - | T.null ds && nds == "." = False - | T.null ds - , Just ('.',nds') <- T.uncons nds - , Just (d,nds'') <- T.uncons nds' = isDigit d && checkEs' nds'' - | Just ('.',nds') <- T.uncons nds = checkEs $ T.dropWhile isDigit nds' - | T.null ds = False - | otherwise = checkEs nds - checkEs' s = case T.break ('e' ==) s of - ("", _) -> False - (ds,es) -> T.all isDigit ds && checkEs es - checkEs str' = case T.uncons str' of - Nothing -> True - Just ('e',ds) -> isIntString ds - _ -> False - -{- --- | This assumes that 'isNumString' is 'True'. -toDouble :: Text -> Double -toDouble str = case T.uncons $ T.toLower str of - Just ('-', str') -> toD $ '-' `T.cons` adj str' - _ -> toD $ adj str - where - adj s = T.cons '0' - $ case T.span ('.' ==) s of - (ds, ".") | not $ T.null ds -> s `T.snoc` '0' - (ds, ds') | Just ('.',es) <- T.uncons ds' - , Just ('e',es') <- T.uncons es - -> ds `T.snoc` '.' `T.snoc` '0' - `T.snoc` 'e' `T.snoc` '0' `T.append` es' - _ -> s - toD = either (const $ error "Not a Double") fst . T.signed T.double --} --- | This assumes that 'isNumString' is 'True'. -toDouble :: Text -> Double -toDouble str = case T.uncons $ T.toLower str of - Just ('-', str') -> toD $ '-' `T.cons` adj str' - _ -> toD $ adj str - where - adj s = T.cons '0' - $ case T.span ('.' ==) s of - (ds, ".") | not $ T.null ds -> s `T.snoc` '0' - (ds, ds') | Just ('.',es) <- T.uncons ds' - , Just ('e',_) <- T.uncons es - -> ds `T.snoc` '.' `T.snoc` '0' `T.append` es - _ -> s - toD = read . T.unpack - -isIntString :: Text -> Bool -isIntString = isJust . stringToInt - --- | Determine if this String represents an integer. -stringToInt :: Text -> Maybe Int -stringToInt str = case T.signed T.decimal str of - Right (n, "") -> Just n - _ -> Nothing - --- | Graphviz requires double quotes to be explicitly escaped. -escapeQuotes :: String -> String -escapeQuotes [] = [] -escapeQuotes ('"':str) = '\\':'"': escapeQuotes str -escapeQuotes (c:str) = c : escapeQuotes str - --- | Remove explicit escaping of double quotes. -descapeQuotes :: String -> String -descapeQuotes [] = [] -descapeQuotes ('\\':'"':str) = '"' : descapeQuotes str -descapeQuotes (c:str) = c : descapeQuotes str - -isKeyword :: Text -> Bool -isKeyword = flip Set.member keywords . T.toLower - --- | The following are Dot keywords and are not valid as labels, etc. unquoted. -keywords :: Set Text -keywords = Set.fromList [ "node" - , "edge" - , "graph" - , "digraph" - , "subgraph" - , "strict" - ] - --- ----------------------------------------------------------------------------- - -uniq :: (Ord a) => [a] -> [a] -uniq = uniqBy id - -uniqBy :: (Ord b) => (a -> b) -> [a] -> [a] -uniqBy f = map head . groupSortBy f - -groupSortBy :: (Ord b) => (a -> b) -> [a] -> [[a]] -groupSortBy f = groupBy ((==) `on` f) . sortBy (compare `on` f) - -groupSortCollectBy :: (Ord b) => (a -> b) -> (a -> c) -> [a] -> [(b,[c])] -groupSortCollectBy f g = map (liftM2 (,) (f . head) (map g)) . groupSortBy f - --- | Fold over 'Bool's; first param is for 'False', second for 'True'. -bool :: a -> a -> Bool -> a -bool f t b = if b - then t - else f - -isSingle :: [a] -> Bool -isSingle [_] = True -isSingle _ = False diff --git a/FAQ b/FAQ deleted file mode 100644 --- a/FAQ +++ /dev/null @@ -1,644 +0,0 @@ -% FAQ -% Ivan Lazar Miljenovic - -Fortuitously Anticipated Queries (FAQ) -====================================== - -Note that to distinguish it from [Graphviz], the library shall be -henceforth referred to as _graphviz_. - -Graphviz vs _graphviz_ ----------------------- - -### What is the difference between Graphviz and _graphviz_? ### - -[Graphviz] is an open source library and collection of utility -programs using that library to visualise [graphs] (which are specified -using the [Dot] language). - -_graphviz_ is a library for the purely functional programming language -[Haskell] that provides "bindings" to Graphviz's programs. It does so -by allowing programmers to specify the layout of the graph and then -converts that to Dot code before calling the appropriate program to -perform the visualisation. - -[Graphviz]: http://www.graphviz.org/ -[graphs]: http://en.wikipedia.org/wiki/Graph_theory -[Dot]: http://www.graphviz.org/doc/info/lang.html -[Haskell]: http://haskell.org/ - -### Why should I use graphviz over one of the other Haskell Graphviz libraries? ### - -Various Haskell libraries have support for Graphviz to one extent or -another; however _graphviz_ has the most comprehensive support -available out of all of them: - -* There are [four different representations] of Dot graphs: - - 1. Canonical, which matches the layout of `dot -Tcanon`. - 2. Generalised, which allows statements to be in any order. - 3. A graph-based one that allows manipulation of the Dot graph. - 4. A monadic interface for embedding graphs in Haskell. - - There are also conversion functions between them. - - [four different representations]: #whats-the-difference-between-the-different-dotgraph-types - -* The ability to parse and generate most aspects of Dot [syntax] and - [attributes]. This includes taking into account escaping and - quoting rules where applicable. - - [syntax]: http://graphviz.org/doc/info/lang.html - [attributes]: http://graphviz.org/doc/info/attrs.html - -* The ability to use a custom node type for Dot graphs. - -* Support for the all five layout algorithm programs and all specified - [output formats] as well as the ability to use custom programs, etc. - - [output formats]: http://www.graphviz.org/doc/info/output.html - -* Functions to convert [FGL] graphs and other graph-like structures - (albeit not as nicely) to and from the internal Dot representations. - In future, this will be expanded to a much larger range of - graph-like values once a suitable abstraction is available. - - [FGL]: http://web.engr.oregonstate.edu/~erwig/fgl/haskell/ - -* The ability to augment Dot and FGL graphs with positioning - information by round-trip passing through Graphviz. - -* Pure Haskell implementations of `dot -Tcanon` and `tred`. - -* _graphviz_ is continually being worked upon and expanded to better - suit/match the requirements of Graphviz, to improve performance and - to make it easier for the programmer to use. - -### Is the API of _graphviz_ stable? ### - -For the most part, yes: the only items that are likely to change in -the future are those with bugs/errors or if a radically better way of -doing things is found. For most uses, however, the API should not -change for the foreseeable future. - -Note that _graphviz_'s version numbers follow the -[package versioning policy]; this means that you can immediately tell -when the API has had a backwards-incompatible change by comparing the -first two elements of the version. However, these changes won't -always affect most users. - -[package versioning policy]: http://www.haskell.org/haskellwiki/Package_versioning_policy - -### What aspects of Dot syntax and attributes are covered? ### - -It's easier to state which aspects of Dot [syntax] and [attributes] -_aren't_ covered: - -#### Overall syntax items not covered #### - -* Cannot specify a sub-graph as an end point in an edge; - -* Comments, pre-processor lines and split lines are (currently) not - supported within HTML-like labels. - -* _graphviz_ only uses UTF-8 encoding for printing and parsing - (whereas Graphviz allows Latin1 encoding with the `charset` - attribute). - -* Graphviz is more liberal in accepting "invalid" values - (e.g. accepting a floating-point value when only integer values are - meant to be accepted); _graphviz_ is more strict in this aspect (and - will indeed throw an exception if it cannot parse something - properly). - -* No extensions (e.g. postscript-specific attributes) are available. - -#### Attribute and value items not covered #### - -* The global `orientation` attribute is not defined; however its - behaviour is duplicated by the `rotate` attribute. - -* The deprecated `overlap` algorithms have not been defined. - -* `pointf` and `point` values have been combined into one datatype; as - such, when constructing values such as `Rect` care should be taken - about which parts of a `Point` are allowed. - -* Only polygon-based `shape`s are available. - -* The `charset` attribute is not available as _graphviz_ assumes that - all Dot graphs will be in UTF-8 for simplicity; if Latin1-encoded - graphs need to be parsed then you shall need to do all I/O for them - by hand. - -* `colorscheme` attributes _are_ parsed, but the behaviour is not - quite the same: consider the following minimal Dot graph: - - ~~~~~ {.dot} - digraph { - a [ style=filled, fillcolor=gray, colorscheme=svg ] - } - ~~~~~ - - Despite the fact that the color is specified before the colorscheme, - Graphviz will use that colorscheme to parse the color (as an SVG - gray differs from the X11 gray); _graphviz_, however, will use the - default colorscheme of `x11` to parse the color, and **then** set - the colorscheme to be `svg` (despite it not being used after it is - set). - -#### Available items of note #### - -There are a few items of note that are available that are worthy of -special note (as they may not be immediately obvious from the -generated documentation): - -* _graphviz_ is able to parse (but not print) the following special - aspects of specifying edges in Dot code: - - - The `node:port` method of specifying of head/tail `portPos` - values. - - - Stating multiple edges with common interior nodes (e.g. `a -> b - -> c`). - - - Stating edges with a grouping of nodes (e.g. `a -> {b c}`). - -* Sub-graphs are specified as being clusters when the subgraph name - starts with either `"cluster"` or `"cluster_"`; note that this - prefix is removed when determining the subraph's name for the - internal datatypes. - -* Anonymous subgraphs (where not even the `subgraph` keyword is - specified) are also parseable. - -* HTML-like and record labels are available, and feature proper - escaping/unescaping when printing/parsing. - -* Other syntactic issues are taken care of for you automatically (such - as escaping/unescaping quotation marks). Even newlines are - automatically escaped (but not unescaped) for you, defaulting to - centered lines. - -Getting _graphviz_ and more documentation ------------------------------------------ - -### Where can I obtain _graphviz_? ### - -The best place to get _graphviz_ is from its [HackageDB] page. - -[HackageDB]: http://hackage.haskell.org/package/graphviz - -### Where can I find the API documentation for _graphviz_? ### - -Also on its [HackageDB] page. - -### Is it safe to install and use _graphviz_ from its darcs repository? ### - -No; unlike other projects I make no guarantees as to the stability of -the live version of _graphviz_. Whilst the [darcs] [repository] is -_usually_ stable, it's often in a state of flux and at times patches -that break the repository are recorded (when it's simpler/cleaner to -break one patch into several smaller patches). - -[darcs]: http://darcs.net/ -[repository]: http://code.haskell.org/graphviz/ - -### How is _graphviz_ licensed? ### - -_graphviz_ is licensed under a [3-Clause BSD License] (note that the -ColorBrewer Color Schemes found in `Data.GraphViz.Attributes.Colors.Brewer` -are covered under -[their own license](http://graphviz.org/doc/info/colors.html#brewer_license)). - -[3-Clause BSD License]: http://www.opensource.org/licenses/bsd-license.php - -Simplistically, this means that you can do whatever you want with -_graphviz_ as long as you cite both myself and [Matthew Sackman] (the -original author) as being the authors of _graphviz_. However, I would -appreciate at least an [email] letting me know how _graphviz_ is being -used. - -[Matthew Sackman]: http://www.wellquite.org/ -[email]: mailto:Ivan.Miljenovic+graphviz@gmail.com - -### Where can I find more information on _graphviz_? ### - -From its [home page]. - -[home page]: http://projects.haskell.org/graphviz/ - -### Are there any tutorials on how to use _graphviz_? ### - -A basic tutorial on -[how to visualise graph-like data](http://ivanmiljenovic.wordpress.com/2011/10/16/graphviz-in-vacuum/) -is available; more will come if people ask for it. - -### What other packages use _graphviz_? ### - -This is a list of all known packages that use _graphviz_: if you know -of any others please let me know and I'll add it to the list. - -* [Graphalyze](http://hackage.haskell.org/package/Graphalyze) -* [SourceGraph](http://hackage.haskell.org/package/SourceGraph) - -### What is the history of _graphviz_? ### - -_graphviz_ was originally written by [Matthew Sackman] (if you want -his reasons for doing so, you'll have to ask him yourself) with the -first known release being on 10 July, 2008. In 2008 I (Ivan -Miljenovic) needed a library that provided bindings to Graphviz with -clustering support; at the time _graphviz_ was the most fully featured -and closest to what I wanted, so I submitted a patch that provided -support for both clustering and undirected graphs. - -In April 2009, Matthew wanted to step down from maintaining _graphviz_ -and asked if I wanted to take over. Since then the library has been -almost completely re-written with greatly improved coverage of the Dot -language and extra features. However, the original outline of the -library still remains. - -Using _graphviz_ ----------------- - -### Can I start using _graphviz_ without knowing anything about Graphviz? ### - -You can, but if you want to start doing anything more advanced then -you should be reading Graphviz's documentation as well as -_graphviz_'s. This is because the layout and design of _graphviz_ is -heavily based upon the Dot language and the various [attributes] that -Graphviz supports. - -### Can I just use _graphviz_ without reading its documentation? ### - -You should _at least_ read the various messages about possible -ambiguities, etc. at the top of each module and for the attributes you -use before you use _graphviz_. - -### Do I need to have Graphviz installed to use _graphviz_? ### - -Technically, no if you're only dealing with the Dot language aspects. -However, usage of the functions in the `Commands` module, or the -augmentation of pretty-printing functions in the GraphViz module _do_ -require Graphviz to be installed. - -### Why didn't you use FFI to bind to the Graphviz library? ### - -Because I just kept working where [Matthew Sackman] left off and it -was already using Graphviz's tools rather than the actual library. -However, most other language bindings (for Python, Perl, etc.) seem to -do the same: generate Dot code and pass that to the relevant tool. - -This, however, does provide a fortunate side effect where the ability -to print and parse Dot code means that _graphviz_ can be used for more -than just visualising graphs created solely in Haskell: it can also -import pre-defined graphs, or else generate Dot code for use with -other tools. - -### What's the difference between the different DotGraph types? ### - -_graphviz_ has four different "implementations" of Dot code: - -**Canonical:** - -: matches the output of `dot -Tcanon`. Recommended for use when - converting existing data into Dot (especially with the - `graphElemsToDot` function in `Data.GraphViz`). - -**Generalised:** - -: most closely matches the layout of actual Dot code, as such this is - preferred when parsing in arbitrary Dot graphs. Also useful in - cases where you want to use the common Graphviz "hack" of specifying - global attributes that don't apply to sub-graphs _after_ the - sub-graphs in question. - -**Graph:** - -: provides common graph operations on Dot graphs, based upon those - found in the [FGL]. - -**Monadic:** - -: a nicer way of defining relatively static Dot graphs to embed within - Haskell code, etc. Loosely based (with permission!) upon Andy - Gill's [dotgen] library. - -[dotgen]: http://hackage.haskell.org/package/dotgen - -### What's the best way to parse Dot code? ### - -In both cases below, you should use the `parseDotGraph` function to -parse the Dot code: this is because it will strip out comments and -pre-processor lines and join together split lines (if any of these -remain the parser will fail). Also, if you are not sure what the type -of the nodes are, use either String or else the `GraphID` type as it -explicitly caters for both Strings and numbers (whereas just assuming -it being a String will result in numbers being stored internally as a -String). - -If you can, first run `dot -Tcanon` on the Dot code and parse it as a -`DotGraph` value. This is because `DotGraph` types are easier to deal -with. - -If, however, this isn't possible (e.g. it uses an image that isn't in -the current working directory) then use the `GDotGraph` type. - -### There are too many attributes!!! Which ones should I use? ### - -The `Data.GraphViz.Attributes` module contains a cut-down list of -recommended and commonly used attributes. - -The entire list of attributes can be found in -`Data.GraphViz.Attributes.Complete`. In particular, the following -attributes are **not** recommended for use: - -* `Color` for anything except edge colours or gradients for nodes, - clusters and graphs when using Graphviz >= 2.29.0 (and if you must, - the border colour for a node). - -* `ColorScheme`: just stick with X11 colours. - -* `Comment`: pretty useless. Enough said. - -### Can I use any attribute wherever I want? ### - -No: attributes are all defined in one big datatype for the sake of -simplicity, but not all attributes are valid in all places. Read the -documentation (either for Graphviz or _graphviz_) to determine which is -suitable where. - -### How can I use _graphviz_ to visualise non-FGL graphs? ### - -The `graphElemsToDot` function allows you to visualise any graph for -which you can specify a list of labelled nodes and a list of labelled -edges. - -### How can I use/process multiple graphs like Graphviz does? ### - -At one stage, _graphviz_ supported dealing with lists of `DotGraph`s; -however, it was found to be faster to deal with each graph -individually rather than try to get Graphviz to deal with them all in -one go. In future, once the problem causing this has been tracked -down and fixed this feature will be returned. - -### How can I use custom datatypes for node IDs? ### - -The important thing here is to ensure that your custom datatype has -defined instances of `PrintDot` and `ParseDot`. Probably the easiest -way of doing this is to have functions that convert between your type -and `String` and let graphviz determine how to print and parse those. -Here is an example of a more difficult type that should be printed -like `"1: Foo"`: - -~~~~~~~~~~~~~~~~~~~~ {.haskell} -data MyType = MyType String Int - -instance PrintDot MyType where - unqtDot (MyType s i) = unqtDot i <> colon <+> unqtDot s - - -- We have a space in there, so we need quotes. - toDot = doubleQuotes . unqtDot - -instance ParseDot MyType where - parseUnqt = do i <- parseUnqt - character ':' - whitespace1 - s <- parseUnqt - return $ MyType s i - - -- Has at least one space, so it will be quoted. - parse = quotedParse parseUnqt -~~~~~~~~~~~~~~~~~~~~ - -Things to note from this example: - -* Whilst `PrintDot` and `ParseDot` have default definitions for - `toDot` and `parse`, they assume the datatype doesn't need quotes; - as such if the value will - [need quoting](http://www.graphviz.org/doc/info/lang.html), then you - should do so explicitly. - -* It is better to use the `PrintDot` instances for common types such - as `Int` and `String` rather than using the pretty-printers inbuilt - conversion functions (`int`, `text`, etc.) to ensure that - quotations, etc. are dealt with correctly. - -* Be as liberal as you can when parsing, especially with whitespace: - when printing only one space is used, yet when parsing we use the - `whitespace1` parsing combinator that will parse all whitespace - characters (but it must consume _at least_ one; there is a variant - that does not need to parse any). - -### When parsing Dot code, do I have to worry about the case? ### - -Not at all: _graphviz_'s parser is case-insensitive; however, the -correct case is checked first so there is a slight degradation in -performance when the wrong case is used. - -### How do I set portPos values for nodes in edges? ### - -Graphviz allows you to specify edges such as `from:a -> to:b` where -the nodes "from" and "to" are defined with either `RecordLabel` or -`Html.Label` labels and have different sections; the edge is then drawn -from the "a" section of the "from" node to the "b" section of the "to" -node. - -Whilst _graphviz_ can parse this, you can't define this yourself; -instead, do it the manual way: - -~~~~~~~~~~~~~~~~~~~~ {.haskell} -DotEdge "from" "to" True [ TailPort (LabelledPort (PN "a") Nothing) - , HeadPort (LabelledPort (PN "b") Nothing) - ] -~~~~~~~~~~~~~~~~~~~~ - -I realise that doing this manually isn't as convenient, but I am open -to suggestions on how this can be improved. - -Note where `TailPort` and `HeadPort` are used; the next question -explains this. - -### Is there anything else I should know? ### - -A few other things of note that you should know about: - -* For an edge `a -> b`, Graphviz terms "a" to be the _tail_ node and - "b" to be the _head_ node. - -* When creating `GraphID` values for the graphs and sub-graphs, you - should ensure that they won't clash with any of the `nodeID` values - when printed to avoid possible problems. - -* It is a good idea to have unique IDs for sub-graphs to ensure that - global attributes are applied only to items in that sub-graph and so - that clusters aren't combined (it took me a _long_ time to find out - that this was the case). - -* You should specify an ID for the overall graph when outputting to a - format such as SVG as it becomes the title of that image. - -* Graphviz allows a node to be "defined" twice with different - attributes; in practice they are combined into one node. Running - Dot code through `dot -Tcanon` before parsing removes this problem. - -* Several attributes are defined with taking a list of items; all of - these assume that the provided lists are non-empty (sub-values are a - different story). - -* If a particular Dot graph is not parseable, the parser throws an - error rather than failing gracefully. - -Design Decisions ----------------- - -### Why does _graphviz_ use Polyparse rather than Parsec? ### - -Short answer: because _graphviz_ was already using [Polyparse] when I -started working on it (and I hadn't done any parsing before so I had -no preference either way). - -[Polyparse]: http://www.cs.york.ac.uk/fp/polyparse/ - -Longer answer: Polyparse has several advantages I feel over [Parsec]: - -* Simpler types. -* Avoids the whole "but Parsec-3 is slower than Parsec-2" debate (with - its associated baggage/problems). -* Few inbuilt combinators: since there is no inbuilt `character` - parsing combinator, there are no problems with _graphviz_ using its - own case-less one. -* [Easier backtracking](http://www.cs.york.ac.uk/fp/polyparse/#how) - -[Parsec]: http://hackage.haskell.org/package/parsec - -### Why do you have four different representations of Dot graphs? ### - -_graphviz_ has [four different representations] of Dot graphs. Apart -from the reasons given before, the canonical implementation was the -original representation, whereas the generalised one was only -introduced in the 2999.8.0.0 release and the other two in the -2999.12.0.0 release. - -Note, however, that I was thinking of adding something like the -generalised implementation back around the time of the -[2999.0.0.0 release](http://www.haskell.org/pipermail/haskell-cafe/2009-July/064436.html), -yet -[people didn't like the idea](http://www.haskell.org/pipermail/haskell-cafe/2009-July/064442.html). - -The graph-based implementation was added solely so I could write as -(un-yet finished) tutorial, and thought others might find it useful. -The monadic implementation came about as an attempt to encourage more -people to use _graphviz_ rather than other libraries such as [dotgen], -and I thought a nicer way of writing Dot graphs might help (the -initial plans involved complicated type-hackery to try and almost make -it a DSL for actual Dot code; however it ended up being too -complicated and unwieldy). - -### Why are only FGL graphs supported? ### - -Love them or hate them, [FGL] currently provides the best graph -datatype and library available for Haskell at this time. As such, if -any one graph type had to be chosen to have conversion functions -written for it then FGL is the best option. Furthermore, I needed FGL -graph support (which is the much more important reason!). - -### Why are the version numbers so high? ### - -To make sure the latest release has the highest version number: -Matthew Sackman originally made releases with date-based versioning, -but when I switched to using the [package versioning policy] I had to -change this. I could have started with 2010.x.y.z or so, but at the -time I had initial hopes of introducing compatibility with other -graphs (not just [FGL] ones) soon and wanted to make that the -3000.0.0.0 release; however that has not yet come to pass. - -### Why do you use the American spelling of colour in _graphviz_? ### - -Because that's how Graphviz spells it, and I was following upstream to -avoid confusion. - -Bugs, Feature Requests and Development --------------------------------------- - -### Do you have any future plans for _graphviz_? ### - -Yes, I do! See the TODO file for more information. - -### Does _graphviz_ have a test suite? ### - -Yes, there is: to get it, you have to build it with the `test` flag -enabled; for example: - -~~~~~~~~~~~~~~~~~~~~ {.bash} -cabal install graphviz --flags=test -~~~~~~~~~~~~~~~~~~~~ - -Then run the `graphviz-testsuite` executable. This test suite uses -[QuickCheck] to ensure that _graphviz_ can parse the Dot code it -generates (as well as a few other things). Note that it isn't -perfect: there are no guarantees that the Dot graphs that are -generated are indeed valid, and those more extensive tests are not yet -available. - -[QuickCheck]: http://hackage.haskell.org/package/QuickCheck - -Furthermore, you can do more controlled testing to try and track down -the source of a bug as the above flag will also expose several -testing modules which give you access to the various tests used as -well as the `Arbitrary` instances for use with [QuickCheck]. - -For proper testing of real-life Dot code, there is also the -`TestParsing.hs` script that comes in the _graphviz_ tarball (but is -not installed). Once you have _graphviz_ installed you can just run -this script, passing it any files containing Dot graphs you wish to -test. It will attempt to parse each Dot graph as a `GDotGraph`, and -then test to see if the canonicalised form is parseable as a -`DotGraph`. - -### I've found a bug! ### - -Oh-oh... please [email] me the specifics of what you were doing -(including the Dot file in question if it's a parsing problem) and -I'll get right on it. - -### I have a feature request. ### - -Is it in the TODO? If not, [email] me and I'll consider implementing -it (depending on time and how well I think it will fit in the overall -library). - -### I want to help out with developing _graphviz_. ### - -Great! Whether you have a specific feature in mind or want to help -clear the TODO list, please [email] me to check with what you're doing -(who knows, I could already be implementing that very feature). - -Once we've discussed what you're going to do, first get yourself a -copy of the darcs repository: - -~~~~~~~~~~~~~~~~~~~~ {.bash} -darcs get --lazy http://code.haskell.org/graphviz -~~~~~~~~~~~~~~~~~~~~ - -Once you've made your changes, make sure you build and run the -testsuite (and ensure it passes!). Then record the patch[es] and -`darcs send` them. I'll then review them and if I'm happy with them, -I'll apply them. - -### What is the purpose of the AttributeGenerator.hs file? ### - -Graphviz has a large number of attributes. Rather than try to edit -everything manually each time I want to change how I use the large -`Attribute` datatype, the AttributeGenerator script generates the -datatype, instances, etc. for me. - - - - - diff --git a/FAQ.md b/FAQ.md new file mode 100644 --- /dev/null +++ b/FAQ.md @@ -0,0 +1,624 @@ + +Fortuitously Anticipated Queries (FAQ) +====================================== + +Note that to distinguish it from [Graphviz], the library shall be +henceforth referred to as _graphviz_. + +Graphviz vs _graphviz_ +---------------------- + +### What is the difference between Graphviz and _graphviz_? ### + +[Graphviz] is an open source library and collection of utility +programs using that library to visualise [graphs] (which are specified +using the [Dot] language). + +_graphviz_ is a library for the purely functional programming language +[Haskell] that provides "bindings" to Graphviz's programs. It does so +by allowing programmers to specify the layout of the graph and then +converts that to Dot code before calling the appropriate program to +perform the visualisation. + +[Graphviz]: http://www.graphviz.org/ +[graphs]: http://en.wikipedia.org/wiki/Graph_theory +[Dot]: http://www.graphviz.org/doc/info/lang.html +[Haskell]: http://haskell.org/ + +### Why should I use graphviz over one of the other Haskell Graphviz libraries? ### + +Various Haskell libraries have support for Graphviz to one extent or +another; however _graphviz_ has the most comprehensive support +available out of all of them: + +* There are [four different representations] of Dot graphs: + + 1. Canonical, which provides a clean separated definition of a + Dot graph (that matches the former layout of `dot -Tcanon`). + 2. Generalised, which allows statements to be in any order. + 3. A graph-based one that allows manipulation of the Dot graph. + 4. A monadic interface for embedding relatively static graphs + in Haskell. + + There are also conversion functions between them. + + [four different representations]: #whats-the-difference-between-the-different-dotgraph-types + +* The ability to parse and generate most aspects of Dot [syntax] and + [attributes]. This includes taking into account escaping and + quoting rules where applicable. + + [syntax]: http://graphviz.org/doc/info/lang.html + [attributes]: http://graphviz.org/doc/info/attrs.html + +* The ability to use a custom node type for Dot graphs. + +* Support for all stated layout algorithm programs and all specified + [output formats] as well as the ability to use custom programs, etc. + + [output formats]: http://www.graphviz.org/doc/info/output.html + +* Functions to convert [FGL] graphs and other graph-like structures + (albeit not as nicely) to and from the internal Dot representations. + In future, this will be expanded to a much larger range of + graph-like values once a suitable abstraction is available. + + [FGL]: http://web.engr.oregonstate.edu/~erwig/fgl/haskell/ + +* The ability to augment Dot and FGL graphs with positioning + information by round-trip passing through Graphviz. + +* Pure Haskell implementations of `dot -Tcanon` and `tred`. + +* _graphviz_ is continually being worked upon and expanded to better + suit/match the requirements of Graphviz, to improve performance and + to make it easier for the programmer to use. + +### Is the API of _graphviz_ stable? ### + +For the most part, yes: the only items that are likely to change in +the future are those with bugs/errors or if a radically better way of +doing things is found. For most uses, however, the API should not +change for the foreseeable future. + +Note that _graphviz_'s version numbers follow the +[package versioning policy]; this means that you can immediately tell +when the API has had a backwards-incompatible change by comparing the +first two elements of the version. However, these changes won't +always affect most users. + +[package versioning policy]: http://www.haskell.org/haskellwiki/Package_versioning_policy + +### What aspects of Dot syntax and attributes are covered? ### + +It's easier to state which aspects of Dot [syntax] and [attributes] +_aren't_ covered: + +#### Overall syntax items not covered #### + +* Cannot specify a sub-graph as an end point in an edge; + +* Comments, pre-processor lines and split lines are (currently) not + supported within HTML-like labels. + +* _graphviz_ only uses UTF-8 encoding for printing and parsing + (whereas Graphviz allows Latin1 encoding with the `charset` + attribute). + +* Graphviz is more liberal in accepting "invalid" values + (e.g. accepting a floating-point value when only integer values are + meant to be accepted); _graphviz_ is more strict in this aspect (and + will indeed throw an exception if it cannot parse something + properly). + +* No extensions (e.g. postscript-specific attributes) are available. + +#### Attribute and value items not covered #### + +* The global `orientation` attribute is not defined; however its + behaviour is duplicated by the `rotate` attribute. + +* The deprecated `overlap` algorithms have not been defined, and the + ability to specify an integer prefix for use with the `fdp` layout + tool is not available. + +* The deprecated `shapefile` attribute is not available; instead, you + should specify the file on the command line. + +* The deprecated `z` attribute is not available; use the optional + third dimension for the `pos` attribute instead. + +* Only polygon-based `shape`s are available (i.e. no custom shapes as + yet). + +* The `charset` attribute is not available as _graphviz_ assumes that + all Dot graphs will be in UTF-8 for simplicity; if Latin1-encoded + graphs need to be parsed then you shall need to do all I/O for them + by hand. + +* `colorscheme` attributes _are_ parsed, but the behaviour is not + quite the same: consider the following minimal Dot graph: + + ~~~~~ {.dot} + digraph { + a [ style=filled, fillcolor=gray, colorscheme=svg ] + } + ~~~~~ + + Despite the fact that the color is specified before the colorscheme, + Graphviz will use that colorscheme to parse the color (as an SVG + gray differs from the X11 gray); _graphviz_, however, will use the + default colorscheme of `x11` to parse the color, and **then** set + the colorscheme to be `svg` (despite it not being used after it is + set). + +#### Available items of note #### + +There are a few items of note that are available that are worthy of +special note (as they may not be immediately obvious from the +generated documentation): + +* _graphviz_ is able to parse (but not print) the following special + aspects of specifying edges in Dot code: + + - The `node:port` method of specifying of head/tail `portPos` + values. + + - Stating multiple edges with common interior nodes (e.g. `a -> b + -> c`). + + - Stating edges with a grouping of nodes (e.g. `a -> {b c}`). + +* Sub-graphs are specified as being clusters when the subgraph name + starts with either `"cluster"` or `"cluster_"`; note that this + prefix is removed when determining the subraph's name for the + internal datatypes. + +* Anonymous subgraphs (where not even the `subgraph` keyword is + specified) are also parseable. + +* HTML-like and record labels are available, and feature proper + escaping/unescaping when printing/parsing. + +* Other syntactic issues are taken care of for you automatically (such + as escaping/unescaping quotation marks). Even newlines are + automatically escaped (but not unescaped) for you, defaulting to + centered lines. + +Getting _graphviz_ and more documentation +----------------------------------------- + +### Where can I obtain _graphviz_? ### + +The best place to get _graphviz_ is from its [HackageDB] page. + +[HackageDB]: http://hackage.haskell.org/package/graphviz + +### Where can I find the API documentation for _graphviz_? ### + +Also on its [HackageDB] page. + +### Is it safe to install and use _graphviz_ from its git repository? ### + +No; unlike other projects I make no guarantees as to the stability of +the live version of _graphviz_. Whilst the [git] [repository] is +_usually_ stable, it's often in a state of flux and at times patches +that break the repository are recorded (when it's simpler/cleaner to +break one patch into several smaller patches). + +[git]: http://git-scm.com/ +[repository]: https://github.com/ivan-m/graphviz/ + +### How is _graphviz_ licensed? ### + +_graphviz_ is licensed under a [3-Clause BSD License] (note that the +ColorBrewer Color Schemes found in `Data.GraphViz.Attributes.Colors.Brewer` +are covered under +[their own license](http://graphviz.org/doc/info/colors.html#brewer_license)). + +[3-Clause BSD License]: http://www.opensource.org/licenses/bsd-license.php + +Simplistically, this means that you can do whatever you want with +_graphviz_ as long as you cite both myself and [Matthew Sackman] (the +original author) as being the authors of _graphviz_. However, I would +appreciate at least an [email] letting me know how _graphviz_ is being +used. + +[Matthew Sackman]: http://www.wellquite.org/ +[email]: mailto:Ivan.Miljenovic@gmail.com + +### Where can I find more information on _graphviz_? ### + +From its [home page]. + +[home page]: http://projects.haskell.org/graphviz/ + +### Are there any tutorials on how to use _graphviz_? ### + +A basic tutorial on +[how to visualise graph-like data](http://ivanmiljenovic.wordpress.com/2011/10/16/graphviz-in-vacuum/) +is available; more will come if people ask for it. + +### What other packages use _graphviz_? ### + +This is a list of all known packages that use _graphviz_: if you know +of any others please let me know and I'll add it to the list. + +* [Graphalyze](http://hackage.haskell.org/package/Graphalyze) +* [SourceGraph](http://hackage.haskell.org/package/SourceGraph) + +### What is the history of _graphviz_? ### + +_graphviz_ was originally written by [Matthew Sackman] (if you want +his reasons for doing so, you'll have to ask him yourself) with the +first known release being on 10 July, 2008. In 2008 I (Ivan +Miljenovic) needed a library that provided bindings to Graphviz with +clustering support; at the time _graphviz_ was the most fully featured +and closest to what I wanted, so I submitted a patch that provided +support for both clustering and undirected graphs. + +In April 2009, Matthew wanted to step down from maintaining _graphviz_ +and asked if I wanted to take over. Since then the library has been +almost completely re-written with greatly improved coverage of the Dot +language and extra features. However, the original outline of the +library still remains. + +Using _graphviz_ +---------------- + +### Can I start using _graphviz_ without knowing anything about Graphviz? ### + +You can, but if you want to start doing anything more advanced then +you should be reading Graphviz's documentation as well as +_graphviz_'s. This is because the layout and design of _graphviz_ is +heavily based upon the Dot language and the various [attributes] that +Graphviz supports. + +### Can I just use _graphviz_ without reading its documentation? ### + +You should _at least_ read the various messages about possible +ambiguities, etc. at the top of each module and for the attributes you +use before you use _graphviz_. + +### Do I need to have Graphviz installed to use _graphviz_? ### + +Technically, no if you're only dealing with the Dot language aspects. +However, usage of the functions in the `Commands` module, or the +augmentation of pretty-printing functions in the GraphViz module _do_ +require Graphviz to be installed. + +### Why didn't you use FFI to bind to the Graphviz library? ### + +Because I just kept working where [Matthew Sackman] left off and it +was already using Graphviz's tools rather than the actual library. +However, most other language bindings (for Python, Perl, etc.) seem to +do the same: generate Dot code and pass that to the relevant tool. + +This, however, does provide a fortunate side effect where the ability +to print and parse Dot code means that _graphviz_ can be used for more +than just visualising graphs created solely in Haskell: it can also +import pre-defined graphs, or else generate Dot code for use with +other tools. + +### What's the difference between the different DotGraph types? ### + +_graphviz_ has four different "implementations" of Dot code: + +**Canonical:** + +: matches the (former) output of `dot -Tcanon`. Recommended for use + when converting existing data into Dot (especially with the + `graphElemsToDot` function in `Data.GraphViz`). + +**Generalised:** + +: most closely matches the layout of actual Dot code, as such this is + preferred when parsing in arbitrary Dot graphs. Also useful in + cases where you want to use the common Graphviz "hack" of specifying + global attributes that don't apply to sub-graphs _after_ the + sub-graphs in question. + +**Graph:** + +: provides common graph operations on Dot graphs, based upon those + found in the [FGL]. + +**Monadic:** + +: a nicer way of defining relatively static Dot graphs to embed within + Haskell code, etc. Loosely based (with permission!) upon Andy + Gill's [dotgen] library. + +[dotgen]: http://hackage.haskell.org/package/dotgen + +### What's the best way to parse Dot code? ### + +Use the `parseDotGraph` function (rather than the general parsing +functions that are available) to parse your Dot code: this is will +strip out comments and pre-processor lines and join together split +lines (if any of these remain the parser will fail). Also, if you are +not sure what the type of the nodes are, use either String or else the +`GraphID` type as it explicitly caters for both Strings and numbers +(whereas just assuming it being a String will result in numbers being +stored internally as a String). + +Unless you are very sure of the representation of the Dot code you +have been provided, you should parse in any Dot code as the +`Generalised.DotGraph` type. Afterwards you can use +`FromGeneralisedDot` to convert to whichever representation you +prefer. + +### There are too many attributes!!! Which ones should I use? ### + +The `Data.GraphViz.Attributes` module contains a cut-down list of +recommended and commonly used attributes. + +The entire list of attributes can be found in +`Data.GraphViz.Attributes.Complete`. In particular, the following +attributes are **not** recommended for use: + +* `Color` for anything except edge colours or gradients for nodes, + clusters and graphs when using Graphviz >= 2.29.0 (and if you must, + the border colour for a node). + +* `ColorScheme`: just stick with X11 colours. + +* `Comment`: pretty useless. Enough said. + +### Can I use any attribute wherever I want? ### + +No: attributes are all defined in one big datatype for the sake of +simplicity, but not all attributes are valid in all places. Read the +documentation (either for Graphviz or _graphviz_) to determine which is +suitable where. + +### How can I use _graphviz_ to visualise non-FGL graphs? ### + +The `graphElemsToDot` function allows you to visualise any graph for +which you can specify a list of labelled nodes and a list of labelled +edges. + +### How can I use/process multiple graphs like Graphviz does? ### + +At one stage, _graphviz_ supported dealing with lists of `DotGraph`s; +however, it was found to be faster to deal with each graph +individually rather than try to get Graphviz to deal with them all in +one go. In future, once the problem causing this has been tracked +down and fixed this feature will be returned. + +### How can I use custom datatypes for node IDs? ### + +The important thing here is to ensure that your custom datatype has +defined instances of `PrintDot` and `ParseDot`. Probably the easiest +way of doing this is to have functions that convert between your type +and `String` or `Text` and let graphviz determine how to print and +parse those. Here is an example of a more difficult type that should +be printed like `"1: Foo"`: + +~~~~~~~~~~~~~~~~~~~~ {.haskell} +data MyType = MyType Int String + +instance PrintDot MyType where + unqtDot (MyType i s) = unqtDot i <> colon <+> unqtDot s + + -- We have a space in there, so we need quotes. + toDot = doubleQuotes . unqtDot + +instance ParseDot MyType where + parseUnqt = MyType <$> parseUnqt + <* character ':' + <* whitespace1 + <*> parseUnqt + + -- Has at least one space, so it will be quoted. + parse = quotedParse parseUnqt +~~~~~~~~~~~~~~~~~~~~ + +Things to note from this example: + +* Whilst `PrintDot` and `ParseDot` have default definitions for + `toDot` and `parse`, they assume the datatype doesn't need quotes; + as such if the value will + [need quoting](http://www.graphviz.org/doc/info/lang.html), then you + should do so explicitly. + +* It is better to use the `PrintDot` instances for common types such + as `Int` and `String` rather than using the pretty-printers inbuilt + conversion functions (`int`, `text`, etc.) to ensure that + quotations, etc. are dealt with correctly. + +* Be as liberal as you can when parsing, especially with whitespace: + when printing only one space is used, yet when parsing we use the + `whitespace1` parsing combinator that will parse all whitespace + characters (but it must consume _at least_ one; there is a variant + that does not need to parse any). + +### When parsing Dot code, do I have to worry about the case? ### + +Not at all: _graphviz_'s parser is case-insensitive; however, the +correct case is checked first so there is a slight degradation in +performance when the wrong case is used. + +### How do I set portPos values for nodes in edges? ### + +Graphviz allows you to specify edges such as `from:a -> to:b` where +the nodes "from" and "to" are defined with either `RecordLabel` or +`Html.Label` labels and have different sections; the edge is then drawn +from the "a" section of the "from" node to the "b" section of the "to" +node. + +Whilst _graphviz_ can parse this, you can't define this yourself; +instead, do it the manual way: + +~~~~~~~~~~~~~~~~~~~~ {.haskell} +DotEdge "from" "to" True [ TailPort (LabelledPort (PN "a") Nothing) + , HeadPort (LabelledPort (PN "b") Nothing) + ] +~~~~~~~~~~~~~~~~~~~~ + +I realise that doing this manually isn't as convenient, but I am open +to suggestions on how this can be improved. + +Note where `TailPort` and `HeadPort` are used; the next question +explains this. + +### Is there anything else I should know? ### + +A few other things of note that you should know about: + +* For an edge `a -> b`, Graphviz terms "a" to be the _tail_ node and + "b" to be the _head_ node. + +* When creating `GraphID` values for the graphs and sub-graphs, you + should ensure that they won't clash with any of the `nodeID` values + when printed to avoid possible problems. + +* It is a good idea to have unique IDs for sub-graphs to ensure that + global attributes are applied only to items in that sub-graph and so + that clusters aren't combined (it took me a _long_ time to find out + that this was the case). + +* You should specify an ID for the overall graph when outputting to a + format such as SVG as it becomes the title of that image. + +* Graphviz allows a node to be "defined" twice with different + attributes; in practice they are combined into one node. Running + Dot code through `dot -Tcanon` before parsing removes this problem. + +* Several attributes are defined with taking a list of items; all of + these assume that the provided lists are non-empty (sub-values are a + different story). + +* If a particular Dot graph is not parseable, the parser throws an + error rather than failing gracefully. + +Design Decisions +---------------- + +### Why does _graphviz_ use Polyparse rather than Parsec? ### + +Short answer: because _graphviz_ was already using [Polyparse] when I +started working on it (and I hadn't done any parsing before so I had +no preference either way). + +[Polyparse]: http://www.cs.york.ac.uk/fp/polyparse/ + +Longer answer: Polyparse has several advantages I feel over [Parsec]: + +* Simpler types. +* Avoids the whole "but Parsec-3 is slower than Parsec-2" debate (with + its associated baggage/problems). +* Few inbuilt combinators: since there is no inbuilt `character` + parsing combinator, there are no problems with _graphviz_ using its + own case-less one. +* [Easier backtracking](http://www.cs.york.ac.uk/fp/polyparse/#how) + +[Parsec]: http://hackage.haskell.org/package/parsec + +### Why do you have four different representations of Dot graphs? ### + +_graphviz_ has [four different representations] of Dot graphs. Apart +from the reasons given before, the canonical implementation was the +original representation, whereas the generalised one was only +introduced in the 2999.8.0.0 release and the other two in the +2999.12.0.0 release. + +Note, however, that I was thinking of adding something like the +generalised implementation back around the time of the +[2999.0.0.0 release](http://www.haskell.org/pipermail/haskell-cafe/2009-July/064436.html), +yet +[people didn't like the idea](http://www.haskell.org/pipermail/haskell-cafe/2009-July/064442.html). + +The graph-based implementation was added solely so I could write an +(as-yet finished) tutorial, and thought others might find it useful. +The monadic implementation came about as an attempt to encourage more +people to use _graphviz_ rather than other libraries such as [dotgen], +and I thought a nicer way of writing Dot graphs might help (the +initial plans involved complicated type-hackery to try and almost make +it a DSL for actual Dot code; however it ended up being too +complicated and unwieldy). + +### Why are only FGL graphs supported? ### + +Love them or hate them, [FGL] currently provides the best graph +datatype and library available for Haskell at this time. As such, if +any one graph type had to be chosen to have conversion functions +written for it then FGL is the best option. Furthermore, I needed FGL +graph support (which is the much more important reason!). + +### Why are the version numbers so high? ### + +To make sure the latest release has the highest version number: +Matthew Sackman originally made releases with date-based versioning, +but when I switched to using the [package versioning policy] I had to +change this. I could have started with 2010.x.y.z or so, but at the +time I had initial hopes of introducing compatibility with other +graphs (not just [FGL] ones) soon and wanted to make that the +3000.0.0.0 release; however that has not yet come to pass. + +### Why do you use the American spelling of colour in _graphviz_? ### + +Because that's how Graphviz spells it, and I was following upstream to +avoid confusion. + +Bugs, Feature Requests and Development +-------------------------------------- + +### Do you have any future plans for _graphviz_? ### + +Yes, I do! See the TODO file for more information. + +### Does _graphviz_ have a test suite? ### + +Yes, there is, using the in-built support for test suites in Cabal: + +~~~~~~~~~~~~~~~~~~~~ {.bash} +cabal install graphviz --enable-tests +~~~~~~~~~~~~~~~~~~~~ + +Then run the `graphviz-testsuite` executable. This test suite uses +[QuickCheck] to ensure that _graphviz_ can parse the Dot code it +generates (as well as a few other things). Note that it isn't +perfect: there are no guarantees that the Dot graphs that are +generated are indeed valid, and those more extensive tests are not yet +available. + +[QuickCheck]: http://hackage.haskell.org/package/QuickCheck + +Furthermore, you can do more controlled testing to try and track down +the source of a bug as the above flag will also expose several +testing modules which give you access to the various tests used as +well as the `Arbitrary` instances for use with [QuickCheck]. + +For proper testing of real-life Dot code, there is also the +`TestParsing.hs` script that comes in the _graphviz_ tarball (but is +not installed). Once you have _graphviz_ installed you can just run +this script, passing it any files containing Dot graphs you wish to +test. It will attempt to parse each Dot graph as a +`Generalised.DotGraph`, and then test to see if the canonicalised form +is parseable as a `DotGraph`. + +### I've found a bug! ### + +Oh-oh... please file a report at the GitHub [repository] to tell me +the specifics of what you were doing (including the Dot file in +question if it's a parsing problem) and I'll get right on it. + +### I have a feature request. ### + +Is it in the TODO? If not, file an issue at the GitHub [repository] +and I'll consider implementing it (depending on time and how well I +think it will fit in the overall library). + +### I want to help out with developing _graphviz_. ### + +Great! Whether you have a specific feature in mind or want to help +clear the TODO list, please create a pull-request on the GitHub +[repository]. + +### What is the purpose of the AttributeGenerator.hs file? ### + +Graphviz has a large number of attributes. Rather than try to edit +everything manually each time I want to change how I use the large +`Attribute` datatype, the AttributeGenerator script generates the +datatype, instances, etc. for me. diff --git a/LICENSE b/LICENSE deleted file mode 100644 --- a/LICENSE +++ /dev/null @@ -1,106 +0,0 @@ -% License -% Ivan Lazar Miljenovic - -Licensing Information -===================== - -The overall graphviz library is covered by a [3-Clause BSD License]. -However, the _ColorBrewer_ colours are licensed under their own -license. - -[3-Clause BSD License]: http://www.opensource.org/licenses/bsd-license.php - -License for graphviz --------------------- - -Copyright (c) 2008, Matthew Sackman - -Copyright (c) 2008 - 2010, [Ivan Lazar Miljenovic](mailto:Ivan.Miljenovic+graphviz@gmail.com) - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials - provided with the distribution. - - * The names of the contributors to this software may not be used - to endorse or promote products derived from this software - without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -The ColorBrewer license ------------------------ - -> The _ColorBrewer_ colours and colour schemes found in -> `Data.GraphViz.Attributes.Colors` are covered by the following -> license. This text is not part of the license. - -Apache-Style Software License for ColorBrewer software and ColorBrewer -Color Schemes, Version 1.1 - -Copyright (c) 2002 Cynthia Brewer, Mark Harrower, and The Pennsylvania -State University. All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - 1. Redistributions as source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - 2. The end-user documentation included with the redistribution, if - any, must include the following acknowledgment: - - This product includes color specifications and designs developed - by Cynthia Brewer (http://colorbrewer.org/). - - Alternately, this acknowledgment may appear in the software - itself, if and wherever such third-party acknowledgments - normally appear. - - 3. The name "ColorBrewer" must not be used to endorse or promote - products derived from this software without prior written - permission. For written permission, please contact Cynthia - Brewer at cbrewer@psu.edu. - - 4. Products derived from this software may not be called - "ColorBrewer", nor may "ColorBrewer" appear in their name, - without prior written permission of Cynthia Brewer. - -THIS SOFTWARE IS PROVIDED "AS IS" AND ANY EXPRESSED OR IMPLIED -WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF -MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL CYNTHIA BREWER, MARK HARROWER, OR THE -PENNSYLVANIA STATE UNIVERSITY BE LIABLE FOR ANY DIRECT, INDIRECT, -INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, -BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS -OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND -ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR -TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE -USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH -DAMAGE. - - diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,98 @@ + +Licensing Information +===================== + +The overall graphviz library is covered by a [3-Clause BSD License]. +However, the _ColorBrewer_ colours are licensed under their own +license. + +[3-Clause BSD License]: http://www.opensource.org/licenses/bsd-license.php + +License for graphviz +-------------------- + +Copyright (c) 2008, Matthew Sackman + +Copyright (c) 2008 - 2010, [Ivan Lazar Miljenovic](mailto:Ivan.Miljenovic+graphviz@gmail.com) + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials + provided with the distribution. + + * The names of the contributors to this software may not be used + to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +The ColorBrewer license +----------------------- + +> The _ColorBrewer_ colours and colour schemes found in +> `Data.GraphViz.Attributes.Colors` are covered by the following +> license. This text is not part of the license. + +Apache-Style Software License for ColorBrewer software and ColorBrewer +Color Schemes, Version 1.1 + +Copyright (c) 2002 Cynthia Brewer, Mark Harrower, and The Pennsylvania +State University. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + 1. Redistributions as source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. The end-user documentation included with the redistribution, if + any, must include the following acknowledgment: + + This product includes color specifications and designs developed + by Cynthia Brewer (http://colorbrewer.org/). + + Alternately, this acknowledgment may appear in the software + itself, if and wherever such third-party acknowledgments + normally appear. + + 3. The name "ColorBrewer" must not be used to endorse or promote + products derived from this software without prior written + permission. For written permission, please contact Cynthia + Brewer at cbrewer@psu.edu. + + 4. Products derived from this software may not be called + "ColorBrewer", nor may "ColorBrewer" appear in their name, + without prior written permission of Cynthia Brewer. + +THIS SOFTWARE IS PROVIDED "AS IS" AND ANY EXPRESSED OR IMPLIED +WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL CYNTHIA BREWER, MARK HARROWER, OR THE +PENNSYLVANIA STATE UNIVERSITY BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, +BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS +OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR +TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +DAMAGE. diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -1,64 +0,0 @@ -% Haskell bindings to the Graphviz toolkit -% Ivan Lazar Miljenovic - -The graphviz Library -==================== - -The _graphviz_ library provides bindings to the [Graphviz] graph -visualisation suite of tools for the purely functional programming -language [Haskell]. It can be downloaded from [HackageDB] or - if you -have [cabal-install] - installing it is as simple as: - -~~~~~~~~~~~~~~~~~~~~ {.bash} -cabal update -cabal install graphviz -~~~~~~~~~~~~~~~~~~~~ - -[Graphviz]: http://www.graphviz.org/ -[Haskell]: http://haskell.org/ -[HackageDB]: http://hackage.haskell.org/package/graphviz -[cabal-install]: http://haskell.org/haskellwiki/Cabal-Install - -Library features ----------------- - -Main features of the graphviz library include: - -* Almost complete coverage of all Graphviz attributes and syntax. - -* Support for specifying clusters. - -* The ability to use a custom node type. - -* Functions for running a Graphviz layout tool with all specified - output types. - -* The ability to not only generate but also parse Dot code with two - options: strict and liberal (in terms of ordering of statements). - -* Functions to convert [FGL] graphs and other graph-like data - structures to Dot code - including support to group them into - clusters - with a high degree of customisation by specifying which - attributes to use and limited support for the inverse operation. - -* Round-trip support for passing an [FGL] graph through Graphviz to - augment node and edge labels with positional information, etc. - -[FGL]: http://web.engr.oregonstate.edu/~erwig/fgl/haskell/ - -graphviz is free software licensed under a [3-Clause BSD License]. - -\(C\) 2008 [Matthew Sackman](http://www.wellquite.org/) - -\(C\) 2008 - onwards [Ivan Lazar Miljenovic](http://ivanmiljenovic.wordpress.com/) - -[3-Clause BSD License]: http://www.opensource.org/licenses/bsd-license.php - -For more information, feel free to -[email](mailto:Ivan.Miljenovic+graphviz@gmail.com) me. - - diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,53 @@ + +The graphviz Library +==================== + +The _graphviz_ library provides bindings to the [Graphviz] graph +visualisation suite of tools for the purely functional programming +language [Haskell]. It can be downloaded from [HackageDB] or - if you +have [cabal-install] - installing it is as simple as: + +~~~~~~~~~~~~~~~~~~~~ {.bash} +cabal update +cabal install graphviz +~~~~~~~~~~~~~~~~~~~~ + +[Graphviz]: http://www.graphviz.org/ +[Haskell]: http://haskell.org/ +[HackageDB]: http://hackage.haskell.org/package/graphviz +[cabal-install]: http://haskell.org/haskellwiki/Cabal-Install + +Library features +---------------- + +Main features of the graphviz library include: + +* Almost complete coverage of all Graphviz attributes and syntax. + +* Support for specifying clusters. + +* The ability to use a custom node type. + +* Functions for running a Graphviz layout tool with all specified + output types. + +* The ability to not only generate but also parse Dot code with two + options: strict and liberal (in terms of ordering of statements). + +* Functions to convert [FGL] graphs and other graph-like data + structures to Dot code - including support to group them into + clusters - with a high degree of customisation by specifying which + attributes to use and limited support for the inverse operation. + +* Round-trip support for passing an [FGL] graph through Graphviz to + augment node and edge labels with positional information, etc. + +[FGL]: http://web.engr.oregonstate.edu/~erwig/fgl/haskell/ + +graphviz is free software licensed under a [3-Clause BSD License]. + +\(C\) 2008 [Matthew Sackman](http://www.wellquite.org/) + +\(C\) 2008 - onwards [Ivan Lazar Miljenovic](http://ivanmiljenovic.wordpress.com/) + +[3-Clause BSD License]: http://www.opensource.org/licenses/bsd-license.php diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,4 +0,0 @@ -#!/usr/bin/env runghc - -import Distribution.Simple -main = defaultMain diff --git a/TODO b/TODO deleted file mode 100644 --- a/TODO +++ /dev/null @@ -1,54 +0,0 @@ -% TODO -% Ivan Lazar Miljenovic - -Future Plans for graphviz -========================= - -This is a list of planned feature improvements to graphviz along with -an indication of when it's likely to be implemented (note that these -time scales are in relation to releases, not actual time; however, it -is quite possible that the order will not be adhered to). - -Short term ----------- - -* Quickstart-style documentation to help users get going with graphviz - quickly. - -* Add nicer syntax for record labels, and specifying ports in Monadic - Dot graphs. - -* Define new classes to distinguish between printing/parsing Attribute - values and other values (as only the former requires quoted - variants). - -* Clean up AttributeGenerator and get it to use a better - pretty-printing library. - -Medium term ------------ - -* Improve the test suite such that the generated `DotGraph` values are - valid (and thus can be passed to Graphviz proper). This may not in - fact be possible as guaranteeing an arbitrary `Attribute` is valid - is rather tricky (as the value itself needs to be verified, - especially stateful ones). - -* Switch to a proper test-suite library rather than the hand-rolled - one currently being used. - -* Add support for clusters as endpoints of edges. - -Long term ---------- - -* Allow usage of non-FGL graphs with graphviz. This will require - implementing a separate library to represent graphs (see initial - discussions about this - [here](http://www.haskell.org/pipermail/haskell-cafe/2009-June/063402.html)). - - diff --git a/TODO.md b/TODO.md new file mode 100644 --- /dev/null +++ b/TODO.md @@ -0,0 +1,51 @@ + +Future Plans for graphviz +========================= + +This is a list of planned feature improvements to graphviz along with +an indication of when it's likely to be implemented (note that these +time scales are in relation to releases, not actual time; however, it +is quite possible that the order will not be adhered to). + +Short term +---------- + +* Quickstart-style documentation to help users get going with graphviz + quickly. + +* Add nicer syntax for record labels, and specifying ports in Monadic + Dot graphs. + +* Add support for custom shapes; in particular, a nice way of + re-defining the `Shape` datatype (as just adding a non-nullary + constructor would make it unwieldy to make sure tests, etc. were + kept up-to-date). + +* Define new classes to distinguish between printing/parsing Attribute + values and other values (as only the former requires quoted + variants). + +* Clean up AttributeGenerator and get it to use a better + pretty-printing library. + +Medium term +----------- + +* Improve the test suite such that the generated `DotGraph` values are + valid (and thus can be passed to Graphviz proper). This may not in + fact be possible as guaranteeing an arbitrary `Attribute` is valid + is rather tricky (as the value itself needs to be verified, + especially stateful ones). + +* Switch to a proper test-suite library rather than the hand-rolled + one currently being used. + +* Add support for clusters as endpoints of edges. + +Long term +--------- + +* Allow usage of non-FGL graphs with graphviz. This will require + implementing a separate library to represent graphs (see initial + discussions about this + [here](http://www.haskell.org/pipermail/haskell-cafe/2009-June/063402.html)). diff --git a/graphviz.cabal b/graphviz.cabal --- a/graphviz.cabal +++ b/graphviz.cabal @@ -1,6 +1,5 @@ Name: graphviz -Version: 2999.13.0.3 -Stability: Beta +Version: 2999.20.2.1 Synopsis: Bindings to Graphviz for graph visualisation. Description: { This library provides bindings for the Dot language used by the @@ -30,41 +29,39 @@ augment node and edge labels with positional information, etc. } -Homepage: http://projects.haskell.org/graphviz/ Category: Graphs, Graphics License: BSD3 -License-File: LICENSE +License-File: LICENSE.md Copyright: Matthew Sackman, Ivan Lazar Miljenovic Author: Matthew Sackman, Ivan Lazar Miljenovic -Maintainer: Ivan.Miljenovic+graphviz@gmail.com +Maintainer: Daniel Casanueva (coding `at` danielcasanueva.eu) Build-Type: Simple -Cabal-Version: >= 1.14 -Extra-Source-Files: TODO - Changelog - README - FAQ - utils/AttributeGenerator.hs - utils/TestParsing.hs +Cabal-Version: 1.18 +Extra-Doc-Files: TODO.md, Changelog.md, README.md, FAQ.md +Extra-Source-Files: utils/AttributeGenerator.hs +Bug-Reports: https://codeberg.org/daniel-casanueva/graphviz/issues -Source-Repository head - Type: darcs - Location: http://code.haskell.org/graphviz +Flag test-parsing + Description: Build a utility to test parsing of available Dot code. + Default: False Library { - Default-Language: Haskell98 + Default-Language: Haskell2010 - Build-Depends: base == 4.*, + Build-Depends: base >=4.5.0.0 && <5, containers, process, - fgl == 5.4.*, + directory, + temporary >=1.1 && <1.4, + fgl >= 5.4 && < 5.9, filepath, - polyparse >= 1.7 && < 1.9, - bytestring == 0.9.*, + polyparse >=1.9 && <1.14, + bytestring >= 0.9, colour == 2.3.*, - transformers >= 0.2 && < 0.4, + mtl == 2.*, text, - wl-pprint-text, - dlist == 0.5.* + wl-pprint-text == 1.2.*, + dlist >= 0.5 && < 1.1 Exposed-Modules: Data.GraphViz Data.GraphViz.Types @@ -87,71 +84,76 @@ Data.GraphViz.Exception Data.GraphViz.Algorithms + Data.GraphViz.Attributes.Internal + Data.GraphViz.Internal.Util + Data.GraphViz.Internal.State + Data.GraphViz.Types.Internal.Common + Other-Modules: Data.GraphViz.Algorithms.Clustering + Data.GraphViz.Attributes.Arrows Data.GraphViz.Attributes.ColorScheme - Data.GraphViz.Attributes.Internal Data.GraphViz.Attributes.Same - Data.GraphViz.Types.Common + Data.GraphViz.Attributes.Values + Data.GraphViz.Commands.Available Data.GraphViz.Types.State - Data.GraphViz.Util - Data.GraphViz.State - if True - Ghc-Options: -Wall - - if impl(ghc >= 6.12.1) - Ghc-Options: -fno-warn-unused-do-bind - - Ghc-Prof-Options: -prof -auto-all + Ghc-Options: -Wall } Test-Suite graphviz-testsuite { - Default-Language: Haskell98 + Default-Language: Haskell2010 Type: exitcode-stdio-1.0 -- Versions controlled by library section Build-Depends: base, + graphviz, containers, - process, - fgl, + fgl >= 5.5.0.0, + fgl-arbitrary == 0.2.*, filepath, - polyparse, - bytestring, - colour, - transformers, + hspec >= 2.1 && < 3, text, - wl-pprint-text, - dlist, - QuickCheck >= 2.3 && < 2.5 + QuickCheck >= 2.3 && < 2.16 + Build-Tool-Depends: hspec-discover:hspec-discover == 2.* - hs-Source-Dirs: . tests + hs-Source-Dirs: tests - Main-Is: RunTests.hs + Main-Is: Main.hs - Other-Modules: Data.GraphViz.Testing - Data.GraphViz.Testing.Instances + Other-Modules: Data.GraphViz.Testing.Instances Data.GraphViz.Testing.Properties - Data.GraphViz.Testing.Instances.FGL Data.GraphViz.Testing.Instances.Helpers Data.GraphViz.Testing.Instances.Attributes Data.GraphViz.Testing.Instances.Common Data.GraphViz.Testing.Instances.Canonical Data.GraphViz.Testing.Instances.Generalised Data.GraphViz.Testing.Instances.Graph + Data.GraphViz.Testing.Proxy + Data.GraphVizSpec + Data.GraphViz.AlgorithmsSpec + Data.GraphViz.Attributes.CompleteSpec + Data.GraphViz.Attributes.HTMLSpec + Data.GraphViz.PreProcessingSpec + Data.GraphViz.Types.CanonicalSpec + Data.GraphViz.Types.GeneralisedSpec + Data.GraphViz.Types.GraphSpec + + Spec + if True - Ghc-Options: -O -Wall + Ghc-Options: -Wall if impl(ghc >= 6.12.1) Ghc-Options: -fno-warn-unused-do-bind - GHC-Prof-Options: -auto-all -caf-all -rtsopts + GHC-Prof-Options: -rtsopts } Benchmark graphviz-printparse { - Default-Language: Haskell98 + Default-Language: Haskell2010 Type: exitcode-stdio-1.0 @@ -159,17 +161,37 @@ deepseq, text, graphviz, - criterion >= 0.5 && < 0.7 + criterion >= 0.5 && < 1.7 hs-Source-Dirs: utils Main-Is: Benchmark.hs - if True - Ghc-Options: -O -Wall + Ghc-Options: -Wall - if impl(ghc >= 6.12.1) - Ghc-Options: -fno-warn-unused-do-bind + GHC-Prof-Options: -rtsopts +} - GHC-Prof-Options: -auto-all -caf-all -rtsopts +Executable graphviz-testparsing { + Default-Language: Haskell2010 + + if flag(test-parsing) + Buildable: True + else + Buildable: False + + hs-Source-Dirs: utils + + Main-Is: TestParsing.hs + + Build-Depends: base, + graphviz, + bytestring, + directory, + filepath, + text + + Ghc-Options: -Wall + + GHC-Prof-Options: -rtsopts } diff --git a/tests/Data/GraphViz/AlgorithmsSpec.hs b/tests/Data/GraphViz/AlgorithmsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/GraphViz/AlgorithmsSpec.hs @@ -0,0 +1,37 @@ +{- | + Module : Data.GraphViz.AlgorithmsSpec + Description : Testing algorithms + Copyright : Matthew Sackman, Ivan Lazar Miljenovic + License : BSD3 + Maintainer : Ivan.Miljenovic@gmail.com + + + + -} +module Data.GraphViz.AlgorithmsSpec (spec) where + +import Data.GraphViz.Algorithms (CanonicaliseOptions) +import Data.GraphViz.Testing.Instances () +import Data.GraphViz.Testing.Properties (prop_canonicalise, + prop_canonicaliseEdges, + prop_canonicaliseNodes, + prop_transitive, prop_transitiveNodes) +import Data.GraphViz.Types.Canonical (DotGraph) + +import Test.Hspec (Spec) +import Test.Hspec.QuickCheck (prop) + +-------------------------------------------------------------------------------- + +spec :: Spec +spec = do + prop "Canonicalisation should be idempotent" + (prop_canonicalise :: CanonicaliseOptions -> DotGraph Int -> Bool) + prop "Canonicalisation shouldn't change any nodes" + (prop_canonicaliseNodes :: CanonicaliseOptions -> DotGraph Int -> Bool) + prop "Canonicalisation shouldn't change any edges" + (prop_canonicaliseEdges :: CanonicaliseOptions -> DotGraph Int -> Bool) + prop "Transitive reduction should be idempotent" + (prop_transitive :: CanonicaliseOptions -> DotGraph Int -> Bool) + prop "Transitive reduction shouldn't change any nodes" + (prop_transitiveNodes :: CanonicaliseOptions -> DotGraph Int -> Bool) diff --git a/tests/Data/GraphViz/Attributes/CompleteSpec.hs b/tests/Data/GraphViz/Attributes/CompleteSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/GraphViz/Attributes/CompleteSpec.hs @@ -0,0 +1,26 @@ +{- | + Module : Data.GraphViz.Attributes.CompleteSpec + Description : Attribute testing + Copyright : Ivan Lazar Miljenovic + License : BSD3 + Maintainer : Ivan.Miljenovic@gmail.com + + + + -} +module Data.GraphViz.Attributes.CompleteSpec (spec) where + +import Data.GraphViz.Attributes.Complete (Attributes) +import Data.GraphViz.Testing.Instances () +import Data.GraphViz.Testing.Properties (prop_printParseListID) + +import Test.Hspec (Spec) +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (Property) + +-------------------------------------------------------------------------------- + +spec :: Spec +spec = + prop "Printing and parsing of attributes" + (prop_printParseListID :: Attributes -> Property) diff --git a/tests/Data/GraphViz/Attributes/HTMLSpec.hs b/tests/Data/GraphViz/Attributes/HTMLSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/GraphViz/Attributes/HTMLSpec.hs @@ -0,0 +1,26 @@ +{- | + Module : Data.GraphViz.Attributes.HTMLSpec + Description : HTML label testing + Copyright : Ivan Lazar Miljenovic + License : BSD3 + Maintainer : Ivan.Miljenovic@gmail.com + + This is in addition to "Data.GraphViz.Attributes.CompleteSpec" as + HTML labels are also likely to have their own quirks for testing. + + -} +module Data.GraphViz.Attributes.HTMLSpec (spec) where + +import Data.GraphViz.Attributes.HTML (Label) +import Data.GraphViz.Testing.Instances () +import Data.GraphViz.Testing.Properties (prop_printParseID) + +import Test.Hspec (Spec) +import Test.Hspec.QuickCheck (prop) + +-------------------------------------------------------------------------------- + +spec :: Spec +spec = + prop "Printing and parsing of HTML labels" + (prop_printParseID :: Label -> Bool) diff --git a/tests/Data/GraphViz/PreProcessingSpec.hs b/tests/Data/GraphViz/PreProcessingSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/GraphViz/PreProcessingSpec.hs @@ -0,0 +1,24 @@ +{- | + Module : Data.GraphViz.PreProcessingSpec + Description : Test pre-processing + Copyright : Matthew Sackman, Ivan Lazar Miljenovic + License : BSD3 + Maintainer : Ivan.Miljenovic@gmail.com + + + + -} +module Data.GraphViz.PreProcessingSpec where + +import Data.GraphViz.Testing.Instances () +import Data.GraphViz.Testing.Properties (prop_preProcessingID) +import Data.GraphViz.Types.Canonical (DotGraph) + +import Test.Hspec (Spec) +import Test.Hspec.QuickCheck (prop) + +-------------------------------------------------------------------------------- + +spec :: Spec +spec = prop "Preprocessing doesn't change Dot code" + (prop_preProcessingID :: DotGraph Int -> Bool) diff --git a/tests/Data/GraphViz/Testing.hs b/tests/Data/GraphViz/Testing.hs deleted file mode 100644 --- a/tests/Data/GraphViz/Testing.hs +++ /dev/null @@ -1,383 +0,0 @@ -{-# LANGUAGE Rank2Types, FlexibleContexts #-} - -{- | - Module : Data.GraphViz.Testing - Description : Test-suite for graphviz. - Copyright : (c) Ivan Lazar Miljenovic - License : 3-Clause BSD-style - Maintainer : Ivan.Miljenovic@gmail.com - - This defines a test-suite for the graphviz library. - - Limitations of the test suite are as follows: - - * For the most part, this library lets you use arbitrary numbers - for String values. However, this is not tested due to too many - corner cases for special parsers that don't take arbitrary - Strings. As the Dot standard is ambiguous over whether you can - or can't use numbers as Strings (more specifically, if they - should be quoted or not), this is a user beware situation. - - * Same goes for empty Strings; sometimes they're allowed, sometimes - they're not. Thus, to simplify matters they're not generated. - - * The generated Strings are very simple, only composed of lower - case letters, digits and some symbols. This is because too many - tests were \"failing\" due to some corner case; e.g. lower-case - letters only because the parser parses Strings as lowercase, so - if a particular String isn't valid (e.g. @\"all\"@ for 'LayerID', - then the 'Arbitrary' instance has to ensure that all possible - ways of capitalising that String isn't generated as a random - 'LRName'. - - * The generated 'DotRepr's are not guaranteed to be valid. - - * To avoid needless endless recursion, sub-graphs do not have their - own internal sub-graphs. - - * This test suite isn't perfect: if you deliberately try to stuff - something up, you probably can. --} -module Data.GraphViz.Testing - ( -- * Running the test suite. - runChosenTests - , runTests - , runTest - -- ** The tests themselves - , Test(..) - , defaultTests - , test_printParseID_Attributes - , test_generalisedSameDot - , test_printParseID - , test_preProcessingID - , test_dotizeAugment - , test_dotizeAugmentUniq - , test_canonicalise - , test_transitive - -- * Re-exporting modules for manual testing. - , module Data.GraphViz - , module Data.GraphViz.Testing.Properties - -- * Debugging printing - , PrintDot(..) - , printIt - , renderDot - -- * Debugging parsing - , ParseDot(..) - , parseIt - , parseIt' - , runParser - , preProcess - ) where - -import Test.QuickCheck - -import Data.GraphViz.Testing.Instances() -import Data.GraphViz.Testing.Properties - -import Data.GraphViz -import Data.GraphViz.Parsing(parseIt, parseIt', runParser) -import Data.GraphViz.PreProcessing(preProcess) -import Data.GraphViz.Printing(printIt, renderDot) -import qualified Data.GraphViz.Types.Generalised as G -import qualified Data.GraphViz.Types.Graph as Gr --- Can't use PatriciaTree because a Show instance is needed. -import Data.Graph.Inductive.Tree(Gr) - -import System.Exit(ExitCode(..), exitWith) -import System.IO(hPutStrLn, stderr) - --- ----------------------------------------------------------------------------- - -runChosenTests :: [Test] -> IO () -runChosenTests tsts = do putStrLn msg - blankLn - runTests tsts - 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." - - successMsg = "All tests were successful!" - - --- ----------------------------------------------------------------------------- --- Defining a Test structure and how to run tests. - --- | Defines the test structure being used. -data Test = Test { name :: String - , lookupName :: String -- ^ Should be lowercase - , desc :: String - , tests :: [IO Result] -- ^ QuickCheck test. - } - --- | Run all of the provided tests. -runTests :: [Test] -> IO () -runTests = mapM_ ((>>) spacerLn . runTest) - --- | Run the provided test. -runTest :: Test -> IO () -runTest tst = do putStrLn title - blankLn - putStrLn $ desc tst - blankLn - run $ tests tst - blankLn - where - nm = '"' : name tst ++ "\"" - title = "Running test: " ++ nm ++ "." - successMsg = "All tests for " ++ nm ++ " were successful!" - gaveUpMsg = "Too many sample inputs for " ++ nm ++ " were rejected;\n\ - \tentatively marking this as successful." - failMsg = "The tests for " ++ nm ++ " failed!\n\ - \Not attempting any further tests." - - run [] = putStrLn successMsg - run (t:ts) = do r <- t - case r of - Success{} -> run ts - GaveUp{} -> putStrLn gaveUpMsg >> run ts - _ -> die failMsg - -spacerLn :: IO () -spacerLn = putStrLn (replicate 70 '=') >> blankLn - -blankLn :: IO () -blankLn = putStrLn "" - -die :: String -> IO a -die msg = do hPutStrLn stderr msg - exitWith (ExitFailure 1) - -qCheck :: (Testable prop) => prop -> IO Result -qCheck = quickCheckWithResult (stdArgs { maxSize = 50, maxSuccess = 200 }) - --- ----------------------------------------------------------------------------- --- Defining the tests to use. - --- | The tests to run by default. -defaultTests :: [Test] -defaultTests = [ test_printParseID_Attributes - , test_generalisedSameDot - , test_printParseID - , test_preProcessingID - , test_dotizeAugment - , test_dotizeHasAugment - , test_dotizeAugmentUniq - , test_findAllNodes - , test_findAllNodesE - , test_findAllEdges - , test_noGraphInfo - , test_canonicalise - , test_transitive - ] - --- | Test that 'Attributes' can be printed and then parsed back. -test_printParseID_Attributes :: Test -test_printParseID_Attributes - = Test { name = "Printing and parsing of Attributes" - , lookupName = "attributes" - , desc = dsc - , tests = [qCheck prop] - } - where - prop :: Attributes -> Property - prop = prop_printParseListID - - dsc = "The most common source of errors in printing and parsing are for\n\ - \Attributes." - -test_generalisedSameDot :: Test -test_generalisedSameDot - = Test { name = "Printing generalised Dot code" - , lookupName = "makegeneralised" - , desc = dsc - , tests = [qCheck prop] - } - where - prop :: DotGraph Int -> Bool - prop = prop_generalisedSameDot - - dsc = "When generalising \"DotGraph\" values to other \"DotRepr\" values,\n\ - \the generated Dot code should be identical." - -test_printParseID :: Test -test_printParseID - = Test { name = "Printing and Parsing DotReprs" - , lookupName = "printparseid" - , desc = dsc - , tests = tsts - } - where - tsts :: [IO Result] - tsts = [ qCheck (prop_printParseID :: DotGraph Int -> Bool) - , qCheck (prop_printParseID :: G.DotGraph Int -> Bool) - , qCheck (prop_printParseID :: Gr.DotGraph Int -> Bool) - ] - - dsc = "The graphviz library should be able to parse back in its own\n\ - \generated Dot code for any \"DotRepr\" instance" - -test_preProcessingID :: Test -test_preProcessingID - = Test { name = "Pre-processing Dot code" - , lookupName = "preprocessing" - , desc = dsc - , tests = [qCheck prop] - } - where - prop :: DotGraph Int -> Bool - prop = prop_preProcessingID - - dsc = "When parsing Dot code, some pre-processing is done to remove items\n\ - \such as comments and to join together multi-line strings. This\n\ - \test verifies that this pre-processing doesn't affect actual\n\ - \Dot code by running the pre-processor on generated Dot code.\n\n\ - \This test is not run on generalised Dot graphs as if it works for\n\ - \normal dot graphs then it should also work for generalised ones." - -test_dotizeAugment :: Test -test_dotizeAugment - = Test { name = "Augmenting FGL Graphs" - , lookupName = "augment" - , desc = dsc - , tests = [qCheck prop] - } - where - prop :: Gr Char Double -> Bool - prop = prop_dotizeAugment - - dsc = "The various Graph to Graph functions in Data.GraphViz should\n\ - \only _augment_ the graph labels and not change the graphs\n\ - \themselves. This test compares the original graphs to these\n\ - \augmented graphs and verifies that they are the same." - -test_dotizeHasAugment :: Test -test_dotizeHasAugment - = Test { name = "Ensuring augmentation of FGL Graphs" - , lookupName = "hasaugment" - , desc = dsc - , tests = [qCheck prop] - } - where - prop :: Gr Char Double -> Bool - prop = prop_dotizeHasAugment - - dsc = "The various Graph to Graph functions in Data.GraphViz should\n\ - \actually agument the graph labels; this ensures that all labels\n\ - \actually have attached Attributes after augmentation." - -test_dotizeAugmentUniq :: Test -test_dotizeAugmentUniq - = Test { name = "Unique edges in augmented FGL Graphs" - , lookupName = "augmentuniq" - , desc = dsc - , tests = [qCheck prop] - } - where - prop :: Gr Char Double -> Bool - prop = prop_dotizeAugmentUniq - - dsc = "When augmenting a graph with multiple edges, as long as no\n\ - \Attributes are provided that override the default settings,\n\ - \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 DotRepr" - , lookupName = "findnodes" - , desc = dsc - , tests = map qCheck props - } - where - props :: [Gr () () -> Bool] - props = testAllGraphTypes prop_findAllNodes - - dsc = "nodeInformation should find all nodes in a DotRepr;\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 DotRepr" - , lookupName = "findedgelessnodes" - , desc = dsc - , tests = map qCheck props - } - where - props :: [Gr () () -> Bool] - props = testAllGraphTypes prop_findAllNodesE - - dsc = "nodeInformation should find all nodes in a DotRepr,\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 DotRepr" - , lookupName = "findedges" - , desc = dsc - , tests = map qCheck props - } - where - props :: [Gr () () -> Bool] - props = testAllGraphTypes prop_findAllEdges - - dsc = "nodeInformation should find all edges in a DotRepr;\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 DotReprs should have no structural information" - , lookupName = "nographinfo" - , desc = dsc - , tests = map qCheck props - } - where - props :: [Gr () () -> Bool] - props = testAllGraphTypes prop_noGraphInfo - - dsc = "When converting a Graph to a DotRepr, there should be no\n\ - \clusters or global attributes." - -test_canonicalise :: Test -test_canonicalise - = Test { name = "Canonicalisation should be idempotent" - , lookupName = "canonicalise" - , desc = dsc - , tests = [qCheck prop] - } - where - prop :: DotGraph Int -> Bool - prop = prop_canonicalise - - dsc = "Repeated application of canonicalise shouldn't have any further affect." - -test_transitive :: Test -test_transitive - = Test { name = "Transitive reduction should be idempotent" - , lookupName = "transitive" - , desc = dsc - , tests = [qCheck prop] - } - where - prop :: DotGraph Int -> Bool - prop = prop_transitive - - dsc = "Repeated application of transitiveReduction shouldn't have any further affect." - --- ----------------------------------------------------------------------------- - --- | Used when a property takes in a DotRepr as the first argument to --- indicate which instance it should test via 'fromCanonical'. -testAllGraphTypes :: (Testable prop) - => (forall dg. (Eq (dg Int), DotRepr dg Int) => dg Int -> prop) - -> [prop] -testAllGraphTypes prop = [ prop (undefined :: DotGraph Int) - , prop (undefined :: G.DotGraph Int) - , prop (undefined :: Gr.DotGraph Int) - ] diff --git a/tests/Data/GraphViz/Testing/Instances.hs b/tests/Data/GraphViz/Testing/Instances.hs --- a/tests/Data/GraphViz/Testing/Instances.hs +++ b/tests/Data/GraphViz/Testing/Instances.hs @@ -18,10 +18,9 @@ -} module Data.GraphViz.Testing.Instances() where -import Data.GraphViz.Testing.Instances.FGL() -import Data.GraphViz.Testing.Instances.Canonical() -import Data.GraphViz.Testing.Instances.Generalised() -import Data.GraphViz.Testing.Instances.Graph() +import Data.Graph.Inductive.Arbitrary () +import Data.GraphViz.Testing.Instances.Canonical () +import Data.GraphViz.Testing.Instances.Generalised () +import Data.GraphViz.Testing.Instances.Graph () -- ----------------------------------------------------------------------------- - diff --git a/tests/Data/GraphViz/Testing/Instances/Attributes.hs b/tests/Data/GraphViz/Testing/Instances/Attributes.hs --- a/tests/Data/GraphViz/Testing/Instances/Attributes.hs +++ b/tests/Data/GraphViz/Testing/Instances/Attributes.hs @@ -1,6 +1,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP, OverloadedStrings #-} {- | Module : Data.GraphViz.Testing.Instances.Attributes @@ -19,24 +19,30 @@ import Data.GraphViz.Testing.Instances.Helpers -import Data.GraphViz.Attributes.Complete -import qualified Data.GraphViz.Attributes.HTML as Html -import Data.GraphViz.Attributes.Colors.Brewer -import Data.GraphViz.Attributes.Colors.X11(X11Color) -import Data.GraphViz.Attributes.Colors.SVG(SVGColor) -import Data.GraphViz.Attributes.Internal(compassLookup) -import Data.GraphViz.State(initialState, layerSep) -import Data.GraphViz.Util(bool) +import Data.GraphViz.Attributes.Colors.Brewer +import Data.GraphViz.Attributes.Colors.SVG (SVGColor) +import Data.GraphViz.Attributes.Colors.X11 (X11Color) +import Data.GraphViz.Attributes.Complete +import qualified Data.GraphViz.Attributes.HTML as Html +import Data.GraphViz.Attributes.Internal (compassLookup) +import Data.GraphViz.Internal.State (initialState, + layerListSep, layerSep) +import Data.GraphViz.Internal.Util (bool) import Test.QuickCheck -import Data.List(nub, delete, groupBy) -import qualified Data.Map as Map -import qualified Data.Text.Lazy as T -import Data.Text.Lazy(Text) -import Control.Monad(liftM, liftM2, liftM3, liftM4) -import System.FilePath(searchPathSeparator) +import Control.Monad (liftM, liftM2, liftM3, liftM4) +import Data.List (delete, groupBy, nub) +import qualified Data.Map as Map +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as T +import System.FilePath (searchPathSeparator) +#if !MIN_VERSION_QuickCheck(2,9,0) +import Data.GraphViz.Internal.Util (createVersion) +import Data.Version (Version(..)) +#endif + -- ----------------------------------------------------------------------------- -- Defining Arbitrary instances for Attributes @@ -62,16 +68,17 @@ arbitrary = oneof [ liftM Damping arbitrary , liftM K arbitrary , liftM URL arbitrary + , liftM Area arbitrary , liftM ArrowHead arbitrary , liftM ArrowSize arbitrary , liftM ArrowTail arbitrary - , liftM Aspect arbitrary + , liftM Background arbitrary , liftM BoundingBox arbitrary - , liftM ColorScheme arbitrary , liftM BgColor arbList , liftM Center arbitrary , liftM ClusterRank arbitrary , liftM Color arbList + , liftM ColorScheme arbitrary , liftM Comment arbitrary , liftM Compound arbitrary , liftM Concentrate arbitrary @@ -100,6 +107,7 @@ , liftM GradientAngle arbitrary , liftM Group arbitrary , liftM HeadURL arbitrary + , liftM Head_LP arbitrary , liftM HeadClip arbitrary , liftM HeadLabel arbitrary , liftM HeadPort arbitrary @@ -110,6 +118,7 @@ , liftM Image arbitrary , liftM ImagePath arbitrary , liftM ImageScale arbitrary + , liftM InputScale arbitrary , liftM Label arbitrary , liftM LabelURL arbitrary , liftM LabelScheme arbitrary @@ -125,12 +134,14 @@ , liftM LabelTooltip arbitrary , liftM Landscape arbitrary , liftM Layer arbitrary + , liftM LayerListSep arbitrary , liftM Layers arbitrary + , liftM LayerSelect arbitrary , liftM LayerSep arbitrary , liftM Layout arbitrary , liftM Len arbitrary - , liftM LevelsGap arbitrary , liftM Levels arbitrary + , liftM LevelsGap arbitrary , liftM LHead arbitrary , liftM LHeight arbitrary , liftM LPos arbitrary @@ -147,6 +158,7 @@ , liftM NodeSep arbitrary , liftM NoJustify arbitrary , liftM Normalize arbitrary + , liftM NoTranslate arbitrary , liftM Nslimit arbitrary , liftM Nslimit1 arbitrary , liftM Ordering arbitrary @@ -154,6 +166,7 @@ , liftM OutputOrder arbitrary , liftM Overlap arbitrary , liftM OverlapScaling arbitrary + , liftM OverlapShrink arbitrary , liftM Pack arbitrary , liftM PackMode arbitrary , liftM Pad arbitrary @@ -184,7 +197,6 @@ , liftM SearchSize arbitrary , liftM Sep arbitrary , liftM Shape arbitrary - , liftM ShapeFile arbitrary , liftM ShowBoxes arbitrary , liftM Sides arbitrary , liftM Size arbitrary @@ -196,6 +208,7 @@ , liftM Style arbList , liftM StyleSheet arbitrary , liftM TailURL arbitrary + , liftM Tail_LP arbitrary , liftM TailClip arbitrary , liftM TailLabel arbitrary , liftM TailPort arbitrary @@ -209,24 +222,26 @@ , liftM VoroMargin arbitrary , liftM Weight arbitrary , liftM Width arbitrary + , liftM XDotVersion arbitrary , liftM XLabel arbitrary - , liftM Z arbitrary + , liftM XLP arbitrary , liftM2 UnknownAttribute (suchThat arbIDString validUnknown) arbitrary ] shrink (Damping v) = map Damping $ shrink v shrink (K v) = map K $ shrink v shrink (URL v) = map URL $ shrink v + shrink (Area v) = map Area $ shrink v shrink (ArrowHead v) = map ArrowHead $ shrink v shrink (ArrowSize v) = map ArrowSize $ shrink v shrink (ArrowTail v) = map ArrowTail $ shrink v - shrink (Aspect v) = map Aspect $ shrink v + shrink (Background v) = map Background $ shrink v shrink (BoundingBox v) = map BoundingBox $ shrink v - shrink (ColorScheme v) = map ColorScheme $ shrink v shrink (BgColor v) = map BgColor $ nonEmptyShrinks v shrink (Center v) = map Center $ shrink v shrink (ClusterRank v) = map ClusterRank $ shrink v shrink (Color v) = map Color $ nonEmptyShrinks v + shrink (ColorScheme v) = map ColorScheme $ shrink v shrink (Comment v) = map Comment $ shrink v shrink (Compound v) = map Compound $ shrink v shrink (Concentrate v) = map Concentrate $ shrink v @@ -255,6 +270,7 @@ shrink (GradientAngle v) = map GradientAngle $ shrink v shrink (Group v) = map Group $ shrink v shrink (HeadURL v) = map HeadURL $ shrink v + shrink (Head_LP v) = map Head_LP $ shrink v shrink (HeadClip v) = map HeadClip $ shrink v shrink (HeadLabel v) = map HeadLabel $ shrink v shrink (HeadPort v) = map HeadPort $ shrink v @@ -265,6 +281,7 @@ shrink (Image v) = map Image $ shrink v shrink (ImagePath v) = map ImagePath $ shrink v shrink (ImageScale v) = map ImageScale $ shrink v + shrink (InputScale v) = map InputScale $ shrink v shrink (Label v) = map Label $ shrink v shrink (LabelURL v) = map LabelURL $ shrink v shrink (LabelScheme v) = map LabelScheme $ shrink v @@ -280,12 +297,14 @@ shrink (LabelTooltip v) = map LabelTooltip $ shrink v shrink (Landscape v) = map Landscape $ shrink v shrink (Layer v) = map Layer $ shrink v + shrink (LayerListSep v) = map LayerListSep $ shrink v shrink (Layers v) = map Layers $ shrink v + shrink (LayerSelect v) = map LayerSelect $ shrink v shrink (LayerSep v) = map LayerSep $ shrink v shrink (Layout v) = map Layout $ shrink v shrink (Len v) = map Len $ shrink v - shrink (LevelsGap v) = map LevelsGap $ shrink v shrink (Levels v) = map Levels $ shrink v + shrink (LevelsGap v) = map LevelsGap $ shrink v shrink (LHead v) = map LHead $ shrink v shrink (LHeight v) = map LHeight $ shrink v shrink (LPos v) = map LPos $ shrink v @@ -302,6 +321,7 @@ shrink (NodeSep v) = map NodeSep $ shrink v shrink (NoJustify v) = map NoJustify $ shrink v shrink (Normalize v) = map Normalize $ shrink v + shrink (NoTranslate v) = map NoTranslate $ shrink v shrink (Nslimit v) = map Nslimit $ shrink v shrink (Nslimit1 v) = map Nslimit1 $ shrink v shrink (Ordering v) = map Ordering $ shrink v @@ -309,6 +329,7 @@ shrink (OutputOrder v) = map OutputOrder $ shrink v shrink (Overlap v) = map Overlap $ shrink v shrink (OverlapScaling v) = map OverlapScaling $ shrink v + shrink (OverlapShrink v) = map OverlapShrink $ shrink v shrink (Pack v) = map Pack $ shrink v shrink (PackMode v) = map PackMode $ shrink v shrink (Pad v) = map Pad $ shrink v @@ -339,7 +360,6 @@ shrink (SearchSize v) = map SearchSize $ shrink v shrink (Sep v) = map Sep $ shrink v shrink (Shape v) = map Shape $ shrink v - shrink (ShapeFile v) = map ShapeFile $ shrink v shrink (ShowBoxes v) = map ShowBoxes $ shrink v shrink (Sides v) = map Sides $ shrink v shrink (Size v) = map Size $ shrink v @@ -351,6 +371,7 @@ shrink (Style v) = map Style $ nonEmptyShrinks v shrink (StyleSheet v) = map StyleSheet $ shrink v shrink (TailURL v) = map TailURL $ shrink v + shrink (Tail_LP v) = map Tail_LP $ shrink v shrink (TailClip v) = map TailClip $ shrink v shrink (TailLabel v) = map TailLabel $ shrink v shrink (TailPort v) = map TailPort $ shrink v @@ -364,11 +385,15 @@ shrink (VoroMargin v) = map VoroMargin $ shrink v shrink (Weight v) = map Weight $ shrink v shrink (Width v) = map Width $ shrink v + shrink (XDotVersion v) = map XDotVersion $ shrink v shrink (XLabel v) = map XLabel $ shrink v - shrink (Z v) = map Z $ shrink v + shrink (XLP v) = map XLP $ shrink v shrink (UnknownAttribute a v) = liftM2 UnknownAttribute (liftM (filter validUnknown) shrink a) (shrink v) {- delete to here -} +instance Arbitrary GraphvizCommand where + arbitrary = arbBounded + instance Arbitrary ArrowType where arbitrary = liftM AType -- Arrow specifications have between 1 and 4 elements. @@ -388,16 +413,6 @@ instance Arbitrary ArrowSide where arbitrary = arbBounded -instance Arbitrary AspectType where - arbitrary = oneof [ liftM RatioOnly arbitrary - , liftM2 RatioPassCount arbitrary posArbitrary - ] - - shrink (RatioOnly d) = map RatioOnly $ shrink d - shrink (RatioPassCount d i) = do ds <- shrink d - is <- shrink i - return $ RatioPassCount ds is - instance Arbitrary LabelScheme where arbitrary = arbBounded @@ -412,7 +427,7 @@ -- Pretty sure points have to be positive... arbitrary = liftM4 Point posArbitrary posArbitrary posZ arbitrary where - posZ = frequency [(1, return Nothing), (3, liftM Just posArbitrary)] + posZ = liftArbitrary posArbitrary shrink p = do x' <- shrink $ xCoord p y' <- shrink $ yCoord p @@ -439,6 +454,16 @@ shrink (DVal d) = map DVal $ shrink d shrink (PVal p) = map PVal $ shrink p +instance Arbitrary SVGFontNames where + arbitrary = arbBounded + +instance Arbitrary GraphSize where + arbitrary = liftM3 GSize arbitrary arbitrary arbitrary + + shrink gs = do w' <- shrink $ width gs + h' <- shrinkM $ height gs + return $ GSize w' h' False + instance Arbitrary ModeType where arbitrary = arbBounded @@ -453,7 +478,7 @@ shrink (StrLabel str) = map StrLabel $ shrink str shrink (HtmlLabel html) = map HtmlLabel $ shrink html - shrink (RecordLabel fs) = map RecordLabel . filter notStr $ shrinkList fs + shrink (RecordLabel fs) = map RecordLabel . filter notStr $ listShrink fs notStr :: RecordFields -> Bool notStr [FieldLabel{}] = False -- Just in case @@ -478,7 +503,7 @@ shrink (LabelledTarget f l) = [PortName f, FieldLabel l] shrink (PortName f) = map PortName $ shrink f shrink (FieldLabel l) = map FieldLabel $ shrink l - shrink (FlipFields fs) = map FlipFields $ shrinkList fs + shrink (FlipFields fs) = map FlipFields $ listShrink fs instance Arbitrary Overlap where arbitrary = oneof [ simpleOverlap @@ -490,6 +515,7 @@ simpleOverlap = elements [ KeepOverlaps , ScaleOverlaps , ScaleXYOverlaps + , VoronoiOverlap , CompressOverlap , VpscOverlap , IpsepOverlap @@ -503,6 +529,11 @@ -- one because of arbLayerName arbitrary = return . LSep . T.pack $ layerSep initialState +instance Arbitrary LayerListSep where + -- Since Arbitrary isn't stateful, we can't generate an arbitrary + -- one because of arbLayerName + arbitrary = return . LLSep . T.pack $ layerListSep initialState + instance Arbitrary LayerList where arbitrary = liftM LL $ listOf1 arbName where @@ -513,7 +544,7 @@ shrink (LL ll) = map LL $ nonEmptyShrinks ll -instance Arbitrary LayerRange where +instance Arbitrary LayerRangeElem where arbitrary = oneof [ liftM LRID arbitrary , liftM2 LRS arbitrary arbitrary ] @@ -632,8 +663,8 @@ , liftM2 StartStyleSeed arbitrary arbitrary ] - shrink StartStyle{} = [] -- No shrinks for STStyle - shrink (StartSeed ss) = map StartSeed $ shrink ss + shrink StartStyle{} = [] -- No shrinks for STStyle + shrink (StartSeed ss) = map StartSeed $ shrink ss shrink (StartStyleSeed st ss) = map (StartStyleSeed st) $ shrink ss instance Arbitrary STStyle where @@ -656,6 +687,8 @@ , Bold , Invisible , Filled + , Striped + , Wedged , Diagonals , Rounded , Tapered @@ -667,6 +700,8 @@ , "bold" , "invis" , "filled" + , "striped" + , "wedged" , "diagonals" , "rounded" , "tapered" @@ -777,6 +812,15 @@ shrink (BrewerColor c) = map BrewerColor $ shrink c shrink _ = [] -- Shrinking 0<=h,s,v<=1 does nothing +-- | No guarantees are made as to sanity of generated weightings. +instance Arbitrary WeightedColor where + arbitrary = liftM2 WC arbitrary arbitrary + + -- No color shrinks to itself, so no sanity checking needed. + shrink (WC c mw) = do c' <- shrink c + mw' <- shrink mw + return $ WC c' mw' + instance Arbitrary X11Color where arbitrary = arbBounded @@ -793,8 +837,8 @@ instance Arbitrary Html.Label where arbitrary = sized $ arbHtml True - shrink ht@(Html.Text txts) = delete ht . map Html.Text $ shrinkL txts - shrink (Html.Table tbl) = map Html.Table $ shrink tbl + shrink (Html.Text txts) = map Html.Text $ listShrink txts + shrink (Html.Table tbl) = map Html.Table $ shrink tbl -- Note: for the most part, Html.Label values are very repetitive (and -- furthermore, they end up chewing a large amount of memory). As @@ -820,7 +864,7 @@ . sized $ arbHtmlText fnt where - s' = min s 10 + s' = min s 5 -- When parsing, all textual characters are parsed together; thus, -- make sure we generate them like that. @@ -836,9 +880,9 @@ instance Arbitrary Html.TextItem where arbitrary = sized $ arbHtmlText True - shrink (Html.Str str) = map Html.Str $ shrink str - shrink (Html.Newline as) = map Html.Newline $ shrink as - shrink hf@(Html.Font as txt) = do as' <- shrink as + shrink (Html.Str str) = map Html.Str . filter (not . T.null) . map T.strip $ shrink str + shrink (Html.Newline as) = map Html.Newline $ shrinkHtmlAttrs as + shrink hf@(Html.Font as txt) = do as' <- shrinkHtmlAttrs as txt' <- shrinkL txt returnCheck hf $ Html.Font as' txt' shrink (Html.Format _ txt) = txt @@ -851,23 +895,34 @@ else id s' = min 2 s arbRec = resize s' . sized $ arbHtmlTexts False - recHtmlText = [ (1, liftM2 Html.Font arbitrary arbRec) + recHtmlText = [ (1, liftM2 Html.Font arbHtmlAttrs arbRec) , (3, liftM2 Html.Format arbitrary arbRec) ] - options = allowFonts [ (10, liftM Html.Str arbitrary) - , (10, liftM Html.Newline arbitrary) + options = allowFonts [ (10, liftM Html.Str (suchThat (liftM T.strip arbitrary) (not . T.null))) + , (10, liftM Html.Newline arbHtmlAttrs) ] instance Arbitrary Html.Format where arbitrary = arbBounded instance Arbitrary Html.Table where - arbitrary = liftM3 Html.HTable arbitrary arbitrary (sized arbRows) + arbitrary = liftM3 Html.HTable (liftArbitrary arbHtmlAttrs) arbHtmlAttrs (sized arbRows) where arbRows s = resize (min s 10) arbList - shrink (Html.HTable fas as rs) = map (Html.HTable fas as) $ shrinkL rs + shrink (Html.HTable fas as rs) = liftM3 Html.HTable shrinkFont (shrinkHtmlAttrs as) (shrinkL rs) + where + shrinkFont = liftShrink shrinkHtmlAttrs fas +#if !MIN_VERSION_QuickCheck(2,10,0) +liftArbitrary :: Gen a -> Gen (Maybe a) +liftArbitrary gen = frequency [(1, return Nothing), (3, liftM Just gen)] + +liftShrink :: (a -> [a]) -> Maybe a -> [Maybe a] +liftShrink shr (Just x) = Nothing : map Just (shr x) +liftShrink _ Nothing = [] +#endif + instance Arbitrary Html.Row where arbitrary = frequency [ (5, liftM Html.Cells arbList) , (1, return Html.HorizontalRule) @@ -891,6 +946,12 @@ instance Arbitrary Html.Img where arbitrary = liftM Html.Img arbitrary +arbHtmlAttrs :: Gen Html.Attributes +arbHtmlAttrs = sized (\s -> resize (min 5 s) arbitrary) + +shrinkHtmlAttrs :: Html.Attributes -> [Html.Attributes] +shrinkHtmlAttrs = listShrink + instance Arbitrary Html.Attribute where arbitrary = oneof [ liftM Html.Align arbitrary , liftM Html.BAlign arbitrary @@ -901,45 +962,55 @@ , liftM Html.CellSpacing arbitrary , liftM Html.Color arbitrary , liftM Html.ColSpan arbitrary + , liftM Html.Columns arbitrary , liftM Html.Face arbitrary , liftM Html.FixedSize arbitrary + , liftM Html.GradientAngle arbitrary , liftM Html.Height arbitrary , liftM Html.HRef arbitrary , liftM Html.ID arbitrary , liftM Html.PointSize arbitrary , liftM Html.Port arbitrary + , liftM Html.Rows arbitrary , liftM Html.RowSpan arbitrary , liftM Html.Scale arbitrary + , liftM Html.Sides (fmap nub (sized (\s -> resize (min s 4) arbitrary))) -- Will never have more than 4 values , liftM Html.Src arbString + , liftM Html.Style arbitrary , liftM Html.Target arbitrary , liftM Html.Title arbitrary , liftM Html.VAlign arbitrary , liftM Html.Width arbitrary ] - shrink (Html.Align v) = map Html.Align $ shrink v - shrink (Html.BAlign v) = map Html.BAlign $ shrink v - shrink (Html.BGColor v) = map Html.BGColor $ shrink v - shrink (Html.Border v) = map Html.Border $ shrink v - shrink (Html.CellBorder v) = map Html.CellBorder $ shrink v - shrink (Html.CellPadding v) = map Html.CellPadding $ shrink v - shrink (Html.CellSpacing v) = map Html.CellSpacing $ shrink v - shrink (Html.Color v) = map Html.Color $ shrink v - shrink (Html.ColSpan v) = map Html.ColSpan $ shrink v - shrink (Html.Face v) = map Html.Face $ shrink v - shrink (Html.FixedSize v) = map Html.FixedSize $ shrink v - shrink (Html.Height v) = map Html.Height $ shrink v - shrink (Html.HRef v) = map Html.HRef $ shrink v - shrink (Html.ID v) = map Html.ID $ shrink v - shrink (Html.PointSize v) = map Html.PointSize $ shrink v - shrink (Html.Port v) = map Html.Port $ shrink v - shrink (Html.RowSpan v) = map Html.RowSpan $ shrink v - shrink (Html.Scale v) = map Html.Scale $ shrink v - shrink (Html.Src v) = map Html.Src $ shrinkString v - shrink (Html.Target v) = map Html.Target $ shrink v - shrink (Html.Title v) = map Html.Title $ shrink v - shrink (Html.VAlign v) = map Html.VAlign $ shrink v - shrink (Html.Width v) = map Html.Width $ shrink v + shrink (Html.Align v) = map Html.Align $ shrink v + shrink (Html.BAlign v) = map Html.BAlign $ shrink v + shrink (Html.BGColor v) = map Html.BGColor $ shrink v + shrink (Html.Border v) = map Html.Border $ shrink v + shrink (Html.CellBorder v) = map Html.CellBorder $ shrink v + shrink (Html.CellPadding v) = map Html.CellPadding $ shrink v + shrink (Html.CellSpacing v) = map Html.CellSpacing $ shrink v + shrink (Html.Color v) = map Html.Color $ shrink v + shrink (Html.ColSpan v) = map Html.ColSpan $ shrink v + shrink (Html.Columns v) = map Html.Columns $ shrink v + shrink (Html.Face v) = map Html.Face $ shrink v + shrink (Html.FixedSize v) = map Html.FixedSize $ shrink v + shrink (Html.GradientAngle v) = map Html.GradientAngle $ shrink v + shrink (Html.Height v) = map Html.Height $ shrink v + shrink (Html.HRef v) = map Html.HRef $ shrink v + shrink (Html.ID v) = map Html.ID $ shrink v + shrink (Html.PointSize v) = map Html.PointSize $ shrink v + shrink (Html.Port v) = map Html.Port $ shrink v + shrink (Html.Rows v) = map Html.Rows $ shrink v + shrink (Html.RowSpan v) = map Html.RowSpan $ shrink v + shrink (Html.Scale v) = map Html.Scale $ shrink v + shrink (Html.Sides v) = map Html.Sides $ listShrink' v + shrink (Html.Src v) = map Html.Src $ shrinkString v + shrink (Html.Style v) = map Html.Style $ shrink v + shrink (Html.Target v) = map Html.Target $ shrink v + shrink (Html.Title v) = map Html.Title $ shrink v + shrink (Html.VAlign v) = map Html.VAlign $ shrink v + shrink (Html.Width v) = map Html.Width $ shrink v instance Arbitrary Html.Scale where arbitrary = arbBounded @@ -950,6 +1021,15 @@ instance Arbitrary Html.VAlign where arbitrary = arbBounded +instance Arbitrary Html.CellFormat where + arbitrary = arbBounded + +instance Arbitrary Html.Side where + arbitrary = arbBounded + +instance Arbitrary Html.Style where + arbitrary = arbBounded + instance Arbitrary PortName where arbitrary = liftM PN $ suchThat arbitrary (liftM2 (&&) (T.all (/=':')) notCP) @@ -958,3 +1038,46 @@ notCP :: Text -> Bool notCP = flip Map.notMember compassLookup + +instance Arbitrary Number where + arbitrary = frequency [ (3, liftM Dbl $ suchThat arbitrary notInt) + , (1, liftM Int arbitrary) + ] + + shrink (Int i) = map Int $ shrink i + shrink (Dbl d) = map Dbl $ filter notInt $ shrink d + +instance Arbitrary Normalized where + arbitrary = oneof [ elements [IsNormalized, NotNormalized] + , liftM NormalizedAngle arbitrary + ] + + shrink (NormalizedAngle a) = map NormalizedAngle $ shrink a + shrink _ = [] + +#if !MIN_VERSION_QuickCheck(2,9,0) +instance Arbitrary Version where + arbitrary = liftM (createVersion . map getPositive) arbList + + shrink = map createVersion . nonEmptyShrinks . versionBranch +#endif + +instance Arbitrary NodeSize where + arbitrary = arbBounded + +{- + +As of Graphviz 2.36.0 this was commented out; as such it might come +back, so leave this here in case we need it again. + +instance Arbitrary AspectType where + arbitrary = oneof [ liftM RatioOnly arbitrary + , liftM2 RatioPassCount arbitrary posArbitrary + ] + + shrink (RatioOnly d) = map RatioOnly $ shrink d + shrink (RatioPassCount d i) = do ds <- shrink d + is <- shrink i + return $ RatioPassCount ds is + +-} diff --git a/tests/Data/GraphViz/Testing/Instances/Canonical.hs b/tests/Data/GraphViz/Testing/Instances/Canonical.hs --- a/tests/Data/GraphViz/Testing/Instances/Canonical.hs +++ b/tests/Data/GraphViz/Testing/Instances/Canonical.hs @@ -13,12 +13,12 @@ import Data.GraphViz.Testing.Instances.Common import Data.GraphViz.Testing.Instances.Helpers +import Data.GraphViz.Internal.Util (bool) import Data.GraphViz.Types.Canonical -import Data.GraphViz.Util(bool) import Test.QuickCheck -import Control.Monad(liftM2, liftM4) +import Control.Monad (liftM2, liftM4) -- ----------------------------------------------------------------------------- -- Defining Arbitrary instances for the overall types @@ -32,10 +32,10 @@ instance (Eq n, Arbitrary n) => Arbitrary (DotStatements n) where arbitrary = sized (arbDS gaGraph True) - shrink ds@(DotStmts gas sgs ns es) = do gas' <- shrinkL gas - sgs' <- shrinkL sgs - ns' <- shrinkL ns - es' <- shrinkL es + shrink ds@(DotStmts gas sgs ns es) = do gas' <- shrink gas + sgs' <- shrink sgs + ns' <- shrink ns + es' <- shrink es returnCheck ds $ DotStmts gas' sgs' ns' es' diff --git a/tests/Data/GraphViz/Testing/Instances/Common.hs b/tests/Data/GraphViz/Testing/Instances/Common.hs --- a/tests/Data/GraphViz/Testing/Instances/Common.hs +++ b/tests/Data/GraphViz/Testing/Instances/Common.hs @@ -17,36 +17,35 @@ import Data.GraphViz.Testing.Instances.Attributes import Data.GraphViz.Testing.Instances.Helpers -import Data.GraphViz.Attributes(Attributes) -import Data.GraphViz.Types.Common( DotNode(..), DotEdge(..) - , GlobalAttributes(..), GraphID(..)) +import Data.GraphViz.Algorithms (CanonicaliseOptions (..)) +import Data.GraphViz.Attributes (Attributes) +import Data.GraphViz.Types.Internal.Common (DotEdge (..), DotNode (..), + GlobalAttributes (..), GraphID (..)) import Test.QuickCheck -import Control.Monad(liftM, liftM2, liftM3) +import Control.Monad (liftM, liftM2, liftM3) -- ----------------------------------------------------------------------------- -- Common values instance Arbitrary GraphID where arbitrary = oneof [ liftM Str arbitrary - , liftM Int arbitrary - , liftM Dbl $ suchThat arbitrary notInt + , liftM Num arbitrary ] shrink (Str s) = map Str $ shrink s - shrink (Int i) = map Int $ shrink i - shrink (Dbl d) = map Dbl $ filter notInt $ shrink d + shrink (Num n) = map Num $ shrink n instance (Arbitrary n) => Arbitrary (DotNode n) where arbitrary = liftM2 DotNode arbitrary arbNodeAttrs - shrink (DotNode n as) = map (DotNode n) $ shrinkList as + shrink (DotNode n as) = map (DotNode n) $ shrink as instance (Arbitrary n) => Arbitrary (DotEdge n) where arbitrary = liftM3 DotEdge arbitrary arbitrary arbEdgeAttrs - shrink (DotEdge f t as) = map (DotEdge f t) $ shrinkList as + shrink (DotEdge f t as) = map (DotEdge f t) $ shrink as instance Arbitrary GlobalAttributes where arbitrary = gaGraph @@ -69,3 +68,6 @@ , liftM NodeAttrs arbNodeAttrs , liftM EdgeAttrs arbEdgeAttrs ] + +instance Arbitrary CanonicaliseOptions where + arbitrary = liftM2 COpts arbitrary arbitrary diff --git a/tests/Data/GraphViz/Testing/Instances/FGL.hs b/tests/Data/GraphViz/Testing/Instances/FGL.hs deleted file mode 100644 --- a/tests/Data/GraphViz/Testing/Instances/FGL.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE FlexibleInstances #-} - -{- | - Module : Data.GraphViz.Testing.Instances.FGL - Description : 'Arbitrary' instances for FGL graphs. - Copyright : (c) Ivan Lazar Miljenovic - License : 3-Clause BSD-style - Maintainer : Ivan.Miljenovic@gmail.com - - This module defines the 'Arbitrary' instances for FGL 'DynGraph' - graphs. Note that this instance cannot be in - "Data.GraphViz.Testing.Instances", as this instance requires the - FlexibleInstances extension, which makes some of the other - 'Arbitrary' instances fail to type-check. --} -module Data.GraphViz.Testing.Instances.FGL() where - -import Test.QuickCheck - -import Data.GraphViz.Util(uniq) - -import Data.Graph.Inductive.Graph(Graph, mkGraph, nodes, delNode) -import Data.List(sortBy) -import Data.Function(on) -import Control.Monad(liftM, liftM3) - --- ----------------------------------------------------------------------------- --- Arbitrary instance for FGL graphs. - -instance (Graph g, Arbitrary n, Arbitrary e) => Arbitrary (g n e) where - arbitrary = do ns <- suchThat genNs (not . null) - let nGen = elements ns - lns <- mapM makeLNode ns - les <- liftM (sortBy (compare `on` toE)) . listOf - $ makeLEdge nGen - return $ mkGraph lns les - where - genNs = liftM uniq arbitrary - toE (f,t,_) = (f,t) - makeLNode n = liftM ((,) n) arbitrary - makeLEdge nGen = liftM3 (,,) nGen nGen arbitrary - - shrink gr = case nodes gr of - -- Need to have at least 2 nodes before we delete one! - ns@(_:_:_) -> map (`delNode` gr) ns - _ -> [] diff --git a/tests/Data/GraphViz/Testing/Instances/Generalised.hs b/tests/Data/GraphViz/Testing/Instances/Generalised.hs --- a/tests/Data/GraphViz/Testing/Instances/Generalised.hs +++ b/tests/Data/GraphViz/Testing/Instances/Generalised.hs @@ -10,17 +10,17 @@ -} module Data.GraphViz.Testing.Instances.Generalised where -import Data.GraphViz.Testing.Instances.Attributes() +import Data.GraphViz.Testing.Instances.Attributes () import Data.GraphViz.Testing.Instances.Common -import Data.GraphViz.Testing.Instances.Helpers() +import Data.GraphViz.Testing.Instances.Helpers () +import Data.GraphViz.Internal.Util (bool) import Data.GraphViz.Types.Generalised -import Data.GraphViz.Util(bool) import Test.QuickCheck +import Control.Monad (liftM, liftM2, liftM4) import qualified Data.Sequence as Seq -import Control.Monad(liftM, liftM2, liftM4) -- ----------------------------------------------------------------------------- -- Defining Arbitrary instances for the generalised types diff --git a/tests/Data/GraphViz/Testing/Instances/Helpers.hs b/tests/Data/GraphViz/Testing/Instances/Helpers.hs --- a/tests/Data/GraphViz/Testing/Instances/Helpers.hs +++ b/tests/Data/GraphViz/Testing/Instances/Helpers.hs @@ -11,14 +11,14 @@ -} module Data.GraphViz.Testing.Instances.Helpers where -import Data.GraphViz.Parsing(isNumString) -import Data.GraphViz.State(initialState, layerSep) +import Data.GraphViz.Internal.State (initialState, layerListSep, layerSep) +import Data.GraphViz.Parsing (isNumString) import Test.QuickCheck +import Control.Monad (liftM, liftM2) +import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as T -import Data.Text.Lazy(Text) -import Control.Monad(liftM, liftM2) -- ----------------------------------------------------------------------------- -- Helper Functions @@ -66,7 +66,7 @@ shrinkString = map T.unpack . shrink . T.pack notNumStr :: Text -> Bool -notNumStr = not . isNumString +notNumStr = not . isNumString True arbBounded :: (Bounded a, Enum a) => Gen a arbBounded = elements [minBound .. maxBound] @@ -74,7 +74,7 @@ arbLayerName :: Gen Text arbLayerName = suchThat arbitrary (T.all notLayerSep) where - defLayerSep = layerSep initialState + defLayerSep = layerSep initialState ++ layerListSep initialState notLayerSep = (`notElem` defLayerSep) arbStyleName :: Gen Text @@ -86,20 +86,20 @@ arbList = listOf1 arbitrary nonEmptyShrinks :: (Arbitrary a) => [a] -> [[a]] -nonEmptyShrinks = filter (not . null) . shrinkList +nonEmptyShrinks = filter (not . null) . shrink nonEmptyShrinks' :: [a] -> [[a]] -nonEmptyShrinks' = filter (not . null) . shrinkList' +nonEmptyShrinks' = filter (not . null) . listShrink' -- Shrink lists with more than one value only by removing values, not -- by shrinking individual items. -shrinkList :: (Arbitrary a) => [a] -> [[a]] -shrinkList [a] = map return $ shrink a -shrinkList as = shrinkList' as +listShrink :: (Arbitrary a) => [a] -> [[a]] +listShrink [a] = map return $ shrink a +listShrink as = listShrink' as -- Just shrink the size. -shrinkList' :: [a] -> [[a]] -shrinkList' as = rm (length as) as +listShrink' :: [a] -> [[a]] +listShrink' as = rm (length as) as where rm 0 _ = [] rm 1 _ = [[]] @@ -125,7 +125,7 @@ shrinkM j = shrink j shrinkL :: (Arbitrary a) => [a] -> [[a]] -shrinkL xs = case shrinkList xs of +shrinkL xs = case listShrink xs of [] -> [xs] xs' -> xs' diff --git a/tests/Data/GraphViz/Testing/Properties.hs b/tests/Data/GraphViz/Testing/Properties.hs --- a/tests/Data/GraphViz/Testing/Properties.hs +++ b/tests/Data/GraphViz/Testing/Properties.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-} {- | Module : Data.GraphViz.Testing.Properties @@ -11,30 +11,38 @@ -} module Data.GraphViz.Testing.Properties where -import Data.GraphViz( dotizeGraph, graphToDot - , setDirectedness, nonClusteredParams) -import Data.GraphViz.Types( DotRepr(..), PrintDotRepr - , DotNode(..), DotEdge(..), GlobalAttributes(..) - , printDotGraph, graphNodes, graphEdges - , graphStructureInformation) -import Data.GraphViz.Types.Canonical(DotGraph(..), DotStatements(..)) +import Data.GraphViz (dotizeGraph, graphToDot, + nonClusteredParams, + setDirectedness) +import Data.GraphViz.Algorithms +import Data.GraphViz.Internal.Util (groupSortBy, isSingle) +import Data.GraphViz.Parsing (ParseDot(..), parseIt, + parseIt') +import Data.GraphViz.PreProcessing (preProcess) +import Data.GraphViz.Printing (PrintDot(..), printIt) +import Data.GraphViz.Testing.Proxy (DGProxy(..)) +import Data.GraphViz.Types (DotEdge(..), DotNode(..), + DotRepr(..), + GlobalAttributes(..), + PrintDotRepr, + edgeInformationClean, + graphEdges, graphNodes, + nodeInformationClean, + printDotGraph) +import Data.GraphViz.Types.Canonical (DotGraph(..), + DotStatements(..)) import qualified Data.GraphViz.Types.Generalised as G -import Data.GraphViz.Printing(PrintDot(..), printIt) -import Data.GraphViz.Parsing(ParseDot(..), parseIt, parseIt') -import Data.GraphViz.PreProcessing(preProcess) -import Data.GraphViz.Util(groupSortBy, isSingle) -import Data.GraphViz.Algorithms import Test.QuickCheck -import Data.Graph.Inductive( Graph, DynGraph - , equal, nmap, emap, labNodes, 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 Data.Text.Lazy(Text) -import Control.Arrow((&&&)) +import Control.Arrow ((&&&)) +import Data.Function (on) +import Data.Graph.Inductive (DynGraph, Graph, edges, emap, equal, + labEdges, labNodes, nmap, nodes) +import Data.List (nub, sort) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Text.Lazy (Text) -- ----------------------------------------------------------------------------- -- The properties to test for @@ -55,7 +63,7 @@ prop_generalisedSameDot :: (Ord n, PrintDot n, ParseDot n) => DotGraph n -> Bool prop_generalisedSameDot dg = printDotGraph dg == printDotGraph gdg where - gdg = canonicalToType (undefined :: G.DotGraph n) dg + gdg = canonicalToType (DGProxy :: DGProxy G.DotGraph) dg -- | Pre-processing shouldn't change the output of printed Dot code. -- This should work for all 'PrintDot' instances, but is more @@ -91,7 +99,7 @@ -- should have unique 'Attributes' (namely the positions). Note -- that this may not hold true with custom supplied 'Attributes' -- (i.e. not using one of the @dotize@ functions). -prop_dotizeAugmentUniq :: (DynGraph g, Eq n, Ord e) => g n e -> Bool +prop_dotizeAugmentUniq :: (DynGraph g, Ord e) => g n e -> Bool prop_dotizeAugmentUniq g = all uniqLs lss where g' = setDirectedness dotizeGraph nonClusteredParams g @@ -104,22 +112,22 @@ -- | Ensure that the definition of 'nodeInformation' for a DotRepr -- finds all the nodes. prop_findAllNodes :: (DotRepr dg Int, Ord el, Graph g) - => dg Int -> g nl el -> Bool -prop_findAllNodes dg' g = ((==) `on` sort) gns dgns + => DGProxy dg -> g nl el -> Bool +prop_findAllNodes dgp g = ((==) `on` sort) gns dgns where gns = nodes g - dg = canonicalToType dg' $ setDirectedness graphToDot nonClusteredParams g + dg = canonicalToType dgp $ setDirectedness graphToDot nonClusteredParams g dgns = map nodeID $ graphNodes dg -- | Ensure that the definition of 'nodeInformation' for DotReprs -- finds all the nodes when the explicit 'DotNode' definitions are -- removed. prop_findAllNodesE :: (DotRepr dg Int, Ord el, Graph g) - => dg Int -> g nl el -> Bool -prop_findAllNodesE dg' g = ((==) `on` sort) gns dgns + => DGProxy dg -> g nl el -> Bool +prop_findAllNodesE dgp g = ((==) `on` sort) gns dgns where gns = nodes g - dg = canonicalToType dg' . removeNodes $ setDirectedness graphToDot nonClusteredParams g + dg = canonicalToType dgp . removeNodes $ setDirectedness graphToDot nonClusteredParams g dgns = map nodeID $ graphNodes dg removeNodes dot@DotGraph{graphStatements = stmts} = dot { graphStatements @@ -130,36 +138,57 @@ -- | Ensure that the definition of 'edgeInformation' for DotReprs -- finds all the nodes. -prop_findAllEdges :: (DotRepr dg Int, Ord el, Graph g) => dg Int -> g nl el -> Bool -prop_findAllEdges dg' g = ((==) `on` sort) ges dges +prop_findAllEdges :: (DotRepr dg Int, Graph g) => DGProxy dg -> g nl el -> Bool +prop_findAllEdges dgp g = ((==) `on` sort) ges dges where ges = edges g - dg = canonicalToType dg' $ graphToDot nonClusteredParams g + dg = canonicalToType dgp $ graphToDot nonClusteredParams g dges = map (fromNode &&& toNode) $ graphEdges dg -- | There should be no clusters or global attributes when converting -- a 'Graph' to a DotRepr (via fromCanonical) without any formatting -- or clustering. prop_noGraphInfo :: (DotRepr dg Int, Ord el, Graph g) - => dg Int -> g nl el -> Bool -prop_noGraphInfo dg' g = info == (GraphAttrs [], Map.empty) + => DGProxy dg -> g nl el -> Bool +prop_noGraphInfo dgp g = info == (GraphAttrs [], Map.empty) where - dg = canonicalToType dg' + dg = canonicalToType dgp $ setDirectedness graphToDot nonClusteredParams g info = graphStructureInformation dg -- | Canonicalisation should be idempotent. -prop_canonicalise :: (ParseDot n, PrintDot n, DotRepr dg n) => dg n -> Bool -prop_canonicalise g = cdg == canonicalise cdg +prop_canonicalise :: (DotRepr dg n) => CanonicaliseOptions -> dg n -> Bool +prop_canonicalise copts g = cdg == canonicaliseOptions copts cdg where - cdg = canonicalise g + cdg = canonicaliseOptions copts g +-- | Canonicalisation shouldn't change any nodes. +prop_canonicaliseNodes :: (DotRepr dg n) => CanonicaliseOptions -> dg n -> Bool +prop_canonicaliseNodes copts g = nodeInformationClean True g + == nodeInformationClean True cdg + where + cdg = canonicaliseOptions copts g + +-- | Canonicalisation shouldn't change any edges. +prop_canonicaliseEdges :: (DotRepr dg n) => CanonicaliseOptions -> dg n -> Bool +prop_canonicaliseEdges copts g = sort (edgeInformationClean True g) + == sort (edgeInformationClean True cdg) + where + cdg = canonicaliseOptions copts g + -- | Removing transitive edges should be idempotent. -prop_transitive :: (DotRepr dg n) => dg n -> Bool -prop_transitive g = tdg == transitiveReduction tdg +prop_transitive :: (DotRepr dg n) => CanonicaliseOptions -> dg n -> Bool +prop_transitive copts g = tdg == transitiveReductionOptions copts tdg where - tdg = transitiveReduction g + tdg = transitiveReductionOptions copts g +-- | Transitive reduction shouldn't change any nodes. +prop_transitiveNodes :: (DotRepr dg n) => CanonicaliseOptions -> dg n -> Bool +prop_transitiveNodes copts g = nodeInformationClean True g + == nodeInformationClean True cdg + where + cdg = transitiveReductionOptions copts g + -- ----------------------------------------------------------------------------- -- Helper utility functions @@ -177,5 +206,5 @@ -- | A wrapper around 'fromCanonical' that lets you specify up-front -- what type to create (it need not be a sensible value). -canonicalToType :: (DotRepr dg n) => dg n -> DotGraph n -> dg n +canonicalToType :: (DotRepr dg n) => DGProxy dg -> DotGraph n -> dg n canonicalToType _ = fromCanonical diff --git a/tests/Data/GraphViz/Testing/Proxy.hs b/tests/Data/GraphViz/Testing/Proxy.hs new file mode 100644 --- /dev/null +++ b/tests/Data/GraphViz/Testing/Proxy.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE KindSignatures #-} + +{- | + Module : Data.GraphViz.Testing.Proxy + Description : Proxy implementation + Copyright : Matthew Sackman, Ivan Lazar Miljenovic + License : BSD3 + Maintainer : Ivan.Miljenovic@gmail.com + + Data.Proxy was added to base with GHC 7.8.1, and we want to test + for older versions than that. + + -} +module Data.GraphViz.Testing.Proxy where + +-------------------------------------------------------------------------------- + +data DGProxy (dg :: * -> *) = DGProxy + deriving (Eq, Ord, Show, Read) diff --git a/tests/Data/GraphViz/Types/CanonicalSpec.hs b/tests/Data/GraphViz/Types/CanonicalSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/GraphViz/Types/CanonicalSpec.hs @@ -0,0 +1,44 @@ +{- | + Module : Data.GraphViz.Types.CanonicalSpec + Description : Testing canonical graph representation + Copyright : Matthew Sackman, Ivan Lazar Miljenovic + License : BSD3 + Maintainer : Ivan.Miljenovic@gmail.com + + + + -} +module Data.GraphViz.Types.CanonicalSpec (spec) where + +import Data.GraphViz.Testing.Instances () +import Data.GraphViz.Testing.Properties (prop_findAllEdges, prop_findAllNodes, + prop_findAllNodesE, + prop_generalisedSameDot, + prop_noGraphInfo, prop_printParseID) +import Data.GraphViz.Testing.Proxy (DGProxy(..)) +import Data.GraphViz.Types.Canonical (DotGraph) + +import Test.Hspec (Spec) +import Test.Hspec.QuickCheck (prop) + +import Data.Graph.Inductive.PatriciaTree (Gr) + +-------------------------------------------------------------------------------- + +spec :: Spec +spec = do + prop "Generalising a graph doesn't change Dot code" + (prop_generalisedSameDot :: DotGraph Int -> Bool) + prop "Printing and parsing Dot graph" + (prop_printParseID :: DotGraph Int -> Bool) + prop "Find all nodes in a Dot graph" + (prop_findAllNodes dproxy :: Gr () () -> Bool) + prop "Find all nodes in an node-less Dot graph" + (prop_findAllNodesE dproxy :: Gr () () -> Bool) + prop "Find all edges in a Dot graph" + (prop_findAllEdges dproxy :: Gr () () -> Bool) + prop "Plain Dot graphs should have no structural information" + (prop_noGraphInfo dproxy :: Gr () () -> Bool) + +dproxy :: DGProxy DotGraph +dproxy = DGProxy diff --git a/tests/Data/GraphViz/Types/GeneralisedSpec.hs b/tests/Data/GraphViz/Types/GeneralisedSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/GraphViz/Types/GeneralisedSpec.hs @@ -0,0 +1,41 @@ +{- | + Module : Data.GraphViz.Types.GeneralisedSpec + Description : Testing generalised graph representation + Copyright : Matthew Sackman, Ivan Lazar Miljenovic + License : BSD3 + Maintainer : Ivan.Miljenovic@gmail.com + + + + -} +module Data.GraphViz.Types.GeneralisedSpec (spec) where + +import Data.GraphViz.Testing.Instances () +import Data.GraphViz.Testing.Properties (prop_findAllEdges, prop_findAllNodes, + prop_findAllNodesE, prop_noGraphInfo, + prop_printParseID) +import Data.GraphViz.Testing.Proxy (DGProxy(..)) +import Data.GraphViz.Types.Generalised (DotGraph) + +import Test.Hspec (Spec) +import Test.Hspec.QuickCheck (prop) + +import Data.Graph.Inductive.PatriciaTree (Gr) + +-------------------------------------------------------------------------------- + +spec :: Spec +spec = do + prop "Printing and parsing Dot graph" + (prop_printParseID :: DotGraph Int -> Bool) + prop "Find all nodes in a Dot graph" + (prop_findAllNodes dproxy :: Gr () () -> Bool) + prop "Find all nodes in an node-less Dot graph" + (prop_findAllNodesE dproxy :: Gr () () -> Bool) + prop "Find all edges in a Dot graph" + (prop_findAllEdges dproxy :: Gr () () -> Bool) + prop "Plain Dot graphs should have no structural information" + (prop_noGraphInfo dproxy :: Gr () () -> Bool) + +dproxy :: DGProxy DotGraph +dproxy = DGProxy diff --git a/tests/Data/GraphViz/Types/GraphSpec.hs b/tests/Data/GraphViz/Types/GraphSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/GraphViz/Types/GraphSpec.hs @@ -0,0 +1,59 @@ +{- | + Module : Data.GraphViz.Types.GraphSpec + Description : Testing graph-based graph representation + Copyright : Matthew Sackman, Ivan Lazar Miljenovic + License : BSD3 + Maintainer : Ivan.Miljenovic@gmail.com + + + + -} +module Data.GraphViz.Types.GraphSpec (spec) where + +import Data.GraphViz.Testing.Instances () +import Data.GraphViz.Testing.Properties (prop_findAllEdges, prop_findAllNodes, + prop_findAllNodesE, prop_noGraphInfo, + prop_printParseID) +import Data.GraphViz.Testing.Proxy (DGProxy(..)) +import Data.GraphViz.Types (edgeInformation) +import Data.GraphViz.Types.Graph (Context(..), DotEdge(..), DotGraph, + DotNode(..), addEdge, emptyGraph, + mkGraph, (&)) + +import Test.Hspec (Spec, describe, it) +import Test.Hspec.QuickCheck (prop) + +import Data.Graph.Inductive.PatriciaTree (Gr) + +-------------------------------------------------------------------------------- + +spec :: Spec +spec = do + prop "Printing and parsing Dot graph" + (prop_printParseID :: DotGraph Int -> Bool) + prop "Find all nodes in a Dot graph" + (prop_findAllNodes dproxy :: Gr () () -> Bool) + prop "Find all nodes in an node-less Dot graph" + (prop_findAllNodesE dproxy :: Gr () () -> Bool) + prop "Find all edges in a Dot graph" + (prop_findAllEdges dproxy :: Gr () () -> Bool) + prop "Plain Dot graphs should have no structural information" + (prop_noGraphInfo dproxy :: Gr () () -> Bool) + + describe "issue#28" $ do + it "mkGraph retains proper edge order" $ + hasEdge (mkGraph [DotNode 0 [], DotNode 1 []] [DotEdge 0 1 []]) (0,1) + it "& retains proper edge order" $ + hasEdge (Cntxt { node = 1, inCluster = Nothing, attributes = [], predecessors = [(0,[])], successors = []} + & Cntxt { node = 0, inCluster = Nothing, attributes = [], predecessors = [], successors = []} + & emptyGraph) + (0,1) + it "addEdge retains proper edge order" $ + hasEdge (addEdge 0 1 [] (mkGraph [DotNode 0 [], DotNode 1 []] [])) (0,1) + + +dproxy :: DGProxy DotGraph +dproxy = DGProxy + +hasEdge :: DotGraph Int -> (Int,Int) -> Bool +hasEdge dg (f,t) = edgeInformation False dg == [DotEdge f t []] diff --git a/tests/Data/GraphVizSpec.hs b/tests/Data/GraphVizSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/GraphVizSpec.hs @@ -0,0 +1,34 @@ +{- | + Module : Data.GraphVizSpec + Description : Testing algorithms + Copyright : Matthew Sackman, Ivan Lazar Miljenovic + License : BSD3 + Maintainer : Ivan.Miljenovic@gmail.com + + + + -} +module Data.GraphVizSpec (spec) where + +import Data.GraphViz.Testing.Instances () +import Data.GraphViz.Testing.Properties (prop_dotizeAugment, + prop_dotizeAugmentUniq, + prop_dotizeHasAugment) + +import Test.Hspec (Spec) +import Test.Hspec.QuickCheck (prop) + +import Data.Graph.Inductive.PatriciaTree (Gr) + +-------------------------------------------------------------------------------- + +spec :: Spec +spec = do + prop "FGL Graphs are augmentable" + (prop_dotizeAugment :: GrType -> Bool) + prop "Ensure augmentation is valid" + (prop_dotizeHasAugment :: GrType -> Bool) + prop "Unique edges in augmented FGL Graphs" + (prop_dotizeAugmentUniq :: GrType -> Bool) + +type GrType = Gr Char Double diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,23 @@ +{- | + Module : Main + Description : Top-level HSpec runner + Copyright : Matthew Sackman, Ivan Lazar Miljenovic + License : BSD3 + Maintainer : Ivan.Miljenovic@gmail.com + + Used as we want to wrap default QuickCheck configurations. + + -} +module Main where + +import qualified Spec +import Test.Hspec.QuickCheck (modifyMaxSize, modifyMaxSuccess) +import Test.Hspec.Runner (hspec) + +-------------------------------------------------------------------------------- + +main :: IO () +main = hspec + . modifyMaxSuccess (const 200) + . modifyMaxSize (const 50) + $ Spec.spec diff --git a/tests/RunTests.hs b/tests/RunTests.hs deleted file mode 100644 --- a/tests/RunTests.hs +++ /dev/null @@ -1,83 +0,0 @@ -{- | - Module : RunTests - Description : Run the graphviz test suite. - Copyright : (c) Ivan Lazar Miljenovic - License : 3-Clause BSD-style - Maintainer : Ivan.Miljenovic@gmail.com - - This module exists solely to make a Main module to build and run - the test suite. --} -module Main where - -import Data.GraphViz.Testing( Test(name, lookupName) - , defaultTests, runChosenTests) - -import Data.Char(toLower) -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 = 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 ++ " Run the test associated with each key," - , " (where denotes a space-separated list of keys" - , " from the table below)." - , "" - , 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,_)) = 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 diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} diff --git a/utils/AttributeGenerator.hs b/utils/AttributeGenerator.hs --- a/utils/AttributeGenerator.hs +++ b/utils/AttributeGenerator.hs @@ -148,14 +148,14 @@ . asRows . firstOthers equals (char '|') . (++ [defUnknown]) - . map createDefn + . map createDf $ atts att derivs = nest tab $ text "deriving (Eq, Ord, Show, Read)" - createDefn a = [cnst a <+> vtypeCode a - , if isEmpty cm - then empty - else text "-- ^" <+> cm - ] + createDf a = [cnst a <+> vtypeCode a + , if isEmpty cm + then empty + else text "-- ^" <+> cm + ] where cm = comment a defUnknown = [ unknownAttr <+> unknownNameAlias <+> vtype Strng @@ -170,17 +170,19 @@ where tp = tpNm att -nameAlias :: Atts -> Code -nameAlias att = comment - $$ (text "type" - <+> unknownNameAlias - <+> equals - <+> vtype Strng) +-- The Atts value isn't used; this is just to make it have the same +-- type as the other code-generating functions. +nameAlias :: Atts -> Code +nameAlias _ = cmnt + $$ (text "type" + <+> unknownNameAlias + <+> equals + <+> vtype Strng) where - comment = text "-- | The name for an" <+> unknownAttr - <> text "; must satisfy " - <+> quotes validUnknownName - <> text "." + cmnt = text "-- | The name for an" <+> unknownAttr + <> text "; must satisfy " + <+> quotes validUnknownName + <> text "." unknownNameAlias :: Code unknownNameAlias = text "AttributeName" @@ -191,7 +193,6 @@ hdr = text "instance" <+> text "PrintDot" <+> tpNm att <+> text "where" var = char 'v' sFunc = text "unqtDot" - cnct = text "<>" insts = asRows . (++ [unknownInst]) . map mkInstance @@ -227,17 +228,26 @@ $ 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 + | 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") + unknownName = text "attrName" + pUnknown = text "do" + <+> ( (unknownName <+> text "<- stringBlock") + $$ (text "liftEqParse" + <+> (parens (text "\"" <> unknownAttr <+> text "(\"" + <+> text "++ T.unpack" <+> unknownName + <+> text "++ \")\"") + $$ parens (unknownAttr <+> unknownName) + ) + ) + ) arbitraryInstance :: Atts -> Code arbitraryInstance att = hdr $+$ fns @@ -310,17 +320,21 @@ . concatMap parseNames $ atts att -arbitraryFor :: VType -> Doc -arbitraryFor (Cust ('[':_)) = text "arbList" -arbitraryFor _ = text "arbitrary" +arbitraryFor :: VType -> Doc +arbitraryFor = text . bool "arbitrary" "arbList" . isListType arbitraryFor' :: Attribute -> Doc arbitraryFor' = arbitraryFor . valtype shrinkFor :: VType -> Doc -shrinkFor (Cust ('[':_)) = text "nonEmptyShrinks" -shrinkFor _ = text "shrink" +shrinkFor = text . bool "shrink" "nonEmptyShrinks" . isListType +-- Some types are aliases for lists. +isListType :: VType -> Bool +isListType (Cust ('[':_)) = True +isListType (Cust "ColorList") = True +isListType _ = False + usedByFunc :: String -> (Attribute -> Bool) -> Atts -> Code usedByFunc nm p att = cmnt $$ asRows (tpSig : trs ++ [fls]) where @@ -448,168 +462,375 @@ -- The actual attributes --- ColorScheme is put earlier so that when sorting, it comes before the various *Color attributes. +-- Don't edit this value directly; edit the table below instead. attributes :: [Attribute] -attributes = [ makeAttr "Damping" ["Damping"] "G" Dbl Nothing (Just "0.99") (Just "@0.99@") (Just "@0.0@") (Just "neato only") - , makeAttr "K" ["K"] "GC" Dbl Nothing (Just "0.3") (Just "@0.3@") (Just "@0@") (Just "sfdp, fdp only") - , makeAttr "URL" ["URL", "href"] "ENGC" EStrng Nothing (Just "\"\"") (Just "none") Nothing (Just "svg, postscript, map only") - , makeAttr "ArrowHead" ["arrowhead"] "E" (Cust "ArrowType") Nothing (Just "normal") (Just "@'normal'@") Nothing Nothing - , makeAttr "ArrowSize" ["arrowsize"] "E" Dbl Nothing (Just "1") (Just "@1.0@") (Just "@0.0@") Nothing - , makeAttr "ArrowTail" ["arrowtail"] "E" (Cust "ArrowType") Nothing (Just "normal") (Just "@'normal'@") Nothing Nothing - , makeAttr "Aspect" ["aspect"] "G" (Cust "AspectType") Nothing Nothing Nothing Nothing (Just "dot only") - , makeAttr "BoundingBox" ["bb"] "G" (Cust "Rect") Nothing Nothing Nothing Nothing (Just "write only") - , makeAttr "ColorScheme" ["colorscheme"] "ENCG" (Cust "ColorScheme") Nothing (Just "X11") (Just "@'X11'@") Nothing Nothing - , makeAttr "BgColor" ["bgcolor"] "GC" (Cust "[Color]") Nothing (Just "[X11Color Transparent]") (Just "@['X11Color' 'Transparent']@") Nothing Nothing - , makeAttr "Center" ["center"] "G" Bl (Just "True") (Just "False") (Just "@'False'@") Nothing Nothing - , makeAttr "ClusterRank" ["clusterrank"] "G" (Cust "ClusterMode") Nothing (Just "Local") (Just "@'Local'@") Nothing (Just "dot only") - , makeAttr "Color" ["color"] "ENC" (Cust "[Color]") Nothing (Just "[X11Color Black]") (Just "@['X11Color' 'Black']@") Nothing Nothing - , makeAttr "Comment" ["comment"] "ENG" Strng Nothing (Just "\"\"") (Just "@\\\"\\\"@") Nothing Nothing - , makeAttr "Compound" ["compound"] "G" Bl (Just "True") (Just "False")(Just "@'False'@") Nothing (Just "dot only") - , makeAttr "Concentrate" ["concentrate"] "G" Bl (Just "True") (Just "False") (Just "@'False'@") Nothing Nothing - , makeAttr "Constraint" ["constraint"] "E" Bl (Just "True") (Just "True") (Just "@'True'@") Nothing (Just "dot only") - , makeAttr "Decorate" ["decorate"] "E" Bl (Just "True") (Just "False") (Just "@'False'@") Nothing Nothing - , makeAttr "DefaultDist" ["defaultdist"] "G" Dbl Nothing Nothing (Just "@1+(avg. len)*sqrt(|V|)@") (Just "@epsilon@") (Just "neato only, only if @'Pack' 'DontPack'@") - , makeAttr "Dim" ["dim"] "G" Integ Nothing (Just "2") (Just "@2@") (Just "@2@") (Just "sfdp, fdp, neato only") - , makeAttr "Dimen" ["dimen"] "G" Integ Nothing (Just "2") (Just "@2@") (Just "@2@") (Just "sfdp, fdp, neato only") - , makeAttr "Dir" ["dir"] "E" (Cust "DirType") Nothing Nothing (Just "@'Forward'@ (directed), @'NoDir'@ (undirected)") Nothing Nothing - , makeAttr "DirEdgeConstraints" ["diredgeconstraints"] "G" (Cust "DEConstraints") (Just "EdgeConstraints") (Just "NoConstraints") (Just "@'NoConstraints'@") Nothing (Just "neato only") - , makeAttr "Distortion" ["distortion"] "N" Dbl Nothing (Just "0") (Just "@0.0@") (Just "@-100.0@") Nothing - , makeAttr "DPI" ["dpi", "resolution"] "G" Dbl Nothing Nothing (Just "@96.0@, @0.0@") Nothing (Just "svg, bitmap output only; \\\"resolution\\\" is a synonym") - , makeAttr "EdgeURL" ["edgeURL", "edgehref"] "E" EStrng Nothing (Just "\"\"") (Just "@\\\"\\\"@") Nothing (Just "svg, map only") - , makeAttr "EdgeTarget" ["edgetarget"] "E" EStrng Nothing Nothing (Just "none") Nothing (Just "svg, map only") - , makeAttr "EdgeTooltip" ["edgetooltip"] "E" EStrng Nothing Nothing (Just "@\\\"\\\"@") Nothing (Just "svg, cmap only") - , makeAttr "Epsilon" ["epsilon"] "G" Dbl Nothing Nothing (Just "@.0001 * # nodes@ (@mode == 'KK'@), @.0001@ (@mode == 'Major'@)") Nothing (Just "neato only") - , makeAttr "ESep" ["esep"] "G" (Cust "DPoint") Nothing (Just "(DVal 3)") (Just "@'DVal' 3@") Nothing (Just "not dot") - , makeAttr "FillColor" ["fillcolor"] "NEC" (Cust "[Color]") Nothing (Just "[X11Color Black]")(Just "@['X11Color' 'LightGray']@ (nodes), @['X11Color' 'Black']@ (clusters)") Nothing Nothing - , makeAttr "FixedSize" ["fixedsize"] "N" Bl (Just "True") (Just "False") (Just "@'False'@") Nothing Nothing - , makeAttr "FontColor" ["fontcolor"] "ENGC" (Cust "Color") Nothing (Just "(X11Color Black)") (Just "@'X11Color' 'Black'@") Nothing Nothing - , makeAttr "FontName" ["fontname"] "ENGC" Strng Nothing (Just "\"Times-Roman\"") (Just "@\\\"Times-Roman\\\"@") Nothing Nothing - , makeAttr "FontNames" ["fontnames"] "G" Strng Nothing (Just "\"\"") (Just "@\\\"\\\"@") Nothing (Just "svg only") - , makeAttr "FontPath" ["fontpath"] "G" Strng Nothing Nothing (Just "system dependent") Nothing Nothing - , makeAttr "FontSize" ["fontsize"] "ENGC" Dbl Nothing (Just "14") (Just "@14.0@") (Just "@1.0@") Nothing - , makeAttr "ForceLabels" ["forcelabels"] "G" Bl (Just "True") (Just "False") (Just "@'False'@") Nothing (Just "Only for 'XLabel' attributes, requires Graphviz >= 2.29.0") - , makeAttr "GradientAngle" ["gradientangle"] "NCG" Integ Nothing (Just "0") (Just "0") Nothing (Just "requires Graphviz >= 2.29.0") - , makeAttr "Group" ["group"] "N" Strng Nothing (Just "\"\"") (Just "@\\\"\\\"@") Nothing (Just "dot only") - , makeAttr "HeadURL" ["headURL", "headhref"] "E" EStrng Nothing (Just "\"\"") (Just "@\\\"\\\"@") Nothing (Just "svg, map only") - , makeAttr "HeadClip" ["headclip"] "E" Bl (Just "True") (Just "True") (Just "@'True'@") Nothing Nothing - , makeAttr "HeadLabel" ["headlabel"] "E" (Cust "Label") Nothing (Just "(StrLabel \"\")") (Just "@'StrLabel' \\\"\\\"@") Nothing Nothing - , makeAttr "HeadPort" ["headport"] "E" (Cust "PortPos") Nothing (Just "(CompassPoint CenterPoint)") (Just "@'CompassPoint' 'CenterPoint'@") Nothing Nothing - , makeAttr "HeadTarget" ["headtarget"] "E" EStrng Nothing (Just "\"\"") (Just "none") Nothing (Just "svg, map only") - , makeAttr "HeadTooltip" ["headtooltip"] "E" EStrng Nothing (Just "\"\"") (Just "@\\\"\\\"@") Nothing (Just "svg, cmap only") - , makeAttr "Height" ["height"] "N" Dbl Nothing (Just "0.5") (Just "@0.5@") (Just "@0.02@") Nothing - , makeAttr "ID" ["id"] "GNE" EStrng Nothing (Just "\"\"") (Just "@\\\"\\\"") Nothing (Just "svg, postscript, map only") - , makeAttr "Image" ["image"] "N" Strng Nothing (Just "\"\"") (Just "@\\\"\\\"@") Nothing Nothing - , makeAttr "ImagePath" ["imagepath"] "G" (Cust "Paths") Nothing (Just "(Paths [])") (Just "@'Paths' []@") Nothing (Just "Printing and parsing is OS-specific, requires Graphviz >= 2.29.0") - , makeAttr "ImageScale" ["imagescale"] "N" (Cust "ScaleType") (Just "UniformScale") (Just "NoScale") (Just "@'NoScale'@") Nothing Nothing - , makeAttr "Label" ["label"] "ENGC" (Cust "Label") Nothing (Just "(StrLabel \"\")") (Just "@'StrLabel' \\\"\\\\N\\\"@ (nodes), @'StrLabel' \\\"\\\"@ (otherwise)") Nothing Nothing - , makeAttr "LabelURL" ["labelURL", "labelhref"] "E" EStrng Nothing (Just "\"\"") (Just "@\\\"\\\"@") Nothing (Just "svg, map only") - , makeAttr "LabelScheme" ["label_scheme"] "G" (Cust "LabelScheme") Nothing (Just "NotEdgeLabel") (Just "@'NotEdgeLabel'@") Nothing (Just "sfdp only, requires Graphviz >= 2.28.0") - , makeAttr "LabelAngle" ["labelangle"] "E" Dbl Nothing (Just "(-25)") (Just "@-25.0@") (Just "@-180.0@") Nothing - , makeAttr "LabelDistance" ["labeldistance"] "E" Dbl Nothing (Just "1") (Just "@1.0@") (Just "@0.0@") Nothing - , makeAttr "LabelFloat" ["labelfloat"] "E" Bl (Just "True") (Just "False") (Just "@'False'@") Nothing Nothing - , makeAttr "LabelFontColor" ["labelfontcolor"] "E" (Cust "Color") Nothing (Just "(X11Color Black)") (Just "@'X11Color' 'Black'@") Nothing Nothing - , makeAttr "LabelFontName" ["labelfontname"] "E" Strng Nothing (Just "\"Times-Roman\"") (Just "@\\\"Times-Roman\\\"@") Nothing Nothing - , makeAttr "LabelFontSize" ["labelfontsize"] "E" Dbl Nothing (Just "14") (Just "@14.0@") (Just "@1.0@") Nothing - , makeAttr "LabelJust" ["labeljust"] "GC" (Cust "Justification") Nothing (Just "JCenter") (Just "@'JCenter'@") Nothing Nothing - , makeAttr "LabelLoc" ["labelloc"] "GCN" (Cust "VerticalPlacement") Nothing (Just "VTop") (Just "@'VTop'@ (clusters), @'VBottom'@ (root graphs), @'VCenter'@ (nodes)") Nothing Nothing - , makeAttr "LabelTarget" ["labeltarget"] "E" EStrng Nothing (Just "\"\"") (Just "none") Nothing (Just "svg, map only") - , makeAttr "LabelTooltip" ["labeltooltip"] "E" EStrng Nothing (Just "\"\"") (Just "@\\\"\\\"@") Nothing (Just "svg, cmap only") - , makeAttr "Landscape" ["landscape"] "G" Bl (Just "True") (Just "False") (Just "@'False'@") Nothing Nothing - , makeAttr "Layer" ["layer"] "EN" (Cust "LayerRange") Nothing Nothing Nothing Nothing Nothing - , makeAttr "Layers" ["layers"] "G" (Cust "LayerList") Nothing (Just "(LL [])") (Just "@'LL' []@") Nothing Nothing - , makeAttr "LayerSep" ["layersep"] "G" (Cust "LayerSep") Nothing (Just "(LSep \" :\\t\")") (Just "@'LSep' \\\" :\\t\\\"@") Nothing Nothing - , makeAttr "Layout" ["layout"] "G" Strng Nothing (Just "\"\"") (Just "@\\\"\\\"@") Nothing Nothing - , makeAttr "Len" ["len"] "E" Dbl Nothing Nothing (Just "@1.0@ (neato), @0.3@ (fdp)") Nothing (Just "fdp, neato only") - , makeAttr "LevelsGap" ["levelsgap"] "G" Dbl Nothing (Just "0") (Just "@0.0@") Nothing (Just "neato only") - , makeAttr "Levels" ["levels"] "G" Integ Nothing (Just "maxBound") (Just "@'maxBound'@") (Just "@0@") (Just "sfdp only") - , makeAttr "LHead" ["lhead"] "E" Strng Nothing (Just "\"\"") (Just "@\\\"\\\"@") Nothing (Just "dot only") - , makeAttr "LHeight" ["LHeight"] "GC" Dbl Nothing Nothing Nothing Nothing (Just "write only, requires Graphviz >= 2.28.0") - , makeAttr "LPos" ["lp"] "EGC" (Cust "Point") Nothing Nothing Nothing Nothing (Just "write only") - , makeAttr "LTail" ["ltail"] "E" Strng Nothing (Just "\"\"") (Just "@\\\"\\\"@") Nothing (Just "dot only") - , makeAttr "LWidth" ["lwidth"] "GC" Dbl Nothing Nothing Nothing Nothing (Just "write only, requires Graphviz >= 2.28.0") - , makeAttr "Margin" ["margin"] "NG" (Cust "DPoint") Nothing Nothing (Just "device dependent") Nothing Nothing - , makeAttr "MaxIter" ["maxiter"] "G" Integ Nothing Nothing (Just "@100 * # nodes@ (@mode == 'KK'@), @200@ (@mode == 'Major'@), @600@ (fdp)") Nothing (Just "fdp, neato only") - , makeAttr "MCLimit" ["mclimit"] "G" Dbl Nothing (Just "1") (Just "@1.0@") Nothing (Just "dot only") - , makeAttr "MinDist" ["mindist"] "G" Dbl Nothing (Just "1") (Just "@1.0@") (Just "@0.0@") (Just "circo only") - , makeAttr "MinLen" ["minlen"] "E" Integ Nothing (Just "1") (Just "@1@") (Just "@0@") (Just "dot only") - , makeAttr "Mode" ["mode"] "G" (Cust "ModeType") Nothing (Just "Major") (Just "@'Major'@") Nothing (Just "neato only") - , makeAttr "Model" ["model"] "G" (Cust "Model") Nothing (Just "ShortPath") (Just "@'ShortPath'@") Nothing (Just "neato only") - , makeAttr "Mosek" ["mosek"] "G" Bl (Just "True") (Just "False") (Just "@'False'@") Nothing (Just "neato only; requires the Mosek software") - , makeAttr "NodeSep" ["nodesep"] "G" Dbl Nothing (Just "0.25") (Just "@0.25@") (Just "@0.02@") (Just "dot only") - , makeAttr "NoJustify" ["nojustify"] "GCNE" Bl (Just "True") (Just "False") (Just "@'False'@") Nothing Nothing - , makeAttr "Normalize" ["normalize"] "G" Bl (Just "True") (Just "False") (Just "@'False'@") Nothing (Just "not dot") - , makeAttr "Nslimit" ["nslimit"] "G" Dbl Nothing Nothing Nothing Nothing (Just "dot only") - , makeAttr "Nslimit1" ["nslimit1"] "G" Dbl Nothing Nothing Nothing Nothing (Just "dot only") - , makeAttr "Ordering" ["ordering"] "GN" (Cust "Order") Nothing Nothing (Just "none") Nothing (Just "dot only") - , makeAttr "Orientation" ["orientation"] "N" Dbl Nothing (Just "0") (Just "@0.0@") (Just "@360.0@") Nothing - , makeAttr "OutputOrder" ["outputorder"] "G" (Cust "OutputMode") Nothing (Just "BreadthFirst") (Just "@'BreadthFirst'@") Nothing Nothing - , makeAttr "Overlap" ["overlap"] "G" (Cust "Overlap") (Just "KeepOverlaps") (Just "KeepOverlaps") (Just "@'KeepOverlaps'@") Nothing (Just "not dot") - , makeAttr "OverlapScaling" ["overlap_scaling"] "G" Dbl Nothing (Just "(-4)") (Just "@-4@") (Just "@-1.0e10@") (Just "prism only") - , makeAttr "Pack" ["pack"] "G" (Cust "Pack") (Just "DoPack") (Just "DontPack") (Just "@'DontPack'@") Nothing (Just "not dot") - , makeAttr "PackMode" ["packmode"] "G" (Cust "PackMode") Nothing (Just "PackNode") (Just "@'PackNode'@") Nothing (Just "not dot") - , makeAttr "Pad" ["pad"] "G" (Cust "DPoint") Nothing (Just "(DVal 0.0555)") (Just "@'DVal' 0.0555@ (4 points)") Nothing Nothing - , makeAttr "Page" ["page"] "G" (Cust "Point") Nothing Nothing Nothing Nothing Nothing - , makeAttr "PageDir" ["pagedir"] "G" (Cust "PageDir") Nothing (Just "Bl") (Just "@'Bl'@") Nothing Nothing - , makeAttr "PenColor" ["pencolor"] "C" (Cust "Color") Nothing (Just "(X11Color Black)") (Just "@'X11Color' 'Black'@") Nothing Nothing - , makeAttr "PenWidth" ["penwidth"] "CNE" Dbl Nothing (Just "1") (Just "@1.0@") (Just "@0.0@") Nothing - , makeAttr "Peripheries" ["peripheries"] "NC" Integ Nothing (Just "1") (Just "shape default (nodes), @1@ (clusters)") (Just "0") Nothing - , makeAttr "Pin" ["pin"] "N" Bl (Just "True") (Just "False") (Just "@'False'@") Nothing (Just "fdp, neato only") - , makeAttr "Pos" ["pos"] "EN" (Cust "Pos") Nothing Nothing Nothing Nothing Nothing - , makeAttr "QuadTree" ["quadtree"] "G" (Cust "QuadType") (Just "NormalQT") (Just "NormalQT") (Just "@'NormalQT'@") Nothing (Just "sfdp only") - , makeAttr "Quantum" ["quantum"] "G" Dbl Nothing (Just "0") (Just "@0.0@") (Just "@0.0@") Nothing - , makeAttr "Rank" ["rank"] "S" (Cust "RankType") Nothing Nothing Nothing Nothing (Just "dot only") - , makeAttr "RankDir" ["rankdir"] "G" (Cust "RankDir") Nothing (Just "FromTop") (Just "@'FromTop'@") Nothing (Just "dot only") - , makeAttr "RankSep" ["ranksep"] "G" (Cust "[Double]") Nothing Nothing (Just "@[0.5]@ (dot), @[1.0]@ (twopi)") (Just "[0.02]") (Just "twopi, dot only") - , makeAttr "Ratio" ["ratio"] "G" (Cust "Ratios") Nothing Nothing Nothing Nothing Nothing - , makeAttr "Rects" ["rects"] "N" (Cust "[Rect]") Nothing Nothing Nothing Nothing (Just "write only") - , makeAttr "Regular" ["regular"] "N" Bl (Just "True") (Just "False") (Just "@'False'@") Nothing Nothing - , makeAttr "ReMinCross" ["remincross"] "G" Bl (Just "True") (Just "False") (Just "@'False'@") Nothing (Just "dot only") - , makeAttr "RepulsiveForce" ["repulsiveforce"] "G" Dbl Nothing (Just "1") (Just "@1.0@") (Just "@0.0@") (Just "sfdp only") - , makeAttr "Root" ["root"] "GN" (Cust "Root") (Just "IsCentral") (Just "(NodeName \"\")") (Just "@'NodeName' \\\"\\\"@ (graphs), @'NotCentral'@ (nodes)") Nothing (Just "circo, twopi only") - , makeAttr "Rotate" ["rotate"] "G" Integ Nothing (Just "0") (Just "@0@") Nothing Nothing - , makeAttr "Rotation" ["rotation"] "G" Dbl Nothing (Just "0") (Just "@0@") Nothing (Just "sfdp only, requires Graphviz >= 2.28.0") - , makeAttr "SameHead" ["samehead"] "E" Strng Nothing (Just "\"\"") (Just "@\\\"\\\"@") Nothing (Just "dot only") - , makeAttr "SameTail" ["sametail"] "E" Strng Nothing (Just "\"\"") (Just "@\\\"\\\"@") Nothing (Just "dot only") - , makeAttr "SamplePoints" ["samplepoints"] "N" Integ Nothing Nothing (Just "@8@ (output), @20@ (overlap and image maps)") Nothing Nothing - , makeAttr "Scale" ["scale"] "G" (Cust "DPoint") Nothing Nothing Nothing Nothing (Just "twopi only, requires Graphviz >= 2.28.0") - , makeAttr "SearchSize" ["searchsize"] "G" Integ Nothing (Just "30") (Just "@30@") Nothing (Just "dot only") - , makeAttr "Sep" ["sep"] "G" (Cust "DPoint") Nothing (Just "(DVal 4)") (Just "@'DVal' 4@") Nothing (Just "not dot") - , makeAttr "Shape" ["shape"] "N" (Cust "Shape") Nothing (Just "Ellipse") (Just "@'Ellipse'@") Nothing Nothing - , makeAttr "ShapeFile" ["shapefile"] "N" Strng Nothing (Just "\"\"") (Just "@\\\"\\\"@") Nothing Nothing - , makeAttr "ShowBoxes" ["showboxes"] "ENG" Integ Nothing (Just "0") (Just "@0@") (Just "@0@") (Just "dot only") - , makeAttr "Sides" ["sides"] "N" Integ Nothing (Just "4") (Just "@4@") (Just "@0@") Nothing - , makeAttr "Size" ["size"] "G" (Cust "Point") Nothing Nothing Nothing Nothing Nothing - , makeAttr "Skew" ["skew"] "N" Dbl Nothing (Just "0") (Just "@0.0@") (Just "@-100.0@") Nothing - , makeAttr "Smoothing" ["smoothing"] "G" (Cust "SmoothType") Nothing (Just "NoSmooth") (Just "@'NoSmooth'@") Nothing (Just "sfdp only") - , makeAttr "SortV" ["sortv"] "GCN" (Cust "Word16") Nothing (Just "0") (Just "@0@") (Just "@0@") Nothing - , makeAttr "Splines" ["splines"] "G" (Cust "EdgeType") (Just "SplineEdges") (Just "SplineEdges") Nothing Nothing Nothing - , makeAttr "Start" ["start"] "G" (Cust "StartType") Nothing Nothing Nothing Nothing (Just "fdp, neato only") - , makeAttr "Style" ["style"] "ENC" (Cust "[StyleItem]") Nothing Nothing Nothing Nothing Nothing - , makeAttr "StyleSheet" ["stylesheet"] "G" Strng Nothing (Just "\"\"") (Just "@\\\"\\\"@") Nothing (Just "svg only") - , makeAttr "TailURL" ["tailURL", "tailhref"] "E" EStrng Nothing (Just "\"\"") (Just "@\\\"\\\"@") Nothing (Just "svg, map only") - , makeAttr "TailClip" ["tailclip"] "E" Bl (Just "True") (Just "True") (Just "@'True'@") Nothing Nothing - , makeAttr "TailLabel" ["taillabel"] "E" (Cust "Label") Nothing (Just "(StrLabel \"\")") (Just "@'StrLabel' \\\"\\\"@") Nothing Nothing - , makeAttr "TailPort" ["tailport"] "E" (Cust "PortPos") Nothing (Just "(CompassPoint CenterPoint)") (Just "@'CompassPoint' 'CenterPoint'@") Nothing Nothing - , makeAttr "TailTarget" ["tailtarget"] "E" EStrng Nothing (Just "\"\"") (Just "none") Nothing (Just "svg, map only") - , makeAttr "TailTooltip" ["tailtooltip"] "E" EStrng Nothing (Just "\"\"") (Just "@\\\"\\\"@") Nothing (Just "svg, cmap only") - , makeAttr "Target" ["target"] "ENGC" EStrng Nothing (Just "\"\"") (Just "none") Nothing (Just "svg, map only") - , makeAttr "Tooltip" ["tooltip"] "NEC" EStrng Nothing (Just "\"\"") (Just "@\\\"\\\"@") Nothing (Just "svg, cmap only") - , makeAttr "TrueColor" ["truecolor"] "G" Bl (Just "True") Nothing Nothing Nothing (Just "bitmap output only") - , makeAttr "Vertices" ["vertices"] "N" (Cust "[Point]") Nothing Nothing Nothing Nothing (Just "write only") - , makeAttr "ViewPort" ["viewport"] "G" (Cust "ViewPort") Nothing Nothing (Just "none") Nothing Nothing - , makeAttr "VoroMargin" ["voro_margin"] "G" Dbl Nothing (Just "0.05") (Just "@0.05@") (Just "@0.0@") (Just "not dot") - , makeAttr "Weight" ["weight"] "E" Dbl Nothing Nothing (Just "@1.0@") (Just "@0@ (dot), @1@ (neato,fdp,sfdp)") Nothing - , makeAttr "Width" ["width"] "N" Dbl Nothing (Just "0.75") (Just "@0.75@") (Just "@0.01@") Nothing - , makeAttr "XLabel" ["xlabel"] "EN" (Cust "Label") Nothing (Just "(StrLabel \"\")") (Just "@'StrLabel' \\\"\\\"@") Nothing (Just "requires Graphviz >= 2.29.0") - , makeAttr "Z" ["z"] "N" Dbl Nothing (Just "0") (Just "@0.0@") (Just "@-MAXFLOAT@, @-1000@") Nothing - ] +attributes = [ + -- BEGIN RECEIVE ORGTBL Attributes + makeAttr "Damping" ["Damping"] "G" (Dbl) Nothing (Just "0.99") (Just "@0.99@") (Just "@0.0@") (Just "'Neato' only"), + makeAttr "K" ["K"] "GC" (Dbl) Nothing (Just "0.3") (Just "@0.3@") (Just "@0@") (Just "'Sfdp', 'Fdp' only"), + makeAttr "URL" ["URL", "href"] "ENGC" (EStrng) Nothing (Just "\"\"") (Just "none") Nothing (Just "svg, postscript, map only"), + makeAttr "Area" ["area"] "NC" (Dbl) Nothing (Just "1.0") (Just "@1.0@") (Just "@>0@") (Just "'Patchwork' only, requires Graphviz >= 2.30.0"), + makeAttr "ArrowHead" ["arrowhead"] "E" (Cust "ArrowType") Nothing (Just "normal") (Just "@'normal'@") Nothing Nothing, + makeAttr "ArrowSize" ["arrowsize"] "E" (Dbl) Nothing (Just "1.0") (Just "@1.0@") (Just "@0.0@") Nothing, + makeAttr "ArrowTail" ["arrowtail"] "E" (Cust "ArrowType") Nothing (Just "normal") (Just "@'normal'@") Nothing Nothing, + makeAttr "Background" ["_background"] "G" (Strng) Nothing (Just "\"\"") (Just "none") Nothing (Just "xdot only"), + makeAttr "BoundingBox" ["bb"] "G" (Cust "Rect") Nothing Nothing Nothing Nothing (Just "write only"), + makeAttr "BgColor" ["bgcolor"] "GC" (Cust "ColorList") Nothing (Just "[]") (Just "@[]@") Nothing Nothing, + makeAttr "Center" ["center"] "G" (Bl) (Just "True") (Just "False") (Just "@'False'@") Nothing Nothing, + makeAttr "ClusterRank" ["clusterrank"] "G" (Cust "ClusterMode") Nothing (Just "Local") (Just "@'Local'@") Nothing (Just "'Dot' only"), + makeAttr "Color" ["color"] "ENC" (Cust "ColorList") Nothing (Just "[toWColor Black]") (Just "@['WC' ('X11Color' 'Black') Nothing]@") Nothing Nothing, + makeAttr "ColorScheme" ["colorscheme"] "ENCG" (Cust "ColorScheme") Nothing (Just "X11") (Just "@'X11'@") Nothing Nothing, + makeAttr "Comment" ["comment"] "ENG" (Strng) Nothing (Just "\"\"") (Just "@\\\"\\\"@") Nothing Nothing, + makeAttr "Compound" ["compound"] "G" (Bl) (Just "True") (Just "False") (Just "@'False'@") Nothing (Just "'Dot' only"), + makeAttr "Concentrate" ["concentrate"] "G" (Bl) (Just "True") (Just "False") (Just "@'False'@") Nothing Nothing, + makeAttr "Constraint" ["constraint"] "E" (Bl) (Just "True") (Just "True") (Just "@'True'@") Nothing (Just "'Dot' only"), + makeAttr "Decorate" ["decorate"] "E" (Bl) (Just "True") (Just "False") (Just "@'False'@") Nothing Nothing, + makeAttr "DefaultDist" ["defaultdist"] "G" (Dbl) Nothing Nothing (Just "@1+(avg. len)*sqrt(abs(V))@ (unable to statically define)") (Just "The value of 'Epsilon'.") (Just "'Neato' only, only if @'Pack' 'DontPack'@"), + makeAttr "Dim" ["dim"] "G" (Integ) Nothing (Just "2") (Just "@2@") (Just "@2@") (Just "maximum of @10@; 'Sfdp', 'Fdp', 'Neato' only"), + makeAttr "Dimen" ["dimen"] "G" (Integ) Nothing (Just "2") (Just "@2@") (Just "@2@") (Just "maximum of @10@; 'Sfdp', 'Fdp', 'Neato' only"), + makeAttr "Dir" ["dir"] "E" (Cust "DirType") Nothing Nothing (Just "@'Forward'@ (directed), @'NoDir'@ (undirected)") Nothing Nothing, + makeAttr "DirEdgeConstraints" ["diredgeconstraints"] "G" (Cust "DEConstraints") (Just "EdgeConstraints") (Just "NoConstraints") (Just "@'NoConstraints'@") Nothing (Just "'Neato' only"), + makeAttr "Distortion" ["distortion"] "N" (Dbl) Nothing (Just "0.0") (Just "@0.0@") (Just "@-100.0@") Nothing, + makeAttr "DPI" ["dpi", "resolution"] "G" (Dbl) Nothing (Just "96.0") (Just "@96.0@, @0.0@") Nothing (Just "svg, bitmap output only; \\\"resolution\\\" is a synonym"), + makeAttr "EdgeURL" ["edgeURL", "edgehref"] "E" (EStrng) Nothing (Just "\"\"") (Just "@\\\"\\\"@") Nothing (Just "svg, map only"), + makeAttr "EdgeTarget" ["edgetarget"] "E" (EStrng) Nothing Nothing (Just "none") Nothing (Just "svg, map only"), + makeAttr "EdgeTooltip" ["edgetooltip"] "E" (EStrng) Nothing (Just "\"\"") (Just "@\\\"\\\"@") Nothing (Just "svg, cmap only"), + makeAttr "Epsilon" ["epsilon"] "G" (Dbl) Nothing Nothing (Just "@.0001 * # nodes@ (@mode == 'KK'@), @.0001@ (@mode == 'Major'@)") Nothing (Just "'Neato' only"), + makeAttr "ESep" ["esep"] "G" (Cust "DPoint") Nothing (Just "(DVal 3)") (Just "@'DVal' 3@") Nothing (Just "not 'Dot'"), + makeAttr "FillColor" ["fillcolor"] "NEC" (Cust "ColorList") Nothing (Just "[toWColor Black]") (Just "@['WC' ('X11Color' 'LightGray') Nothing]@ (nodes), @['WC' ('X11Color' 'Black') Nothing]@ (clusters)") Nothing Nothing, + makeAttr "FixedSize" ["fixedsize"] "N" (Cust "NodeSize") (Just "SetNodeSize") (Just "GrowAsNeeded") (Just "@'GrowAsNeeded'@") Nothing Nothing, + makeAttr "FontColor" ["fontcolor"] "ENGC" (Cust "Color") Nothing (Just "(X11Color Black)") (Just "@'X11Color' 'Black'@") Nothing Nothing, + makeAttr "FontName" ["fontname"] "ENGC" (Strng) Nothing (Just "\"Times-Roman\"") (Just "@\\\"Times-Roman\\\"@") Nothing Nothing, + makeAttr "FontNames" ["fontnames"] "G" (Cust "SVGFontNames") Nothing (Just "SvgNames") (Just "@'SvgNames'@") Nothing (Just "svg only"), + makeAttr "FontPath" ["fontpath"] "G" (Cust "Paths") Nothing Nothing (Just "system dependent") Nothing Nothing, + makeAttr "FontSize" ["fontsize"] "ENGC" (Dbl) Nothing (Just "14.0") (Just "@14.0@") (Just "@1.0@") Nothing, + makeAttr "ForceLabels" ["forcelabels"] "G" (Bl) (Just "True") (Just "True") (Just "@'True'@") Nothing (Just "only for 'XLabel' attributes, requires Graphviz >= 2.29.0"), + makeAttr "GradientAngle" ["gradientangle"] "NCG" (Integ) Nothing (Just "0") (Just "0") Nothing (Just "requires Graphviz >= 2.29.0"), + makeAttr "Group" ["group"] "N" (Strng) Nothing (Just "\"\"") (Just "@\\\"\\\"@") Nothing (Just "'Dot' only"), + makeAttr "HeadURL" ["headURL", "headhref"] "E" (EStrng) Nothing (Just "\"\"") (Just "@\\\"\\\"@") Nothing (Just "svg, map only"), + makeAttr "Head_LP" ["head_lp"] "E" (Cust "Point") Nothing Nothing Nothing Nothing (Just "write only, requires Graphviz >= 2.30.0"), + makeAttr "HeadClip" ["headclip"] "E" (Bl) (Just "True") (Just "True") (Just "@'True'@") Nothing Nothing, + makeAttr "HeadLabel" ["headlabel"] "E" (Cust "Label") Nothing (Just "(StrLabel \"\")") (Just "@'StrLabel' \\\"\\\"@") Nothing Nothing, + makeAttr "HeadPort" ["headport"] "E" (Cust "PortPos") Nothing (Just "(CompassPoint CenterPoint)") (Just "@'CompassPoint' 'CenterPoint'@") Nothing Nothing, + makeAttr "HeadTarget" ["headtarget"] "E" (EStrng) Nothing (Just "\"\"") (Just "none") Nothing (Just "svg, map only"), + makeAttr "HeadTooltip" ["headtooltip"] "E" (EStrng) Nothing (Just "\"\"") (Just "@\\\"\\\"@") Nothing (Just "svg, cmap only"), + makeAttr "Height" ["height"] "N" (Dbl) Nothing (Just "0.5") (Just "@0.5@") (Just "@0.02@") Nothing, + makeAttr "ID" ["id"] "GNE" (EStrng) Nothing (Just "\"\"") (Just "@\\\"\\\"@") Nothing (Just "svg, postscript, map only"), + makeAttr "Image" ["image"] "N" (Strng) Nothing (Just "\"\"") (Just "@\\\"\\\"@") Nothing Nothing, + makeAttr "ImagePath" ["imagepath"] "G" (Cust "Paths") Nothing (Just "(Paths [])") (Just "@'Paths' []@") Nothing (Just "Printing and parsing is OS-specific, requires Graphviz >= 2.29.0"), + makeAttr "ImageScale" ["imagescale"] "N" (Cust "ScaleType") (Just "UniformScale") (Just "NoScale") (Just "@'NoScale'@") Nothing Nothing, + makeAttr "InputScale" ["inputscale"] "N" (Dbl) Nothing Nothing (Just "none") Nothing (Just "'Fdp', 'Neato' only, a value of @0@ is equivalent to being @72@, requires Graphviz >= 2.36.0"), + makeAttr "Label" ["label"] "ENGC" (Cust "Label") Nothing (Just "(StrLabel \"\")") (Just "@'StrLabel' \\\"\\\\N\\\"@ (nodes), @'StrLabel' \\\"\\\"@ (otherwise)") Nothing Nothing, + makeAttr "LabelURL" ["labelURL", "labelhref"] "E" (EStrng) Nothing (Just "\"\"") (Just "@\\\"\\\"@") Nothing (Just "svg, map only"), + makeAttr "LabelScheme" ["label_scheme"] "G" (Cust "LabelScheme") Nothing (Just "NotEdgeLabel") (Just "@'NotEdgeLabel'@") Nothing (Just "'Sfdp' only, requires Graphviz >= 2.28.0"), + makeAttr "LabelAngle" ["labelangle"] "E" (Dbl) Nothing (Just "(-25.0)") (Just "@-25.0@") (Just "@-180.0@") Nothing, + makeAttr "LabelDistance" ["labeldistance"] "E" (Dbl) Nothing (Just "1.0") (Just "@1.0@") (Just "@0.0@") Nothing, + makeAttr "LabelFloat" ["labelfloat"] "E" (Bl) (Just "True") (Just "False") (Just "@'False'@") Nothing Nothing, + makeAttr "LabelFontColor" ["labelfontcolor"] "E" (Cust "Color") Nothing (Just "(X11Color Black)") (Just "@'X11Color' 'Black'@") Nothing Nothing, + makeAttr "LabelFontName" ["labelfontname"] "E" (Strng) Nothing (Just "\"Times-Roman\"") (Just "@\\\"Times-Roman\\\"@") Nothing Nothing, + makeAttr "LabelFontSize" ["labelfontsize"] "E" (Dbl) Nothing (Just "14.0") (Just "@14.0@") (Just "@1.0@") Nothing, + makeAttr "LabelJust" ["labeljust"] "GC" (Cust "Justification") Nothing (Just "JCenter") (Just "@'JCenter'@") Nothing Nothing, + makeAttr "LabelLoc" ["labelloc"] "GCN" (Cust "VerticalPlacement") Nothing (Just "VTop") (Just "@'VTop'@ (clusters), @'VBottom'@ (root graphs), @'VCenter'@ (nodes)") Nothing Nothing, + makeAttr "LabelTarget" ["labeltarget"] "E" (EStrng) Nothing (Just "\"\"") (Just "none") Nothing (Just "svg, map only"), + makeAttr "LabelTooltip" ["labeltooltip"] "E" (EStrng) Nothing (Just "\"\"") (Just "@\\\"\\\"@") Nothing (Just "svg, cmap only"), + makeAttr "Landscape" ["landscape"] "G" (Bl) (Just "True") (Just "False") (Just "@'False'@") Nothing Nothing, + makeAttr "Layer" ["layer"] "ENC" (Cust "LayerRange") Nothing (Just "[]") (Just "@[]@") Nothing Nothing, + makeAttr "LayerListSep" ["layerlistsep"] "G" (Cust "LayerListSep") Nothing (Just "(LLSep \",\")") (Just "@'LLSep' \\\",\\\"@") Nothing (Just "requires Graphviz >= 2.30.0"), + makeAttr "Layers" ["layers"] "G" (Cust "LayerList") Nothing (Just "(LL [])") (Just "@'LL' []@") Nothing Nothing, + makeAttr "LayerSelect" ["layerselect"] "G" (Cust "LayerRange") Nothing (Just "[]") (Just "@[]@") Nothing Nothing, + makeAttr "LayerSep" ["layersep"] "G" (Cust "LayerSep") Nothing (Just "(LSep \" :\\t\")") (Just "@'LSep' \\\" :\\t\\\"@") Nothing Nothing, + makeAttr "Layout" ["layout"] "G" (Cust "GraphvizCommand") Nothing Nothing Nothing Nothing Nothing, + makeAttr "Len" ["len"] "E" (Dbl) Nothing Nothing (Just "@1.0@ ('Neato'), @0.3@ ('Fdp')") Nothing (Just "'Fdp', 'Neato' only"), + makeAttr "Levels" ["levels"] "G" (Integ) Nothing (Just "maxBound") (Just "@'maxBound'@") (Just "@0@") (Just "'Sfdp' only"), + makeAttr "LevelsGap" ["levelsgap"] "G" (Dbl) Nothing (Just "0.0") (Just "@0.0@") Nothing (Just "'Neato' only"), + makeAttr "LHead" ["lhead"] "E" (Strng) Nothing (Just "\"\"") (Just "@\\\"\\\"@") Nothing (Just "'Dot' only"), + makeAttr "LHeight" ["LHeight"] "GC" (Dbl) Nothing Nothing Nothing Nothing (Just "write only, requires Graphviz >= 2.28.0"), + makeAttr "LPos" ["lp"] "EGC" (Cust "Point") Nothing Nothing Nothing Nothing (Just "write only"), + makeAttr "LTail" ["ltail"] "E" (Strng) Nothing (Just "\"\"") (Just "@\\\"\\\"@") Nothing (Just "'Dot' only"), + makeAttr "LWidth" ["lwidth"] "GC" (Dbl) Nothing Nothing Nothing Nothing (Just "write only, requires Graphviz >= 2.28.0"), + makeAttr "Margin" ["margin"] "NGC" (Cust "DPoint") Nothing Nothing (Just "device dependent") Nothing Nothing, + makeAttr "MaxIter" ["maxiter"] "G" (Integ) Nothing 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") (Just "@1.0@") Nothing (Just "'Dot' only"), + makeAttr "MinDist" ["mindist"] "G" (Dbl) Nothing (Just "1.0") (Just "@1.0@") (Just "@0.0@") (Just "'Circo' only"), + makeAttr "MinLen" ["minlen"] "E" (Integ) Nothing (Just "1") (Just "@1@") (Just "@0@") (Just "'Dot' only"), + makeAttr "Mode" ["mode"] "G" (Cust "ModeType") Nothing (Just "Major") (Just "@'Major'@ (actually @'Spring'@ for 'Sfdp', but this isn't used as a default in this library)") Nothing (Just "'Neato', 'Sfdp' only"), + makeAttr "Model" ["model"] "G" (Cust "Model") Nothing (Just "ShortPath") (Just "@'ShortPath'@") Nothing (Just "'Neato' only"), + makeAttr "Mosek" ["mosek"] "G" (Bl) (Just "True") (Just "False") (Just "@'False'@") Nothing (Just "'Neato' only; requires the Mosek software"), + makeAttr "NodeSep" ["nodesep"] "G" (Dbl) Nothing (Just "0.25") (Just "@0.25@") (Just "@0.02@") Nothing, + makeAttr "NoJustify" ["nojustify"] "GCNE" (Bl) (Just "True") (Just "False") (Just "@'False'@") Nothing Nothing, + makeAttr "Normalize" ["normalize"] "G" (Cust "Normalized") (Just "IsNormalized") (Just "NotNormalized") (Just "@'NotNormalized'@") Nothing (Just "not 'Dot'"), + makeAttr "NoTranslate" ["notranslate"] "G" (Bl) (Just "True") (Just "False") (Just "@'False'@") Nothing (Just "'Neato' only, requires Graphviz >= 2.38.0"), + makeAttr "Nslimit" ["nslimit"] "G" (Dbl) Nothing Nothing Nothing Nothing (Just "'Dot' only"), + makeAttr "Nslimit1" ["nslimit1"] "G" (Dbl) Nothing Nothing Nothing Nothing (Just "'Dot' only"), + makeAttr "Ordering" ["ordering"] "GN" (Cust "Order") Nothing Nothing (Just "none") Nothing (Just "'Dot' only"), + makeAttr "Orientation" ["orientation"] "N" (Dbl) Nothing (Just "0.0") (Just "@0.0@") (Just "@360.0@") Nothing, + makeAttr "OutputOrder" ["outputorder"] "G" (Cust "OutputMode") Nothing (Just "BreadthFirst") (Just "@'BreadthFirst'@") Nothing Nothing, + makeAttr "Overlap" ["overlap"] "G" (Cust "Overlap") (Just "KeepOverlaps") (Just "KeepOverlaps") (Just "@'KeepOverlaps'@") Nothing (Just "not 'Dot'"), + makeAttr "OverlapScaling" ["overlap_scaling"] "G" (Dbl) Nothing (Just "(-4)") (Just "@-4@") (Just "@-1.0e10@") (Just "'PrismOverlap' only"), + makeAttr "OverlapShrink" ["overlap_shrink"] "G" (Bl) (Just "True") (Just "True") (Just "@'True'@") Nothing (Just "'PrismOverlap' only, requires Graphviz >= 2.36.0"), + makeAttr "Pack" ["pack"] "G" (Cust "Pack") (Just "DoPack") (Just "DontPack") (Just "@'DontPack'@") Nothing Nothing, + makeAttr "PackMode" ["packmode"] "G" (Cust "PackMode") Nothing (Just "PackNode") (Just "@'PackNode'@") Nothing Nothing, + makeAttr "Pad" ["pad"] "G" (Cust "DPoint") Nothing (Just "(DVal 0.0555)") (Just "@'DVal' 0.0555@ (4 points)") Nothing Nothing, + makeAttr "Page" ["page"] "G" (Cust "Point") Nothing Nothing Nothing Nothing Nothing, + makeAttr "PageDir" ["pagedir"] "G" (Cust "PageDir") Nothing (Just "Bl") (Just "@'Bl'@") Nothing Nothing, + makeAttr "PenColor" ["pencolor"] "C" (Cust "Color") Nothing (Just "(X11Color Black)") (Just "@'X11Color' 'Black'@") Nothing Nothing, + makeAttr "PenWidth" ["penwidth"] "CNE" (Dbl) Nothing (Just "1.0") (Just "@1.0@") (Just "@0.0@") Nothing, + makeAttr "Peripheries" ["peripheries"] "NC" (Integ) Nothing (Just "1") (Just "shape default (nodes), @1@ (clusters)") (Just "0") Nothing, + makeAttr "Pin" ["pin"] "N" (Bl) (Just "True") (Just "False") (Just "@'False'@") Nothing (Just "'Fdp', 'Neato' only"), + makeAttr "Pos" ["pos"] "EN" (Cust "Pos") Nothing Nothing Nothing Nothing Nothing, + makeAttr "QuadTree" ["quadtree"] "G" (Cust "QuadType") (Just "NormalQT") (Just "NormalQT") (Just "@'NormalQT'@") Nothing (Just "'Sfdp' only"), + makeAttr "Quantum" ["quantum"] "G" (Dbl) Nothing (Just "0") (Just "@0.0@") (Just "@0.0@") Nothing, + makeAttr "Rank" ["rank"] "S" (Cust "RankType") Nothing Nothing Nothing Nothing (Just "'Dot' only"), + makeAttr "RankDir" ["rankdir"] "G" (Cust "RankDir") Nothing (Just "FromTop") (Just "@'FromTop'@") Nothing (Just "'Dot' only"), + makeAttr "RankSep" ["ranksep"] "G" (Cust "[Double]") Nothing Nothing (Just "@[0.5]@ ('Dot'), @[1.0]@ ('Twopi')") (Just "@[0.02]@") (Just "'Twopi', 'Dot' only"), + makeAttr "Ratio" ["ratio"] "G" (Cust "Ratios") Nothing Nothing Nothing Nothing Nothing, + makeAttr "Rects" ["rects"] "N" (Cust "[Rect]") Nothing Nothing Nothing Nothing (Just "write only"), + makeAttr "Regular" ["regular"] "N" (Bl) (Just "True") (Just "False") (Just "@'False'@") Nothing Nothing, + makeAttr "ReMinCross" ["remincross"] "G" (Bl) (Just "True") (Just "False") (Just "@'False'@") Nothing (Just "'Dot' only"), + makeAttr "RepulsiveForce" ["repulsiveforce"] "G" (Dbl) Nothing (Just "1.0") (Just "@1.0@") (Just "@0.0@") (Just "'Sfdp' only"), + makeAttr "Root" ["root"] "GN" (Cust "Root") (Just "IsCentral") (Just "(NodeName \"\")") (Just "@'NodeName' \\\"\\\"@ (graphs), @'NotCentral'@ (nodes)") Nothing (Just "'Circo', 'Twopi' only"), + makeAttr "Rotate" ["rotate"] "G" (Integ) Nothing (Just "0") (Just "@0@") Nothing Nothing, + makeAttr "Rotation" ["rotation"] "G" (Dbl) Nothing (Just "0") (Just "@0@") Nothing (Just "'Sfdp' only, requires Graphviz >= 2.28.0"), + makeAttr "SameHead" ["samehead"] "E" (Strng) Nothing (Just "\"\"") (Just "@\\\"\\\"@") Nothing (Just "'Dot' only"), + makeAttr "SameTail" ["sametail"] "E" (Strng) Nothing (Just "\"\"") (Just "@\\\"\\\"@") Nothing (Just "'Dot' only"), + makeAttr "SamplePoints" ["samplepoints"] "N" (Integ) Nothing Nothing (Just "@8@ (output), @20@ (overlap and image maps)") Nothing Nothing, + makeAttr "Scale" ["scale"] "G" (Cust "DPoint") Nothing Nothing Nothing Nothing (Just "Not 'Dot', requires Graphviz >= 2.28.0 (>= 2.38.0 for anything except 'TwoPi')"), + makeAttr "SearchSize" ["searchsize"] "G" (Integ) Nothing (Just "30") (Just "@30@") Nothing (Just "'Dot' only"), + makeAttr "Sep" ["sep"] "G" (Cust "DPoint") Nothing (Just "(DVal 4)") (Just "@'DVal' 4@") Nothing (Just "not 'Dot'"), + makeAttr "Shape" ["shape"] "N" (Cust "Shape") Nothing (Just "Ellipse") (Just "@'Ellipse'@") Nothing Nothing, + makeAttr "ShowBoxes" ["showboxes"] "ENG" (Integ) Nothing (Just "0") (Just "@0@") (Just "@0@") (Just "'Dot' only; used for debugging by printing PostScript guide boxes"), + makeAttr "Sides" ["sides"] "N" (Integ) Nothing (Just "4") (Just "@4@") (Just "@0@") Nothing, + makeAttr "Size" ["size"] "G" (Cust "GraphSize") Nothing Nothing Nothing Nothing Nothing, + makeAttr "Skew" ["skew"] "N" (Dbl) Nothing (Just "0.0") (Just "@0.0@") (Just "@-100.0@") Nothing, + makeAttr "Smoothing" ["smoothing"] "G" (Cust "SmoothType") Nothing (Just "NoSmooth") (Just "@'NoSmooth'@") Nothing (Just "'Sfdp' only"), + makeAttr "SortV" ["sortv"] "GCN" (Cust "Word16") Nothing (Just "0") (Just "@0@") (Just "@0@") Nothing, + makeAttr "Splines" ["splines"] "G" (Cust "EdgeType") (Just "SplineEdges") Nothing (Just "@'SplineEdges'@ ('Dot'), @'LineEdges'@ (other)") Nothing Nothing, + makeAttr "Start" ["start"] "G" (Cust "StartType") Nothing Nothing (Just "@'StartStyleSeed' 'RandomStyle' seed@ for some unknown fixed seed.") Nothing (Just "'Fdp', 'Neato' only"), + makeAttr "Style" ["style"] "ENCG" (Cust "[StyleItem]") Nothing Nothing Nothing Nothing Nothing, + makeAttr "StyleSheet" ["stylesheet"] "G" (Strng) Nothing (Just "\"\"") (Just "@\\\"\\\"@") Nothing (Just "svg only"), + makeAttr "TailURL" ["tailURL", "tailhref"] "E" (EStrng) Nothing (Just "\"\"") (Just "@\\\"\\\"@") Nothing (Just "svg, map only"), + makeAttr "Tail_LP" ["tail_lp"] "E" (Cust "Point") Nothing Nothing Nothing Nothing (Just "write only, requires Graphviz >= 2.30.0"), + makeAttr "TailClip" ["tailclip"] "E" (Bl) (Just "True") (Just "True") (Just "@'True'@") Nothing Nothing, + makeAttr "TailLabel" ["taillabel"] "E" (Cust "Label") Nothing (Just "(StrLabel \"\")") (Just "@'StrLabel' \\\"\\\"@") Nothing Nothing, + makeAttr "TailPort" ["tailport"] "E" (Cust "PortPos") Nothing (Just "(CompassPoint CenterPoint)") (Just "@'CompassPoint' 'CenterPoint'@") Nothing Nothing, + makeAttr "TailTarget" ["tailtarget"] "E" (EStrng) Nothing (Just "\"\"") (Just "none") Nothing (Just "svg, map only"), + makeAttr "TailTooltip" ["tailtooltip"] "E" (EStrng) Nothing (Just "\"\"") (Just "@\\\"\\\"@") Nothing (Just "svg, cmap only"), + makeAttr "Target" ["target"] "ENGC" (EStrng) Nothing (Just "\"\"") (Just "none") Nothing (Just "svg, map only"), + makeAttr "Tooltip" ["tooltip"] "NEC" (EStrng) Nothing (Just "\"\"") (Just "@\\\"\\\"@") Nothing (Just "svg, cmap only"), + makeAttr "TrueColor" ["truecolor"] "G" (Bl) (Just "True") Nothing Nothing Nothing (Just "bitmap output only"), + makeAttr "Vertices" ["vertices"] "N" (Cust "[Point]") Nothing Nothing Nothing Nothing (Just "write only"), + makeAttr "ViewPort" ["viewport"] "G" (Cust "ViewPort") Nothing Nothing (Just "none") Nothing Nothing, + makeAttr "VoroMargin" ["voro_margin"] "G" (Dbl) Nothing (Just "0.05") (Just "@0.05@") (Just "@0.0@") (Just "not 'Dot'"), + makeAttr "Weight" ["weight"] "E" (Cust "Number") Nothing (Just "(Int 1)") (Just "@'Int' 1@") (Just "@'Int' 0@ ('Dot'), @'Int' 1@ ('Neato','Fdp','Sfdp')") (Just "as of Graphviz 2.30: weights for dot need to be 'Int's"), + makeAttr "Width" ["width"] "N" (Dbl) Nothing (Just "0.75") (Just "@0.75@") (Just "@0.01@") Nothing, + makeAttr "XDotVersion" ["xdotversion"] "G" (Cust "Version") Nothing Nothing Nothing Nothing (Just "xdot only, requires Graphviz >= 2.34.0, equivalent to specifying version of xdot to be used"), + makeAttr "XLabel" ["xlabel"] "EN" (Cust "Label") Nothing (Just "(StrLabel \"\")") (Just "@'StrLabel' \\\"\\\"@") Nothing (Just "requires Graphviz >= 2.29.0"), + makeAttr "XLP" ["xlp"] "EN" (Cust "Point") Nothing Nothing Nothing Nothing (Just "write only, requires Graphviz >= 2.29.0") + -- END RECEIVE ORGTBL Attributes + ] +{- + +When using Emacs with org-mode available, hitting ` C-c C-c ' inside +the table below should update the actual Haskell code above. + +This way, you can more easily edit/update the appropriate values. + +* Values in "Allowed names" should be space-separated (and are + converted into a list of Strings). + +* Used by should consist of a sub-set of `ENGCS'. + +* The entries in "Type" should be a valid Haskell value of type + 'VType' (parens are added). + +* An empty cell in the last five columns translates to a `Nothing' + value; anything else is wrapped in quotes and then has Just applied to + it. As such, you still need to escape quotes. + +* Any entries in 'Parsing default' or "Default value" should be a + valid Haskell value (add parens if needed) with the exception that + double-quotes should be escaped. + +* @C-c `@ can be used to edit a field that has been narrowed. + +#+ORGTBL: SEND Attributes orgtbl-to-generic :skip 2 :splice t :hline nil :no-escape t :lstart " makeAttr " :lend "," :llend "" :sep " " :fmt (1 cell-quote 2 cell-to-list 3 cell-quote 4 cell-parens 5 cell-to-maybe 6 cell-to-maybe 7 cell-to-maybe 8 cell-to-maybe 9 cell-to-maybe) +| Constructor | Allowed names | Used By | Type | Parse def | Default value | Default for Documentation | Minimum | Comment notes | +|-----------------+-----------------+---------+-----------------+------------+-----------------+----------------------+------------+----------------------| +| <15> | <15> | | <15> | <10> | <15> | <20> | <10> | <20> | +| Damping | Damping | G | Dbl | | 0.99 | @0.99@ | @0.0@ | 'Neato' only | +| K | K | GC | Dbl | | 0.3 | @0.3@ | @0@ | 'Sfdp', 'Fdp' only | +| URL | URL href | ENGC | EStrng | | \"\" | none | | svg, postscript, map only | +| Area | area | NC | Dbl | | 1.0 | @1.0@ | @>0@ | 'Patchwork' only, requires Graphviz >= 2.30.0 | +| ArrowHead | arrowhead | E | Cust "ArrowType" | | normal | @'normal'@ | | | +| ArrowSize | arrowsize | E | Dbl | | 1.0 | @1.0@ | @0.0@ | | +| ArrowTail | arrowtail | E | Cust "ArrowType" | | normal | @'normal'@ | | | +| Background | _background | G | Strng | | \"\" | none | | xdot only | +| BoundingBox | bb | G | Cust "Rect" | | | | | write only | +| BgColor | bgcolor | GC | Cust "ColorList" | | [] | @[]@ | | | +| Center | center | G | Bl | True | False | @'False'@ | | | +| ClusterRank | clusterrank | G | Cust "ClusterMode" | | Local | @'Local'@ | | 'Dot' only | +| Color | color | ENC | Cust "ColorList" | | [toWColor Black] | @['WC' ('X11Color' 'Black') Nothing]@ | | | +| ColorScheme | colorscheme | ENCG | Cust "ColorScheme" | | X11 | @'X11'@ | | | +| Comment | comment | ENG | Strng | | \"\" | @\\\"\\\"@ | | | +| Compound | compound | G | Bl | True | False | @'False'@ | | 'Dot' only | +| Concentrate | concentrate | G | Bl | True | False | @'False'@ | | | +| Constraint | constraint | E | Bl | True | True | @'True'@ | | 'Dot' only | +| Decorate | decorate | E | Bl | True | False | @'False'@ | | | +| DefaultDist | defaultdist | G | Dbl | | | @1+(avg. len)*sqrt(abs(V))@ (unable to statically define) | The value of 'Epsilon'. | 'Neato' only, only if @'Pack' 'DontPack'@ | +| Dim | dim | G | Integ | | 2 | @2@ | @2@ | maximum of @10@; 'Sfdp', 'Fdp', 'Neato' only | +| Dimen | dimen | G | Integ | | 2 | @2@ | @2@ | maximum of @10@; 'Sfdp', 'Fdp', 'Neato' only | +| Dir | dir | E | Cust "DirType" | | | @'Forward'@ (directed), @'NoDir'@ (undirected) | | | +| DirEdgeConstraints | diredgeconstraints | G | Cust "DEConstraints" | EdgeConstraints | NoConstraints | @'NoConstraints'@ | | 'Neato' only | +| Distortion | distortion | N | Dbl | | 0.0 | @0.0@ | @-100.0@ | | +| DPI | dpi resolution | G | Dbl | | 96.0 | @96.0@, @0.0@ | | svg, bitmap output only; \\\"resolution\\\" is a synonym | +| EdgeURL | edgeURL edgehref | E | EStrng | | \"\" | @\\\"\\\"@ | | svg, map only | +| EdgeTarget | edgetarget | E | EStrng | | | none | | svg, map only | +| EdgeTooltip | edgetooltip | E | EStrng | | \"\" | @\\\"\\\"@ | | svg, cmap only | +| Epsilon | epsilon | G | Dbl | | | @.0001 * # nodes@ (@mode == 'KK'@), @.0001@ (@mode == 'Major'@) | | 'Neato' only | +| ESep | esep | G | Cust "DPoint" | | (DVal 3) | @'DVal' 3@ | | not 'Dot' | +| FillColor | fillcolor | NEC | Cust "ColorList" | | [toWColor Black] | @['WC' ('X11Color' 'LightGray') Nothing]@ (nodes), @['WC' ('X11Color' 'Black') Nothing]@ (clusters) | | | +| FixedSize | fixedsize | N | Cust "NodeSize" | SetNodeSize | GrowAsNeeded | @'GrowAsNeeded'@ | | | +| FontColor | fontcolor | ENGC | Cust "Color" | | (X11Color Black) | @'X11Color' 'Black'@ | | | +| FontName | fontname | ENGC | Strng | | \"Times-Roman\" | @\\\"Times-Roman\\\"@ | | | +| FontNames | fontnames | G | Cust "SVGFontNames" | | SvgNames | @'SvgNames'@ | | svg only | +| FontPath | fontpath | G | Cust "Paths" | | | system dependent | | | +| FontSize | fontsize | ENGC | Dbl | | 14.0 | @14.0@ | @1.0@ | | +| ForceLabels | forcelabels | G | Bl | True | True | @'True'@ | | only for 'XLabel' attributes, requires Graphviz >= 2.29.0 | +| GradientAngle | gradientangle | NCG | Integ | | 0 | 0 | | requires Graphviz >= 2.29.0 | +| Group | group | N | Strng | | \"\" | @\\\"\\\"@ | | 'Dot' only | +| HeadURL | headURL headhref | E | EStrng | | \"\" | @\\\"\\\"@ | | svg, map only | +| Head_LP | head_lp | E | Cust "Point" | | | | | write only, requires Graphviz >= 2.30.0 | +| HeadClip | headclip | E | Bl | True | True | @'True'@ | | | +| HeadLabel | headlabel | E | Cust "Label" | | (StrLabel \"\") | @'StrLabel' \\\"\\\"@ | | | +| HeadPort | headport | E | Cust "PortPos" | | (CompassPoint CenterPoint) | @'CompassPoint' 'CenterPoint'@ | | | +| HeadTarget | headtarget | E | EStrng | | \"\" | none | | svg, map only | +| HeadTooltip | headtooltip | E | EStrng | | \"\" | @\\\"\\\"@ | | svg, cmap only | +| Height | height | N | Dbl | | 0.5 | @0.5@ | @0.02@ | | +| ID | id | GNE | EStrng | | \"\" | @\\\"\\\"@ | | svg, postscript, map only | +| Image | image | N | Strng | | \"\" | @\\\"\\\"@ | | | +| ImagePath | imagepath | G | Cust "Paths" | | (Paths []) | @'Paths' []@ | | Printing and parsing is OS-specific, requires Graphviz >= 2.29.0 | +| ImageScale | imagescale | N | Cust "ScaleType" | UniformScale | NoScale | @'NoScale'@ | | | +| InputScale | inputscale | N | Dbl | | | none | | 'Fdp', 'Neato' only, a value of @0@ is equivalent to being @72@, requires Graphviz >= 2.36.0 | +| Label | label | ENGC | Cust "Label" | | (StrLabel \"\") | @'StrLabel' \\\"\\\\N\\\"@ (nodes), @'StrLabel' \\\"\\\"@ (otherwise) | | | +| LabelURL | labelURL labelhref | E | EStrng | | \"\" | @\\\"\\\"@ | | svg, map only | +| LabelScheme | label_scheme | G | Cust "LabelScheme" | | NotEdgeLabel | @'NotEdgeLabel'@ | | 'Sfdp' only, requires Graphviz >= 2.28.0 | +| LabelAngle | labelangle | E | Dbl | | (-25.0) | @-25.0@ | @-180.0@ | | +| LabelDistance | labeldistance | E | Dbl | | 1.0 | @1.0@ | @0.0@ | | +| LabelFloat | labelfloat | E | Bl | True | False | @'False'@ | | | +| LabelFontColor | labelfontcolor | E | Cust "Color" | | (X11Color Black) | @'X11Color' 'Black'@ | | | +| LabelFontName | labelfontname | E | Strng | | \"Times-Roman\" | @\\\"Times-Roman\\\"@ | | | +| LabelFontSize | labelfontsize | E | Dbl | | 14.0 | @14.0@ | @1.0@ | | +| LabelJust | labeljust | GC | Cust "Justification" | | JCenter | @'JCenter'@ | | | +| LabelLoc | labelloc | GCN | Cust "VerticalPlacement" | | VTop | @'VTop'@ (clusters), @'VBottom'@ (root graphs), @'VCenter'@ (nodes) | | | +| LabelTarget | labeltarget | E | EStrng | | \"\" | none | | svg, map only | +| LabelTooltip | labeltooltip | E | EStrng | | \"\" | @\\\"\\\"@ | | svg, cmap only | +| Landscape | landscape | G | Bl | True | False | @'False'@ | | | +| Layer | layer | ENC | Cust "LayerRange" | | [] | @[]@ | | | +| LayerListSep | layerlistsep | G | Cust "LayerListSep" | | (LLSep \",\") | @'LLSep' \\\",\\\"@ | | requires Graphviz >= 2.30.0 | +| Layers | layers | G | Cust "LayerList" | | (LL []) | @'LL' []@ | | | +| LayerSelect | layerselect | G | Cust "LayerRange" | | [] | @[]@ | | | +| LayerSep | layersep | G | Cust "LayerSep" | | (LSep \" :\\t\") | @'LSep' \\\" :\\t\\\"@ | | | +| Layout | layout | G | Cust "GraphvizCommand" | | | | | | +| Len | len | E | Dbl | | | @1.0@ ('Neato'), @0.3@ ('Fdp') | | 'Fdp', 'Neato' only | +| Levels | levels | G | Integ | | maxBound | @'maxBound'@ | @0@ | 'Sfdp' only | +| LevelsGap | levelsgap | G | Dbl | | 0.0 | @0.0@ | | 'Neato' only | +| LHead | lhead | E | Strng | | \"\" | @\\\"\\\"@ | | 'Dot' only | +| LHeight | LHeight | GC | Dbl | | | | | write only, requires Graphviz >= 2.28.0 | +| LPos | lp | EGC | Cust "Point" | | | | | write only | +| LTail | ltail | E | Strng | | \"\" | @\\\"\\\"@ | | 'Dot' only | +| LWidth | lwidth | GC | Dbl | | | | | write only, requires Graphviz >= 2.28.0 | +| Margin | margin | NGC | Cust "DPoint" | | | device dependent | | | +| MaxIter | maxiter | G | Integ | | | @100 * # nodes@ (@mode == 'KK'@), @200@ (@mode == 'Major'@), @600@ ('Fdp') | | 'Fdp', 'Neato' only | +| MCLimit | mclimit | G | Dbl | | 1.0 | @1.0@ | | 'Dot' only | +| MinDist | mindist | G | Dbl | | 1.0 | @1.0@ | @0.0@ | 'Circo' only | +| MinLen | minlen | E | Integ | | 1 | @1@ | @0@ | 'Dot' only | +| Mode | mode | G | Cust "ModeType" | | Major | @'Major'@ (actually @'Spring'@ for 'Sfdp', but this isn't used as a default in this library) | | 'Neato', 'Sfdp' only | +| Model | model | G | Cust "Model" | | ShortPath | @'ShortPath'@ | | 'Neato' only | +| Mosek | mosek | G | Bl | True | False | @'False'@ | | 'Neato' only; requires the Mosek software | +| NodeSep | nodesep | G | Dbl | | 0.25 | @0.25@ | @0.02@ | | +| NoJustify | nojustify | GCNE | Bl | True | False | @'False'@ | | | +| Normalize | normalize | G | Cust "Normalized" | IsNormalized | NotNormalized | @'NotNormalized'@ | | not 'Dot' | +| NoTranslate | notranslate | G | Bl | True | False | @'False'@ | | 'Neato' only, requires Graphviz >= 2.38.0 | +| Nslimit | nslimit | G | Dbl | | | | | 'Dot' only | +| Nslimit1 | nslimit1 | G | Dbl | | | | | 'Dot' only | +| Ordering | ordering | GN | Cust "Order" | | | none | | 'Dot' only | +| Orientation | orientation | N | Dbl | | 0.0 | @0.0@ | @360.0@ | | +| OutputOrder | outputorder | G | Cust "OutputMode" | | BreadthFirst | @'BreadthFirst'@ | | | +| Overlap | overlap | G | Cust "Overlap" | KeepOverlaps | KeepOverlaps | @'KeepOverlaps'@ | | not 'Dot' | +| OverlapScaling | overlap_scaling | G | Dbl | | (-4) | @-4@ | @-1.0e10@ | 'PrismOverlap' only | +| OverlapShrink | overlap_shrink | G | Bl | True | True | @'True'@ | | 'PrismOverlap' only, requires Graphviz >= 2.36.0 | +| Pack | pack | G | Cust "Pack" | DoPack | DontPack | @'DontPack'@ | | | +| PackMode | packmode | G | Cust "PackMode" | | PackNode | @'PackNode'@ | | | +| Pad | pad | G | Cust "DPoint" | | (DVal 0.0555) | @'DVal' 0.0555@ (4 points) | | | +| Page | page | G | Cust "Point" | | | | | | +| PageDir | pagedir | G | Cust "PageDir" | | Bl | @'Bl'@ | | | +| PenColor | pencolor | C | Cust "Color" | | (X11Color Black) | @'X11Color' 'Black'@ | | | +| PenWidth | penwidth | CNE | Dbl | | 1.0 | @1.0@ | @0.0@ | | +| Peripheries | peripheries | NC | Integ | | 1 | shape default (nodes), @1@ (clusters) | 0 | | +| Pin | pin | N | Bl | True | False | @'False'@ | | 'Fdp', 'Neato' only | +| Pos | pos | EN | Cust "Pos" | | | | | | +| QuadTree | quadtree | G | Cust "QuadType" | NormalQT | NormalQT | @'NormalQT'@ | | 'Sfdp' only | +| Quantum | quantum | G | Dbl | | 0 | @0.0@ | @0.0@ | | +| Rank | rank | S | Cust "RankType" | | | | | 'Dot' only | +| RankDir | rankdir | G | Cust "RankDir" | | FromTop | @'FromTop'@ | | 'Dot' only | +| RankSep | ranksep | G | Cust "[Double]" | | | @[0.5]@ ('Dot'), @[1.0]@ ('Twopi') | @[0.02]@ | 'Twopi', 'Dot' only | +| Ratio | ratio | G | Cust "Ratios" | | | | | | +| Rects | rects | N | Cust "[Rect]" | | | | | write only | +| Regular | regular | N | Bl | True | False | @'False'@ | | | +| ReMinCross | remincross | G | Bl | True | False | @'False'@ | | 'Dot' only | +| RepulsiveForce | repulsiveforce | G | Dbl | | 1.0 | @1.0@ | @0.0@ | 'Sfdp' only | +| Root | root | GN | Cust "Root" | IsCentral | (NodeName \"\") | @'NodeName' \\\"\\\"@ (graphs), @'NotCentral'@ (nodes) | | 'Circo', 'Twopi' only | +| Rotate | rotate | G | Integ | | 0 | @0@ | | | +| Rotation | rotation | G | Dbl | | 0 | @0@ | | 'Sfdp' only, requires Graphviz >= 2.28.0 | +| SameHead | samehead | E | Strng | | \"\" | @\\\"\\\"@ | | 'Dot' only | +| SameTail | sametail | E | Strng | | \"\" | @\\\"\\\"@ | | 'Dot' only | +| SamplePoints | samplepoints | N | Integ | | | @8@ (output), @20@ (overlap and image maps) | | | +| Scale | scale | G | Cust "DPoint" | | | | | Not 'Dot', requires Graphviz >= 2.28.0 (>= 2.38.0 for anything except 'TwoPi') | +| SearchSize | searchsize | G | Integ | | 30 | @30@ | | 'Dot' only | +| Sep | sep | G | Cust "DPoint" | | (DVal 4) | @'DVal' 4@ | | not 'Dot' | +| Shape | shape | N | Cust "Shape" | | Ellipse | @'Ellipse'@ | | | +| ShowBoxes | showboxes | ENG | Integ | | 0 | @0@ | @0@ | 'Dot' only; used for debugging by printing PostScript guide boxes | +| Sides | sides | N | Integ | | 4 | @4@ | @0@ | | +| Size | size | G | Cust "GraphSize" | | | | | | +| Skew | skew | N | Dbl | | 0.0 | @0.0@ | @-100.0@ | | +| Smoothing | smoothing | G | Cust "SmoothType" | | NoSmooth | @'NoSmooth'@ | | 'Sfdp' only | +| SortV | sortv | GCN | Cust "Word16" | | 0 | @0@ | @0@ | | +| Splines | splines | G | Cust "EdgeType" | SplineEdges | | @'SplineEdges'@ ('Dot'), @'LineEdges'@ (other) | | | +| Start | start | G | Cust "StartType" | | | @'StartStyleSeed' 'RandomStyle' seed@ for some unknown fixed seed. | | 'Fdp', 'Neato' only | +| Style | style | ENCG | Cust "[StyleItem]" | | | | | | +| StyleSheet | stylesheet | G | Strng | | \"\" | @\\\"\\\"@ | | svg only | +| TailURL | tailURL tailhref | E | EStrng | | \"\" | @\\\"\\\"@ | | svg, map only | +| Tail_LP | tail_lp | E | Cust "Point" | | | | | write only, requires Graphviz >= 2.30.0 | +| TailClip | tailclip | E | Bl | True | True | @'True'@ | | | +| TailLabel | taillabel | E | Cust "Label" | | (StrLabel \"\") | @'StrLabel' \\\"\\\"@ | | | +| TailPort | tailport | E | Cust "PortPos" | | (CompassPoint CenterPoint) | @'CompassPoint' 'CenterPoint'@ | | | +| TailTarget | tailtarget | E | EStrng | | \"\" | none | | svg, map only | +| TailTooltip | tailtooltip | E | EStrng | | \"\" | @\\\"\\\"@ | | svg, cmap only | +| Target | target | ENGC | EStrng | | \"\" | none | | svg, map only | +| Tooltip | tooltip | NEC | EStrng | | \"\" | @\\\"\\\"@ | | svg, cmap only | +| TrueColor | truecolor | G | Bl | True | | | | bitmap output only | +| Vertices | vertices | N | Cust "[Point]" | | | | | write only | +| ViewPort | viewport | G | Cust "ViewPort" | | | none | | | +| VoroMargin | voro_margin | G | Dbl | | 0.05 | @0.05@ | @0.0@ | not 'Dot' | +| Weight | weight | E | Cust "Number" | | (Int 1) | @'Int' 1@ | @'Int' 0@ ('Dot'), @'Int' 1@ ('Neato','Fdp','Sfdp') | as of Graphviz 2.30: weights for dot need to be 'Int's | +| Width | width | N | Dbl | | 0.75 | @0.75@ | @0.01@ | | +| XDotVersion | xdotversion | G | Cust "Version" | | | | | xdot only, requires Graphviz >= 2.34.0, equivalent to specifying version of xdot to be used | +| XLabel | xlabel | EN | Cust "Label" | | (StrLabel \"\") | @'StrLabel' \\\"\\\"@ | | requires Graphviz >= 2.29.0 | +| XLP | xlp | EN | Cust "Point" | | | | | write only, requires Graphviz >= 2.29.0 | + +-} + unknownAttr :: Doc unknownAttr = text "UnknownAttribute" +-- For testing purposes +attrs :: [Attribute] attrs = take 10 $ drop 5 attributes +-- For testing purposes +attrs' :: Atts attrs' = AS (text "Attribute") attrs bool :: a -> a -> Bool -> a @@ -617,3 +838,12 @@ dollar :: Doc dollar = char '$' + + +-- Local Variables: +-- eval: (turn-on-orgtbl) +-- eval: (defun cell-quote (s) (concat "\"" s "\"")) +-- eval: (defun cell-parens (s) (concat "(" s ")")) +-- eval: (defun cell-to-maybe (s) (if (string= "" s) "Nothing" (cell-parens (concat "Just " (cell-quote s))))) +-- eval: (defun cell-to-list (s) (concat "[" (mapconcat 'cell-quote (split-string s) ", ") "]")) +-- END: diff --git a/utils/Benchmark.hs b/utils/Benchmark.hs --- a/utils/Benchmark.hs +++ b/utils/Benchmark.hs @@ -1,5 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + {- | Module : Benchmark Description : Benchmarking utilities for graphviz @@ -10,13 +12,13 @@ -} module Main where -import Data.GraphViz hiding (DotGraph) +import Data.GraphViz hiding (DotGraph) import Data.GraphViz.Types.Generalised import Criterion.Main import Control.DeepSeq -import Data.Text.Lazy(Text) +import Data.Text.Lazy (Text) -- ----------------------------------------------------------------------------- diff --git a/utils/TestParsing.hs b/utils/TestParsing.hs --- a/utils/TestParsing.hs +++ b/utils/TestParsing.hs @@ -1,4 +1,4 @@ -#!/usr/bin/runhaskell +{-# LANGUAGE MultiParamTypeClasses, OverloadedStrings #-} {- | Module : TestParsing @@ -12,23 +12,25 @@ (with the assumption that the provided code is valid). -} -module Main where +module Main (main) where -import Data.GraphViz +import Data.GraphViz +import Data.GraphViz.Commands.IO (toUTF8) +import Data.GraphViz.Exception +import Data.GraphViz.Parsing (runParser) +import Data.GraphViz.PreProcessing (preProcess) import qualified Data.GraphViz.Types.Generalised as G -import Data.GraphViz.Parsing(runParser) -import Data.GraphViz.PreProcessing(preProcess) -import Data.GraphViz.Commands.IO(hGetStrict, toUTF8) -import Data.GraphViz.Exception -import qualified Data.Text.Lazy as T -import Data.Text.Lazy(Text) +import Control.Exception (SomeException, evaluate, try) +import Control.Monad (filterM, liftM) import qualified Data.ByteString.Lazy as B -import Control.Exception(try, evaluate, SomeException) -import Control.Monad(liftM, filterM) -import System.Directory -import System.FilePath -import System.Environment(getArgs) +import Data.Either (either) +import Data.Monoid (mappend) +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as T +import System.Directory +import System.Environment (getArgs) +import System.FilePath -- ----------------------------------------------------------------------------- @@ -41,7 +43,7 @@ \\n\ \One way of using this file:\n\t\ \$ locate -r \".*\\.\\(gv\\|dot\\)$\" -0\ - \ | xargs -0 runhaskell TestParsing.hs" + \ | xargs -0 TestParsing.hs" tryParsing [fp] = do isDir <- doesDirectoryExist fp if isDir then mapM_ tryParseFile =<< getDContents fp @@ -53,56 +55,53 @@ -- ----------------------------------------------------------------------------- - -withParse :: (PPDotRepr dg n) => (a -> IO Text) -> (dg n -> IO ()) +withParse :: (Show a, PPDotRepr dg n) => (a -> IO Text) -> (dg n -> IO ()) -> (ErrMsg -> String) -> a -> IO () withParse toStr withDG cmbErr a = do dc <- liftM getMsg . try $ toStr a case dc of Right dc' -> do edg <- tryParse dc' case edg of (Right dg) -> withDG dg - (Left err) -> do putStrLn "Parsing problem!" + (Left err) -> do putStr (show a) + putStrLn " - Parsing problem!" putStrLn $ cmbErr err putStrLn "" - Left err -> do putStrLn "IO problem!" + Left err -> do putStr (show a) + putStrLn " - IO problem!" putStrLn err putStrLn "" where getMsg :: Either SomeException Text -> Either ErrMsg Text getMsg = either (Left . show) Right -type DG = DotGraph Text type GDG = G.DotGraph Text type ErrMsg = String tryParseFile :: FilePath -> IO () -tryParseFile fp = withParse readFile' - (tryParseCanon fp) +tryParseFile fp = withParse readUTF8File + ((`seq` return ()) . T.length . printDotGraph . asGDG) ("Cannot parse as a G.DotGraph: "++) fp - -tryParseCanon :: FilePath -> GDG -> IO () -tryParseCanon fp = withParse prettyPrint - ((`seq` putStrLn "Parsed OK!") . T.length . printDotGraph . asDG) - (\ e -> fp ++ ": Canonical Form not a DotGraph:\n" - ++ e) where - asDG = flip asTypeOf emptDG - emptDG = DotGraph False False Nothing $ DotStmts [] [] [] [] :: DG - prettyPrint dg = graphvizWithHandle (commandFor dg) dg Canon hGetStrict + asGDG :: GDG -> GDG + asGDG = id tryParse :: (PPDotRepr dg n) => Text -> IO (Either ErrMsg (dg n)) tryParse dc = handle getErr $ let (dg, rst) = runParser parse $ preProcess dc - in T.length rst `seq` return dg + in T.length rst `seq` return (eitherLR (augmentErr rst) id dg) where getErr :: SomeException -> IO (Either ErrMsg a) getErr = return . Left . show -readFile' :: FilePath -> IO Text -readFile' fp = do putStr fp - putStr " - " - readUTF8File fp + augmentErr rst err = err ++ "\n\tRemaining input: " ++ show res + where + sampleLen = 35 + + res | T.length rst <= sampleLen = rst + | otherwise = T.take sampleLen rst `mappend` " ..." + + eitherLR f g = either (Left . f) (Right . g) -- Force any encoding errors into the IO section rather than when parsing. readUTF8File :: FilePath -> IO Text