1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Test.Framework.Tests.Runners.XMLTests (
test, property
) where
import Test.Framework.Runners.Core ( RunTest(..), FinishedTest )
import Test.Framework.Runners.XML.JUnitWriter ( RunDescription(..), morphFlatTestCase, serialize )
import Test.HUnit.Base ( Test(..), (@?=) )
import Test.QuickCheck ( Arbitrary, sized, Gen, oneof, listOf, arbitrary )
import qualified Test.QuickCheck.Property as QC ( Property, property )
import Control.Monad ( ap, liftM2, liftM3 )
import Data.Maybe ( isJust )
import qualified Text.XML.Light as XML ( Element, findAttr, unqual )
import qualified Text.XML.Light.Input as XML ( parseXMLDoc )
-- | `Arbitrary` instance for `TestResult` generation.
instance Arbitrary FinishedTest where
arbitrary = sized testResult
-- | Size-constrained generator for `TestResult`
testResult :: Int -> Gen FinishedTest
testResult n | n <= 0 = arbitraryTR
| otherwise = oneof [ liftM2 RunTestGroup arbitraryXmlStr (listOf subResult),
subResult]
where arbitraryTR = liftM3 RunTest arbitraryXmlStr arbitraryXmlStr
(liftM2 (,) arbitraryXmlStr arbitrary)
-- | drastically cut the size at each level.
-- round .. -1 is a hack. It works a bit better
-- (is more extreme) than floor and we're really
-- just trying to bound the size so that the
-- tests finish quickly. To see how @floor /=
-- (-1) + round@ consider the inputs: 0.5, 1.5,
-- and 2.5.
subResult :: Gen FinishedTest
subResult = let reduce x = (round (logBase 32 (fromIntegral x) :: Double)) - 1
in testResult $ reduce n
-- | `RunDescription` generator. All string records are restricted to valid xml characters.
instance Arbitrary RunDescription where
arbitrary = do
return RunDescription
`ap` arbitrary -- errors
`ap` arbitrary -- failed count
`ap` arbitrary -- skipped
`ap` arbitraryMaybeXmlStr -- hostname
`ap` arbitraryXmlStr -- suiteName
`ap` arbitrary -- testCount
`ap` arbitrary -- time
`ap` arbitraryMaybeXmlStr -- timeStamp
`ap` arbitraryMaybeXmlStr -- runId
`ap` arbitraryMaybeXmlStr -- package
`ap` arbitrary -- tests
-- | Generator for strings that only contain valid XML codepoints, and
-- are wrapped in Maybe. If/when empty strings are generated, they
-- have a 50% chance of being `Nothing`, so this generator should be biased
-- to create `Just` `String`s over `Nothing`
arbitraryMaybeXmlStr :: Gen (Maybe String)
arbitraryMaybeXmlStr = do
str <- arbitraryXmlStr
if null str -- if we have an empty string, we have a chance of generating @Nothing@
then oneof [return (Just str), return Nothing]
else return (Just str)
-- | String generator that does not include invalid XML characters. The
-- set of invalid characters is specified here:
-- http://www.w3.org/TR/2000/REC-xml-20001006#NT-Char
arbitraryXmlStr :: Gen String
arbitraryXmlStr = listOf arbitraryXmlChar
where
arbitraryXmlChar :: Gen Char
arbitraryXmlChar = do c <- arbitrary
if validXmlChar (fromEnum c)
then return c
else arbitraryXmlChar
validXmlChar c = c == 0x9 || c == 0xA || c == 0xD
|| (c >= 0x20 && c <= 0xD7FF)
|| (c >= 0xE000 && c <= 0xFFFD)
|| (c >= 0x10000 && c <= 0x10FFFF)
-- | Generate random `RunDescriptions`, serialize to (flat) XML strings, then check that they are XML
-- TODO: check them against the JUnit schema
property :: RunDescription -> QC.Property
property = QC.property . isJust . parseSerialize
parseSerialize :: RunDescription -> Maybe XML.Element
parseSerialize = XML.parseXMLDoc . serialize False
-- | Verify that the group names are properly prepended to sub-tests.
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)]]
|
