module Main (main) where
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
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)]
parsePortTests =
[ ( ":\"x\"" , PortI (StringId "x" ) Nothing )
, ( ":\"\\t\\\"\":nw" , PortI (StringId "\\t\"" ) (Just CompassNW) )
, ( ":-.0004" , PortI (FloatId (-0.0004) ) Nothing )
, ( ":-1.23:sE" , PortI (FloatId (-1.23) ) (Just CompassSE) )
, ( ":123" , PortI (IntegerId 123 ) Nothing )
, ( ":123:NE" , PortI (IntegerId 123 ) (Just CompassNE) )
, ( ":__2xYz" , PortI (NameId "__2xYz" ) Nothing )
, ( ":__2xYz:S" , PortI (NameId "__2xYz" ) (Just CompassS) )
, ( ":n" , PortC CompassN )
, ( ":SE" , PortC CompassSE )
]
parseCompassTests :: [(String, Compass)]
parseCompassTests =
concat
[ [ (t, CompassN) | t <- allCaps "n" ]
, [ (t, CompassE) | t <- allCaps "e" ]
, [ (t, CompassS) | t <- allCaps "s" ]
, [ (t, CompassW) | t <- allCaps "w" ]
, [ (t, CompassNE) | t <- allCaps "ne" ]
, [ (t, CompassNW) | t <- allCaps "nw" ]
, [ (t, CompassSE) | t <- allCaps "se" ]
, [ (t, CompassSW) | t <- allCaps "sw" ]
]
parseAttributeTests :: [(String, Attribute)]
parseAttributeTests =
[ ( "a" , AttributeSetTrue (NameId "a") )
, ( "a=b" , AttributeSetValue (NameId "a") (NameId "b") )
, ( "-.003\t=\r\n _xYz123_" , AttributeSetValue (FloatId (-0.003)) (NameId "_xYz123_") )
, ( "\"\\t\\\"\" =-123" , AttributeSetValue (StringId "\\t\"") (IntegerId (-123)) )
]
parseIdTests :: [(String, Id)]
parseIdTests =
[ ( "a" , NameId "a" )
, ( "A1" , NameId "A1" )
, ( "_2X" , NameId "_2X" )
, ( "\"\"" , StringId "" )
, ( "\"\\t\\r\\n\"" , StringId "\\t\\r\\n" )
, ( ".0" , FloatId 0.0 )
, ( ".123" , FloatId 0.123 )
, ( "+.999" , FloatId 0.999 )
, ( "-.001" , FloatId (-0.001) )
, ( "+.001" , FloatId 0.001 )
, ( "0.0" , FloatId 0.0 )
, ( "1.2" , FloatId 1.2 )
, ( "123.456" , FloatId 123.456 )
, ( "0" , IntegerId 0 )
, ( "+0" , IntegerId 0 )
, ( "-0" , IntegerId 0 )
, ( "123" , IntegerId 123 )
, ( "-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 (Int,Int)
testParser name parser tests =
help tests [] (0 :: Int) (0 :: Int)
where
help [] es np nf = do
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)
Right v ->
if v /= o
then help ts (makeFailureMessage' name i o v : es) np (succ nf)
else help ts es (succ np) nf
makeFailureMessage :: (Show a) => String -> String -> a -> String
makeFailureMessage name i o =
"(" ++ name ++ " " ++ show i ++ ")" ++
" should have returned " ++ "(" ++ show o ++ ")"
makeFailureMessage' :: (Show a) => String -> String -> a -> a -> String
makeFailureMessage' name i o v =
"(" ++ 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)
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
parse' :: Parser a -> String -> Either ParseError a
parse' p = parse p ""
allCaps :: String -> [String]
allCaps [] = [[]]
allCaps (c:cs) =
concatMap (\t -> [l:t, u:t]) (allCaps cs)
where
l = toLower c
u = toUpper c