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

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

-- | 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 Int
plus Int
minus Int
upperBound TestTree
tree = (OptionSet -> OptionSet) -> TestTree -> TestTree
Tasty.PlusTestOptions (forall a. a -> Maybe a
Just TestGroupProps
points 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 = forall a. Maybe a
Nothing
  parseValue :: String -> Maybe (Maybe JsonPath)
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 -> JsonPath
JsonPath
  optionName :: Tagged (Maybe JsonPath) String
optionName = forall {k} (s :: k) b. b -> Tagged s b
Tagged String
"grading-json"
  optionHelp :: Tagged (Maybe JsonPath) String
optionHelp = forall {k} (s :: k) b. b -> Tagged s b
Tagged String
"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. 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

instance Semigroup Summary where
  <> :: 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 forall {m :: * -> *}.
(Monad m, IsOption (m JsonPath)) =>
OptionSet -> TestTree -> m (StatusMap -> IO (Time -> 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 JsonPath)) ]
  runner :: OptionSet -> TestTree -> m (StatusMap -> IO (Time -> IO Bool))
runner OptionSet
options TestTree
testTree = do
    JsonPath 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
        timeToNs :: Tasty.Time -> Integer
        timeToNs :: Time -> Integer
timeToNs Time
time = forall a b. (RealFrac a, Integral b) => a -> b
round forall a b. (a -> b) -> a -> b
$ Time
time forall a. Num a => a -> a -> a
* Time
1e9

        runTest :: (Tasty.IsTest t)
                => Tasty.OptionSet
                -> Tasty.TestName
                -> t
                -> Tasty.Traversal (Functor.Compose (State.StateT IntMap.Key IO) (Const Summary))
        runTest :: forall t.
IsTest t =>
OptionSet
-> String
-> t
-> Traversal (Compose (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

          Result
testResult <- 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

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

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

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

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

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

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

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


          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 { jsonRenderer :: Endo [Value]
jsonRenderer = forall a. (a -> a) -> Endo a
Endo (Value
grouped forall a. a -> [a] -> [a]
:)
                  }

      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 {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 (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
opts String
name [Traversal (Compose (StateT Int IO) (Const Summary))]
tests -> OptionSet
-> String
-> Traversal (Compose (StateT Int IO) (Const Summary))
-> Traversal (Compose (StateT Int IO) (Const Summary))
runGroup OptionSet
opts String
name forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [Traversal (Compose (StateT Int IO) (Const Summary))]
tests}
             OptionSet
options
             TestTree
testTree

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