diff --git a/Changelog b/Changelog --- a/Changelog +++ b/Changelog @@ -1,35 +1,99 @@ +% graphviz - Changelog +% Ivan Lazar Miljenovic + +Release History and Changelog +============================= + +The following is information about what major changes have gone into +each release. + +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 DotGraphs; this optional +* 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 DotGraphs and the - new GDotGraphs; this shouldn't affect any code already in use. + 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: +* 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. +* 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 +* 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). +* 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: @@ -44,158 +108,186 @@ - Return any errors if calling Graphviz failed rather than just printing them to stderr -* Improved Color support: +* Improved `Color` support: - - fixed ColorScheme values + - fixed `ColorScheme` values - - explicitly named X11 colors + - explicitly named `X11` colors - - conversion to/from values from the colour library + - conversion to/from values from the [colour] library -* Removed OrientationGraph; problems with distinguishing it when - parsing from node-based Orientation values; its functionality is - duplicated by Rotate. + [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. + 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. +* 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. +* Remove some `Shape` aliases and change capitalisation of others. * Properly parse and print IDs of clusters. -* Allow NodeCluster values have node types different from the LNode - they come from. +* 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. +* 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. +* 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). +* 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". +* 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 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. +* 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. + 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 +* 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. Also add cluster support for the graph - -> dot -> graph conversion-style functions, as requested by Nikolas - Mayr. + automatically detect this. -* Allow custom arrow types as supported by GraphViz; as requested by - Han Joosten. +* Add cluster support for the graph augmentation functions, **as + requested by Nikolas Mayr**. -* Fixed a bug in HSV-style Color values where Int was used instead of - Double; spotted by Michael deLorimier. +* 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. + 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. +* 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. +* 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. +* 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 +* 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 -> DotGraph functions created them the wrong - way round, so for those users who only used these this was not - apparent. Spotted by Neil Brown. + 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 +* 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 `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 +* 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 < 4 is once again supported. +* Use [extensible-exceptions] so that `base-3.x` is once again + supported. -* Follow the PVP rather than using dates for versions: - http://www.haskell.org/haskellwiki/Package_versioning_policy + [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 -=================== +------------------- -* Support polyparse >= 1.1 (as opposed to < 1.3) +* New maintainer: Ivan Lazar Miljenovic. -* Require base == 4.* (i.e. GHC 6.10.*) due to new exception handling. +* Support `polyparse >= 1.1` (as opposed to `< 1.3`) -* Include functions from Graphalyze-0.5 for running GraphViz commands, - etc. +* 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. +* 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,6 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses + , FlexibleContexts + #-} {- | Module : Data.GraphViz @@ -53,6 +55,7 @@ -- * Utility functions , prettyPrint , prettyPrint' + , canonicalise , preview -- * Re-exporting other modules. , module Data.GraphViz.Types @@ -378,7 +381,7 @@ stripID :: LEdge (EdgeID b) -> LEdge b stripID (f,t,eid) = (f,t, eLbl eid) --- | Pass the 'DotGraph' through the relevant command and then augment +-- | Pass the 'DotRepr' through the relevant command and then augment -- the 'Graph' that it came from. dotAttributes :: (Graph gr, DotRepr dg Node) => Bool -> gr a (EdgeID b) -> dg Node -> IO (gr (AttributeNode a) (AttributeEdge b)) @@ -426,6 +429,12 @@ -- functions in "Data.GraphViz.Types.Printing") no longer uses -- indentation (this is to ensure the Dot code is printed correctly -- due to the limitations of the Pretty Printer used). +-- +-- This will call 'error' if an error occurs when calling the +-- relevant 'GraphvizCommand': likely causes are that Graphviz suite +-- isn't installed, or it has an 'Image' or 'HtmlImg' Attribute that +-- references an image that can't be found from the working +-- directory. prettyPrint :: (DotRepr dg n) => dg n -> IO String prettyPrint dg = liftM fromDotResult -- Note that the choice of command here should be @@ -437,10 +446,18 @@ -- | The 'unsafePerformIO'd version of 'prettyPrint'. Graphviz should -- always produce the same pretty-printed output, so this should be --- safe. +-- safe. However, it is not recommended to use it in production +-- code, just for testing purposes. prettyPrint' :: (DotRepr dg n) => dg n -> String prettyPrint' = unsafePerformIO . prettyPrint +-- | Convert the 'DotRepr' into its canonical form. This /should/ +-- work as it appears that the 'prettyPrint'ed form is always in the +-- format of a 'DotGraph', but the Graphviz code hasn't been +-- examined to verify this. +canonicalise :: (DotRepr dg n, DotRepr DotGraph n) => dg n -> IO (DotGraph n) +canonicalise = liftM parseDotGraph . prettyPrint + -- | Quickly visualise a graph using the 'Xlib' 'GraphvizCanvas'. preview :: (Ord b, Graph gr) => gr a b -> IO () preview g = ign $ forkIO (ign $ runGraphvizCanvas' dg Xlib) @@ -451,7 +468,7 @@ -- | Used for obtaining results from 'graphvizWithHandle', etc. when -- errors should only occur when Graphviz isn't installed. If the -- value is @'Left' _@, then 'error' is used. -fromDotResult :: Either l r -> r -fromDotResult (Right r) = r -fromDotResult Left{} = error "Could not run the relevant Graphviz command; \ - \is the Graphviz suite of tools installed?" +fromDotResult :: Either String r -> r +fromDotResult (Right r) = r +fromDotResult (Left err) = error $ "Error when running the relevant Graphviz\ + \ command:\n" ++ err diff --git a/Data/GraphViz/AttributeGenerator.hs b/Data/GraphViz/AttributeGenerator.hs --- a/Data/GraphViz/AttributeGenerator.hs +++ b/Data/GraphViz/AttributeGenerator.hs @@ -114,7 +114,6 @@ | Integ | Strng | EStrng - | URL | Bl | Cust String deriving (Eq, Ord, Show, Read) @@ -124,7 +123,6 @@ vtype Integ = text "Int" vtype Strng = text "String" vtype EStrng = text "EscString" -vtype URL = text "URL" vtype Bl = text "Bool" vtype (Cust t) = text t @@ -140,6 +138,7 @@ constructors = nest tab . asRows . firstOthers equals (char '|') + . (++ [defUnknown]) . map createDefn $ atts att derivs = nest (tab + 2) $ text "deriving (Eq, Ord, Show, Read)" @@ -150,6 +149,9 @@ ] where cm = comment a + defUnknown = [ unknownAttr <+> vtype Strng <+> vtype Strng + , text "-- ^ /Valid for/: Assumed valid for all; the fields are 'Attribute' name and value respectively." + ] createAlias :: Atts -> Code createAlias att = text "type" @@ -167,12 +169,17 @@ sFunc = text "unqtDot" cnct = text "<>" insts = asRows + . (++ [unknownInst]) . map mkInstance $ atts att mkInstance a = [ sFunc <+> parens (cnst a <+> var) , equals <+> text "printField" <+> doubleQuotes (name a) <+> var ] + unknownInst = [ sFunc <+> parens (unknownAttr <+> char 'a' <+> var) + , equals <+> text "toDot" <+> char 'a' + <+> text "<> equals <>" <+> text "toDot" <+> var + ] insts' = nest tab $ vsep [ insts , text "listToDot" <+> equals <+> text "unqtListToDot" @@ -190,25 +197,26 @@ ops = flip ($$) rbrack . asRows . firstOthers lbrack comma + . map return + . (++ [pUnknown]) . map parseAttr $ atts att pFunc = text "parseUnqt" - parseAttr a = [ text "liftM" <+> cnst a - , dollar <+> pfFunc a - ] pType b a - | valtype a == Bl = pFld <> text "Bool" - | isJust $ parseDef a = pFld <> text "Def" <+> fromJust (parseDef a) - | otherwise = pFld + | 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 - pfFunc a = case map doubleQuotes $ parseNames a of - [n] -> pType False a <+> n - ns -> pType True a <+> docList ns + parseAttr a = case map doubleQuotes $ parseNames a of + [n] -> pType False a <+> n + ns -> pType True a <+> docList ns + pUnknown = text "liftM2" <+> unknownAttr <+> text "stringBlock" + <+> parens (text "parseEq >> parse") arbitraryInstance :: Atts -> Code -arbitraryInstance att = hdr $+$ fns +arbitraryInstance att = vsep [hdr $+$ fns, kFunc] where hdr = text "instance" <+> text "Arbitrary" <+> tpNm att <+> text "where" fns = nest tab $ vsep [aFn, sFn] @@ -216,11 +224,13 @@ ops = flip ($$) rbrack . asRows . firstOthers lbrack comma + . (++ [[aUnknown]]) . map (return . arbAttr) $ atts att aFunc = text "arbitrary" arbAttr a = text "liftM" <+> cnst a <+> arbitraryFor' a sFn = asRows + . (++ [sUnknown]) . map shrinkAttr $ atts att sFunc = text "shrink" @@ -229,7 +239,29 @@ , equals <+> text "map" <+> cnst a , dollar <+> shrinkFor (valtype a) <+> var ] + aUnknown = text "liftM2" <+> unknownAttr + <+> parens (text "suchThat" <+> text "arbIDString" <+> kFuncNm) + <+> arbitraryFor Strng + sUnknown = [ sFunc <+> parens (unknownAttr <+> char 'a' <+> var) + , equals <+> text "liftM2" <+> unknownAttr + , parens (text "liftM" <+> parens (text "filter" <+> kFuncNm) + <+> shrinkFor Strng <+> char 'a') + <+> parens (shrinkFor Strng <+> var) + ] + kFunc = asRows (kTpSig : kTrs ++ [kOth]) + kFuncNm = text "validUnknown" + kTpSig = [ kFuncNm + , colon <> colon <+> text "String -> Bool" + ] + kTrs = map kTr . concatMap parseNames $ atts att + kTr pn = [ kFuncNm <+> doubleQuotes pn + , equals <+> text "False" + ] + kOth = [ kFuncNm <+> char '_' + , equals <+> text "True" + ] + arbitraryFor :: VType -> Doc arbitraryFor Strng = text "arbString" arbitraryFor EStrng = text "arbString" @@ -258,7 +290,7 @@ ] fn = text "usedBy" <> nm' tr = text "True" - trs = map aTr as' + trs = map aTr as' ++ [unknownATr] fl = text "False" fls = [ fn <+> char '_' , equals <+> fl @@ -267,6 +299,9 @@ aTr a = [ fn <+> cnst a <> braces empty , equals <+> tr ] + unknownATr = [ fn <+> unknownAttr <> braces empty + , equals <+> tr + ] -- ----------------------------------------------------------------------------- @@ -319,7 +354,7 @@ attributes :: [Attribute] attributes = [ makeAttr "Damping" ["Damping"] "G" Dbl Nothing (Just "@0.99@") (Just "@0.0@") (Just "neato only") , makeAttr "K" ["K"] "GC" Dbl Nothing (Just "@0.3@") (Just "@0@") (Just "sfdp, fdp only") - , makeAttr "URL" ["URL", "href"] "ENGC" URL Nothing (Just "none") Nothing (Just "svg, postscript, map only") + , makeAttr "URL" ["URL", "href"] "ENGC" EStrng Nothing (Just "none") Nothing (Just "svg, postscript, map only") , makeAttr "ArrowHead" ["arrowhead"] "E" (Cust "ArrowType") Nothing (Just "@'normal'@") Nothing Nothing , makeAttr "ArrowSize" ["arrowsize"] "E" Dbl Nothing (Just "@1.0@") (Just "@0.0@") Nothing , makeAttr "ArrowTail" ["arrowtail"] "E" (Cust "ArrowType") Nothing (Just "@'normal'@") Nothing Nothing @@ -343,7 +378,7 @@ , makeAttr "DirEdgeConstraints" ["diredgeconstraints"] "G" (Cust "DEConstraints") (Just "EdgeConstraints") (Just "@'NoConstraints'@") Nothing (Just "neato only") , makeAttr "Distortion" ["distortion"] "N" Dbl Nothing (Just "@0.0@") (Just "@-100.0@") Nothing , makeAttr "DPI" ["dpi", "resolution"] "G" Dbl Nothing (Just "@96.0@, @0.0@") Nothing (Just "svg, bitmap output only; \\\"resolution\\\" is a synonym") - , makeAttr "EdgeURL" ["edgeURL", "edgehref"] "E" URL Nothing (Just "@\\\"\\\"@") Nothing (Just "svg, map only") + , makeAttr "EdgeURL" ["edgeURL", "edgehref"] "E" EStrng Nothing (Just "@\\\"\\\"@") Nothing (Just "svg, map only") , makeAttr "EdgeTarget" ["edgetarget"] "E" EStrng Nothing (Just "none") Nothing (Just "svg, map only") , makeAttr "EdgeTooltip" ["edgetooltip"] "E" EStrng Nothing (Just "@\\\"\\\"@") Nothing (Just "svg, cmap only") , makeAttr "Epsilon" ["epsilon"] "G" Dbl Nothing (Just "@.0001 * # nodes@ (@mode == 'KK'@), @.0001@ (@mode == 'Major'@)") Nothing (Just "neato only") @@ -356,7 +391,7 @@ , makeAttr "FontPath" ["fontpath"] "G" Strng Nothing (Just "system-dependent") Nothing Nothing , makeAttr "FontSize" ["fontsize"] "ENGC" Dbl Nothing (Just "@14.0@") (Just "@1.0@") Nothing , makeAttr "Group" ["group"] "N" Strng Nothing (Just "@\\\"\\\"@") Nothing (Just "dot only") - , makeAttr "HeadURL" ["headURL", "headhref"] "E" URL Nothing (Just "@\\\"\\\"@") Nothing (Just "svg, map only") + , makeAttr "HeadURL" ["headURL", "headhref"] "E" EStrng Nothing (Just "@\\\"\\\"@") Nothing (Just "svg, map only") , makeAttr "HeadClip" ["headclip"] "E" Bl (Just "True") (Just "@'True'@") Nothing Nothing , makeAttr "HeadLabel" ["headlabel"] "E" (Cust "Label") Nothing (Just "@\\\"\\\"@") Nothing Nothing , makeAttr "HeadPort" ["headport"] "E" (Cust "PortPos") Nothing (Just "@'PP' 'CenterPoint'@") Nothing Nothing @@ -366,7 +401,7 @@ , makeAttr "ID" ["id"] "GNE" (Cust "Label") Nothing (Just "@\\\"\\\"@") Nothing (Just "svg, postscript, map only") , makeAttr "Image" ["image"] "N" Strng Nothing (Just "@\\\"\\\"@") Nothing Nothing , makeAttr "ImageScale" ["imagescale"] "N" (Cust "ScaleType") (Just "UniformScale") (Just "@'NoScale'@") Nothing Nothing - , makeAttr "LabelURL" ["labelURL", "labelhref"] "E" URL Nothing (Just "@\\\"\\\"@") Nothing (Just "svg, map only") + , makeAttr "LabelURL" ["labelURL", "labelhref"] "E" EStrng Nothing (Just "@\\\"\\\"@") Nothing (Just "svg, map only") , makeAttr "LabelAngle" ["labelangle"] "E" Dbl Nothing (Just "@-25.0@") (Just "@-180.0@") Nothing , makeAttr "LabelDistance" ["labeldistance"] "E" Dbl Nothing (Just "@1.0@") (Just "@0.0@") Nothing , makeAttr "LabelFloat" ["labelfloat"] "E" Bl (Just "True") (Just "@'False'@") Nothing Nothing @@ -420,7 +455,7 @@ , makeAttr "QuadTree" ["quadtree"] "G" (Cust "QuadType") (Just "NormalQT") (Just "@'NormalQT'@") Nothing (Just "sfdp only") , makeAttr "Quantum" ["quantum"] "G" Dbl Nothing (Just "@0.0@") (Just "@0.0@") Nothing , makeAttr "RankDir" ["rankdir"] "G" (Cust "RankDir") Nothing (Just "@'TB'@") Nothing (Just "dot only") - , makeAttr "RankSep" ["ranksep"] "G" Dbl Nothing (Just "@0.5@ (dot), @1.0@ (twopi)") (Just "0.02") (Just "twopi, dot only") + , makeAttr "RankSep" ["ranksep"] "G" (Cust "[Double]") Nothing (Just "@0.5@ (dot), @1.0@ (twopi)") (Just "0.02") (Just "twopi, dot only") , makeAttr "Rank" ["rank"] "S" (Cust "RankType") Nothing Nothing Nothing (Just "dot only") , makeAttr "Ratio" ["ratio"] "G" (Cust "Ratios") Nothing Nothing Nothing Nothing , makeAttr "Rects" ["rects"] "N" (Cust "Rect") Nothing Nothing Nothing (Just "write only") @@ -446,7 +481,7 @@ , makeAttr "Start" ["start"] "G" (Cust "StartType") Nothing (Just "@\\\"\\\"@") Nothing (Just "fdp, neato only") , makeAttr "StyleSheet" ["stylesheet"] "G" Strng Nothing (Just "@\\\"\\\"@") Nothing (Just "svg only") , makeAttr "Style" ["style"] "ENC" (Cust "[StyleItem]") Nothing Nothing Nothing Nothing - , makeAttr "TailURL" ["tailURL", "tailhref"] "E" URL Nothing (Just "@\\\"\\\"@") Nothing (Just "svg, map only") + , makeAttr "TailURL" ["tailURL", "tailhref"] "E" EStrng Nothing (Just "@\\\"\\\"@") Nothing (Just "svg, map only") , makeAttr "TailClip" ["tailclip"] "E" Bl (Just "True") (Just "@'True'@") Nothing Nothing , makeAttr "TailLabel" ["taillabel"] "E" (Cust "Label") Nothing (Just "@\\\"\\\"@") Nothing Nothing , makeAttr "TailPort" ["tailport"] "E" (Cust "PortPos") Nothing (Just "center") Nothing Nothing @@ -462,6 +497,9 @@ , makeAttr "Width" ["width"] "N" Dbl Nothing (Just "@0.75@") (Just "@0.01@") Nothing , makeAttr "Z" ["z"] "N" Dbl Nothing (Just "@0.0@") (Just "@-MAXFLOAT@, @-1000@") Nothing ] + +unknownAttr :: Doc +unknownAttr = text "UnknownAttribute" attrs = take 10 $ drop 5 attributes diff --git a/Data/GraphViz/Attributes.hs b/Data/GraphViz/Attributes.hs --- a/Data/GraphViz/Attributes.hs +++ b/Data/GraphViz/Attributes.hs @@ -26,12 +26,12 @@ /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 and PointfList are defined as actual lists (but - 'LayerList' is not). Note that for the Color 'Attribute' for - node values, only a single Color is valid; edges are allowed - multiple colors with one spline/arrow per color in the list (but - you must have at least one 'Color' in the list). This might be - changed in future. + * @ColorList@, @DoubleList@ and @PointfList@ are defined as actual + lists (but 'LayerList' is not). All of these are assumed to be + non-empty lists. Note that for the @Color@ 'Attribute' for node + values, only a single Color is valid; edges are allowed multiple + colors with one spline/arrow per color in the list (but you must have + at least one 'Color' in the list). This might be changed in future. * Style is implemented as a list of 'StyleItem' values; note that empty lists are not allowed. @@ -58,10 +58,6 @@ * Only polygon-based 'Shape's are available. - * 'PortPos' only has the 'CompassPoint' option, not - @PortName[:CompassPoint]@ (since record shapes aren't allowed, - and parsing HTML-like labels could be problematic). - * Not every 'Attribute' is fully documented/described. However, all those which have specific allowed values should be covered. @@ -84,7 +80,6 @@ , usedByEdges -- * Value types for @Attribute@s. , EscString - , URL(..) , ArrowType(..) , AspectType(..) , Rect(..) @@ -117,15 +112,22 @@ , STStyle(..) , StyleItem(..) , StyleName(..) - , PortPos(..) - , CompassPoint(..) , ViewPort(..) , FocusType(..) , VerticalPlacement(..) , ScaleType(..) , Justification(..) , Ratios(..) + -- Re-exported from Data.GraphViz.Attributes.Internal + , PortName(..) + , PortPos(..) + , CompassPoint(..) + -- Re-exporting modules , module Data.GraphViz.Attributes.Colors + , module Data.GraphViz.Attributes.HTML + -- * Types representing the Dot grammar for records. + , RecordFields + , RecordField(..) -- * Types representing the Dot grammar for @ArrowType@. , ArrowShape(..) , ArrowModifier(..) @@ -163,6 +165,8 @@ ) where import Data.GraphViz.Attributes.Colors +import Data.GraphViz.Attributes.HTML +import Data.GraphViz.Attributes.Internal import Data.GraphViz.Util import Data.GraphViz.Parsing import Data.GraphViz.Printing @@ -200,11 +204,20 @@ 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 for + /backwards-compatibility purposes only/ (specifically, to be able to + parse old Dot code containing 'Attribute's that are no longer valid). + As such, this 'Attribute' should not be used directly. The attribute + name is assumed to match the first type of identifier listed in + "Data.GraphViz.Printing" (i.e. a non-number that does not need to be + quoted). + -} 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 URL -- ^ /Valid for/: ENGC; /Default/: none; /Notes/: svg, postscript, map only + | URL EscString -- ^ /Valid for/: ENGC; /Default/: none; /Notes/: svg, postscript, map only | 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'@ @@ -228,7 +241,7 @@ | 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 URL -- ^ /Valid for/: E; /Default/: @\"\"@; /Notes/: svg, map only + | 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 @@ -241,7 +254,7 @@ | FontPath String -- ^ /Valid for/: G; /Default/: system-dependent | FontSize Double -- ^ /Valid for/: ENGC; /Default/: @14.0@; /Minimum/: @1.0@ | Group String -- ^ /Valid for/: N; /Default/: @\"\"@; /Notes/: dot only - | HeadURL URL -- ^ /Valid for/: E; /Default/: @\"\"@; /Notes/: svg, map 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/: @\"\"@ | HeadPort PortPos -- ^ /Valid for/: E; /Default/: @'PP' 'CenterPoint'@ @@ -251,7 +264,7 @@ | ID Label -- ^ /Valid for/: GNE; /Default/: @\"\"@; /Notes/: svg, postscript, map only | Image String -- ^ /Valid for/: N; /Default/: @\"\"@ | ImageScale ScaleType -- ^ /Valid for/: N; /Default/: @'NoScale'@; /Parsing Default/: 'UniformScale' - | LabelURL URL -- ^ /Valid for/: E; /Default/: @\"\"@; /Notes/: svg, map only + | LabelURL EscString -- ^ /Valid for/: E; /Default/: @\"\"@; /Notes/: svg, map only | 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' @@ -305,7 +318,7 @@ | QuadTree QuadType -- ^ /Valid for/: G; /Default/: @'NormalQT'@; /Parsing Default/: 'NormalQT'; /Notes/: sfdp only | Quantum Double -- ^ /Valid for/: G; /Default/: @0.0@; /Minimum/: @0.0@ | RankDir RankDir -- ^ /Valid for/: G; /Default/: @'TB'@; /Notes/: dot only - | RankSep Double -- ^ /Valid for/: G; /Default/: @0.5@ (dot), @1.0@ (twopi); /Minimum/: 0.02; /Notes/: twopi, dot only + | RankSep [Double] -- ^ /Valid for/: G; /Default/: @0.5@ (dot), @1.0@ (twopi); /Minimum/: 0.02; /Notes/: twopi, dot only | Rank RankType -- ^ /Valid for/: S; /Notes/: dot only | Ratio Ratios -- ^ /Valid for/: G | Rects Rect -- ^ /Valid for/: N; /Notes/: write only @@ -331,7 +344,7 @@ | Start StartType -- ^ /Valid for/: G; /Default/: @\"\"@; /Notes/: fdp, neato only | StyleSheet String -- ^ /Valid for/: G; /Default/: @\"\"@; /Notes/: svg only | Style [StyleItem] -- ^ /Valid for/: ENC - | TailURL URL -- ^ /Valid for/: E; /Default/: @\"\"@; /Notes/: svg, map 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/: @\"\"@ | TailPort PortPos -- ^ /Valid for/: E; /Default/: center @@ -346,6 +359,7 @@ | 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@ | Z Double -- ^ /Valid for/: N; /Default/: @0.0@; /Minimum/: @-MAXFLOAT@, @-1000@ + | UnknownAttribute String String -- ^ /Valid for/: Assumed valid for all; the fields are 'Attribute' name and value respectively. deriving (Eq, Ord, Show, Read) type Attributes = [Attribute] @@ -495,154 +509,156 @@ unqtDot (Weight v) = printField "weight" v unqtDot (Width v) = printField "width" v unqtDot (Z v) = printField "z" v + unqtDot (UnknownAttribute a v) = toDot a <> equals <> toDot v listToDot = unqtListToDot instance ParseDot Attribute where - parseUnqt = oneOf [ liftM Damping $ parseField "Damping" - , liftM K $ parseField "K" - , liftM URL $ parseFields ["URL", "href"] - , liftM ArrowHead $ parseField "arrowhead" - , liftM ArrowSize $ parseField "arrowsize" - , liftM ArrowTail $ parseField "arrowtail" - , liftM Aspect $ parseField "aspect" - , liftM Bb $ parseField "bb" - , liftM BgColor $ parseField "bgcolor" - , liftM Center $ parseFieldBool "center" - , liftM Charset $ parseField "charset" - , liftM ClusterRank $ parseField "clusterrank" - , liftM ColorScheme $ parseField "colorscheme" - , liftM Color $ parseField "color" - , liftM Comment $ parseField "comment" - , liftM Compound $ parseFieldBool "compound" - , liftM Concentrate $ parseFieldBool "concentrate" - , liftM Constraint $ parseFieldBool "constraint" - , liftM Decorate $ parseFieldBool "decorate" - , liftM DefaultDist $ parseField "defaultdist" - , liftM Dimen $ parseField "dimen" - , liftM Dim $ parseField "dim" - , liftM Dir $ parseField "dir" - , liftM DirEdgeConstraints $ parseFieldDef EdgeConstraints "diredgeconstraints" - , liftM Distortion $ parseField "distortion" - , liftM DPI $ parseFields ["dpi", "resolution"] - , liftM EdgeURL $ parseFields ["edgeURL", "edgehref"] - , liftM EdgeTarget $ parseField "edgetarget" - , liftM EdgeTooltip $ parseField "edgetooltip" - , liftM Epsilon $ parseField "epsilon" - , liftM ESep $ parseField "esep" - , liftM FillColor $ parseField "fillcolor" - , liftM FixedSize $ parseFieldBool "fixedsize" - , liftM FontColor $ parseField "fontcolor" - , liftM FontName $ parseField "fontname" - , liftM FontNames $ parseField "fontnames" - , liftM FontPath $ parseField "fontpath" - , liftM FontSize $ parseField "fontsize" - , liftM Group $ parseField "group" - , liftM HeadURL $ parseFields ["headURL", "headhref"] - , liftM HeadClip $ parseFieldBool "headclip" - , liftM HeadLabel $ parseField "headlabel" - , liftM HeadPort $ parseField "headport" - , liftM HeadTarget $ parseField "headtarget" - , liftM HeadTooltip $ parseField "headtooltip" - , liftM Height $ parseField "height" - , liftM ID $ parseField "id" - , liftM Image $ parseField "image" - , liftM ImageScale $ parseFieldDef UniformScale "imagescale" - , liftM LabelURL $ parseFields ["labelURL", "labelhref"] - , liftM LabelAngle $ parseField "labelangle" - , liftM LabelDistance $ parseField "labeldistance" - , liftM LabelFloat $ parseFieldBool "labelfloat" - , liftM LabelFontColor $ parseField "labelfontcolor" - , liftM LabelFontName $ parseField "labelfontname" - , liftM LabelFontSize $ parseField "labelfontsize" - , liftM LabelJust $ parseField "labeljust" - , liftM LabelLoc $ parseField "labelloc" - , liftM LabelTarget $ parseField "labeltarget" - , liftM LabelTooltip $ parseField "labeltooltip" - , liftM Label $ parseField "label" - , liftM Landscape $ parseFieldBool "landscape" - , liftM LayerSep $ parseField "layersep" - , liftM Layers $ parseField "layers" - , liftM Layer $ parseField "layer" - , liftM Layout $ parseField "layout" - , liftM Len $ parseField "len" - , liftM LevelsGap $ parseField "levelsgap" - , liftM Levels $ parseField "levels" - , liftM LHead $ parseField "lhead" - , liftM LPos $ parseField "lp" - , liftM LTail $ parseField "ltail" - , liftM Margin $ parseField "margin" - , liftM MaxIter $ parseField "maxiter" - , liftM MCLimit $ parseField "mclimit" - , liftM MinDist $ parseField "mindist" - , liftM MinLen $ parseField "minlen" - , liftM Model $ parseField "model" - , liftM Mode $ parseField "mode" - , liftM Mosek $ parseFieldBool "mosek" - , liftM NodeSep $ parseField "nodesep" - , liftM NoJustify $ parseFieldBool "nojustify" - , liftM Normalize $ parseFieldBool "normalize" - , liftM Nslimit1 $ parseField "nslimit1" - , liftM Nslimit $ parseField "nslimit" - , liftM Ordering $ parseField "ordering" - , liftM Orientation $ parseField "orientation" - , liftM OutputOrder $ parseField "outputorder" - , liftM OverlapScaling $ parseField "overlap_scaling" - , liftM Overlap $ parseFieldDef KeepOverlaps "overlap" - , liftM PackMode $ parseField "packmode" - , liftM Pack $ parseFieldDef DoPack "pack" - , liftM Pad $ parseField "pad" - , liftM PageDir $ parseField "pagedir" - , liftM Page $ parseField "page" - , liftM PenColor $ parseField "pencolor" - , liftM PenWidth $ parseField "penwidth" - , liftM Peripheries $ parseField "peripheries" - , liftM Pin $ parseFieldBool "pin" - , liftM Pos $ parseField "pos" - , liftM QuadTree $ parseFieldDef NormalQT "quadtree" - , liftM Quantum $ parseField "quantum" - , liftM RankDir $ parseField "rankdir" - , liftM RankSep $ parseField "ranksep" - , liftM Rank $ parseField "rank" - , liftM Ratio $ parseField "ratio" - , liftM Rects $ parseField "rects" - , liftM Regular $ parseFieldBool "regular" - , liftM ReMinCross $ parseFieldBool "remincross" - , liftM RepulsiveForce $ parseField "repulsiveforce" - , liftM Root $ parseFieldDef IsCentral "root" - , liftM Rotate $ parseField "rotate" - , liftM SameHead $ parseField "samehead" - , liftM SameTail $ parseField "sametail" - , liftM SamplePoints $ parseField "samplepoints" - , liftM SearchSize $ parseField "searchsize" - , liftM Sep $ parseField "sep" - , liftM ShapeFile $ parseField "shapefile" - , liftM Shape $ parseField "shape" - , liftM ShowBoxes $ parseField "showboxes" - , liftM Sides $ parseField "sides" - , liftM Size $ parseField "size" - , liftM Skew $ parseField "skew" - , liftM Smoothing $ parseField "smoothing" - , liftM SortV $ parseField "sortv" - , liftM Splines $ parseFieldDef SplineEdges "splines" - , liftM Start $ parseField "start" - , liftM StyleSheet $ parseField "stylesheet" - , liftM Style $ parseField "style" - , liftM TailURL $ parseFields ["tailURL", "tailhref"] - , liftM TailClip $ parseFieldBool "tailclip" - , liftM TailLabel $ parseField "taillabel" - , liftM TailPort $ parseField "tailport" - , liftM TailTarget $ parseField "tailtarget" - , liftM TailTooltip $ parseField "tailtooltip" - , liftM Target $ parseField "target" - , liftM Tooltip $ parseField "tooltip" - , liftM TrueColor $ parseFieldBool "truecolor" - , liftM Vertices $ parseField "vertices" - , liftM ViewPort $ parseField "viewport" - , liftM VoroMargin $ parseField "voro_margin" - , liftM Weight $ parseField "weight" - , liftM Width $ parseField "width" - , liftM Z $ parseField "z" + parseUnqt = oneOf [ parseField Damping "Damping" + , parseField K "K" + , parseFields URL ["URL", "href"] + , parseField ArrowHead "arrowhead" + , parseField ArrowSize "arrowsize" + , parseField ArrowTail "arrowtail" + , parseField Aspect "aspect" + , parseField Bb "bb" + , parseField BgColor "bgcolor" + , parseFieldBool Center "center" + , parseField Charset "charset" + , parseField ClusterRank "clusterrank" + , parseField ColorScheme "colorscheme" + , parseField Color "color" + , parseField Comment "comment" + , parseFieldBool Compound "compound" + , parseFieldBool Concentrate "concentrate" + , parseFieldBool Constraint "constraint" + , parseFieldBool Decorate "decorate" + , parseField DefaultDist "defaultdist" + , parseField Dimen "dimen" + , parseField Dim "dim" + , 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" + , 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" + , parseFieldDef ImageScale UniformScale "imagescale" + , parseFields LabelURL ["labelURL", "labelhref"] + , 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" + , parseField Label "label" + , parseFieldBool Landscape "landscape" + , parseField LayerSep "layersep" + , parseField Layers "layers" + , parseField Layer "layer" + , parseField Layout "layout" + , parseField Len "len" + , parseField LevelsGap "levelsgap" + , parseField Levels "levels" + , parseField LHead "lhead" + , parseField LPos "lp" + , parseField LTail "ltail" + , parseField Margin "margin" + , parseField MaxIter "maxiter" + , parseField MCLimit "mclimit" + , parseField MinDist "mindist" + , parseField MinLen "minlen" + , parseField Model "model" + , parseField Mode "mode" + , parseFieldBool Mosek "mosek" + , parseField NodeSep "nodesep" + , parseFieldBool NoJustify "nojustify" + , parseFieldBool Normalize "normalize" + , parseField Nslimit1 "nslimit1" + , parseField Nslimit "nslimit" + , parseField Ordering "ordering" + , parseField Orientation "orientation" + , parseField OutputOrder "outputorder" + , parseField OverlapScaling "overlap_scaling" + , parseFieldDef Overlap KeepOverlaps "overlap" + , parseField PackMode "packmode" + , parseFieldDef Pack DoPack "pack" + , parseField Pad "pad" + , parseField PageDir "pagedir" + , parseField Page "page" + , parseField PenColor "pencolor" + , parseField PenWidth "penwidth" + , parseField Peripheries "peripheries" + , parseFieldBool Pin "pin" + , parseField Pos "pos" + , parseFieldDef QuadTree NormalQT "quadtree" + , parseField Quantum "quantum" + , parseField RankDir "rankdir" + , parseField RankSep "ranksep" + , parseField Rank "rank" + , parseField Ratio "ratio" + , parseField Rects "rects" + , parseFieldBool Regular "regular" + , parseFieldBool ReMinCross "remincross" + , parseField RepulsiveForce "repulsiveforce" + , parseFieldDef Root IsCentral "root" + , parseField Rotate "rotate" + , parseField SameHead "samehead" + , parseField SameTail "sametail" + , parseField SamplePoints "samplepoints" + , parseField SearchSize "searchsize" + , parseField Sep "sep" + , parseField ShapeFile "shapefile" + , 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 StyleSheet "stylesheet" + , parseField Style "style" + , 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 Z "z" + , liftM2 UnknownAttribute stringBlock (parseEq >> parse) ] parse = parseUnqt @@ -730,144 +746,149 @@ 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 BgColor{} = True -usedByClusters ColorScheme{} = True -usedByClusters Color{} = True -usedByClusters FillColor{} = True -usedByClusters FontColor{} = True -usedByClusters FontName{} = True -usedByClusters FontSize{} = True -usedByClusters LabelJust{} = True -usedByClusters LabelLoc{} = True -usedByClusters Label{} = True -usedByClusters LPos{} = 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 _ = False +usedByClusters :: Attribute -> Bool +usedByClusters K{} = True +usedByClusters URL{} = True +usedByClusters BgColor{} = True +usedByClusters ColorScheme{} = True +usedByClusters Color{} = True +usedByClusters FillColor{} = True +usedByClusters FontColor{} = True +usedByClusters FontName{} = True +usedByClusters FontSize{} = True +usedByClusters LabelJust{} = True +usedByClusters LabelLoc{} = True +usedByClusters Label{} = True +usedByClusters LPos{} = 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 _ = False +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 Group{} = True -usedByNodes Height{} = True -usedByNodes ID{} = True -usedByNodes Image{} = True -usedByNodes ImageScale{} = True -usedByNodes LabelLoc{} = True -usedByNodes Label{} = True -usedByNodes Layer{} = True -usedByNodes Margin{} = True -usedByNodes NoJustify{} = 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 ShapeFile{} = 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 Z{} = True -usedByNodes _ = False +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 Group{} = True +usedByNodes Height{} = True +usedByNodes ID{} = True +usedByNodes Image{} = True +usedByNodes ImageScale{} = True +usedByNodes LabelLoc{} = True +usedByNodes Label{} = True +usedByNodes Layer{} = True +usedByNodes Margin{} = True +usedByNodes NoJustify{} = 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 ShapeFile{} = 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 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 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 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 Label{} = 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 _ = False - +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 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 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 Label{} = 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 UnknownAttribute{} = True +usedByEdges _ = False {- Delete to here -} + -- ----------------------------------------------------------------------------- {- | @@ -907,33 +928,6 @@ -- ----------------------------------------------------------------------------- --- | No checks are placed on the content of a 'URL' value; however, --- you should ensure that it does not contain any \'@>@\' or \'@<@\' --- characters; Graphviz might care about escaping other characters --- properly, but for the purposes of this library the presence of --- these characters will make it harder to parse URLs. -newtype URL = UStr { urlString :: EscString } - deriving (Eq, Ord, Show, Read) - -instance PrintDot URL where - unqtDot = wrap (char '<') (char '>') - -- Explicitly use text here... no quotes! - . text . urlString - -instance ParseDot URL where - parseUnqt = liftM UStr - $ bracket (character open) - (character close) - (many1 $ satisfy ((/=) close)) - where - open = '<' - close = '>' - - -- No quotes - parse = parseUnqt - --- ----------------------------------------------------------------------------- - -- | /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 @@ -980,12 +974,12 @@ appMod (m, a) = unqtDot m <> unqtDot a instance ParseDot ArrowType where - parseUnqt = do mas <- many1 $ do m <- parseUnqt + parseUnqt = specialArrowParse + `onFail` + do mas <- many1 $ do m <- parseUnqt a <- parseUnqt return (m,a) return $ AType mas - `onFail` - specialArrowParse specialArrowParse :: Parse ArrowType specialArrowParse = oneOf [ stringRep eDiamond "ediamond" @@ -1247,27 +1241,114 @@ -- ----------------------------------------------------------------------------- data Label = StrLabel EscString - | URLLabel URL + | HtmlLabel HtmlLabel -- ^ If 'PlainText' is used, the + -- 'HtmlLabel' value is the entire + -- \"shape\"; if anything else + -- except 'PointShape' is used then + -- the 'HtmlLabel' 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 (URLLabel u) = unqtDot u + unqtDot (StrLabel s) = unqtDot s + unqtDot (HtmlLabel h) = angled $ unqtDot h + unqtDot (RecordLabel fs) = unqtDot fs - toDot (StrLabel s) = toDot s - toDot (URLLabel u) = toDot u + toDot (StrLabel s) = toDot s + toDot h@HtmlLabel{} = unqtDot h + toDot (RecordLabel fs) = toDot fs instance ParseDot Label where - parseUnqt = liftM StrLabel parseUnqt - `onFail` - liftM URLLabel parseUnqt + -- 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. - parse = liftM StrLabel parse - `onFail` - liftM URLLabel parse + 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 = doubleQuotes $ unqtDot rf + + unqtListToDot [f] = unqtDot f + unqtListToDot fs = hsep . punctuate (char '|') $ map unqtDot fs + + listToDot [f] = toDot f + listToDot fs = doubleQuotes $ unqtListToDot fs + +instance ParseDot RecordField where + parseUnqt = do t <- liftM PN $ parseAngled parseRecord + ml <- optional (whitespace >> 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] = 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 String +parseRecord = parseEscaped False recordEscChars + +unqtRecordString :: String -> DotCode +unqtRecordString = unqtEscaped recordEscChars + +recordEscChars :: [Char] +recordEscChars = ['{', '}', '|', ' ', '<', '>'] + +-- ----------------------------------------------------------------------------- + data Point = Point Int Int | PointD Double Double deriving (Eq, Ord, Show, Read) @@ -1374,7 +1455,7 @@ parseLayerName :: Parse String parseLayerName = many1 . orQuote - $ satisfy (liftM2 (&&) notLayerSep ((/=) quoteChar)) + $ satisfy (liftM2 (&&) notLayerSep (quoteChar /=)) parseLayerName' :: Parse String parseLayerName' = stringBlock @@ -1766,6 +1847,8 @@ | 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 @@ -1799,6 +1882,8 @@ 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 = oneOf [ stringRep Box3D "box3d" -- Parse this before "box" @@ -1831,6 +1916,8 @@ , stringRep Tab "tab" , stringRep Folder "folder" , stringRep Component "component" + , stringRep Record "record" + , stringRep MRecord "Mrecord" ] -- ----------------------------------------------------------------------------- @@ -1901,6 +1988,8 @@ -- ----------------------------------------------------------------------------- +-- | An individual style item. Except for 'DD', the @['String']@ +-- should be empty. data StyleItem = SItem StyleName [String] deriving (Eq, Ord, Show, Read) @@ -1925,7 +2014,6 @@ parseUnqt = do nm <- parseUnqt args <- tryParseList' parseArgs return $ SItem nm args - where parse = quotedParse (liftM2 SItem parseUnqt parseArgs) `onFail` @@ -1972,13 +2060,9 @@ instance ParseDot StyleName where parseUnqt = liftM checkDD parseStyleName - parse = liftM checkDD - $ quotedParse parseStyleName - `onFail` - -- In case a singleton DD is at the end of an attribute list. - do f <- orQuote $ noneOf [quoteChar, '(', ')', ',', ' ', ']'] - r <- many (orQuote $ noneOf [quoteChar, '(', ')', ',', ']']) - return $ f:r + parse = quotedParse parseUnqt + `onFail` + liftM checkDD quotelessString checkDD :: String -> StyleName checkDD str = case map toLower str of @@ -1993,60 +2077,11 @@ _ -> DD str parseStyleName :: Parse String -parseStyleName = do f <- orQuote $ noneOf [quoteChar, '(', ')', ',', ' '] - r <- many (orQuote $ noneOf [quoteChar, '(', ')', ',']) +parseStyleName = do f <- orQuote . noneOf $ ' ' : disallowedChars + r <- many (orQuote $ noneOf disallowedChars) return $ f:r - --- ----------------------------------------------------------------------------- - -newtype PortPos = PP CompassPoint - deriving (Eq, Ord, Show, Read) - -instance PrintDot PortPos where - unqtDot (PP cp) = unqtDot cp - - toDot (PP cp) = toDot cp - -instance ParseDot PortPos where - parseUnqt = liftM PP parseUnqt - -data CompassPoint = North - | NorthEast - | East - | SouthEast - | South - | SouthWest - | West - | NorthWest - | CenterPoint - | NoCP - deriving (Eq, Ord, Bounded, Enum, Show, Read) - -instance PrintDot CompassPoint where - unqtDot NorthEast = text "ne" - unqtDot NorthWest = text "nw" - unqtDot North = text "n" - unqtDot East = text "e" - unqtDot SouthEast = text "se" - unqtDot SouthWest = text "sw" - unqtDot South = text "s" - unqtDot West = text "w" - unqtDot CenterPoint = text "c" - unqtDot NoCP = text "_" - -instance ParseDot CompassPoint where - -- Have to take care of longer parsing values first. - parseUnqt = oneOf [ stringRep NorthEast "ne" - , stringRep NorthWest "nw" - , stringRep North "n" - , stringRep SouthEast "se" - , stringRep SouthWest "sw" - , stringRep South "s" - , stringRep East "e" - , stringRep West "w" - , stringRep CenterPoint "c" - , stringRep NoCP "_" - ] + where + disallowedChars = [quoteChar, '(', ')', ','] -- ----------------------------------------------------------------------------- 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,6 +1,6 @@ {- | Module : Data.GraphViz.Attributes.Colors - Description : Helper functions for converting to Dot format. + Description : Specification of Color-related types and functions. Copyright : (c) Ivan Lazar Miljenovic License : 3-Clause BSD-style Maintainer : Ivan.Miljenovic@gmail.com diff --git a/Data/GraphViz/Attributes/HTML.hs b/Data/GraphViz/Attributes/HTML.hs new file mode 100644 --- /dev/null +++ b/Data/GraphViz/Attributes/HTML.hs @@ -0,0 +1,589 @@ +{- | + Module : Data.GraphViz.Attributes.HTML + Description : Specification of HTML-like types for Graphviz. + Copyright : (c) Ivan Lazar Miljenovic + License : 3-Clause BSD-style + Maintainer : Ivan.Miljenovic@gmail.com + + This module defines the syntax for HTML-like values for use in + Graphviz. Please note that these values are /not/ really HTML, but + the term \"HTML\" is used throughout as it is less cumbersome than + \"HTML-like\". To be able to use this, the version of Graphviz must + be at least 1.10. For more information, please see: + + + The actual definition of the syntax specifies that these types must + be valid XML syntax. As such, this assumed when printing and parsing, + though the correct escape/descaping for @\"@, @&@, @\<@ and @\>@ are + automatically done when printing and parsing. + + Differences from how Graphviz treats HTML-like values: + + * Graphviz only specifies the above-listed characters must be + escaped; however, internally it also escapes @-@, @\'@ and multiple + sequences of spaces. This library attempts to match this behaviour. + Please let me know if this behaviour (especially about escaping + multiple spaces) is unwanted. + + * When parsing escaped HTML characters, numeric escapes are + converted to the corresponding character as are the various characters + listed above; all other escaped characters (apart from those listed + above) are silently ignored and removed from the input (since + technically these must be valid /XML/, which doesn't recognise as many + named escape characters as does HTML). + + * All whitespace read in is kept (even if Graphviz would ignore + multiple whitespace characters); when printing them, however, they are + replaced with non-breaking spaces. As such, if multiple literal + whitespace characters are used in a sequence, then the result of + parsing and then printing some Dot code will /not/ be the same as the + initial Dot code. Furthermore, all whitespace characters are printed + as spaces. + + * It is assumed that all parsed @&@ values are the beginning of an + XML escape sequence (which /must/ finish with a @;@ character). + + * There should be no pre-escaped characters in values; when + printing, the @&@ will get escaped without considering if that is an + escaped character. + +-} +module Data.GraphViz.Attributes.HTML + ( HtmlLabel(..) + , HtmlText + , HtmlTextItem(..) + , HtmlTable(..) + , HtmlRow(..) + , HtmlCell(..) + , HtmlImg(..) + , HtmlAttributes + , HtmlAttribute(..) + , HtmlAlign(..) + , HtmlVAlign(..) + , HtmlScale(..) + ) 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 Numeric(readHex) +import Data.Char(chr, ord, isSpace) +import Data.Function(on) +import Data.List(groupBy, delete) +import Data.Maybe(maybeToList, listToMaybe) +import Data.Word(Word8, Word16) +import qualified Data.Map as Map +import Control.Monad(liftM) + +-- ----------------------------------------------------------------------------- + +-- | The overall type for HTML-like labels. Fundamentally, HTML-like +-- values in Graphviz are either textual (i.e. a single element with +-- formatting) or a table. Note that 'HtmlLabel' values can be +-- nested via 'HtmlLabelCell'. +data HtmlLabel = HtmlText HtmlText + | HtmlTable HtmlTable + deriving (Eq, Ord, Show, Read) + +instance PrintDot HtmlLabel where + unqtDot (HtmlText txt) = unqtDot txt + unqtDot (HtmlTable tbl) = unqtDot tbl + +instance ParseDot HtmlLabel where + -- Try parsing HtmlTable first in case of a FONT tag being used. + parseUnqt = liftM HtmlTable parseUnqt + `onFail` + liftM HtmlText parseUnqt + `adjustErr` + (++ "\nCan't parse HtmlLabel") + + parse = parseUnqt + +-- | Represents a textual component of an HTML-like label. It is +-- assumed that an 'HtmlText' list is non-empty. It is preferable +-- to \"group\" 'HtmlStr' values together rather than have +-- individual ones. Note that when printing, the individual values +-- are concatenated together without spaces, and when parsing +-- anything that isn't a tag is assumed to be an 'HtmlStr': that is, +-- something like \"@\ \@\" is parsed as: +-- +-- > [HtmlNewline [], HtmlStr " ", HtmlNewline []] +type HtmlText = [HtmlTextItem] + +-- | Textual items in HTML-like labels. +data HtmlTextItem = HtmlStr String + -- | Only accepts an optional 'HtmlAlign' + -- 'HtmlAttribute'; defined this way for ease of + -- printing/parsing. + | HtmlNewline HtmlAttributes + | HtmlFont HtmlAttributes HtmlText + deriving (Eq, Ord, Show, Read) + +instance PrintDot HtmlTextItem where + unqtDot (HtmlStr str) = escapeValue str + unqtDot (HtmlNewline as) = printHtmlEmptyTag (text "BR") as + unqtDot (HtmlFont as txt) = printHtmlFontTag as $ unqtDot txt + + unqtListToDot = hcat . map unqtDot + + listToDot = unqtListToDot + +instance ParseDot HtmlTextItem where + parseUnqt = oneOf [ liftM HtmlStr unescapeValue + , parseHtmlEmptyTag HtmlNewline "BR" + , parseHtmlFontTag HtmlFont parseUnqt + ] + `adjustErr` + (++ "\nCan't parse HtmlTextItem") + + parse = parseUnqt + + parseUnqtList = many1 parseUnqt -- sepBy1 parseUnqt allWhitespace' + + parseList = parseUnqtList + +-- | A table in HTML-like labels. Tables are optionally wrapped in +-- overall @FONT@ tags. +data HtmlTable = HTable { -- | Optional @FONT@ attributes. @'Just' + -- []@ denotes empty @FONT@ tags; + -- @'Nothing'@ denotes no such tags. + tableFontAttrs :: Maybe HtmlAttributes + , tableAttrs :: HtmlAttributes + -- | This list is assumed to be non-empty. + , tableRows :: [HtmlRow] + } + deriving (Eq, Ord, Show, Read) + +instance PrintDot HtmlTable where + unqtDot tbl = case tableFontAttrs tbl of + (Just as) -> printHtmlFontTag as tbl' + Nothing -> tbl' + where + tbl' = printHtmlTag (text "TABLE") + (tableAttrs tbl) + (toDot $ tableRows tbl) + +instance ParseDot HtmlTable where + parseUnqt = wrapWhitespace (parseHtmlFontTag addFontAttrs pTbl) + `onFail` + pTbl + `adjustErr` + (++ "\nCan't parse HtmlTable") + where + pTbl = wrapWhitespace $ parseHtmlTag (HTable Nothing) + "TABLE" + (wrapWhitespace parseUnqt) + addFontAttrs fas tbl = tbl { tableFontAttrs = Just fas } + + parse = parseUnqt + +-- | A row in an 'HtmlTable'. The list of 'HtmlCell' values is +-- assumed to be non-empty. +newtype HtmlRow = HtmlRow [HtmlCell] + deriving (Eq, Ord, Show, Read) + +instance PrintDot HtmlRow where + unqtDot (HtmlRow cs) = printHtmlTag tr [] $ unqtDot cs + where + tr = text "TR" + + unqtListToDot = hcat . map unqtDot + + listToDot = unqtListToDot + +instance ParseDot HtmlRow where + -- To save doing it manually, use 'parseHtmlTag' and ignore any + -- 'HtmlAttributes' that it might accidentally parse. + parseUnqt = wrapWhitespace $ parseHtmlTag (const HtmlRow) "TR" parseUnqt + `adjustErr` + (++ "\nCan't parse HtmlRow") + + parse = parseUnqt + + parseUnqtList = wrapWhitespace $ sepBy1 parseUnqt allWhitespace' + + parseList = parseUnqtList + +-- | Cells either recursively contain another 'HtmlLabel' or else a +-- path to an image file. +data HtmlCell = HtmlLabelCell HtmlAttributes HtmlLabel + | HtmlImgCell HtmlAttributes HtmlImg + deriving (Eq, Ord, Show, Read) + +instance PrintDot HtmlCell where + unqtDot (HtmlLabelCell as l) = printCell as $ unqtDot l + unqtDot (HtmlImgCell as img) = printCell as $ unqtDot img + + unqtListToDot = hsep . map unqtDot + + listToDot = unqtListToDot + +printCell :: HtmlAttributes -> DotCode -> DotCode +printCell = printHtmlTag (text "TD") + +instance ParseDot HtmlCell where + parseUnqt = oneOf [ parseCell HtmlLabelCell parse + , parseCell HtmlImgCell $ wrapWhitespace parseUnqt + ] + `adjustErr` + (++ "\nCan't parse HtmlCell") + where + parseCell = flip parseHtmlTag "TD" + + parse = parseUnqt + + parseUnqtList = wrapWhitespace $ sepBy1 parseUnqt allWhitespace' + + parseList = parseUnqtList + +-- | The path to an image; accepted 'HtmlAttributes' are 'HtmlScale' and 'HtmlSrc'. +newtype HtmlImg = HtmlImg HtmlAttributes + deriving (Eq, Ord, Show, Read) + +instance PrintDot HtmlImg where + unqtDot (HtmlImg as) = printHtmlEmptyTag (text "IMG") as + +instance ParseDot HtmlImg where + parseUnqt = wrapWhitespace (parseHtmlEmptyTag HtmlImg "IMG") + `adjustErr` + (++ "\nCan't parse HtmlImg") + + parse = parseUnqt + +-- ----------------------------------------------------------------------------- + +-- | The various HTML-like label-specific attributes being used. +type HtmlAttributes = [HtmlAttribute] + +-- | Note that not all 'HtmlAttribute' values are valid everywhere: +-- see the comments for each one on where it is valid. +data HtmlAttribute = HtmlAlign HtmlAlign -- ^ Valid for: 'HtmlTable', 'HtmlCell', 'HtmlNewline'. + | HtmlBAlign HtmlAlign -- ^ Valid for: 'HtmlCell'. + | HtmlBGColor Color -- ^ Valid for: 'HtmlTable' (including 'tableFontAttrs'), 'HtmlCell', 'HtmlFont'. + | HtmlBorder Word8 -- ^ Valid for: 'HtmlTable', 'HtmlCell'. Default is @1@; @0@ represents no border. + | HtmlCellBorder Word8 -- ^ Valid for: 'HtmlTable'. Default is @1@; @0@ represents no border. + | HtmlCellPadding Word8 -- ^ Valid for: 'HtmlTable', 'HtmlCell'. Default is @2@. + | HtmlCellSpacing Word8 -- ^ Valid for: 'HtmlTable', 'HtmlCell'. Default is @2@; maximum is @127@. + | HtmlColor Color -- ^ Valid for: 'HtmlTable', 'HtmlCell'. + | HtmlColSpan Word16 -- ^ Valid for: 'HtmlCell'. Default is @1@. + | HtmlFace String -- ^ Valid for: 'tableFontAttrs', 'HtmlFont'. + | HtmlFixedSize Bool -- ^ Valid for: 'HtmlTable', 'HtmlCell'. Default is @'False'@. + | HtmlHeight Word16 -- ^ Valid for: 'HtmlTable', 'HtmlCell'. + | HtmlHRef String -- ^ Valid for: 'HtmlTable', 'HtmlCell'. + | HtmlPointSize Double -- ^ Valid for: 'tableFontAttrs', 'HtmlFont'. + | HtmlPort PortName -- ^ Valid for: 'HtmlTable', 'HtmlCell'. + | HtmlRowSpan Word16 -- ^ Valid for: 'HtmlCell'. + | HtmlScale HtmlScale -- ^ Valid for: 'HtmlImg'. + | HtmlSrc FilePath -- ^ Valid for: 'HtmlImg'. + | HtmlTarget String -- ^ Valid for: 'HtmlTable', 'HtmlCell'. + | HtmlTitle String -- ^ Valid for: 'HtmlTable', 'HtmlCell'. Has an alias of @TOOLTIP@. + | HtmlVAlign HtmlVAlign -- ^ Valid for: 'HtmlTable', 'HtmlCell'. + | HtmlWidth Word16 -- ^ Valid for: 'HtmlTable', 'HtmlCell'. + deriving (Eq, Ord, Show, Read) + +instance PrintDot HtmlAttribute where + unqtDot (HtmlAlign v) = printHtmlField "ALIGN" v + unqtDot (HtmlBAlign v) = printHtmlField "BALIGN" v + unqtDot (HtmlBGColor v) = printHtmlField "BGCOLOR" v + unqtDot (HtmlBorder v) = printHtmlField "BORDER" v + unqtDot (HtmlCellBorder v) = printHtmlField "CELLBORDER" v + unqtDot (HtmlCellPadding v) = printHtmlField "CELLPADDING" v + unqtDot (HtmlCellSpacing v) = printHtmlField "CELLSPACING" v + unqtDot (HtmlColor v) = printHtmlField "COLOR" v + unqtDot (HtmlColSpan v) = printHtmlField "COLSPAN" v + unqtDot (HtmlFace v) = printHtmlField' "FACE" $ escapeAttribute v + unqtDot (HtmlFixedSize v) = printHtmlField' "FIXEDSIZE" $ printBoolHtml v + unqtDot (HtmlHeight v) = printHtmlField "HEIGHT" v + unqtDot (HtmlHRef v) = printHtmlField' "HREF" $ escapeAttribute v + unqtDot (HtmlPointSize v) = printHtmlField "POINT-SIZE" v + unqtDot (HtmlPort v) = printHtmlField' "PORT" . escapeAttribute $ portName v + unqtDot (HtmlRowSpan v) = printHtmlField "ROWSPAN" v + unqtDot (HtmlScale v) = printHtmlField "SCALE" v + unqtDot (HtmlSrc v) = printHtmlField' "SRC" $ escapeAttribute v + unqtDot (HtmlTarget v) = printHtmlField' "TARGET" $ escapeAttribute v + unqtDot (HtmlTitle v) = printHtmlField' "TITLE" $ escapeAttribute v + unqtDot (HtmlVAlign v) = printHtmlField "VALIGN" v + unqtDot (HtmlWidth v) = printHtmlField "WIDTH" v + + unqtListToDot = hsep . map unqtDot + + listToDot = unqtListToDot + +-- | Only to be used when the 'PrintDot' instance of @a@ matches the +-- HTML syntax (i.e. numbers and @Html*@ values; 'Color' values also +-- seem to work). +printHtmlField :: (PrintDot a) => String -> a -> DotCode +printHtmlField f = printHtmlField' f . unqtDot + +printHtmlField' :: String -> DotCode -> DotCode +printHtmlField' f v = text f <> equals <> doubleQuotes v + +instance ParseDot HtmlAttribute where + parseUnqt = oneOf [ parseHtmlField HtmlAlign "ALIGN" + , parseHtmlField HtmlBAlign "BALIGN" + , parseHtmlField HtmlBGColor "BGCOLOR" + , parseHtmlField HtmlBorder "BORDER" + , parseHtmlField HtmlCellBorder "CELLBORDER" + , parseHtmlField HtmlCellPadding "CELLPADDING" + , parseHtmlField HtmlCellSpacing "CELLSPACING" + , parseHtmlField HtmlColor "COLOR" + , parseHtmlField HtmlColSpan "COLSPAN" + , parseHtmlField' HtmlFace "FACE" unescapeAttribute + , parseHtmlField' HtmlFixedSize "FIXEDSIZE" parseBoolHtml + , parseHtmlField HtmlHeight "HEIGHT" + , parseHtmlField' HtmlHRef "HREF" unescapeAttribute + , parseHtmlField HtmlPointSize "POINT-SIZE" + , parseHtmlField' (HtmlPort . PN) "PORT" unescapeAttribute + , parseHtmlField HtmlRowSpan "ROWSPAN" + , parseHtmlField HtmlScale "SCALE" + , parseHtmlField' HtmlSrc "SRC" unescapeAttribute + , parseHtmlField' HtmlTarget "TARGET" unescapeAttribute + , parseHtmlField' HtmlTitle "TITLE" unescapeAttribute + `onFail` + parseHtmlField' HtmlTitle "TOOLTIP" unescapeAttribute + , parseHtmlField HtmlVAlign "VALIGN" + , parseHtmlField HtmlWidth "WIDTH" + ] + + parse = parseUnqt + + parseUnqtList = sepBy parseUnqt allWhitespace -- needs at least one whitespace char + + parseList = parseUnqtList + + + +parseHtmlField :: (ParseDot a) => (a -> HtmlAttribute) -> String + -> Parse HtmlAttribute +parseHtmlField c f = parseHtmlField' c f parseUnqt + +parseHtmlField' :: (a -> HtmlAttribute) -> String -> Parse a + -> Parse HtmlAttribute +parseHtmlField' c f p = do string f + parseEq + liftM c $ quotedParse p + +-- | Specifies horizontal placement. When an object is allocated more +-- space than required, this value determines where the extra space +-- is placed left and right of the object. +data HtmlAlign = HLeft + | HCenter -- ^ Default value. + | HRight + | HText -- ^ 'HtmlLabelCell' values only; aligns lines + -- of text using the full cell width. The + -- alignment of a line is determined by its + -- (possibly implicit) associated + -- 'HtmlNewline' element. + deriving (Eq, Ord, Bounded, Enum, Show, Read) + +instance PrintDot HtmlAlign where + unqtDot HLeft = text "LEFT" + unqtDot HCenter = text "CENTER" + unqtDot HRight = text "RIGHT" + unqtDot HText = text "TEXT" + +instance ParseDot HtmlAlign where + parseUnqt = oneOf [ stringRep HLeft "LEFT" + , stringRep HCenter "CENTER" + , stringRep HRight "RIGHT" + , stringRep HText "TEXT" + ] + + parse = parseUnqt + +-- | Specifies vertical placement. When an object is allocated more +-- space than required, this value determines where the extra space +-- is placed above and below the object. +data HtmlVAlign = HTop + | HMiddle -- ^ Default value. + | HBottom + deriving (Eq, Ord, Bounded, Enum, Show, Read) + +instance PrintDot HtmlVAlign where + unqtDot HTop = text "TOP" + unqtDot HMiddle = text "MIDDLE" + unqtDot HBottom = text "BOTTOM" + +instance ParseDot HtmlVAlign where + parseUnqt = oneOf [ stringRep HTop "TOP" + , stringRep HMiddle "MIDDLE" + , stringRep HBottom "BOTTOM" + ] + + 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 HtmlScale = HtmlNaturalSize -- ^ Default value. + | HtmlScaleUniformly + | HtmlExpandWidth + | HtmlExpandHeight + | HtmlExpandBoth + deriving (Eq, Ord, Bounded, Enum, Show, Read) + +instance PrintDot HtmlScale where + unqtDot HtmlNaturalSize = text "FALSE" + unqtDot HtmlScaleUniformly = text "TRUE" + unqtDot HtmlExpandWidth = text "WIDTH" + unqtDot HtmlExpandHeight = text "HEIGHT" + unqtDot HtmlExpandBoth = text "BOTH" + +instance ParseDot HtmlScale where + parseUnqt = oneOf [ stringRep HtmlNaturalSize "FALSE" + , stringRep HtmlScaleUniformly "TRUE" + , stringRep HtmlExpandWidth "WIDTH" + , stringRep HtmlExpandHeight "HEIGHT" + , stringRep HtmlExpandBoth "BOTH" + ] + + parse = parseUnqt + +-- ----------------------------------------------------------------------------- + +escapeAttribute :: String -> DotCode +escapeAttribute = escapeHtml False + +escapeValue :: String -> DotCode +escapeValue = escapeHtml True + +escapeHtml :: Bool -> String -> DotCode +escapeHtml quotesAllowed = hcat + . concatMap escapeSegment + . 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 = char s : map numEscape sps + escapeSegment txt = map xmlChar txt + + allowQuotes = if quotesAllowed + then Map.delete '"' + else id + + escs = allowQuotes $ Map.fromList htmlEscapes + xmlChar c = maybe (char c) escape $ c `Map.lookup` escs + + numEscape = escape' . (<>) (char '#') . int . ord + escape' e = char '&' <> e <> char ';' + escape = escape' . text + +unescapeAttribute :: Parse String +unescapeAttribute = unescapeHtml False + +unescapeValue :: Parse String +unescapeValue = unescapeHtml True + +-- | Parses an HTML-compatible 'String', de-escaping known characters. +-- Note: this /will/ fail if an unknown non-numeric HTML-escape is +-- used. +unescapeHtml :: Bool -> Parse String +unescapeHtml quotesAllowed = liftM concat + . many1 . oneOf $ [ parseEscpd + , validChars + ] + where + parseEscpd = do character '&' + esc <- many1 $ satisfy (';' /=) + character ';' + let c = case esc of + ('#':'x':hex) -> readMaybe readHex hex + ('#':'X':hex) -> readMaybe readHex hex + ('#':dec) -> readMaybe readInt dec + _ -> esc `Map.lookup` escMap + return $ maybeToList c + + readMaybe f str = do (n, []) <- listToMaybe $ f str + return $ chr n + readInt :: ReadS Int + readInt = reads + + allowQuotes = if quotesAllowed + then delete '"' + else id + + escMap = Map.fromList htmlUnescapes + + validChars = liftM return $ satisfy (`notElem` needEscaping) + needEscaping = allowQuotes $ map fst htmlEscapes + +-- | The characters that need to be escaped and what they need to be +-- replaced with (sans @'&'@). +htmlEscapes :: [(Char, String)] +htmlEscapes = [ ('"', "quot") + , ('<', "lt") + , ('>', "gt") + , ('&', "amp") + ] + ++ map numEscape ['-', '\''] + where + numEscape c = (c, '#' : show (ord c)) + +-- | Flip the order and add extra values that might be escaped. More +-- specifically, provide the escape code for spaces (@\"nbsp\"@) and +-- apostrophes (@\"apos\"@) since they aren't used for escaping. +htmlUnescapes :: [(String, Char)] +htmlUnescapes = maybeEscaped + ++ + map (uncurry (flip (,))) htmlEscapes + where + maybeEscaped = [("nbsp", ' '), ("apos", '\'')] + +printBoolHtml :: Bool -> DotCode +printBoolHtml = text . bool "FALSE" "TRUE" + +parseBoolHtml :: Parse Bool +parseBoolHtml = stringRep True "TRUE" + `onFail` + stringRep False "FALSE" + +-- ----------------------------------------------------------------------------- + +-- | Print something like @value<\/FOO>@ +printHtmlTag :: DotCode -> HtmlAttributes -> DotCode -> DotCode +printHtmlTag t as v = angled (t <+> toDot as) + <> v + <> angled (fslash <> t) + +printHtmlFontTag :: HtmlAttributes -> DotCode -> DotCode +printHtmlFontTag = printHtmlTag (text "FONT") + +-- | Print something like @@ +printHtmlEmptyTag :: DotCode -> HtmlAttributes -> DotCode +printHtmlEmptyTag t as = angled $ t <+> toDot as <> fslash + +-- ----------------------------------------------------------------------------- + +-- Note: can't use bracket here because we're not completely +-- discarding everything from the opening bracket. + +-- | Parse something like @value<\/FOO>@ +parseHtmlTag :: (HtmlAttributes -> val -> tag) -> String + -> Parse val -> Parse tag +parseHtmlTag c t pv = do as <- parseAngled openingTag + v <- pv + parseAngled $ character '/' >> t' >> allWhitespace' + return $ c as v + where + t' = string t + openingTag = do t' + as <- tryParseList' $ allWhitespace >> parse + allWhitespace' + return as + +parseHtmlFontTag :: (HtmlAttributes -> val -> tag) -> Parse val -> Parse tag +parseHtmlFontTag = flip parseHtmlTag "FONT" + +-- | Parse something like @@ +parseHtmlEmptyTag :: (HtmlAttributes -> tag) -> String -> Parse tag +parseHtmlEmptyTag c t = parseAngled + ( do string t + as <- tryParseList' $ allWhitespace >> parse + allWhitespace' + character '/' + return $ c as + ) diff --git a/Data/GraphViz/Attributes/Internal.hs b/Data/GraphViz/Attributes/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/GraphViz/Attributes/Internal.hs @@ -0,0 +1,152 @@ +{-# OPTIONS_HADDOCK hide #-} + +{- | + Module : Data.GraphViz.Attributes.Internal + Description : Internal Attribute value definitions + Copyright : (c) Ivan Lazar Miljenovic + License : 3-Clause BSD-style + Maintainer : Ivan.Miljenovic@gmail.com + + This module is defined so as to avoid exposing internal functions + in the external API. + + -} + +module Data.GraphViz.Attributes.Internal + ( PortName(..) + , PortPos(..) + , CompassPoint(..) + , compassLookup + , parseEdgeBasedPP + ) where + +import Data.GraphViz.Parsing +import Data.GraphViz.Printing + +import Data.Maybe(isNothing) +import qualified Data.Map as Map +import Data.Map(Map) +import Control.Monad(liftM, liftM2) + +-- ----------------------------------------------------------------------------- + +-- Note that printing and parsing of PortName values is specific to +-- where it's being used: record- and HTML-like labels print/parse +-- them differently from when they're on they're part of PortPos; the +-- default printing and parsing is done for the latter. + +-- Should this really be exported from here? Or in another common module? + +-- | Specifies a name for ports (used also in record-based and +-- HTML-like labels). Note that it is not valid for a 'PortName' +-- value to contain a colon (@:@) character; it is assumed that it +-- doesn't. +newtype PortName = PN { portName :: String } + deriving (Eq, Ord, Show, Read) + +instance PrintDot PortName where + unqtDot = unqtDot . portName + + toDot = toDot . portName + +instance ParseDot PortName where + parseUnqt = liftM PN . many1 + . orQuote $ satisfy (`notElem` ['"', ':']) + + parse= quotedParse parseUnqt + `onFail` + unqtPortName + +unqtPortName :: Parse PortName +unqtPortName = liftM PN quotelessString + +-- ----------------------------------------------------------------------------- + +data PortPos = LabelledPort PortName (Maybe CompassPoint) + | CompassPoint CompassPoint + deriving (Eq, Ord, Show, Read) + +instance PrintDot PortPos where + unqtDot (LabelledPort n mc) = unqtDot n + <> maybe empty (colon <>) (fmap unqtDot mc) + unqtDot (CompassPoint cp) = unqtDot cp + + toDot (LabelledPort n Nothing) = toDot n + toDot lp@LabelledPort{} = doubleQuotes $ unqtDot lp + toDot cp = unqtDot cp + +instance ParseDot PortPos where + parseUnqt = do n <- parseUnqt + mc <- optional $ character ':' >> parseUnqt + return $ if isNothing mc + then checkPortName n + else LabelledPort n mc + + parse = quotedParse parseUnqt + `onFail` + liftM checkPortName unqtPortName + +checkPortName :: PortName -> PortPos +checkPortName pn = maybe (LabelledPort pn Nothing) CompassPoint + . flip 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) + `onFail` + parse + +data CompassPoint = North + | NorthEast + | East + | SouthEast + | South + | SouthWest + | West + | NorthWest + | CenterPoint + | NoCP + deriving (Eq, Ord, Bounded, Enum, Show, Read) + +instance PrintDot CompassPoint where + unqtDot NorthEast = text "ne" + unqtDot NorthWest = text "nw" + unqtDot North = text "n" + unqtDot East = text "e" + unqtDot SouthEast = text "se" + unqtDot SouthWest = text "sw" + unqtDot South = text "s" + unqtDot West = text "w" + unqtDot CenterPoint = text "c" + unqtDot NoCP = text "_" + +instance ParseDot CompassPoint where + -- Have to take care of longer parsing values first. + parseUnqt = oneOf [ stringRep NorthEast "ne" + , stringRep NorthWest "nw" + , stringRep North "n" + , stringRep SouthEast "se" + , stringRep SouthWest "sw" + , stringRep South "s" + , stringRep East "e" + , stringRep West "w" + , stringRep CenterPoint "c" + , stringRep NoCP "_" + ] + +compassLookup :: Map String CompassPoint +compassLookup = Map.fromList [ ("ne", NorthEast) + , ("nw", NorthWest) + , ("n", North) + , ("e", East) + , ("se", SouthEast) + , ("sw", SouthWest) + , ("s", South) + , ("w", West) + , ("c", CenterPoint) + , ("_", NoCP) + ] + +-- ----------------------------------------------------------------------------- diff --git a/Data/GraphViz/Commands.hs b/Data/GraphViz/Commands.hs --- a/Data/GraphViz/Commands.hs +++ b/Data/GraphViz/Commands.hs @@ -62,7 +62,7 @@ import Control.Exception.Extensible( SomeException(..), catch , bracket, evaluate, handle) import Control.Monad(liftM) -import System.FilePath(FilePath, (<.>)) +import System.FilePath((<.>)) -- ----------------------------------------------------------------------------- @@ -170,7 +170,7 @@ | WBmp -- ^ Wireless BitMap format; -- monochrome format usually used -- for mobile computing devices. - deriving (Eq, Ord, Show, Read) + deriving (Eq, Ord, Bounded, Enum, Show, Read) instance GraphvizResult GraphvizOutput where outputCall Bmp = "bmp" @@ -255,7 +255,7 @@ -- file; instead, they directly draw a canvas (i.e. a window) with -- the resulting image. data GraphvizCanvas = Gtk | Xlib - deriving (Eq, Ord, Read, Show) + deriving (Eq, Ord, Bounded, Enum, Read, Show) instance GraphvizResult GraphvizCanvas where outputCall Gtk = "gtk" @@ -309,7 +309,7 @@ -- 'hGetContents' that will ensure this happens. -- -- If the command was unsuccessful, then @'Left' error@ is returned. -graphvizWithHandle :: (DotRepr dg n, Show a) +graphvizWithHandle :: (DotRepr dg n) => GraphvizCommand -- ^ Which command to run -> dg n -- ^ The 'DotRepr' to use -> GraphvizOutput -- ^ The 'GraphvizOutput' type @@ -319,7 +319,7 @@ -- This version is not exported as we don't want to let arbitrary -- @Handle -> IO a@ functions to be used for GraphvizCanvas outputs. -graphvizWithHandle' :: (DotRepr dg n, GraphvizResult o, Show a) +graphvizWithHandle' :: (DotRepr dg n, GraphvizResult o) => GraphvizCommand -> dg n -> o -> (Handle -> IO a) -> IO (Either String a) graphvizWithHandle' cmd gr t f @@ -342,8 +342,8 @@ mvOutput <- newEmptyMVar mvErr <- newEmptyMVar - _ <- forkIO $ signalWhenDone hGetContents' errp mvErr - _ <- forkIO $ signalWhenDone f' outp mvOutput + forkIO $ signalWhenDone hGetContents' errp mvErr + forkIO $ signalWhenDone f' outp mvOutput -- When these are both able to be taken, then the forks are finished err <- takeMVar mvErr @@ -385,10 +385,8 @@ runGraphvizCanvas cmd gr c = liftM maybeErr $ graphvizWithHandle' cmd gr c nullHandle where - nullHandle :: Handle -> IO () - nullHandle h = do r <- hGetContents h - evaluate (length r) - return () + nullHandle :: Handle -> IO () + nullHandle = liftM (const ()) . hGetContents' -- | Run the recommended Graphviz command on this graph and render it -- using the given canvas type. diff --git a/Data/GraphViz/Parsing.hs b/Data/GraphViz/Parsing.hs --- a/Data/GraphViz/Parsing.hs +++ b/Data/GraphViz/Parsing.hs @@ -25,22 +25,30 @@ , Parse , ParseDot(..) , parseIt + , parseIt' + , runParser' -- * Convenience parsing combinators. + , bracket + , discard , onlyBool + , quotelessString , stringBlock , numString , isNumString , isIntString , quotedString + , parseEscaped , parseAndSpace , string , strings - , hasString , character , parseStrictFloat , noneOf , whitespace , whitespace' + , allWhitespace + , allWhitespace' + , wrapWhitespace , optionalQuotedString , optionalQuoted , quotedParse @@ -49,9 +57,10 @@ , newline , newline' , parseComma + , parseEq , tryParseList , tryParseList' - , skipToNewline + , consumeLine , parseField , parseFields , parseFieldBool @@ -63,22 +72,22 @@ , commaSep' , stringRep , stringReps - -- * Pre-processing of Dot code to remove comments, etc. - , preProcess + , parseAngled + , parseBraced ) where import Data.GraphViz.Util -import Text.ParserCombinators.Poly.Lazy +import Text.ParserCombinators.Poly.Lazy hiding (bracket, discard) import Data.Char( digitToInt , isDigit , isSpace , toLower ) -import Data.Function(on) -import Data.Maybe(isJust, fromMaybe, isNothing) +import Data.Maybe(fromMaybe, isNothing) import Data.Ratio((%)) -import Data.Word(Word8) +import qualified Data.Set as Set +import Data.Word(Word8, Word16) import Control.Monad(liftM, when) -- ----------------------------------------------------------------------------- @@ -87,6 +96,14 @@ -- | A @ReadS@-like type alias. type Parse a = Parser Char a +-- | A variant of 'runParser' where it is assumed that the provided +-- parsing function consumes all of the 'String' input (with the +-- exception of whitespace at the end). +runParser' :: Parse a -> String -> a +runParser' p = fst . runParser p' + where + p' = p `discard` (allWhitespace' >> eof) + class ParseDot a where parseUnqt :: Parse a @@ -95,27 +112,44 @@ parseUnqtList :: Parse [a] parseUnqtList = bracketSep (parseAndSpace $ character '[') - (parseAndSpace $ parseComma) - (parseAndSpace $ character ']') - (parseAndSpace parse) + ( wrapWhitespace parseComma + `onFail` + allWhitespace + ) + (allWhitespace' >> 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. +-- 'String' that hasn't been parsed (for debugging purposes). parseIt :: (ParseDot a) => String -> (a, String) parseIt = runParser parse +-- | Parse the required value with the assumption that it will parse +-- all of the input 'String'. +parseIt' :: (ParseDot a) => String -> a +parseIt' = runParser' parse + instance ParseDot Int where parseUnqt = parseInt' instance ParseDot Word8 where parseUnqt = parseInt +instance ParseDot Word16 where + parseUnqt = parseInt + instance ParseDot Double where parseUnqt = parseFloat' + parseUnqtList = sepBy1 parseUnqt (character ':') + + parseList = quotedParse parseUnqtList + `onFail` + liftM return parse + instance ParseDot Bool where parseUnqt = onlyBool `onFail` @@ -143,7 +177,7 @@ -- such, this will successfully parse all un-quoted Strings. parseUnqtList = quotedString - parseList = oneOf [numString, stringBlock] + parseList = quotelessString `onFail` -- This will also take care of quoted versions of -- above. @@ -154,6 +188,10 @@ parse = parseList +-- | Parse a 'String' that doesn't need to be quoted. +quotelessString :: Parse String +quotelessString = numString `onFail` stringBlock + numString :: Parse String numString = liftM show parseStrictFloat `onFail` @@ -166,10 +204,7 @@ -- | Used when quotes are explicitly required; quotedString :: Parse String -quotedString = many stringInterior - -stringInterior :: Parse Char -stringInterior = orQuote $ satisfy ((/=) quoteChar) +quotedString = parseEscaped True [] parseSigned :: Real a => Parse a -> Parse a parseSigned p = (character '-' >> liftM negate p) @@ -195,9 +230,8 @@ parseFloat = do ds <- many (satisfy isDigit) frac <- optional $ do character '.' - many1 (satisfy isDigit) - `adjustErr` (++ "\nexpected digit after .") - when (isNothing frac && null ds) + many (satisfy isDigit) + when (null ds && noDec frac) (fail "No actual digits in floating point number!") expn <- optional parseExp when (isNothing frac && isNothing expn) @@ -205,14 +239,15 @@ let frac' = fromMaybe "" frac expn' = fromMaybe 0 expn ( return . fromRational . (* (10^^(expn' - length frac'))) - . (%1) . fst - . runParser parseInt) (ds++frac') + . (%1) . runParser' parseInt) (ds++frac') `onFail` fail "Expected a floating point number" - where parseExp = do character 'e' - ((character '+' >> parseInt) - `onFail` - parseInt') + where + parseExp = do character 'e' + ((character '+' >> parseInt) + `onFail` + parseInt') + noDec = maybe True null parseFloat' :: Parse Double parseFloat' = parseSigned ( parseFloat @@ -225,8 +260,31 @@ -- ----------------------------------------------------------------------------- +-- | 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"++)) + +infixl 3 `discard` + +-- | @x `discard` y@ parses both x and y, but discards the result of y. +-- +-- The definition of @discard@ defined in Polyparse is too strict +-- and prevents backtracking. This should be fixed in the next +-- release after 1.4. +discard :: Parse a -> Parse b -> Parse a +pa `discard` pb = do a <- pa + pb + return a + parseAndSpace :: Parse a -> Parse a -parseAndSpace p = p `discard` whitespace' +parseAndSpace p = p `discard` allWhitespace' string :: String -> Parse String string = mapM character @@ -240,13 +298,12 @@ strings :: [String] -> Parse String strings = oneOf . map string -hasString :: String -> Parse Bool -hasString = liftM isJust . optional . string - character :: Char -> Parse Char -character c = satisfy (((==) `on` toLower) c) +character c = satisfy parseC `adjustErr` (++ "\nnot the expected char: " ++ [c]) + where + parseC c' = c' == c || toLower c == c' noneOf :: (Eq a) => [a] -> Parser a a noneOf t = satisfy (\x -> all (/= x) t) @@ -257,6 +314,16 @@ whitespace' :: Parse String whitespace' = many (satisfy isSpace) +allWhitespace :: Parse () +allWhitespace = (whitespace `onFail` newline) >> allWhitespace' + +allWhitespace' :: Parse () +allWhitespace' = newline' `discard` whitespace' + +-- | Parse and discard optional whitespace. +wrapWhitespace :: Parse a -> Parse a +wrapWhitespace = bracket allWhitespace' allWhitespace' + optionalQuotedString :: String -> Parse String optionalQuotedString = optionalQuoted . string @@ -279,6 +346,23 @@ quoteChar :: Char quoteChar = '"' +-- | Parse a 'String' where the provided 'Char's (as well as @\"@) are +-- escaped. Note: does not parse surrounding quotes, and assumes +-- that @\\@ is not an escaped character. The 'Bool' value +-- indicates whether empty 'String's are allowed or not. +parseEscaped :: Bool -> [Char] -> Parse String +parseEscaped empt cs = lots $ qPrs `onFail` oth + where + lots = if empt then many else many1 + cs' = quoteChar : cs + csSet = Set.fromList cs' + slash = '\\' + -- Have to allow standard slashes + qPrs = do character slash + mE <- optional $ oneOf (map character cs') + return $ fromMaybe slash mE + oth = satisfy (`Set.notMember` csSet) + newline :: Parse String newline = oneOf $ map string ["\r\n", "\n", "\r"] @@ -289,35 +373,43 @@ newline' = many (whitespace' >> newline) >> return () -- | Parses and returns all characters up till the end of the line, --- then skips to the beginning of the next line. -skipToNewline :: Parse String -skipToNewline = many (noneOf ['\n','\r']) `discard` newline +-- but does not touch the newline characters. +consumeLine :: Parse String +consumeLine = many (noneOf ['\n','\r']) -parseField :: (ParseDot a) => String -> Parse a -parseField fld = do string fld - whitespace' - character '=' - whitespace' - parse +parseEq :: Parse () +parseEq = wrapWhitespace (character '=') >> return () -parseFields :: (ParseDot a) => [String] -> Parse a -parseFields = oneOf . map parseField +parseField :: (ParseDot a) => (a -> b) -> String -> Parse b +parseField c fld = do string fld + parseEq + liftM c parse -parseFieldBool :: String -> Parse Bool -parseFieldBool = parseFieldDef True +parseFields :: (ParseDot a) => (a -> b) -> [String] -> Parse b +parseFields c = oneOf . map (parseField c) -parseFieldsBool :: [String] -> Parse Bool -parseFieldsBool = oneOf . map parseFieldBool +parseFieldBool :: (Bool -> b) -> String -> Parse b +parseFieldBool = flip parseFieldDef True +parseFieldsBool :: (Bool -> b) -> [String] -> Parse b +parseFieldsBool c = oneOf . map (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 -> String -> Parse a -parseFieldDef d fld = parseField fld - `onFail` - stringRep d fld +parseFieldDef :: (ParseDot a) => (a -> b) -> a -> String -> Parse b +parseFieldDef c d fld = parseField c fld + `onFail` + -- Have to make sure it isn't too greedy + -- guessing something is a global attribute + -- when its actually a node/edge/etc. + do string fld + nxt <- optional $ satisfy restIDString + bool (fail "Not actually the field you were after") + (return $ c d) + (isNothing nxt) -parseFieldsDef :: (ParseDot a) => a -> [String] -> Parse a -parseFieldsDef d = oneOf . map (parseFieldDef d) +parseFieldsDef :: (ParseDot a) => (a -> b) -> a -> [String] -> Parse b +parseFieldsDef c d = oneOf . map (parseFieldDef c d) commaSep :: (ParseDot a, ParseDot b) => Parse (a, b) commaSep = commaSep' parse parse @@ -333,8 +425,8 @@ b <- pb return (a,b) -parseComma :: Parse Char -parseComma = character ',' +parseComma :: Parse () +parseComma = character ',' >> return () tryParseList :: (ParseDot a) => Parse [a] tryParseList = tryParseList' parse @@ -342,54 +434,8 @@ tryParseList' :: Parse [a] -> Parse [a] tryParseList' = liftM (fromMaybe []) . optional --- ----------------------------------------------------------------------------- --- Filtering out unwanted Dot items such as comments - --- | Remove unparseable features of Dot, such as comments and --- multi-line strings (which are converted to single-line strings). -preProcess :: String -> String -preProcess = fst . runParser parseOutUnwanted - -- snd should be null - --- | Parse out comments and make quoted strings spread over multiple --- lines only over a single line. Should parse the /entire/ input --- 'String'. -parseOutUnwanted :: Parse String -parseOutUnwanted = liftM concat (many getNext) - where - getNext :: Parse String - getNext = parseSplitStrings - `onFail` - (oneOf [ parseLineComment, parseMultiLineComment ] >> return []) - `onFail` - liftM return next - --- | Parse @//@-style comments. -parseLineComment :: Parse String -parseLineComment = string "//" >> newline - --- | Parse @/* ... */@-style comments. -parseMultiLineComment :: Parse String -parseMultiLineComment = bracket start end (liftM concat $ many inner) - where - start = string "/*" - end = string "*/" - inner = many1 (satisfy ((/=) '*')) - `onFail` - do ast <- character '*' - n <- satisfy ((/=) '/') - liftM ((:) ast . (:) n) inner - --- | Parse out @\@ from a quoted string. -parseSplitStrings :: Parse String -parseSplitStrings = do oq <- parseQuote - inner <- liftM concat $ many parseInner - cq <- parseQuote - return $ oq : inner ++ [cq] - where - parseInner = string "\\\"" - `onFail` - (character '\\' >> newline >> return []) - `onFail` - liftM return (satisfy ((/=) quoteChar)) +parseAngled :: Parse a -> Parse a +parseAngled = bracket (character '<') (character '>') +parseBraced :: Parse a -> Parse a +parseBraced = bracket (character '{') (character '}') diff --git a/Data/GraphViz/PreProcessing.hs b/Data/GraphViz/PreProcessing.hs new file mode 100644 --- /dev/null +++ b/Data/GraphViz/PreProcessing.hs @@ -0,0 +1,118 @@ +{- | + Module : Data.GraphViz.PreProcessing + Description : Pre-process imported Dot code. + Copyright : (c) Ivan Lazar Miljenovic + License : 3-Clause BSD-style + Maintainer : Ivan.Miljenovic@gmail.com + + "Real life" Dot code contains various items that are not directly + parseable by this library. This module defines the 'preProcess' + function to remove these components, which include: + + * 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). + + * 'String's concatenated together using @\"...\" + \"...\"@; + these are concatenated into one big 'String'. +-} +module Data.GraphViz.PreProcessing(preProcess) where + +import Data.GraphViz.Parsing + +import Control.Monad(liftM) + +-- ----------------------------------------------------------------------------- +-- Filtering out unwanted Dot items such as comments + +-- | Remove unparseable features of Dot, such as comments and +-- multi-line strings (which are converted to single-line strings). +preProcess :: String -> String +preProcess = runParser' parseOutUnwanted + -- snd should be null + +-- | Parse out comments and make quoted strings spread over multiple +-- lines only over a single line. Should parse the /entire/ input +-- 'String'. +parseOutUnwanted :: Parse String +parseOutUnwanted = liftM concat (many getNext) + where + getNext = parseConcatStrings + `onFail` + parseHTML + `onFail` + (parseUnwanted >> return []) + `onFail` + liftM return next + +-- | Parses an unwanted part of the Dot code (comments and +-- pre-processor lines; also un-splits lines). +parseUnwanted :: Parse () +parseUnwanted = oneOf [ parseLineComment + , parseMultiLineComment + , parsePreProcessor + , parseSplitLine + ] + >> return () + +-- | Remove pre-processor lines (that is, those that start with a +-- @#@). Will consume the newline from the beginning of the +-- previous line, but will leave the one from the pre-processor line +-- there (so in the end it just removes the line). +parsePreProcessor :: Parse String +parsePreProcessor = do newline + character '#' + consumeLine + +-- | Parse @//@-style comments. +parseLineComment :: Parse String +parseLineComment = string "//" + -- Note: do /not/ consume the newlines, as they're + -- needed in case the next line is a pre-processor + -- line. + >> consumeLine + +-- | Parse @/* ... */@-style comments. +parseMultiLineComment :: Parse String +parseMultiLineComment = bracket start end (liftM concat $ many inner) + where + start = string "/*" + end = string "*/" + inner = many1 (satisfy ((/=) '*')) + `onFail` + do ast <- character '*' + n <- satisfy ((/=) '/') + liftM ((:) ast . (:) n) inner + +parseConcatStrings :: Parse String +parseConcatStrings = liftM (wrapQuotes . concat) + $ sepBy1 parseString parseConcat + where + parseString = quotedParse (liftM concat $ many parseInner) + parseInner = string "\\\"" + `onFail` + parseSplitLine -- in case there's a split mid-quote + `onFail` + liftM return (satisfy ((/=) quoteChar)) + parseConcat = parseSep >> character '+' >> parseSep + parseSep = many $ allWhitespace `onFail` parseUnwanted + wrapQuotes str = quoteChar : str ++ [quoteChar] + + +-- | Lines can be split with a @\\@ at the end of the line. +parseSplitLine :: Parse String +parseSplitLine = character '\\' >> newline >> return "" + +parseHTML :: Parse String +parseHTML = liftM (addQuotes . concat) + . parseAngled $ many inner + where + inner = parseHTML + `onFail` + many1 (satisfy (\c -> c /= open && c /= close)) + addQuotes str = open : str ++ [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 @@ -28,6 +28,10 @@ * an HTML string (<...>). + (Note that the first restriction is referring to a byte-by-byte + comparison using octal values; when using UTF-8 this corresponds to + all characters @c@ where @ord c >= 128@.) + Due to these restrictions, you should only use 'text' when you are sure that the 'String' in question is static and quotes are definitely needed/unneeded; it is better to use the 'String' @@ -42,9 +46,15 @@ , PrintDot(..) , printIt , addQuotes + , unqtEscaped + , printEscaped , wrap , commaDel , printField + , angled + , rang + , lang + , fslash ) where import Data.GraphViz.Util @@ -61,7 +71,9 @@ import qualified Text.PrettyPrint as PP -import Data.Word(Word8) +import Data.Char(toLower) +import qualified Data.Set as Set +import Data.Word(Word8, Word16) -- ----------------------------------------------------------------------------- @@ -112,6 +124,9 @@ instance PrintDot Word8 where unqtDot = int . fromIntegral +instance PrintDot Word16 where + unqtDot = int . fromIntegral + instance PrintDot Double where -- If it's an "integral" double, then print as an integer. -- This seems to match how Graphviz apps use Dot. @@ -121,6 +136,17 @@ where di = round d + toDot d = if any ((==) 'e' . toLower) $ show d + then doubleQuotes ud + else ud + where + ud = unqtDot d + + unqtListToDot = hcat . punctuate colon . map unqtDot + + listToDot [d] = toDot d + listToDot ds = doubleQuotes $ unqtListToDot ds + instance PrintDot Bool where unqtDot True = text "true" unqtDot False = text "false" @@ -154,11 +180,11 @@ -- | Escape quotes in Strings that need them. unqtString :: String -> DotCode unqtString "" = empty -unqtString str = text $ escapeQuotes str -- no quotes? no worries! +unqtString str = unqtEscaped [] str -- no quotes? no worries! -- | Escape quotes and quote Strings that need them (including keywords). -qtString :: String -> DotCode -qtString str = addQuotes str $ unqtString str +qtString :: String -> DotCode +qtString = printEscaped [] instance (PrintDot a) => PrintDot [a] where unqtDot = unqtListToDot @@ -173,3 +199,39 @@ printField :: (PrintDot a) => String -> a -> DotCode printField f v = text f <> equals <> toDot v + +-- | Escape the specified chars as well as @\"@. +unqtEscaped :: [Char] -> String -> DotCode +unqtEscaped cs = text . addEscapes cs + +-- | Escape the specified chars as well as @\"@ and then wrap the +-- result in quotes. +printEscaped :: [Char] -> String -> DotCode +printEscaped cs str = addQuotes str' $ text str' + where + str' = addEscapes cs str + +-- | Ensure the provided characters are all escaped. Note that we +-- cannot convert to 'DotCode' immediately because 'printEscaped' +-- needs to pass the result from this to 'addQuotes' to determine if +-- it needs to be quoted or not. +addEscapes :: [Char] -> String -> String +addEscapes cs = foldr escape "" + where + cs' = Set.fromList $ quote : cs + slash = '\\' + quote = '"' + escape c str | c `Set.member` cs' = slash : c : str + | otherwise = c : str + +angled :: DotCode -> DotCode +angled = wrap lang rang + +lang :: DotCode +lang = char '<' + +rang :: DotCode +rang = char '>' + +fslash :: DotCode +fslash = char '/' diff --git a/Data/GraphViz/Testing.hs b/Data/GraphViz/Testing.hs --- a/Data/GraphViz/Testing.hs +++ b/Data/GraphViz/Testing.hs @@ -35,15 +35,14 @@ * To avoid needless endless recursion, 'DotSubGraph's do not have sub-'DotSubGraph's (same with 'GDotSubGraph's). - * The 'Graph' values that are generated do not have multiple edges - for simplicity purposes. - * This test suite isn't perfect: if you deliberately try to stuff something up, you probably can. -} module Data.GraphViz.Testing ( -- * Running the test suite. runDefaultTests + , runTests + , runTest -- ** The tests themselves , Test(..) , test_printParseID_Attributes @@ -52,6 +51,7 @@ , test_preProcessingID , test_parsePrettyID , test_dotizeAugment + , test_dotizeAugmentUniq -- * Re-exporting modules for manual testing. , module Data.GraphViz , module Data.GraphViz.Types.Generalised @@ -76,7 +76,8 @@ import Data.GraphViz.Testing.Properties import Data.GraphViz hiding (RunResult(..)) -import Data.GraphViz.Parsing(ParseDot(..), parseIt, runParser, preProcess) +import Data.GraphViz.Parsing(ParseDot(..), parseIt, runParser) +import Data.GraphViz.PreProcessing(preProcess) import Data.GraphViz.Printing(PrintDot(..), printIt, renderDot) import Data.GraphViz.Types.Generalised hiding ( GraphID(..) , GlobalAttributes(..) @@ -101,7 +102,7 @@ \If any of these tests fail, please inform the maintainer,\n\ \including full output of this test suite.\n\ \\n\ - \This test suite takes approximately 110 minutes to run on a\n\ + \This test suite takes approximately 55 minutes to run on a\n\ \2 GHz Mobile Core 2 Duo (running with a single thread)." successMsg = "All tests were successful!" @@ -166,6 +167,7 @@ -- DotGraphs to pass to Graphviz! -- , test_parsePrettyID , test_dotizeAugment + , test_dotizeAugmentUniq ] -- | Test that 'Attributes' can be printed and then parsed back. @@ -277,3 +279,19 @@ \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_dotizeAugmentUniq :: Test +test_dotizeAugmentUniq + = Test { name = "Unique edges in augmented FGL Graphs" + , desc = dsc + , test = quickCheckResult 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." + diff --git a/Data/GraphViz/Testing/Instances.hs b/Data/GraphViz/Testing/Instances.hs --- a/Data/GraphViz/Testing/Instances.hs +++ b/Data/GraphViz/Testing/Instances.hs @@ -20,16 +20,18 @@ import Data.GraphViz.Parsing(isNumString) import Data.GraphViz.Attributes +import Data.GraphViz.Attributes.Internal(compassLookup) import Data.GraphViz.Types import Data.GraphViz.Types.Generalised +import Data.GraphViz.Util(bool) import Test.QuickCheck -import Data.Char(toLower) -import Data.List(nub) +import Data.List(nub, delete, groupBy) import qualified Data.Sequence as Seq +import qualified Data.Map as Map import Control.Monad(liftM, liftM2, liftM3, liftM4, guard) -import Data.Word(Word8) +import Data.Word(Word8, Word16) -- ----------------------------------------------------------------------------- -- Defining Arbitrary instances for the overall types @@ -44,13 +46,11 @@ arbitrary = oneof [ liftM Str arbString , liftM Int arbitrary , liftM Dbl $ suchThat arbitrary notInt - , liftM HTML arbitrary ] shrink (Str s) = map Str $ shrinkString s shrink (Int i) = map Int $ shrink i shrink (Dbl d) = map Dbl $ filter notInt $ shrink d - shrink (HTML u) = map HTML $ shrink u instance (Eq a, Arbitrary a) => Arbitrary (DotStatements a) where arbitrary = sized (arbDS True) @@ -154,7 +154,7 @@ instance Arbitrary Attribute where arbitrary = oneof [ liftM Damping arbitrary , liftM K arbitrary - , liftM URL arbitrary + , liftM URL arbString , liftM ArrowHead arbitrary , liftM ArrowSize arbitrary , liftM ArrowTail arbitrary @@ -178,7 +178,7 @@ , liftM DirEdgeConstraints arbitrary , liftM Distortion arbitrary , liftM DPI arbitrary - , liftM EdgeURL arbitrary + , liftM EdgeURL arbString , liftM EdgeTarget arbString , liftM EdgeTooltip arbString , liftM Epsilon arbitrary @@ -191,7 +191,7 @@ , liftM FontPath arbString , liftM FontSize arbitrary , liftM Group arbString - , liftM HeadURL arbitrary + , liftM HeadURL arbString , liftM HeadClip arbitrary , liftM HeadLabel arbitrary , liftM HeadPort arbitrary @@ -201,7 +201,7 @@ , liftM ID arbitrary , liftM Image arbString , liftM ImageScale arbitrary - , liftM LabelURL arbitrary + , liftM LabelURL arbString , liftM LabelAngle arbitrary , liftM LabelDistance arbitrary , liftM LabelFloat arbitrary @@ -255,7 +255,7 @@ , liftM QuadTree arbitrary , liftM Quantum arbitrary , liftM RankDir arbitrary - , liftM RankSep arbitrary + , liftM RankSep arbList , liftM Rank arbitrary , liftM Ratio arbitrary , liftM Rects arbitrary @@ -281,7 +281,7 @@ , liftM Start arbitrary , liftM StyleSheet arbString , liftM Style arbList - , liftM TailURL arbitrary + , liftM TailURL arbString , liftM TailClip arbitrary , liftM TailLabel arbitrary , liftM TailPort arbitrary @@ -296,168 +296,321 @@ , liftM Weight arbitrary , liftM Width arbitrary , liftM Z arbitrary + , liftM2 UnknownAttribute (suchThat arbIDString validUnknown) arbString ] - shrink (Damping v) = map Damping $ shrink v - shrink (K v) = map K $ shrink v - shrink (URL v) = map URL $ 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 (Bb v) = map Bb $ shrink v - shrink (BgColor v) = map BgColor $ shrink v - shrink (Center v) = map Center $ shrink v - shrink (Charset v) = map Charset $ shrinkString v - shrink (ClusterRank v) = map ClusterRank $ shrink v - shrink (ColorScheme v) = map ColorScheme $ shrink v - shrink (Color v) = map Color $ nonEmptyShrinks v - shrink (Comment v) = map Comment $ shrinkString v - shrink (Compound v) = map Compound $ shrink v - shrink (Concentrate v) = map Concentrate $ shrink v - shrink (Constraint v) = map Constraint $ shrink v - shrink (Decorate v) = map Decorate $ shrink v - shrink (DefaultDist v) = map DefaultDist $ shrink v - shrink (Dimen v) = map Dimen $ shrink v - shrink (Dim v) = map Dim $ shrink v - shrink (Dir v) = map Dir $ shrink v - shrink (DirEdgeConstraints v) = map DirEdgeConstraints $ shrink v - shrink (Distortion v) = map Distortion $ shrink v - shrink (DPI v) = map DPI $ shrink v - shrink (EdgeURL v) = map EdgeURL $ shrink v - shrink (EdgeTarget v) = map EdgeTarget $ shrinkString v - shrink (EdgeTooltip v) = map EdgeTooltip $ shrinkString v - shrink (Epsilon v) = map Epsilon $ shrink v - shrink (ESep v) = map ESep $ shrink v - shrink (FillColor v) = map FillColor $ shrink v - shrink (FixedSize v) = map FixedSize $ shrink v - shrink (FontColor v) = map FontColor $ shrink v - shrink (FontName v) = map FontName $ shrinkString v - shrink (FontNames v) = map FontNames $ shrinkString v - shrink (FontPath v) = map FontPath $ shrinkString v - shrink (FontSize v) = map FontSize $ shrink v - shrink (Group v) = map Group $ shrinkString v - shrink (HeadURL v) = map HeadURL $ shrink v - shrink (HeadClip v) = map HeadClip $ shrink v - shrink (HeadLabel v) = map HeadLabel $ shrink v - shrink (HeadPort v) = map HeadPort $ shrink v - shrink (HeadTarget v) = map HeadTarget $ shrinkString v - shrink (HeadTooltip v) = map HeadTooltip $ shrinkString v - shrink (Height v) = map Height $ shrink v - shrink (ID v) = map ID $ shrink v - shrink (Image v) = map Image $ shrinkString v - shrink (ImageScale v) = map ImageScale $ shrink v - shrink (LabelURL v) = map LabelURL $ shrink v - shrink (LabelAngle v) = map LabelAngle $ shrink v - shrink (LabelDistance v) = map LabelDistance $ shrink v - shrink (LabelFloat v) = map LabelFloat $ shrink v - shrink (LabelFontColor v) = map LabelFontColor $ shrink v - shrink (LabelFontName v) = map LabelFontName $ shrinkString v - shrink (LabelFontSize v) = map LabelFontSize $ shrink v - shrink (LabelJust v) = map LabelJust $ shrink v - shrink (LabelLoc v) = map LabelLoc $ shrink v - shrink (LabelTarget v) = map LabelTarget $ shrinkString v - shrink (LabelTooltip v) = map LabelTooltip $ shrinkString v - shrink (Label v) = map Label $ shrink v - shrink (Landscape v) = map Landscape $ shrink v - shrink (LayerSep v) = map LayerSep $ shrinkString v - shrink (Layers v) = map Layers $ shrink v - shrink (Layer v) = map Layer $ shrink v - shrink (Layout v) = map Layout $ shrinkString v - shrink (Len v) = map Len $ shrink v - shrink (LevelsGap v) = map LevelsGap $ shrink v - shrink (Levels v) = map Levels $ shrink v - shrink (LHead v) = map LHead $ shrinkString v - shrink (LPos v) = map LPos $ shrink v - shrink (LTail v) = map LTail $ shrinkString v - shrink (Margin v) = map Margin $ shrink v - shrink (MaxIter v) = map MaxIter $ shrink v - shrink (MCLimit v) = map MCLimit $ shrink v - shrink (MinDist v) = map MinDist $ shrink v - shrink (MinLen v) = map MinLen $ shrink v - shrink (Model v) = map Model $ shrink v - shrink (Mode v) = map Mode $ shrink v - shrink (Mosek v) = map Mosek $ shrink v - shrink (NodeSep v) = map NodeSep $ shrink v - shrink (NoJustify v) = map NoJustify $ shrink v - shrink (Normalize v) = map Normalize $ shrink v - shrink (Nslimit1 v) = map Nslimit1 $ shrink v - shrink (Nslimit v) = map Nslimit $ shrink v - shrink (Ordering v) = map Ordering $ shrinkString v - shrink (Orientation v) = map Orientation $ shrink v - shrink (OutputOrder v) = map OutputOrder $ shrink v - shrink (OverlapScaling v) = map OverlapScaling $ shrink v - shrink (Overlap v) = map Overlap $ shrink v - shrink (PackMode v) = map PackMode $ shrink v - shrink (Pack v) = map Pack $ shrink v - shrink (Pad v) = map Pad $ shrink v - shrink (PageDir v) = map PageDir $ shrink v - shrink (Page v) = map Page $ shrink v - shrink (PenColor v) = map PenColor $ shrink v - shrink (PenWidth v) = map PenWidth $ shrink v - shrink (Peripheries v) = map Peripheries $ shrink v - shrink (Pin v) = map Pin $ shrink v - shrink (Pos v) = map Pos $ shrink v - shrink (QuadTree v) = map QuadTree $ shrink v - shrink (Quantum v) = map Quantum $ shrink v - shrink (RankDir v) = map RankDir $ shrink v - shrink (RankSep v) = map RankSep $ shrink v - shrink (Rank v) = map Rank $ shrink v - shrink (Ratio v) = map Ratio $ shrink v - shrink (Rects v) = map Rects $ shrink v - shrink (Regular v) = map Regular $ shrink v - shrink (ReMinCross v) = map ReMinCross $ shrink v - shrink (RepulsiveForce v) = map RepulsiveForce $ shrink v - shrink (Root v) = map Root $ shrink v - shrink (Rotate v) = map Rotate $ shrink v - shrink (SameHead v) = map SameHead $ shrinkString v - shrink (SameTail v) = map SameTail $ shrinkString v - shrink (SamplePoints v) = map SamplePoints $ shrink v - shrink (SearchSize v) = map SearchSize $ shrink v - shrink (Sep v) = map Sep $ shrink v - shrink (ShapeFile v) = map ShapeFile $ shrinkString v - shrink (Shape v) = map Shape $ shrink v - shrink (ShowBoxes v) = map ShowBoxes $ shrink v - shrink (Sides v) = map Sides $ shrink v - shrink (Size v) = map Size $ shrink v - shrink (Skew v) = map Skew $ shrink v - shrink (Smoothing v) = map Smoothing $ shrink v - shrink (SortV v) = map SortV $ shrink v - shrink (Splines v) = map Splines $ shrink v - shrink (Start v) = map Start $ shrink v - shrink (StyleSheet v) = map StyleSheet $ shrinkString v - shrink (Style v) = map Style $ nonEmptyShrinks v - shrink (TailURL v) = map TailURL $ shrink v - shrink (TailClip v) = map TailClip $ shrink v - shrink (TailLabel v) = map TailLabel $ shrink v - shrink (TailPort v) = map TailPort $ shrink v - shrink (TailTarget v) = map TailTarget $ shrinkString v - shrink (TailTooltip v) = map TailTooltip $ shrinkString v - shrink (Target v) = map Target $ shrinkString v - shrink (Tooltip v) = map Tooltip $ shrinkString v - shrink (TrueColor v) = map TrueColor $ shrink v - shrink (Vertices v) = map Vertices $ nonEmptyShrinks v - shrink (ViewPort v) = map ViewPort $ shrink v - shrink (VoroMargin v) = map VoroMargin $ shrink v - shrink (Weight v) = map Weight $ shrink v - shrink (Width v) = map Width $ shrink v - shrink (Z v) = map Z $ shrink v + shrink (Damping v) = map Damping $ shrink v + shrink (K v) = map K $ shrink v + shrink (URL v) = map URL $ shrinkString 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 (Bb v) = map Bb $ shrink v + shrink (BgColor v) = map BgColor $ shrink v + shrink (Center v) = map Center $ shrink v + shrink (Charset v) = map Charset $ shrinkString v + shrink (ClusterRank v) = map ClusterRank $ shrink v + shrink (ColorScheme v) = map ColorScheme $ shrink v + shrink (Color v) = map Color $ nonEmptyShrinks v + shrink (Comment v) = map Comment $ shrinkString v + shrink (Compound v) = map Compound $ shrink v + shrink (Concentrate v) = map Concentrate $ shrink v + shrink (Constraint v) = map Constraint $ shrink v + shrink (Decorate v) = map Decorate $ shrink v + shrink (DefaultDist v) = map DefaultDist $ shrink v + shrink (Dimen v) = map Dimen $ shrink v + shrink (Dim v) = map Dim $ shrink v + shrink (Dir v) = map Dir $ shrink v + shrink (DirEdgeConstraints v) = map DirEdgeConstraints $ shrink v + shrink (Distortion v) = map Distortion $ shrink v + shrink (DPI v) = map DPI $ shrink v + shrink (EdgeURL v) = map EdgeURL $ shrinkString v + shrink (EdgeTarget v) = map EdgeTarget $ shrinkString v + shrink (EdgeTooltip v) = map EdgeTooltip $ shrinkString v + shrink (Epsilon v) = map Epsilon $ shrink v + shrink (ESep v) = map ESep $ shrink v + shrink (FillColor v) = map FillColor $ shrink v + shrink (FixedSize v) = map FixedSize $ shrink v + shrink (FontColor v) = map FontColor $ shrink v + shrink (FontName v) = map FontName $ shrinkString v + shrink (FontNames v) = map FontNames $ shrinkString v + shrink (FontPath v) = map FontPath $ shrinkString v + shrink (FontSize v) = map FontSize $ shrink v + shrink (Group v) = map Group $ shrinkString v + shrink (HeadURL v) = map HeadURL $ shrinkString v + shrink (HeadClip v) = map HeadClip $ shrink v + shrink (HeadLabel v) = map HeadLabel $ shrink v + shrink (HeadPort v) = map HeadPort $ shrink v + shrink (HeadTarget v) = map HeadTarget $ shrinkString v + shrink (HeadTooltip v) = map HeadTooltip $ shrinkString v + shrink (Height v) = map Height $ shrink v + shrink (ID v) = map ID $ shrink v + shrink (Image v) = map Image $ shrinkString v + shrink (ImageScale v) = map ImageScale $ shrink v + shrink (LabelURL v) = map LabelURL $ shrinkString v + shrink (LabelAngle v) = map LabelAngle $ shrink v + shrink (LabelDistance v) = map LabelDistance $ shrink v + shrink (LabelFloat v) = map LabelFloat $ shrink v + shrink (LabelFontColor v) = map LabelFontColor $ shrink v + shrink (LabelFontName v) = map LabelFontName $ shrinkString v + shrink (LabelFontSize v) = map LabelFontSize $ shrink v + shrink (LabelJust v) = map LabelJust $ shrink v + shrink (LabelLoc v) = map LabelLoc $ shrink v + shrink (LabelTarget v) = map LabelTarget $ shrinkString v + shrink (LabelTooltip v) = map LabelTooltip $ shrinkString v + shrink (Label v) = map Label $ shrink v + shrink (Landscape v) = map Landscape $ shrink v + shrink (LayerSep v) = map LayerSep $ shrinkString v + shrink (Layers v) = map Layers $ shrink v + shrink (Layer v) = map Layer $ shrink v + shrink (Layout v) = map Layout $ shrinkString v + shrink (Len v) = map Len $ shrink v + shrink (LevelsGap v) = map LevelsGap $ shrink v + shrink (Levels v) = map Levels $ shrink v + shrink (LHead v) = map LHead $ shrinkString v + shrink (LPos v) = map LPos $ shrink v + shrink (LTail v) = map LTail $ shrinkString v + shrink (Margin v) = map Margin $ shrink v + shrink (MaxIter v) = map MaxIter $ shrink v + shrink (MCLimit v) = map MCLimit $ shrink v + shrink (MinDist v) = map MinDist $ shrink v + shrink (MinLen v) = map MinLen $ shrink v + shrink (Model v) = map Model $ shrink v + shrink (Mode v) = map Mode $ shrink v + shrink (Mosek v) = map Mosek $ shrink v + shrink (NodeSep v) = map NodeSep $ shrink v + shrink (NoJustify v) = map NoJustify $ shrink v + shrink (Normalize v) = map Normalize $ shrink v + shrink (Nslimit1 v) = map Nslimit1 $ shrink v + shrink (Nslimit v) = map Nslimit $ shrink v + shrink (Ordering v) = map Ordering $ shrinkString v + shrink (Orientation v) = map Orientation $ shrink v + shrink (OutputOrder v) = map OutputOrder $ shrink v + shrink (OverlapScaling v) = map OverlapScaling $ shrink v + shrink (Overlap v) = map Overlap $ shrink v + shrink (PackMode v) = map PackMode $ shrink v + shrink (Pack v) = map Pack $ shrink v + shrink (Pad v) = map Pad $ shrink v + shrink (PageDir v) = map PageDir $ shrink v + shrink (Page v) = map Page $ shrink v + shrink (PenColor v) = map PenColor $ shrink v + shrink (PenWidth v) = map PenWidth $ shrink v + shrink (Peripheries v) = map Peripheries $ shrink v + shrink (Pin v) = map Pin $ shrink v + shrink (Pos v) = map Pos $ shrink v + shrink (QuadTree v) = map QuadTree $ shrink v + shrink (Quantum v) = map Quantum $ shrink v + shrink (RankDir v) = map RankDir $ shrink v + shrink (RankSep v) = map RankSep $ nonEmptyShrinks v + shrink (Rank v) = map Rank $ shrink v + shrink (Ratio v) = map Ratio $ shrink v + shrink (Rects v) = map Rects $ shrink v + shrink (Regular v) = map Regular $ shrink v + shrink (ReMinCross v) = map ReMinCross $ shrink v + shrink (RepulsiveForce v) = map RepulsiveForce $ shrink v + shrink (Root v) = map Root $ shrink v + shrink (Rotate v) = map Rotate $ shrink v + shrink (SameHead v) = map SameHead $ shrinkString v + shrink (SameTail v) = map SameTail $ shrinkString v + shrink (SamplePoints v) = map SamplePoints $ shrink v + shrink (SearchSize v) = map SearchSize $ shrink v + shrink (Sep v) = map Sep $ shrink v + shrink (ShapeFile v) = map ShapeFile $ shrinkString v + shrink (Shape v) = map Shape $ shrink v + shrink (ShowBoxes v) = map ShowBoxes $ shrink v + shrink (Sides v) = map Sides $ shrink v + shrink (Size v) = map Size $ shrink v + shrink (Skew v) = map Skew $ shrink v + shrink (Smoothing v) = map Smoothing $ shrink v + shrink (SortV v) = map SortV $ shrink v + shrink (Splines v) = map Splines $ shrink v + shrink (Start v) = map Start $ shrink v + shrink (StyleSheet v) = map StyleSheet $ shrinkString v + shrink (Style v) = map Style $ nonEmptyShrinks v + shrink (TailURL v) = map TailURL $ shrinkString v + shrink (TailClip v) = map TailClip $ shrink v + shrink (TailLabel v) = map TailLabel $ shrink v + shrink (TailPort v) = map TailPort $ shrink v + shrink (TailTarget v) = map TailTarget $ shrinkString v + shrink (TailTooltip v) = map TailTooltip $ shrinkString v + shrink (Target v) = map Target $ shrinkString v + shrink (Tooltip v) = map Tooltip $ shrinkString v + shrink (TrueColor v) = map TrueColor $ shrink v + shrink (Vertices v) = map Vertices $ nonEmptyShrinks v + shrink (ViewPort v) = map ViewPort $ shrink v + shrink (VoroMargin v) = map VoroMargin $ shrink v + shrink (Weight v) = map Weight $ shrink v + shrink (Width v) = map Width $ shrink v + shrink (Z v) = map Z $ shrink v + shrink (UnknownAttribute a v) = liftM2 UnknownAttribute (liftM (filter validUnknown) shrinkString a) (shrinkString v) + +validUnknown :: String -> Bool +validUnknown "Damping" = False +validUnknown "K" = False +validUnknown "URL" = False +validUnknown "href" = False +validUnknown "arrowhead" = False +validUnknown "arrowsize" = False +validUnknown "arrowtail" = False +validUnknown "aspect" = False +validUnknown "bb" = False +validUnknown "bgcolor" = False +validUnknown "center" = False +validUnknown "charset" = False +validUnknown "clusterrank" = False +validUnknown "colorscheme" = False +validUnknown "color" = False +validUnknown "comment" = False +validUnknown "compound" = False +validUnknown "concentrate" = False +validUnknown "constraint" = False +validUnknown "decorate" = False +validUnknown "defaultdist" = False +validUnknown "dimen" = False +validUnknown "dim" = False +validUnknown "dir" = False +validUnknown "diredgeconstraints" = False +validUnknown "distortion" = False +validUnknown "dpi" = False +validUnknown "resolution" = False +validUnknown "edgeURL" = False +validUnknown "edgehref" = False +validUnknown "edgetarget" = False +validUnknown "edgetooltip" = False +validUnknown "epsilon" = False +validUnknown "esep" = False +validUnknown "fillcolor" = False +validUnknown "fixedsize" = False +validUnknown "fontcolor" = False +validUnknown "fontname" = False +validUnknown "fontnames" = False +validUnknown "fontpath" = False +validUnknown "fontsize" = False +validUnknown "group" = False +validUnknown "headURL" = False +validUnknown "headhref" = False +validUnknown "headclip" = False +validUnknown "headlabel" = False +validUnknown "headport" = False +validUnknown "headtarget" = False +validUnknown "headtooltip" = False +validUnknown "height" = False +validUnknown "id" = False +validUnknown "image" = False +validUnknown "imagescale" = False +validUnknown "labelURL" = False +validUnknown "labelhref" = False +validUnknown "labelangle" = False +validUnknown "labeldistance" = False +validUnknown "labelfloat" = False +validUnknown "labelfontcolor" = False +validUnknown "labelfontname" = False +validUnknown "labelfontsize" = False +validUnknown "labeljust" = False +validUnknown "labelloc" = False +validUnknown "labeltarget" = False +validUnknown "labeltooltip" = False +validUnknown "label" = False +validUnknown "landscape" = False +validUnknown "layersep" = False +validUnknown "layers" = False +validUnknown "layer" = False +validUnknown "layout" = False +validUnknown "len" = False +validUnknown "levelsgap" = False +validUnknown "levels" = False +validUnknown "lhead" = False +validUnknown "lp" = False +validUnknown "ltail" = False +validUnknown "margin" = False +validUnknown "maxiter" = False +validUnknown "mclimit" = False +validUnknown "mindist" = False +validUnknown "minlen" = False +validUnknown "model" = False +validUnknown "mode" = False +validUnknown "mosek" = False +validUnknown "nodesep" = False +validUnknown "nojustify" = False +validUnknown "normalize" = False +validUnknown "nslimit1" = False +validUnknown "nslimit" = False +validUnknown "ordering" = False +validUnknown "orientation" = False +validUnknown "outputorder" = False +validUnknown "overlap_scaling" = False +validUnknown "overlap" = False +validUnknown "packmode" = False +validUnknown "pack" = False +validUnknown "pad" = False +validUnknown "pagedir" = False +validUnknown "page" = False +validUnknown "pencolor" = False +validUnknown "penwidth" = False +validUnknown "peripheries" = False +validUnknown "pin" = False +validUnknown "pos" = False +validUnknown "quadtree" = False +validUnknown "quantum" = False +validUnknown "rankdir" = False +validUnknown "ranksep" = False +validUnknown "rank" = False +validUnknown "ratio" = False +validUnknown "rects" = False +validUnknown "regular" = False +validUnknown "remincross" = False +validUnknown "repulsiveforce" = False +validUnknown "root" = False +validUnknown "rotate" = False +validUnknown "samehead" = False +validUnknown "sametail" = False +validUnknown "samplepoints" = False +validUnknown "searchsize" = False +validUnknown "sep" = False +validUnknown "shapefile" = False +validUnknown "shape" = False +validUnknown "showboxes" = False +validUnknown "sides" = False +validUnknown "size" = False +validUnknown "skew" = False +validUnknown "smoothing" = False +validUnknown "sortv" = False +validUnknown "splines" = False +validUnknown "start" = False +validUnknown "stylesheet" = False +validUnknown "style" = False +validUnknown "tailURL" = False +validUnknown "tailhref" = False +validUnknown "tailclip" = False +validUnknown "taillabel" = False +validUnknown "tailport" = False +validUnknown "tailtarget" = False +validUnknown "tailtooltip" = False +validUnknown "target" = False +validUnknown "tooltip" = False +validUnknown "truecolor" = False +validUnknown "vertices" = False +validUnknown "viewport" = False +validUnknown "voro_margin" = False +validUnknown "weight" = False +validUnknown "width" = False +validUnknown "z" = False +validUnknown _ = True {- delete to here -} instance Arbitrary Word8 where arbitrary = arbitraryBoundedIntegral shrink = shrinkIntegral -instance Arbitrary URL where - arbitrary = liftM UStr - $ suchThat arbString (not . null) - - shrink (UStr ustr) = map UStr $ nonEmptyShrinks ustr +instance Arbitrary Word16 where + arbitrary = arbitraryBoundedIntegral + shrink = shrinkIntegral instance Arbitrary ArrowType where arbitrary = liftM AType -- Arrow specifications have between 1 and 4 elements. - $ resize 4 arbList + $ sized (\ s -> resize (min s 4) arbList) shrink (AType as) = map AType $ nonEmptyShrinks as @@ -531,12 +684,39 @@ instance Arbitrary Label where arbitrary = oneof [ liftM StrLabel arbString - , liftM URLLabel arbitrary + , liftM HtmlLabel arbitrary + , liftM RecordLabel $ suchThat arbList notStr ] - shrink (StrLabel str) = map StrLabel $ shrinkString str - shrink (URLLabel url) = map URLLabel $ shrink url + shrink (StrLabel str) = map StrLabel $ shrinkString str + shrink (HtmlLabel html) = map HtmlLabel $ shrink html + shrink (RecordLabel fs) = map RecordLabel . filter notStr $ shrinkList fs +notStr :: RecordFields -> Bool +notStr [FieldLabel{}] = False -- Just in case +notStr _ = True + +arbField :: Bool -> Int -> Gen RecordField +arbField b s = resize s' + . oneof + . bool id ((:) genFlipped) b + $ [ liftM2 LabelledTarget arbitrary arbString + , liftM PortName arbitrary + , liftM FieldLabel arbString + ] + where + genFlipped = liftM FlipFields + $ listOf1 (sized $ arbField False) + s' = min 3 s + +instance Arbitrary RecordField where + arbitrary = sized (arbField True) + + shrink (LabelledTarget f l) = [PortName f, FieldLabel l] + shrink (PortName f) = map PortName $ shrink f + shrink (FieldLabel l) = map FieldLabel $ shrinkString l + shrink (FlipFields fs) = map FlipFields $ shrinkList fs + instance Arbitrary Overlap where arbitrary = oneof [ simpleOverlap , liftM PrismOverlap arbitrary @@ -616,7 +796,6 @@ -- is just a point... , liftM SplinePos $ suchThat arbList validSplineList ] - where shrink (PointPos p) = map PointPos $ shrink p shrink (SplinePos ss) = map SplinePos . filter validSplineList @@ -720,8 +899,13 @@ ] instance Arbitrary PortPos where - arbitrary = liftM PP arbitrary + arbitrary = oneof [ liftM2 LabelledPort arbitrary arbitrary + , liftM CompassPoint arbitrary + ] + shrink (LabelledPort pn mc) = map (flip LabelledPort mc) $ shrink pn + shrink _ = [] + instance Arbitrary CompassPoint where arbitrary = arbBounded @@ -810,6 +994,160 @@ instance Arbitrary X11Color where arbitrary = arbBounded +instance Arbitrary HtmlLabel where + arbitrary = sized $ arbHtml True + + shrink ht@(HtmlText txts) = delete ht . map HtmlText $ shrinkL txts + shrink (HtmlTable tbl) = map HtmlTable $ shrink tbl + +-- Note: for the most part, HtmlLabel values are very repetitive (and +-- furthermore, they end up chewing a large amount of memory). As +-- such, use resize to limit how large the actual HtmlLabel values +-- become. +arbHtml :: Bool -> Int -> Gen HtmlLabel +arbHtml table s = resize' $ frequency options + where + s' = min 2 s + resize' = if not table + then resize s' + else id + allowTable = if table + then (:) (1, arbTbl) + else id + arbTbl = liftM HtmlTable arbitrary + options = allowTable [ (20, liftM HtmlText . sized $ arbHtmlTexts table) ] + +arbHtmlTexts :: Bool -> Int -> Gen HtmlText +arbHtmlTexts fnt s = liftM simplifyHtmlText + . resize s' + . listOf1 + . sized + $ arbHtmlText fnt + where + s' = min s 10 + +-- When parsing, all textual characters are parsed together; thus, +-- make sure we generate them like that. +simplifyHtmlText :: HtmlText -> HtmlText +simplifyHtmlText = map head . groupBy sameType + where + sameType HtmlStr{} HtmlStr{} = True + sameType HtmlNewline{} HtmlNewline{} = True + sameType HtmlFont{} HtmlFont{} = True + sameType _ _ = False + +instance Arbitrary HtmlTextItem where + arbitrary = sized $ arbHtmlText True + + shrink (HtmlStr str) = map HtmlStr $ shrinkString str + shrink (HtmlNewline as) = map HtmlNewline $ shrink as + shrink hf@(HtmlFont as txt) = do as' <- shrink as + txt' <- shrinkL txt + returnCheck hf $ HtmlFont as' txt' + +arbHtmlText :: Bool -> Int -> Gen HtmlTextItem +arbHtmlText font s = frequency options + where + allowFonts = if font + then (:) (1, arbFont) + else id + s' = min 2 s + arbFont = liftM2 HtmlFont arbitrary . resize s' . sized $ arbHtmlTexts False + options = allowFonts [ (10, liftM HtmlStr arbString) + , (10, liftM HtmlNewline arbitrary) + ] + +instance Arbitrary HtmlTable where + arbitrary = liftM3 HTable arbitrary arbitrary (sized arbRows) + where + arbRows s = resize (min s 10) arbList + + shrink (HTable fas as rs) = map (HTable fas as) $ shrinkL rs + +instance Arbitrary HtmlRow where + arbitrary = liftM HtmlRow arbList + + shrink hr@(HtmlRow cs) = delete hr . map HtmlRow $ shrinkL cs + +instance Arbitrary HtmlCell where + arbitrary = oneof [ liftM2 HtmlLabelCell arbitrary . sized $ arbHtml False + , liftM2 HtmlImgCell arbitrary arbitrary + ] + + shrink lc@(HtmlLabelCell as h) = do as' <- shrink as + h' <- shrink h + returnCheck lc $ HtmlLabelCell as' h' + shrink (HtmlImgCell as ic) = map (HtmlImgCell as) $ shrink ic + +instance Arbitrary HtmlImg where + arbitrary = liftM HtmlImg arbitrary + +instance Arbitrary HtmlAttribute where + arbitrary = oneof [ liftM HtmlAlign arbitrary + , liftM HtmlBAlign arbitrary + , liftM HtmlBGColor arbitrary + , liftM HtmlBorder arbitrary + , liftM HtmlCellBorder arbitrary + , liftM HtmlCellPadding arbitrary + , liftM HtmlCellSpacing arbitrary + , liftM HtmlColor arbitrary + , liftM HtmlColSpan arbitrary + , liftM HtmlFace arbString + , liftM HtmlFixedSize arbitrary + , liftM HtmlHeight arbitrary + , liftM HtmlHRef arbString + , liftM HtmlPointSize arbitrary + , liftM HtmlPort arbitrary + , liftM HtmlRowSpan arbitrary + , liftM HtmlScale arbitrary + , liftM HtmlSrc arbString + , liftM HtmlTarget arbString + , liftM HtmlTitle arbString + , liftM HtmlVAlign arbitrary + , liftM HtmlWidth arbitrary + ] + + shrink (HtmlAlign v) = map HtmlAlign $ shrink v + shrink (HtmlBAlign v) = map HtmlBAlign $ shrink v + shrink (HtmlBGColor v) = map HtmlBGColor $ shrink v + shrink (HtmlBorder v) = map HtmlBorder $ shrink v + shrink (HtmlCellBorder v) = map HtmlCellBorder $ shrink v + shrink (HtmlCellPadding v) = map HtmlCellPadding $ shrink v + shrink (HtmlCellSpacing v) = map HtmlCellSpacing $ shrink v + shrink (HtmlColor v) = map HtmlColor $ shrink v + shrink (HtmlColSpan v) = map HtmlColSpan $ shrink v + shrink (HtmlFace v) = map HtmlFace $ shrink v + shrink (HtmlFixedSize v) = map HtmlFixedSize $ shrink v + shrink (HtmlHeight v) = map HtmlHeight $ shrink v + shrink (HtmlHRef v) = map HtmlHRef $ shrink v + shrink (HtmlPointSize v) = map HtmlPointSize $ shrink v + shrink (HtmlPort v) = map HtmlPort $ shrink v + shrink (HtmlRowSpan v) = map HtmlRowSpan $ shrink v + shrink (HtmlScale v) = map HtmlScale $ shrink v + shrink (HtmlSrc v) = map HtmlSrc $ shrink v + shrink (HtmlTarget v) = map HtmlTarget $ shrink v + shrink (HtmlTitle v) = map HtmlTitle $ shrink v + shrink (HtmlVAlign v) = map HtmlVAlign $ shrink v + shrink (HtmlWidth v) = map HtmlWidth $ shrink v + +instance Arbitrary HtmlScale where + arbitrary = arbBounded + +instance Arbitrary HtmlAlign where + arbitrary = arbBounded + +instance Arbitrary HtmlVAlign where + arbitrary = arbBounded + +instance Arbitrary PortName where + arbitrary = liftM PN . flip suchThat (liftM2 (&&) (not . null) notCP) + $ liftM (filter (/= ':')) arbString + + shrink = map PN . filter notCP . shrinkString . portName + +notCP :: String -> Bool +notCP = flip Map.notMember compassLookup + -- ----------------------------------------------------------------------------- -- Helper Functions @@ -820,11 +1158,19 @@ posArbitrary = liftM fromPositive arbitrary arbString :: Gen String -arbString = suchThat (liftM (map toLower) genStr) validString +arbString = suchThat genStr validString where genStr = listOf1 $ elements strChr - strChr = ['a'..'z'] ++ ['0'..'9'] ++ ['\'', '"', ' ', '\t', '(', ')' + strChr = ['a'..'z'] ++ ['0'..'9'] ++ ['\'', '"', ' ', '(', ')' , ',', ':', '.'] + +arbIDString :: Gen String +arbIDString = suchThat genStr validString + where + genStr = liftM2 (:) (elements frst) $ listOf (elements rest) + frst = ['a'..'z'] ++ ['_'] + rest = frst ++ ['0'.. '9'] + validString :: String -> Bool validString "true" = False validString "false" = False diff --git a/Data/GraphViz/Testing/Instances/FGL.hs b/Data/GraphViz/Testing/Instances/FGL.hs --- a/Data/GraphViz/Testing/Instances/FGL.hs +++ b/Data/GraphViz/Testing/Instances/FGL.hs @@ -18,9 +18,11 @@ import Test.QuickCheck -import Data.GraphViz.Util(uniq, uniqBy) +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) -- ----------------------------------------------------------------------------- @@ -30,7 +32,8 @@ arbitrary = do ns <- suchThat genNs (not . null) let nGen = elements ns lns <- mapM makeLNode ns - les <- liftM (uniqBy toE) . listOf $ makeLEdge nGen + les <- liftM (sortBy (compare `on` toE)) . listOf + $ makeLEdge nGen return $ mkGraph lns les where genNs = liftM uniq arbitrary @@ -38,4 +41,7 @@ makeLNode n = liftM ((,) n) arbitrary makeLEdge nGen = liftM3 (,,) nGen nGen arbitrary - shrink gr = map (flip delNode gr) (nodes gr) + shrink gr = case nodes gr of + -- Need to have at least 2 nodes before we delete one! + ns@(_:_:_) -> map (flip delNode gr) ns + _ -> [] diff --git a/Data/GraphViz/Testing/Properties.hs b/Data/GraphViz/Testing/Properties.hs --- a/Data/GraphViz/Testing/Properties.hs +++ b/Data/GraphViz/Testing/Properties.hs @@ -13,11 +13,14 @@ import Data.GraphViz.Types(DotRepr, DotGraph, printDotGraph) import Data.GraphViz.Types.Generalised(generaliseDotGraph) import Data.GraphViz.Printing(PrintDot(..), printIt) -import Data.GraphViz.Parsing(ParseDot(..), parseIt, preProcess) +import Data.GraphViz.Parsing(ParseDot(..), parseIt, parseIt') +import Data.GraphViz.PreProcessing(preProcess) +import Data.GraphViz.Util(groupSortBy, isSingle) import Test.QuickCheck -import Data.Graph.Inductive(DynGraph, equal, nmap, emap) +import Data.Graph.Inductive(DynGraph, equal, nmap, emap, labEdges) +import Data.List(nub) -- ----------------------------------------------------------------------------- -- The properties to test for @@ -25,7 +28,7 @@ -- | Checking that @parse . print == id@; that is, graphviz can parse -- its own output. prop_printParseID :: (ParseDot a, PrintDot a, Eq a) => a -> Bool -prop_printParseID a = fst (tryParse a) == a +prop_printParseID a = tryParse' a == a -- | A version of 'prop_printParse' specifically for lists; it ensures -- that the list is not empty (as most list-based parsers fail on @@ -52,7 +55,7 @@ -- pretty-printed output of 'prettyPrint'' rather than just 'printIt'. prop_parsePrettyID :: (DotRepr dg n, Eq (dg n), ParseDot (dg n)) => dg n -> Bool -prop_parsePrettyID dg = (fst . parseIt . prettyPrint') dg == dg +prop_parsePrettyID dg = (parseIt' . prettyPrint') dg == dg -- | This property verifies that 'dotizeGraph'', etc. only /augment/ the -- original graph; that is, the actual nodes, edges and labels for @@ -66,6 +69,19 @@ g' = dotizeGraph' g unAugment = nmap snd . emap snd +-- | When a graph with multiple edges is augmented, then all edges +-- 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 g = all uniqLs lss + where + g' = dotizeGraph' g + les = map (\(f,t,l) -> ((f,t),l)) $ labEdges g' + lss = map (map snd) . filter (not . isSingle) + $ groupSortBy fst les + uniqLs ls = ls == nub ls + -- ----------------------------------------------------------------------------- -- Helper utility functions @@ -75,3 +91,8 @@ -- enter and explicit type signature. tryParse :: (ParseDot a, PrintDot a) => a -> (a, String) tryParse = parseIt . printIt + +-- | Equivalent to 'tryParse' except that it is assumed that the +-- entire 'String' *is* fully consumed. +tryParse' :: (ParseDot a, PrintDot a) => a -> a +tryParse' = parseIt' . printIt diff --git a/Data/GraphViz/Types.hs b/Data/GraphViz/Types.hs --- a/Data/GraphViz/Types.hs +++ b/Data/GraphViz/Types.hs @@ -55,15 +55,13 @@ to @n2@ and from @n2@ to @n3@). These types of edge definitions are parseable; however, they are converted to singleton edges. - * Cannot create edges with subgraphs\/clusters as one of the - end points. + * It is not yet possible to create or parse edges with + subgraphs\/clusters as one of the end points. * When either creating a 'DotGraph' by hand or parsing one, it is possible to specify that @'directedGraph' = d@, but 'DotEdge' values with @'directedEdge' = 'not' d@. - * Nodes cannot have Port values. - * Cannot place items in an arbitrary order: in particular, this means that it is not possible to use the normal Graphviz hack of having graph attributes that do not apply to subgraphs\/clusters by @@ -71,10 +69,19 @@ to use an arbitrary ordering, you may wish to use "Data.GraphViz.Types.Generalised". - * The parser will strip out comments and convert multiline strings - into a single line string. Pre-processor lines (i.e. those - started by @#@) and string concatenation are not yet supported. + * The parser will strip out comments and pre-processor lines, join + together multiline statements and concatenate split strings together. + However, pre-processing within HTML-like labels is currently not + supported. + * Graphviz allows a node to be \"defined\" twice (e.g. the actual + node definition, and then in a subgraph with extra global attributes + applied to it). This actually represents the same node, but when + parsing they will be considered as separate 'DotNode's (such that + 'graphNodes' will return both \"definitions\"). The canonical form + (see @prettyPrint@ in "Data.GraphViz") combines the \"definitions\" + into one. + See "Data.GraphViz.Attributes" for more limitations. -} @@ -91,18 +98,21 @@ , isValidGraph , graphErrors -- * Sub-components of a @DotGraph@. - , GraphID(..) + , GraphID(..) -- Re-exported from Data.GraphViz.Types.Common , DotStatements(..) , GlobalAttributes(..) , DotSubGraph(..) , DotNode(..) - , DotEdge(..) + , DotEdge(..) -- Re-exported from Data.GraphViz.Types.Common ) where import Data.GraphViz.Types.Common -import Data.GraphViz.Attributes +import Data.GraphViz.Attributes( Attributes, Attribute + , usedByGraphs, usedByClusters, usedBySubGraphs + , usedByNodes, usedByEdges) import Data.GraphViz.Util import Data.GraphViz.Parsing +import Data.GraphViz.PreProcessing import Data.GraphViz.Printing import Control.Monad(liftM) @@ -265,7 +275,8 @@ deriving (Eq, Ord, Show, Read) instance PrintDot GlobalAttributes where - unqtDot = printAttrBased printGlobAttrType attrs + -- Can't use printAttrBased because an empty list still must be printed. + unqtDot ga = printGlobAttrType ga <+> toDot (attrs ga) <> semi unqtListToDot = printAttrBasedList printGlobAttrType attrs @@ -277,16 +288,20 @@ printGlobAttrType EdgeAttrs{} = text "edge" instance ParseDot GlobalAttributes where - parseUnqt = parseAttrBased parseGlobAttrType + -- Not using parseAttrBased here because we want to force usage of + -- Attributes. + parseUnqt = do gat <- parseGlobAttrType + as <- whitespace' >> parse + return $ gat as `onFail` - liftM determineType parse `discard` optional lineEnd + liftM determineType parse parse = parseUnqt -- Don't want the option of quoting `adjustErr` (++ "\n\nNot a valid listing of global attributes") -- Have to do this manually because of the special case - parseUnqtList = sepBy (whitespace' >> parse) newline' + parseUnqtList = parseStatements parse parseList = parseUnqtList @@ -333,12 +348,15 @@ instance (ParseDot a) => ParseDot (DotSubGraph a) where parseUnqt = parseStmtBased parseUnqt (parseSubGraphID DotSG) + `onFail` + -- Take "anonymous" DotSubGraphs into account. + liftM (DotSG False Nothing) (parseBracesBased parseUnqt) parse = parseUnqt -- Don't want the option of quoting `adjustErr` (++ "\n\nNot a valid Sub Graph") - parseUnqtList = parseStmtBasedList parseUnqt (parseSubGraphID DotSG) + parseUnqtList = sepBy (whitespace' >> parseUnqt) newline' parseList = parseUnqtList @@ -384,7 +402,15 @@ parseList = parseUnqtList parseNodeID :: (ParseDot a) => Parse (Attributes -> DotNode a) -parseNodeID = liftM DotNode parse +parseNodeID = liftM DotNode parseAndCheck + where + parseAndCheck = do a <- parse + me <- optional parseUnwanted + maybe (return a) (const notANode) me + notANode = fail "This appears to be an edge, not a node" + parseUnwanted = oneOf [ parseEdgeType >> return () + , character ':' >> return () -- PortPos value + ] instance Functor DotNode where fmap f n = n { nodeID = f $ nodeID n } @@ -395,117 +421,11 @@ -- ----------------------------------------------------------------------------- --- | An edge in 'DotGraph'. -data DotEdge a = DotEdge { edgeFromNodeID :: a - , edgeToNodeID :: a - , directedEdge :: Bool - , edgeAttributes :: Attributes - } - deriving (Eq, Ord, Show, Read) - -instance (PrintDot a) => PrintDot (DotEdge a) where - unqtDot = printAttrBased printEdgeID edgeAttributes - - unqtListToDot = printAttrBasedList printEdgeID edgeAttributes - - listToDot = unqtListToDot - -printEdgeID :: (PrintDot a) => DotEdge a -> DotCode -printEdgeID e = unqtDot (edgeFromNodeID e) - <+> bool undirEdge' dirEdge' (directedEdge e) - <+> unqtDot (edgeToNodeID e) - - -instance (ParseDot a) => ParseDot (DotEdge a) where - parseUnqt = parseAttrBased 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 - $ sepBy (whitespace' >> parseEdgeLine) newline' - - parseList = parseUnqtList - -parseEdgeID :: (ParseDot a) => Parse (Attributes -> DotEdge a) -parseEdgeID = do eHead <- parse - whitespace' - eType <- parseEdgeType - whitespace' - eTail <- parse - return $ DotEdge eHead eTail eType - -parseEdgeType :: Parse Bool -parseEdgeType = stringRep True dirEdge - `onFail` - stringRep False undirEdge - -parseEdgeLine :: (ParseDot a) => Parse [DotEdge a] -parseEdgeLine = liftM return parse - `onFail` - do n1 <- parse - ens <- many1 $ do whitespace' - eType <- parseEdgeType - whitespace' - n <- parse - return (eType, n) - let ens' = (True, n1) : ens - efs = zipWith mkEdg ens' (tail ens') - ef = return $ \ as -> map ($as) efs - parseAttrBased ef - where - mkEdg (_, hn) (et, tn) = DotEdge hn tn et - -instance Functor DotEdge where - fmap f e = e { edgeFromNodeID = f $ edgeFromNodeID e - , edgeToNodeID = f $ edgeToNodeID e - } - -dirEdge :: String -dirEdge = "->" - -dirEdge' :: DotCode -dirEdge' = text dirEdge - -undirEdge :: String -undirEdge = "--" - -undirEdge' :: DotCode -undirEdge' = text undirEdge +-- Defined here rather than in Common with the rest of the Edge stuff +-- because all the DotError stuff is here. invalidEdge :: DotEdge a -> [DotError a] invalidEdge e = map (EdgeError eID) $ filter (not . usedByEdges) (edgeAttributes e) where eID = Just (edgeFromNodeID e, edgeToNodeID e) - --- ----------------------------------------------------------------------------- - --- Printing and parsing helpers. - -printAttrBased :: (a -> DotCode) -> (a -> Attributes) -> a -> DotCode -printAttrBased ff fas a = dc <> semi - where - f = ff a - dc = case fas a of - [] -> f - as -> f <+> toDot as - -printAttrBasedList :: (a -> DotCode) -> (a -> Attributes) - -> [a] -> DotCode -printAttrBasedList ff fas = vcat . map (printAttrBased ff fas) - -parseAttrBased :: Parse (Attributes -> a) -> Parse a -parseAttrBased p = do f <- p - whitespace' - atts <- tryParseList - lineEnd - return $ f atts - `adjustErr` - (++ "\n\nNot a valid attribute-based structure") - -parseAttrBasedList :: Parse (Attributes -> a) -> Parse [a] -parseAttrBasedList p = sepBy (whitespace' >> parseAttrBased p) newline' - -lineEnd :: Parse () -lineEnd = whitespace' >> character ';' >> return () diff --git a/Data/GraphViz/Types/Common.hs b/Data/GraphViz/Types/Common.hs --- a/Data/GraphViz/Types/Common.hs +++ b/Data/GraphViz/Types/Common.hs @@ -15,10 +15,11 @@ import Data.GraphViz.Parsing import Data.GraphViz.Printing import Data.GraphViz.Util -import Data.GraphViz.Attributes(URL) +import Data.GraphViz.Attributes(Attributes, Attribute(HeadPort, TailPort)) +import Data.GraphViz.Attributes.Internal(PortPos, parseEdgeBasedPP) import Data.Maybe(isJust) -import Control.Monad(liftM, when) +import Control.Monad(liftM, liftM2, when) -- ----------------------------------------------------------------------------- -- This is re-exported by Data.GraphViz.Types @@ -30,26 +31,20 @@ data GraphID = Str String | Int Int | Dbl Double - | HTML URL deriving (Eq, Ord, Show, Read) instance PrintDot GraphID where unqtDot (Str str) = unqtDot str unqtDot (Int i) = unqtDot i unqtDot (Dbl d) = unqtDot d - unqtDot (HTML u) = unqtDot u toDot (Str str) = toDot str toDot gID = unqtDot gID instance ParseDot GraphID where - parseUnqt = liftM HTML parseUnqt - `onFail` - liftM stringNum parseUnqt + parseUnqt = liftM stringNum parseUnqt - parse = liftM HTML parse - `onFail` - liftM stringNum parse + parse = liftM stringNum parse `adjustErr` (++ "\nNot a valid GraphID") @@ -60,7 +55,116 @@ then Dbl $ toDouble str else Str str + -- ----------------------------------------------------------------------------- + +-- 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 a = DotEdge { edgeFromNodeID :: a + , edgeToNodeID :: a + , directedEdge :: Bool + , edgeAttributes :: Attributes + } + deriving (Eq, Ord, Show, Read) + +instance (PrintDot a) => PrintDot (DotEdge a) where + unqtDot = printAttrBased printEdgeID edgeAttributes + + unqtListToDot = printAttrBasedList printEdgeID edgeAttributes + + listToDot = unqtListToDot + +printEdgeID :: (PrintDot a) => DotEdge a -> DotCode +printEdgeID e = toDot (edgeFromNodeID e) + <+> bool undirEdge' dirEdge' (directedEdge e) + <+> toDot (edgeToNodeID e) + + +instance (ParseDot a) => ParseDot (DotEdge a) where + parseUnqt = parseAttrBased 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 a) => Parse (Attributes -> DotEdge a) +parseEdgeID = do eFrom <- parseEdgeNode + eType <- parseEdgeType + eTo <- parseEdgeNode + return $ mkEdge eFrom eType eTo + +type EdgeNode a = (a, Maybe PortPos) + +-- | Takes into account edge statements containing something like +-- @a -> \{b c\}@. +parseEdgeNodes :: (ParseDot a) => Parse [EdgeNode a] +parseEdgeNodes = parseBraced ( wrapWhitespace + -- Should really use sepBy1, but this will do. + $ parseStatements parseEdgeNode + ) + `onFail` + liftM return parseEdgeNode + +parseEdgeNode :: (ParseDot a) => Parse (EdgeNode a) +parseEdgeNode = liftM2 (,) parse + (optional $ character ':' >> parseEdgeBasedPP) + +mkEdge :: EdgeNode a -> Bool -> EdgeNode a + -> Attributes -> DotEdge a +mkEdge (eFrom, mFP) eDir (eTo, mTP) = DotEdge eFrom eTo eDir + . addPortPos TailPort mFP + . addPortPos HeadPort mTP + +mkEdges :: [EdgeNode a] -> Bool -> [EdgeNode a] + -> Attributes -> [DotEdge a] +mkEdges fs eDir ts as = liftM2 (\f t -> mkEdge f eDir 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 a) => Parse [DotEdge a] +parseEdgeLine = do n1 <- parseEdgeNodes + ens <- many1 $ do eType <- parseEdgeType + n <- parseEdgeNodes + return (eType, n) + let ens' = (True, n1) : ens + efs = zipWith mkEdg ens' (tail ens') + ef = return $ \ as -> concatMap ($as) efs + parseAttrBased ef + where + mkEdg (_, hn) (et, tn) = mkEdges hn et tn + +instance Functor DotEdge where + fmap f e = e { edgeFromNodeID = f $ edgeFromNodeID e + , edgeToNodeID = f $ edgeToNodeID e + } + +dirEdge :: String +dirEdge = "->" + +dirEdge' :: DotCode +dirEdge' = text dirEdge + +undirEdge :: String +undirEdge = "--" + +undirEdge' :: DotCode +undirEdge' = text undirEdge + +-- ----------------------------------------------------------------------------- -- Labels dirGraph :: String @@ -103,7 +207,8 @@ <+> maybe empty toDot (mID g) parseGraphID :: (Bool -> Bool -> Maybe GraphID -> a) -> Parse a -parseGraphID f = do str <- liftM isJust +parseGraphID f = do allWhitespace' + str <- liftM isJust $ optional (parseAndSpace $ string strGraph) dir <- parseAndSpace ( stringRep True dirGraph `onFail` @@ -123,9 +228,9 @@ parseStmtBased :: Parse stmt -> Parse (stmt -> a) -> Parse a parseStmtBased = flip apply . parseBracesBased -parseStmtBasedList :: Parse stmt -> Parse (stmt -> a) -> Parse [a] -parseStmtBasedList ps pr = sepBy (whitespace' >> parseStmtBased ps pr) newline' - +-- 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 [ h <+> lbrace , ind i @@ -135,14 +240,7 @@ ind = nest 4 parseBracesBased :: Parse a -> Parse a -parseBracesBased p = do whitespace' - character '{' - newline' - a <- p - newline' - whitespace' - character '}' - return a +parseBracesBased p = whitespace' >> parseBraced (wrapWhitespace p) `adjustErr` (++ "\nNot a valid value wrapped in braces.") @@ -178,7 +276,7 @@ where -- If it's a String value, check to see if it's actually a -- cluster_Blah value; thus need to manually re-parse it. - getClustFrom (Str str) = fst $ runParser pStr str + getClustFrom (Str str) = runParser' pStr str getClustFrom gid = (False, Just gid) checkCl = stringRep True clust @@ -196,9 +294,7 @@ -- For Strings, there are no more quotes to unescape, so consume -- what you can. - pID = liftM HTML parseUnqt - `onFail` - liftM stringNum (many next) + pID = liftM stringNum (many next) {- This is a much nicer definition, but unfortunately it doesn't work. The problem is that Graphviz decides that a subgraph is a cluster @@ -214,3 +310,41 @@ when (isCl || isJust sID) $ whitespace >> return () return (isCl, sID) -} + +printAttrBased :: (a -> DotCode) -> (a -> Attributes) -> a -> DotCode +printAttrBased ff fas a = dc <> semi + where + f = ff a + dc = case fas a of + [] -> f + as -> f <+> toDot as + +printAttrBasedList :: (a -> DotCode) -> (a -> Attributes) + -> [a] -> DotCode +printAttrBasedList ff fas = vcat . map (printAttrBased ff fas) + +parseAttrBased :: Parse (Attributes -> a) -> Parse a +parseAttrBased p = do f <- p + atts <- tryParseList' (whitespace' >> parse) + return $ f atts + `adjustErr` + (++ "\n\nNot a valid attribute-based structure") + +parseAttrBasedList :: Parse (Attributes -> a) -> Parse [a] +parseAttrBasedList = parseStatements . parseAttrBased + +-- | Parse the separator (and any other whitespace present) between statements. +statementEnd :: Parse () +statementEnd = parseSplit >> newline' + where + parseSplit = (whitespace' >> oneOf [ liftM return $ character ';' + , newline + ] + ) + `onFail` + whitespace + +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 @@ -36,7 +36,7 @@ , generaliseDotGraph ) where -import Data.GraphViz.Types hiding (GraphID(..)) +import Data.GraphViz.Types hiding (GraphID(..), DotEdge(..)) import Data.GraphViz.Types.Common import Data.GraphViz.Parsing import Data.GraphViz.Printing @@ -97,12 +97,10 @@ type GDotStatements a = Seq (GDotStatement a) printGStmts :: (PrintDot a) => GDotStatements a -> DotCode -printGStmts = vcat . map toDot . F.toList +printGStmts = toDot . F.toList parseGStmts :: (ParseDot a) => Parse (GDotStatements a) -parseGStmts = liftM Seq.fromList $ many p - where - p = whitespace' >> parse `discard` newline' +parseGStmts = liftM Seq.fromList parse statementNodes :: GDotStatements a -> [DotNode a] statementNodes = concatMap stmtNodes . F.toList @@ -131,6 +129,10 @@ unqtDot (DN dn) = unqtDot dn unqtDot (DE de) = unqtDot de + unqtListToDot = vcat . map unqtDot + + listToDot = unqtListToDot + instance (ParseDot a) => ParseDot (GDotStatement a) where parseUnqt = oneOf [ liftM GA parseUnqt , liftM SG parseUnqt @@ -142,6 +144,17 @@ `adjustErr` (++ "Not a valid statement") + parseUnqtList = liftM concat . wrapWhitespace + $ parseStatements p + where + -- Have to do something special here because of "a -> b -> c" + -- syntax for edges. + p = liftM (map DE) parseEdgeLine + `onFail` + liftM return parse + + parseList = parseUnqtList + instance Functor GDotStatement where fmap _ (GA ga) = GA ga -- Have to re-make this to make the type checker happy. fmap f (SG sg) = SG $ fmap f sg @@ -178,12 +191,15 @@ instance (ParseDot a) => ParseDot (GDotSubGraph a) where parseUnqt = parseStmtBased parseGStmts (parseSubGraphID GDotSG) + `onFail` + -- Take anonymous GDotSubGraphs into account + liftM (GDotSG False Nothing) (parseBracesBased parseGStmts) parse = parseUnqt -- Don't want the option of quoting `adjustErr` (++ "\n\nNot a valid Sub Graph") - parseUnqtList = parseStmtBasedList parseGStmts (parseSubGraphID GDotSG) + parseUnqtList = sepBy (whitespace' >> parseUnqt) newline' parseList = parseUnqtList diff --git a/Data/GraphViz/Util.hs b/Data/GraphViz/Util.hs --- a/Data/GraphViz/Util.hs +++ b/Data/GraphViz/Util.hs @@ -15,6 +15,7 @@ , isAsciiLower , isDigit , toLower + , ord ) import Data.List(groupBy, sortBy) @@ -22,7 +23,6 @@ import Data.Function(on) import qualified Data.Set as Set import Data.Set(Set) -import Control.Monad(liftM2) -- ----------------------------------------------------------------------------- @@ -36,7 +36,7 @@ frstIDString c = any ($c) [ isAsciiUpper , isAsciiLower , (==) '_' - , liftM2 (&&) (>= '\200') (<= '\377') + , (\ x -> ord x >= 128) ] -- | The rest of a non-quoted 'String' must match this. @@ -58,7 +58,7 @@ (_,'.':ds) -> checkEs $ dropWhile isDigit ds ([],_) -> False (_,ds) -> checkEs ds - checkEs' s = case break ((==) 'e') s of + checkEs' s = case break ('e' ==) s of ([], _) -> False (ds,es) -> all isDigit ds && checkEs es checkEs [] = True @@ -72,7 +72,7 @@ _ -> read $ adj str where adj s = (:) '0' - $ case span ((==) '.') (map toLower s) of + $ case span ('.' ==) (map toLower s) of (ds@(_:_), '.':[]) -> ds ++ '.' : '0' : [] (ds, '.':es@('e':_)) -> ds ++ '.' : '0' : es _ -> s @@ -124,10 +124,17 @@ uniq = uniqBy id uniqBy :: (Ord b) => (a -> b) -> [a] -> [a] -uniqBy f = map head . groupBy ((==) `on` f) . sortBy (compare `on` f) +uniqBy f = map head . groupSortBy f +groupSortBy :: (Ord b) => (a -> b) -> [a] -> [[a]] +groupSortBy f = groupBy ((==) `on` f) . sortBy (compare `on` f) + -- | Fold over 'Bool's; first param is for 'False', second for 'True'. bool :: a -> a -> Bool -> a bool f t b = if b then t else f + +isSingle :: [a] -> Bool +isSingle [_] = True +isSingle _ = False diff --git a/FAQ b/FAQ new file mode 100644 --- /dev/null +++ b/FAQ @@ -0,0 +1,635 @@ +% graphviz - 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: + +* Two different methods of specifying Dot graphs: + + 1. Strict, which matches the layout of `dot -Tcanon`. + 2. Liberal, which allows statements to be in any order. + + There are also conversion functions between the two of them. + +* 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]. + + [output formats]: http://www.graphviz.org/doc/info/output.html + +* Functions to convert [FGL] graphs to and from the internal Dot + representations. + + [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. + +### 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 +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_ is currently locale-specific: Dot graphs are meant to be + encoded in UTF-8 by default unless specified to be Latin-1, but this + isn't verified or checked. Dot code that is parsed in is assumed to + be in UTF-8; in future this will be enforced (both for printing and + parsing purposes). + +* 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; + however the optional `!` and third value for `point` values is not + accepted. + +* Only polygon-based `shape`s are available. + +* The default `layersep` is used when printing and parsing + `layerRange` and `layerList` values; this will be fixed in a future + release (when state-based printing and parsing is implemented). + +* The `/ssss/yyyy` and `//yyyy` forms of printing and prsing `color`s + are not yet available. + +#### 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. + +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` +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_? ### + +There will be soon. + +### 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? ### + +Unfortunately, no: the layout and design of _graphviz_ is heavily +based upon the Dot language and the various [attributes] that Graphviz +supports. As such, you can't just suffice on the documentation +available in _graphviz_ (unless you're doing something _very_ +simplistic). + +### 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 DotGraph and GDotGraph? ### + +The layout of `DotGraph` matches the output of `dot -Tcanon`. It has +a fixed layout which makes it easier to reason about and get +sub-components. + +`GDotGraph` on the other hand is more liberal in its layout, allowing +you to put statements in any order you please. This is 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. + +### 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 following attributes are easy to use and recommended: + +* `ArrowHead` and `ArrowTail` (for directed graphs) to set the styles + of the ends of edges: note that in Graphviz parlance, "Head" refers + to the end node and "Tail" refers to the start node of the edge (see + below). + +* When wanting to use different colours, use the following criteria to + pick the correct attribute. Note: for the first two, you should + also have `SItem Filled []` set as one of the `Style` values for + that item. + + - `BgColor` to set the background colour of a graph/cluster. + + - `FillColor` to set the background colour for a node. + + - `Color` to set the colour of an edge; if you supply more than + one value then the edge is drawn using parallel splines/lines + (one per colour in the list). + + - `PenColor` to set the colour of the bounding box for a cluster. + + When choosing a `Color` value for one of the above, it is better to + use one of the `X11Color` values (note: these are **not** the same + as the standard X11 colours) or - if you have to - one of the manual + colours over a `BrewerColor`, as they come under a different license + and have no real standard on what the values are. + +* `Label`: `StrLabel` can be used for both nodes and edges; the other + two only for nodes. `RecordLabel` and `HtmlLabel` provide ways of + having more fine-grained control over a node's layout with different + sub-components, etc.; in most cases these won't be needed. + +* `Rank`: this lets you control relative placement of sub-graphs and + clusters. + +* `Shape`: Use `Record` and `MRecord` for `RecordLabel` labels; feel + free to use any other ones at any time (though you probably want to + use `PlainText` for `HtmlLabel` labels). + +* `Style`: use this to set line types, etc. for nodes and edges. You + should **not** use a `DD` (device-dependent) value. + +The following attributes are **not** recommended for use: + +* `Charset`: the only accepted options are `"UTF-8"` and `"Latin-1"`, + but in future _graphviz_ will not contain this attribute and will + only allow UTF-8 usage. + +* `Color` for anything except edge colours. + +* `ColorScheme`: just stick with X11 colours. + +* `Comment`: pretty useless, but will interfere with the augmentation + functions (since they use the `Comment` attribute to distinguish + between multiple edges). + +### 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 in Graphviz or _graphviz_) to determine which is +suitable where. + +### How can I use _graphviz_ to visualise non-FGL graphs? ### + +At the moment, you unfortunately have to write your own manual +conversion functions (see `graphToDot`, etc. in the GraphViz module +for ideas on how to do this). In future, it should be possible to +convert any graph-like datatype into a `DotGraph` (this requires me to +go write another library first...). + +### 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 ':' + whitespace + 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 printing, especially with whitespace: + when printing only one space is used, yet when parsing we use the + `whitespace` 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). However, we're not being so + liberal as to allow parsing of newline characters (for which there + is a separate parsing combinator). + +### 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 +`HtmlLabel` 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) + ] +~~~~~~~~~~~~~~~~~~~~ + +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. + +* It is possible to specify a graph as being directed/undirected but + having individual edges being the opposite; care should be taken to + avoid this (this possible issue may be resolved in future). + +* 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 two different representations of Dot graphs? ### + +_graphviz_ has +[two different representations](#whats-the-difference-between-dotgraph-and-gdotgraph) +of Dot graphs. Apart from the reasons given before, `DotGraph` was +the original representation, whereas `GDotGraph` was only introduced +in the 2999.8.0.0 release. + +Note, however, that I was thinking of adding something like +`GDotGraph` 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). + +As such, `GDotGraph` is there if anyone needs/wants to use it, but +usage of `DotGraph` is recommended/preferred. + +### 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/ +~~~~~~~~~~~~~~~~~~~~ + +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/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,26 +1,39 @@ -The overall graphviz library is covered by this 3-Clause BSD license. -------------------------------------------------------------------- +% graphviz - License +% Ivan Lazar Miljenovic -Copyright (c) 2008-2009, Matthew Sackman - 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 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. + * 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. + * 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 @@ -34,12 +47,12 @@ (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 Color Schemes (see Data.GraphViz.Attributes.Colors) -are covered by the following license: -------------------------------------------------------------------- +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 @@ -85,3 +98,9 @@ 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 --- a/README +++ b/README @@ -1,19 +1,31 @@ -The graphviz library provides bindings for Haskell to the Dot language -used by the Graphviz [1] suite of tools for graph visualisation. The -latest version of this library is available from Hackage [2]. +% graphviz - Haskell bindings to the Graphviz toolkit +% Ivan Lazar Miljenovic -[1] http://graphviz.org/ -[2] http://hackage.haskell.org/package/graphviz +The graphviz Library +==================== -Features of the graphviz library include: +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: -* Almost complete coverage of all Graphviz attributes, etc. for - graphs, sub-graphs, clusters, nodes and edges: - http://graphviz.org/doc/info/attrs.html +~~~~~~~~~~~~~~~~~~~~ {.bash} +cabal update +cabal install graphviz +~~~~~~~~~~~~~~~~~~~~ -* Thorough documentation on known problems with the library and how it - differs from the actual Dot specification. +[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. @@ -24,52 +36,30 @@ * The ability to not only generate but also parse Dot code with two options: strict and liberal (in terms of ordering of statements). -* Functions to convert FGL graphs to Dot code - including support to +* Functions to convert [FGL] graphs to Dot code - including support to group them into clusters - with a high degree of customisation by - specifying which attributes to use. + specifying which attributes to use and limited support for the + inverse operation. -* Round-trip support for passing an FGL graph through Graphviz to +* Round-trip support for passing an [FGL] graph through Graphviz to augment node and edge labels with positional information, etc. -Please note that currently the convenience functions are only -available for FGL [3] graphs; this will be extended in future once a -method for dealing with generic graph types is developed. - -[3] http://web.engr.oregonstate.edu/~erwig/fgl/haskell/ - --------------------------------------------------------------------------------- - -Developing graphviz -------------------- - -Following are some notes on what to keep in mind if you want to -contribute to the development of graphviz: - -* When printing and parsing values, there are two options: with or - without quotes. Some values (e.g. numbers) may optionally be quoted - in Dot code; others (namely strings with spaces, etc.) _must_ be - quoted. +[FGL]: http://web.engr.oregonstate.edu/~erwig/fgl/haskell/ -* Whenever you are parsing a type of value where the Dot - representation of one is the prefix of the Dot representation of - another, be sure to parse the longer value first. +graphviz is free software licensed under a [3-Clause BSD License]. -* Because there are so many attributes, the definition, instances for - and functions using the overall Attribute type are all defined using - the AttributeGenerator.hs script. This file is not an actual part - of the library, but should be used if any top-level work is being - done for Attributes. +\(C\) 2008 [Matthew Sackman](http://www.wellquite.org/) -* Any changes should pass the testsuite, which is built by enabling - the "test" flag. There are three ways of testing: +\(C\) 2008 - 2010 [Ivan Lazar Miljenovic](http://ivanmiljenovic.wordpress.com/) - - Run the graphviz-testsuite program; this takes approximately 90 - minutes to run and covers various properties that should hold. +[3-Clause BSD License]: http://www.opensource.org/licenses/bsd-license.php - - Import the "Data.GraphViz.Testing" module for manual testing. +For more information, feel free to +[email](mailto:Ivan.Miljenovic+graphviz@gmail.com) me. - - If you did not build the library with the "test" flag enabled, you - can extract Data.GraphViz.Testing and Data.GraphViz.Testing.* from - the source tarball to be able to use them directly; they only use - graphviz's public API. + diff --git a/RunTests.hs b/RunTests.hs --- a/RunTests.hs +++ b/RunTests.hs @@ -10,7 +10,7 @@ -} module Main where -import Data.GraphViz.Testing +import Data.GraphViz.Testing(runDefaultTests) main :: IO () main = runDefaultTests diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -1,6 +1,53 @@ -Areas to work on: +% graphviz - TODO +% Ivan Lazar Miljenovic -* Utilise the generic graph class once it is finalised. +Future Plans for graphviz +========================= -* Encoding: Graphviz uses UTF-8 by default, Latin1 when set; should - graphviz use utf8-string and disable changing the encoding? +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). + +Short term +---------- + +* Make the parsers and printers state-based, which means they will be + better able to cope with `ColorScheme` and layers better. + +* Improve the printer and parser performance (to be done whilst making + them state-based). + +* Fix encoding problems: Graphviz uses UTF-8 by default, Latin1 when + set; to resolve ambiguities force usage of UTF-8 and remove the + option of Latin-1. To do so, will probably use the + [text](http://hackage.haskell.org/package/text) library (which will + hopefully also improve performance for the previous point). + +* Quickstart-style documentation to help users get going with graphviz + quickly. + +Medium term +----------- + +* Improve the test suite such that the generated `DotGraph` and + `GDotGraph` values are valid (and thus can be passed to Graphviz + proper). This will require the state-based printer and parser from + above to be implemented. + +* Add support for non-visualisation Graphviz tools (e.g. dijkstra and + tred). + +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/TestParsing.hs b/TestParsing.hs new file mode 100644 --- /dev/null +++ b/TestParsing.hs @@ -0,0 +1,94 @@ +#!/usr/bin/runhaskell + +{- | + Module : TestParsing + Description : Check if the graphviz parser can parse "real world" Dot code. + Copyright : (c) Ivan Lazar Miljenovic + License : 3-Clause BSD-style + Maintainer : Ivan.Miljenovic@gmail.com + + This module defines a program that determines if the provided files + containing Dot code can be properly parsed using graphviz's parsers + (with the assumption that the provided code is valid). + +-} +module Main where + +import Data.GraphViz +import Data.GraphViz.Types.Generalised +import Data.GraphViz.Parsing(runParser, parse, discard, allWhitespace', eof) +import Data.GraphViz.PreProcessing(preProcess) + +import Control.Exception(try, ErrorCall(..), IOException) +import Control.Monad(liftM) +import System.Environment(getArgs) +import System.IO(openFile, IOMode(ReadMode)) + +-- ----------------------------------------------------------------------------- + +main :: IO () +main = tryParsing =<< getArgs + where + tryParsing [] = putStrLn "Test that the graphviz library can parse\ + \ \"real life\" Dot code by passing a list\n\ + \of files in which contain Dot graphs.\n\ + \\n\ + \One way of using this file:\n\t\ + \$ locate -r \".*\\.\\(gv\\|dot\\)$\" -0\ + \ | xargs -0 runhaskell TestParsing.hs" + tryParsing fs = mapM_ tryParseFile fs + +-- ----------------------------------------------------------------------------- + + +withParse :: (DotRepr dg n) => (a -> IO String) -> (dg n -> IO ()) + -> (ErrMsg -> String) -> a -> IO () +withParse toStr withDG cmbErr a = do dc <- toStr a + edg <- tryParse dc + case edg of + (Right dg) -> withDG dg + (Left err) -> do putStrLn "Parsing problem!" + putStrLn $ cmbErr err + putStrLn "" + +type DG = DotGraph String +type GDG = GDotGraph String +type ErrMsg = String + +tryParseFile :: FilePath -> IO () +tryParseFile fp = readFile' fp >>= maybeParse + where + maybeParse (Left err) = putStrLn $ "Error parsing \"" ++ fp ++ "\":\n\t" + ++ err ++ "\n" + maybeParse (Right dot) = withParse (const $ return dot) + (tryParseCanon fp) + (\ e -> fp ++ ": Cannot parse as a GDotGraph:\n" + ++ e) + fp + + +tryParseCanon :: FilePath -> GDG -> IO () +tryParseCanon fp = withParse prettyPrint + (const (return ()) . asDG) + (\ e -> fp ++ ": Canonical Form not a DotGraph:\n" + ++ e) + where + asDG = flip asTypeOf emptDG + emptDG = DotGraph False False Nothing $ DotStmts [] [] [] [] :: DG + +tryParse :: (DotRepr dg n) => String -> IO (Either ErrMsg (dg n)) +tryParse dc = liftM getErrMsg . try + $ let (dg, rst) = runParser parse $ preProcess dc + in length rst `seq` return dg + +getErrMsg :: Either ErrorCall a -> Either ErrMsg a +getErrMsg = either getEC Right + where + getEC (ErrorCall e) = Left e + +readFile' :: FilePath -> IO (Either ErrMsg String) +readFile' fp = liftM getMsg . try + $ openFile fp ReadMode >>= hGetContents' + where + getMsg :: Either IOException String -> Either ErrMsg String + getMsg = either (Left . show) Right diff --git a/graphviz.cabal b/graphviz.cabal --- a/graphviz.cabal +++ b/graphviz.cabal @@ -1,20 +1,15 @@ Name: graphviz -Version: 2999.8.0.0 +Version: 2999.9.0.0 Stability: Beta Synopsis: Graphviz bindings for Haskell. Description: { This library provides bindings for the Dot language used by the Graphviz () suite of programs, as well as -functions to call the Grapvhiz programs. -. -Features of this library are: +functions to call those programs. . -* Almost complete coverage of all Graphviz attributes, etc. for - graphs, sub-graphs, clusters, nodes and edges: - +Main features of the graphviz library include: . -* Thorough documentation on known problems with the library and how it - differs from the actual Dot specification. +* Almost complete coverage of all Graphviz attributes and syntax. . * Support for specifying clusters. . @@ -28,24 +23,28 @@ . * Functions to convert FGL graphs to Dot code - including support to group them into clusters - with a high degree of customisation by - specifying which attributes to use. + 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. } +Homepage: http://projects.haskell.org/graphviz/ Category: Graphs, Graphics License: BSD3 License-File: LICENSE Copyright: Matthew Sackman, Ivan Lazar Miljenovic Author: Matthew Sackman, Ivan Lazar Miljenovic -Maintainer: Ivan.Miljenovic@gmail.com +Maintainer: Ivan.Miljenovic+graphviz@gmail.com Build-Type: Simple Cabal-Version: >= 1.6 Extra-Source-Files: TODO Changelog README + FAQ Data/GraphViz/AttributeGenerator.hs + TestParsing.hs Source-Repository head Type: darcs @@ -62,7 +61,7 @@ process, fgl, filepath, - polyparse >= 1.1, + polyparse >= 1.4, pretty, bytestring < 0.10, colour >= 2.3 && < 2.4 @@ -75,8 +74,11 @@ Data.GraphViz.Commands Data.GraphViz.Attributes Data.GraphViz.Attributes.Colors + Data.GraphViz.Attributes.HTML + Data.GraphViz.PreProcessing - Other-Modules: Data.GraphViz.Types.Clustering + Other-Modules: Data.GraphViz.Attributes.Internal + Data.GraphViz.Types.Clustering Data.GraphViz.Types.Common Data.GraphViz.Util if flag(test) @@ -88,7 +90,12 @@ Other-Modules: Data.GraphViz.Testing.Instances Data.GraphViz.Testing.Instances.FGL - Ghc-Options: -Wall + if True + Ghc-Options: -Wall + + if impl(ghc >= 6.12.1) + Ghc-Options: -fno-warn-unused-do-bind + Ghc-Prof-Options: -prof -auto-all } @@ -101,5 +108,11 @@ Main-Is: RunTests.hs - GHC-Options: -O2 + if True + Ghc-Options: -O2 + + if impl(ghc >= 6.12.1) + Ghc-Options: -fno-warn-unused-do-bind + + GHC-Prof-Options: -auto-all -caf-all }