{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
-- | Run a 'Tasty.TestTree' and produce an XML file summarising the test results
-- in the same schema that would be produced by Apache Ant's JUnit test runner.
-- This schema can be intepreted by the Jenkins continuous integration server,
-- amongst other tools.
module Test.Tasty.Runners.AntXML (antXMLRunner, AntXMLPath(..) ) where

import Numeric (showFFloat)
import Control.Applicative
import Control.Arrow (first)
import Control.Monad.IO.Class (liftIO)
import Data.Foldable (fold)
import Data.List (intercalate)
import Data.Maybe (fromMaybe)
import Data.Monoid (Monoid(..), Endo(..), Sum(..))
import Data.Proxy (Proxy(..))
import Data.Tagged (Tagged(..))
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
import System.Directory (createDirectoryIfMissing, canonicalizePath)
import System.FilePath (takeDirectory)

import qualified Control.Concurrent.STM as STM
import qualified Control.Monad.State as State
import qualified Control.Monad.Reader as Reader
import qualified Data.Functor.Compose as Functor
import qualified Data.IntMap as IntMap
import qualified Test.Tasty as Tasty
import qualified Test.Tasty.Providers as Tasty
import qualified Test.Tasty.Options as Tasty
import qualified Test.Tasty.Runners as Tasty
import qualified Text.XML.Light as XML

--------------------------------------------------------------------------------
newtype AntXMLPath = AntXMLPath FilePath
  deriving (Typeable)

instance Tasty.IsOption (Maybe AntXMLPath) where
  defaultValue :: Maybe AntXMLPath
defaultValue = forall a. Maybe a
Nothing
  parseValue :: String -> Maybe (Maybe AntXMLPath)
parseValue = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> AntXMLPath
AntXMLPath
  optionName :: Tagged (Maybe AntXMLPath) String
optionName = forall {k} (s :: k) b. b -> Tagged s b
Tagged String
"xml"
  optionHelp :: Tagged (Maybe AntXMLPath) String
optionHelp = forall {k} (s :: k) b. b -> Tagged s b
Tagged String
"A file path to store the test results in Ant-compatible XML"


--------------------------------------------------------------------------------
data Summary = Summary { Summary -> Sum Int
summaryFailures :: Sum Int
                       , Summary -> Sum Int
summaryErrors :: Sum Int
                       , Summary -> Sum Int
summarySuccesses :: Sum Int
                       , Summary -> Endo [Element]
xmlRenderer :: Endo [XML.Element]
                       } deriving (forall x. Rep Summary x -> Summary
forall x. Summary -> Rep Summary x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Summary x -> Summary
$cfrom :: forall x. Summary -> Rep Summary x
Generic)

instance Monoid Summary where
  mempty :: Summary
mempty = forall a. (Generic a, Monoid' (Rep a)) => a
memptydefault
#if !MIN_VERSION_base(4,11,0)
  mappend = mappenddefault
#else
instance Semigroup Summary where
  <> :: Summary -> Summary -> Summary
(<>) = forall a. (Generic a, Monoid' (Rep a)) => a -> a -> a
mappenddefault
#endif


--------------------------------------------------------------------------------
{-|

  To run tests using this ingredient, use 'Tasty.defaultMainWithIngredients',
  passing 'antXMLRunner' as one possible ingredient. This ingredient will run
  tests if you pass the @--xml@ command line option. For example,
  @--xml=junit.xml@ will run all the tests and generate @junit.xml@ as output.

-}
antXMLRunner :: Tasty.Ingredient
antXMLRunner :: Ingredient
antXMLRunner = [OptionDescription]
-> (OptionSet
    -> TestTree -> Maybe (StatusMap -> IO (Time -> IO Bool)))
-> Ingredient
Tasty.TestReporter [OptionDescription]
optionDescription forall {m :: * -> *} {a}.
(Monad m, IsOption (m AntXMLPath), RealFloat a) =>
OptionSet -> TestTree -> m (StatusMap -> IO (a -> IO Bool))
runner
 where
  optionDescription :: [OptionDescription]
optionDescription = [ forall v. IsOption v => Proxy v -> OptionDescription
Tasty.Option (forall {k} (t :: k). Proxy t
Proxy :: Proxy (Maybe AntXMLPath)) ]
  runner :: OptionSet -> TestTree -> m (StatusMap -> IO (a -> IO Bool))
runner OptionSet
options TestTree
testTree = do
    AntXMLPath String
path <- forall v. IsOption v => OptionSet -> v
Tasty.lookupOption OptionSet
options

    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \StatusMap
statusMap ->
      let
        timeDigits :: a
timeDigits = a
3
        showTime :: a -> String
showTime a
time = forall a. RealFloat a => Maybe Int -> a -> ShowS
showFFloat (forall a. a -> Maybe a
Just forall {a}. Num a => a
timeDigits) a
time String
""

        runTest :: (Tasty.IsTest t)
                => Tasty.OptionSet
                -> Tasty.TestName
                -> t
                -> Tasty.Traversal (Functor.Compose (Reader.ReaderT [String] (State.StateT IntMap.Key IO)) (Const Summary))
        runTest :: forall t.
IsTest t =>
OptionSet
-> String
-> t
-> Traversal
     (Compose (ReaderT [String] (StateT Int IO)) (Const Summary))
runTest OptionSet
_ String
testName t
_ = forall (f :: * -> *). f () -> Traversal f
Tasty.Traversal forall a b. (a -> b) -> a -> b
$ forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Functor.Compose forall a b. (a -> b) -> a -> b
$ do
          Int
i <- forall s (m :: * -> *). MonadState s m => m s
State.get
          [String]
groupNames <- forall r (m :: * -> *). MonadReader r m => m r
Reader.ask

          Summary
summary <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
STM.atomically forall a b. (a -> b) -> a -> b
$ do
            Status
status <- forall a. TVar a -> STM a
STM.readTVar forall a b. (a -> b) -> a -> b
$
              forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"Attempted to lookup test by index outside bounds") forall a b. (a -> b) -> a -> b
$
                forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
i StatusMap
statusMap

            let testCaseAttributes :: a -> [Attr]
testCaseAttributes a
time = forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry QName -> String -> Attr
XML.Attr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first String -> QName
XML.unqual)
                  [ (String
"name", String
testName)
                  , (String
"time", forall {a}. RealFloat a => a -> String
showTime a
time)
                  , (String
"classname", forall a. [a] -> [[a]] -> [a]
intercalate String
"." (forall a. [a] -> [a]
reverse [String]
groupNames))
                  ]

                mkSummary :: t -> Summary
mkSummary t
contents =
                  forall a. Monoid a => a
mempty { xmlRenderer :: Endo [Element]
xmlRenderer = forall a. (a -> a) -> Endo a
Endo
                             (forall t. Node t => QName -> t -> Element
XML.node (String -> QName
XML.unqual String
"testcase") t
contents forall a. a -> [a] -> [a]
:)
                         }

                mkSuccess :: a -> Summary
mkSuccess a
time = (forall {t}. Node t => t -> Summary
mkSummary (forall {a}. RealFloat a => a -> [Attr]
testCaseAttributes a
time)) { summarySuccesses :: Sum Int
summarySuccesses = forall a. a -> Sum a
Sum Int
1 }

                mkFailure :: a -> t -> Summary
mkFailure a
time t
reason =
                  forall {t}. Node t => t -> Summary
mkSummary ( forall {a}. RealFloat a => a -> [Attr]
testCaseAttributes a
time
                            , forall t. Node t => QName -> t -> Element
XML.node (String -> QName
XML.unqual String
"failure") t
reason
                            )

            case Status
status of
              -- If the test is done, generate XML for it
              Tasty.Done Result
result
                | Result -> Bool
Tasty.resultSuccessful Result
result -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall {a}. RealFloat a => a -> Summary
mkSuccess (Result -> Time
Tasty.resultTime Result
result))
                | Bool
