graphviz 2999.17.0.2 → 2999.20.2.1
raw patch · 51 files changed
Files
- Changelog.md +155/−2
- Data/GraphViz.hs +23/−10
- Data/GraphViz/Algorithms.hs +21/−22
- Data/GraphViz/Attributes/Arrows.hs +5/−1
- Data/GraphViz/Attributes/Colors.hs +9/−6
- Data/GraphViz/Attributes/Complete.hs +15/−4
- Data/GraphViz/Attributes/HTML.hs +130/−51
- Data/GraphViz/Attributes/Internal.hs +5/−1
- Data/GraphViz/Attributes/Values.hs +12/−8
- Data/GraphViz/Commands.hs +2/−2
- Data/GraphViz/Commands/IO.hs +24/−72
- Data/GraphViz/Exception.hs +1/−2
- Data/GraphViz/Internal/State.hs +5/−9
- Data/GraphViz/Internal/Util.hs +21/−11
- Data/GraphViz/Parsing.hs +19/−3
- Data/GraphViz/PreProcessing.hs +11/−6
- Data/GraphViz/Printing.hs +75/−16
- Data/GraphViz/Types.hs +15/−16
- Data/GraphViz/Types/Canonical.hs +3/−3
- Data/GraphViz/Types/Generalised.hs +7/−9
- Data/GraphViz/Types/Graph.hs +57/−46
- Data/GraphViz/Types/Internal/Common.hs +14/−10
- Data/GraphViz/Types/Monadic.hs +76/−16
- Data/GraphViz/Types/State.hs +13/−13
- FAQ.md +13/−27
- LICENSE.md +0/−2
- README.md +0/−5
- Setup.hs +0/−4
- TODO.md +0/−2
- graphviz.cabal +41/−47
- tests/Data/GraphViz/AlgorithmsSpec.hs +37/−0
- tests/Data/GraphViz/Attributes/CompleteSpec.hs +26/−0
- tests/Data/GraphViz/Attributes/HTMLSpec.hs +26/−0
- tests/Data/GraphViz/PreProcessingSpec.hs +24/−0
- tests/Data/GraphViz/Testing.hs +0/−459
- tests/Data/GraphViz/Testing/Instances.hs +4/−5
- tests/Data/GraphViz/Testing/Instances/Attributes.hs +84/−40
- tests/Data/GraphViz/Testing/Instances/FGL.hs +0/−47
- tests/Data/GraphViz/Testing/Instances/Helpers.hs +1/−1
- tests/Data/GraphViz/Testing/Properties.hs +23/−22
- tests/Data/GraphViz/Testing/Proxy.hs +19/−0
- tests/Data/GraphViz/Types/CanonicalSpec.hs +44/−0
- tests/Data/GraphViz/Types/GeneralisedSpec.hs +41/−0
- tests/Data/GraphViz/Types/GraphSpec.hs +59/−0
- tests/Data/GraphVizSpec.hs +34/−0
- tests/Main.hs +23/−0
- tests/RunTests.hs +0/−83
- tests/Spec.hs +1/−0
- utils/AttributeGenerator.hs +2/−0
- utils/Benchmark.hs +4/−2
- utils/TestParsing.hs +23/−24
Changelog.md view
@@ -1,11 +1,164 @@-% Changelog-% Ivan Lazar Miljenovic Release History and Changelog ============================= The following is information about what major changes have gone into each release.++Changes in 2999.20.2.0+----------------------++* Metadata update.+* Relax QuickCheck upper boundary.++Changes in 2999.20.2.0+----------------------++* Add `PrintDot` instances for `Word32` and `Word64`.+* Dependency bumps.++Changes in 2999.20.1.0+----------------------++* Add `MonadFix` instance for `DotM` (thanks to **George Wilson**)++* Fix exception catching for missing executables (thanks to **Kostas+ Dermentzis**)++* Dependency bumps.++Changes in 2999.20.0.4+----------------------++* Dependency bumps.++Changes in 2999.20.0.3+----------------------++* Dependency bumps.++Changes in 2999.20.0.2+----------------------++* Fix Haddock issue (thanks to **Moritz Kiefer**)++* Bump HSpec upper bound (thanks to **Moritz Kiefer**)++* Make Hackage happier with Cabal-Version field++Changes in 2999.20.0.1+----------------------++* Allow building with temporary-1.3.*.++Changes in 2999.20.0.0+----------------------++* Can now create subgraphs using the Monadic representation.++* Allow unescaped `-` and `'` in HTML labels (thanks to **Andrey+ Kartashov**)++* Support for strict `Text` instances for printing/parsing.++* Creating a Graph representation with `mkGraph` was not adding edges+ correctly (reported by **Joshua Chia**).++* Test suite now uses HSpec, making it a lot easier to add tests for+ specific issues.++* Builds with GHC 8.4.* (thanks to **Tony Day**).++* Monoid and Semigroup instances for Monadic representation (thanks to+ **Chris Martin**).++* Be more lenient in parsing some attributes (e.g. allow `top` instead+ of just `t` for `VerticalPlacement`).++* Add new HTML attributes: `Columns`, `GradientAngle`, `Rows`, `Sides`+ and `Style`.++* Improve/update the TestParsing executable to work on being able to+ parse all the sample `Dot` graphs shipped with Graphviz.++* Bump dependencies.++Changes in 2999.19.0.0+----------------------++* Roll back change in 2999.18.1.0 for Monadic graphs, as they turn out+ to not actually work in practice (reported by **Lennart Spitzner**).++* Add a `quickParams` value to help with testing graphs in ghci+ (requested by **Ian Jeffries**).++* Fix parsing of edge chains (reported by **Jonas Collberg**).++* Fix how seemingly numeric text literals are quoted (reported by+ **Joey Hess**).++Changes in 2999.18.1.2+----------------------++* Allow dlist-0.8, thanks to **Sean Leather**.++* Properly allow QuickCheck-2.9.++Changes in 2999.18.1.1+----------------------++* Bump allowed version of QuickCheck for the test suite.++Changes in 2999.18.1.0+----------------------++* Monadic graphs can now have edges to and from lists of nodes, as+ requested by **Harold Carr**.++* Compatible with GHC-8.* pre-releases.++ - Please note that there is currently a warning emitted on+ compilation by GHC-8.*; this has been reported+ [here](https://ghc.haskell.org/trac/ghc/ticket/11822).++Changes in 2999.18.0.2+----------------------++* Match new behaviour of `dot`, etc. in supporting edge specifications+ like `a, b -> c, d` (spotted by **Dilawar Singh**).++Changes in 2999.18.0.1+----------------------++* Loosened bound on `fgl-arbitrary`.++Changes in 2999.18.0.0+----------------------++* Now builds on GHC 7.10.*.++* Attribute changes:++ - Added the `NoTranslate` attribute.++ - Add support for overlines in HTML labels.++ Both of these are available as of Graphviz 2.38.0, but were+ somehow overlooked in previous releases of this library.++* Uses new `fgl-arbitrary` library for testing rather than custom+ instances for FGL graphs.++* Migrated to git; central repository now on+ [GitHub](https://github.com/ivan-m/graphviz).++Changes in 2999.17.0.2+----------------------++* Augmentation tests are no longer run by default. This avoids+ problems where Graphviz is not installed/configured properly.++* Use `.gv` for temporary files instead of `.dot`. Changes in 2999.17.0.1 ----------------------
Data/GraphViz.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, OverloadedStrings #-}+{-# LANGUAGE CPP, FlexibleContexts, MultiParamTypeClasses, OverloadedStrings #-} {- | Module : Data.GraphViz@@ -26,6 +26,7 @@ -- ** Specifying parameters. -- $params GraphvizParams(..)+ , quickParams , defaultParams , nonClusteredParams , blankParams@@ -78,7 +79,6 @@ import Control.Arrow (first, (&&&)) import Control.Concurrent (forkIO)-import Data.Functor ((<$>)) import Data.Graph.Inductive.Graph import qualified Data.Map as Map import Data.Maybe (fromJust, mapMaybe)@@ -87,6 +87,10 @@ import qualified Data.Text.Lazy as T import System.IO.Unsafe (unsafePerformIO) +#if !(MIN_VERSION_base (4,8,0))+import Data.Functor ((<$>))+#endif+ -- ----------------------------------------------------------------------------- -- | Determine if the given graph is undirected.@@ -203,6 +207,15 @@ -- | An alias for 'NodeCluster' when dealing with FGL graphs. type LNodeCluster cl l = NodeCluster cl (Node,l) +-- | Especially useful for quick explorations in ghci, this is a "do+-- what I mean" set of parameters that prints the specified labels+-- of a non-clustered graph.+quickParams :: (Labellable nl, Labellable el) => GraphvizParams n nl el () nl+quickParams = nonClusteredParams { fmtNode = nodeFmt, fmtEdge = edgeFmt }+ where+ nodeFmt (_,l) = [toLabel l]+ edgeFmt (_,_,l) = [toLabel l]+ -- | A default 'GraphvizParams' value which assumes the graph is -- directed, contains no clusters and has no 'Attribute's set. --@@ -240,14 +253,14 @@ -- programmatically setting the clustering function (and as such do -- not know what the types might be). blankParams :: GraphvizParams n nl el cl l-blankParams = Params { isDirected = undefined- , globalAttributes = undefined- , clusterBy = undefined- , isDotCluster = undefined- , clusterID = undefined- , fmtCluster = undefined- , fmtNode = undefined- , fmtEdge = undefined+blankParams = Params { isDirected = error "Unspecified definition of isDirected"+ , globalAttributes = error "Unspecified definition of globalAttributes"+ , clusterBy = error "Unspecified definition of clusterBy"+ , isDotCluster = error "Unspecified definition of isDotCluster"+ , clusterID = error "Unspecified definition of clusterID"+ , fmtCluster = error "Unspecified definition of fmtCluster"+ , fmtNode = error "Unspecified definition of fmtNode"+ , fmtEdge = error "Unspecified definition of fmtEdge" } -- | Determine if the provided 'Graph' is directed or not and set the
Data/GraphViz/Algorithms.hs view
@@ -38,19 +38,19 @@ import Data.GraphViz.Types.Canonical import Data.GraphViz.Types.Internal.Common -import Control.Arrow (first, second, (***))-import Control.Monad (unless)-import Control.Monad.Trans.State-import qualified Data.DList as DList-import qualified Data.Foldable as F-import Data.Function (on)-import Data.List (deleteBy, groupBy, partition,- sortBy, (\\))-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)-import Data.Set (Set)-import qualified Data.Set as Set+import Control.Arrow (first, second, (***))+import Control.Monad (unless)+import Control.Monad.State (State, execState, gets, modify)+import qualified Data.DList as DList+import qualified Data.Foldable as F+import Data.Function (on)+import Data.List (deleteBy, groupBy, partition, sortBy,+ (\\))+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)+import Data.Set (Set)+import qualified Data.Set as Set -- ----------------------------------------------------------------------------- @@ -382,7 +382,7 @@ esMS = do edgeGraph tes ns <- getsMap Map.keys- mapM_ (traverse zeroTag) ns+ mapM_ (traverseTag zeroTag) ns esM = fst $ execState esMS (Map.empty, Set.empty) @@ -442,13 +442,12 @@ } -- Perform a DFS to determine whether or not to keep each edge.-traverse :: (Ord n) => Tag -> n -> TagState n ()-traverse t n = do setMark True- checkIncoming- outEs <- getsMap (maybe [] outgoing . Map.lookup n)- mapM_ maybeRecurse outEs- setMark False-+traverseTag :: (Ord n) => Tag -> n -> TagState n ()+traverseTag t n = do setMark True+ checkIncoming+ outEs <- getsMap (maybe [] outgoing . Map.lookup n)+ mapM_ maybeRecurse outEs+ setMark False where setMark mrk = modifyMap (Map.adjust (\tv -> tv { marked = mrk }) n) @@ -471,4 +470,4 @@ delSet <- getSet let n' = toNode e unless (isMarked m n' || t' `Set.member` delSet)- $ traverse t' n'+ $ traverseTag t' n'
Data/GraphViz/Attributes/Arrows.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP, OverloadedStrings #-} {-# OPTIONS_HADDOCK hide #-} {- | Module : Data.GraphViz.Attributes.Arrows@@ -17,6 +17,10 @@ import Data.GraphViz.Printing import Data.Maybe (isJust)++#if !MIN_VERSION_base (4,13,0)+import Data.Monoid ((<>))+#endif -- -----------------------------------------------------------------------------
Data/GraphViz/Attributes/Colors.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP, OverloadedStrings #-} {- | Module : Data.GraphViz.Attributes.Colors@@ -36,11 +36,10 @@ , fromAColour ) where -import Data.GraphViz.Attributes.Colors.Brewer (BrewerColor (..))+import Data.GraphViz.Attributes.Colors.Brewer (BrewerColor(..)) import Data.GraphViz.Attributes.Colors.SVG (SVGColor, svgColour)-import Data.GraphViz.Attributes.Colors.X11 (X11Color (Transparent),- x11Colour)-import Data.GraphViz.Attributes.ColorScheme (ColorScheme (..))+import Data.GraphViz.Attributes.Colors.X11 (X11Color(Transparent), x11Colour)+import Data.GraphViz.Attributes.ColorScheme (ColorScheme(..)) import Data.GraphViz.Exception import Data.GraphViz.Internal.State import Data.GraphViz.Internal.Util (bool)@@ -59,6 +58,10 @@ import Data.Word (Word8) import Numeric (readHex, showHex) +#if !MIN_VERSION_base (4,13,0)+import Data.Monoid ((<>))+#endif+ -- ----------------------------------------------------------------------------- -- | Defining a color for use with Graphviz. Note that named colors@@ -304,7 +307,7 @@ cs = colorScheme c lv = fl c -parseNamedColor :: (NamedColor nc, ParseDot lv)+parseNamedColor :: (ParseDot lv) => (ColorScheme -> Maybe cs) -> Parse cs -> (cs -> Bool) -> (cs -> lv -> nc) -> Bool -> Parse nc parseNamedColor gcs parseCS vcs mkC q
Data/GraphViz/Attributes/Complete.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP, OverloadedStrings #-} {- | Module : Data.GraphViz.Attributes.Complete@@ -192,11 +192,11 @@ import Data.GraphViz.Attributes.Arrows import Data.GraphViz.Attributes.Colors-import Data.GraphViz.Attributes.Colors.X11 (X11Color (Black))+import Data.GraphViz.Attributes.Colors.X11 (X11Color(Black)) import Data.GraphViz.Attributes.Internal import Data.GraphViz.Attributes.Values import Data.GraphViz.Commands.Available-import Data.GraphViz.Exception (GraphvizException (NotCustomAttr),+import Data.GraphViz.Exception (GraphvizException(NotCustomAttr), throw) import Data.GraphViz.Internal.State (getsGS, parseStrictly) import Data.GraphViz.Internal.Util (bool, isIDString, keywords,@@ -209,9 +209,13 @@ import qualified Data.Set as S import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as T-import Data.Version (Version (..))+import Data.Version (Version(..)) import Data.Word (Word16) +#if !MIN_VERSION_base (4,13,0)+import Data.Monoid ((<>))+#endif+ -- ----------------------------------------------------------------------------- {- $attributes@@ -346,6 +350,7 @@ | NodeSep Double -- ^ /Valid for/: G; /Default/: @0.25@; /Minimum/: @0.02@ | NoJustify Bool -- ^ /Valid for/: GCNE; /Default/: @'False'@; /Parsing Default/: 'True' | Normalize Normalized -- ^ /Valid for/: G; /Default/: @'NotNormalized'@; /Parsing Default/: 'IsNormalized'; /Notes/: not 'Dot'+ | NoTranslate Bool -- ^ /Valid for/: G; /Default/: @'False'@; /Parsing Default/: 'True'; /Notes/: 'Neato' only, requires Graphviz >= 2.38.0 | Nslimit Double -- ^ /Valid for/: G; /Notes/: 'Dot' only | Nslimit1 Double -- ^ /Valid for/: G; /Notes/: 'Dot' only | Ordering Order -- ^ /Valid for/: GN; /Default/: none; /Notes/: 'Dot' only@@ -514,6 +519,7 @@ unqtDot (NodeSep v) = printField "nodesep" v unqtDot (NoJustify v) = printField "nojustify" v unqtDot (Normalize v) = printField "normalize" v+ unqtDot (NoTranslate v) = printField "notranslate" v unqtDot (Nslimit v) = printField "nslimit" v unqtDot (Nslimit1 v) = printField "nslimit1" v unqtDot (Ordering v) = printField "ordering" v@@ -678,6 +684,7 @@ , parseField NodeSep "nodesep" , parseFieldBool NoJustify "nojustify" , parseFieldDef Normalize IsNormalized "normalize"+ , parseFieldBool NoTranslate "notranslate" , parseField Nslimit "nslimit" , parseField Nslimit1 "nslimit1" , parseField Ordering "ordering"@@ -809,6 +816,7 @@ usedByGraphs NodeSep{} = True usedByGraphs NoJustify{} = True usedByGraphs Normalize{} = True+usedByGraphs NoTranslate{} = True usedByGraphs Nslimit{} = True usedByGraphs Nslimit1{} = True usedByGraphs Ordering{} = True@@ -1099,6 +1107,7 @@ sameAttribute NodeSep{} NodeSep{} = True sameAttribute NoJustify{} NoJustify{} = True sameAttribute Normalize{} Normalize{} = True+sameAttribute NoTranslate{} NoTranslate{} = True sameAttribute Nslimit{} Nslimit{} = True sameAttribute Nslimit1{} Nslimit1{} = True sameAttribute Ordering{} Ordering{} = True@@ -1248,6 +1257,7 @@ defaultAttributeValue NodeSep{} = Just $ NodeSep 0.25 defaultAttributeValue NoJustify{} = Just $ NoJustify False defaultAttributeValue Normalize{} = Just $ Normalize NotNormalized+defaultAttributeValue NoTranslate{} = Just $ NoTranslate False defaultAttributeValue Orientation{} = Just $ Orientation 0.0 defaultAttributeValue OutputOrder{} = Just $ OutputOrder BreadthFirst defaultAttributeValue Overlap{} = Just $ Overlap KeepOverlaps@@ -1399,6 +1409,7 @@ , "nodesep" , "nojustify" , "normalize"+ , "notranslate" , "nslimit" , "nslimit1" , "ordering"
Data/GraphViz/Attributes/HTML.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, PatternGuards #-}+{-# LANGUAGE CPP, OverloadedStrings, PatternGuards #-} {- | Module : Data.GraphViz.Attributes.HTML@@ -64,7 +64,10 @@ , Attribute(..) , Align(..) , VAlign(..)+ , CellFormat(..) , Scale(..)+ , Side(..)+ , Style(..) ) where import Data.GraphViz.Attributes.Colors@@ -82,6 +85,10 @@ import Data.Word (Word16, Word8) import Numeric (readHex) +#if !MIN_VERSION_base (4,13,0)+import Data.Monoid ((<>))+#endif+ -- ----------------------------------------------------------------------------- -- | The overall type for HTML-like labels. Fundamentally, HTML-like@@ -156,6 +163,7 @@ data Format = Italics | Bold | Underline+ | Overline -- ^ Requires Graphviz >= 2.38.0. | Subscript | Superscript deriving (Eq, Ord, Bounded, Enum, Show, Read)@@ -164,6 +172,7 @@ unqtDot Italics = text "I" unqtDot Bold = text "B" unqtDot Underline = text "U"+ unqtDot Overline = text "O" unqtDot Subscript = text "SUB" unqtDot Superscript = text "SUP" @@ -171,6 +180,7 @@ parseUnqt = stringValue [ ("I", Italics) , ("B", Bold) , ("U", Underline)+ , ("O", Overline) , ("SUB", Subscript) , ("SUP", Superscript) ]@@ -298,55 +308,65 @@ -- | Note that not all 'Attribute' values are valid everywhere: -- see the comments for each one on where it is valid.-data Attribute = Align Align -- ^ Valid for: 'Table', 'Cell', 'Newline'.- | BAlign Align -- ^ Valid for: 'Cell'.- | BGColor Color -- ^ Valid for: 'Table' (including 'tableFontAttrs'), 'Cell', 'Font'.- | Border Word8 -- ^ Valid for: 'Table', 'Cell'. Default is @1@; @0@ represents no border.- | CellBorder Word8 -- ^ Valid for: 'Table'. Default is @1@; @0@ represents no border.- | CellPadding Word8 -- ^ Valid for: 'Table', 'Cell'. Default is @2@.- | CellSpacing Word8 -- ^ Valid for: 'Table', 'Cell'. Default is @2@; maximum is @127@.- | Color Color -- ^ Valid for: 'Table', 'Cell'.- | ColSpan Word16 -- ^ Valid for: 'Cell'. Default is @1@.- | Face T.Text -- ^ Valid for: 'tableFontAttrs', 'Font'.- | FixedSize Bool -- ^ Valid for: 'Table', 'Cell'. Default is @'False'@.- | Height Word16 -- ^ Valid for: 'Table', 'Cell'.- | HRef T.Text -- ^ Valid for: 'Table', 'Cell'.- | ID T.Text -- ^ Valid for: 'Table', 'Cell'. Requires Graphviz >= 2.29.0- | PointSize Double -- ^ Valid for: 'tableFontAttrs', 'Font'.- | Port PortName -- ^ Valid for: 'Table', 'Cell'.- | RowSpan Word16 -- ^ Valid for: 'Cell'.- | Scale Scale -- ^ Valid for: 'Img'.- | Src FilePath -- ^ Valid for: 'Img'.- | Target T.Text -- ^ Valid for: 'Table', 'Cell'.- | Title T.Text -- ^ Valid for: 'Table', 'Cell'. Has an alias of @TOOLTIP@.- | VAlign VAlign -- ^ Valid for: 'Table', 'Cell'.- | Width Word16 -- ^ Valid for: 'Table', 'Cell'.+data Attribute = Align Align -- ^ Valid for: 'Table', 'Cell', 'Newline'.+ | BAlign Align -- ^ Valid for: 'Cell'.+ | BGColor Color -- ^ Valid for: 'Table' (including 'tableFontAttrs'), 'Cell', 'Font'.+ | Border Word8 -- ^ Valid for: 'Table', 'Cell'. Default is @1@; @0@ represents no border.+ | CellBorder Word8 -- ^ Valid for: 'Table'. Default is @1@; @0@ represents no border.+ | CellPadding Word8 -- ^ Valid for: 'Table', 'Cell'. Default is @2@.+ | CellSpacing Word8 -- ^ Valid for: 'Table', 'Cell'. Default is @2@; maximum is @127@.+ | Color Color -- ^ Valid for: 'Table', 'Cell'.+ | ColSpan Word16 -- ^ Valid for: 'Cell'. Default is @1@.+ | Columns CellFormat -- ^ Valid for: 'Table'. Requires Graphviz >= 2.40.1+ | Face T.Text -- ^ Valid for: 'tableFontAttrs', 'Font'.+ | FixedSize Bool -- ^ Valid for: 'Table', 'Cell'. Default is @'False'@.+ | GradientAngle Int -- ^ Valid for: 'Table', 'Cell'. Default is @0@. Requires Graphviz >= 2.40.1+ | Height Word16 -- ^ Valid for: 'Table', 'Cell'.+ | HRef T.Text -- ^ Valid for: 'Table', 'Cell'.+ | ID T.Text -- ^ Valid for: 'Table', 'Cell'. Requires Graphviz >= 2.29.0+ | PointSize Double -- ^ Valid for: 'tableFontAttrs', 'Font'.+ | Port PortName -- ^ Valid for: 'Table', 'Cell'.+ | Rows CellFormat -- ^ Valid for: 'Table'. Requires Graphviz >= 2.40.1+ | RowSpan Word16 -- ^ Valid for: 'Cell'.+ | Scale Scale -- ^ Valid for: 'Img'.+ | Sides [Side] -- ^ Valid for: 'Table', 'Cell'. Default is @['LeftSide', 'TopSide', 'RightSide', 'BottomSide']@. Requires Graphviz >= 2.40.1+ | Src FilePath -- ^ Valid for: 'Img'.+ | Style Style -- ^ Valid for: 'Table', 'Cell'. Requires Graphviz >= 2.40.1+ | Target T.Text -- ^ Valid for: 'Table', 'Cell'.+ | Title T.Text -- ^ Valid for: 'Table', 'Cell'. Has an alias of @TOOLTIP@.+ | VAlign VAlign -- ^ Valid for: 'Table', 'Cell'.+ | Width Word16 -- ^ Valid for: 'Table', 'Cell'. deriving (Eq, Ord, Show, Read) instance PrintDot Attribute where- unqtDot (Align v) = printHtmlField "ALIGN" v- unqtDot (BAlign v) = printHtmlField "BALIGN" v- unqtDot (BGColor v) = printHtmlField "BGCOLOR" v- unqtDot (Border v) = printHtmlField "BORDER" v- unqtDot (CellBorder v) = printHtmlField "CELLBORDER" v- unqtDot (CellPadding v) = printHtmlField "CELLPADDING" v- unqtDot (CellSpacing v) = printHtmlField "CELLSPACING" v- unqtDot (Color v) = printHtmlField "COLOR" v- unqtDot (ColSpan v) = printHtmlField "COLSPAN" v- unqtDot (Face v) = printHtmlField' "FACE" $ escapeAttribute v- unqtDot (FixedSize v) = printHtmlField' "FIXEDSIZE" $ printBoolHtml v- unqtDot (Height v) = printHtmlField "HEIGHT" v- unqtDot (HRef v) = printHtmlField' "HREF" $ escapeAttribute v- unqtDot (ID v) = printHtmlField' "ID" $ escapeAttribute v- unqtDot (PointSize v) = printHtmlField "POINT-SIZE" v- unqtDot (Port v) = printHtmlField' "PORT" . escapeAttribute $ portName v- unqtDot (RowSpan v) = printHtmlField "ROWSPAN" v- unqtDot (Scale v) = printHtmlField "SCALE" v- unqtDot (Src v) = printHtmlField' "SRC" . escapeAttribute $ T.pack v- unqtDot (Target v) = printHtmlField' "TARGET" $ escapeAttribute v- unqtDot (Title v) = printHtmlField' "TITLE" $ escapeAttribute v- unqtDot (VAlign v) = printHtmlField "VALIGN" v- unqtDot (Width v) = printHtmlField "WIDTH" v+ unqtDot (Align v) = printHtmlField "ALIGN" v+ unqtDot (BAlign v) = printHtmlField "BALIGN" v+ unqtDot (BGColor v) = printHtmlField "BGCOLOR" v+ unqtDot (Border v) = printHtmlField "BORDER" v+ unqtDot (CellBorder v) = printHtmlField "CELLBORDER" v+ unqtDot (CellPadding v) = printHtmlField "CELLPADDING" v+ unqtDot (CellSpacing v) = printHtmlField "CELLSPACING" v+ unqtDot (Color v) = printHtmlField "COLOR" v+ unqtDot (ColSpan v) = printHtmlField "COLSPAN" v+ unqtDot (Columns v) = printHtmlField "COLUMNS" v+ unqtDot (Face v) = printHtmlField' "FACE" $ escapeAttribute v+ unqtDot (FixedSize v) = printHtmlField' "FIXEDSIZE" $ printBoolHtml v+ unqtDot (GradientAngle v) = printHtmlField "GRADIENTANGLE" v+ unqtDot (Height v) = printHtmlField "HEIGHT" v+ unqtDot (HRef v) = printHtmlField' "HREF" $ escapeAttribute v+ unqtDot (ID v) = printHtmlField' "ID" $ escapeAttribute v+ unqtDot (PointSize v) = printHtmlField "POINT-SIZE" v+ unqtDot (Port v) = printHtmlField' "PORT" . escapeAttribute $ portName v+ unqtDot (Rows v) = printHtmlField "ROWS" v+ unqtDot (RowSpan v) = printHtmlField "ROWSPAN" v+ unqtDot (Scale v) = printHtmlField "SCALE" v+ unqtDot (Sides v) = printHtmlField "SIDES" v+ unqtDot (Src v) = printHtmlField' "SRC" . escapeAttribute $ T.pack v+ unqtDot (Style v) = printHtmlField "STYLE" v+ unqtDot (Target v) = printHtmlField' "TARGET" $ escapeAttribute v+ unqtDot (Title v) = printHtmlField' "TITLE" $ escapeAttribute v+ unqtDot (VAlign v) = printHtmlField "VALIGN" v+ unqtDot (Width v) = printHtmlField "WIDTH" v unqtListToDot = hsep . mapM unqtDot @@ -371,16 +391,21 @@ , parseHtmlField CellSpacing "CELLSPACING" , parseHtmlField Color "COLOR" , parseHtmlField ColSpan "COLSPAN"+ , parseHtmlField Columns "COLUMNS" , parseHtmlField' Face "FACE" unescapeAttribute , parseHtmlField' FixedSize "FIXEDSIZE" parseBoolHtml+ , parseHtmlField GradientAngle "GRADIENTANGLE" , parseHtmlField Height "HEIGHT" , parseHtmlField' HRef "HREF" unescapeAttribute , parseHtmlField' ID "ID" unescapeAttribute , parseHtmlField PointSize "POINT-SIZE" , parseHtmlField' (Port . PN) "PORT" unescapeAttribute+ , parseHtmlField Rows "ROWS" , parseHtmlField RowSpan "ROWSPAN" , parseHtmlField Scale "SCALE"+ , parseHtmlField Sides "SIDES" , parseHtmlField' Src "SRC" $ fmap T.unpack unescapeAttribute+ , parseHtmlField Style "STYLE" , parseHtmlField' Target "TARGET" unescapeAttribute , parseHtmlField' Title "TITLE" unescapeAttribute `onFail`@@ -463,6 +488,17 @@ parse = parseUnqt +data CellFormat = RuleBetween+ deriving (Eq, Ord, Bounded, Enum, Show, Read)++instance PrintDot CellFormat where+ unqtDot RuleBetween = text "*"++instance ParseDot CellFormat where+ parseUnqt = stringRep RuleBetween "*"++ parse = parseUnqt+ -- | Specifies how an image will use any extra space available in its -- cell. If undefined, the image inherits the value of the -- @ImageScale@ attribute.@@ -490,6 +526,52 @@ parse = parseUnqt +-- | Which sides of a border in a cell or table should be drawn, if a+-- border is drawn.+data Side = LeftSide+ | RightSide+ | TopSide+ | BottomSide+ deriving (Eq, Ord, Bounded, Enum, Show, Read)++instance PrintDot Side where+ unqtDot LeftSide = text "L"+ unqtDot RightSide = text "R"+ unqtDot TopSide = text "T"+ unqtDot BottomSide = text "B"++ unqtListToDot = hcat . mapM unqtDot++ listToDot = unqtListToDot++instance ParseDot Side where+ parseUnqt = oneOf [ stringRep LeftSide "L"+ , stringRep RightSide "R"+ , stringRep TopSide "T"+ , stringRep BottomSide "B"+ ]++ parse = parseUnqt++ parseUnqtList = many parseUnqt++ parseList = parseUnqtList++data Style = Rounded -- ^ Valid for 'Table'+ | Radial -- ^ Valid for 'Table', 'Cell'.+ deriving (Eq, Ord, Bounded, Enum, Show, Read)++instance PrintDot Style where+ unqtDot Rounded = text "ROUNDED"+ unqtDot Radial = text "RADIAL"++instance ParseDot Style where+ parseUnqt = oneOf [ stringRep Rounded "ROUNDED"+ , stringRep Radial "RADIAL"+ ]++ parse = parseUnqt+ -- ----------------------------------------------------------------------------- escapeAttribute :: T.Text -> DotCode@@ -569,9 +651,6 @@ , ('>', "gt") , ('&', "amp") ]- ++ map numEscape ['-', '\'']- where- numEscape c = (c, T.pack $ '#' : show (ord c)) -- | Flip the order and add extra values that might be escaped. More -- specifically, provide the escape code for spaces (@\"nbsp\"@) and@@ -618,7 +697,7 @@ parseTag :: (Attributes -> val -> tag) -> String -> Parse val -> Parse tag parseTag c t pv = c <$> parseAngled openingTag- <*> pv+ <*> wrapWhitespace pv <* parseAngled (character '/' *> t' *> whitespace) `adjustErr` (("Can't parse Html tag: " ++ t ++ "\n\t")++)
Data/GraphViz/Attributes/Internal.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP, OverloadedStrings #-} {-# OPTIONS_HADDOCK hide #-} {- |@@ -29,6 +29,10 @@ import qualified Data.Map as Map import Data.Maybe (isNothing) import Data.Text.Lazy (Text)++#if !MIN_VERSION_base (4,13,0)+import Data.Monoid ((<>))+#endif -- -----------------------------------------------------------------------------
Data/GraphViz/Attributes/Values.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP, OverloadedStrings #-} {-# OPTIONS_HADDOCK hide #-} {- | Module : Data.GraphViz.Attributes.Values@@ -29,6 +29,10 @@ import Data.Word (Word16) import System.FilePath (searchPathSeparator, splitSearchPath) +#if !MIN_VERSION_base (4,13,0)+import Data.Monoid ((<>))+#endif+ -- ----------------------------------------------------------------------------- {- |@@ -1272,7 +1276,7 @@ `onFail` fmap (`SItem` []) parse - parseUnqtList = sepBy1 parseUnqt parseComma+ parseUnqtList = sepBy1 parseUnqt (wrapWhitespace parseComma) parseList = quotedParse parseUnqtList `onFail`@@ -1417,9 +1421,9 @@ unqtDot VBottom = char 'b' instance ParseDot VerticalPlacement where- parseUnqt = oneOf [ stringRep VTop "t"- , stringRep VCenter "c"- , stringRep VBottom "b"+ parseUnqt = oneOf [ stringReps VTop ["top", "t"]+ , stringReps VCenter ["centre", "center", "c"]+ , stringReps VBottom ["bottom", "b"] ] -- -----------------------------------------------------------------------------@@ -1478,9 +1482,9 @@ unqtDot JCenter = char 'c' instance ParseDot Justification where- parseUnqt = oneOf [ stringRep JLeft "l"- , stringRep JRight "r"- , stringRep JCenter "c"+ parseUnqt = oneOf [ stringReps JLeft ["left", "l"]+ , stringReps JRight ["right", "r"]+ , stringReps JCenter ["center", "centre", "c"] ] -- -----------------------------------------------------------------------------
Data/GraphViz/Commands.hs view
@@ -166,7 +166,7 @@ outputCall Bmp = "bmp" outputCall Canon = "canon" outputCall DotOutput = "dot"- outputCall (XDot mv) = "xdot" ++ maybe "" (showVersion . (\v -> v {versionTags = []})) mv+ outputCall (XDot mv) = "xdot" ++ maybe "" showVersion mv outputCall Eps = "eps" outputCall Fig = "fig" outputCall Gd = "gd"@@ -249,7 +249,7 @@ -> GraphvizOutput -> FilePath -> IO FilePath runGraphvizCommand cmd gr t fp- = mapException addExc $ graphvizWithHandle cmd gr t toFile+ = handle (throwIO . addExc) $ graphvizWithHandle cmd gr t toFile where addFl = (++) ("Unable to create " ++ fp ++ "\n") toFile h = SB.hGetContents h >>= SB.writeFile fp >> return fp
Data/GraphViz/Commands/IO.hs view
@@ -29,35 +29,29 @@ ) where import Data.GraphViz.Exception-import Data.GraphViz.Internal.State (initialState)-import Data.GraphViz.Printing (toDot)+import Data.GraphViz.Printing (runDotCode, toDot) import Data.GraphViz.Types (ParseDotRepr, PrintDotRepr, parseDotGraph, printDotGraph) import Text.PrettyPrint.Leijen.Text (displayT, renderOneLine) -import Control.Concurrent (MVar, forkIO, newEmptyMVar, putMVar,- takeMVar)-import Control.Exception (IOException, evaluate, finally)-import Control.Monad (liftM, unless)-import Control.Monad.Trans.State-import qualified Data.ByteString as SB-import Data.ByteString.Lazy (ByteString)-import qualified Data.ByteString.Lazy as B-import Data.Text.Encoding.Error (UnicodeException)-import Data.Text.Lazy (Text)-import qualified Data.Text.Lazy.Encoding as T-import System.Directory (canonicalizePath, doesFileExist,- executable, findExecutable,- getHomeDirectory, getPermissions)-import System.Exit (ExitCode (ExitSuccess))-import System.FilePath (joinPath, splitDirectories, (<.>))-import System.IO (Handle,- IOMode (ReadMode, WriteMode),- hClose, hGetContents, hPutChar,- stdin, stdout, withFile)-import System.IO.Temp (withSystemTempFile)-import System.Process (runInteractiveProcess,- waitForProcess)+import Control.Concurrent (MVar, forkIO, newEmptyMVar, putMVar,+ takeMVar)+import Control.Exception (IOException, evaluate, finally)+import Control.Monad (liftM)+import qualified Data.ByteString as SB+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as B+import Data.Text.Encoding.Error (UnicodeException)+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy.Encoding as T+import System.Exit (ExitCode(ExitSuccess))+import System.FilePath ((<.>))+import System.IO (Handle, IOMode(ReadMode, WriteMode),+ hClose, hGetContents, hPutChar,+ stdin, stdout, withFile)+import System.IO.Temp (withSystemTempFile)+import System.Process (runInteractiveProcess,+ waitForProcess) -- -----------------------------------------------------------------------------@@ -66,7 +60,7 @@ -- (i.e. more compact than the output of 'renderDot'). renderCompactDot :: (PrintDotRepr dg n) => dg n -> Text renderCompactDot = displayT . renderOneLine- . (`evalState` initialState)+ . runDotCode . toDot -- -----------------------------------------------------------------------------@@ -107,8 +101,7 @@ hPutCompactDot :: (PrintDotRepr dg n) => Handle -> dg n -> IO () hPutCompactDot = toHandle renderCompactDot -toHandle :: (PrintDotRepr dg n) => (dg n -> Text) -> Handle -> dg n- -> IO ()+toHandle :: (dg n -> Text) -> Handle -> dg n -> IO () toHandle f h dg = do B.hPutStr h . T.encodeUtf8 $ f dg hPutChar h '\n' @@ -155,11 +148,8 @@ -> (Handle -> IO a) -- ^ Obtaining the output; should be strict. -> dg n -> IO a-runCommand cmd args hf dg = do- isEx <- isExecutable cmd- unless isEx (throw $ CmdNotFound cmd)-- mapException notRunnable $+runCommand cmd args hf dg+ = handle (throwIO . notRunnable) $ withSystemTempFile ("graphviz" <.> "gv") $ \dotFile dotHandle -> do finally (hPutCompactDot dotHandle dg) (hClose dotHandle) bracket@@ -199,7 +189,7 @@ ] -- Augmenting the hf function to let it work within the forkIO:- hf' = mapException fErr . hf+ hf' = handle (throwIO . fErr) . hf fErr :: IOException -> GraphvizException fErr e = GVProgramExc $ "Error re-directing the output from " ++ cmd ++ ": " ++ show e@@ -220,41 +210,3 @@ -- | Store the result of the 'Handle' consumption into the 'MVar'. signalWhenDone :: (Handle -> IO a) -> Handle -> MVar a -> IO () signalWhenDone f h mv = f h >>= putMVar mv >> return ()--canonicalizeExecutable :: String -> IO (Maybe FilePath)-canonicalizeExecutable cmd = liftMaybePlus (findExecutable cmd) checkPath- where- -- Check to see if it's an explicitly listed command- checkPath = handle noSuchFile $- do fp <- canonicalizePath' cmd- prm <- getPermissions fp- if executable prm- then return (Just fp)- else return Nothing-- noSuchFile :: IOException -> IO (Maybe FilePath)- noSuchFile = const (return Nothing)--isExecutable :: FilePath -> IO Bool-isExecutable cmd = findExecutable cmd >>= maybe checkPath (const (return True))- where- -- Check to see if it's an explicitly listed command- checkPath = handle noSuchFile $- do fp <- canonicalizePath' cmd- ex <- doesFileExist fp- if ex- then executable `fmap` getPermissions fp- else return False-- noSuchFile :: IOException -> IO Bool- noSuchFile = const (return False)--liftMaybePlus :: IO (Maybe a) -> IO (Maybe a) -> IO (Maybe a)-liftMaybePlus mm1 mm2 = mm1 >>= maybe mm2 (return . Just)--canonicalizePath' :: FilePath -> IO FilePath-canonicalizePath' fp = do fp' <- case splitDirectories fp of- "~":ds -> do hd <- getHomeDirectory- return (joinPath (hd:ds))- _ -> return fp- canonicalizePath fp'
Data/GraphViz/Exception.hs view
@@ -11,6 +11,7 @@ -- * Re-exported for convenience. , mapException , throw+ , throwIO , handle , bracket ) where@@ -35,7 +36,6 @@ | NotUTF8Dot String | GVProgramExc String | NotCustomAttr String- | CmdNotFound String deriving (Eq, Ord, Typeable) instance Show GraphvizException where@@ -43,6 +43,5 @@ showsPrec _ (NotUTF8Dot str) = showString $ "Invalid UTF-8 Dot code: " ++ str showsPrec _ (GVProgramExc str) = showString $ "Error running utility program: " ++ str showsPrec _ (NotCustomAttr str) = showString $ "Not a custom Attribute: " ++ str- showsPrec _ (CmdNotFound str) = showString $ "Command not found: " ++ str instance Exception GraphvizException
Data/GraphViz/Internal/State.hs view
@@ -1,5 +1,5 @@ {-# OPTIONS_HADDOCK hide #-}-{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-} {- | Module : Data.GraphViz.Internal.State@@ -30,7 +30,6 @@ import Data.GraphViz.Attributes.ColorScheme -import Control.Monad.Trans.State (State, gets, modify) import Text.ParserCombinators.Poly.StateText (Parser, stQuery, stUpdate) -- -----------------------------------------------------------------------------@@ -40,11 +39,6 @@ getsGS :: (GraphvizState -> a) -> m a -instance GraphvizStateM (State GraphvizState) where- modifyGS = modify-- getsGS = gets- instance GraphvizStateM (Parser GraphvizState) where modifyGS = stUpdate @@ -129,10 +123,12 @@ NodeAttribute -> nodeColor EdgeAttribute -> edgeColor --- | The default separators for 'LayerSep'.+-- | The default separators for+-- 'Data.GraphViz.Attributes.Complete.LayerSep'. defLayerSep :: [Char] defLayerSep = [' ', ':', '\t'] --- | The default separators for 'LayerListSep'.+-- | The default separators for+-- 'Data.GraphViz.Attributes.Complete.LayerListSep'. defLayerListSep :: [Char] defLayerListSep = [',']
Data/GraphViz/Internal/Util.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, PatternGuards #-}+{-# LANGUAGE CPP, OverloadedStrings, PatternGuards #-} {-# OPTIONS_HADDOCK hide #-} {- |@@ -23,8 +23,13 @@ import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as T import qualified Data.Text.Lazy.Read as T-import Data.Version (Version (..)) +#if MIN_VERSION_base(4,8,0)+import Data.Version (Version, makeVersion)+#else+import Data.Version (Version(..))+#endif+ -- ----------------------------------------------------------------------------- isIDString :: Text -> Bool@@ -43,13 +48,14 @@ restIDString :: Char -> Bool restIDString c = frstIDString c || isDigit c --- | Determine if this String represents a number.-isNumString :: Text -> Bool-isNumString "" = False-isNumString "-" = False-isNumString str = case T.uncons $ T.toLower str of- Just ('-',str') -> go str'- _ -> go str+-- | Determine if this String represents a number. Boolean parameter+-- determines if exponents are considered part of numbers for this.+isNumString :: Bool -> Text -> Bool+isNumString _ "" = False+isNumString _ "-" = False+isNumString allowE str = case T.uncons $ T.toLower str of+ Just ('-',str') -> go str'+ _ -> go str where -- Can't use Data.Text.Lazy.Read.double as it doesn't cover all -- possible cases@@ -68,7 +74,7 @@ (ds,es) -> T.all isDigit ds && checkEs es checkEs str' = case T.uncons str' of Nothing -> True- Just ('e',ds) -> isIntString ds+ Just ('e',ds) -> allowE && isIntString ds _ -> False {-@@ -137,8 +143,12 @@ , "strict" ] -createVersion :: [Int] -> Version+createVersion :: [Int] -> Version+#if MIN_VERSION_base(4,8,0)+createVersion = makeVersion+#else createVersion bs = Version { versionBranch = bs, versionTags = []}+#endif -- -----------------------------------------------------------------------------
Data/GraphViz/Parsing.hs view
@@ -33,6 +33,7 @@ , runParserWith , parseLiberally , checkValidParse+ , checkValidParseWithRest -- * Convenience parsing combinators. , ignoreSep , onlyBool@@ -77,7 +78,7 @@ , parseColorScheme ) where -import Data.GraphViz.Exception (GraphvizException (NotDotCode), throw)+import Data.GraphViz.Exception (GraphvizException(NotDotCode), throw) import Data.GraphViz.Internal.State import Data.GraphViz.Internal.Util @@ -98,10 +99,11 @@ maybeToList) import Data.Ratio ((%)) import qualified Data.Set as Set+import qualified Data.Text as ST import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as T import qualified Data.Text.Lazy.Read as T-import Data.Version (Version (..))+import Data.Version (Version(..)) import Data.Word (Word16, Word8) -- -----------------------------------------------------------------------------@@ -125,7 +127,7 @@ -- parsing function consumes all of the 'Text' input (with the -- exception of whitespace at the end). runParser' :: Parse a -> Text -> a-runParser' p = checkValidParse . fst . runParser p'+runParser' p = checkValidParseWithRest . runParser p' where p' = p `discard` (whitespace *> eof) @@ -158,6 +160,15 @@ checkValidParse (Left err) = throw (NotDotCode err) checkValidParse (Right a) = a +-- | If unable to parse /Dot/ code properly, 'throw' a+-- 'GraphvizException', with the error containing the remaining+-- unparsed code..+checkValidParseWithRest :: (Either String a, Text) -> a+checkValidParseWithRest (Left err, rst) = throw (NotDotCode err')+ where+ err' = err ++ "\n\nRemaining input:\n\t" ++ show rst+checkValidParseWithRest (Right a,_) = a+ -- | Parse the required value with the assumption that it will parse -- all of the input 'Text'. parseIt' :: (ParseDot a) => Text -> a@@ -238,6 +249,11 @@ -- This will also take care of quoted versions of -- above. quotedParse quotedString++instance ParseDot ST.Text where+ parseUnqt = T.toStrict <$> parseUnqt++ parse = T.toStrict <$> parse instance (ParseDot a) => ParseDot [a] where parseUnqt = parseUnqtList
Data/GraphViz/PreProcessing.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ {- | Module : Data.GraphViz.PreProcessing Description : Pre-process imported Dot code.@@ -9,7 +11,7 @@ parseable by this library. This module defines the 'preProcess' function to remove these components, which include: - * Comments (both @\/* ... *\/@ style and @\/\/ ... @ style);+ * Comments (both @\/\* ... *\/@ style and @\/\/ ... @ style); * Pre-processor lines (lines starting with a @#@); @@ -21,14 +23,17 @@ -} module Data.GraphViz.PreProcessing(preProcess) where +import Data.GraphViz.Exception (GraphvizException (NotDotCode), throw) import Data.GraphViz.Parsing-import Data.GraphViz.Exception(GraphvizException(NotDotCode), throw) -import qualified Data.Text.Lazy as T-import Data.Text.Lazy(Text)+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as T+import Data.Text.Lazy.Builder (Builder) import qualified Data.Text.Lazy.Builder as B-import Data.Text.Lazy.Builder(Builder)-import Data.Monoid(Monoid(..), mconcat)++#if !(MIN_VERSION_base(4,8,0))+import Data.Monoid (Monoid (..), mconcat)+#endif -- ----------------------------------------------------------------------------- -- Filtering out unwanted Dot items such as comments
Data/GraphViz/Printing.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE FlexibleInstances, OverloadedStrings, TypeSynonymInstances #-}+{-# LANGUAGE CPP, FlexibleInstances, GeneralizedNewtypeDeriving,+ OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {- |@@ -48,6 +49,8 @@ module Data.GraphViz.Printing ( module Text.PrettyPrint.Leijen.Text.Monadic , DotCode+ , DotCodeM+ , runDotCode , renderDot -- Exported for Data.GraphViz.Types.Internal.Common.printSGID , PrintDot(..) , unqtText@@ -70,10 +73,11 @@ import Data.GraphViz.Attributes.ColorScheme -- Only implicitly import and re-export combinators.+import qualified Data.Text as ST import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as T-import Text.PrettyPrint.Leijen.Text.Monadic hiding (Pretty (..),- SimpleDoc (..), bool,+import Text.PrettyPrint.Leijen.Text.Monadic hiding (Pretty(..),+ SimpleDoc(..), bool, displayIO, displayT, hPutDoc, putDoc, renderCompact,@@ -81,25 +85,69 @@ width, (<$>)) import qualified Text.PrettyPrint.Leijen.Text.Monadic as PP -import Control.Monad (ap, when)-import Control.Monad.Trans.State-import Data.Char (toLower)-import qualified Data.Set as Set-import Data.Version (Version (..))-import Data.Word (Word16, Word8)+import Control.Monad (ap, when)+import Control.Monad.State (MonadState, State, evalState, gets,+ modify)+import Data.Char (toLower)+import qualified Data.Set as Set+import Data.String (IsString(..))+import Data.Version (Version(..))+import Data.Word (Word64, Word32, Word16, Word8) +#if !(MIN_VERSION_base (4,11,0))++#if !(MIN_VERSION_base (4,8,0))+import Control.Applicative (Applicative)+import Data.Monoid (Monoid(..))+#endif++#if MIN_VERSION_base (4,9,0) && !MIN_VERSION_base (4,13,0)+import Data.Semigroup (Semigroup(..))+#else+import Data.Monoid ((<>))+#endif++#endif+ -- ----------------------------------------------------------------------------- -- | A type alias to indicate what is being produced.-type DotCode = State GraphvizState Doc+newtype DotCodeM a = DotCodeM { getDotCode :: State GraphvizState a }+ deriving (Functor, Applicative, Monad, MonadState GraphvizState) +type DotCode = DotCodeM Doc++runDotCode :: DotCode -> Doc+runDotCode = (`evalState` initialState) . getDotCode+ instance Show DotCode where showsPrec d = showsPrec d . renderDot +instance IsString DotCode where+ fromString = PP.string . fromString++#if MIN_VERSION_base (4,9,0)+instance Semigroup DotCode where+ (<>) = beside++instance Monoid DotCode where+ mempty = empty+ mappend = (<>)+#else+instance Monoid DotCode where+ mempty = empty+ mappend = beside+#endif++instance GraphvizStateM DotCodeM where+ modifyGS = modify++ getsGS = gets+ -- | Correctly render Graphviz output. renderDot :: DotCode -> Text renderDot = PP.displayT . PP.renderPretty 0.4 80- . (`evalState` initialState)+ . runDotCode -- | A class used to correctly print parts of the Graphviz Dot language. -- Minimal implementation is 'unqtDot'.@@ -143,6 +191,12 @@ instance PrintDot Word16 where unqtDot = int . fromIntegral +instance PrintDot Word32 where+ unqtDot = unqtDot . toInteger++instance PrintDot Word64 where+ unqtDot = unqtDot . toInteger+ instance PrintDot Double where -- If it's an "integral" double, then print as an integer. This -- seems to match how Graphviz apps use Dot.@@ -189,6 +243,11 @@ toDot = qtString +instance PrintDot ST.Text where+ unqtDot = unqtDot . T.fromStrict++ toDot = qtString . T.fromStrict+ -- | For use with @OverloadedStrings@ to avoid ambiguous type variable errors. unqtText :: Text -> DotCode unqtText = unqtDot@@ -205,11 +264,11 @@ needsQuotes :: Text -> Bool needsQuotes str- | T.null str = True- | isKeyword str = True- | isIDString str = False- | isNumString str = False- | otherwise = True+ | T.null str = True+ | isKeyword str = True+ | isIDString str = False+ | isNumString False str = False+ | otherwise = True addQuotes :: Text -> DotCode -> DotCode addQuotes = bool id dquotes . needsQuotes
Data/GraphViz/Types.hs view
@@ -124,23 +124,22 @@ usedByGraphs, usedByNodes) import Data.GraphViz.Internal.State (GraphvizState) import Data.GraphViz.Internal.Util (bool)-import Data.GraphViz.Parsing (ParseDot (..), adjustErr,- checkValidParse, parse,+import Data.GraphViz.Parsing (ParseDot(..), adjustErr,+ checkValidParseWithRest, parse, parseLiberally, runParserWith) import Data.GraphViz.PreProcessing (preProcess)-import Data.GraphViz.Printing (PrintDot (..), printIt)-import Data.GraphViz.Types.Canonical (DotGraph (..), DotStatements (..),- DotSubGraph (..))-import Data.GraphViz.Types.Internal.Common (DotEdge (..), DotNode (..),- GlobalAttributes (..), GraphID (..),- Number (..), numericValue, withGlob)+import Data.GraphViz.Printing (PrintDot(..), printIt)+import Data.GraphViz.Types.Canonical (DotGraph(..), DotStatements(..),+ DotSubGraph(..))+import Data.GraphViz.Types.Internal.Common (DotEdge(..), DotNode(..),+ GlobalAttributes(..), GraphID(..),+ Number(..), numericValue, withGlob) import Data.GraphViz.Types.State -import Control.Arrow (first, second, (***))-import Control.Monad.Trans.State (evalState, execState, get, modify,- put)-import Data.Text.Lazy (Text)-import qualified Data.Text.Lazy as T+import Control.Arrow (second, (***))+import Control.Monad.State (evalState, execState, get, modify, put)+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as T -- ----------------------------------------------------------------------------- @@ -182,7 +181,7 @@ -- | Change the node values. This function is assumed to be -- /injective/, otherwise the resulting graph will not be -- identical to the original (modulo labels).- mapDotGraph :: (Ord n', DotRepr dg n') => (n -> n') -> dg n -> dg n'+ mapDotGraph :: (DotRepr dg n') => (n -> n') -> dg n -> dg n' -- | Return information on all the clusters contained within this -- 'DotRepr', as well as the top-level 'GraphAttrs' for the@@ -286,9 +285,9 @@ parseDotGraphWith :: (ParseDotRepr dg n) => (GraphvizState -> GraphvizState) -> Text -> dg n-parseDotGraphWith f = fst . prs . preProcess+parseDotGraphWith f = prs . preProcess where- prs = first checkValidParse . runParserWith f parse'+ prs = checkValidParseWithRest . runParserWith f parse' parse' = parse `adjustErr` ("Unable to parse the Dot graph; usually this is because of either:\n\
Data/GraphViz/Types/Canonical.hs view
@@ -32,11 +32,11 @@ > , graphID = Just (Str "G") > , graphStatements = DotStmts { attrStmts = [] > , subGraphs = [ DotSG { isCluster = True- > , subGraphID = Just (Int 0)+ > , subGraphID = Just (Num (Int 0)) > , subGraphStmts = DotStmts { attrStmts = [ GraphAttrs [ style filled > , color LightGray > , textLabel "process #1"]- > , NodeAttrs [style filled, color White]]}+ > , NodeAttrs [style filled, color White]] > , subGraphs = [] > , nodeStmts = [ DotNode "a0" [] > , DotNode "a1" []@@ -47,7 +47,7 @@ > , DotEdge "a2" "a3" [] > , DotEdge "a3" "a0" []]}} > , DotSG { isCluster = True- > , subGraphID = Just (Int 1)+ > , subGraphID = Just (Num (Int 1)) > , subGraphStmts = DotStmts { attrStmts = [ GraphAttrs [textLabel "process #2", color Blue] > , NodeAttrs [style filled]] > , subGraphs = []
Data/GraphViz/Types/Generalised.hs view
@@ -62,7 +62,7 @@ ) where import Data.GraphViz.Algorithms (canonicalise)-import Data.GraphViz.Internal.State (AttributeType (..))+import Data.GraphViz.Internal.State (AttributeType(..)) import Data.GraphViz.Internal.Util (bool) import Data.GraphViz.Parsing import Data.GraphViz.Printing@@ -71,13 +71,12 @@ import Data.GraphViz.Types.Internal.Common import Data.GraphViz.Types.State -import Control.Arrow ((&&&))-import Control.Monad.Trans.State (evalState, execState, get, modify,- put)-import qualified Data.Foldable as F-import Data.Sequence (Seq, (><))-import qualified Data.Sequence as Seq-import qualified Data.Traversable as T+import Control.Arrow ((&&&))+import Control.Monad.State (evalState, execState, get, modify, put)+import qualified Data.Foldable as F+import Data.Sequence (Seq, (><))+import qualified Data.Sequence as Seq+import qualified Data.Traversable as T -- ----------------------------------------------------------------------------- @@ -135,7 +134,6 @@ parse = parseUnqt -- Don't want the option of quoting `adjustErr` ("Not a valid generalised DotGraph\n\t"++)- -- | Assumed to be an injective mapping function. instance Functor DotGraph where
Data/GraphViz/Types/Graph.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE CPP, FlexibleInstances, MultiParamTypeClasses #-} {- | Module : Data.GraphViz.Types.Graph@@ -96,7 +96,7 @@ , removeEmptyClusters ) where -import Data.GraphViz.Algorithms (CanonicaliseOptions (..),+import Data.GraphViz.Algorithms (CanonicaliseOptions(..), canonicaliseOptions) import Data.GraphViz.Algorithms.Clustering import Data.GraphViz.Attributes.Complete (Attributes)@@ -109,19 +109,24 @@ import Data.GraphViz.Types.Internal.Common (partitionGlobal) import qualified Data.GraphViz.Types.State as St -import Control.Applicative (liftA2, (<$>), (<*>))+import Control.Applicative (liftA2, (<|>)) import Control.Arrow ((***)) import qualified Data.Foldable as F import Data.List (delete, foldl', unfoldr) import Data.Map (Map) import qualified Data.Map as M-import Data.Maybe (fromMaybe, mapMaybe)+import Data.Maybe (fromMaybe, mapMaybe,+ maybeToList) import qualified Data.Sequence as Seq import qualified Data.Set as S import Text.ParserCombinators.ReadPrec (prec)-import Text.Read (Lexeme (Ident), lexP, parens,+import Text.Read (Lexeme(Ident), lexP, parens, readPrec) +#if !(MIN_VERSION_base (4,8,0))+import Control.Applicative ((<$>), (<*>))+#endif+ -- ----------------------------------------------------------------------------- -- | A Dot graph that allows graph operations on it.@@ -136,7 +141,7 @@ -- | It should be safe to substitute 'unsafeFromCanonical' for -- 'fromCanonical' in the output of this.-instance (Ord n, Show n) => Show (DotGraph n) where+instance (Show n) => Show (DotGraph n) where showsPrec d dg = showParen (d > 10) $ showString "fromCanonical " . shows (toCanonical dg) @@ -219,14 +224,16 @@ (Cntxt n mc as ps ss) & dg = withValues merge dg' where ps' = toMap ps- ps'' = M.delete n ps'+ ps'' = fromMap (M.delete n ps') ss' = toMap ss- ss'' = M.delete n ss'+ ss'' = fromMap (M.delete n ss') dg' = addNode n mc as dg - merge = addSucc n ps'' . addPred n ss''+ merge = addSuccRev n ps'' . addPredRev n ss''+ -- Add reverse edges . M.adjust (\ni -> ni { _predecessors = ps', _successors = ss' }) n+ -- Add actual edges infixr 5 & @@ -236,26 +243,26 @@ composeList :: (Ord n) => [Context n] -> DotGraph n composeList = foldr (&) emptyGraph -addSucc :: (Ord n) => n -> EdgeMap n -> NodeMap n -> NodeMap n-addSucc = addPS niSucc+addSuccRev :: (Ord n) => n -> [(n, Attributes)] -> NodeMap n -> NodeMap n+addSuccRev = addEdgeLinks niSkip niSucc -addPred :: (Ord n) => n -> EdgeMap n -> NodeMap n -> NodeMap n-addPred = addPS niPred+addPredRev :: (Ord n) => n -> [(n, Attributes)] -> NodeMap n -> NodeMap n+addPredRev = addEdgeLinks niSkip niPred -addPS :: (Ord n) => ((EdgeMap n -> EdgeMap n) -> NodeInfo n -> NodeInfo n)- -> n -> EdgeMap n -> NodeMap n -> NodeMap n-addPS fni t fas nm = t `seq` foldl' addSucc' nm fas'+addEdgeLinks :: (Ord n) => UpdateEdgeMap n -> UpdateEdgeMap n+ -> n -> [(n, Attributes)] -> NodeMap n -> NodeMap n+addEdgeLinks fwd rev f tas = updRev . updFwd where- fas' = fromMap fas+ updFwd = M.adjust addFwd f - addSucc' nm' (f,as) = f `seq` M.alter (addS as) f nm'+ addFwd ni = foldl' (\ni' (t,as) -> fwd (M.insertWith (++) t [as]) ni') ni tas - addS as = Just- . maybe (error "Node not in the graph!")- (fni (M.insertWith (++) t [as]))+ updRev nm = foldl' (\nm' (t,as) -> M.adjust (addRev as) t nm') nm tas --- | Add a node to the current graph. Throws an error if the node--- already exists in the graph.+ addRev as = rev (M.insertWith (++) f [as])++-- | Add a node to the current graph. Merges attributes and edges if+-- the node already exists in the graph. -- -- If the specified cluster does not yet exist in the graph, then it -- will be added (as a sub-graph of the overall graph and no@@ -267,13 +274,17 @@ -> Attributes -> DotGraph n -> DotGraph n-addNode n mc as dg- | n `M.member` ns = error "Node already exists in the graph"- | otherwise = addEmptyCluster mc- $ dg { values = ns' }+addNode n mc as dg = addEmptyCluster mc $ dg { values = ns' } where ns = values dg- ns' = M.insert n (NI mc as M.empty M.empty) ns+ ns' = M.insertWith mergeLogic n (NI mc as M.empty M.empty) ns+ mergeLogic (NI newClust newAttrs newPreds newSuccs) (NI oldClust oldAttrs oldPreds oldSuccs) =+ NI resClust resAttrs resPreds resSuccs+ where+ resClust = newClust <|> oldClust+ resAttrs = unSame $ S.union (toSAttr newAttrs) (toSAttr oldAttrs)+ resPreds = M.unionWith (++) newPreds oldPreds+ resSuccs = M.unionWith (++) newSuccs oldSuccs -- | A variant of 'addNode' that takes in a DotNode (not in a -- cluster).@@ -286,9 +297,7 @@ addEdge :: (Ord n) => n -> n -> Attributes -> DotGraph n -> DotGraph n addEdge f t as = withValues merge where- -- Add the edge assuming it's directed; let the getter functions- -- be smart regarding directedness.- merge = addPred t (M.singleton f [as]) . addSucc f (M.singleton t [as])+ merge = addEdgeLinks niSucc niPred f [(t,as)] -- | A variant of 'addEdge' that takes a 'DotEdge' value. addDotEdge :: (Ord n) => DotEdge n -> DotGraph n -> DotGraph n@@ -343,7 +352,7 @@ -- | Convert this DotGraph into canonical form. All edges are found -- in the outer graph rather than in clusters.-toCanonical :: (Ord n) => DotGraph n -> C.DotGraph n+toCanonical :: DotGraph n -> C.DotGraph n toCanonical dg = C.DotGraph { C.strictGraph = strictGraph dg , C.directedGraph = directedGraph dg , C.graphID = graphID dg@@ -448,7 +457,7 @@ -- | Delete the specified cluster, and makes any clusters or nodes -- within it be in its root cluster (or the overall graph if -- required).-deleteCluster :: (Ord n) => GraphID -> DotGraph n -> DotGraph n+deleteCluster :: GraphID -> DotGraph n -> DotGraph n deleteCluster c dg = withValues (M.map adjNode) . withClusters (M.map adjCluster . M.delete c) $ dg@@ -464,7 +473,7 @@ adjCluster ci = ci { parentCluster = adjParent $ parentCluster ci } -- | Remove clusters with no sub-clusters and no nodes within them.-removeEmptyClusters :: (Ord n) => DotGraph n -> DotGraph n+removeEmptyClusters :: DotGraph n -> DotGraph n removeEmptyClusters dg = dg { clusters = cM' } where cM = clusters dg@@ -529,8 +538,7 @@ sucs = emToDE (DotEdge n) $ _successors ni preds = emToDE (`DotEdge` n) $ n `M.delete` _predecessors ni -emToDE :: (Ord n) => (n -> Attributes -> DotEdge n)- -> EdgeMap n -> [DotEdge n]+emToDE :: (n -> Attributes -> DotEdge n) -> EdgeMap n -> [DotEdge n] emToDE f = map (uncurry f) . fromMap -- | Which cluster (or the root graph) is this cluster in?@@ -576,7 +584,7 @@ instance (Ord n, PrintDot n, ParseDot n) => PPDotRepr DotGraph n -- | Uses the PrintDot instance for canonical 'C.DotGraph's.-instance (Ord n, PrintDot n) => PrintDot (DotGraph n) where+instance (PrintDot n) => PrintDot (DotGraph n) where unqtDot = unqtDot . toCanonical -- | Uses the ParseDot instance for generalised 'G.DotGraph's.@@ -666,7 +674,7 @@ t' = liftA2 (,) t edgeAttributes eM = M.fromList . groupSortCollectBy fst snd -mapNs :: (Ord n, Ord n') => (n -> n') -> DotGraph n -> DotGraph n'+mapNs :: (Ord n') => (n -> n') -> DotGraph n -> DotGraph n' mapNs f (DG st d as mid cs vs) = DG st d as mid cs $ mapNM vs where@@ -683,7 +691,7 @@ cl = M.mapWithKey addPath $ M.mapKeysMonotonic Just cgs - addPath c as = ( maybe [] (:[]) $ c `M.lookup` pM+ addPath c as = ( maybeToList $ c `M.lookup` pM , as ) @@ -691,8 +699,7 @@ (p' Seq.:> _) -> p' _ -> Seq.empty -getNodeInfo :: (Ord n) => Bool -> DotGraph n- -> NodeLookup n+getNodeInfo :: Bool -> DotGraph n -> NodeLookup n getNodeInfo withGlob dg = M.map toLookup ns where (gGlob, aM) = globAttrMap nodeAs dg@@ -709,7 +716,7 @@ as' | withGlob = unSame $ toSAttr as `S.union` pAs | otherwise = as -getEdgeInfo :: (Ord n) => Bool -> DotGraph n -> [DotEdge n]+getEdgeInfo :: Bool -> DotGraph n -> [DotEdge n] getEdgeInfo withGlob dg = concatMap (uncurry mkDotEdges) es where gGlob = edgeAs $ graphAttrs dg@@ -757,8 +764,7 @@ -- ----------------------------------------------------------------------------- -withValues :: (Ord n) => (NodeMap n -> NodeMap n)- -> DotGraph n -> DotGraph n+withValues :: (NodeMap n -> NodeMap n) -> DotGraph n -> DotGraph n withValues f dg = dg { values = f $ values dg } withClusters :: (Map GraphID ClusterInfo -> Map GraphID ClusterInfo)@@ -777,11 +783,16 @@ , EdgeAttrs $ unSame ea ] -niSucc :: (Ord n) => (EdgeMap n -> EdgeMap n) -> NodeInfo n -> NodeInfo n+type UpdateEdgeMap n = (EdgeMap n -> EdgeMap n) -> NodeInfo n -> NodeInfo n++niSucc :: UpdateEdgeMap n niSucc f ni = ni { _successors = f $ _successors ni } -niPred :: (Ord n) => (EdgeMap n -> EdgeMap n) -> NodeInfo n -> NodeInfo n+niPred :: UpdateEdgeMap n niPred f ni = ni { _predecessors = f $ _predecessors ni }++niSkip :: UpdateEdgeMap n+niSkip _ ni = ni toMap :: (Ord n) => [(n, Attributes)] -> EdgeMap n toMap = M.fromAscList . groupSortCollectBy fst snd
Data/GraphViz/Types/Internal/Common.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP, OverloadedStrings #-} {-# OPTIONS_HADDOCK hide #-} {- |@@ -32,8 +32,8 @@ , parseStatements ) where -import Data.GraphViz.Attributes.Complete (Attribute (HeadPort, TailPort),- Attributes, Number (..),+import Data.GraphViz.Attributes.Complete (Attribute(HeadPort, TailPort),+ Attributes, Number(..), usedByClusters, usedByGraphs, usedByNodes) import Data.GraphViz.Attributes.Internal (PortPos, parseEdgeBasedPP)@@ -48,6 +48,10 @@ import qualified Data.Text.Lazy as T import qualified Data.Text.Lazy.Read as T +#if !MIN_VERSION_base (4,13,0)+import Data.Monoid ((<>))+#endif+ -- ----------------------------------------------------------------------------- -- This is re-exported by Data.GraphViz.Types @@ -76,7 +80,7 @@ stringNum :: Text -> GraphID stringNum str = maybe checkDbl (Num . Int) $ stringToInt str where- checkDbl = if isNumString str+ checkDbl = if isNumString True str then Num . Dbl $ toDouble str else Str str @@ -277,12 +281,12 @@ -- | Takes into account edge statements containing something like -- @a -> \{b c\}@. parseEdgeNodes :: (ParseDot n) => Parse [EdgeNode n]-parseEdgeNodes = parseBraced ( wrapWhitespace- -- Should really use sepBy1, but this will do.- $ parseStatements parseEdgeNode- )- `onFail`- fmap (:[]) parseEdgeNode+parseEdgeNodes = oneOf [ parseBraced (wrapWhitespace+ -- Should really use sepBy1, but this will do.+ $ parseStatements parseEdgeNode)+ , sepBy1 parseEdgeNode (wrapWhitespace parseComma)+ , (: []) <$> parseEdgeNode+ ] parseEdgeNode :: (ParseDot n) => Parse (EdgeNode n) parseEdgeNode = liftA2 (,) parse
Data/GraphViz/Types/Monadic.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE CPP, FlexibleInstances, MultiParamTypeClasses #-} {- | Module : Data.GraphViz.Types.Monadic@@ -64,12 +64,15 @@ , nodeAttrs , edgeAttrs -- * Adding items to the graph.- -- ** Clusters+ -- ** Subgraphs and clusters+ , subgraph+ , anonSubgraph , cluster -- ** Nodes , node , node' -- ** Edges+ -- $edges , edge , (-->) , (<->)@@ -78,11 +81,21 @@ import Data.GraphViz.Attributes (Attributes) import Data.GraphViz.Types.Generalised -import Control.Applicative (Applicative (..))-import Data.DList (DList)-import qualified Data.DList as DL-import qualified Data.Sequence as Seq+import Data.DList (DList)+import qualified Data.DList as DL+import qualified Data.Sequence as Seq +#if !(MIN_VERSION_base (4,8,0))+import Control.Applicative (Applicative(..))+import Data.Monoid (Monoid(..))+#endif++#if MIN_VERSION_base (4,9,0) && !MIN_VERSION_base (4,13,0)+import Data.Semigroup (Semigroup(..))+#endif++import Control.Monad.Fix (MonadFix (mfix))+ -- ----------------------------------------------------------------------------- -- The Dot monad. @@ -113,6 +126,19 @@ ~(b,stmts') = runDot $ f a in (b, stmts `DL.append` stmts') +instance MonadFix (DotM n) where+ mfix m = let (a,n) = runDot $ m a+ in DotM (a,n)++#if MIN_VERSION_base (4,9,0)+instance Semigroup a => Semigroup (DotM n a) where+ DotM x1 <> DotM x2 = DotM (x1 <> x2)+#endif++instance Monoid a => Monoid (DotM n a) where+ mappend (DotM x1) (DotM x2) = DotM (mappend x1 x2)+ mempty = DotM mempty+ tell :: DotStmts n -> Dot n tell = DotM . (,) () @@ -157,21 +183,21 @@ convertStatements = Seq.fromList . map convertStatement . DL.toList data DotStmt n = MA GlobalAttributes- | MC (Cluster n)+ | MS (Subgraph n) | MN (DotNode n) | ME (DotEdge n) convertStatement :: DotStmt n -> DotStatement n convertStatement (MA gas) = GA gas-convertStatement (MC cl) = SG . DotSG True (Just $ clID cl)- . execStmts $ clStmts cl+convertStatement (MS sg) = SG . DotSG (sgIsClust sg) (sgID sg)+ . execStmts $ sgStmts sg convertStatement (MN dn) = DN dn convertStatement (ME de) = DE de -- ----------------------------------------------------------------------------- -- Global Attributes --- | Add graph/sub-graph/cluster attributes.+-- | Add graph\/sub-graph\/cluster attributes. graphAttrs :: Attributes -> Dot n graphAttrs = tellStmt . MA . GraphAttrs @@ -184,15 +210,32 @@ edgeAttrs = tellStmt . MA . EdgeAttrs -- -------------------------------------------------------------------------------- Clusters+-- Subgraphs (including Clusters) -data Cluster n = Cl { clID :: GraphID- , clStmts :: Dot n- }+data Subgraph n = Sg { sgIsClust :: Bool+ , sgID :: Maybe GraphID+ , sgStmts :: Dot n+ } +-- | Add a named subgraph to the graph.+subgraph :: GraphID -> DotM n a -> Dot n+subgraph = nonClust . Just++-- | Add an anonymous subgraph to the graph.+--+-- It is highly recommended you use 'subgraph' instead.+anonSubgraph :: DotM n a -> Dot n+anonSubgraph = nonClust Nothing++nonClust :: Maybe GraphID -> DotM n a -> Dot n+nonClust = createSubGraph False++createSubGraph :: Bool -> Maybe GraphID -> DotM n a -> Dot n+createSubGraph isCl mid = tellStmt . MS . Sg isCl mid . (>> return ())+ -- | Add a named cluster to the graph.-cluster :: GraphID -> DotM n a -> Dot n-cluster cid = tellStmt . MC . Cl cid . (>> return ())+cluster :: GraphID -> DotM n a -> Dot n+cluster = createSubGraph True . Just -- ----------------------------------------------------------------------------- -- Nodes@@ -207,6 +250,23 @@ -- ----------------------------------------------------------------------------- -- Edges++{- $edges++ If you wish to use something analogous to Dot's ability to write+ multiple edges with in-line subgraphs such as:++ > {a b c} -> {d e f}++ Then you can use '-->' and '<->' in combination with monadic+ traversal functions such as @traverse_@, @for_@, @mapM_@, @forM_@+ and @zipWithM_@; for example:++ > ("a" -->) `traverse_` ["d", "e", "f"]+ > ["a", "b", "c"] `for_` (--> "d")+ > zipWithM_ (-->) ["a", "b", "c"] ["d", "e", "f"]++ -} -- | Add an edge to the graph. edge :: n -> n -> Attributes -> Dot n
Data/GraphViz/Types/State.hs view
@@ -39,17 +39,17 @@ import Data.GraphViz.Attributes.Same import Data.GraphViz.Types.Internal.Common -import Control.Arrow ((&&&), (***))-import Control.Monad (when)-import Control.Monad.Trans.State-import Data.DList (DList)-import qualified Data.DList as DList-import Data.Function (on)-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Sequence (Seq, ViewL (..), (|>))-import qualified Data.Sequence as Seq-import qualified Data.Set as Set+import Control.Arrow ((&&&), (***))+import Control.Monad (when)+import Control.Monad.State (State, execState, gets, modify)+import Data.DList (DList)+import qualified Data.DList as DList+import Data.Function (on)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Sequence (Seq, ViewL(..), (|>))+import qualified Data.Sequence as Seq+import qualified Data.Set as Set -- ----------------------------------------------------------------------------- @@ -168,10 +168,10 @@ type NodeState n a = GVState (NodeLookup' n) a -toDotNodes :: (Ord n) => NodeLookup n -> [DotNode n]+toDotNodes :: NodeLookup n -> [DotNode n] toDotNodes = map (\(n,(_,as)) -> DotNode n as) . Map.assocs -getNodeLookup :: (Ord n) => Bool -> NodeState n a -> NodeLookup n+getNodeLookup :: Bool -> NodeState n a -> NodeLookup n getNodeLookup addGs = Map.map combine . value . (`execState` initState) where initState = SV Set.empty addGs Seq.empty Map.empty
FAQ.md view
@@ -1,5 +1,3 @@-% FAQ-% Ivan Lazar Miljenovic Fortuitously Anticipated Queries (FAQ) ======================================@@ -200,16 +198,16 @@ Also on its [HackageDB] page. -### Is it safe to install and use _graphviz_ from its darcs repository? ###+### Is it safe to install and use _graphviz_ from its git repository? ### No; unlike other projects I make no guarantees as to the stability of-the live version of _graphviz_. Whilst the [darcs] [repository] is+the live version of _graphviz_. Whilst the [git] [repository] is _usually_ stable, it's often in a state of flux and at times patches that break the repository are recorded (when it's simpler/cleaner to break one patch into several smaller patches). -[darcs]: http://darcs.net/-[repository]: http://hub.darcs.net/ivanm/graphviz+[git]: http://git-scm.com/+[repository]: https://github.com/ivan-m/graphviz/ ### How is _graphviz_ licensed? ### @@ -227,7 +225,7 @@ used. [Matthew Sackman]: http://www.wellquite.org/-[email]: mailto:Ivan.Miljenovic+graphviz@gmail.com+[email]: mailto:Ivan.Miljenovic@gmail.com ### Where can I find more information on _graphviz_? ### @@ -602,33 +600,21 @@ ### 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.+Oh-oh... please file a report at the GitHub [repository] to tell me+the specifics of what you were doing (including the Dot file in+question if it's a parsing problem) and I'll get right on it. ### I have a feature request. ### -Is it in the TODO? If not, [email] me and I'll consider implementing-it (depending on time and how well I think it will fit in the overall-library).+Is it in the TODO? If not, file an issue at the GitHub [repository]+and I'll consider implementing it (depending on time and how well I+think it will fit in the overall library). ### I want to help out with developing _graphviz_. ### Great! Whether you have a specific feature in mind or want to help-clear the TODO list, please [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://hub.darcs.net/ivanm/graphviz-~~~~~~~~~~~~~~~~~~~~--Once you've made your changes, make sure you build and run the-testsuite (and ensure it passes!). Then record the patch[es] and-`darcs send` them. I'll then review them and if I'm happy with them,-I'll apply them.+clear the TODO list, please create a pull-request on the GitHub+[repository]. ### What is the purpose of the AttributeGenerator.hs file? ###
LICENSE.md view
@@ -1,5 +1,3 @@-% License-% Ivan Lazar Miljenovic Licensing Information =====================
README.md view
@@ -1,5 +1,3 @@-% Haskell bindings to the Graphviz toolkit-% Ivan Lazar Miljenovic The graphviz Library ====================@@ -53,6 +51,3 @@ \(C\) 2008 - onwards [Ivan Lazar Miljenovic](http://ivanmiljenovic.wordpress.com/) [3-Clause BSD License]: http://www.opensource.org/licenses/bsd-license.php--For more information, feel free to-[email](mailto:Ivan.Miljenovic+graphviz@gmail.com) me.
− Setup.hs
@@ -1,4 +0,0 @@-#!/usr/bin/env runghc--import Distribution.Simple-main = defaultMain
TODO.md view
@@ -1,5 +1,3 @@-% TODO-% Ivan Lazar Miljenovic Future Plans for graphviz =========================
graphviz.cabal view
@@ -1,6 +1,5 @@ Name: graphviz-Version: 2999.17.0.2-Stability: Beta+Version: 2999.20.2.1 Synopsis: Bindings to Graphviz for graph visualisation. Description: { This library provides bindings for the Dot language used by the@@ -30,25 +29,17 @@ augment node and edge labels with positional information, etc. } -Homepage: http://projects.haskell.org/graphviz/ Category: Graphs, Graphics License: BSD3 License-File: LICENSE.md Copyright: Matthew Sackman, Ivan Lazar Miljenovic Author: Matthew Sackman, Ivan Lazar Miljenovic-Maintainer: Ivan.Miljenovic+graphviz@gmail.com-Bug-Reports: http://hub.darcs.net/ivanm/graphviz/issues+Maintainer: Daniel Casanueva (coding `at` danielcasanueva.eu) Build-Type: Simple-Cabal-Version: >= 1.14-Extra-Source-Files: TODO.md- Changelog.md- README.md- FAQ.md- utils/AttributeGenerator.hs--Source-Repository head- Type: darcs- Location: http://hub.darcs.net/ivanm/graphviz+Cabal-Version: 1.18+Extra-Doc-Files: TODO.md, Changelog.md, README.md, FAQ.md+Extra-Source-Files: utils/AttributeGenerator.hs+Bug-Reports: https://codeberg.org/daniel-casanueva/graphviz/issues Flag test-parsing Description: Build a utility to test parsing of available Dot code.@@ -57,20 +48,20 @@ Library { Default-Language: Haskell2010 - Build-Depends: base == 4.*,+ Build-Depends: base >=4.5.0.0 && <5, containers, process, directory,- temporary >=1.1 && <1.3,- fgl >= 5.4 && < 5.6,+ temporary >=1.1 && <1.4,+ fgl >= 5.4 && < 5.9, filepath,- polyparse >=1.9 && <1.12,- bytestring >= 0.9 && < 0.11,+ polyparse >=1.9 && <1.14,+ bytestring >= 0.9, colour == 2.3.*,- transformers >= 0.2 && < 0.5,+ mtl == 2.*, text,- wl-pprint-text >= 1.1.0.0 && < 1.2.0.0,- dlist >= 0.5 && < 0.8+ wl-pprint-text == 1.2.*,+ dlist >= 0.5 && < 1.1 Exposed-Modules: Data.GraphViz Data.GraphViz.Types@@ -106,13 +97,7 @@ Data.GraphViz.Commands.Available Data.GraphViz.Types.State - if True- Ghc-Options: -Wall-- if impl(ghc >= 6.12.1)- Ghc-Options: -fno-warn-unused-do-bind-- Ghc-Prof-Options: -prof -auto-all+ Ghc-Options: -Wall } Test-Suite graphviz-testsuite {@@ -124,34 +109,47 @@ Build-Depends: base, graphviz, containers,- fgl,+ fgl >= 5.5.0.0,+ fgl-arbitrary == 0.2.*, filepath,+ hspec >= 2.1 && < 3, text,- QuickCheck >= 2.3 && < 2.8+ QuickCheck >= 2.3 && < 2.16+ Build-Tool-Depends: hspec-discover:hspec-discover == 2.* hs-Source-Dirs: tests - Main-Is: RunTests.hs+ Main-Is: Main.hs - Other-Modules: Data.GraphViz.Testing- Data.GraphViz.Testing.Instances+ Other-Modules: Data.GraphViz.Testing.Instances Data.GraphViz.Testing.Properties- Data.GraphViz.Testing.Instances.FGL Data.GraphViz.Testing.Instances.Helpers Data.GraphViz.Testing.Instances.Attributes Data.GraphViz.Testing.Instances.Common Data.GraphViz.Testing.Instances.Canonical Data.GraphViz.Testing.Instances.Generalised Data.GraphViz.Testing.Instances.Graph+ Data.GraphViz.Testing.Proxy + Data.GraphVizSpec+ Data.GraphViz.AlgorithmsSpec+ Data.GraphViz.Attributes.CompleteSpec+ Data.GraphViz.Attributes.HTMLSpec+ Data.GraphViz.PreProcessingSpec+ Data.GraphViz.Types.CanonicalSpec+ Data.GraphViz.Types.GeneralisedSpec+ Data.GraphViz.Types.GraphSpec++ Spec+ if True- Ghc-Options: -O -Wall+ Ghc-Options: -Wall if impl(ghc >= 6.12.1) Ghc-Options: -fno-warn-unused-do-bind - GHC-Prof-Options: -auto-all -caf-all -rtsopts+ GHC-Prof-Options: -rtsopts } Benchmark graphviz-printparse {@@ -163,19 +161,15 @@ deepseq, text, graphviz,- criterion >= 0.5 && < 0.9+ criterion >= 0.5 && < 1.7 hs-Source-Dirs: utils Main-Is: Benchmark.hs - if True- Ghc-Options: -O -Wall-- if impl(ghc >= 6.12.1)- Ghc-Options: -fno-warn-unused-do-bind+ Ghc-Options: -Wall - GHC-Prof-Options: -auto-all -caf-all -rtsopts+ GHC-Prof-Options: -rtsopts } Executable graphviz-testparsing {@@ -197,7 +191,7 @@ filepath, text - Ghc-Options: -O -Wall+ Ghc-Options: -Wall - GHC-Prof-Options: -auto-all -caf-all -rtsopts+ GHC-Prof-Options: -rtsopts }
+ tests/Data/GraphViz/AlgorithmsSpec.hs view
@@ -0,0 +1,37 @@+{- |+ Module : Data.GraphViz.AlgorithmsSpec+ Description : Testing algorithms+ Copyright : Matthew Sackman, Ivan Lazar Miljenovic+ License : BSD3+ Maintainer : Ivan.Miljenovic@gmail.com++++ -}+module Data.GraphViz.AlgorithmsSpec (spec) where++import Data.GraphViz.Algorithms (CanonicaliseOptions)+import Data.GraphViz.Testing.Instances ()+import Data.GraphViz.Testing.Properties (prop_canonicalise,+ prop_canonicaliseEdges,+ prop_canonicaliseNodes,+ prop_transitive, prop_transitiveNodes)+import Data.GraphViz.Types.Canonical (DotGraph)++import Test.Hspec (Spec)+import Test.Hspec.QuickCheck (prop)++--------------------------------------------------------------------------------++spec :: Spec+spec = do+ prop "Canonicalisation should be idempotent"+ (prop_canonicalise :: CanonicaliseOptions -> DotGraph Int -> Bool)+ prop "Canonicalisation shouldn't change any nodes"+ (prop_canonicaliseNodes :: CanonicaliseOptions -> DotGraph Int -> Bool)+ prop "Canonicalisation shouldn't change any edges"+ (prop_canonicaliseEdges :: CanonicaliseOptions -> DotGraph Int -> Bool)+ prop "Transitive reduction should be idempotent"+ (prop_transitive :: CanonicaliseOptions -> DotGraph Int -> Bool)+ prop "Transitive reduction shouldn't change any nodes"+ (prop_transitiveNodes :: CanonicaliseOptions -> DotGraph Int -> Bool)
+ tests/Data/GraphViz/Attributes/CompleteSpec.hs view
@@ -0,0 +1,26 @@+{- |+ Module : Data.GraphViz.Attributes.CompleteSpec+ Description : Attribute testing+ Copyright : Ivan Lazar Miljenovic+ License : BSD3+ Maintainer : Ivan.Miljenovic@gmail.com++++ -}+module Data.GraphViz.Attributes.CompleteSpec (spec) where++import Data.GraphViz.Attributes.Complete (Attributes)+import Data.GraphViz.Testing.Instances ()+import Data.GraphViz.Testing.Properties (prop_printParseListID)++import Test.Hspec (Spec)+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck (Property)++--------------------------------------------------------------------------------++spec :: Spec+spec =+ prop "Printing and parsing of attributes"+ (prop_printParseListID :: Attributes -> Property)
+ tests/Data/GraphViz/Attributes/HTMLSpec.hs view
@@ -0,0 +1,26 @@+{- |+ Module : Data.GraphViz.Attributes.HTMLSpec+ Description : HTML label testing+ Copyright : Ivan Lazar Miljenovic+ License : BSD3+ Maintainer : Ivan.Miljenovic@gmail.com++ This is in addition to "Data.GraphViz.Attributes.CompleteSpec" as+ HTML labels are also likely to have their own quirks for testing.++ -}+module Data.GraphViz.Attributes.HTMLSpec (spec) where++import Data.GraphViz.Attributes.HTML (Label)+import Data.GraphViz.Testing.Instances ()+import Data.GraphViz.Testing.Properties (prop_printParseID)++import Test.Hspec (Spec)+import Test.Hspec.QuickCheck (prop)++--------------------------------------------------------------------------------++spec :: Spec+spec =+ prop "Printing and parsing of HTML labels"+ (prop_printParseID :: Label -> Bool)
+ tests/Data/GraphViz/PreProcessingSpec.hs view
@@ -0,0 +1,24 @@+{- |+ Module : Data.GraphViz.PreProcessingSpec+ Description : Test pre-processing+ Copyright : Matthew Sackman, Ivan Lazar Miljenovic+ License : BSD3+ Maintainer : Ivan.Miljenovic@gmail.com++++ -}+module Data.GraphViz.PreProcessingSpec where++import Data.GraphViz.Testing.Instances ()+import Data.GraphViz.Testing.Properties (prop_preProcessingID)+import Data.GraphViz.Types.Canonical (DotGraph)++import Test.Hspec (Spec)+import Test.Hspec.QuickCheck (prop)++--------------------------------------------------------------------------------++spec :: Spec+spec = prop "Preprocessing doesn't change Dot code"+ (prop_preProcessingID :: DotGraph Int -> Bool)
− tests/Data/GraphViz/Testing.hs
@@ -1,459 +0,0 @@-{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, Rank2Types #-}--{- |- Module : Data.GraphViz.Testing- Description : Test-suite for graphviz.- Copyright : (c) Ivan Lazar Miljenovic- License : 3-Clause BSD-style- Maintainer : Ivan.Miljenovic@gmail.com-- This defines a test-suite for the graphviz library.-- Limitations of the test suite are as follows:-- * For the most part, this library lets you use arbitrary numbers- for String values. However, this is not tested due to too many- corner cases for special parsers that don't take arbitrary- Strings. As the Dot standard is ambiguous over whether you can- or can't use numbers as Strings (more specifically, if they- should be quoted or not), this is a user beware situation.-- * Same goes for empty Strings; sometimes they're allowed, sometimes- they're not. Thus, to simplify matters they're not generated.-- * The generated Strings are very simple, only composed of lower- case letters, digits and some symbols. This is because too many- tests were \"failing\" due to some corner case; e.g. lower-case- letters only because the parser parses Strings as lowercase, so- if a particular String isn't valid (e.g. @\"all\"@ for 'LayerID',- then the 'Arbitrary' instance has to ensure that all possible- ways of capitalising that String isn't generated as a random- 'LRName'.-- * The generated 'DotRepr's are not guaranteed to be valid.-- * To avoid needless endless recursion, sub-graphs do not have their- own internal sub-graphs.-- * This test suite isn't perfect: if you deliberately try to stuff- something up, you probably can.--}-module Data.GraphViz.Testing- ( -- * Running the test suite.- runChosenTests- , runTests- , runTest- -- ** The tests themselves- , Test(..)- , defaultTests- , allTests- , test_printParseID_Attributes- , test_generalisedSameDot- , test_printParseID- , test_preProcessingID- , test_dotizeAugment- , test_dotizeHasAugment- , test_dotizeAugmentUniq- , test_canonicalise- , test_canonicaliseNodes- , test_canonicaliseEdges- , test_transitive- , test_transitiveNodes- -- * Re-exporting modules for manual testing.- , module Data.GraphViz- , module Data.GraphViz.Testing.Properties- -- * Debugging printing- , PrintDot(..)- , printIt- , renderDot- -- * Debugging parsing- , ParseDot(..)- , parseIt- , parseIt'- , runParser- , preProcess- ) where--import Test.QuickCheck--import Data.GraphViz.Testing.Instances ()-import Data.GraphViz.Testing.Properties--import Data.GraphViz-import Data.GraphViz.Algorithms (CanonicaliseOptions)-import Data.GraphViz.Parsing (parseIt, parseIt', runParser)-import Data.GraphViz.PreProcessing (preProcess)-import Data.GraphViz.Printing (printIt, renderDot)-import qualified Data.GraphViz.Types.Generalised as G-import qualified Data.GraphViz.Types.Graph as Gr--- Can't use PatriciaTree because a Show instance is needed.-import Data.Graph.Inductive.Tree (Gr)--import System.Exit (ExitCode (..), exitWith)-import System.IO (hPutStrLn, stderr)---- -------------------------------------------------------------------------------runChosenTests :: [Test] -> IO ()-runChosenTests tsts = do putStrLn msg- blankLn- runTests tsts- spacerLn- putStrLn successMsg- where- msg = "This is the test suite for the graphviz library.\n\- \If any of these tests fail, please inform the maintainer,\n\- \including full output of this test suite."-- successMsg = "All tests were successful!"----- -------------------------------------------------------------------------------- Defining a Test structure and how to run tests.---- | Defines the test structure being used.-data Test = Test { name :: String- , lookupName :: String -- ^ Should be lowercase- , desc :: String- , tests :: [IO Result] -- ^ QuickCheck test.- }---- | Run all of the provided tests.-runTests :: [Test] -> IO ()-runTests = mapM_ ((>>) spacerLn . runTest)---- | Run the provided test.-runTest :: Test -> IO ()-runTest tst = do putStrLn title- blankLn- putStrLn $ desc tst- blankLn- run $ tests tst- blankLn- where- nm = '"' : name tst ++ "\""- title = "Running test: " ++ nm ++ "."- successMsg = "All tests for " ++ nm ++ " were successful!"- gaveUpMsg = "Too many sample inputs for " ++ nm ++ " were rejected;\n\- \tentatively marking this as successful."- failMsg = "The tests for " ++ nm ++ " failed!\n\- \Not attempting any further tests."-- run [] = putStrLn successMsg- run (t:ts) = do r <- t- case r of- Success{} -> run ts- GaveUp{} -> putStrLn gaveUpMsg >> run ts- _ -> die failMsg--spacerLn :: IO ()-spacerLn = putStrLn (replicate 70 '=') >> blankLn--blankLn :: IO ()-blankLn = putStrLn ""--die :: String -> IO a-die msg = do hPutStrLn stderr msg- exitWith (ExitFailure 1)--qCheck :: (Testable prop) => prop -> IO Result-qCheck = quickCheckWithResult (stdArgs { maxSize = 50, maxSuccess = 200 })---- -------------------------------------------------------------------------------- Defining the tests to use.---- | The tests to run by default.-defaultTests :: [Test]-defaultTests = [ test_printParseID_Attributes- , test_generalisedSameDot- , test_printParseID- , test_preProcessingID- -- These require dot and neato to be installed and- -- configured properly. As such, don't run them by- -- default.-- -- , test_dotizeAugment- -- , test_dotizeHasAugment- -- , test_dotizeAugmentUniq- , test_findAllNodes- , test_findAllNodesE- , test_findAllEdges- , test_noGraphInfo- , test_canonicalise- , test_canonicaliseNodes- , test_canonicaliseEdges- , test_transitive- , test_transitiveNodes- ]---- | All available tests.-allTests :: [Test]-allTests = [ test_printParseID_Attributes- , test_generalisedSameDot- , test_printParseID- , test_preProcessingID- , test_dotizeAugment- , test_dotizeHasAugment- , test_dotizeAugmentUniq- , test_findAllNodes- , test_findAllNodesE- , test_findAllEdges- , test_noGraphInfo- , test_canonicalise- , test_canonicaliseNodes- , test_canonicaliseEdges- , test_transitive- , test_transitiveNodes- ]---- | Test that 'Attributes' can be printed and then parsed back.-test_printParseID_Attributes :: Test-test_printParseID_Attributes- = Test { name = "Printing and parsing of Attributes"- , lookupName = "attributes"- , desc = dsc- , tests = [qCheck prop]- }- where- prop :: Attributes -> Property- prop = prop_printParseListID-- dsc = "The most common source of errors in printing and parsing are for\n\- \Attributes."--test_generalisedSameDot :: Test-test_generalisedSameDot- = Test { name = "Printing generalised Dot code"- , lookupName = "makegeneralised"- , desc = dsc- , tests = [qCheck prop]- }- where- prop :: DotGraph Int -> Bool- prop = prop_generalisedSameDot-- dsc = "When generalising \"DotGraph\" values to other \"DotRepr\" values,\n\- \the generated Dot code should be identical."--test_printParseID :: Test-test_printParseID- = Test { name = "Printing and Parsing DotReprs"- , lookupName = "printparseid"- , desc = dsc- , tests = tsts- }- where- tsts :: [IO Result]- tsts = [ qCheck (prop_printParseID :: DotGraph Int -> Bool)- , qCheck (prop_printParseID :: G.DotGraph Int -> Bool)- , qCheck (prop_printParseID :: Gr.DotGraph Int -> Bool)- ]-- dsc = "The graphviz library should be able to parse back in its own\n\- \generated Dot code for any \"DotRepr\" instance"--test_preProcessingID :: Test-test_preProcessingID- = Test { name = "Pre-processing Dot code"- , lookupName = "preprocessing"- , desc = dsc- , tests = [qCheck prop]- }- where- prop :: DotGraph Int -> Bool- prop = prop_preProcessingID-- dsc = "When parsing Dot code, some pre-processing is done to remove items\n\- \such as comments and to join together multi-line strings. This\n\- \test verifies that this pre-processing doesn't affect actual\n\- \Dot code by running the pre-processor on generated Dot code.\n\n\- \This test is not run on generalised Dot graphs as if it works for\n\- \normal dot graphs then it should also work for generalised ones."--augMsg :: String-augMsg = "\n\nThis requires dot and neato to be installed, and for `dot' to be\n\- \to be in the output of `dot -Txxx`."--test_dotizeAugment :: Test-test_dotizeAugment- = Test { name = "Augmenting FGL Graphs"- , lookupName = "augment"- , desc = dsc- , tests = [qCheck prop]- }- where- prop :: Gr Char Double -> Bool- prop = prop_dotizeAugment-- dsc = "The various Graph to Graph functions in Data.GraphViz should\n\- \only _augment_ the graph labels and not change the graphs\n\- \themselves. This test compares the original graphs to these\n\- \augmented graphs and verifies that they are the same." ++ augMsg--test_dotizeHasAugment :: Test-test_dotizeHasAugment- = Test { name = "Ensuring augmentation of FGL Graphs"- , lookupName = "hasaugment"- , desc = dsc- , tests = [qCheck prop]- }- where- prop :: Gr Char Double -> Bool- prop = prop_dotizeHasAugment-- dsc = "The various Graph to Graph functions in Data.GraphViz should\n\- \actually agument the graph labels; this ensures that all labels\n\- \actually have attached Attributes after augmentation." ++ augMsg--test_dotizeAugmentUniq :: Test-test_dotizeAugmentUniq- = Test { name = "Unique edges in augmented FGL Graphs"- , lookupName = "augmentuniq"- , desc = dsc- , tests = [qCheck prop]- }- where- prop :: Gr Char Double -> Bool- prop = prop_dotizeAugmentUniq-- dsc = "When augmenting a graph with multiple edges, as long as no\n\- \Attributes are provided that override the default settings,\n\- \then each edge between two nodes should have a unique position\n\- \Attribute, etc." ++ augMsg--test_findAllNodes :: Test-test_findAllNodes- = Test { name = "Ensure all nodes are found in a DotRepr"- , lookupName = "findnodes"- , desc = dsc- , tests = map qCheck props- }- where- props :: [Gr () () -> Bool]- props = testAllGraphTypes prop_findAllNodes-- dsc = "nodeInformation should find all nodes in a DotRepr;\n\- \this is tested by converting an FGL graph and comparing\n\- \the nodes it should have to those that are found."--test_findAllNodesE :: Test-test_findAllNodesE- = Test { name = "Ensure all nodes are found in a node-less DotRepr"- , lookupName = "findedgelessnodes"- , desc = dsc- , tests = map qCheck props- }- where- props :: [Gr () () -> Bool]- props = testAllGraphTypes prop_findAllNodesE-- dsc = "nodeInformation should find all nodes in a DotRepr,\n\- \even if there are no explicit nodes in that graph.\n\- \This is tested by converting an FGL graph and comparing\n\- \the nodes it should have to those that are found."--test_findAllEdges :: Test-test_findAllEdges- = Test { name = "Ensure all edges are found in a DotRepr"- , lookupName = "findedges"- , desc = dsc- , tests = map qCheck props- }- where- props :: [Gr () () -> Bool]- props = testAllGraphTypes prop_findAllEdges-- dsc = "nodeInformation should find all edges in a DotRepr;\n\- \this is tested by converting an FGL graph and comparing\n\- \the edges it should have to those that are found."--test_noGraphInfo :: Test-test_noGraphInfo- = Test { name = "Plain DotReprs should have no structural information"- , lookupName = "nographinfo"- , desc = dsc- , tests = map qCheck props- }- where- props :: [Gr () () -> Bool]- props = testAllGraphTypes prop_noGraphInfo-- dsc = "When converting a Graph to a DotRepr, there should be no\n\- \clusters or global attributes."--test_canonicalise :: Test-test_canonicalise- = Test { name = "Canonicalisation should be idempotent"- , lookupName = "canonicalise"- , desc = dsc- , tests = [qCheck prop]- }- where- prop :: CanonicaliseOptions -> DotGraph Int -> Bool- prop = prop_canonicalise-- dsc = "Repeated application of canonicalise shouldn't have any further affect."--test_canonicaliseNodes :: Test-test_canonicaliseNodes- = Test { name = "Canonicalisation shouldn't change any nodes"- , lookupName = "canonicalisenodes"- , desc = dsc- , tests = [qCheck prop]- }- where- prop :: CanonicaliseOptions -> DotGraph Int -> Bool- prop = prop_canonicaliseNodes-- dsc = "Canonicalisation shouldn't change or remove any nodes."--test_canonicaliseEdges :: Test-test_canonicaliseEdges- = Test { name = "Canonicalisation shouldn't change any edges"- , lookupName = "canonicaliseedges"- , desc = dsc- , tests = [qCheck prop]- }- where- prop :: CanonicaliseOptions -> DotGraph Int -> Bool- prop = prop_canonicaliseEdges-- dsc = "Canonicalisation shouldn't change or remove any edges."--test_transitive :: Test-test_transitive- = Test { name = "Transitive reduction should be idempotent"- , lookupName = "transitive"- , desc = dsc- , tests = [qCheck prop]- }- where- prop :: CanonicaliseOptions -> DotGraph Int -> Bool- prop = prop_transitive-- dsc = "Repeated application of transitiveReduction shouldn't have any further affect."--test_transitiveNodes :: Test-test_transitiveNodes- = Test { name = "Transitive reduction shouldn't change any nodes"- , lookupName = "transitivenodes"- , desc = dsc- , tests = [qCheck prop]- }- where- prop :: CanonicaliseOptions -> DotGraph Int -> Bool- prop = prop_transitiveNodes-- dsc = "Transitive reduction shouldn't change or remove any nodes."---- --------------------------------------------------------------------------------- | Used when a property takes in a DotRepr as the first argument to--- indicate which instance it should test via 'fromCanonical'.-testAllGraphTypes :: (Testable prop)- => (forall dg. (Eq (dg Int), DotRepr dg Int) => dg Int -> prop)- -> [prop]-testAllGraphTypes prop = [ prop (undefined :: DotGraph Int)- , prop (undefined :: G.DotGraph Int)- , prop (undefined :: Gr.DotGraph Int)- ]
tests/Data/GraphViz/Testing/Instances.hs view
@@ -18,10 +18,9 @@ -} module Data.GraphViz.Testing.Instances() where -import Data.GraphViz.Testing.Instances.FGL()-import Data.GraphViz.Testing.Instances.Canonical()-import Data.GraphViz.Testing.Instances.Generalised()-import Data.GraphViz.Testing.Instances.Graph()+import Data.Graph.Inductive.Arbitrary ()+import Data.GraphViz.Testing.Instances.Canonical ()+import Data.GraphViz.Testing.Instances.Generalised ()+import Data.GraphViz.Testing.Instances.Graph () -- ------------------------------------------------------------------------------
tests/Data/GraphViz/Testing/Instances/Attributes.hs view
@@ -1,6 +1,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK hide #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP, OverloadedStrings #-} {- | Module : Data.GraphViz.Testing.Instances.Attributes@@ -27,7 +27,7 @@ import Data.GraphViz.Attributes.Internal (compassLookup) import Data.GraphViz.Internal.State (initialState, layerListSep, layerSep)-import Data.GraphViz.Internal.Util (bool, createVersion)+import Data.GraphViz.Internal.Util (bool) import Test.QuickCheck @@ -36,9 +36,13 @@ import qualified Data.Map as Map import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as T-import Data.Version (Version (..)) import System.FilePath (searchPathSeparator) +#if !MIN_VERSION_QuickCheck(2,9,0)+import Data.GraphViz.Internal.Util (createVersion)+import Data.Version (Version(..))+#endif+ -- ----------------------------------------------------------------------------- -- Defining Arbitrary instances for Attributes @@ -154,6 +158,7 @@ , liftM NodeSep arbitrary , liftM NoJustify arbitrary , liftM Normalize arbitrary+ , liftM NoTranslate arbitrary , liftM Nslimit arbitrary , liftM Nslimit1 arbitrary , liftM Ordering arbitrary@@ -316,6 +321,7 @@ shrink (NodeSep v) = map NodeSep $ shrink v shrink (NoJustify v) = map NoJustify $ shrink v shrink (Normalize v) = map Normalize $ shrink v+ shrink (NoTranslate v) = map NoTranslate $ shrink v shrink (Nslimit v) = map Nslimit $ shrink v shrink (Nslimit1 v) = map Nslimit1 $ shrink v shrink (Ordering v) = map Ordering $ shrink v@@ -421,7 +427,7 @@ -- Pretty sure points have to be positive... arbitrary = liftM4 Point posArbitrary posArbitrary posZ arbitrary where- posZ = frequency [(1, return Nothing), (3, liftM Just posArbitrary)]+ posZ = liftArbitrary posArbitrary shrink p = do x' <- shrink $ xCoord p y' <- shrink $ yCoord p@@ -657,8 +663,8 @@ , liftM2 StartStyleSeed arbitrary arbitrary ] - shrink StartStyle{} = [] -- No shrinks for STStyle- shrink (StartSeed ss) = map StartSeed $ shrink ss+ shrink StartStyle{} = [] -- No shrinks for STStyle+ shrink (StartSeed ss) = map StartSeed $ shrink ss shrink (StartStyleSeed st ss) = map (StartStyleSeed st) $ shrink ss instance Arbitrary STStyle where@@ -831,8 +837,8 @@ instance Arbitrary Html.Label where arbitrary = sized $ arbHtml True - shrink ht@(Html.Text txts) = delete ht . map Html.Text $ shrinkL txts- shrink (Html.Table tbl) = map Html.Table $ shrink tbl+ shrink (Html.Text txts) = map Html.Text $ listShrink txts+ shrink (Html.Table tbl) = map Html.Table $ shrink tbl -- Note: for the most part, Html.Label values are very repetitive (and -- furthermore, they end up chewing a large amount of memory). As@@ -858,7 +864,7 @@ . sized $ arbHtmlText fnt where- s' = min s 10+ s' = min s 5 -- When parsing, all textual characters are parsed together; thus, -- make sure we generate them like that.@@ -874,9 +880,9 @@ instance Arbitrary Html.TextItem where arbitrary = sized $ arbHtmlText True - shrink (Html.Str str) = map Html.Str $ shrink str- shrink (Html.Newline as) = map Html.Newline $ shrink as- shrink hf@(Html.Font as txt) = do as' <- shrink as+ shrink (Html.Str str) = map Html.Str . filter (not . T.null) . map T.strip $ shrink str+ shrink (Html.Newline as) = map Html.Newline $ shrinkHtmlAttrs as+ shrink hf@(Html.Font as txt) = do as' <- shrinkHtmlAttrs as txt' <- shrinkL txt returnCheck hf $ Html.Font as' txt' shrink (Html.Format _ txt) = txt@@ -889,23 +895,34 @@ else id s' = min 2 s arbRec = resize s' . sized $ arbHtmlTexts False- recHtmlText = [ (1, liftM2 Html.Font arbitrary arbRec)+ recHtmlText = [ (1, liftM2 Html.Font arbHtmlAttrs arbRec) , (3, liftM2 Html.Format arbitrary arbRec) ]- options = allowFonts [ (10, liftM Html.Str arbitrary)- , (10, liftM Html.Newline arbitrary)+ options = allowFonts [ (10, liftM Html.Str (suchThat (liftM T.strip arbitrary) (not . T.null)))+ , (10, liftM Html.Newline arbHtmlAttrs) ] instance Arbitrary Html.Format where arbitrary = arbBounded instance Arbitrary Html.Table where- arbitrary = liftM3 Html.HTable arbitrary arbitrary (sized arbRows)+ arbitrary = liftM3 Html.HTable (liftArbitrary arbHtmlAttrs) arbHtmlAttrs (sized arbRows) where arbRows s = resize (min s 10) arbList - shrink (Html.HTable fas as rs) = map (Html.HTable fas as) $ shrinkL rs+ shrink (Html.HTable fas as rs) = liftM3 Html.HTable shrinkFont (shrinkHtmlAttrs as) (shrinkL rs)+ where+ shrinkFont = liftShrink shrinkHtmlAttrs fas +#if !MIN_VERSION_QuickCheck(2,10,0)+liftArbitrary :: Gen a -> Gen (Maybe a)+liftArbitrary gen = frequency [(1, return Nothing), (3, liftM Just gen)]++liftShrink :: (a -> [a]) -> Maybe a -> [Maybe a]+liftShrink shr (Just x) = Nothing : map Just (shr x)+liftShrink _ Nothing = []+#endif+ instance Arbitrary Html.Row where arbitrary = frequency [ (5, liftM Html.Cells arbList) , (1, return Html.HorizontalRule)@@ -929,6 +946,12 @@ instance Arbitrary Html.Img where arbitrary = liftM Html.Img arbitrary +arbHtmlAttrs :: Gen Html.Attributes+arbHtmlAttrs = sized (\s -> resize (min 5 s) arbitrary)++shrinkHtmlAttrs :: Html.Attributes -> [Html.Attributes]+shrinkHtmlAttrs = listShrink+ instance Arbitrary Html.Attribute where arbitrary = oneof [ liftM Html.Align arbitrary , liftM Html.BAlign arbitrary@@ -939,45 +962,55 @@ , liftM Html.CellSpacing arbitrary , liftM Html.Color arbitrary , liftM Html.ColSpan arbitrary+ , liftM Html.Columns arbitrary , liftM Html.Face arbitrary , liftM Html.FixedSize arbitrary+ , liftM Html.GradientAngle arbitrary , liftM Html.Height arbitrary , liftM Html.HRef arbitrary , liftM Html.ID arbitrary , liftM Html.PointSize arbitrary , liftM Html.Port arbitrary+ , liftM Html.Rows arbitrary , liftM Html.RowSpan arbitrary , liftM Html.Scale arbitrary+ , liftM Html.Sides (fmap nub (sized (\s -> resize (min s 4) arbitrary))) -- Will never have more than 4 values , liftM Html.Src arbString+ , liftM Html.Style arbitrary , liftM Html.Target arbitrary , liftM Html.Title arbitrary , liftM Html.VAlign arbitrary , liftM Html.Width arbitrary ] - shrink (Html.Align v) = map Html.Align $ shrink v- shrink (Html.BAlign v) = map Html.BAlign $ shrink v- shrink (Html.BGColor v) = map Html.BGColor $ shrink v- shrink (Html.Border v) = map Html.Border $ shrink v- shrink (Html.CellBorder v) = map Html.CellBorder $ shrink v- shrink (Html.CellPadding v) = map Html.CellPadding $ shrink v- shrink (Html.CellSpacing v) = map Html.CellSpacing $ shrink v- shrink (Html.Color v) = map Html.Color $ shrink v- shrink (Html.ColSpan v) = map Html.ColSpan $ shrink v- shrink (Html.Face v) = map Html.Face $ shrink v- shrink (Html.FixedSize v) = map Html.FixedSize $ shrink v- shrink (Html.Height v) = map Html.Height $ shrink v- shrink (Html.HRef v) = map Html.HRef $ shrink v- shrink (Html.ID v) = map Html.ID $ shrink v- shrink (Html.PointSize v) = map Html.PointSize $ shrink v- shrink (Html.Port v) = map Html.Port $ shrink v- shrink (Html.RowSpan v) = map Html.RowSpan $ shrink v- shrink (Html.Scale v) = map Html.Scale $ shrink v- shrink (Html.Src v) = map Html.Src $ shrinkString v- shrink (Html.Target v) = map Html.Target $ shrink v- shrink (Html.Title v) = map Html.Title $ shrink v- shrink (Html.VAlign v) = map Html.VAlign $ shrink v- shrink (Html.Width v) = map Html.Width $ shrink v+ shrink (Html.Align v) = map Html.Align $ shrink v+ shrink (Html.BAlign v) = map Html.BAlign $ shrink v+ shrink (Html.BGColor v) = map Html.BGColor $ shrink v+ shrink (Html.Border v) = map Html.Border $ shrink v+ shrink (Html.CellBorder v) = map Html.CellBorder $ shrink v+ shrink (Html.CellPadding v) = map Html.CellPadding $ shrink v+ shrink (Html.CellSpacing v) = map Html.CellSpacing $ shrink v+ shrink (Html.Color v) = map Html.Color $ shrink v+ shrink (Html.ColSpan v) = map Html.ColSpan $ shrink v+ shrink (Html.Columns v) = map Html.Columns $ shrink v+ shrink (Html.Face v) = map Html.Face $ shrink v+ shrink (Html.FixedSize v) = map Html.FixedSize $ shrink v+ shrink (Html.GradientAngle v) = map Html.GradientAngle $ shrink v+ shrink (Html.Height v) = map Html.Height $ shrink v+ shrink (Html.HRef v) = map Html.HRef $ shrink v+ shrink (Html.ID v) = map Html.ID $ shrink v+ shrink (Html.PointSize v) = map Html.PointSize $ shrink v+ shrink (Html.Port v) = map Html.Port $ shrink v+ shrink (Html.Rows v) = map Html.Rows $ shrink v+ shrink (Html.RowSpan v) = map Html.RowSpan $ shrink v+ shrink (Html.Scale v) = map Html.Scale $ shrink v+ shrink (Html.Sides v) = map Html.Sides $ listShrink' v+ shrink (Html.Src v) = map Html.Src $ shrinkString v+ shrink (Html.Style v) = map Html.Style $ shrink v+ shrink (Html.Target v) = map Html.Target $ shrink v+ shrink (Html.Title v) = map Html.Title $ shrink v+ shrink (Html.VAlign v) = map Html.VAlign $ shrink v+ shrink (Html.Width v) = map Html.Width $ shrink v instance Arbitrary Html.Scale where arbitrary = arbBounded@@ -988,6 +1021,15 @@ instance Arbitrary Html.VAlign where arbitrary = arbBounded +instance Arbitrary Html.CellFormat where+ arbitrary = arbBounded++instance Arbitrary Html.Side where+ arbitrary = arbBounded++instance Arbitrary Html.Style where+ arbitrary = arbBounded+ instance Arbitrary PortName where arbitrary = liftM PN $ suchThat arbitrary (liftM2 (&&) (T.all (/=':')) notCP)@@ -1013,10 +1055,12 @@ shrink (NormalizedAngle a) = map NormalizedAngle $ shrink a shrink _ = [] +#if !MIN_VERSION_QuickCheck(2,9,0) instance Arbitrary Version where arbitrary = liftM (createVersion . map getPositive) arbList shrink = map createVersion . nonEmptyShrinks . versionBranch+#endif instance Arbitrary NodeSize where arbitrary = arbBounded
− tests/Data/GraphViz/Testing/Instances/FGL.hs
@@ -1,47 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE FlexibleInstances #-}--{- |- Module : Data.GraphViz.Testing.Instances.FGL- Description : 'Arbitrary' instances for FGL graphs.- Copyright : (c) Ivan Lazar Miljenovic- License : 3-Clause BSD-style- Maintainer : Ivan.Miljenovic@gmail.com-- This module defines the 'Arbitrary' instances for FGL 'DynGraph'- graphs. Note that this instance cannot be in- "Data.GraphViz.Testing.Instances", as this instance requires the- FlexibleInstances extension, which makes some of the other- 'Arbitrary' instances fail to type-check.--}-module Data.GraphViz.Testing.Instances.FGL() where--import Test.QuickCheck--import Data.GraphViz.Internal.Util (uniq)--import Control.Monad (liftM, liftM3)-import Data.Function (on)-import Data.Graph.Inductive.Graph (Graph, delNode, mkGraph, nodes)-import Data.List (sortBy)---- -------------------------------------------------------------------------------- Arbitrary instance for FGL graphs.--instance (Graph g, Arbitrary n, Arbitrary e) => Arbitrary (g n e) where- arbitrary = do ns <- suchThat genNs (not . null)- let nGen = elements ns- lns <- mapM makeLNode ns- les <- liftM (sortBy (compare `on` toE)) . listOf- $ makeLEdge nGen- return $ mkGraph lns les- where- genNs = liftM uniq arbitrary- toE (f,t,_) = (f,t)- makeLNode n = liftM ((,) n) arbitrary- makeLEdge nGen = liftM3 (,,) nGen nGen arbitrary-- shrink gr = case nodes gr of- -- Need to have at least 2 nodes before we delete one!- ns@(_:_:_) -> map (`delNode` gr) ns- _ -> []
tests/Data/GraphViz/Testing/Instances/Helpers.hs view
@@ -66,7 +66,7 @@ shrinkString = map T.unpack . shrink . T.pack notNumStr :: Text -> Bool-notNumStr = not . isNumString+notNumStr = not . isNumString True arbBounded :: (Bounded a, Enum a) => Gen a arbBounded = elements [minBound .. maxBound]
tests/Data/GraphViz/Testing/Properties.hs view
@@ -16,20 +16,21 @@ setDirectedness) import Data.GraphViz.Algorithms import Data.GraphViz.Internal.Util (groupSortBy, isSingle)-import Data.GraphViz.Parsing (ParseDot (..), parseIt,+import Data.GraphViz.Parsing (ParseDot(..), parseIt, parseIt') import Data.GraphViz.PreProcessing (preProcess)-import Data.GraphViz.Printing (PrintDot (..), printIt)-import Data.GraphViz.Types (DotEdge (..), DotNode (..),- DotRepr (..),- GlobalAttributes (..),+import Data.GraphViz.Printing (PrintDot(..), printIt)+import Data.GraphViz.Testing.Proxy (DGProxy(..))+import Data.GraphViz.Types (DotEdge(..), DotNode(..),+ DotRepr(..),+ GlobalAttributes(..), PrintDotRepr, edgeInformationClean, graphEdges, graphNodes, nodeInformationClean, printDotGraph)-import Data.GraphViz.Types.Canonical (DotGraph (..),- DotStatements (..))+import Data.GraphViz.Types.Canonical (DotGraph(..),+ DotStatements(..)) import qualified Data.GraphViz.Types.Generalised as G import Test.QuickCheck@@ -62,7 +63,7 @@ prop_generalisedSameDot :: (Ord n, PrintDot n, ParseDot n) => DotGraph n -> Bool prop_generalisedSameDot dg = printDotGraph dg == printDotGraph gdg where- gdg = canonicalToType (undefined :: G.DotGraph n) dg+ gdg = canonicalToType (DGProxy :: DGProxy G.DotGraph) dg -- | Pre-processing shouldn't change the output of printed Dot code. -- This should work for all 'PrintDot' instances, but is more@@ -98,7 +99,7 @@ -- should have unique 'Attributes' (namely the positions). Note -- that this may not hold true with custom supplied 'Attributes' -- (i.e. not using one of the @dotize@ functions).-prop_dotizeAugmentUniq :: (DynGraph g, Eq n, Ord e) => g n e -> Bool+prop_dotizeAugmentUniq :: (DynGraph g, Ord e) => g n e -> Bool prop_dotizeAugmentUniq g = all uniqLs lss where g' = setDirectedness dotizeGraph nonClusteredParams g@@ -111,22 +112,22 @@ -- | Ensure that the definition of 'nodeInformation' for a DotRepr -- finds all the nodes. prop_findAllNodes :: (DotRepr dg Int, Ord el, Graph g)- => dg Int -> g nl el -> Bool-prop_findAllNodes dg' g = ((==) `on` sort) gns dgns+ => DGProxy dg -> g nl el -> Bool+prop_findAllNodes dgp g = ((==) `on` sort) gns dgns where gns = nodes g- dg = canonicalToType dg' $ setDirectedness graphToDot nonClusteredParams g+ dg = canonicalToType dgp $ setDirectedness graphToDot nonClusteredParams g dgns = map nodeID $ graphNodes dg -- | Ensure that the definition of 'nodeInformation' for DotReprs -- finds all the nodes when the explicit 'DotNode' definitions are -- removed. prop_findAllNodesE :: (DotRepr dg Int, Ord el, Graph g)- => dg Int -> g nl el -> Bool-prop_findAllNodesE dg' g = ((==) `on` sort) gns dgns+ => DGProxy dg -> g nl el -> Bool+prop_findAllNodesE dgp g = ((==) `on` sort) gns dgns where gns = nodes g- dg = canonicalToType dg' . removeNodes $ setDirectedness graphToDot nonClusteredParams g+ dg = canonicalToType dgp . removeNodes $ setDirectedness graphToDot nonClusteredParams g dgns = map nodeID $ graphNodes dg removeNodes dot@DotGraph{graphStatements = stmts} = dot { graphStatements@@ -137,21 +138,21 @@ -- | Ensure that the definition of 'edgeInformation' for DotReprs -- finds all the nodes.-prop_findAllEdges :: (DotRepr dg Int, Ord el, Graph g) => dg Int -> g nl el -> Bool-prop_findAllEdges dg' g = ((==) `on` sort) ges dges+prop_findAllEdges :: (DotRepr dg Int, Graph g) => DGProxy dg -> g nl el -> Bool+prop_findAllEdges dgp g = ((==) `on` sort) ges dges where ges = edges g- dg = canonicalToType dg' $ graphToDot nonClusteredParams g+ dg = canonicalToType dgp $ graphToDot nonClusteredParams g dges = map (fromNode &&& toNode) $ graphEdges dg -- | There should be no clusters or global attributes when converting -- a 'Graph' to a DotRepr (via fromCanonical) without any formatting -- or clustering. prop_noGraphInfo :: (DotRepr dg Int, Ord el, Graph g)- => dg Int -> g nl el -> Bool-prop_noGraphInfo dg' g = info == (GraphAttrs [], Map.empty)+ => DGProxy dg -> g nl el -> Bool+prop_noGraphInfo dgp g = info == (GraphAttrs [], Map.empty) where- dg = canonicalToType dg'+ dg = canonicalToType dgp $ setDirectedness graphToDot nonClusteredParams g info = graphStructureInformation dg @@ -205,5 +206,5 @@ -- | A wrapper around 'fromCanonical' that lets you specify up-front -- what type to create (it need not be a sensible value).-canonicalToType :: (DotRepr dg n) => dg n -> DotGraph n -> dg n+canonicalToType :: (DotRepr dg n) => DGProxy dg -> DotGraph n -> dg n canonicalToType _ = fromCanonical
+ tests/Data/GraphViz/Testing/Proxy.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE KindSignatures #-}++{- |+ Module : Data.GraphViz.Testing.Proxy+ Description : Proxy implementation+ Copyright : Matthew Sackman, Ivan Lazar Miljenovic+ License : BSD3+ Maintainer : Ivan.Miljenovic@gmail.com++ Data.Proxy was added to base with GHC 7.8.1, and we want to test+ for older versions than that.++ -}+module Data.GraphViz.Testing.Proxy where++--------------------------------------------------------------------------------++data DGProxy (dg :: * -> *) = DGProxy+ deriving (Eq, Ord, Show, Read)
+ tests/Data/GraphViz/Types/CanonicalSpec.hs view
@@ -0,0 +1,44 @@+{- |+ Module : Data.GraphViz.Types.CanonicalSpec+ Description : Testing canonical graph representation+ Copyright : Matthew Sackman, Ivan Lazar Miljenovic+ License : BSD3+ Maintainer : Ivan.Miljenovic@gmail.com++++ -}+module Data.GraphViz.Types.CanonicalSpec (spec) where++import Data.GraphViz.Testing.Instances ()+import Data.GraphViz.Testing.Properties (prop_findAllEdges, prop_findAllNodes,+ prop_findAllNodesE,+ prop_generalisedSameDot,+ prop_noGraphInfo, prop_printParseID)+import Data.GraphViz.Testing.Proxy (DGProxy(..))+import Data.GraphViz.Types.Canonical (DotGraph)++import Test.Hspec (Spec)+import Test.Hspec.QuickCheck (prop)++import Data.Graph.Inductive.PatriciaTree (Gr)++--------------------------------------------------------------------------------++spec :: Spec+spec = do+ prop "Generalising a graph doesn't change Dot code"+ (prop_generalisedSameDot :: DotGraph Int -> Bool)+ prop "Printing and parsing Dot graph"+ (prop_printParseID :: DotGraph Int -> Bool)+ prop "Find all nodes in a Dot graph"+ (prop_findAllNodes dproxy :: Gr () () -> Bool)+ prop "Find all nodes in an node-less Dot graph"+ (prop_findAllNodesE dproxy :: Gr () () -> Bool)+ prop "Find all edges in a Dot graph"+ (prop_findAllEdges dproxy :: Gr () () -> Bool)+ prop "Plain Dot graphs should have no structural information"+ (prop_noGraphInfo dproxy :: Gr () () -> Bool)++dproxy :: DGProxy DotGraph+dproxy = DGProxy
+ tests/Data/GraphViz/Types/GeneralisedSpec.hs view
@@ -0,0 +1,41 @@+{- |+ Module : Data.GraphViz.Types.GeneralisedSpec+ Description : Testing generalised graph representation+ Copyright : Matthew Sackman, Ivan Lazar Miljenovic+ License : BSD3+ Maintainer : Ivan.Miljenovic@gmail.com++++ -}+module Data.GraphViz.Types.GeneralisedSpec (spec) where++import Data.GraphViz.Testing.Instances ()+import Data.GraphViz.Testing.Properties (prop_findAllEdges, prop_findAllNodes,+ prop_findAllNodesE, prop_noGraphInfo,+ prop_printParseID)+import Data.GraphViz.Testing.Proxy (DGProxy(..))+import Data.GraphViz.Types.Generalised (DotGraph)++import Test.Hspec (Spec)+import Test.Hspec.QuickCheck (prop)++import Data.Graph.Inductive.PatriciaTree (Gr)++--------------------------------------------------------------------------------++spec :: Spec+spec = do+ prop "Printing and parsing Dot graph"+ (prop_printParseID :: DotGraph Int -> Bool)+ prop "Find all nodes in a Dot graph"+ (prop_findAllNodes dproxy :: Gr () () -> Bool)+ prop "Find all nodes in an node-less Dot graph"+ (prop_findAllNodesE dproxy :: Gr () () -> Bool)+ prop "Find all edges in a Dot graph"+ (prop_findAllEdges dproxy :: Gr () () -> Bool)+ prop "Plain Dot graphs should have no structural information"+ (prop_noGraphInfo dproxy :: Gr () () -> Bool)++dproxy :: DGProxy DotGraph+dproxy = DGProxy
+ tests/Data/GraphViz/Types/GraphSpec.hs view
@@ -0,0 +1,59 @@+{- |+ Module : Data.GraphViz.Types.GraphSpec+ Description : Testing graph-based graph representation+ Copyright : Matthew Sackman, Ivan Lazar Miljenovic+ License : BSD3+ Maintainer : Ivan.Miljenovic@gmail.com++++ -}+module Data.GraphViz.Types.GraphSpec (spec) where++import Data.GraphViz.Testing.Instances ()+import Data.GraphViz.Testing.Properties (prop_findAllEdges, prop_findAllNodes,+ prop_findAllNodesE, prop_noGraphInfo,+ prop_printParseID)+import Data.GraphViz.Testing.Proxy (DGProxy(..))+import Data.GraphViz.Types (edgeInformation)+import Data.GraphViz.Types.Graph (Context(..), DotEdge(..), DotGraph,+ DotNode(..), addEdge, emptyGraph,+ mkGraph, (&))++import Test.Hspec (Spec, describe, it)+import Test.Hspec.QuickCheck (prop)++import Data.Graph.Inductive.PatriciaTree (Gr)++--------------------------------------------------------------------------------++spec :: Spec+spec = do+ prop "Printing and parsing Dot graph"+ (prop_printParseID :: DotGraph Int -> Bool)+ prop "Find all nodes in a Dot graph"+ (prop_findAllNodes dproxy :: Gr () () -> Bool)+ prop "Find all nodes in an node-less Dot graph"+ (prop_findAllNodesE dproxy :: Gr () () -> Bool)+ prop "Find all edges in a Dot graph"+ (prop_findAllEdges dproxy :: Gr () () -> Bool)+ prop "Plain Dot graphs should have no structural information"+ (prop_noGraphInfo dproxy :: Gr () () -> Bool)++ describe "issue#28" $ do+ it "mkGraph retains proper edge order" $+ hasEdge (mkGraph [DotNode 0 [], DotNode 1 []] [DotEdge 0 1 []]) (0,1)+ it "& retains proper edge order" $+ hasEdge (Cntxt { node = 1, inCluster = Nothing, attributes = [], predecessors = [(0,[])], successors = []}+ & Cntxt { node = 0, inCluster = Nothing, attributes = [], predecessors = [], successors = []}+ & emptyGraph)+ (0,1)+ it "addEdge retains proper edge order" $+ hasEdge (addEdge 0 1 [] (mkGraph [DotNode 0 [], DotNode 1 []] [])) (0,1)+++dproxy :: DGProxy DotGraph+dproxy = DGProxy++hasEdge :: DotGraph Int -> (Int,Int) -> Bool+hasEdge dg (f,t) = edgeInformation False dg == [DotEdge f t []]
+ tests/Data/GraphVizSpec.hs view
@@ -0,0 +1,34 @@+{- |+ Module : Data.GraphVizSpec+ Description : Testing algorithms+ Copyright : Matthew Sackman, Ivan Lazar Miljenovic+ License : BSD3+ Maintainer : Ivan.Miljenovic@gmail.com++++ -}+module Data.GraphVizSpec (spec) where++import Data.GraphViz.Testing.Instances ()+import Data.GraphViz.Testing.Properties (prop_dotizeAugment,+ prop_dotizeAugmentUniq,+ prop_dotizeHasAugment)++import Test.Hspec (Spec)+import Test.Hspec.QuickCheck (prop)++import Data.Graph.Inductive.PatriciaTree (Gr)++--------------------------------------------------------------------------------++spec :: Spec+spec = do+ prop "FGL Graphs are augmentable"+ (prop_dotizeAugment :: GrType -> Bool)+ prop "Ensure augmentation is valid"+ (prop_dotizeHasAugment :: GrType -> Bool)+ prop "Unique edges in augmented FGL Graphs"+ (prop_dotizeAugmentUniq :: GrType -> Bool)++type GrType = Gr Char Double
+ tests/Main.hs view
@@ -0,0 +1,23 @@+{- |+ Module : Main+ Description : Top-level HSpec runner+ Copyright : Matthew Sackman, Ivan Lazar Miljenovic+ License : BSD3+ Maintainer : Ivan.Miljenovic@gmail.com++ Used as we want to wrap default QuickCheck configurations.++ -}+module Main where++import qualified Spec+import Test.Hspec.QuickCheck (modifyMaxSize, modifyMaxSuccess)+import Test.Hspec.Runner (hspec)++--------------------------------------------------------------------------------++main :: IO ()+main = hspec+ . modifyMaxSuccess (const 200)+ . modifyMaxSize (const 50)+ $ Spec.spec
− tests/RunTests.hs
@@ -1,83 +0,0 @@-{- |- Module : RunTests- Description : Run the graphviz test suite.- Copyright : (c) Ivan Lazar Miljenovic- License : 3-Clause BSD-style- Maintainer : Ivan.Miljenovic@gmail.com-- This module exists solely to make a Main module to build and run- the test suite.--}-module Main where--import Data.GraphViz.Testing (Test (name, lookupName), allTests, defaultTests,- runChosenTests)--import Control.Arrow ((&&&))-import Control.Monad (when)-import Data.Char (toLower)-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Maybe (mapMaybe)-import System.Environment (getArgs, getProgName)-import System.Exit (exitSuccess)---- -------------------------------------------------------------------------------main :: IO ()-main = do opts <- getArgs- let opts' = map (map toLower) opts- hasArg arg = arg `elem` opts'- when (hasArg "help") helpMsg- let tests = if hasArg "all"- then allTests- else mapMaybe getTest opts'- tests' = if null tests- then defaultTests- else tests- runChosenTests tests'--testLookup :: Map String Test-testLookup = Map.fromList- $ map (lookupName &&& id) allTests--getTest :: String -> Maybe Test-getTest = (`Map.lookup` testLookup)--helpMsg :: IO ()-helpMsg = getProgName >>= (putStr . msg) >> exitSuccess- where- msg nm = unlines- [ "This utility is the test-suite for the graphviz library for Haskell."- , "Various tests are available; see the table below for a complete list."- , "There are several ways of running this program:"- , ""- , " " ++ nm ++ " Run the default set of tests"- , " " ++ nm ++ " all Run all of the tests"- , " " ++ nm ++ " help Get this help message"- , " " ++ nm ++ " <key> Run the test associated with each key,"- , " (where <key> denotes a space-separated list of keys"- , " from the table below)."- , ""- , helpTable- ]--helpTable :: String-helpTable = unlines $ fmtName ((lnHeader,lnHeaderLen),(nHeader,nHeaderLen))- : line- : map fmtName testNames- where- andLen = ((id &&& length) .)- testNames = map (andLen lookupName &&& andLen name) allTests- fmtName ((ln,lnl),(n,_)) = concat [ ln- , replicate (maxLN-lnl+spacerLen) ' '- , n- ]- line = replicate (maxLN + spacerLen + maxN) '-'- maxLN = maximum $ map (snd . fst) testNames- maxN = maximum $ map (snd . snd) testNames- spacerLen = 3- lnHeader = "Key"- lnHeaderLen = length lnHeader- nHeader = "Description"- nHeaderLen = length nHeader
+ tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}
utils/AttributeGenerator.hs view
@@ -560,6 +560,7 @@ makeAttr "NodeSep" ["nodesep"] "G" (Dbl) Nothing (Just "0.25") (Just "@0.25@") (Just "@0.02@") Nothing, makeAttr "NoJustify" ["nojustify"] "GCNE" (Bl) (Just "True") (Just "False") (Just "@'False'@") Nothing Nothing, makeAttr "Normalize" ["normalize"] "G" (Cust "Normalized") (Just "IsNormalized") (Just "NotNormalized") (Just "@'NotNormalized'@") Nothing (Just "not 'Dot'"),+ makeAttr "NoTranslate" ["notranslate"] "G" (Bl) (Just "True") (Just "False") (Just "@'False'@") Nothing (Just "'Neato' only, requires Graphviz >= 2.38.0"), makeAttr "Nslimit" ["nslimit"] "G" (Dbl) Nothing Nothing Nothing Nothing (Just "'Dot' only"), makeAttr "Nslimit1" ["nslimit1"] "G" (Dbl) Nothing Nothing Nothing Nothing (Just "'Dot' only"), makeAttr "Ordering" ["ordering"] "GN" (Cust "Order") Nothing Nothing (Just "none") Nothing (Just "'Dot' only"),@@ -751,6 +752,7 @@ | NodeSep | nodesep | G | Dbl | | 0.25 | @0.25@ | @0.02@ | | | NoJustify | nojustify | GCNE | Bl | True | False | @'False'@ | | | | Normalize | normalize | G | Cust "Normalized" | IsNormalized | NotNormalized | @'NotNormalized'@ | | not 'Dot' |+| NoTranslate | notranslate | G | Bl | True | False | @'False'@ | | 'Neato' only, requires Graphviz >= 2.38.0 | | Nslimit | nslimit | G | Dbl | | | | | 'Dot' only | | Nslimit1 | nslimit1 | G | Dbl | | | | | 'Dot' only | | Ordering | ordering | GN | Cust "Order" | | | none | | 'Dot' only |
utils/Benchmark.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-}+ {- | Module : Benchmark Description : Benchmarking utilities for graphviz@@ -10,13 +12,13 @@ -} module Main where -import Data.GraphViz hiding (DotGraph)+import Data.GraphViz hiding (DotGraph) import Data.GraphViz.Types.Generalised import Criterion.Main import Control.DeepSeq-import Data.Text.Lazy(Text)+import Data.Text.Lazy (Text) -- -----------------------------------------------------------------------------
utils/TestParsing.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE MultiParamTypeClasses, OverloadedStrings #-} {- | Module : TestParsing@@ -12,10 +12,10 @@ (with the assumption that the provided code is valid). -}-module Main where+module Main (main) where import Data.GraphViz-import Data.GraphViz.Commands.IO (hGetStrict, toUTF8)+import Data.GraphViz.Commands.IO (toUTF8) import Data.GraphViz.Exception import Data.GraphViz.Parsing (runParser) import Data.GraphViz.PreProcessing (preProcess)@@ -24,6 +24,8 @@ import Control.Exception (SomeException, evaluate, try) import Control.Monad (filterM, liftM) import qualified Data.ByteString.Lazy as B+import Data.Either (either)+import Data.Monoid (mappend) import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as T import System.Directory@@ -53,56 +55,53 @@ -- ----------------------------------------------------------------------------- --withParse :: (PPDotRepr dg n) => (a -> IO Text) -> (dg n -> IO ())+withParse :: (Show a, PPDotRepr dg n) => (a -> IO Text) -> (dg n -> IO ()) -> (ErrMsg -> String) -> a -> IO () withParse toStr withDG cmbErr a = do dc <- liftM getMsg . try $ toStr a case dc of Right dc' -> do edg <- tryParse dc' case edg of (Right dg) -> withDG dg- (Left err) -> do putStrLn "Parsing problem!"+ (Left err) -> do putStr (show a)+ putStrLn " - Parsing problem!" putStrLn $ cmbErr err putStrLn ""- Left err -> do putStrLn "IO problem!"+ Left err -> do putStr (show a)+ putStrLn " - IO problem!" putStrLn err putStrLn "" where getMsg :: Either SomeException Text -> Either ErrMsg Text getMsg = either (Left . show) Right -type DG = DotGraph Text type GDG = G.DotGraph Text type ErrMsg = String tryParseFile :: FilePath -> IO ()-tryParseFile fp = withParse readFile'- (tryParseCanon fp)+tryParseFile fp = withParse readUTF8File+ ((`seq` return ()) . T.length . printDotGraph . asGDG) ("Cannot parse as a G.DotGraph: "++) fp--tryParseCanon :: FilePath -> GDG -> IO ()-tryParseCanon fp = withParse prettyPrint- ((`seq` putStrLn "Parsed OK!") . T.length . printDotGraph . asDG)- (\ e -> fp ++ ": Canonical Form not a DotGraph:\n"- ++ e) where- asDG = flip asTypeOf emptDG- emptDG = DotGraph False False Nothing $ DotStmts [] [] [] [] :: DG- prettyPrint dg = graphvizWithHandle (commandFor dg) dg Canon hGetStrict+ asGDG :: GDG -> GDG+ asGDG = id tryParse :: (PPDotRepr dg n) => Text -> IO (Either ErrMsg (dg n)) tryParse dc = handle getErr $ let (dg, rst) = runParser parse $ preProcess dc- in T.length rst `seq` return dg+ in T.length rst `seq` return (eitherLR (augmentErr rst) id dg) where getErr :: SomeException -> IO (Either ErrMsg a) getErr = return . Left . show -readFile' :: FilePath -> IO Text-readFile' fp = do putStr fp- putStr " - "- readUTF8File fp+ augmentErr rst err = err ++ "\n\tRemaining input: " ++ show res+ where+ sampleLen = 35++ res | T.length rst <= sampleLen = rst+ | otherwise = T.take sampleLen rst `mappend` " ..."++ eitherLR f g = either (Left . f) (Right . g) -- Force any encoding errors into the IO section rather than when parsing. readUTF8File :: FilePath -> IO Text