{-# 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.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 = Maybe AntXMLPath
forall a. Maybe a
Nothing
  parseValue :: String -> Maybe (Maybe AntXMLPath)
parseValue = Maybe AntXMLPath -> Maybe (Maybe AntXMLPath)
forall a. a -> Maybe a
Just (Maybe AntXMLPath -> Maybe (Maybe AntXMLPath))
-> (String -> Maybe AntXMLPath)
-> String
-> Maybe (Maybe AntXMLPath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AntXMLPath -> Maybe AntXMLPath
forall a. a -> Maybe a
Just (AntXMLPath -> Maybe AntXMLPath)
-> (String -> AntXMLPath) -> String -> Maybe AntXMLPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> AntXMLPath
AntXMLPath
  optionName :: Tagged (Maybe AntXMLPath) String
optionName = String -> Tagged (Maybe AntXMLPath) String
forall k (s :: k) b. b -> Tagged s b
Tagged String
"xml"
  optionHelp :: Tagged (Maybe AntXMLPath) String
optionHelp = String -> Tagged (Maybe AntXMLPath) String
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. Summary -> Rep Summary x)
-> (forall x. Rep Summary x -> Summary) -> Generic Summary
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 = Summary
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
(<>) = 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 OptionSet -> TestTree -> Maybe (StatusMap -> IO (Time -> IO Bool))
forall (m :: * -> *) a.
(Monad m, IsOption (m AntXMLPath), RealFloat a) =>
OptionSet -> TestTree -> m (StatusMap -> IO (a -> IO Bool))
runner
 where
  optionDescription :: [OptionDescription]
optionDescription = [ Proxy (Maybe AntXMLPath) -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Tasty.Option (Proxy (Maybe AntXMLPath)
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 <- OptionSet -> m AntXMLPath
forall v. IsOption v => OptionSet -> v
Tasty.lookupOption OptionSet
options

    (StatusMap -> IO (a -> IO Bool))
-> m (StatusMap -> IO (a -> IO Bool))
forall (m :: * -> *) a. Monad m => a -> m a
return ((StatusMap -> IO (a -> IO Bool))
 -> m (StatusMap -> IO (a -> IO Bool)))
-> (StatusMap -> IO (a -> IO Bool))
-> m (StatusMap -> IO (a -> IO Bool))
forall a b. (a -> b) -> a -> b
$ \StatusMap
statusMap ->
      let
        timeDigits :: p
timeDigits = p
3
        showTime :: a -> String
showTime a
time = Maybe Int -> a -> ShowS
forall a. RealFloat a => Maybe Int -> a -> ShowS
showFFloat (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
forall p. Num p => p
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 :: OptionSet
-> String
-> t
-> Traversal
     (Compose (ReaderT [String] (StateT Int IO)) (Const Summary))
runTest OptionSet
_ String
testName t
_ = Compose (ReaderT [String] (StateT Int IO)) (Const Summary) ()
-> Traversal
     (Compose (ReaderT [String] (StateT Int IO)) (Const Summary))
forall (f :: * -> *). f () -> Traversal f
Tasty.Traversal (Compose (ReaderT [String] (StateT Int IO)) (Const Summary) ()
 -> Traversal
      (Compose (ReaderT [String] (StateT Int IO)) (Const Summary)))
-> Compose (ReaderT [String] (StateT Int IO)) (Const Summary) ()
-> Traversal
     (Compose (ReaderT [String] (StateT Int IO)) (Const Summary))
forall a b. (a -> b) -> a -> b
$ ReaderT [String] (StateT Int IO) (Const Summary ())
-> Compose (ReaderT [String] (StateT Int IO)) (Const Summary) ()
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Functor.Compose (ReaderT [String] (StateT Int IO) (Const Summary ())
 -> Compose (ReaderT [String] (StateT Int IO)) (Const Summary) ())
-> ReaderT [String] (StateT Int IO) (Const Summary ())
-> Compose (ReaderT [String] (StateT Int IO)) (Const Summary) ()
forall a b. (a -> b) -> a -> b
$ do
          Int
i <- ReaderT [String] (StateT Int IO) Int
forall s (m :: * -> *). MonadState s m => m s
State.get
          [String]
groupNames <- ReaderT [String] (StateT Int IO) [String]
forall r (m :: * -> *). MonadReader r m => m r
Reader.ask

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

            let testCaseAttributes :: a -> [Attr]
testCaseAttributes a
time = ((String, String) -> Attr) -> [(String, String)] -> [Attr]
forall a b. (a -> b) -> [a] -> [b]
map ((QName -> String -> Attr) -> (QName, String) -> Attr
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry QName -> String -> Attr
XML.Attr ((QName, String) -> Attr)
-> ((String, String) -> (QName, String))
-> (String, String)
-> Attr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> QName) -> (String, String) -> (QName, String)
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", a -> String
forall a. RealFloat a => a -> String
showTime a
time)
                  , (String
"classname", String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"." ([String] -> [String]
forall a. [a] -> [a]
reverse [String]
groupNames))
                  ]

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

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

                mkFailure :: a -> t -> Summary
mkFailure a
time t
reason =
                  ([Attr], Element) -> Summary
forall t. Node t => t -> Summary
mkSummary ( a -> [Attr]
forall a. RealFloat a => a -> [Attr]
testCaseAttributes a
time
                            , QName -> t -> Element
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 -> Summary -> STM Summary
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Time -> Summary
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  -> Summary -> STM Summary
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Summary -> STM Summary) -> Summary -> STM Summary
forall a b. (a -> b) -> a -> b
$ (Time -> String -> Summary
forall a t. (RealFloat a, Node t) => a -> t -> Summary
mkFailure (Result -> Time
Tasty.resultTime Result
result) (SomeException -> String
forall a. Show a => a -> String
show SomeException
e)) { summaryErrors :: Sum Int
summaryErrors = Int -> Sum Int
forall a. a -> Sum a
Sum Int
1 }
                      Maybe SomeException
Nothing -> Summary -> STM Summary
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Summary -> STM Summary) -> Summary -> STM Summary
forall a b. (a -> b) -> a -> b
$
                        if Result -> Bool
resultTimedOut Result
result
                          then (Time -> String -> Summary
forall a t. (RealFloat a, Node t) => a -> t -> Summary
mkFailure (Result -> Time
Tasty.resultTime Result
result) String
"TimeOut") { summaryErrors :: Sum Int
summaryErrors = Int -> Sum Int
forall a. a -> Sum a
Sum Int
1 }
                          else (Time -> String -> Summary
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 = Int -> Sum Int
forall a. a -> Sum a
Sum Int
1 }

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

          Summary -> Const Summary ()
forall k a (b :: k). a -> Const a b
Const Summary
summary Const Summary ()
-> ReaderT [String] (StateT Int IO) ()
-> ReaderT [String] (StateT Int IO) (Const Summary ())
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Int -> Int) -> ReaderT [String] (StateT Int IO) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

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

          let grouped :: Element
grouped =
                QName -> ([Attr], [Element]) -> Element
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")
                       (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> (Summary -> Int) -> Summary -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sum Int -> Int
forall a. Sum a -> a
getSum (Sum Int -> Int) -> (Summary -> Sum Int) -> Summary -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Summary -> Sum Int
summaryFailures (Summary -> Sum Int) -> (Summary -> Sum Int) -> Summary -> Sum Int
forall a. Monoid a => a -> a -> a
`mappend` Summary -> Sum Int
summaryErrors (Summary -> Sum Int) -> (Summary -> Sum Int) -> Summary -> Sum Int
forall a. Monoid a => a -> a -> a
`mappend` Summary -> Sum Int
summarySuccesses) (Summary -> String) -> Summary -> String
forall a b. (a -> b) -> a -> b
$ Summary
soFar)
                   ]
                  , Endo [Element] -> [Element] -> [Element]
forall a. Endo a -> a -> a
appEndo (Summary -> Endo [Element]
xmlRenderer Summary
soFar) []
                  )

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

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

        (a -> IO Bool) -> IO (a -> IO Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ((a -> IO Bool) -> IO (a -> IO Bool))
-> (a -> IO Bool) -> IO (a -> IO Bool)
forall a b. (a -> b) -> a -> b
$ \a
elapsedTime -> do
          String -> IO ()
createPathDirIfMissing String
path
          String -> String -> IO ()
writeFile String
path (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
            Element -> String
XML.showTopElement (Element -> String) -> Element -> String
forall a b. (a -> b) -> a -> b
$
              QName -> ([Attr], [Element]) -> Element
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")
                     (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> (Summary -> Int) -> Summary -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sum Int -> Int
forall a. Sum a -> a
getSum (Sum Int -> Int) -> (Summary -> Sum Int) -> Summary -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Summary -> Sum Int
summaryErrors (Summary -> String) -> Summary -> String
forall a b. (a -> b) -> a -> b
$ Summary
summary)
                 , QName -> String -> Attr
XML.Attr (String -> QName
XML.unqual String
"failures")
                     (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> (Summary -> Int) -> Summary -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sum Int -> Int
forall a. Sum a -> a
getSum (Sum Int -> Int) -> (Summary -> Sum Int) -> Summary -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Summary -> Sum Int
summaryFailures (Summary -> String) -> Summary -> String
forall a b. (a -> b) -> a -> b
$ Summary
summary)
                 , QName -> String -> Attr
XML.Attr (String -> QName
XML.unqual String
"tests") (Int -> String
forall a. Show a => a -> String
show Int
tests)
                 , QName -> String -> Attr
XML.Attr (String -> QName
XML.unqual String
"time") (a -> String
forall a. RealFloat a => a -> String
showTime a
elapsedTime)
                 ]
                , Endo [Element] -> [Element] -> [Element]
forall a. Endo a -> a -> a
appEndo (Summary -> Endo [Element]
xmlRenderer Summary
summary) [])

          Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Sum Int -> Int
forall a. Sum a -> a
getSum ((Summary -> Sum Int
summaryFailures (Summary -> Sum Int) -> (Summary -> Sum Int) -> Summary -> Sum Int
forall a. Monoid a => a -> a -> a
`mappend` Summary -> Sum Int
summaryErrors) Summary
summary) Int -> Int -> Bool
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) -> SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
e
         Outcome
_ -> Maybe SomeException
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 = ShowS -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ShowS
takeDirectory (String -> IO String
canonicalizePath String
path)
                                IO String -> (String -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> String -> IO ()
createDirectoryIfMissing Bool
True