language-dot 0.1.1 → 0.1.2
raw patch · 4 files changed
+109/−16 lines, 4 filesdep ~prettyPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: pretty
API changes (from Hackage documentation)
Files
- language-dot.cabal +13/−6
- ppdot/Main.hs +6/−5
- src/Language/Dot/Parser.hs +1/−0
- test/Main.hs +89/−5
language-dot.cabal view
@@ -1,16 +1,16 @@+cabal-version: 3.0 name: language-dot-version: 0.1.1+version: 0.1.2 category: Language synopsis: A library for the analysis and creation of Graphviz DOT files description: A library for the analysis and creation of Graphviz DOT files. author: Brian Lewis <brian@lorf.org> maintainer: Ben Gamari <ben@smart-cactus.org> copyright: (c) 2009 Galois, Inc.-license: BSD3+license: BSD-3-Clause license-file: LICENSE--cabal-version: >= 1.8-build-type: Simple+tested-with: GHC==9.2.3, GHC==9.4.5, GHC==9.6.2+build-type: Simple flag executable description: Build the `ppdot' executable.@@ -36,6 +36,8 @@ if impl(ghc >= 6.8) ghc-options: -fwarn-tabs + default-language: Haskell2010+ executable ppdot if flag(executable) buildable: True@@ -54,18 +56,23 @@ if impl(ghc >= 6.8) ghc-options: -fwarn-tabs + default-language: Haskell2010+ test-suite test type: exitcode-stdio-1.0 main-is: Main.hs other-modules: Language.Dot.Parser+ Language.Dot.Pretty Language.Dot.Syntax hs-source-dirs: test, src ghc-options: -Wall cpp-options: -DTEST build-depends: base == 4.*,- parsec == 3.*+ parsec == 3.*,+ pretty+ default-language: Haskell2010 source-repository head type: git
ppdot/Main.hs view
@@ -1,7 +1,8 @@ module Main (main) where import Control.Exception (IOException, try)-import Control.Monad.Error (ErrorT(..), MonadError(..))+import Control.Monad.Error.Class (MonadError(..))+import Control.Monad.Except (ExceptT(..), runExceptT) import System.Environment (getArgs, getProgName) import System.Exit (exitFailure, exitSuccess) import System.IO (hPutStrLn, stderr)@@ -25,9 +26,9 @@ renderDotFile :: FilePath -> IO () renderDotFile fp =- runErrorT (renderDotFileET fp) >>= either exitError putStrLn+ runExceptT (renderDotFileET fp) >>= either exitError putStrLn -renderDotFileET :: FilePath -> ErrorT String IO String+renderDotFileET :: FilePath -> ExceptT String IO String renderDotFileET fp = do contents <- readFile fp `liftCatch` show graph <- parseDot fp contents `liftEither` show@@ -57,8 +58,8 @@ -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -liftCatch :: IO a -> (IOException -> e) -> ErrorT e IO a-liftCatch a f = ErrorT $ fmap (either (Left . f) Right) (try a)+liftCatch :: IO a -> (IOException -> e) -> ExceptT e IO a+liftCatch a f = ExceptT $ fmap (either (Left . f) Right) (try a) liftEither :: (MonadError e m) => Either l r -> (l -> e) -> m r liftEither e f = either (throwError . f) return e
src/Language/Dot/Parser.hs view
@@ -3,6 +3,7 @@ module Language.Dot.Parser ( parseDot #ifdef TEST+ , parseGraph , parsePort , parseCompass , parseAttribute
test/Main.hs view
@@ -2,22 +2,52 @@ import Control.Monad (unless) import Data.Char (toLower, toUpper)+import System.Exit (exitSuccess, exitFailure) import Text.Parsec import Text.Parsec.String import Language.Dot.Parser+import Language.Dot.Pretty import Language.Dot.Syntax -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- main :: IO () main = do- testParser "parsePort" parsePort parsePortTests- testParser "parseCompass" parseCompass parseCompassTests- testParser "parseAttribute" parseAttribute parseAttributeTests- testParser "parseId" parseId parseIdTests+ let sumBoth (a,b) (c,d) = (a+c, b+d)+ (np,nf) <- foldr sumBoth (0,0) <$> sequence+ [+ testParser "parsePort" parsePort parsePortTests+ , testParser "parseCompass" parseCompass parseCompassTests+ , testParser "parseAttribute" parseAttribute parseAttributeTests+ , testParser "parseId" parseId parseIdTests+ , testParser "parseGraphs" parseGraph parseGraphTests+ , testRoundTrip "RT1" "digraph T1 { n1 -> n2; n1 -> n3 -> n4; }"+ , testRoundTrip "RT2" "graph T2 { n1 [ shape=\"oval\" ]\n\+ \ n1 -- n2 [ style=\"dotted\"];\n\+ \ }"+ , testRoundTrip "RT3" "digraph T3 {\n\+ \ n1 [ shape=\"rectangle\" \n\+ \ label=\"This is a very long string that may interact with the pretting printing of the output\"\n\+ \ style=\"rounded\"\n\+ \ ];\n\+ \ n1 -> n2 -> n3 -> n4 -> n5 -> n6 [\n\+ \ style=\"dotted\"\n\+ \ label=\"This is another very long string whose purpose is to ensure that pretty printing is working correctly when there are very long strings in the output\"\n\+ \ samehead=\"Yes, use the same head if there are multiples\"\n\+ \ ];\n\+ \ }"+ ]+ unless (nf == 0) $ do+ putStrLn ("Final results: "+ <> show np <> " tests passed but "+ <> show nf <> " failed.")+ exitFailure+ putStrLn $ "All " <> show np <> " tests passed."+ exitSuccess + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- parsePortTests :: [(String, Port)]@@ -77,9 +107,40 @@ , ( "-123" , IntegerId (-123) ) ] +parseGraphTests :: [(String, Graph)]+parseGraphTests =+ [+ ( "digraph T1 { n1 -> n2; n1 -> n3 -> n4; }"+ , Graph UnstrictGraph DirectedGraph (Just $ NameId "T1")+ [+ EdgeStatement [ ENodeId NoEdge (NodeId (NameId "n1") Nothing)+ , ENodeId DirectedEdge (NodeId (NameId "n2") Nothing)+ ]+ []+ , EdgeStatement [ ENodeId NoEdge (NodeId (NameId "n1") Nothing)+ , ENodeId DirectedEdge (NodeId (NameId "n3") Nothing)+ , ENodeId DirectedEdge (NodeId (NameId "n4") Nothing)+ ]+ []+ ]+ )++ , ( "graph T2 { n1 [ shape=\"oval\" ]; n1 -- n2 [ style=\"dotted\"]; }"+ , Graph UnstrictGraph UndirectedGraph (Just $ NameId "T2")+ [+ NodeStatement (NodeId (NameId "n1") Nothing)+ [ AttributeSetValue (NameId "shape") (StringId "oval") ]+ , EdgeStatement [ ENodeId NoEdge (NodeId (NameId "n1") Nothing)+ , ENodeId UndirectedEdge (NodeId (NameId "n2") Nothing)+ ]+ [ AttributeSetValue (NameId "style") (StringId "dotted") ]+ ]+ )+ ]+ -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -testParser :: (Eq a, Show a) => String -> Parser a -> [(String, a)] -> IO ()+testParser :: (Eq a, Show a) => String -> Parser a -> [(String, a)] -> IO (Int,Int) testParser name parser tests = help tests [] (0 :: Int) (0 :: Int) where@@ -87,6 +148,7 @@ putStrLn $ name ++ ": " ++ show np ++ " passed, " ++ show nf ++ " failed" mapM_ (putStrLn . (" "++)) (reverse es) unless (null es) (putStrLn "")+ return (np, nf) help ((i,o):ts) es np nf = case parse' parser i of Left _ -> help ts (makeFailureMessage name i o : es) np (succ nf)@@ -105,6 +167,28 @@ "(" ++ name ++ " " ++ show i ++ ")" ++ " returned " ++ "(" ++ show v ++ ")" ++ ", expected " ++ "(" ++ show o ++ ")"++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++testRoundTrip :: String -> String -> IO (Int,Int)+testRoundTrip testName input =+ case parse' parseGraph input of+ Left e -> do putStrLn $ "Parse failed for test " <> testName+ putStrLn $ "Input: " <> input+ putStrLn $ "Error: " <> show e+ return (0,1)+ Right v -> case parse' parseGraph $ renderDot v of+ Left _ -> do putStrLn $ "Parse failed for pretty form in test " <> testName+ putStrLn $ "Pretty: " <> renderDot v+ return (0,1)+ Right v' -> if v == v'+ then do putStrLn $ "Parse success for " <> testName+ -- putStrLn $ renderDot v+ return (1,0)+ else do putStrLn $ "Doubled round-trip failure for " <> testName <> ":"+ putStrLn $ "First parse: " <> show v+ putStrLn $ "Second parse: " <> show v'+ return (0,1) -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --