graphviz 2999.19.0.0 → 2999.20.2.1
raw patch · 43 files changed
Files
- Changelog.md +78/−2
- Data/GraphViz/Algorithms.hs +13/−13
- Data/GraphViz/Attributes/Arrows.hs +5/−1
- Data/GraphViz/Attributes/Colors.hs +8/−5
- Data/GraphViz/Attributes/Complete.hs +8/−4
- Data/GraphViz/Attributes/HTML.hs +127/−51
- Data/GraphViz/Attributes/Internal.hs +5/−1
- Data/GraphViz/Attributes/Values.hs +12/−8
- Data/GraphViz/Commands.hs +1/−1
- Data/GraphViz/Commands/IO.hs +22/−25
- Data/GraphViz/Exception.hs +1/−0
- Data/GraphViz/Internal/State.hs +5/−9
- Data/GraphViz/Parsing.hs +8/−2
- Data/GraphViz/Printing.hs +68/−9
- Data/GraphViz/Types.hs +11/−12
- Data/GraphViz/Types/Canonical.hs +3/−3
- Data/GraphViz/Types/Generalised.hs +6/−7
- Data/GraphViz/Types/Graph.hs +42/−32
- Data/GraphViz/Types/Internal/Common.hs +5/−1
- Data/GraphViz/Types/Monadic.hs +50/−11
- Data/GraphViz/Types/State.hs +11/−11
- FAQ.md +0/−2
- LICENSE.md +0/−2
- README.md +0/−7
- Setup.hs +0/−4
- TODO.md +0/−2
- graphviz.cabal +37/−42
- 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/Attributes.hs +74/−38
- tests/Data/GraphViz/Testing/Properties.hs +22/−21
- 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/TestParsing.hs +23/−24
Changelog.md view
@@ -1,11 +1,87 @@-% 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 ----------------------
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 -- -----------------------------------------------------------------------------
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)@@ -58,6 +57,10 @@ import qualified Data.Text.Lazy as T import Data.Word (Word8) import Numeric (readHex, showHex)++#if !MIN_VERSION_base (4,13,0)+import Data.Monoid ((<>))+#endif -- -----------------------------------------------------------------------------
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,8 +209,12 @@ 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 -- -----------------------------------------------------------------------------
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@@ -301,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 @@ -374,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`@@ -466,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.@@ -493,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@@ -572,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@@ -621,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
@@ -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,32 +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)-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.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)+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) -- -----------------------------------------------------------------------------@@ -63,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 -- -----------------------------------------------------------------------------@@ -152,7 +149,7 @@ -> dg n -> IO a runCommand cmd args hf dg- = mapException notRunnable $+ = handle (throwIO . notRunnable) $ withSystemTempFile ("graphviz" <.> "gv") $ \dotFile dotHandle -> do finally (hPutCompactDot dotHandle dg) (hClose dotHandle) bracket@@ -192,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
Data/GraphViz/Exception.hs view
@@ -11,6 +11,7 @@ -- * Re-exported for convenience. , mapException , throw+ , throwIO , handle , bracket ) where
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/Parsing.hs view
@@ -78,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 @@ -99,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) -- -----------------------------------------------------------------------------@@ -248,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/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,6 +73,7 @@ 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(..),@@ -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.@@ -188,6 +242,11 @@ unqtDot = unqtString toDot = qtString++instance PrintDot ST.Text where+ unqtDot = unqtDot . T.fromStrict++ toDot = qtString . T.fromStrict -- | For use with @OverloadedStrings@ to avoid ambiguous type variable errors. unqtText :: Text -> DotCode
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,+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 (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 -- -----------------------------------------------------------------------------
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
@@ -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 -- -----------------------------------------------------------------------------
Data/GraphViz/Types/Graph.hs view
@@ -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,17 +109,18 @@ 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))@@ -223,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 & @@ -240,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@@ -271,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).@@ -290,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@@ -686,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 ) @@ -778,11 +783,16 @@ , EdgeAttrs $ unSame ea ] -niSucc :: (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 :: (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 #-} {- |@@ -47,6 +47,10 @@ import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as T import qualified Data.Text.Lazy.Read as T++#if !MIN_VERSION_base (4,13,0)+import Data.Monoid ((<>))+#endif -- ----------------------------------------------------------------------------- -- This is re-exported by Data.GraphViz.Types
Data/GraphViz/Types/Monadic.hs view
@@ -64,7 +64,9 @@ , nodeAttrs , edgeAttrs -- * Adding items to the graph.- -- ** Clusters+ -- ** Subgraphs and clusters+ , subgraph+ , anonSubgraph , cluster -- ** Nodes , node@@ -85,8 +87,15 @@ #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. @@ -117,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 . (,) () @@ -161,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 @@ -188,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
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 -- -----------------------------------------------------------------------------
FAQ.md view
@@ -1,5 +1,3 @@-% FAQ-% Ivan Lazar Miljenovic Fortuitously Anticipated Queries (FAQ) ======================================
LICENSE.md view
@@ -1,5 +1,3 @@-% License-% Ivan Lazar Miljenovic Licensing Information =====================
README.md view
@@ -1,11 +1,7 @@-% Haskell bindings to the Graphviz toolkit-% Ivan Lazar Miljenovic The graphviz Library ==================== -[](https://hackage.haskell.org/package/graphviz) [](https://travis-ci.org/ivan-m/graphviz)- The _graphviz_ library provides bindings to the [Graphviz] graph visualisation suite of tools for the purely functional programming language [Haskell]. It can be downloaded from [HackageDB] or - if you@@ -55,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.19.0.0-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,26 +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@gmail.com+Maintainer: Daniel Casanueva (coding `at` danielcasanueva.eu) Build-Type: Simple-Tested-With: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4,- GHC == 7.10.2, GHC == 8.0.1, GHC == 8.1.*-Cabal-Version: >= 1.14-Extra-Source-Files: TODO.md- Changelog.md- README.md- FAQ.md- utils/AttributeGenerator.hs--Source-Repository head- Type: git- Location: git://github.com/ivan-m/graphviz.git+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.@@ -58,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.13,- bytestring >= 0.9 && < 0.11,+ polyparse >=1.9 && <1.14,+ bytestring >= 0.9, colour == 2.3.*,- transformers >= 0.2 && < 0.6,+ mtl == 2.*, text,- wl-pprint-text >= 1.1.0.0 && < 1.2.0.0,- dlist >= 0.5 && < 0.9+ wl-pprint-text == 1.2.*,+ dlist >= 0.5 && < 1.1 Exposed-Modules: Data.GraphViz Data.GraphViz.Types@@ -107,11 +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-Options: -Wall } Test-Suite graphviz-testsuite {@@ -123,19 +109,20 @@ 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.10+ 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.Helpers Data.GraphViz.Testing.Instances.Attributes@@ -143,9 +130,21 @@ 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@@ -162,17 +161,13 @@ deepseq, text, graphviz,- criterion >= 0.5 && < 1.2+ 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: -rtsopts }@@ -196,7 +191,7 @@ filepath, text - Ghc-Options: -O -Wall+ Ghc-Options: -Wall 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/Attributes.hs view
@@ -40,7 +40,7 @@ #if !MIN_VERSION_QuickCheck(2,9,0) import Data.GraphViz.Internal.Util (createVersion)-import Data.Version (Version (..))+import Data.Version (Version(..)) #endif -- -----------------------------------------------------------------------------@@ -427,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@@ -663,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@@ -837,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@@ -864,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.@@ -880,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@@ -895,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)@@ -935,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@@ -945,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@@ -992,6 +1019,15 @@ arbitrary = arbBounded 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
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@@ -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, 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/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