{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
module Test.Tasty.Grade (testGroupPoints, jsonRunner) where

import Control.Applicative
import Control.Monad.IO.Class (liftIO)
import Data.Maybe (fromMaybe)
import Data.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 Data.Functor.Compose as Functor
import qualified Data.Aeson as Aeson
import Data.Aeson ((.=))
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

data TestGroupProps = TestGroupProps
  { TestGroupProps -> Int
pointsPerSuccess :: Int
  , TestGroupProps -> Int
pointsPerFailure :: Int
  , TestGroupProps -> Int
maxPointPerGroup :: Int
  }
  deriving (Int -> TestGroupProps -> ShowS
[TestGroupProps] -> ShowS
TestGroupProps -> String
(Int -> TestGroupProps -> ShowS)
-> (TestGroupProps -> String)
-> ([TestGroupProps] -> ShowS)
-> Show TestGroupProps
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TestGroupProps] -> ShowS
$cshowList :: [TestGroupProps] -> ShowS
show :: TestGroupProps -> String
$cshow :: TestGroupProps -> String
showsPrec :: Int -> TestGroupProps -> ShowS
$cshowsPrec :: Int -> TestGroupProps -> ShowS
Show, TestGroupProps -> TestGroupProps -> Bool
(TestGroupProps -> TestGroupProps -> Bool)
-> (TestGroupProps -> TestGroupProps -> Bool) -> Eq TestGroupProps
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TestGroupProps -> TestGroupProps -> Bool
$c/= :: TestGroupProps -> TestGroupProps -> Bool
== :: TestGroupProps -> TestGroupProps -> Bool
$c== :: TestGroupProps -> TestGroupProps -> Bool
Eq, Eq TestGroupProps
Eq TestGroupProps =>
(TestGroupProps -> TestGroupProps -> Ordering)
-> (TestGroupProps -> TestGroupProps -> Bool)
-> (TestGroupProps -> TestGroupProps -> Bool)
-> (TestGroupProps -> TestGroupProps -> Bool)
-> (TestGroupProps -> TestGroupProps -> Bool)
-> (TestGroupProps -> TestGroupProps -> TestGroupProps)
-> (TestGroupProps -> TestGroupProps -> TestGroupProps)
-> Ord TestGroupProps
TestGroupProps -> TestGroupProps -> Bool
TestGroupProps -> TestGroupProps -> Ordering
TestGroupProps -> TestGroupProps -> TestGroupProps
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TestGroupProps -> TestGroupProps -> TestGroupProps
$cmin :: TestGroupProps -> TestGroupProps -> TestGroupProps
max :: TestGroupProps -> TestGroupProps -> TestGroupProps
$cmax :: TestGroupProps -> TestGroupProps -> TestGroupProps
>= :: TestGroupProps -> TestGroupProps -> Bool
$c>= :: TestGroupProps -> TestGroupProps -> Bool
> :: TestGroupProps -> TestGroupProps -> Bool
$c> :: TestGroupProps -> TestGroupProps -> Bool
<= :: TestGroupProps -> TestGroupProps -> Bool
$c<= :: TestGroupProps -> TestGroupProps -> Bool
< :: TestGroupProps -> TestGroupProps -> Bool
$c< :: TestGroupProps -> TestGroupProps -> Bool
compare :: TestGroupProps -> TestGroupProps -> Ordering
$ccompare :: TestGroupProps -> TestGroupProps -> Ordering
$cp1Ord :: Eq TestGroupProps
Ord)

instance Tasty.IsOption (Maybe TestGroupProps) where
  defaultValue :: Maybe TestGroupProps
defaultValue = Maybe TestGroupProps
forall a. Maybe a
Nothing
  parseValue :: String -> Maybe (Maybe TestGroupProps)
parseValue _ = Maybe (Maybe TestGroupProps)
forall a. Maybe a
Nothing
  optionName :: Tagged (Maybe TestGroupProps) String
optionName = String -> Tagged (Maybe TestGroupProps) String
forall k (s :: k) b. b -> Tagged s b
Tagged "testgrouppoints"
  optionHelp :: Tagged (Maybe TestGroupProps) String
