diff --git a/Changelog b/Changelog --- a/Changelog +++ b/Changelog @@ -7,6 +7,31 @@ The following is information about what major changes have gone into each release. +Changes in 2999.11.0.0 +---------------------- + +* Addition of the `Labellable` class (and its method `toLabel`) to + make it easier to construct labels. + +* Backslashes (i.e. the `\` character) are now escaped/unescaped + properly (bug spotted by **Han Joosten**). As part of this: + + - Dot-specific escapes such as `\N` are now also handled + correctly, so the slash does not need to be escaped. + + - Newline (`'\n'`) characters in labels, etc. are escaped to + centred-newlines in Dot code, but not unescaped. + +* `Point` values can now have the optional third dimension and end in + a `!` to indicate that that position should be used (as input to + Graphviz). + +* `LayerList` uses `LayerID` values, and now has a proper `shrink` + implementation in the test suite. + +* The optional `z` coordinate and `!` argument for `Point` values are + now supported. + Changes in 2999.10.0.1 ---------------------- diff --git a/Data/GraphViz.hs b/Data/GraphViz.hs --- a/Data/GraphViz.hs +++ b/Data/GraphViz.hs @@ -1,6 +1,4 @@ -{-# LANGUAGE MultiParamTypeClasses - , FlexibleContexts - #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-} {- | Module : Data.GraphViz @@ -21,16 +19,17 @@ module Data.GraphViz ( -- * Conversion from graphs to /Dot/ format. -- ** Specifying parameters. + -- $params GraphvizParams(..) , defaultParams , nonClusteredParams , blankParams , setDirectedness - -- ** Converting graphs. - , graphToDot - -- ** Conversion with support for clusters. + -- *** Specifying clusters. , LNodeCluster , NodeCluster(..) + -- ** Converting graphs. + , graphToDot -- ** Pseudo-inverse conversion. , dotToGraph -- * Graph augmentation. @@ -88,6 +87,62 @@ -- ----------------------------------------------------------------------------- +{- $params + + A 'GraphvizParams' value contains all the information necessary to + manipulate 'Graph's with this library. As such, its components deal + with: + + * Whether to treat graphs as being directed or not; + + * Which top-level 'GlobalAttributes' values should be applied; + + * How to define (and name) clusters; + + * How to format clusters, nodes and edges. + + Apart from not having to pass multiple values around, another + advantage of using 'GraphvizParams' over the previous approach is that + there is no distinction between clustering and non-clustering variants + of the same functions. + + Example usages of 'GraphvizParams' follow: + + * Quickly visualise a graph using the default parameters. Note the + usage of @'nonClusteredParams'@ over @'defaultParams'@ to avoid + type-checking problems with the cluster type. + + > defaultVis :: (Graph gr) => gr nl el -> DotGraph Node + > defaultVis = graphToDot nonClusteredParams + + * As with @defaultVis@, but determine whether or not the graph is + directed or undirected. + + > checkDirectednessVis :: (Graph gr, Ord el) => gr nl el -> DotGraph Node + > checkDirectednessVis = setDirectedness graphToDot nonClusteredParams + + * Clustering nodes based upon whether they are even or odd. We have + the option of either constructing a @GraphvizParams@ directly, or + using @'blankParams'@. Going with the latter to avoid setting + @'isDirected'@. + + > evenOdd :: (Graph gr, Ord el) => gr Int el -> DotGraph Node + > evenOdd = setDirectedness graphToDot params + > where + > params = blankParams { globalAttributes = [] + > , clusterBy = clustBy + > , clusterID = Just . Int + > , fmtCluster = clFmt + > , fmtNode = const [] + > , fmtEdge = const [] + > } + > clustBy (n,l) = C (n `mod` 2) $ N (n,l) + > clFmt m = [GraphAttrs [toLabel $ "n == " ++ show m ++ " (mod 2)"]] + + For more examples, see the source of 'dotizeGraph' and 'preview'. + +-} + -- | Defines the parameters used to convert a 'Graph' into a 'DotRepr'. -- -- A value of type @'GraphvizParams' nl el cl l@ indicates that the @@ -98,32 +153,33 @@ -- -- The clustering in 'clusterBy' can be to arbitrary depth. data GraphvizParams nl el cl l - = Params { -- | 'True' if the 'Graph' is directed; 'False' + = Params { -- | @True@ if the graph is directed; @False@ -- otherwise. isDirected :: Bool -- | The top-level global 'Attributes' for the entire - -- 'Graph'. + -- graph. , globalAttributes :: [GlobalAttributes] -- | A function to specify which cluster a particular -- 'LNode' is in. , clusterBy :: (LNode nl -> LNodeCluster cl l) - -- | The 'GraphID' for a cluster. + -- | The name/identifier for a cluster. , clusterID :: (cl -> Maybe GraphID) -- | Specify which global attributes are applied in -- the given cluster. , fmtCluster :: (cl -> [GlobalAttributes]) - -- | The specific 'Attributes' for that 'LNode'. + -- | The specific @Attributes@ for a node. , fmtNode :: (LNode l -> Attributes) - -- | The specific 'Attributes' for that 'LEdge'. + -- | The specific @Attributes@ for an edge. , fmtEdge :: (LEdge el -> Attributes) } -- | A default 'GraphvizParams' value which assumes the graph is -- directed, contains no clusters and has no 'Attribute's set. -- --- If you wish to have the labels of the nodes after applying --- 'clusterBy' to have a different from before clustering, then you --- will have to specify your own 'GraphvizParams' value from scratch. +-- If you wish to have the labels of the nodes to have a different +-- type after applying 'clusterBy' from before clustering, then you +-- will have to specify your own 'GraphvizParams' value from +-- scratch (or use 'blankParams'). defaultParams :: GraphvizParams nl el cl nl defaultParams = Params { isDirected = True , globalAttributes = [] @@ -135,9 +191,9 @@ } -- | A variant of 'defaultParams' that enforces that the clustering --- type is @'()'@; this avoids problems when using 'defaultParams' --- internally within a function without any constraint on what the --- clustering type is. +-- type is @'()'@ (i.e.: no clustering); this avoids problems when +-- using 'defaultParams' internally within a function without any +-- constraint on what the clustering type is. nonClusteredParams :: GraphvizParams nl el () nl nonClusteredParams = defaultParams @@ -145,7 +201,9 @@ -- @'undefined'@. This is useful when you have a function that will -- set some of the values for you (e.g. 'setDirectedness') but you -- don't want to bother thinking of default values to set in the --- meantime. +-- meantime. This is especially useful when you are +-- programmatically setting the clustering function (and as such do +-- not know what the types might be). blankParams :: GraphvizParams nl el cl l blankParams = Params { isDirected = undefined , globalAttributes = undefined @@ -415,11 +473,17 @@ canonicalise :: (DotRepr dg n, DotRepr DotGraph n) => dg n -> IO (DotGraph n) canonicalise = liftM parseDotGraph . prettyPrint --- | Quickly visualise a graph using the 'Xlib' 'GraphvizCanvas'. -preview :: (Ord el, Graph gr) => gr nl el -> IO () +-- | Quickly visualise a graph using the 'Xlib' 'GraphvizCanvas'. If +-- your label types are not (and cannot) be instances of 'Labellable', +-- you may wish to use 'gmap', 'nmap' or 'emap' to set them to a value +-- such as @\"\"@. +preview :: (Ord el, Graph gr, Labellable nl, Labellable el) => gr nl el -> IO () preview g = ign $ forkIO (ign $ runGraphvizCanvas' dg Xlib) where - dg = setDirectedness graphToDot nonClusteredParams g + dg = setDirectedness graphToDot params g + params = nonClusteredParams { fmtNode = \ (_,l) -> [toLabel l] + , fmtEdge = \ (_, _, l) -> [toLabel l] + } ign = (>> return ()) -- | Used for obtaining results from 'graphvizWithHandle', etc. when diff --git a/Data/GraphViz/Attributes.hs b/Data/GraphViz/Attributes.hs --- a/Data/GraphViz/Attributes.hs +++ b/Data/GraphViz/Attributes.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} + {- | Module : Data.GraphViz.Attributes Description : Definition of the Graphviz attributes. @@ -27,11 +29,12 @@ (since /A/ is at the tail end of the arrow). * @ColorList@, @DoubleList@ and @PointfList@ are defined as actual - lists (but 'LayerList' is not). All of these are assumed to be - non-empty lists. Note that for the @Color@ 'Attribute' for node - values, only a single Color is valid; edges are allowed multiple - colors with one spline/arrow per color in the list (but you must have - at least one 'Color' in the list). This might be changed in future. + lists (@'LayerList'@ needs a newtype for other reasons). All of these + are assumed to be non-empty lists. Note that for the @Color@ + 'Attribute' for node values, only a single Color is valid; edges are + allowed multiple colors with one spline/arrow per color in the list + (but you must have at least one 'Color' in the list). This might be + changed in future. * Style is implemented as a list of 'StyleItem' values; note that empty lists are not allowed. @@ -41,10 +44,8 @@ expanded upon to give an idea of what they represent rather than using generic terms. - * @PointF@ and 'Point' have been combined, and feature support for pure - 'Int'-based co-ordinates as well as 'Double' ones (i.e. no floating - point-only points for Point). The optional '!' and third value - for Point are not available. + * @PointF@ and 'Point' have been combined. The optional '!' and + third value for Point are also available. * 'Rect' uses two 'Point' values to denote the lower-left and top-right corners. @@ -79,63 +80,41 @@ , usedByClusters , usedByNodes , usedByEdges + -- * Value types for @Attribute@s. + , module Data.GraphViz.Attributes.Colors + + -- ** Labels , EscString - , ArrowType(..) - , AspectType(..) - , Rect(..) - , ClusterMode(..) - , DirType(..) - , DEConstraints(..) - , DPoint(..) - , ModeType(..) - , Model(..) , Label(..) - , Point(..) - , Overlap(..) - , LayerRange(..) - , LayerID(..) - , LayerList(..) - , OutputMode(..) - , Pack(..) - , PackMode(..) - , Pos(..) - , EdgeType(..) - , PageDir(..) - , Spline(..) - , QuadType(..) - , Root(..) - , RankType(..) - , RankDir(..) - , Shape(..) - , SmoothType(..) - , StartType(..) - , STStyle(..) - , StyleItem(..) - , StyleName(..) - , ViewPort(..) - , FocusType(..) + , Labellable(..) , VerticalPlacement(..) - , ScaleType(..) + , module Data.GraphViz.Attributes.HTML + -- *** Types representing the Dot grammar for records. + , RecordFields + , RecordField(..) + , Rect(..) , Justification(..) - , Ratios(..) - -- Re-exported from Data.GraphViz.Attributes.Internal + + -- ** Nodes + , Shape(..) + , ScaleType(..) + + -- ** Edges + , DirType(..) + , EdgeType(..) + -- *** Modifying where edges point , PortName(..) , PortPos(..) , CompassPoint(..) - -- Re-exporting modules - , module Data.GraphViz.Attributes.Colors - , module Data.GraphViz.Attributes.HTML - -- * Types representing the Dot grammar for records. - , RecordFields - , RecordField(..) - -- * Types representing the Dot grammar for @ArrowType@. + -- *** Arrows + , ArrowType(..) , ArrowShape(..) , ArrowModifier(..) , ArrowFill(..) , ArrowSide(..) - -- ** Default @ArrowType@ aliases. - -- *** The 9 primitive @ArrowShape@s. + -- **** Default @ArrowType@ aliases. + -- ***** The 9 primitive @ArrowShape@s. , box , crow , diamond @@ -145,24 +124,63 @@ , normal , tee , vee - -- *** 5 derived Arrows. + -- ***** 5 derived Arrows. , oDot , invDot , invODot , oBox , oDiamond - -- *** 5 supported cases for backwards compatibility + -- ***** 5 supported cases for backwards compatibility , eDiamond , openArr , halfOpen , emptyArr , invEmpty - -- ** @ArrowModifier@ instances + -- **** @ArrowModifier@ instances , noMods , openMod - -- * Other exported functions\/values + + -- ** Positioning + , Point(..) + , createPoint + , Pos(..) + , Spline(..) + , DPoint(..) + + -- ** Layout + , AspectType(..) + , ClusterMode(..) + , Model(..) + , Overlap(..) + , Root(..) + , OutputMode(..) + , Pack(..) + , PackMode(..) + , PageDir(..) + , QuadType(..) + , RankType(..) + , RankDir(..) + , StartType(..) + , ViewPort(..) + , FocusType(..) + , Ratios(..) + + -- ** Modes + , ModeType(..) + , DEConstraints(..) + + -- ** Layers + , LayerRange(..) + , LayerID(..) + , LayerList(..) , defLayerSep , notLayerSep + + -- ** Stylistic + , SmoothType(..) + , STStyle(..) + , StyleItem(..) + , StyleName(..) ) where import Data.GraphViz.Attributes.Colors @@ -1257,6 +1275,7 @@ -- ----------------------------------------------------------------------------- +-- | Should only have 2D points (i.e. created with 'createPoint'). data Rect = Rect Point Point deriving (Eq, Ord, Show, Read) @@ -1266,7 +1285,7 @@ toDot = doubleQuotes . unqtDot instance ParseDot Rect where - parseUnqt = liftM (uncurry Rect) commaSepUnqt + parseUnqt = liftM (uncurry Rect) $ commaSep' parsePoint2D parsePoint2D parse = quotedParse parseUnqt @@ -1328,7 +1347,8 @@ -- ----------------------------------------------------------------------------- --- | Either a 'Double' or a 'Point'. +-- | Either a 'Double' or a (2D) 'Point' (i.e. created with +-- 'createPoint'). data DPoint = DVal Double | PVal Point deriving (Eq, Ord, Show, Read) @@ -1341,13 +1361,13 @@ toDot (PVal p) = toDot p instance ParseDot DPoint where - parseUnqt = liftM PVal parseUnqt + parseUnqt = liftM PVal parsePoint2D `onFail` liftM DVal parseUnqt - parse = liftM PVal parse + parse = quotedParse parseUnqt `onFail` - liftM DVal parse + liftM DVal parseUnqt -- ----------------------------------------------------------------------------- @@ -1426,6 +1446,51 @@ , liftM StrLabel parse ] +-- | A convenience class to make it easier to create labels. It is +-- highly recommended that you make any other types that you wish to +-- create labels from an instance of this class, preferably via the +-- @String@ instance. +class Labellable a where + toLabel :: a -> Attribute + +instance Labellable EscString where + toLabel = Label . StrLabel + +instance Labellable Char where + toLabel = toLabel . (:[]) + +instance Labellable Int where + toLabel = toLabel . show + +instance Labellable Double where + toLabel = toLabel . show + +instance Labellable Bool where + toLabel = toLabel . show + +instance Labellable HtmlLabel where + toLabel = Label . HtmlLabel + +instance Labellable HtmlText where + toLabel = toLabel . HtmlText + +instance Labellable HtmlTable where + toLabel = toLabel . HtmlTable + +instance Labellable RecordFields where + toLabel = Label . RecordLabel + +instance Labellable RecordField where + toLabel = toLabel . (:[]) + +-- | A shorter variant than using @PortName@ from 'RecordField'. +instance Labellable PortName where + toLabel = toLabel . PortName + +-- | A shorter variant than using 'LabelledTarget'. +instance Labellable (PortName, EscString) where + toLabel = toLabel . uncurry LabelledTarget + -- ----------------------------------------------------------------------------- -- | A RecordFields value should never be empty. @@ -1489,7 +1554,7 @@ printPortName = angled . unqtRecordString . portName parseRecord :: Parse String -parseRecord = parseEscaped False recordEscChars +parseRecord = parseEscaped False recordEscChars [] unqtRecordString :: String -> DotCode unqtRecordString = unqtEscaped recordEscChars @@ -1499,11 +1564,27 @@ -- ----------------------------------------------------------------------------- -data Point = Point Double Double - deriving (Eq, Ord, Show, Read) +data Point = Point { xCoord :: Double + , yCoord :: Double + -- | Can only be 'Just' for @'Dim' 3@ or greater. + , zCoord :: Maybe Double + -- | Input to Graphviz only: specify that the + -- node position should not change. + , forcePos :: Bool + } + deriving (Eq, Ord, Show, Read) +-- | Create a point with only @x@ and @y@ values. +createPoint :: Double -> Double -> Point +createPoint x y = Point x y Nothing False + +parsePoint2D :: Parse Point +parsePoint2D = liftM (uncurry createPoint) commaSepUnqt + instance PrintDot Point where - unqtDot (Point x y) = commaDel x y + unqtDot (Point x y mz frs) = bool id (<> char '!') frs + . maybe id (\ z -> (<> unqtDot z) . (<> comma)) mz + $ commaDel x y toDot = doubleQuotes . unqtDot @@ -1512,11 +1593,10 @@ listToDot = doubleQuotes . unqtListToDot instance ParseDot Point where - -- Need to take into account the situation where first value is an - -- integer, second a double: if Point parsing first, then it won't - -- parse the second number properly; but if PointD first then it - -- will treat Int/Int as Double/Double. - parseUnqt = liftM (uncurry Point) commaSepUnqt + parseUnqt = do (x,y) <- commaSepUnqt + mz <- optional $ parseComma >> parseUnqt + bng <- liftM isJust . optional $ character '!' + return $ Point x y mz bng parse = quotedParse parseUnqt @@ -1561,29 +1641,31 @@ -- ----------------------------------------------------------------------------- data LayerRange = LRID LayerID - | LRS LayerID String LayerID + | LRS LayerID LayerID deriving (Eq, Ord, Show, Read) instance PrintDot LayerRange where - unqtDot (LRID lid) = unqtDot lid - unqtDot (LRS id1 s id2) = unqtDot id1 <> unqtDot s <> unqtDot id2 + unqtDot (LRID lid) = unqtDot lid + unqtDot (LRS id1 id2) = unqtDot id1 <> s <> unqtDot id2 + where + s = unqtDot $ head defLayerSep toDot (LRID lid) = toDot lid toDot lrs = doubleQuotes $ unqtDot lrs instance ParseDot LayerRange where parseUnqt = do id1 <- parseUnqt - s <- parseLayerSep + _ <- parseLayerSep id2 <- parseUnqt - return $ LRS id1 s id2 + return $ LRS id1 id2 `onFail` liftM LRID parseUnqt parse = quotedParse ( do id1 <- parseUnqt - s <- parseLayerSep + _ <- parseLayerSep id2 <- parseUnqt - return $ LRS id1 s id2 + return $ LRS id1 id2 ) `onFail` liftM LRID parse @@ -1592,12 +1674,12 @@ parseLayerSep = many1 . oneOf $ map character defLayerSep +-- | The default separators for 'LayerSep'. defLayerSep :: [Char] defLayerSep = [' ', ':', '\t'] parseLayerName :: Parse String -parseLayerName = many1 . orQuote - $ satisfy (liftM2 (&&) notLayerSep (quoteChar /=)) +parseLayerName = parseEscaped False [] defLayerSep parseLayerName' :: Parse String parseLayerName' = stringBlock @@ -1607,11 +1689,11 @@ notLayerSep :: Char -> Bool notLayerSep = flip notElem defLayerSep --- | You should not have any quote characters for the 'LRName' option, --- as it won't be parseable. +-- | You should not have any layer separator characters for the +-- 'LRName' option, as they won't be parseable. data LayerID = AllLayers | LRInt Int - | LRName String + | LRName String -- ^ Should not be a number of @"all"@. deriving (Eq, Ord, Show, Read) instance PrintDot LayerID where @@ -1623,6 +1705,15 @@ -- Other two don't need quotes toDot li = unqtDot li + unqtListToDot = hcat . punctuate s . map unqtDot + where + s = unqtDot $ head defLayerSep + + listToDot [l] = toDot l + -- Might not need quotes, but probably will. Can't tell either + -- way since we don't know what the separator character will be. + listToDot ll = doubleQuotes $ unqtDot ll + instance ParseDot LayerID where parseUnqt = liftM checkLayerName parseLayerName -- tests for Int and All @@ -1637,31 +1728,23 @@ then AllLayers else LRName str --- | The list represent (Separator, Name). You should not have any --- quote characters for any of the 'String's, since there are --- parsing problems with them. -data LayerList = LL String [(String, String)] - deriving (Eq, Ord, Show, Read) +-- | A non-empty list of layer names. The names should all be +-- 'LRName' values, and when printed will use an arbitrary character +-- from 'defLayerSep'. +newtype LayerList = LL [LayerID] + deriving (Eq, Ord, Show, Read) instance PrintDot LayerList where - unqtDot (LL l1 ols) = unqtDot l1 <> hcat (map subLL ols) - where - subLL (s, l) = unqtDot s <> unqtDot l + unqtDot (LL ll) = unqtDot ll - toDot (LL l1 []) = toDot l1 - -- Might not need quotes, but probably will. - toDot ll = doubleQuotes $ unqtDot ll + toDot (LL ll) = toDot ll instance ParseDot LayerList where - parseUnqt = do l1 <- parseLayerName - ols <- many $ do s <- parseLayerSep - lnm <- parseLayerName - return (s, lnm) - return $ LL l1 ols + parseUnqt = liftM LL $ sepBy1 parseUnqt parseLayerSep - parse = quotedParse parseUnqt - `onFail` - liftM (flip LL []) (parseLayerName' `onFail` numString) + parse = quotedParse parseUnqt + `onFail` + liftM (LL . (:[]) . LRName) stringBlock -- ----------------------------------------------------------------------------- @@ -2219,11 +2302,14 @@ _ -> DD str parseStyleName :: Parse String -parseStyleName = do f <- orQuote . noneOf $ ' ' : disallowedChars - r <- many (orQuote $ noneOf disallowedChars) +parseStyleName = do f <- orEscaped . noneOf $ ' ' : disallowedChars + r <- parseEscaped True [] disallowedChars return $ f:r where disallowedChars = [quoteChar, '(', ')', ','] + -- Used because the first character has slightly stricter requirements than the rest. + orSlash p = stringRep '\\' "\\\\" `onFail` p + orEscaped = orQuote . orSlash -- ----------------------------------------------------------------------------- @@ -2254,6 +2340,7 @@ parse = quotedParse parseUnqt +-- | For use with 'ViewPort'. data FocusType = XY Point | NodeFocus String deriving (Eq, Ord, Show, Read) 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 @@ -50,8 +50,8 @@ toDot = toDot . portName instance ParseDot PortName where - parseUnqt = liftM PN . many1 - . orQuote $ satisfy (`notElem` ['"', ':']) + parseUnqt = liftM PN + $ parseEscaped False [] ['"', ':'] parse= quotedParse parseUnqt `onFail` diff --git a/Data/GraphViz/Commands.hs b/Data/GraphViz/Commands.hs --- a/Data/GraphViz/Commands.hs +++ b/Data/GraphViz/Commands.hs @@ -59,7 +59,7 @@ import System.Exit(ExitCode(ExitSuccess)) import System.Process(runInteractiveProcess, waitForProcess) import Control.Concurrent(MVar, forkIO, newEmptyMVar, putMVar, takeMVar) -import Control.Exception.Extensible( SomeException(..), catch +import Control.Exception.Extensible( IOException, catch , bracket, evaluate, handle) import Control.Monad(liftM) import System.FilePath((<.>)) @@ -355,22 +355,25 @@ ExitSuccess -> return output _ -> return $ Left $ othErr ++ err where - notRunnable e@SomeException{} = return . Left $ unwords - [ "Unable to call the Graphviz command " - , cmd' - , " with the arguments: " - , unwords args - , " because of: " - , show e - ] + notRunnable :: IOException -> IO (Either String a) + notRunnable e = return . Left $ unwords + [ "Unable to call the Graphviz command " + , cmd' + , " with the arguments: " + , unwords args + , " because of: " + , show e + ] cmd' = showCmd cmd args = ["-T" ++ outputCall t] -- Augmenting the f function to let it work within the forkIO: f' h = liftM Right (f h) `catch` - (\e@SomeException{} -> return . Left $ fErr ++ show e) - fErr = "Error re-directing the output from " ++ cmd' ++ ": " + fErr + fErr :: IOException -> IO (Either String a) + fErr e = return . Left $ "Error re-directing the output from " + ++ cmd' ++ ": " ++ show e othErr = "Error messages from " ++ cmd' ++ ":\n" diff --git a/Data/GraphViz/Parsing.hs b/Data/GraphViz/Parsing.hs --- a/Data/GraphViz/Parsing.hs +++ b/Data/GraphViz/Parsing.hs @@ -82,7 +82,9 @@ import Data.Char( digitToInt , isDigit , isSpace + , isLower , toLower + , toUpper ) import Data.Maybe(fromMaybe, isNothing) import Data.Ratio((%)) @@ -204,7 +206,7 @@ -- | Used when quotes are explicitly required; quotedString :: Parse String -quotedString = parseEscaped True [] +quotedString = parseEscaped True [] [] parseSigned :: Real a => Parse a -> Parse a parseSigned p = (character '-' >> liftM negate p) @@ -303,7 +305,10 @@ `adjustErr` (++ "\nnot the expected char: " ++ [c]) where - parseC c' = c' == c || toLower c == c' + parseC c' = c' == c || c == flipCase c' + flipCase c' = if isLower c' + then toUpper c' + else toLower c' noneOf :: (Eq a) => [a] -> Parser a a noneOf t = satisfy (\x -> all (/= x) t) @@ -346,22 +351,24 @@ quoteChar :: Char quoteChar = '"' --- | Parse a 'String' where the provided 'Char's (as well as @\"@) are --- escaped. Note: does not parse surrounding quotes, and assumes --- that @\\@ is not an escaped character. The 'Bool' value --- indicates whether empty 'String's are allowed or not. -parseEscaped :: Bool -> [Char] -> Parse String -parseEscaped empt cs = lots $ qPrs `onFail` oth +-- | Parse a 'String' where the provided 'Char's (as well as @\"@ and +-- @\\@) are escaped and the second list of 'Char's are those that +-- are not permitted. Note: does not parse surrounding quotes. The +-- 'Bool' value indicates whether empty 'String's are allowed or +-- not. +parseEscaped :: Bool -> [Char] -> [Char] -> Parse String +parseEscaped empt cs bnd = lots $ qPrs `onFail` oth where lots = if empt then many else many1 - cs' = quoteChar : cs + cs' = quoteChar : slash : cs csSet = Set.fromList cs' + bndSet = Set.fromList bnd `Set.union` csSet slash = '\\' -- Have to allow standard slashes qPrs = do character slash mE <- optional $ oneOf (map character cs') return $ fromMaybe slash mE - oth = satisfy (`Set.notMember` csSet) + oth = satisfy (`Set.notMember` bndSet) newline :: Parse String newline = oneOf $ map string ["\r\n", "\n", "\r"] diff --git a/Data/GraphViz/Printing.hs b/Data/GraphViz/Printing.hs --- a/Data/GraphViz/Printing.hs +++ b/Data/GraphViz/Printing.hs @@ -74,6 +74,7 @@ import Data.Char(toLower) import qualified Data.Set as Set import Data.Word(Word8, Word16) +import Control.Monad(ap) -- ----------------------------------------------------------------------------- @@ -216,13 +217,23 @@ -- needs to pass the result from this to 'addQuotes' to determine if -- it needs to be quoted or not. addEscapes :: [Char] -> String -> String -addEscapes cs = foldr escape "" +addEscapes cs = foldr escape "" . withNext where - cs' = Set.fromList $ quote : cs + cs' = Set.fromList $ quote : slash : cs slash = '\\' quote = '"' - escape c str | c `Set.member` cs' = slash : c : str - | otherwise = c : str + escape (c,c') str + | c == slash && c' `Set.member` escLetters = c : str + | c `Set.member` cs' = slash : c : str + | c == '\n' = slash : 'n' : str + | otherwise = c : str + + -- When a slash precedes one of these characters, don't escape the slash. + escLetters = Set.fromList ['N', 'G', 'E', 'T', 'H', 'L', 'n', 'l', 'r'] + + -- Need to check subsequent characters when escaping slashes, but + -- don't want to lose the last character when zipping, so append a space. + withNext = zip `ap` ((++" ") . tail) angled :: DotCode -> DotCode angled = wrap lang rang diff --git a/Data/GraphViz/Testing/Instances.hs b/Data/GraphViz/Testing/Instances.hs --- a/Data/GraphViz/Testing/Instances.hs +++ b/Data/GraphViz/Testing/Instances.hs @@ -31,7 +31,6 @@ import qualified Data.Sequence as Seq import qualified Data.Map as Map import Control.Monad(liftM, liftM2, liftM3, liftM4) -import Data.Word(Word8, Word16) -- ----------------------------------------------------------------------------- -- Defining Arbitrary instances for the overall types @@ -599,14 +598,6 @@ validUnknown _ = True {- delete to here -} -instance Arbitrary Word8 where - arbitrary = arbitraryBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary Word16 where - arbitrary = arbitraryBoundedIntegral - shrink = shrinkIntegral - instance Arbitrary ArrowType where arbitrary = liftM AType -- Arrow specifications have between 1 and 4 elements. @@ -637,7 +628,7 @@ return $ RatioPassCount ds is instance Arbitrary Rect where - arbitrary = liftM2 Rect arbitrary arbitrary + arbitrary = liftM2 Rect point2D point2D shrink (Rect p1 p2) = do p1s <- shrink p1 p2s <- shrink p2 @@ -645,12 +636,18 @@ instance Arbitrary Point where -- Pretty sure points have to be positive... - arbitrary = liftM2 Point posArbitrary posArbitrary + arbitrary = liftM4 Point posArbitrary posArbitrary posZ arbitrary + where + posZ = frequency [(1, return Nothing), (3, liftM Just posArbitrary)] - shrink (Point v1 v2) = do v1s <- shrink v1 - v2s <- shrink v2 - return $ Point v1s v2s + shrink p = do x' <- shrink $ xCoord p + y' <- shrink $ yCoord p + z' <- shrinkM $ zCoord p + return $ Point x' y' z' False +point2D :: Gen Point +point2D = liftM2 createPoint posArbitrary posArbitrary + instance Arbitrary ClusterMode where arbitrary = arbBounded @@ -662,7 +659,7 @@ instance Arbitrary DPoint where arbitrary = oneof [ liftM DVal arbitrary - , liftM PVal arbitrary + , liftM PVal point2D ] shrink (DVal d) = map DVal $ shrink d @@ -729,21 +726,22 @@ shrink _ = [] instance Arbitrary LayerList where - arbitrary = do fs <- arbLayerName - oths <- listOf $ liftM2 (,) arbLayerSep arbLayerName - return $ LL fs oths + arbitrary = liftM LL $ listOf1 arbName + where + arbName = suchThat arbitrary isLayerName - -- This should be improved to try actually shrinking the seps and names. - -- shrink (LL _ [(_,fs')]) = [LL fs' []] - -- shrink (LL fs oths) = map (LL fs) $ shrink oths + isLayerName LRName{} = True + isLayerName _ = False + shrink (LL ll) = map LL $ nonEmptyShrinks ll + instance Arbitrary LayerRange where - arbitrary = oneof [ liftM LRID arbitrary - , liftM3 LRS arbitrary arbLayerSep arbitrary + arbitrary = oneof [ liftM LRID arbitrary + , liftM2 LRS arbitrary arbitrary ] - shrink (LRID nm) = map LRID $ shrink nm - shrink (LRS l1 _ l2) = [LRID l1, LRID l2] + shrink (LRID nm) = map LRID $ shrink nm + shrink (LRS l1 l2) = [LRID l1, LRID l2] instance Arbitrary LayerID where arbitrary = oneof [ return AllLayers @@ -1132,8 +1130,8 @@ arbitrary = arbBounded instance Arbitrary PortName where - arbitrary = liftM PN . flip suchThat (liftM2 (&&) (not . null) notCP) - $ liftM (filter (/= ':')) arbString + arbitrary = liftM PN + $ suchThat arbString (liftM2 (&&) (notElem ':') notCP) shrink = map PN . filter notCP . shrinkString . portName @@ -1150,26 +1148,31 @@ posArbitrary = liftM fromPositive arbitrary arbString :: Gen String -arbString = suchThat genStr validString +arbString = suchThat genStr notBool where - genStr = listOf1 $ elements strChr - strChr = ['a'..'z'] ++ ['0'..'9'] ++ ['\'', '"', ' ', '(', ')' - , ',', ':', '.'] + genStr = liftM2 (:) (elements notDigits) (listOf $ elements strChr) + notDigits = ['a'..'z'] ++ ['\'', '"', ' ', '(', ')', ',', ':', '\\'] + strChr = notDigits ++ '.' : ['0'..'9'] +{-# INLINE arbString #-} + arbIDString :: Gen String -arbIDString = suchThat genStr validString +arbIDString = suchThat genStr notBool where genStr = liftM2 (:) (elements frst) $ listOf (elements rest) frst = ['a'..'z'] ++ ['_'] rest = frst ++ ['0'.. '9'] -validString :: String -> Bool -validString "true" = False -validString "false" = False -validString str = notNumStr str +validString :: String -> Bool +validString = liftM2 (&&) notBool notNumStr +notBool :: String -> Bool +notBool "true" = False +notBool "false" = False +notBool _ = True + shrinkString :: String -> [String] -shrinkString = filter validString . nonEmptyShrinks +shrinkString = filter validString . nonEmptyShrinks' notNumStr :: String -> Bool notNumStr = not . isNumString @@ -1177,9 +1180,6 @@ arbBounded :: (Bounded a, Enum a) => Gen a arbBounded = elements [minBound .. maxBound] -arbLayerSep :: Gen [Char] -arbLayerSep = listOf1 (elements defLayerSep) - arbLayerName :: Gen String arbLayerName = suchThat arbString (all notLayerSep) @@ -1194,11 +1194,18 @@ nonEmptyShrinks :: (Arbitrary a) => [a] -> [[a]] nonEmptyShrinks = filter (not . null) . shrinkList +nonEmptyShrinks' :: [a] -> [[a]] +nonEmptyShrinks' = filter (not . null) . shrinkList' + -- Shrink lists with more than one value only by removing values, not -- by shrinking individual items. shrinkList :: (Arbitrary a) => [a] -> [[a]] shrinkList [a] = map return $ shrink a -shrinkList as = rm (length as) as +shrinkList as = shrinkList' as + +-- Just shrink the size. +shrinkList' :: [a] -> [[a]] +shrinkList' as = rm (length as) as where rm 0 _ = [] rm 1 _ = [[]] diff --git a/FAQ b/FAQ --- a/FAQ +++ b/FAQ @@ -55,13 +55,18 @@ [output formats]: http://www.graphviz.org/doc/info/output.html * Functions to convert [FGL] graphs to and from the internal Dot - representations. + representations. In future, this will be expanded to a much larger + range of graph-like values once a suitable abstraction is available. [FGL]: http://web.engr.oregonstate.edu/~erwig/fgl/haskell/ * The ability to augment Dot and FGL graphs with positioning information by round-trip passing through Graphviz. +* _graphviz_ is continually being worked upon and expanded to better + suit/match the requirements of Graphviz, to improve performance and + to make it easier for the programmer to use. + ### Is the API of _graphviz_ stable? ### For the most part, yes: the only items that are likely to change in @@ -110,9 +115,9 @@ * The deprecated `overlap` algorithms have not been defined. -* `pointf` and `point` values have been combined into one datatype; - however the optional `!` and third value for `point` values is not - accepted. +* `pointf` and `point` values have been combined into one datatype; as + such, when constructing values such as `Rect` care should be taken + about which parts of a `Point` are allowed. * Only polygon-based `shape`s are available. @@ -151,6 +156,11 @@ * HTML-like and record labels are available, and feature proper escaping/unescaping when printing/parsing. +* Other syntactic issues are taken care of for you automatically (such + as escaping/unescaping quotation marks). Even newlines are + automatically escaped (but not unescaped) for you, defaulting to + centered lines. + Getting _graphviz_ and more documentation ----------------------------------------- @@ -201,7 +211,10 @@ ### Are there any tutorials on how to use _graphviz_? ### -There will be soon. +There will be soon. The current stumbling block is that each time I +sit down to write a tutorial, I find that it would be even better if +_graphviz_ had some extra features in it first, so the tutorial has to +wait until I have finished that feature... ### What other packages use _graphviz_? ### @@ -232,11 +245,11 @@ ### Can I start using _graphviz_ without knowing anything about Graphviz? ### -Unfortunately, no: the layout and design of _graphviz_ is heavily -based upon the Dot language and the various [attributes] that Graphviz -supports. As such, you can't just suffice on the documentation -available in _graphviz_ (unless you're doing something _very_ -simplistic). +You can, but if you want to start doing anything more advanced then +you should be reading Graphviz's documentation as well as +_graphviz_'s. This is because the layout and design of _graphviz_ is +heavily based upon the Dot language and the various [attributes] that +Graphviz supports. ### Can I just use _graphviz_ without reading its documentation? ### @@ -314,27 +327,31 @@ - `Color` to set the colour of an edge; if you supply more than one value then the edge is drawn using parallel splines/lines - (one per colour in the list). + (one per colour in the list). This can also be used to set the + border colour for a node, but if a filled style is used and + `FillColor` isn't set then this will also set the background + colour. - `PenColor` to set the colour of the bounding box for a cluster. - When choosing a `Color` value for one of the above, it is better to - use one of the `X11Color` values (note: these are **not** the same - as the standard X11 colours) or - if you have to - one of the manual - colours over a `BrewerColor`, as they come under a different license - and have no real standard on what the values are. + When choosing a `Color` value for one of the above, it is + better to use one of the `X11Color` values (note: these + colours slightly differ from the standard X11 colours) or - if + you have to - one of the manual colours over a `BrewerColor`, + as they come under a different license and have no real + standard on what the values are. -* `Label`: `StrLabel` can be used for both nodes and edges; the other - two only for nodes. `RecordLabel` and `HtmlLabel` provide ways of - having more fine-grained control over a node's layout with different - sub-components, etc.; in most cases these won't be needed. +* For labels, use the `Labellable` class to more easily construct + labels. In most cases, a `String`-based label will suffice; for + more fine-grained control over layout, colours, etc. use either a + `RecordFields` or an `HtmlLabel`. * `Rank`: this lets you control relative placement of sub-graphs and clusters. -* `Shape`: Use `Record` and `MRecord` for `RecordLabel` labels; feel - free to use any other ones at any time (though you probably want to - use `PlainText` for `HtmlLabel` labels). +* `Shape`: Use `Record` and `MRecord` for `RecordFields`-based labels; + feel free to use any other ones at any time (though you probably + want to use `PlainText` for `HtmlLabel` labels). * `Style`: use this to set line types, etc. for nodes and edges. You should **not** use a `DD` (device-dependent) value. @@ -345,7 +362,8 @@ but in future _graphviz_ will not contain this attribute and will only allow UTF-8 usage. -* `Color` for anything except edge colours. +* `Color` for anything except edge colours (and if you must, the + border colour for a node). * `ColorScheme`: just stick with X11 colours. @@ -357,7 +375,7 @@ No: attributes are all defined in one big datatype for the sake of simplicity, but not all attributes are valid in all places. Read the -documentation (either in Graphviz or _graphviz_) to determine which is +documentation (either for Graphviz or _graphviz_) to determine which is suitable where. ### How can I use _graphviz_ to visualise non-FGL graphs? ### @@ -383,7 +401,7 @@ way of doing this is to have functions that convert between your type and `String` and let graphviz determine how to print and parse those. Here is an example of a more difficult type that should be printed -like "1: Foo": +like `"1: Foo"`: ~~~~~~~~~~~~~~~~~~~~ {.haskell} data MyType = MyType String Int @@ -418,7 +436,7 @@ conversion functions (`int`, `text`, etc.) to ensure that quotations, etc. are dealt with correctly. -* Be as liberal as you can when printing, especially with whitespace: +* Be as liberal as you can when parsing, especially with whitespace: when printing only one space is used, yet when parsing we use the `whitespace` parsing combinator that will parse all whitespace characters (but it must consume _at least_ one; there is a variant @@ -449,6 +467,9 @@ ] ~~~~~~~~~~~~~~~~~~~~ +I realise that doing this manually isn't as convenient, but I am open +to suggestions on how this can be improved. + Note where `TailPort` and `HeadPort` are used; the next question explains this. @@ -609,7 +630,7 @@ copy of the darcs repository: ~~~~~~~~~~~~~~~~~~~~ {.bash} -darcs get --lazy http://code.haskell.org/ +darcs get --lazy http://code.haskell.org/graphviz ~~~~~~~~~~~~~~~~~~~~ Once you've made your changes, make sure you build and run the diff --git a/graphviz.cabal b/graphviz.cabal --- a/graphviz.cabal +++ b/graphviz.cabal @@ -1,5 +1,5 @@ Name: graphviz -Version: 2999.10.0.1 +Version: 2999.11.0.0 Stability: Beta Synopsis: Graphviz bindings for Haskell. Description: { @@ -63,8 +63,8 @@ filepath, polyparse == 1.4.*, pretty, - bytestring < 0.10, - colour >= 2.3 && < 2.4, + bytestring == 0.9.*, + colour == 2.3.*, transformers == 0.2.* Exposed-Modules: Data.GraphViz @@ -84,7 +84,7 @@ Data.GraphViz.Types.State Data.GraphViz.Util if flag(test) - Build-Depends: QuickCheck >= 2.1 && < 2.2 + Build-Depends: QuickCheck >= 2.3 && < 2.5 Exposed-Modules: Data.GraphViz.Testing Data.GraphViz.Testing.Properties