otherwise ->
                    case Result -> Maybe SomeException
resultException Result
result of
                      Just SomeException
e  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (forall {a} {t}. (RealFloat a, Node t) => a -> t -> Summary
mkFailure (Result -> Time
Tasty.resultTime Result
result) (forall a. Show a => a -> String
show SomeException
e)) { summaryErrors :: Sum Int
summaryErrors = forall a. a -> Sum a
Sum Int
1 }
                      Maybe SomeException
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
                        if Result -> Bool
resultTimedOut Result
result
                          then (forall {a} {t}. (RealFloat a, Node t) => a -> t -> Summary
mkFailure (Result -> Time
Tasty.resultTime Result
result) String
"TimeOut") { summaryErrors :: Sum Int
summaryErrors = forall a. a -> Sum a
Sum Int
1 }
                          else (forall {a} {t}. (RealFloat a, Node t) => a -> t -> Summary
mkFailure (Result -> Time
Tasty.resultTime Result
result) (Result -> String
Tasty.resultDescription Result
result))
                               { summaryFailures :: Sum Int
summaryFailures = forall a. a -> Sum a
Sum Int
1 }

              -- Otherwise the test has either not been started or is currently
              -- executing
              Status
_ -> forall a. STM a
STM.retry

          forall {k} a (b :: k). a -> Const a b