optionHelp = String -> Tagged (Maybe TestGroupProps) String
forall k (s :: k) b. b -> Tagged s b
Tagged ""

-- | Combinator for adding points to a single test or a whole test-group.
--
-- Note: This currently handles only a single group of test cases,
-- e.g. no nested 'TestTree' are supported.
testGroupPoints ::
  -- | Points you receive for a successful test-case.
  Int ->
  -- | Points you lose when a test-case fails.
  Int ->
  -- | Maximum number of points you can receive for the given test-tree.
  Int ->
  -- | TestTree you want to apply the grading scheme to.
  Tasty.TestTree ->
  Tasty.TestTree
testGroupPoints :: Int -> Int -> Int -> TestTree -> TestTree
testGroupPoints plus :: Int
plus minus :: Int
minus upperBound :: Int
upperBound tree :: TestTree
tree = (OptionSet -> OptionSet) -> TestTree -> TestTree
Tasty.PlusTestOptions (TestGroupProps -> Maybe TestGroupProps
forall a. a -> Maybe a
Just TestGroupProps
points Maybe TestGroupProps -> OptionSet -> OptionSet
forall v. IsOption v => v -> OptionSet -> OptionSet
`Tasty.setOption`) TestTree
tree
  where
    points :: TestGroupProps
points = Int -> Int -> Int -> TestGroupProps
TestGroupProps Int
plus Int
minus Int
upperBound

-- ----------------------------------------------------------------------------

newtype JsonPath = JsonPath FilePath
  deriving (Typeable)

instance Tasty.IsOption (Maybe JsonPath) where
  defaultValue :: Maybe JsonPath
defaultValue = Maybe JsonPath
forall a. Maybe a
Nothing
  parseValue :: String -> Maybe (Maybe JsonPath)
