diff --git a/Changelog b/Changelog --- a/Changelog +++ b/Changelog @@ -1,6 +1,20 @@ -Changes since 2999.1.0.2 -======================== +Changes in 2999.5.1.0 +===================== +* Potentially fixed the graphvizWithHandle bug; correct approach + spotted by Nikolas Mayr. + +* Fixed up Parsing of various Attribute sub-values, especially Point and + Spline (and hence Pos, which uses them). + +* Pre-process out comments and join together multi-line strings before + parsing. + +* Properly parse Doubles like ".2". + +Changes in 2999.5.0.0 +===================== + A major re-write occured; these are the highlights: * Re-write parsing and printing of Dot code using the new ParseDot and @@ -34,25 +48,25 @@ uses "from" and "to" avoid ambiguity; the various Attribute values still follow upstream usage. -Changes since 2999.1.0.1 -======================== +Changes in 2999.1.0.2 +===================== * Fix a bug spotted by Srihari Ramanathan where Color values were double-quoted. -Changes since 2999.1.0.0 -======================== +Changes in 2999.1.0.1 +===================== * The Color Attribute should take [Color], not just a single Color. -Changes since 2999.0.0.0 -======================== +Changes in 2999.1.0.0 +===================== * Stop using Either for composite Attributes and use a custom type: this avoids problems with the Show instance. -Changes since 2009.5.1 -====================== +Changes in 2999.0.0.0 +===================== * Fixed a bug where the Show instance and read function for DotEdge had the from/to nodes the wrong way round. This was not immediately @@ -79,8 +93,8 @@ * Follow the PVP rather than using dates for versions: http://www.haskell.org/haskellwiki/Package_versioning_policy -Changes since 2008.9.20: -======================== +Changes in 2009.5.1 +=================== * Support polyparse >= 1.1 (as opposed to < 1.3) @@ -96,8 +110,8 @@ * Improved Haddock documentation. -Changes since 2008.9.6 -====================== +Changes in 2008.9.20 +==================== * Differentiate between undirected and directed graphs (previously only directed graphs were supported). diff --git a/Data/GraphViz.hs b/Data/GraphViz.hs --- a/Data/GraphViz.hs +++ b/Data/GraphViz.hs @@ -59,6 +59,7 @@ import Control.Arrow((&&&)) import Data.Maybe(mapMaybe, fromJust) import qualified Data.Map as Map +import Control.Parallel.Strategies(rnf) import System.IO(hGetContents) import System.IO.Unsafe(unsafePerformIO) @@ -166,13 +167,13 @@ dotAttributes :: (Graph gr) => Bool -> gr a b -> DotGraph Node -> IO (gr (AttributeNode a) (AttributeEdge b)) dotAttributes isDir gr dot - = do output <- graphvizWithHandle command dot DotOutput hGetContents - let res = fromJust output - length res `seq` return () - return $ rebuildGraphWithAttributes res + = do (Just output) <- graphvizWithHandle command dot DotOutput hToString + return $ rebuildGraphWithAttributes output where command = if isDir then dirCommand else undirCommand - rebuildGraphWithAttributes dotResult = mkGraph lnodes ledges + hToString h = do s <- hGetContents h + rnf s `seq` return s + rebuildGraphWithAttributes dotResult = mkGraph lnodes ledges where lnodes = map (\(n, l) -> (n, (fromJust $ Map.lookup n nodeMap, l))) $ labNodes gr diff --git a/Data/GraphViz/Attributes.hs b/Data/GraphViz/Attributes.hs --- a/Data/GraphViz/Attributes.hs +++ b/Data/GraphViz/Attributes.hs @@ -26,9 +26,6 @@ /A/ to /B/, then /A/ is the tail node and /B/ is the head node (since /A/ is at the tail end of the arrow). - * GraphViz says that a number like @/.02/@ is valid; this library - disagrees. - * When parsing named 'Color' values, the entire value entered is kept as-is; this library as yet has no understanding of different color schemes, etc. @@ -153,6 +150,7 @@ import Data.Maybe(isJust, maybe) import Data.Word(Word8) import Numeric(showHex, readHex) +import Control.Arrow(first) import Control.Monad(liftM) -- ----------------------------------------------------------------------------- @@ -1084,14 +1082,14 @@ toDot at@RatioPassCount{} = doubleQuotes $ unqtDot at instance ParseDot AspectType where - parseUnqt = liftM (uncurry RatioPassCount) commaSep + parseUnqt = liftM (uncurry RatioPassCount) commaSepUnqt `onFail` - liftM RatioOnly parse + liftM RatioOnly parseUnqt - parse = quotedParse (liftM (uncurry RatioPassCount) commaSep) + parse = quotedParse (liftM (uncurry RatioPassCount) commaSepUnqt) `onFail` - optionalQuoted (liftM RatioOnly parse) + liftM RatioOnly parse -- ----------------------------------------------------------------------------- @@ -1104,11 +1102,9 @@ toDot = doubleQuotes . unqtDot instance ParseDot Rect where - parseUnqt = liftM (uncurry Rect) - $ commaSep' parseUnqt parseUnqt + parseUnqt = liftM (uncurry Rect) commaSepUnqt - parse = liftM (uncurry Rect) . quotedParse - $ commaSep' parseUnqt parseUnqt + parse = quotedParse parseUnqt -- ----------------------------------------------------------------------------- @@ -1354,9 +1350,20 @@ listToDot = doubleQuotes . unqtListToDot instance ParseDot Point where - parseUnqt = liftM (uncurry Point) commaSep + -- 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 = intDblPoint `onFail` - liftM (uncurry PointD) commaSep + liftM (uncurry Point) commaSepUnqt + `onFail` + liftM (uncurry PointD) commaSepUnqt + where + intDblPoint = liftM (uncurry PointD . first fI) + $ commaSep' parseUnqt parseStrictFloat + fI :: Int -> Double + fI = fromIntegral parse = quotedParse parseUnqt @@ -1663,15 +1670,13 @@ instance ParseDot Spline where parseUnqt = do ms <- parseP 's' - whitespace me <- parseP 'e' - whitespace ps <- sepBy1 parseUnqt whitespace return $ Spline ms me ps where parseP t = optional $ do character t - character ';' - parse + parseComma + parseUnqt `discard` whitespace parse = quotedParse parseUnqt diff --git a/Data/GraphViz/Commands.hs b/Data/GraphViz/Commands.hs --- a/Data/GraphViz/Commands.hs +++ b/Data/GraphViz/Commands.hs @@ -164,17 +164,23 @@ $ openFile fp WriteMode case pipe of (Left _) -> return False - (Right f) -> do file <- graphvizWithHandle cmd gr t (flip squirt f) - hClose f + (Right f) -> do file <- graphvizWithHandle cmd gr t (toFile f) case file of (Just _) -> return True _ -> return False + where + toFile f h = do squirt h f + hClose h + hClose f -- graphvizWithHandle sometimes throws an error about handles not -- being closed properly: investigate (now on the official TODO). --- | Run the chosen Graphviz command on this graph, but send the result to the --- given handle rather than to a file. +-- | Run the chosen Graphviz command on this graph, but send the +-- result to the given handle rather than to a file. The @'Handle' +-- -> 'IO' a@ function should close the 'Handle' once it is +-- finished. +-- -- The result is wrapped in 'Maybe' rather than throwing an error. graphvizWithHandle :: (PrintDot n, Show a) => GraphvizCommand -> DotGraph n -> GraphvizOutput -> (Handle -> IO a) -> IO (Maybe a) @@ -183,8 +189,6 @@ forkIO $ hPutStrLn inp (printDotGraph gr) >> hClose inp forkIO $ (hGetContents errp >>= hPutStr stderr >> hClose errp) a <- f outp - -- Don't close outp until f finishes. - a `seq` hClose outp exitCode <- waitForProcess prc case exitCode of ExitSuccess -> return (Just a) diff --git a/Data/GraphViz/Types.hs b/Data/GraphViz/Types.hs --- a/Data/GraphViz/Types.hs +++ b/Data/GraphViz/Types.hs @@ -43,8 +43,8 @@ end points. * When either creating a 'DotGraph' by hand or parsing one, it is - possible to specify that @'directedGraph' = d@, but at lease one - 'DotEdge' has @'directedEdge' = 'not' d@. + possible to specify that @'directedGraph' = d@, but 'DotEdge' + values with @'directedEdge' = 'not' d@. * Nodes cannot have Port values. @@ -53,10 +53,9 @@ having graph attributes that do not apply to subgraphs\/clusters by listing them /after/ the subgraphs\/clusters. - * The parser cannot as yet parse comments (in that it doesn't even - know what comments are, and will throw an error). Multiline - statements and C pre-processor lines (that is, lines beginning - with a @#@) are also not parseable. + * The parser will strip out comments and convert multiline strings + into a single line string. Pre-processor lines (i.e. those + started by @#@) and string concatenation are not yet supported. See "Data.GraphViz.Attributes" for more limitations. @@ -130,8 +129,10 @@ -- | Parse a limited subset of the Dot language to form a 'DotGraph' -- (that is, the caveats listed in "Data.GraphViz.Attributes" aside, -- Dot graphs are parsed if they match the layout of 'DotGraph'). +-- +-- Also removes any comments, etc. before parsing. parseDotGraph :: (ParseDot a) => String -> DotGraph a -parseDotGraph = fst . runParser parse +parseDotGraph = fst . runParser parse . preprocess -- | Check if all the 'Attribute's are being used correctly. isValidGraph :: DotGraph a -> Bool diff --git a/Data/GraphViz/Types/Parsing.hs b/Data/GraphViz/Types/Parsing.hs --- a/Data/GraphViz/Types/Parsing.hs +++ b/Data/GraphViz/Types/Parsing.hs @@ -19,9 +19,12 @@ instance. -} module Data.GraphViz.Types.Parsing - ( module Text.ParserCombinators.Poly.Lazy + ( -- * Re-exporting pertinent parts of Polyparse. + module Text.ParserCombinators.Poly.Lazy + -- * The ParseDot class. , Parse , ParseDot(..) + -- * Convenience parsing combinators. , stringBlock , numString , quotedString @@ -30,6 +33,7 @@ , strings , hasString , character + , parseStrictFloat , noneOf , whitespace , whitespace' @@ -49,8 +53,11 @@ , parseFieldDef , parseFieldsDef , commaSep + , commaSepUnqt , commaSep' , stringRep + -- * Pre-processing + , preprocess ) where import Data.GraphViz.Types.Internal @@ -64,7 +71,7 @@ import Data.Function(on) import Data.Maybe(isJust, fromMaybe) import Data.Ratio((%)) -import Control.Monad +import Control.Monad(liftM) -- ----------------------------------------------------------------------------- -- Based off code from Text.Parse in the polyparse library @@ -104,7 +111,7 @@ instance ParseDot Char where -- Can't be a quote character. - parseUnqt = satisfy ((/=) '"') + parseUnqt = satisfy ((/=) quoteChar) parse = satisfy restIDString `onFail` @@ -138,12 +145,15 @@ -- | Used when quotes are explicitly required; quotedString :: Parse String -quotedString = many $ oneOf [ stringRep '"' "\\\"" - , satisfy ((/=) '"') - ] +quotedString = many stringInterior +stringInterior :: Parse Char +stringInterior = stringRep quoteChar "\\\"" + `onFail` + satisfy ((/=) quoteChar) + parseSigned :: Real a => Parse a -> Parse a -parseSigned p = do '-' <- next; commit (fmap negate p) +parseSigned p = (character '-' >> liftM negate p) `onFail` p @@ -158,29 +168,35 @@ parseInt' :: Parse Int parseInt' = parseSigned parseInt +-- | Parse a floating point number that actually contains decimals. +parseStrictFloat :: (RealFrac a) => Parse a +parseStrictFloat = parseSigned parseFloat + parseFloat :: (RealFrac a) => Parse a -parseFloat = do ds <- many1 (satisfy isDigit) - frac <- (do '.' <- next - many (satisfy isDigit) - `adjustErrBad` (++"expected digit after .") - `onFail` return [] ) +parseFloat = do ds <- many (satisfy isDigit) + frac <- do character '.' + many (satisfy isDigit) + `adjustErrBad` (++ "\nexpected digit after .") + `adjustErr` (++ "expected decimal component") expn <- parseExp `onFail` return 0 ( return . fromRational . (* (10^^(expn - length frac))) . (%1) . fst . runParser parseInt) (ds++frac) `onFail` - do w <- many (satisfy (not.isSpace)) - case map toLower w of - "nan" -> return (0/0) - "infinity" -> return (1/0) - _ -> fail "expected a floating point number" - where parseExp = do 'e' <- fmap toLower next - commit (do '+' <- next; parseInt - `onFail` - parseSigned parseInt) + fail "Expected a floating point number" + where parseExp = do character 'e' + commit ((character '+' >> parseInt) + `onFail` + parseSigned parseInt) parseFloat' :: Parse Double -parseFloat' = parseSigned parseFloat +parseFloat' = parseSigned ( parseFloat + `onFail` + liftM fI parseInt + ) + where + fI :: Integer -> Double + fI = fromIntegral -- ----------------------------------------------------------------------------- @@ -222,10 +238,14 @@ quotedParse p quotedParse :: Parse a -> Parse a -quotedParse p = bracket quote quote p - where - quote = character '"' +quotedParse p = bracket parseQuote parseQuote p +parseQuote :: Parse Char +parseQuote = character quoteChar + +quoteChar :: Char +quoteChar = '"' + newline :: Parse String newline = oneOf $ map string ["\r\n", "\n", "\r"] @@ -235,8 +255,10 @@ newline' :: Parse () newline' = many (whitespace' >> newline) >> return () -skipToNewline :: Parse () -skipToNewline = many (noneOf ['\n','\r']) >> newline >> return () +-- | Parses and returns all characters up till the end of the line, +-- then skips to the beginning of the next line. +skipToNewline :: Parse String +skipToNewline = many (noneOf ['\n','\r']) `discard` newline parseField :: (ParseDot a) => String -> Parse a parseField fld = do string fld @@ -267,6 +289,9 @@ commaSep :: (ParseDot a, ParseDot b) => Parse (a, b) commaSep = commaSep' parse parse +commaSepUnqt :: (ParseDot a, ParseDot b) => Parse (a, b) +commaSepUnqt = commaSep' parseUnqt parseUnqt + commaSep' :: Parse a -> Parse b -> Parse (a,b) commaSep' pa pb = do a <- pa whitespace' @@ -283,3 +308,54 @@ tryParseList' :: Parse [a] -> Parse [a] tryParseList' = liftM (fromMaybe []) . optional + +-- ----------------------------------------------------------------------------- +-- Filtering out unwanted Dot items such as comments + +-- | Remove unparseable features of Dot, such as comments and +-- multi-line strings (which are converted to single-line strings). +preprocess :: String -> String +preprocess = fst . runParser parseOutUnwanted + +-- | Parse out comments and make quoted strings spread over multiple +-- lines only over a single line. Should parse the /entire/ input +-- 'String'. +parseOutUnwanted :: Parse String +parseOutUnwanted = liftM concat (many getNext) + where + getNext :: Parse String + getNext = (oneOf [ parseLineComment, parseMultiLineComment ] >> return []) + `onFail` + parseSplitStrings + `onFail` + liftM return next + +-- | Parse @//@-style comments. +parseLineComment :: Parse String +parseLineComment = string "//" >> newline + +-- | Parse @/* ... */@-style comments. +parseMultiLineComment :: Parse String +parseMultiLineComment = bracket start end (liftM concat $ many inner) + where + start = string "/*" + end = string "*/" + inner = many1 (satisfy ((/=) '*')) + `onFail` + do ast <- character '*' + n <- satisfy ((/=) '/') + liftM ((:) ast . (:) n) inner + +-- | Parse out @\@ from a quoted string. +parseSplitStrings :: Parse String +parseSplitStrings = do oq <- parseQuote + inner <- liftM concat $ many parseInner + cq <- parseQuote + return $ oq : inner ++ [cq] + where + parseInner = string "\\\"" + `onFail` + (character '\\' >> newline >> return []) + `onFail` + liftM return (satisfy ((/=) quoteChar)) + diff --git a/Data/GraphViz/Types/Printing.hs b/Data/GraphViz/Types/Printing.hs --- a/Data/GraphViz/Types/Printing.hs +++ b/Data/GraphViz/Types/Printing.hs @@ -100,7 +100,13 @@ unqtDot = int instance PrintDot Double where - unqtDot = double + -- If it's an "integral" double, then print as an integer. + -- This seems to match how GraphViz apps use Dot. + unqtDot d = if d == fromIntegral di + then int di + else double d + where + di = round d instance PrintDot Bool where unqtDot True = text "true" diff --git a/graphviz.cabal b/graphviz.cabal --- a/graphviz.cabal +++ b/graphviz.cabal @@ -1,5 +1,5 @@ Name: graphviz -Version: 2999.5.0.0 +Version: 2999.5.1.0 Stability: Beta Synopsis: GraphViz bindings for Haskell. Description: Provides convenient functions to convert FGL @@ -33,6 +33,7 @@ process, array, fgl, + parallel >= 1.1 && < 1.2, polyparse >= 1.1, pretty