Const Summary
summary forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (forall a. Num a => a -> a -> a
+ Int
1)

        runGroup
          :: Reader.MonadReader [String] f
          => String
          -> Tasty.Traversal (Functor.Compose f (Const Summary))
          -> Tasty.Traversal (Functor.Compose f (Const Summary))
        runGroup :: forall (f :: * -> *).
MonadReader [String] f =>
String
-> Traversal (Compose f (Const Summary))
-> Traversal (Compose f (Const Summary))
runGroup String
groupName Traversal (Compose f (Const Summary))
children = forall (f :: * -> *). f () -> Traversal f
Tasty.Traversal forall a b. (a -> b) -> a -> b
$ forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Functor.Compose forall a b. (a -> b) -> a -> b
$ do
          Const Summary
soFar <- forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
Reader.local (String
groupName forall a. a -> [a] -> [a]
:) forall a b. (a -> b) -> a -> b
$ forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
Functor.getCompose forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Traversal f -> f ()
Tasty.getTraversal Traversal (Compose f (Const Summary))
children

          let grouped :: Element
grouped =
                forall t. Node t => QName -> t -> Element
XML.node (String -> QName
XML.unqual String
"testsuite")
                  ([ QName -> String -> Attr
XML.Attr (String -> QName
XML.unqual String
"name") String
groupName
                   , QName -> String -> Attr
XML.Attr (String -> QName
XML.unqual String
"tests")
                       (forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Sum a -> a
getSum forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Summary -> Sum Int
summaryFailures forall a. Monoid a => a -> a -> a
`mappend` Summary -> Sum Int
summaryErrors forall a. Monoid a => a -> a -> a
`mappend` Summary -> Sum Int
summarySuccesses) forall a b. (a -> b) -> a -> b
$ Summary
soFar)
                   ]
                  , forall a. Endo a -> a -> a
appEndo (Summary -> Endo [Element]
xmlRenderer Summary
soFar) []
                  )

          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall {k} a (b :: k). a -> Const a b
Const
            Summary
soFar { xmlRenderer :: Endo [Element]
xmlRenderer = forall a. (a -> a) -> Endo a
Endo (Element
grouped forall a. a -> [a] -> [a]
:)
                  }

        runGroup' :: p
-> String
-> t (Traversal (Compose f (Const Summary)))
-> Traversal (Compose f (Const Summary))
runGroup' p
_options String
groupName =
#if MIN_VERSION_tasty(1, 5, 0)
          forall (f :: * -> *).
MonadReader [String] f =>
String
-> Traversal (Compose f (Const Summary))
-> Traversal (Compose f (Const Summary))
runGroup String
groupName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
#else
          runGroup groupName
#endif

      in do
        (Const Summary
summary, Int
tests) <-
          forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