parseValue = Maybe JsonPath -> Maybe (Maybe JsonPath)
forall a. a -> Maybe a
Just (Maybe JsonPath -> Maybe (Maybe JsonPath))
-> (String -> Maybe JsonPath) -> String -> Maybe (Maybe JsonPath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JsonPath -> Maybe JsonPath
forall a. a -> Maybe a
Just (JsonPath -> Maybe JsonPath)
-> (String -> JsonPath) -> String -> Maybe JsonPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> JsonPath
JsonPath
  optionName :: Tagged (Maybe JsonPath) String
optionName = String -> Tagged (Maybe JsonPath) String
forall k (s :: k) b. b -> Tagged s b
Tagged "grading-json"
  optionHelp :: Tagged (Maybe JsonPath) String
optionHelp = String -> Tagged (Maybe JsonPath) String
forall k (s :: k) b. b -> Tagged s b
Tagged "A file path to store the test results in JSON, annotated by points"

-- ----------------------------------------------------------------------------

data Summary = Summary { Summary -> Sum Int
summaryFailures :: Sum Int
                       , Summary -> Sum Int
summaryErrors :: Sum Int
                       , Summary -> Sum Int
summarySuccesses :: Sum Int
                       , Summary -> Endo [Value]
jsonRenderer :: Endo [Aeson.Value]
                       } 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

instance Semigroup Summary where
  <> :: Summary -> Summary -> Summary
(<>) = Summary -> Summary -> Summary
forall a. (Generic a, Monoid' (Rep a)) => a -> a -> a
mappenddefault

-- ----------------------------------------------------------------------------

-- | To run tests using this ingredient, use 'Tasty.defaultMainWithIngredients',
-- passing 'jsonRunner' as one possible ingredient.
--
-- This ingredient will run
-- tests if you pass the @--grading-json@ command line option. For example,
-- @--grading-json=report.json@ will run all the tests and generate @report.json@ as output.
jsonRunner :: Tasty.Ingredient
jsonRunner :: Ingredient
jsonRunner = [OptionDescription]
-> (OptionSet
    -> TestTree -> Maybe (StatusMap -> IO (Time -> IO Bool)))
-> Ingredient
Tasty.TestReporter [OptionDescription]
optionDescription OptionSet -> TestTree -> Maybe (StatusMap -> IO (Time -> IO Bool))
forall (m :: * -> *).
(Monad m, IsOption (m JsonPath)) =>
OptionSet -> TestTree -> m (StatusMap -> IO (Time -> IO Bool))
runner
 where
  optionDescription :: [OptionDescription]
optionDescription = [ Proxy (Maybe JsonPath) -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Tasty.Option (Proxy (Maybe JsonPath)
forall k (t :: k). Proxy t
Proxy :: Proxy (Maybe JsonPath)) ]
  runner :: OptionSet -> TestTree -> m (StatusMap -> IO (Time -> IO Bool))
runner options :: OptionSet
options testTree :: TestTree
testTree = do
    JsonPath path :: String
path <- OptionSet -> m JsonPath
forall v. IsOption v => OptionSet -> v
Tasty.lookupOption OptionSet
options

    (StatusMap -> IO (Time -> IO Bool))
-> m (StatusMap -> IO (Time -> IO Bool))
forall (m :: * -> *) a. Monad m => a -> m a
return ((StatusMap -> IO (Time -> IO Bool))
 -> m (StatusMap -> IO (Time -> IO Bool)))
-> (StatusMap -> IO (Time -> IO Bool))
-> m (StatusMap -> IO (Time -> IO Bool))
forall a b. (a -> b) -> a -> b
$ \statusMap :: StatusMap
statusMap ->
      let
        timeToNs :: Tasty.Time -> Integer
        timeToNs :: Time -> Integer
timeToNs time :: Time
time = Time -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round (Time -> Integer) -> Time -> Integer
forall a b. (a -> b) -> a -> b
$ Time
time Time -> Time -> Time
forall a. Num a => a -> a -> a
* 1e9

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

          Result
testResult <- IO Result -> StateT Int IO Result
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Result -> StateT Int IO Result)
-> IO Result -> StateT Int IO Result
forall a b. (a -> b) -> a -> b
$ STM Result -> IO Result
forall a. STM a -> IO a
STM.atomically (STM Result -> IO Result) -> STM Result -> IO Result
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 "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

            case Status
status of
              Tasty.Done result :: Result
result -> Result -> STM Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure Result
result
              -- Otherwise the test has either not been started or is currently
              -- executing
              _ -> STM Result
forall a. STM a
STM.retry

          let testCaseAttributes :: Time -> [a]
testCaseAttributes time :: Time
time =
                [ "name" Text -> String -> a
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= String
testName
                , "time" Text -> Integer -> a
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Time -> Integer
timeToNs Time
time
                ]

              mkSummary :: Aeson.Value -> Summary
              mkSummary :: Value -> Summary
mkSummary contents :: Value
contents =
                Summary
forall a. Monoid a => a
mempty { jsonRenderer :: Endo [Value]
jsonRenderer = ([Value] -> [Value]) -> Endo [Value]
forall a. (a -> a) -> Endo a
Endo
                            (Value
contents Value -> [Value] -> [Value]
forall a. a -> [a] -> [a]
:)
                        }

              mkSuccess :: Tasty.Time -> Summary
              mkSuccess :: Time -> Summary
mkSuccess time :: Time
time = (Value -> Summary
mkSummary ([Pair] -> Value
Aeson.object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ Time -> [Pair]
forall a. KeyValue a => Time -> [a]
testCaseAttributes Time
time)) { summarySuccesses :: Sum Int
summarySuccesses = Int -> Sum Int
forall a. a -> Sum a
Sum 1 }

              mkFailure :: Tasty.Time -> String -> Summary
              mkFailure :: Time -> String -> Summary
mkFailure time :: Time
time reason :: String
reason =
                Value -> Summary
mkSummary (Value -> Summary) -> Value -> Summary
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
Aeson.object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$
                        Time -> [Pair]
forall a. KeyValue a => Time -> [a]
testCaseAttributes Time
time [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<>
                        ["failure" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= String
reason ]

          Summary
summary <- case Result
testResult of
              -- If the test is done, generate XML for it
              result :: Result
result
                | Result -> Bool
Tasty.resultSuccessful Result
result -> Summary -> StateT Int IO Summary
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Time -> Summary
mkSuccess (Result -> Time
Tasty.resultTime Result
result))
                | Bool
otherwise ->
                    case Result -> Maybe SomeException
resultException Result
result of
                      Just e :: SomeException
e  -> Summary -> StateT Int IO Summary
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Summary -> StateT Int IO Summary)
-> Summary -> StateT Int IO Summary
forall a b. (a -> b) -> a -> b
$ (Time -> String -> 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 1 }
                      Nothing ->
                        if Result -> Bool
