Permalink
Browse files

Attempt to support both nested and flat JUnit XML output, defaulting …

…to flat but under flag control
  • Loading branch information...
1 parent d081dbe commit 82ae48b54aecbf95e9f324d57fa318733620468e @batterseapower committed Aug 3, 2011
@@ -63,7 +63,10 @@ optionsDescription = [
"only tests that match at least one glob pattern given by an instance of this argument will be run",
Option [] ["jxml"]
(ReqArg (\t -> mempty { ropt_xml_output = Just (Just t) }) "FILE")
- "write a junit-xml summary of the output to FILE",
+ "write a JUnit XML summary of the output to FILE",
+ Option [] ["jxml-nested"]
+ (NoArg (mempty { ropt_xml_nested = Just True }))
+ "use nested testsuites to represent groups in JUnit XML (not standards compliant)",
Option [] ["plain"]
(NoArg (mempty { ropt_plain_output = Just True }))
"do not use any ANSI terminal features to display the test run",
@@ -124,7 +127,7 @@ defaultMainWithOpts tests ropts = do
-- Output XML report (if requested)
case ropt_xml_output ropts' of
- K (Just file) -> XML.produceReport test_statistics' fin_tests >>= writeFile file
+ K (Just file) -> XML.produceReport (unK (ropt_xml_nested ropts')) test_statistics' fin_tests >>= writeFile file
_ -> return ()
-- Set the error code depending on whether the tests succeded or not
@@ -139,6 +142,7 @@ completeRunnerOptions ro = RunnerOptions {
ropt_test_options = K $ ropt_test_options ro `orElse` mempty,
ropt_test_patterns = K $ ropt_test_patterns ro `orElse` mempty,
ropt_xml_output = K $ ropt_xml_output ro `orElse` Nothing,
+ ropt_xml_nested = K $ ropt_xml_nested ro `orElse` False,
ropt_plain_output = K $ ropt_plain_output ro `orElse` False,
ropt_hide_successes = K $ ropt_hide_successes ro `orElse` False
}
@@ -14,6 +14,7 @@ data RunnerOptions' f = RunnerOptions {
ropt_test_options :: f TestOptions,
ropt_test_patterns :: f [TestPattern],
ropt_xml_output :: f (Maybe FilePath),
+ ropt_xml_nested :: f Bool,
ropt_plain_output :: f Bool,
ropt_hide_successes :: f Bool
}
@@ -24,6 +25,7 @@ instance Monoid (RunnerOptions' Maybe) where
ropt_test_options = Nothing,
ropt_test_patterns = Nothing,
ropt_xml_output = Nothing,
+ ropt_xml_nested = Nothing,
ropt_plain_output = Nothing,
ropt_hide_successes = Nothing
}
@@ -33,6 +35,7 @@ instance Monoid (RunnerOptions' Maybe) where
ropt_test_options = mappendBy ropt_test_options ro1 ro2,
ropt_test_patterns = mappendBy ropt_test_patterns ro1 ro2,
ropt_xml_output = mappendBy ropt_xml_output ro1 ro2,
+ ropt_xml_nested = getLast (mappendBy (Last . ropt_xml_nested) ro1 ro2),
ropt_plain_output = getLast (mappendBy (Last . ropt_plain_output) ro1 ro2),
ropt_hide_successes = getLast (mappendBy (Last . ropt_hide_successes) ro1 ro2)
}
@@ -14,8 +14,8 @@ import System.Locale ( defaultTimeLocale )
import Network.HostName ( getHostName )
-produceReport :: TestStatistics -> [FinishedTest] -> IO String
-produceReport test_statistics fin_tests = fmap serialize $ mergeResults test_statistics fin_tests
+produceReport :: Bool -> TestStatistics -> [FinishedTest] -> IO String
+produceReport nested test_statistics fin_tests = fmap (serialize nested) $ mergeResults test_statistics fin_tests
-- | Generates a description of the complete test run, given some
@@ -1,13 +1,15 @@
module Test.Framework.Runners.XML.JUnitWriter (
RunDescription(..),
- serialize, toXml,
+ serialize,
#ifdef TEST
- morphTestCase
+ morphFlatTestCase, morphNestedTestCase
#endif
) where
+import Test.Framework.Core (TestName)
import Test.Framework.Runners.Core (RunTest(..), FinishedTest)
+import Data.List ( intercalate )
import Data.Maybe ( fromMaybe )
import Text.XML.Light ( ppTopElement, unqual, unode
, Attr(..), Element(..) )
@@ -36,13 +38,16 @@ data RunDescription = RunDescription {
-- | Serializes a `RunDescription` value to a `String`.
-serialize :: RunDescription -> String
-serialize = ppTopElement . toXml
+serialize :: Bool -> RunDescription -> String
+serialize nested = ppTopElement . toXml nested
-- | Maps a `RunDescription` value to an XML Element
-toXml :: RunDescription -> Element
-toXml runDesc = unode "testsuite" (attrs, map morphTestCase $ tests runDesc)
+toXml :: Bool -> RunDescription -> Element
+toXml nested runDesc = unode "testsuite" (attrs, morph_cases (tests runDesc))
where
+ morph_cases | nested = map morphNestedTestCase
+ | otherwise = concatMap (morphFlatTestCase [])
+
-- | Top-level attributes for the first @testsuite@ tag.
attrs :: [Attr]
attrs = map (\(x,f)->Attr (unqual x) (f runDesc)) fields
@@ -58,17 +63,25 @@ toXml runDesc = unode "testsuite" (attrs, map morphTestCase $ tests runDesc)
, ("package", fromMaybe "" . package)
]
--- | Generates XML elements for an individual test case or test group.
-morphTestCase :: FinishedTest -> Element
-morphTestCase (RunTestGroup gname testList) =
- unode "testsuite" (attrs, map morphTestCase testList)
+morphFlatTestCase :: [String] -> FinishedTest -> [Element]
+morphFlatTestCase path (RunTestGroup gname testList)
+ = concatMap (morphFlatTestCase (gname:path)) testList
+morphFlatTestCase path (RunTest tName _ res) = [morphOneTestCase cName tName res]
+ where cName | null path = "<none>"
+ | otherwise = intercalate "." (reverse path)
+
+morphNestedTestCase :: FinishedTest -> Element
+morphNestedTestCase (RunTestGroup gname testList) =
+ unode "testsuite" (attrs, map morphNestedTestCase testList)
where attrs = [ Attr (unqual "name") gname ]
+morphNestedTestCase (RunTest tName _ res) = morphOneTestCase "" tName res
-morphTestCase (RunTest tName _ (tout, pass)) = case pass of
+morphOneTestCase :: String -> TestName -> (String, Bool) -> Element
+morphOneTestCase cName tName (tout, pass) = case pass of
True -> unode "testcase" caseAttrs
False -> unode "testcase" (caseAttrs, unode "failure" (failAttrs, tout))
where caseAttrs = [ Attr (unqual "name") tName
- , Attr (unqual "classname") ""
+ , Attr (unqual "classname") cName
, Attr (unqual "time") ""
]
failAttrs = [ Attr (unqual "message") ""
@@ -9,7 +9,8 @@ import Test.QuickCheck
-- I wish I could use my test framework to test my framework...
main :: IO ()
main = do
- _ <- runTestTT $ TestList TP.tests
- _ <- runTestTT $ TestList XT.tests
- quickCheck XT.prop_validXml
- return ()
+ _ <- runTestTT $ TestList [
+ TestList TP.tests,
+ XT.test
+ ]
+ quickCheck XT.property
@@ -1,23 +1,33 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Test.Framework.Tests.Runners.XMLTests where
+module Test.Framework.Tests.Runners.XMLTests (
+ test, property
+ ) where
import Test.Framework.Runners.Core ( RunTest(..), FinishedTest )
-import Test.Framework.Runners.XML.JUnitWriter ( RunDescription(..), morphTestCase, serialize )
+import Test.Framework.Runners.XML.JUnitWriter ( RunDescription(..), morphFlatTestCase, serialize )
-import Test.HUnit.Base ( Test(..), Assertion, (@?=) )
+import Test.HUnit.Base ( Test(..), (@?=) )
import Test.QuickCheck ( Arbitrary, sized, Gen, oneof, listOf, arbitrary )
-import Test.QuickCheck.Property as P (Property, Result(..), succeeded, failed,
- result, liftIOResult)
+import Test.QuickCheck.Property as P ( Property )
import Control.Monad
-import Data.ByteString.Char8 as C8 ( pack )
+import Data.ByteString.Char8 as BS ( pack )
import Data.Maybe
-import Text.XML.Light ( findAttr, unqual, findElements )
-import Text.XML.LibXML.Parser ( parseMemory_ )
+import qualified Text.XML.Light as XML ( findAttr, unqual )
+import qualified Text.XML.LibXML.Parser as XML ( parseMemory_ )
+import qualified Text.XML.LibXML.Types as XML ( Document )
--- Properties:
+
+-- #ifdef MIN_VERSION_QuickCheck(2, 4, 0)
+import Test.QuickCheck.Property as P (morallyDubiousIOProperty)
+-- #else
+-- import qualified Test.QuickCheck.Property as P (succeeded, failed, liftIOResult)
+
+-- morallyDubiousIOProperty :: IO Bool -> Property
+-- morallyDubiousIOProperty it = P.liftIOResult $ fmap (\err -> if err then P.failed else P.succeeded) it
+-- #endif
-- | `Arbitrary` instance for `TestResult` generation.
instance Arbitrary FinishedTest where
@@ -84,38 +94,16 @@ arbitraryXmlStr = listOf arbitraryXmlChar
|| (c >= 0xE000 && c <= 0xFFFD)
|| (c >= 0x10000 && c <= 0x10FFFF)
--- | Generate random `RunDescriptions`, serialize to XML strings, then
--- compare against the junitreport schema.
-prop_validXml :: RunDescription -> P.Property
-prop_validXml runDescr = P.liftIOResult $ simpleValidate $ serialize runDescr
- where
- simpleValidate :: String -> IO P.Result
- simpleValidate xml = do
- err <- fmap isNothing $ parseMemory_ $ C8.pack xml
- return $ if err then P.failed else P.succeeded
-
-
-{-
- HUnit tests:
--}
+-- | Generate random `RunDescriptions`, serialize to (flat) XML strings, then check that they are XML
+-- TODO: check them against the JUnit schema
+property :: RunDescription -> P.Property
+property = morallyDubiousIOProperty . fmap isJust . parseSerialize
-
-
-tests :: [Test]
-tests = [ ]
-
-{- This test no longer applies
-tests = [ TestLabel "Check the composition of group names"
- (TestCase test_gNameCase1)
- ]
+parseSerialize :: RunDescription -> IO (Maybe XML.Document)
+parseSerialize = XML.parseMemory_ . BS.pack . serialize False
-- | Verify that the group names are properly pre-pended to sub-tests.
-test_gNameCase1 :: Assertion
-test_gNameCase1 = let x = morphTestCase tGroup2
- in
- findAttr (unqual "classname") x @?= Just "top.g1"
- where
- tGroup1 = RunTestGroup "g1" [RunTest "t1" "" ("", True)]
- tGroup2 = RunTestGroup "top" [tGroup1]
--}
-
+test :: Test
+test = TestLabel "Check the composition of group names" $ TestCase $
+ XML.findAttr (XML.unqual "classname") x @?= Just "top.g1"
+ where x = head $ morphFlatTestCase [] $ RunTestGroup "top" [RunTestGroup "g1" [RunTest "t1" "" ("", True)]]
@@ -78,7 +78,7 @@ Executable test-framework-tests
if !flag(tests)
Buildable: False
else
- Build-Depends: HUnit >= 1.2, QuickCheck >= 2.3 && < 2.4,
+ Build-Depends: HUnit >= 1.2, QuickCheck >= 2.3 && < 2.5,
ansi-terminal >= 0.4.0, ansi-wl-pprint >= 0.5.1,
regex-posix >= 0.72, extensible-exceptions >= 0.1.1,
old-locale >= 1.0, time >= 1.1.2,

0 comments on commit 82ae48b

Please sign in to comment.