graphviz 2999.12.0.3 → 2999.12.0.4
raw patch · 16 files changed
+128/−53 lines, 16 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- Changelog +28/−1
- Data/GraphViz.hs +6/−1
- Data/GraphViz/Attributes/Complete.hs +3/−3
- Data/GraphViz/Attributes/HTML.hs +10/−10
- Data/GraphViz/Exception.hs +2/−2
- Data/GraphViz/Parsing.hs +2/−2
- Data/GraphViz/Testing.hs +16/−0
- Data/GraphViz/Testing/Properties.hs +12/−1
- Data/GraphViz/Types.hs +12/−2
- Data/GraphViz/Types/Canonical.hs +2/−4
- Data/GraphViz/Types/Common.hs +4/−4
- Data/GraphViz/Types/Generalised.hs +0/−2
- Data/GraphViz/Types/Graph.hs +2/−2
- graphviz.cabal +1/−1
- utils/AttributeGenerator.hs +3/−3
- utils/TestParsing.hs +25/−15
Changelog view
@@ -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: -->-
Data/GraphViz.hs view
@@ -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: <http://graphviz.org/> @@ -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
Data/GraphViz/Attributes/Complete.hs view
@@ -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
Data/GraphViz/Attributes/HTML.hs view
@@ -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)
Data/GraphViz/Exception.hs view
@@ -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
Data/GraphViz/Parsing.hs view
@@ -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'
Data/GraphViz/Testing.hs view
@@ -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
Data/GraphViz/Testing/Properties.hs view
@@ -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
Data/GraphViz/Types.hs view
@@ -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.
Data/GraphViz/Types/Canonical.hs view
@@ -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'
Data/GraphViz/Types/Common.hs view
@@ -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
Data/GraphViz/Types/Generalised.hs view
@@ -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
Data/GraphViz/Types/Graph.hs view
@@ -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
graphviz.cabal view
@@ -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: {
utils/AttributeGenerator.hs view
@@ -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
utils/TestParsing.hs view
@@ -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