resultTimedOut Result
result
                          then Summary -> StateT Int IO Summary
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Summary -> StateT Int IO Summary)
-> Summary -> StateT Int IO Summary
forall a b. (a -> b) -> a -> b
$ (Time -> String -> Summary
mkFailure (Result -> Time
Tasty.resultTime Result
result) "Timeout") { summaryErrors :: Sum Int
summaryErrors = Int -> Sum Int
forall a. a -> Sum a
Sum 1 }
                          else do
                            String
desc <- IO String -> StateT Int IO String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> StateT Int IO String)
-> IO String -> StateT Int IO String
forall a b. (a -> b) -> a -> b
$ String -> IO String
Tasty.formatMessage (Result -> String
Tasty.resultDescription Result
result)
                            Summary -> StateT Int IO Summary
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Time -> String -> Summary
mkFailure (Result -> Time
Tasty.resultTime Result
result) String
desc)
                               { summaryFailures :: Sum Int
summaryFailures = Int -> Sum Int
forall a. a -> Sum a
Sum 1 }

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

        runGroup ::
          Tasty.OptionSet ->
          Tasty.TestName ->
          Tasty.Traversal (Functor.Compose (State.StateT IntMap.Key IO) (Const Summary)) ->
          Tasty.Traversal (Functor.Compose (State.StateT IntMap.Key IO) (Const Summary))
        runGroup :: OptionSet
-> String
-> Traversal (Compose (StateT Int IO) (Const Summary))
-> Traversal (Compose (StateT Int IO) (Const Summary))
runGroup opts :: OptionSet
opts groupName :: String
groupName children :: Traversal (Compose (StateT Int IO) (Const Summary))
children = Compose (StateT Int IO) (Const Summary) ()
-> Traversal (Compose (StateT Int IO) (Const Summary))
forall (f :: * -> *). f () -> Traversal f
Tasty.Traversal (Compose (StateT Int IO) (Const Summary) ()
 -> Traversal (Compose (StateT Int IO) (Const Summary)))
-> Compose (StateT Int IO) (Const Summary) ()
-> Traversal (Compose (StateT Int IO) (Const Summary))
forall a b. (a -> b) -> a -> b
$ StateT Int IO (Const Summary ())
-> Compose (StateT Int IO) (Const Summary) ()
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Functor.Compose (StateT Int IO (Const Summary ())
 -> Compose (StateT Int IO) (Const Summary) ())
-> StateT Int IO (Const Summary ())
-> Compose (StateT Int IO) (Const Summary) ()
forall a b. (a -> b) -> a -> b
$ do
          Const soFar :: Summary
soFar <- Compose (StateT Int IO) (Const Summary) ()
-> 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 (StateT Int IO) (Const Summary) ()
 -> StateT Int IO (Const Summary ()))
-> Compose (StateT Int IO) (Const Summary) ()
-> StateT Int IO (Const Summary ())
forall a b. (a -> b) -> a -> b
$ Traversal (Compose (StateT Int IO) (Const Summary))
-> Compose (StateT Int IO) (Const Summary) ()
forall (f :: * -> *). Traversal f -> f ()
Tasty.getTraversal Traversal (Compose (StateT Int IO) (Const Summary))
children
          let grouped :: Value
grouped =
                [Pair] -> Value
Aeson.object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$
                  [ "name" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= String
groupName
                  , "tests" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (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 -> Int) -> Summary -> Int
forall a b. (a -> b) -> a -> b
$ Summary
soFar)
                  , "groups" Text -> [Value] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Endo [Value] -> [Value] -> [Value]