State.runStateT Int
0 forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
Reader.runReaderT [] forall a b. (a -> b) -> a -> b
$ forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
Functor.getCompose forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Traversal f -> f ()
Tasty.getTraversal forall a b. (a -> b) -> a -> b
$
           forall b. Monoid b => TreeFold b -> OptionSet -> TestTree -> b
Tasty.foldTestTree
             forall b. Monoid b => TreeFold b
Tasty.trivialFold { foldSingle :: forall t.
IsTest t =>
OptionSet
-> String
-> t
-> Traversal
     (Compose (ReaderT [String] (StateT Int IO)) (Const Summary))
Tasty.foldSingle = forall t.
IsTest t =>
OptionSet
-> String
-> t
-> Traversal
     (Compose (ReaderT [String] (StateT Int IO)) (Const Summary))
runTest, foldGroup :: OptionSet
-> String
-> [Traversal
      (Compose (ReaderT [String] (StateT Int IO)) (Const Summary))]
-> Traversal
     (Compose (ReaderT [String] (StateT Int IO)) (Const Summary))
Tasty.foldGroup = forall {f :: * -> *} {t :: * -> *} {p}.
(MonadReader [String] f, Foldable t) =>
p
-> String
-> t (Traversal (Compose f (Const Summary)))
-> Traversal (Compose f (Const Summary))
runGroup' }
             OptionSet
options
             TestTree
testTree

        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \a
elapsedTime -> do
          String -> IO ()
createPathDirIfMissing String
path
          String -> String -> IO ()
writeFile String
path forall a b. (a -> b) -> a -> b
$
            Element -> String
XML.showTopElement forall a b. (a -> b) -> a -> b
$
              forall t. Node t => QName -> t -> Element
XML.node
                (String -> QName
XML.unqual String
"testsuites")
                ([ QName -> String -> Attr
XML.Attr (String -> QName
XML.unqual String
"errors")
                     (forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Sum a -> a
getSum forall b c a. (b -> c) -> (a -> b) -> a -> c
. Summary -> Sum Int
summaryErrors forall a b. (a -> b) -> a -> b
$ Summary
summary)
                 , QName -> String -> Attr
XML.Attr (String -> QName
XML.unqual String
"failures")
                     (forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Sum a -> a
getSum forall b c a. (b -> c) -> (a -> b) -> a -> c
. Summary -> Sum Int
summaryFailures forall a b. (a -> b) -> a -> b
$ Summary
summary)
                 , QName -> String -> Attr
XML.Attr (String -> QName
XML.unqual String
"tests") (forall a. Show a => a -> String
show Int
tests)
                 , QName -> String -> Attr
XML.Attr (String -> QName
XML.unqual String
"time") (forall {a}. RealFloat a => a -> String
showTime a
elapsedTime)
                 ]
                , forall a. Endo a -> a -> a
appEndo (Summary -> Endo [Element]
xmlRenderer Summary
summary) [])

          forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Sum a -> a
getSum ((Summary -> Sum Int
summaryFailures forall a. Monoid a => a -> a -> a
`mappend` Summary -> Sum Int
summaryErrors) Summary
summary) forall a. Eq a => a -> a -> Bool
== Int
0)

  resultException :: Result -> Maybe SomeException
resultException Result
r =
    case Result -> Outcome
Tasty.resultOutcome Result
r of
         Tasty.Failure (Tasty.TestThrewException SomeException
e) -> forall a. a -> Maybe a
Just SomeException
e
         Outcome
_ -> forall a. Maybe a
Nothing

  resultTimedOut :: Result -> Bool
resultTimedOut Result
r =
    case Result -> Outcome
Tasty.resultOutcome Result
r of
         Tasty.Failure (Tasty.TestTimedOut Integer
_) -> Bool
True
         Outcome
_ -> Bool
False

  createPathDirIfMissing :: String -> IO ()
createPathDirIfMissing String
path = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ShowS
takeDirectory (String -> IO String
canonicalizePath String
path)
                                forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> String -> IO ()
createDirectoryIfMissing Bool
True