diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -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 ---------------------- diff --git a/Data/GraphViz.hs b/Data/GraphViz.hs --- a/Data/GraphViz.hs +++ b/Data/GraphViz.hs @@ -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 diff --git a/Data/GraphViz/Algorithms.hs b/Data/GraphViz/Algorithms.hs --- a/Data/GraphViz/Algorithms.hs +++ b/Data/GraphViz/Algorithms.hs @@ -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' diff --git a/Data/GraphViz/Attributes/Arrows.hs b/Data/GraphViz/Attributes/Arrows.hs --- a/Data/GraphViz/Attributes/Arrows.hs +++ b/Data/GraphViz/Attributes/Arrows.hs @@ -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 -- ----------------------------------------------------------------------------- diff --git a/Data/GraphViz/Attributes/Colors.hs b/Data/GraphViz/Attributes/Colors.hs --- a/Data/GraphViz/Attributes/Colors.hs +++ b/Data/GraphViz/Attributes/Colors.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP, OverloadedStrings #-} {- | Module : Data.GraphViz.Attributes.Colors @@ -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 diff --git a/Data/GraphViz/Attributes/Complete.hs b/Data/GraphViz/Attributes/Complete.hs --- a/Data/GraphViz/Attributes/Complete.hs +++ b/Data/GraphViz/Attributes/Complete.hs @@ -1,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" diff --git a/Data/GraphViz/Attributes/HTML.hs b/Data/GraphViz/Attributes/HTML.hs --- a/Data/GraphViz/Attributes/HTML.hs +++ b/Data/GraphViz/Attributes/HTML.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, PatternGuards #-} +{-# LANGUAGE CPP, OverloadedStrings, PatternGuards #-} {- | Module : Data.GraphViz.Attributes.HTML @@ -64,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")++) diff --git a/Data/GraphViz/Attributes/Internal.hs b/Data/GraphViz/Attributes/Internal.hs --- a/Data/GraphViz/Attributes/Internal.hs +++ b/Data/GraphViz/Attributes/Internal.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP, OverloadedStrings #-} {-# OPTIONS_HADDOCK hide #-} {- | @@ -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 -- ----------------------------------------------------------------------------- diff --git a/Data/GraphViz/Attributes/Values.hs b/Data/GraphViz/Attributes/Values.hs --- a/Data/GraphViz/Attributes/Values.hs +++ b/Data/GraphViz/Attributes/Values.hs @@ -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"] ] -- ----------------------------------------------------------------------------- diff --git a/Data/GraphViz/Commands.hs b/Data/GraphViz/Commands.hs --- a/Data/GraphViz/Commands.hs +++ b/Data/GraphViz/Commands.hs @@ -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 diff --git a/Data/GraphViz/Commands/IO.hs b/Data/GraphViz/Commands/IO.hs --- a/Data/GraphViz/Commands/IO.hs +++ b/Data/GraphViz/Commands/IO.hs @@ -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' diff --git a/Data/GraphViz/Exception.hs b/Data/GraphViz/Exception.hs --- a/Data/GraphViz/Exception.hs +++ b/Data/GraphViz/Exception.hs @@ -11,6 +11,7 @@ -- * Re-exported for convenience. , mapException , throw + , throwIO , handle , bracket ) where @@ -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 diff --git a/Data/GraphViz/Internal/State.hs b/Data/GraphViz/Internal/State.hs --- a/Data/GraphViz/Internal/State.hs +++ b/Data/GraphViz/Internal/State.hs @@ -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 = [','] diff --git a/Data/GraphViz/Internal/Util.hs b/Data/GraphViz/Internal/Util.hs --- a/Data/GraphViz/Internal/Util.hs +++ b/Data/GraphViz/Internal/Util.hs @@ -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 -- ----------------------------------------------------------------------------- diff --git a/Data/GraphViz/Parsing.hs b/Data/GraphViz/Parsing.hs --- a/Data/GraphViz/Parsing.hs +++ b/Data/GraphViz/Parsing.hs @@ -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 diff --git a/Data/GraphViz/PreProcessing.hs b/Data/GraphViz/PreProcessing.hs --- a/Data/GraphViz/PreProcessing.hs +++ b/Data/GraphViz/PreProcessing.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + {- | Module : Data.GraphViz.PreProcessing Description : Pre-process imported Dot code. @@ -9,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 diff --git a/Data/GraphViz/Printing.hs b/Data/GraphViz/Printing.hs --- a/Data/GraphViz/Printing.hs +++ b/Data/GraphViz/Printing.hs @@ -1,4 +1,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 diff --git a/Data/GraphViz/Types.hs b/Data/GraphViz/Types.hs --- a/Data/GraphViz/Types.hs +++ b/Data/GraphViz/Types.hs @@ -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\ diff --git a/Data/GraphViz/Types/Canonical.hs b/Data/GraphViz/Types/Canonical.hs --- a/Data/GraphViz/Types/Canonical.hs +++ b/Data/GraphViz/Types/Canonical.hs @@ -32,11 +32,11 @@ > , graphID = Just (Str "G") > , graphStatements = DotStmts { attrStmts = [] > , subGraphs = [ DotSG { isCluster = True - > , subGraphID = Just (Int 0) + > , subGraphID = Just (Num (Int 0)) > , subGraphStmts = DotStmts { attrStmts = [ GraphAttrs [ style filled > , color LightGray > , textLabel "process #1"] - > , NodeAttrs [style filled, color White]]} + > , NodeAttrs [style filled, color White]] > , subGraphs = [] > , nodeStmts = [ DotNode "a0" [] > , DotNode "a1" [] @@ -47,7 +47,7 @@ > , DotEdge "a2" "a3" [] > , DotEdge "a3" "a0" []]}} > , DotSG { isCluster = True - > , subGraphID = Just (Int 1) + > , subGraphID = Just (Num (Int 1)) > , subGraphStmts = DotStmts { attrStmts = [ GraphAttrs [textLabel "process #2", color Blue] > , NodeAttrs [style filled]] > , subGraphs = [] diff --git a/Data/GraphViz/Types/Generalised.hs b/Data/GraphViz/Types/Generalised.hs --- a/Data/GraphViz/Types/Generalised.hs +++ b/Data/GraphViz/Types/Generalised.hs @@ -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 diff --git a/Data/GraphViz/Types/Graph.hs b/Data/GraphViz/Types/Graph.hs --- a/Data/GraphViz/Types/Graph.hs +++ b/Data/GraphViz/Types/Graph.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE 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 diff --git a/Data/GraphViz/Types/Internal/Common.hs b/Data/GraphViz/Types/Internal/Common.hs --- a/Data/GraphViz/Types/Internal/Common.hs +++ b/Data/GraphViz/Types/Internal/Common.hs @@ -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 diff --git a/Data/GraphViz/Types/Monadic.hs b/Data/GraphViz/Types/Monadic.hs --- a/Data/GraphViz/Types/Monadic.hs +++ b/Data/GraphViz/Types/Monadic.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} +{-# LANGUAGE CPP, FlexibleInstances, MultiParamTypeClasses #-} {- | Module : Data.GraphViz.Types.Monadic @@ -64,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 diff --git a/Data/GraphViz/Types/State.hs b/Data/GraphViz/Types/State.hs --- a/Data/GraphViz/Types/State.hs +++ b/Data/GraphViz/Types/State.hs @@ -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 diff --git a/FAQ.md b/FAQ.md --- a/FAQ.md +++ b/FAQ.md @@ -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? ### diff --git a/LICENSE.md b/LICENSE.md --- a/LICENSE.md +++ b/LICENSE.md @@ -1,5 +1,3 @@ -% License -% Ivan Lazar Miljenovic Licensing Information ===================== diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,4 +0,0 @@ -#!/usr/bin/env runghc - -import Distribution.Simple -main = defaultMain diff --git a/TODO.md b/TODO.md --- a/TODO.md +++ b/TODO.md @@ -1,5 +1,3 @@ -% TODO -% Ivan Lazar Miljenovic Future Plans for graphviz ========================= diff --git a/graphviz.cabal b/graphviz.cabal --- a/graphviz.cabal +++ b/graphviz.cabal @@ -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 } diff --git a/tests/Data/GraphViz/AlgorithmsSpec.hs b/tests/Data/GraphViz/AlgorithmsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/GraphViz/AlgorithmsSpec.hs @@ -0,0 +1,37 @@ +{- | + Module : Data.GraphViz.AlgorithmsSpec + Description : Testing algorithms + Copyright : Matthew Sackman, Ivan Lazar Miljenovic + License : BSD3 + Maintainer : Ivan.Miljenovic@gmail.com + + + + -} +module Data.GraphViz.AlgorithmsSpec (spec) where + +import Data.GraphViz.Algorithms (CanonicaliseOptions) +import Data.GraphViz.Testing.Instances () +import Data.GraphViz.Testing.Properties (prop_canonicalise, + prop_canonicaliseEdges, + prop_canonicaliseNodes, + prop_transitive, prop_transitiveNodes) +import Data.GraphViz.Types.Canonical (DotGraph) + +import Test.Hspec (Spec) +import Test.Hspec.QuickCheck (prop) + +-------------------------------------------------------------------------------- + +spec :: Spec +spec = do + prop "Canonicalisation should be idempotent" + (prop_canonicalise :: CanonicaliseOptions -> DotGraph Int -> Bool) + prop "Canonicalisation shouldn't change any nodes" + (prop_canonicaliseNodes :: CanonicaliseOptions -> DotGraph Int -> Bool) + prop "Canonicalisation shouldn't change any edges" + (prop_canonicaliseEdges :: CanonicaliseOptions -> DotGraph Int -> Bool) + prop "Transitive reduction should be idempotent" + (prop_transitive :: CanonicaliseOptions -> DotGraph Int -> Bool) + prop "Transitive reduction shouldn't change any nodes" + (prop_transitiveNodes :: CanonicaliseOptions -> DotGraph Int -> Bool) diff --git a/tests/Data/GraphViz/Attributes/CompleteSpec.hs b/tests/Data/GraphViz/Attributes/CompleteSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/GraphViz/Attributes/CompleteSpec.hs @@ -0,0 +1,26 @@ +{- | + Module : Data.GraphViz.Attributes.CompleteSpec + Description : Attribute testing + Copyright : Ivan Lazar Miljenovic + License : BSD3 + Maintainer : Ivan.Miljenovic@gmail.com + + + + -} +module Data.GraphViz.Attributes.CompleteSpec (spec) where + +import Data.GraphViz.Attributes.Complete (Attributes) +import Data.GraphViz.Testing.Instances () +import Data.GraphViz.Testing.Properties (prop_printParseListID) + +import Test.Hspec (Spec) +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (Property) + +-------------------------------------------------------------------------------- + +spec :: Spec +spec = + prop "Printing and parsing of attributes" + (prop_printParseListID :: Attributes -> Property) diff --git a/tests/Data/GraphViz/Attributes/HTMLSpec.hs b/tests/Data/GraphViz/Attributes/HTMLSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/GraphViz/Attributes/HTMLSpec.hs @@ -0,0 +1,26 @@ +{- | + Module : Data.GraphViz.Attributes.HTMLSpec + Description : HTML label testing + Copyright : Ivan Lazar Miljenovic + License : BSD3 + Maintainer : Ivan.Miljenovic@gmail.com + + This is in addition to "Data.GraphViz.Attributes.CompleteSpec" as + HTML labels are also likely to have their own quirks for testing. + + -} +module Data.GraphViz.Attributes.HTMLSpec (spec) where + +import Data.GraphViz.Attributes.HTML (Label) +import Data.GraphViz.Testing.Instances () +import Data.GraphViz.Testing.Properties (prop_printParseID) + +import Test.Hspec (Spec) +import Test.Hspec.QuickCheck (prop) + +-------------------------------------------------------------------------------- + +spec :: Spec +spec = + prop "Printing and parsing of HTML labels" + (prop_printParseID :: Label -> Bool) diff --git a/tests/Data/GraphViz/PreProcessingSpec.hs b/tests/Data/GraphViz/PreProcessingSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/GraphViz/PreProcessingSpec.hs @@ -0,0 +1,24 @@ +{- | + Module : Data.GraphViz.PreProcessingSpec + Description : Test pre-processing + Copyright : Matthew Sackman, Ivan Lazar Miljenovic + License : BSD3 + Maintainer : Ivan.Miljenovic@gmail.com + + + + -} +module Data.GraphViz.PreProcessingSpec where + +import Data.GraphViz.Testing.Instances () +import Data.GraphViz.Testing.Properties (prop_preProcessingID) +import Data.GraphViz.Types.Canonical (DotGraph) + +import Test.Hspec (Spec) +import Test.Hspec.QuickCheck (prop) + +-------------------------------------------------------------------------------- + +spec :: Spec +spec = prop "Preprocessing doesn't change Dot code" + (prop_preProcessingID :: DotGraph Int -> Bool) diff --git a/tests/Data/GraphViz/Testing.hs b/tests/Data/GraphViz/Testing.hs deleted file mode 100644 --- a/tests/Data/GraphViz/Testing.hs +++ /dev/null @@ -1,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) - ] diff --git a/tests/Data/GraphViz/Testing/Instances.hs b/tests/Data/GraphViz/Testing/Instances.hs --- a/tests/Data/GraphViz/Testing/Instances.hs +++ b/tests/Data/GraphViz/Testing/Instances.hs @@ -18,10 +18,9 @@ -} module Data.GraphViz.Testing.Instances() where -import Data.GraphViz.Testing.Instances.FGL() -import Data.GraphViz.Testing.Instances.Canonical() -import Data.GraphViz.Testing.Instances.Generalised() -import Data.GraphViz.Testing.Instances.Graph() +import Data.Graph.Inductive.Arbitrary () +import Data.GraphViz.Testing.Instances.Canonical () +import Data.GraphViz.Testing.Instances.Generalised () +import Data.GraphViz.Testing.Instances.Graph () -- ----------------------------------------------------------------------------- - diff --git a/tests/Data/GraphViz/Testing/Instances/Attributes.hs b/tests/Data/GraphViz/Testing/Instances/Attributes.hs --- a/tests/Data/GraphViz/Testing/Instances/Attributes.hs +++ b/tests/Data/GraphViz/Testing/Instances/Attributes.hs @@ -1,6 +1,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP, OverloadedStrings #-} {- | Module : Data.GraphViz.Testing.Instances.Attributes @@ -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 diff --git a/tests/Data/GraphViz/Testing/Instances/FGL.hs b/tests/Data/GraphViz/Testing/Instances/FGL.hs deleted file mode 100644 --- a/tests/Data/GraphViz/Testing/Instances/FGL.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE FlexibleInstances #-} - -{- | - Module : Data.GraphViz.Testing.Instances.FGL - Description : 'Arbitrary' instances for FGL graphs. - Copyright : (c) Ivan Lazar Miljenovic - License : 3-Clause BSD-style - Maintainer : Ivan.Miljenovic@gmail.com - - This module defines the 'Arbitrary' instances for FGL 'DynGraph' - graphs. Note that this instance cannot be in - "Data.GraphViz.Testing.Instances", as this instance requires the - FlexibleInstances extension, which makes some of the other - 'Arbitrary' instances fail to type-check. --} -module Data.GraphViz.Testing.Instances.FGL() where - -import Test.QuickCheck - -import Data.GraphViz.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 - _ -> [] diff --git a/tests/Data/GraphViz/Testing/Instances/Helpers.hs b/tests/Data/GraphViz/Testing/Instances/Helpers.hs --- a/tests/Data/GraphViz/Testing/Instances/Helpers.hs +++ b/tests/Data/GraphViz/Testing/Instances/Helpers.hs @@ -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] diff --git a/tests/Data/GraphViz/Testing/Properties.hs b/tests/Data/GraphViz/Testing/Properties.hs --- a/tests/Data/GraphViz/Testing/Properties.hs +++ b/tests/Data/GraphViz/Testing/Properties.hs @@ -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 diff --git a/tests/Data/GraphViz/Testing/Proxy.hs b/tests/Data/GraphViz/Testing/Proxy.hs new file mode 100644 --- /dev/null +++ b/tests/Data/GraphViz/Testing/Proxy.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE KindSignatures #-} + +{- | + Module : Data.GraphViz.Testing.Proxy + Description : Proxy implementation + Copyright : Matthew Sackman, Ivan Lazar Miljenovic + License : BSD3 + Maintainer : Ivan.Miljenovic@gmail.com + + Data.Proxy was added to base with GHC 7.8.1, and we want to test + for older versions than that. + + -} +module Data.GraphViz.Testing.Proxy where + +-------------------------------------------------------------------------------- + +data DGProxy (dg :: * -> *) = DGProxy + deriving (Eq, Ord, Show, Read) diff --git a/tests/Data/GraphViz/Types/CanonicalSpec.hs b/tests/Data/GraphViz/Types/CanonicalSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/GraphViz/Types/CanonicalSpec.hs @@ -0,0 +1,44 @@ +{- | + Module : Data.GraphViz.Types.CanonicalSpec + Description : Testing canonical graph representation + Copyright : Matthew Sackman, Ivan Lazar Miljenovic + License : BSD3 + Maintainer : Ivan.Miljenovic@gmail.com + + + + -} +module Data.GraphViz.Types.CanonicalSpec (spec) where + +import Data.GraphViz.Testing.Instances () +import Data.GraphViz.Testing.Properties (prop_findAllEdges, prop_findAllNodes, + prop_findAllNodesE, + prop_generalisedSameDot, + prop_noGraphInfo, prop_printParseID) +import Data.GraphViz.Testing.Proxy (DGProxy(..)) +import Data.GraphViz.Types.Canonical (DotGraph) + +import Test.Hspec (Spec) +import Test.Hspec.QuickCheck (prop) + +import Data.Graph.Inductive.PatriciaTree (Gr) + +-------------------------------------------------------------------------------- + +spec :: Spec +spec = do + prop "Generalising a graph doesn't change Dot code" + (prop_generalisedSameDot :: DotGraph Int -> Bool) + prop "Printing and parsing Dot graph" + (prop_printParseID :: DotGraph Int -> Bool) + prop "Find all nodes in a Dot graph" + (prop_findAllNodes dproxy :: Gr () () -> Bool) + prop "Find all nodes in an node-less Dot graph" + (prop_findAllNodesE dproxy :: Gr () () -> Bool) + prop "Find all edges in a Dot graph" + (prop_findAllEdges dproxy :: Gr () () -> Bool) + prop "Plain Dot graphs should have no structural information" + (prop_noGraphInfo dproxy :: Gr () () -> Bool) + +dproxy :: DGProxy DotGraph +dproxy = DGProxy diff --git a/tests/Data/GraphViz/Types/GeneralisedSpec.hs b/tests/Data/GraphViz/Types/GeneralisedSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/GraphViz/Types/GeneralisedSpec.hs @@ -0,0 +1,41 @@ +{- | + Module : Data.GraphViz.Types.GeneralisedSpec + Description : Testing generalised graph representation + Copyright : Matthew Sackman, Ivan Lazar Miljenovic + License : BSD3 + Maintainer : Ivan.Miljenovic@gmail.com + + + + -} +module Data.GraphViz.Types.GeneralisedSpec (spec) where + +import Data.GraphViz.Testing.Instances () +import Data.GraphViz.Testing.Properties (prop_findAllEdges, prop_findAllNodes, + prop_findAllNodesE, prop_noGraphInfo, + prop_printParseID) +import Data.GraphViz.Testing.Proxy (DGProxy(..)) +import Data.GraphViz.Types.Generalised (DotGraph) + +import Test.Hspec (Spec) +import Test.Hspec.QuickCheck (prop) + +import Data.Graph.Inductive.PatriciaTree (Gr) + +-------------------------------------------------------------------------------- + +spec :: Spec +spec = do + prop "Printing and parsing Dot graph" + (prop_printParseID :: DotGraph Int -> Bool) + prop "Find all nodes in a Dot graph" + (prop_findAllNodes dproxy :: Gr () () -> Bool) + prop "Find all nodes in an node-less Dot graph" + (prop_findAllNodesE dproxy :: Gr () () -> Bool) + prop "Find all edges in a Dot graph" + (prop_findAllEdges dproxy :: Gr () () -> Bool) + prop "Plain Dot graphs should have no structural information" + (prop_noGraphInfo dproxy :: Gr () () -> Bool) + +dproxy :: DGProxy DotGraph +dproxy = DGProxy diff --git a/tests/Data/GraphViz/Types/GraphSpec.hs b/tests/Data/GraphViz/Types/GraphSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/GraphViz/Types/GraphSpec.hs @@ -0,0 +1,59 @@ +{- | + Module : Data.GraphViz.Types.GraphSpec + Description : Testing graph-based graph representation + Copyright : Matthew Sackman, Ivan Lazar Miljenovic + License : BSD3 + Maintainer : Ivan.Miljenovic@gmail.com + + + + -} +module Data.GraphViz.Types.GraphSpec (spec) where + +import Data.GraphViz.Testing.Instances () +import Data.GraphViz.Testing.Properties (prop_findAllEdges, prop_findAllNodes, + prop_findAllNodesE, prop_noGraphInfo, + prop_printParseID) +import Data.GraphViz.Testing.Proxy (DGProxy(..)) +import Data.GraphViz.Types (edgeInformation) +import Data.GraphViz.Types.Graph (Context(..), DotEdge(..), DotGraph, + DotNode(..), addEdge, emptyGraph, + mkGraph, (&)) + +import Test.Hspec (Spec, describe, it) +import Test.Hspec.QuickCheck (prop) + +import Data.Graph.Inductive.PatriciaTree (Gr) + +-------------------------------------------------------------------------------- + +spec :: Spec +spec = do + prop "Printing and parsing Dot graph" + (prop_printParseID :: DotGraph Int -> Bool) + prop "Find all nodes in a Dot graph" + (prop_findAllNodes dproxy :: Gr () () -> Bool) + prop "Find all nodes in an node-less Dot graph" + (prop_findAllNodesE dproxy :: Gr () () -> Bool) + prop "Find all edges in a Dot graph" + (prop_findAllEdges dproxy :: Gr () () -> Bool) + prop "Plain Dot graphs should have no structural information" + (prop_noGraphInfo dproxy :: Gr () () -> Bool) + + describe "issue#28" $ do + it "mkGraph retains proper edge order" $ + hasEdge (mkGraph [DotNode 0 [], DotNode 1 []] [DotEdge 0 1 []]) (0,1) + it "& retains proper edge order" $ + hasEdge (Cntxt { node = 1, inCluster = Nothing, attributes = [], predecessors = [(0,[])], successors = []} + & Cntxt { node = 0, inCluster = Nothing, attributes = [], predecessors = [], successors = []} + & emptyGraph) + (0,1) + it "addEdge retains proper edge order" $ + hasEdge (addEdge 0 1 [] (mkGraph [DotNode 0 [], DotNode 1 []] [])) (0,1) + + +dproxy :: DGProxy DotGraph +dproxy = DGProxy + +hasEdge :: DotGraph Int -> (Int,Int) -> Bool +hasEdge dg (f,t) = edgeInformation False dg == [DotEdge f t []] diff --git a/tests/Data/GraphVizSpec.hs b/tests/Data/GraphVizSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/GraphVizSpec.hs @@ -0,0 +1,34 @@ +{- | + Module : Data.GraphVizSpec + Description : Testing algorithms + Copyright : Matthew Sackman, Ivan Lazar Miljenovic + License : BSD3 + Maintainer : Ivan.Miljenovic@gmail.com + + + + -} +module Data.GraphVizSpec (spec) where + +import Data.GraphViz.Testing.Instances () +import Data.GraphViz.Testing.Properties (prop_dotizeAugment, + prop_dotizeAugmentUniq, + prop_dotizeHasAugment) + +import Test.Hspec (Spec) +import Test.Hspec.QuickCheck (prop) + +import Data.Graph.Inductive.PatriciaTree (Gr) + +-------------------------------------------------------------------------------- + +spec :: Spec +spec = do + prop "FGL Graphs are augmentable" + (prop_dotizeAugment :: GrType -> Bool) + prop "Ensure augmentation is valid" + (prop_dotizeHasAugment :: GrType -> Bool) + prop "Unique edges in augmented FGL Graphs" + (prop_dotizeAugmentUniq :: GrType -> Bool) + +type GrType = Gr Char Double diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,23 @@ +{- | + Module : Main + Description : Top-level HSpec runner + Copyright : Matthew Sackman, Ivan Lazar Miljenovic + License : BSD3 + Maintainer : Ivan.Miljenovic@gmail.com + + Used as we want to wrap default QuickCheck configurations. + + -} +module Main where + +import qualified Spec +import Test.Hspec.QuickCheck (modifyMaxSize, modifyMaxSuccess) +import Test.Hspec.Runner (hspec) + +-------------------------------------------------------------------------------- + +main :: IO () +main = hspec + . modifyMaxSuccess (const 200) + . modifyMaxSize (const 50) + $ Spec.spec diff --git a/tests/RunTests.hs b/tests/RunTests.hs deleted file mode 100644 --- a/tests/RunTests.hs +++ /dev/null @@ -1,83 +0,0 @@ -{- | - Module : RunTests - Description : Run the graphviz test suite. - Copyright : (c) Ivan Lazar Miljenovic - License : 3-Clause BSD-style - Maintainer : Ivan.Miljenovic@gmail.com - - This module exists solely to make a Main module to build and run - the test suite. --} -module Main where - -import Data.GraphViz.Testing (Test (name, lookupName), 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 ++ " Run the test associated with each key," - , " (where denotes a space-separated list of keys" - , " from the table below)." - , "" - , helpTable - ] - -helpTable :: String -helpTable = unlines $ fmtName ((lnHeader,lnHeaderLen),(nHeader,nHeaderLen)) - : line - : map fmtName testNames - where - andLen = ((id &&& length) .) - testNames = map (andLen lookupName &&& andLen name) 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 diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} diff --git a/utils/AttributeGenerator.hs b/utils/AttributeGenerator.hs --- a/utils/AttributeGenerator.hs +++ b/utils/AttributeGenerator.hs @@ -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 | diff --git a/utils/Benchmark.hs b/utils/Benchmark.hs --- a/utils/Benchmark.hs +++ b/utils/Benchmark.hs @@ -1,5 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + {- | Module : Benchmark Description : Benchmarking utilities for graphviz @@ -10,13 +12,13 @@ -} module Main where -import Data.GraphViz hiding (DotGraph) +import Data.GraphViz hiding (DotGraph) import Data.GraphViz.Types.Generalised import Criterion.Main import Control.DeepSeq -import Data.Text.Lazy(Text) +import Data.Text.Lazy (Text) -- ----------------------------------------------------------------------------- diff --git a/utils/TestParsing.hs b/utils/TestParsing.hs --- a/utils/TestParsing.hs +++ b/utils/TestParsing.hs @@ -1,4 +1,4 @@ -{-# 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