diff --git a/language-dot.cabal b/language-dot.cabal --- a/language-dot.cabal +++ b/language-dot.cabal @@ -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 maintainer: Ben Gamari 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 diff --git a/ppdot/Main.hs b/ppdot/Main.hs --- a/ppdot/Main.hs +++ b/ppdot/Main.hs @@ -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 diff --git a/src/Language/Dot/Parser.hs b/src/Language/Dot/Parser.hs --- a/src/Language/Dot/Parser.hs +++ b/src/Language/Dot/Parser.hs @@ -3,6 +3,7 @@ module Language.Dot.Parser ( parseDot #ifdef TEST + , parseGraph , parsePort , parseCompass , parseAttribute diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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) -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --