{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
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
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
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 }
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