forall a. Endo a -> a -> a
appEndo (Summary -> Endo [Value]
jsonRenderer Summary
soFar) []
                  ]
                  [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> case OptionSet -> Maybe TestGroupProps
forall v. IsOption v => OptionSet -> v
Tasty.lookupOption OptionSet
opts of
                      Nothing -> []
                      Just TestGroupProps {..} ->
                        [ "points" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Int
pointsPerSuccess
                        , "deductions" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Int
pointsPerFailure
                        , "maximum" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Int
maxPointPerGroup
                        ]


          Const Summary () -> StateT Int IO (Const Summary ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Const Summary () -> StateT Int IO (Const Summary ()))
-> Const Summary () -> StateT Int IO (Const Summary ())
forall a b. (a -> b) -> a -> b
$ Summary -> Const Summary ()
forall k a (b :: k). a -> Const a b
Const
            Summary
soFar { jsonRenderer :: Endo [Value]
jsonRenderer = ([Value] -> [Value]) -> Endo [Value]
forall a. (a -> a) -> Endo a
Endo (Value
grouped Value -> [Value] -> [Value]
forall a. a -> [a] -> [a]
:)
                  }

      in do
        (Const summary :: Summary
summary, tests :: 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 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
$ Compose (StateT Int IO) (Const Summary) ()
-> 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 (StateT Int IO) (Const Summary) ()
 -> StateT Int IO (Const Summary ()))
-> Compose (StateT Int IO) (Const Summary) ()
-> StateT Int IO (Const Summary ())
forall a b. (a -> b) -> a -> b
$ Traversal (Compose (StateT Int IO) (Const Summary))
-> Compose (StateT Int IO) (Const Summary) ()
forall (f :: * -> *). Traversal f -> f ()
Tasty.getTraversal (Traversal (Compose (StateT Int IO) (Const Summary))
 -> Compose (StateT Int IO) (Const Summary) ())
-> Traversal (Compose (StateT Int IO) (Const Summary))
-> Compose (StateT Int IO) (Const Summary) ()
forall a b. (a -> b) -> a -> b
$
           TreeFold (Traversal (Compose (StateT Int IO) (Const Summary)))
-> OptionSet
-> TestTree
-> Traversal (Compose (StateT Int IO) (Const Summary))
forall b. Monoid b => TreeFold b -> OptionSet -> TestTree -> b
Tasty.foldTestTree
             TreeFold (Traversal (Compose (StateT Int IO) (Const Summary)))
forall b. Monoid b => TreeFold b
Tasty.trivialFold { foldSingle :: forall t.
IsTest t =>
OptionSet
-> String
-> t
-> Traversal (Compose (StateT Int IO) (Const Summary))
Tasty.foldSingle = forall t.
IsTest t =>
OptionSet
-> String
-> t
-> Traversal (Compose (StateT Int IO) (Const Summary))
runTest, foldGroup :: OptionSet
-> String
-> Traversal (Compose (StateT Int IO) (Const Summary))
-> Traversal (Compose (StateT Int IO) (Const Summary))
Tasty.foldGroup = OptionSet
-> String
-> Traversal (Compose (StateT Int IO) (Const Summary))
-> Traversal (Compose (StateT Int IO) (Const Summary))
runGroup }
             OptionSet
options
             TestTree
testTree

        (Time -> IO Bool) -> IO (Time -> IO Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Time -> IO Bool) -> IO (Time -> IO Bool))
-> (Time -> IO Bool) -> IO (Time -> IO Bool)
forall a b. (a -> b) -> a -> b
$ \elapsedTime :: Time
elapsedTime -> do
          String -> IO ()
createPathDirIfMissing String
path
          String -> Value -> IO ()
forall a. ToJSON a => String -> a -> IO ()
Aeson.encodeFile String
path (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$
            [Pair] -> Value
Aeson.object
                [ "errors"Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (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 -> Int) -> Summary -> Int
forall a b. (a -> b) -> a -> b
$ Summary
summary)
                , "failures" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (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 -> Int) -> Summary -> Int
forall a b. (a -> b) -> a -> b
$ Summary
summary)
                , "tests" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Int
tests
                , "time" Text -> Integer -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Time -> Integer
timeToNs Time
elapsedTime
                , "results" Text -> [Value] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Endo [Value] -> [Value] -> [Value]
forall a. Endo a -> a -> a
appEndo (Summary -> Endo [Value]
jsonRenderer 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
== 0)

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

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

  createPathDirIfMissing :: String -> IO ()
createPathDirIfMissing path :: 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