{-# 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)]]