diff --git a/Changelog b/Changelog --- a/Changelog +++ b/Changelog @@ -7,6 +7,34 @@ The following is information about what major changes have gone into each release. +Changes in 2999.13.0.0 +---------------------- + +* Added support for the `osage` and `patchwork` visualisation tools. + +* Now uses Dot semantics as of Graphviz-2.28.0. The only change is + when parsing the Attribute `overlap=false`; this is now equivalent + to `overlap=prism`. + +Changes in 2999.12.0.4 +---------------------- + +* Parsing error messages have been cleared up, especially when parsing + Dot graphs. This came about from trying to help **Uri J. Braun** + with an error in his code (which took a while to diagnose as a + problem with the node type). + +* Made more clear to people looking in `Data.GraphViz` who want to + create Dot graphs by hand to look in `Data.GraphViz.Types` (came + about when **Rustom Mody** stated he got confused trying to work out + how to do this). + +* Fixed up augmentation; bug and fix spotted by **Max Rabkin**. + +* Fix up the TestParsing script to actually use the new type setup. + It can also now take a single directory as an argument, and will try + to parse all (non-recursive) files in that directory. + Changes in 2999.12.0.3 ---------------------- @@ -496,4 +524,3 @@ mode:markdown End: --> - diff --git a/Data/GraphViz.hs b/Data/GraphViz.hs --- a/Data/GraphViz.hs +++ b/Data/GraphViz.hs @@ -12,6 +12,11 @@ /Dot/ language used by the /Graphviz/ suite of programs (as well as a limited ability to perform the reverse operation). + If you wish to construct a Haskell representation of a Dot graph + yourself rather than using the conversion functions here, please + see the "Data.GraphViz.Types" module as a starting point for how to + do so. + Information about Graphviz and the Dot language can be found at: @@ -435,7 +440,7 @@ = liftM (augmentGraph gr . parseDG) $ graphvizWithHandle command dot DotOutput hGetDot where - parseDG = asTypeOf dot + parseDG = (`asTypeOf` dot) command = if isDir then dirCommand else undirCommand -- | Use the 'Attributes' in the provided 'DotGraph' to augment the 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 @@ -269,7 +269,7 @@ | Group Text -- ^ /Valid for/: N; /Default/: @\"\"@; /Notes/: dot only | HeadURL EscString -- ^ /Valid for/: E; /Default/: @\"\"@; /Notes/: svg, map only | HeadClip Bool -- ^ /Valid for/: E; /Default/: @'True'@; /Parsing Default/: 'True' - | HeadLabel Label -- ^ /Valid for/: E; /Default/: 'StrLabel' @\"\"@ + | HeadLabel Label -- ^ /Valid for/: E; /Default/: @'StrLabel' \"\"@ | HeadPort PortPos -- ^ /Valid for/: E; /Default/: @'CompassPoint' 'CenterPoint'@ | HeadTarget EscString -- ^ /Valid for/: E; /Default/: none; /Notes/: svg, map only | HeadTooltip EscString -- ^ /Valid for/: E; /Default/: @\"\"@; /Notes/: svg, cmap only @@ -288,7 +288,7 @@ | LabelLoc VerticalPlacement -- ^ /Valid for/: GCN; /Default/: @'VTop'@ (clusters), @'VBottom'@ (root graphs), @'VCenter'@ (nodes) | LabelTarget EscString -- ^ /Valid for/: E; /Default/: none; /Notes/: svg, map only | LabelTooltip EscString -- ^ /Valid for/: E; /Default/: @\"\"@; /Notes/: svg, cmap only - | Label Label -- ^ /Valid for/: ENGC; /Default/: @'StrLabel' \"\N\"@ (nodes), @'StrLabel' \"\"@ (otherwise) + | Label Label -- ^ /Valid for/: ENGC; /Default/: @'StrLabel' \"\\N\"@ (nodes), @'StrLabel' \"\"@ (otherwise) | Landscape Bool -- ^ /Valid for/: G; /Default/: @'False'@; /Parsing Default/: 'True' | LayerSep LayerSep -- ^ /Valid for/: G; /Default/: @'LSep' \" :\t\"@ | Layers LayerList -- ^ /Valid for/: G; /Default/: @'LL' []@ @@ -319,7 +319,7 @@ | OverlapScaling Double -- ^ /Valid for/: G; /Default/: @-4@; /Minimum/: @-1.0e10@; /Notes/: prism only | Overlap Overlap -- ^ /Valid for/: G; /Default/: @'KeepOverlaps'@; /Parsing Default/: 'KeepOverlaps'; /Notes/: not dot | PackMode PackMode -- ^ /Valid for/: G; /Default/: @'PackNode'@; /Notes/: not dot - | Pack Pack -- ^ /Valid for/: G; /Default/: @'False'@; /Parsing Default/: 'DoPack'; /Notes/: not dot + | Pack Pack -- ^ /Valid for/: G; /Default/: @'DontPack'@; /Parsing Default/: 'DoPack'; /Notes/: not dot | Pad DPoint -- ^ /Valid for/: G; /Default/: @'DVal' 0.0555@ (4 points) | PageDir PageDir -- ^ /Valid for/: G; /Default/: @'Bl'@ | Page Point -- ^ /Valid for/: G 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 @@ -102,7 +102,7 @@ `onFail` liftM HtmlText parseUnqt `adjustErr` - (++ "\nCan't parse HtmlLabel") + ("Can't parse HtmlLabel\n\t"++) parse = parseUnqt @@ -141,7 +141,7 @@ , parseHtmlFontTag HtmlFont parseUnqt ] `adjustErr` - (++ "\nCan't parse HtmlTextItem") + ("Can't parse HtmlTextItem\n\t"++) parse = parseUnqt @@ -175,7 +175,7 @@ `onFail` pTbl `adjustErr` - (++ "\nCan't parse HtmlTable") + ("Can't parse HtmlTable\n\t"++) where pTbl = wrapWhitespace $ parseHtmlTag (HTable Nothing) "TABLE" @@ -203,7 +203,7 @@ -- 'HtmlAttributes' that it might accidentally parse. parseUnqt = wrapWhitespace $ parseHtmlTag (const HtmlRow) "TR" parseUnqt `adjustErr` - (++ "\nCan't parse HtmlRow") + ("Can't parse HtmlRow\n\t"++) parse = parseUnqt @@ -233,7 +233,7 @@ , parseCell HtmlImgCell $ wrapWhitespace parseUnqt ] `adjustErr` - (++ "\nCan't parse HtmlCell") + ("Can't parse HtmlCell\n\t"++) where parseCell = flip parseHtmlTag "TD" @@ -253,7 +253,7 @@ instance ParseDot HtmlImg where parseUnqt = wrapWhitespace (parseHtmlEmptyTag HtmlImg "IMG") `adjustErr` - (++ "\nCan't parse HtmlImg") + ("Can't parse HtmlImg\n\t"++) parse = parseUnqt @@ -273,17 +273,17 @@ | HtmlCellSpacing Word8 -- ^ Valid for: 'HtmlTable', 'HtmlCell'. Default is @2@; maximum is @127@. | HtmlColor Color -- ^ Valid for: 'HtmlTable', 'HtmlCell'. | HtmlColSpan Word16 -- ^ Valid for: 'HtmlCell'. Default is @1@. - | HtmlFace Text -- ^ Valid for: 'tableFontAttrs', 'HtmlFont'. + | HtmlFace Text -- ^ Valid for: 'tableFontAttrs', 'HtmlFont'. | HtmlFixedSize Bool -- ^ Valid for: 'HtmlTable', 'HtmlCell'. Default is @'False'@. | HtmlHeight Word16 -- ^ Valid for: 'HtmlTable', 'HtmlCell'. - | HtmlHRef Text -- ^ Valid for: 'HtmlTable', 'HtmlCell'. + | HtmlHRef Text -- ^ Valid for: 'HtmlTable', 'HtmlCell'. | HtmlPointSize Double -- ^ Valid for: 'tableFontAttrs', 'HtmlFont'. | HtmlPort PortName -- ^ Valid for: 'HtmlTable', 'HtmlCell'. | HtmlRowSpan Word16 -- ^ Valid for: 'HtmlCell'. | HtmlScale HtmlScale -- ^ Valid for: 'HtmlImg'. | HtmlSrc FilePath -- ^ Valid for: 'HtmlImg'. - | HtmlTarget Text -- ^ Valid for: 'HtmlTable', 'HtmlCell'. - | HtmlTitle Text -- ^ Valid for: 'HtmlTable', 'HtmlCell'. Has an alias of @TOOLTIP@. + | HtmlTarget Text -- ^ Valid for: 'HtmlTable', 'HtmlCell'. + | HtmlTitle Text -- ^ Valid for: 'HtmlTable', 'HtmlCell'. Has an alias of @TOOLTIP@. | HtmlVAlign HtmlVAlign -- ^ Valid for: 'HtmlTable', 'HtmlCell'. | HtmlWidth Word16 -- ^ Valid for: 'HtmlTable', 'HtmlCell'. deriving (Eq, Ord, Show, Read) diff --git a/Data/GraphViz/Exception.hs b/Data/GraphViz/Exception.hs --- a/Data/GraphViz/Exception.hs +++ b/Data/GraphViz/Exception.hs @@ -20,7 +20,7 @@ -- ----------------------------------------------------------------------------- --- | Exceptions that arise from using this library fall into three +-- | Exceptions that arise from using this library fall into four -- categories: -- -- * Unable to parse provided Dot code. @@ -38,7 +38,7 @@ deriving (Eq, Ord, Typeable) instance Show GraphvizException where - showsPrec _ (NotDotCode str) = showString $ "Error when parsing Dot code: " ++ str + showsPrec _ (NotDotCode str) = showString $ "Error when parsing Dot code:\n" ++ str 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 diff --git a/Data/GraphViz/Parsing.hs b/Data/GraphViz/Parsing.hs --- a/Data/GraphViz/Parsing.hs +++ b/Data/GraphViz/Parsing.hs @@ -255,7 +255,7 @@ Right (n,"") -> return n Right (_,txt) -> fail $ "Trailing digits not parsed as Integral: " ++ T.unpack txt Left err -> fail $ "Could not read Integral: " ++ err - `adjustErr` (++ "\nexpected one or more digits") + `adjustErr` ("Expected one or more digits\n\t"++) parseInt' :: Parse Int parseInt' = parseSigned parseInt @@ -339,7 +339,7 @@ character :: Char -> Parse Char character c = satisfy parseC `adjustErr` - (++ "\nnot the expected char: " ++ [c]) + (const $ "Not the expected character: " ++ [c]) where parseC c' = c' == c || c == flipCase c' flipCase c' = if isLower c' diff --git a/Data/GraphViz/Testing.hs b/Data/GraphViz/Testing.hs --- a/Data/GraphViz/Testing.hs +++ b/Data/GraphViz/Testing.hs @@ -162,6 +162,7 @@ , test_printParseID , test_preProcessingID , test_dotizeAugment + , test_dotizeHasAugment , test_dotizeAugmentUniq , test_findAllNodes , test_findAllNodesE @@ -250,6 +251,21 @@ \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." + +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." test_dotizeAugmentUniq :: Test test_dotizeAugmentUniq diff --git a/Data/GraphViz/Testing/Properties.hs b/Data/GraphViz/Testing/Properties.hs --- a/Data/GraphViz/Testing/Properties.hs +++ b/Data/GraphViz/Testing/Properties.hs @@ -28,7 +28,7 @@ import Test.QuickCheck import Data.Graph.Inductive( Graph, DynGraph - , equal, nmap, emap, labEdges, nodes, edges) + , equal, nmap, emap, labNodes, labEdges, nodes, edges) import Data.List(nub, sort) import Data.Function(on) import qualified Data.Map as Map @@ -77,6 +77,16 @@ g' = setDirectedness dotizeGraph nonClusteredParams g unAugment = nmap snd . emap snd +-- | After augmentation, each node and edge should have a non-empty +-- | list of 'Attributes'. +prop_dotizeHasAugment :: (DynGraph g, Ord e) => g n e -> Bool +prop_dotizeHasAugment g = all (not . null) nodeAugments + && all (not . null) edgeAugments + where + g' = setDirectedness dotizeGraph nonClusteredParams g + nodeAugments = map (fst . snd) $ labNodes g' + edgeAugments = map (fst . \(_,_,l) -> l) $ labEdges g' + -- | When a graph with multiple edges is augmented, then all edges -- should have unique 'Attributes' (namely the positions). Note -- that this may not hold true with custom supplied 'Attributes' @@ -88,6 +98,7 @@ les = map (\(f,t,l) -> ((f,t),l)) $ labEdges g' lss = map (map snd) . filter (not . isSingle) $ groupSortBy fst les + uniqLs [] = False -- Needs to have at least /one/ Attribute! uniqLs ls = ls == nub ls -- | Ensure that the definition of 'nodeInformation' for a DotRepr diff --git a/Data/GraphViz/Types.hs b/Data/GraphViz/Types.hs --- a/Data/GraphViz/Types.hs +++ b/Data/GraphViz/Types.hs @@ -115,11 +115,12 @@ , DotNode(..), DotEdge(..), numericValue) import Data.GraphViz.Types.State import Data.GraphViz.Util(bool) -import Data.GraphViz.Parsing(ParseDot, parseIt) +import Data.GraphViz.Parsing(ParseDot, runParser, checkValidParse, parse, adjustErr) import Data.GraphViz.PreProcessing(preProcess) import Data.GraphViz.Printing(PrintDot, printIt) import Data.Text.Lazy(Text) +import Control.Arrow(first) import Control.Monad.Trans.State(get, put, modify, execState, evalState) -- ----------------------------------------------------------------------------- @@ -219,7 +220,16 @@ -- -- Also removes any comments, etc. before parsing. parseDotGraph :: (ParseDotRepr dg n) => Text -> dg n -parseDotGraph = fst . parseIt . preProcess +parseDotGraph = fst . prs . preProcess + where + prs = first checkValidParse . runParser parse' + + parse' = parse `adjustErr` + ("Unable to parse the Dot graph; usually this is because of either:\n\ + \ * Wrong choice of representation: try the Generalised one\n\ + \ * Wrong choice of node type; try with `DotGraph String`.\n\ + \\n\ + \The actual parsing error was:\n\t"++) -- ----------------------------------------------------------------------------- -- Instance for Canonical graphs, to avoid cyclic modules. 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 @@ -110,8 +110,6 @@ parseUnqt = parseStmtBased parse (parseGraphID DotGraph) parse = parseUnqt -- Don't want the option of quoting - `adjustErr` - (++ "\n\nNot a valid DotGraph") -- | Assumed to be an injective mapping function. instance Functor DotGraph where @@ -145,7 +143,7 @@ parse = parseUnqt -- Don't want the option of quoting `adjustErr` - (++ "Not a valid set of statements") + ("Not a valid set of statements\n\t"++) instance Functor DotStatements where fmap f stmts = stmts { subGraphs = map (fmap f) $ subGraphs stmts @@ -179,7 +177,7 @@ parse = parseUnqt -- Don't want the option of quoting `adjustErr` - (++ "\n\nNot a valid Sub Graph") + ("Not a valid Sub Graph\n\t"++) parseUnqtList = sepBy (whitespace' >> parseUnqt) newline' diff --git a/Data/GraphViz/Types/Common.hs b/Data/GraphViz/Types/Common.hs --- a/Data/GraphViz/Types/Common.hs +++ b/Data/GraphViz/Types/Common.hs @@ -53,7 +53,7 @@ parse = liftM stringNum parse `adjustErr` - (++ "\nNot a valid GraphID") + ("Not a valid GraphID\n\t"++) stringNum :: Text -> GraphID stringNum str = maybe checkDbl Int $ stringToInt str @@ -116,7 +116,7 @@ parse = parseUnqt -- Don't want the option of quoting `adjustErr` - (++ "\n\nNot a valid listing of global attributes") + ("Not a valid listing of global attributes\n\t"++) -- Have to do this manually because of the special case parseUnqtList = parseStatements parse @@ -373,7 +373,7 @@ modifyGS (const gs) return a `adjustErr` - (++ "\nNot a valid value wrapped in braces.") + ("Not a valid value wrapped in braces.\n\t"++) printSubGraphID :: (a -> (Bool, Maybe GraphID)) -> a -> DotCode printSubGraphID f a = sGraph' @@ -461,7 +461,7 @@ atts <- tryParseList' (whitespace' >> parse) return $ f atts `adjustErr` - (++ "\n\nNot a valid attribute-based structure") + ("Not a valid attribute-based structure\n\t"++) parseAttrBasedList :: Parse (Attributes -> a) -> Parse [a] parseAttrBasedList = parseStatements . parseAttrBased 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 @@ -128,8 +128,6 @@ parseUnqt = parseStmtBased parseGStmts (parseGraphID DotGraph) parse = parseUnqt -- Don't want the option of quoting - `adjustErr` - (++ "\n\nNot a valid DotGraph") -- | 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 @@ -36,7 +36,7 @@ > . setStrictness False > . setIsDirected True > . setClusterAttributes (Int 0) [GraphAttrs [style filled, color LightGray, textLabel "process #1"], NodeAttrs [style filled, color White]] - > . setClusterAttributes (Int 1) [ GraphAttrs [textLabel "process #2", color Blue], NodeAttrs [style filled]] + > . setClusterAttributes (Int 1) [GraphAttrs [textLabel "process #2", color Blue], NodeAttrs [style filled]] > $ composeList [ Cntxt "a0" (Just $ Int 0) [] [("a3",[]),("start",[])] [("a1",[])] > , Cntxt "a1" (Just $ Int 0) [] [] [("a2",[]),("b3",[])] > , Cntxt "a2" (Just $ Int 0) [] [] [("a3",[])] @@ -171,7 +171,7 @@ -- | The decomposition of a node from a dot graph. Any loops should -- be found in 'successors' rather than 'predecessors'. Note also --- that these are created/consumed as if for /directed/ graphs. +-- that these are created\/consumed as if for /directed/ graphs. data Context n = Cntxt { node :: !n -- | The cluster this node can be found in; -- @Nothing@ indicates the node can be diff --git a/graphviz.cabal b/graphviz.cabal --- a/graphviz.cabal +++ b/graphviz.cabal @@ -1,5 +1,5 @@ Name: graphviz -Version: 2999.12.0.3 +Version: 2999.12.0.4 Stability: Beta Synopsis: Bindings to Graphviz for graph visualisation. Description: { diff --git a/utils/AttributeGenerator.hs b/utils/AttributeGenerator.hs --- a/utils/AttributeGenerator.hs +++ b/utils/AttributeGenerator.hs @@ -489,7 +489,7 @@ , makeAttr "Group" ["group"] "N" Strng Nothing (Just "\"\"") (Just "@\\\"\\\"@") Nothing (Just "dot only") , makeAttr "HeadURL" ["headURL", "headhref"] "E" EStrng Nothing (Just "\"\"") (Just "@\\\"\\\"@") Nothing (Just "svg, map only") , makeAttr "HeadClip" ["headclip"] "E" Bl (Just "True") (Just "True") (Just "@'True'@") Nothing Nothing - , makeAttr "HeadLabel" ["headlabel"] "E" (Cust "Label") Nothing (Just "(StrLabel \"\")") (Just "'StrLabel' @\\\"\\\"@") Nothing Nothing + , makeAttr "HeadLabel" ["headlabel"] "E" (Cust "Label") Nothing (Just "(StrLabel \"\")") (Just "@'StrLabel' \\\"\\\"@") Nothing Nothing , makeAttr "HeadPort" ["headport"] "E" (Cust "PortPos") Nothing (Just "(CompassPoint CenterPoint)") (Just "@'CompassPoint' 'CenterPoint'@") Nothing Nothing , makeAttr "HeadTarget" ["headtarget"] "E" EStrng Nothing (Just "\"\"") (Just "none") Nothing (Just "svg, map only") , makeAttr "HeadTooltip" ["headtooltip"] "E" EStrng Nothing (Just "\"\"") (Just "@\\\"\\\"@") Nothing (Just "svg, cmap only") @@ -508,7 +508,7 @@ , makeAttr "LabelLoc" ["labelloc"] "GCN" (Cust "VerticalPlacement") Nothing (Just "VTop") (Just "@'VTop'@ (clusters), @'VBottom'@ (root graphs), @'VCenter'@ (nodes)") Nothing Nothing , makeAttr "LabelTarget" ["labeltarget"] "E" EStrng Nothing (Just "\"\"") (Just "none") Nothing (Just "svg, map only") , makeAttr "LabelTooltip" ["labeltooltip"] "E" EStrng Nothing (Just "\"\"") (Just "@\\\"\\\"@") Nothing (Just "svg, cmap only") - , makeAttr "Label" ["label"] "ENGC" (Cust "Label") Nothing (Just "(StrLabel \"\")") (Just "@'StrLabel' \\\"\\N\\\"@ (nodes), @'StrLabel' \\\"\\\"@ (otherwise)") Nothing Nothing + , makeAttr "Label" ["label"] "ENGC" (Cust "Label") Nothing (Just "(StrLabel \"\")") (Just "@'StrLabel' \\\"\\\\N\\\"@ (nodes), @'StrLabel' \\\"\\\"@ (otherwise)") Nothing Nothing , makeAttr "Landscape" ["landscape"] "G" Bl (Just "True") (Just "False") (Just "@'False'@") Nothing Nothing , makeAttr "LayerSep" ["layersep"] "G" (Cust "LayerSep") Nothing (Just "(LSep \" :\\t\")") (Just "@'LSep' \\\" :\\t\\\"@") Nothing Nothing , makeAttr "Layers" ["layers"] "G" (Cust "LayerList") Nothing (Just "(LL [])") (Just "@'LL' []@") Nothing Nothing @@ -539,7 +539,7 @@ , makeAttr "OverlapScaling" ["overlap_scaling"] "G" Dbl Nothing (Just "(-4)") (Just "@-4@") (Just "@-1.0e10@") (Just "prism only") , makeAttr "Overlap" ["overlap"] "G" (Cust "Overlap") (Just "KeepOverlaps") (Just "KeepOverlaps") (Just "@'KeepOverlaps'@") Nothing (Just "not dot") , makeAttr "PackMode" ["packmode"] "G" (Cust "PackMode") Nothing (Just "PackNode") (Just "@'PackNode'@") Nothing (Just "not dot") - , makeAttr "Pack" ["pack"] "G" (Cust "Pack") (Just "DoPack") (Just "DontPack") (Just "@'False'@") Nothing (Just "not dot") + , makeAttr "Pack" ["pack"] "G" (Cust "Pack") (Just "DoPack") (Just "DontPack") (Just "@'DontPack'@") Nothing (Just "not dot") , makeAttr "Pad" ["pad"] "G" (Cust "DPoint") Nothing (Just "(DVal 0.0555)") (Just "@'DVal' 0.0555@ (4 points)") Nothing Nothing , makeAttr "PageDir" ["pagedir"] "G" (Cust "PageDir") Nothing (Just "Bl") (Just "@'Bl'@") Nothing Nothing , makeAttr "Page" ["page"] "G" (Cust "Point") Nothing Nothing Nothing Nothing Nothing diff --git a/utils/TestParsing.hs b/utils/TestParsing.hs --- a/utils/TestParsing.hs +++ b/utils/TestParsing.hs @@ -17,7 +17,7 @@ module Main where import Data.GraphViz -import Data.GraphViz.Types.Generalised +import qualified Data.GraphViz.Types.Generalised as G import Data.GraphViz.Parsing(runParser, parse) import Data.GraphViz.PreProcessing(preProcess) import Data.GraphViz.Commands.IO(hGetStrict, toUTF8) @@ -27,7 +27,9 @@ import Data.Text.Lazy(Text) import qualified Data.ByteString.Lazy as B import Control.Exception.Extensible(try, IOException) -import Control.Monad(liftM) +import Control.Monad(liftM, filterM) +import System.Directory +import System.FilePath import System.Environment(getArgs) -- ----------------------------------------------------------------------------- @@ -35,19 +37,26 @@ main :: IO () main = tryParsing =<< getArgs where - tryParsing [] = putStrLn "Test that the graphviz library can parse\ - \ \"real life\" Dot code by passing a list\n\ - \of files in which contain Dot graphs.\n\ - \\n\ - \One way of using this file:\n\t\ - \$ locate -r \".*\\.\\(gv\\|dot\\)$\" -0\ - \ | xargs -0 runhaskell TestParsing.hs" + tryParsing [] = putStrLn "Test that the graphviz library can parse\ + \ \"real life\" Dot code by passing a list\n\ + \of files in which contain Dot graphs.\n\ + \\n\ + \One way of using this file:\n\t\ + \$ locate -r \".*\\.\\(gv\\|dot\\)$\" -0\ + \ | xargs -0 runhaskell TestParsing.hs" + tryParsing [fp] = do isDir <- doesDirectoryExist fp + if isDir + then mapM_ tryParseFile =<< getDContents fp + else tryParseFile fp tryParsing fs = mapM_ tryParseFile fs +getDContents :: FilePath -> IO [FilePath] +getDContents fp = (filterM doesFileExist . map (fp )) =<< getDirectoryContents fp + -- ----------------------------------------------------------------------------- -withParse :: (DotRepr dg n) => (a -> IO Text) -> (dg n -> IO ()) +withParse :: (PPDotRepr dg n) => (a -> IO Text) -> (dg n -> IO ()) -> (ErrMsg -> String) -> a -> IO () withParse toStr withDG cmbErr a = do dc <- toStr a edg <- tryParse dc @@ -58,7 +67,7 @@ putStrLn "" type DG = DotGraph Text -type GDG = GDotGraph Text +type GDG = G.DotGraph Text type ErrMsg = String tryParseFile :: FilePath -> IO () @@ -68,12 +77,12 @@ ++ err ++ "\n" maybeParse (Right dot) = withParse (const $ return dot) (tryParseCanon fp) - ("Cannot parse as a GDotGraph: "++) + ("Cannot parse as a G.DotGraph: "++) fp tryParseCanon :: FilePath -> GDG -> IO () tryParseCanon fp = withParse prettyPrint - ((`seq` return ()) . T.length . printDotGraph . asDG) + ((`seq` putStrLn "Parsed OK!") . T.length . printDotGraph . asDG) (\ e -> fp ++ ": Canonical Form not a DotGraph:\n" ++ e) where @@ -81,7 +90,7 @@ emptDG = DotGraph False False Nothing $ DotStmts [] [] [] [] :: DG prettyPrint dg = graphvizWithHandle (commandFor dg) dg Canon hGetStrict -tryParse :: (DotRepr dg n) => Text -> IO (Either ErrMsg (dg n)) +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 @@ -90,7 +99,8 @@ getErr = return . Left . show readFile' :: FilePath -> IO (Either ErrMsg Text) -readFile' fp = do putStrLn fp +readFile' fp = do putStr fp + putStr " - " liftM getMsg . try $ readUTF8File fp where getMsg :: Either IOException Text -> Either ErrMsg Text