-- |
-- Module:      Test.Tasty.Ingredients.Rerun
-- Copyright:   Oliver Charles (c) 2014, Andrew Lelechenko (c) 2019
-- Licence:     BSD3
--
-- This ingredient
-- for <https://hackage.haskell.org/package/tasty tasty> testing framework
-- allows to filter a test tree depending
-- on an outcome of the previous run.
-- This may be useful in many scenarios,
-- especially when a test suite grows large.
--
-- The behaviour is controlled by command-line options:
--
-- * @--rerun@ @ @
--
--     Rerun only tests, which failed during the last run.
--     If the last run was successful, execute a full test
--     suite afresh. A shortcut for @--rerun-update@
--     @--rerun-filter failures,exceptions@
--     @--rerun-all-on-success@.
--
-- * @--rerun-update@ @ @
--
--     Update the log file to reflect latest test outcomes.
--
-- * @--rerun-filter@ @CATEGORIES@
--
--     Read the log file and rerun only tests from a given
--     comma-separated list of categories: @failures@,
--     @exceptions@, @new@, @successful@. If this option is
--     omitted or the log file is missing, rerun everything.
--
-- * @--rerun-all-on-success@ @ @
--
--     If according to the log file and @--rerun-filter@ there
--     is nothing left to rerun, run all tests. This comes
--     especially handy in @stack test --file-watch@ or
--     @ghcid@ scenarios.
--
-- * @--rerun-log-file@ @FILE@
--
--     Location of the log file (default: @.tasty-rerun-log@).
--
-- To add it to your test suite just replace
-- 'Tasty.defaultMain' with
-- 'defaultMainWithRerun' or wrap arguments
-- of 'Tasty.defaultMainWithIngredients'
-- into 'rerunningTests'.

{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}

module Test.Tasty.Ingredients.Rerun
  ( defaultMainWithRerun
  , rerunningTests
  ) where

import Prelude (Enum, Bounded, minBound, maxBound, error, (+))

import Control.Applicative (Const(..), (<$>), pure, (<$))
import Control.Arrow ((>>>))
import Control.Monad (when, return, fmap, mapM, (>>=))
import Control.Monad.Trans.Class (lift)
import Data.Bool (Bool (..), otherwise, not, (&&))
import Data.Char (isSpace, toLower)
import Data.Eq (Eq)
import Data.Foldable (asum)
import Data.Function ((.), ($), flip, const)
import Data.Int (Int)
import Data.List (intercalate, lookup, map, (++), reverse, dropWhile)
import Data.List.Split (endBy)
import Data.Maybe (fromMaybe, Maybe(..), maybe)
import Data.Monoid (Any(..), Monoid(..))
import Data.Ord (Ord)
import Data.Proxy (Proxy(..))
import Data.String (String)
import Data.Typeable (Typeable)
import System.IO (FilePath, IO, readFile, writeFile)
import System.IO.Error (catchIOError, isDoesNotExistError, ioError)
import Text.Read (Read, read)
import Text.Show (Show, show)

import qualified Control.Concurrent.STM as STM
import qualified Control.Monad.State as State
import qualified Data.Functor.Compose as Functor
import qualified Data.IntMap as IntMap
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Options.Applicative as OptParse
import qualified Test.Tasty.Options as Tasty
import qualified Test.Tasty.Runners as Tasty

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

instance Tasty.IsOption RerunLogFile where
  optionName :: Tagged RerunLogFile TestName
optionName = forall (m :: * -> *) a. Monad m => a -> m a
return TestName
"rerun-log-file"
  optionHelp :: Tagged RerunLogFile TestName
optionHelp = forall (m :: * -> *) a. Monad m => a -> m a
return TestName
"Location of the log file (default: .tasty-rerun-log)"
  defaultValue :: RerunLogFile
defaultValue = TestName -> RerunLogFile
RerunLogFile TestName
".tasty-rerun-log"
  parseValue :: TestName -> Maybe RerunLogFile
parseValue = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> RerunLogFile
RerunLogFile
  optionCLParser :: Parser RerunLogFile
optionCLParser = forall v. IsOption v => Mod OptionFields v -> Parser v
Tasty.mkOptionCLParser (forall (f :: * -> *) a. HasMetavar f => TestName -> Mod f a
OptParse.metavar TestName
"FILE")

--------------------------------------------------------------------------------
newtype UpdateLog = UpdateLog Bool
  deriving (Typeable)

instance Tasty.IsOption UpdateLog where
  optionName :: Tagged UpdateLog TestName
optionName = forall (m :: * -> *) a. Monad m => a -> m a
return TestName
"rerun-update"
  optionHelp :: Tagged UpdateLog TestName
optionHelp = forall (m :: * -> *) a. Monad m => a -> m a
return TestName
"Update the log file to reflect latest test outcomes"
  defaultValue :: UpdateLog
defaultValue = Bool -> UpdateLog
UpdateLog Bool
False
  parseValue :: TestName -> Maybe UpdateLog
parseValue = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> UpdateLog
UpdateLog forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> Maybe Bool
Tasty.safeReadBool
  optionCLParser :: Parser UpdateLog
optionCLParser = forall v. IsOption v => Mod FlagFields v -> v -> Parser v
Tasty.mkFlagCLParser forall a. Monoid a => a
mempty (Bool -> UpdateLog
UpdateLog Bool
True)

--------------------------------------------------------------------------------
data Filter = Failures | Exceptions | New | Successful
  deriving (Filter -> Filter -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Filter -> Filter -> Bool
$c/= :: Filter -> Filter -> Bool
== :: Filter -> Filter -> Bool
$c== :: Filter -> Filter -> Bool
Eq, Eq Filter
Filter -> Filter -> Bool
Filter -> Filter -> Ordering
Filter -> Filter -> Filter
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 :: Filter -> Filter -> Filter
$cmin :: Filter -> Filter -> Filter
max :: Filter -> Filter -> Filter
$cmax :: Filter -> Filter -> Filter
>= :: Filter -> Filter -> Bool
$c>= :: Filter -> Filter -> Bool
> :: Filter -> Filter -> Bool
$c> :: Filter -> Filter -> Bool
<= :: Filter -> Filter -> Bool
$c<= :: Filter -> Filter -> Bool
< :: Filter -> Filter -> Bool
$c< :: Filter -> Filter -> Bool
compare :: Filter -> Filter -> Ordering
$ccompare :: Filter -> Filter -> Ordering
Ord, Int -> Filter
Filter -> Int
Filter -> [Filter]
Filter -> Filter
Filter -> Filter -> [Filter]
Filter -> Filter -> Filter -> [Filter]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Filter -> Filter -> Filter -> [Filter]
$cenumFromThenTo :: Filter -> Filter -> Filter -> [Filter]
enumFromTo :: Filter -> Filter -> [Filter]
$cenumFromTo :: Filter -> Filter -> [Filter]
enumFromThen :: Filter -> Filter -> [Filter]
$cenumFromThen :: Filter -> Filter -> [Filter]
enumFrom :: Filter -> [Filter]
$cenumFrom :: Filter -> [Filter]
fromEnum :: Filter -> Int
$cfromEnum :: Filter -> Int
toEnum :: Int -> Filter
$ctoEnum :: Int -> Filter
pred :: Filter -> Filter
$cpred :: Filter -> Filter
succ :: Filter -> Filter
$csucc :: Filter -> Filter
Enum, Filter
forall a. a -> a -> Bounded a
maxBound :: Filter
$cmaxBound :: Filter
minBound :: Filter
$cminBound :: Filter
Bounded, Int -> Filter -> ShowS
[Filter] -> ShowS
Filter -> TestName
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
showList :: [Filter] -> ShowS
$cshowList :: [Filter] -> ShowS
show :: Filter -> TestName
$cshow :: Filter -> TestName
showsPrec :: Int -> Filter -> ShowS
$cshowsPrec :: Int -> Filter -> ShowS
Show)

parseFilter :: String -> Maybe Filter
parseFilter :: TestName -> Maybe Filter
parseFilter TestName
s = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup TestName
s (forall a b. (a -> b) -> [a] -> [b]
map (\Filter
x -> (forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (forall a. Show a => a -> TestName
show Filter
x), Filter
x)) [Filter]
everything)

--------------------------------------------------------------------------------
everything :: [Filter]
everything :: [Filter]
everything = [forall a. Bounded a => a
minBound..forall a. Bounded a => a
maxBound]

--------------------------------------------------------------------------------
newtype FilterOption = FilterOption (Set.Set Filter)
  deriving (Typeable)

instance Tasty.IsOption FilterOption where
  optionName :: Tagged FilterOption TestName
optionName = forall (m :: * -> *) a. Monad m => a -> m a
return TestName
"rerun-filter"
  optionHelp :: Tagged FilterOption TestName
optionHelp = forall (m :: * -> *) a. Monad m => a -> m a
return
    forall a b. (a -> b) -> a -> b
$  TestName
"Read the log file and rerun only tests from a given comma-separated list of categories: "
    forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (forall a. [a] -> [[a]] -> [a]
intercalate TestName
", " (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> TestName
show [Filter]
everything))
    forall a. [a] -> [a] -> [a]
++ TestName
". If this option is omitted or the log file is missing, rerun everything."
  defaultValue :: FilterOption
defaultValue = Set Filter -> FilterOption
FilterOption (forall a. Ord a => [a] -> Set a
Set.fromList [Filter]
everything)
  parseValue :: TestName -> Maybe FilterOption
parseValue =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Set Filter -> FilterOption
FilterOption forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> Set a
Set.fromList) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TestName -> Maybe Filter
parseFilter forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
trim) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> [[a]]
endBy TestName
","
    where trim :: ShowS
trim = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace
  optionCLParser :: Parser FilterOption
optionCLParser = forall v. IsOption v => Mod OptionFields v -> Parser v
Tasty.mkOptionCLParser (forall (f :: * -> *) a. HasMetavar f => TestName -> Mod f a
OptParse.metavar TestName
"CATEGORIES")

--------------------------------------------------------------------------------
newtype AllOnSuccess = AllOnSuccess Bool
  deriving (Typeable)

instance Tasty.IsOption AllOnSuccess where
  optionName :: Tagged AllOnSuccess TestName
optionName = forall (m :: * -> *) a. Monad m => a -> m a
return TestName
"rerun-all-on-success"
  optionHelp :: Tagged AllOnSuccess TestName
optionHelp = forall (m :: * -> *) a. Monad m => a -> m a
return TestName
"If according to the log file and --rerun-filter there is nothing left to rerun, run all tests. This comes especially handy in `stack test --file-watch` or `ghcid` scenarios."
  defaultValue :: AllOnSuccess
defaultValue = Bool -> AllOnSuccess
AllOnSuccess Bool
False
  parseValue :: TestName -> Maybe AllOnSuccess
parseValue = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> AllOnSuccess
AllOnSuccess forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> Maybe Bool
Tasty.safeReadBool
  optionCLParser :: Parser AllOnSuccess
optionCLParser = forall v. IsOption v => Mod FlagFields v -> v -> Parser v
Tasty.mkFlagCLParser forall a. Monoid a => a
mempty (Bool -> AllOnSuccess
AllOnSuccess Bool
True)

--------------------------------------------------------------------------------
newtype Rerun = Rerun { Rerun -> Bool
unRerun :: Bool }
  deriving (Typeable)

instance Tasty.IsOption Rerun where
  optionName :: Tagged Rerun TestName
optionName = forall (m :: * -> *) a. Monad m => a -> m a
return TestName
"rerun"
  optionHelp :: Tagged Rerun TestName
optionHelp = forall (m :: * -> *) a. Monad m => a -> m a
return TestName
"Rerun only tests, which failed during the last run. If the last run was successful, execute a full test suite afresh. A shortcut for --rerun-update --rerun-filter failures,exceptions --rerun-all-on-success"
  defaultValue :: Rerun
defaultValue = Bool -> Rerun
Rerun Bool
False
  parseValue :: TestName -> Maybe Rerun
parseValue = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Rerun
Rerun forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> Maybe Bool
Tasty.safeReadBool
  optionCLParser :: Parser Rerun
optionCLParser = forall v. IsOption v => Mod FlagFields v -> v -> Parser v
Tasty.mkFlagCLParser forall a. Monoid a => a
mempty (Bool -> Rerun
Rerun Bool
True)

rerunMeaning :: (UpdateLog, AllOnSuccess, FilterOption)
rerunMeaning :: (UpdateLog, AllOnSuccess, FilterOption)
rerunMeaning = (Bool -> UpdateLog
UpdateLog Bool
True, Bool -> AllOnSuccess
AllOnSuccess Bool
True, Set Filter -> FilterOption
FilterOption (forall a. Ord a => [a] -> Set a
Set.fromList [Filter
Failures, Filter
Exceptions]))

--------------------------------------------------------------------------------
data TestResult = Completed Bool | ThrewException
  deriving (ReadPrec [TestResult]
ReadPrec TestResult
Int -> ReadS TestResult
ReadS [TestResult]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [TestResult]
$creadListPrec :: ReadPrec [TestResult]
readPrec :: ReadPrec TestResult
$creadPrec :: ReadPrec TestResult
readList :: ReadS [TestResult]
$creadList :: ReadS [TestResult]
readsPrec :: Int -> ReadS TestResult
$creadsPrec :: Int -> ReadS TestResult
Read, Int -> TestResult -> ShowS
[TestResult] -> ShowS
TestResult -> TestName
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
showList :: [TestResult] -> ShowS
$cshowList :: [TestResult] -> ShowS
show :: TestResult -> TestName
$cshow :: TestResult -> TestName
showsPrec :: Int -> TestResult -> ShowS
$cshowsPrec :: Int -> TestResult -> ShowS
Show)


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

-- | Drop-in replacement for 'Tasty.defaultMain'.
--
-- > import Test.Tasty
-- > import Test.Tasty.Ingredients.Rerun
-- >
-- > main :: IO ()
-- > main = defaultMainWithRerun tests
-- >
-- > tests :: TestTree
-- > tests = undefined
defaultMainWithRerun :: Tasty.TestTree -> IO ()
defaultMainWithRerun :: TestTree -> IO ()
defaultMainWithRerun =
  [Ingredient] -> TestTree -> IO ()
Tasty.defaultMainWithIngredients
    [ [Ingredient] -> Ingredient
rerunningTests [ Ingredient
Tasty.listingTests, Ingredient
Tasty.consoleTestReporter ] ]

-- | Ingredient transformer, to use with
-- 'Tasty.defaultMainWithIngredients'.
--
-- > import Test.Tasty
-- > import Test.Tasty.Runners
-- > import Test.Tasty.Ingredients.Rerun
-- >
-- > main :: IO ()
-- > main =
-- >   defaultMainWithIngredients
-- >     [ rerunningTests [ listingTests, consoleTestReporter ] ]
-- >     tests
-- >
-- > tests :: TestTree
-- > tests = undefined
rerunningTests :: [Tasty.Ingredient] -> Tasty.Ingredient
rerunningTests :: [Ingredient] -> Ingredient
rerunningTests [Ingredient]
ingredients =
  [OptionDescription]
-> (OptionSet -> TestTree -> Maybe (IO Bool)) -> Ingredient
Tasty.TestManager ([OptionDescription]
rerunOptions forall a. [a] -> [a] -> [a]
++ [Ingredient] -> [OptionDescription]
Tasty.ingredientsOptions [Ingredient]
ingredients) forall a b. (a -> b) -> a -> b
$
    \OptionSet
options TestTree
testTree -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ do
      let RerunLogFile TestName
stateFile = forall v. IsOption v => OptionSet -> v
Tasty.lookupOption OptionSet
options
          (UpdateLog Bool
updateLog, AllOnSuccess Bool
allOnSuccess, FilterOption Set Filter
filter)
            | Rerun -> Bool
unRerun (forall v. IsOption v => OptionSet -> v
Tasty.lookupOption OptionSet
options) = (UpdateLog, AllOnSuccess, FilterOption)
rerunMeaning
            | Bool
otherwise = (forall v. IsOption v => OptionSet -> v
Tasty.lookupOption OptionSet
options, forall v. IsOption v => OptionSet -> v
Tasty.lookupOption OptionSet
options, forall v. IsOption v => OptionSet -> v
Tasty.lookupOption OptionSet
options)

      let nonEmptyFold :: TreeFold Any
nonEmptyFold = forall b. Monoid b => TreeFold b
Tasty.trivialFold { foldSingle :: forall t. IsTest t => OptionSet -> TestName -> t -> Any
Tasty.foldSingle = \OptionSet
_ TestName
_ t
_ -> Bool -> Any
Any Bool
True }
          nullTestTree :: TestTree -> Bool
nullTestTree = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Any -> Bool
getAny forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. Monoid b => TreeFold b -> OptionSet -> TestTree -> b
Tasty.foldTestTree TreeFold Any
nonEmptyFold OptionSet
options
          recoverFromEmpty :: TestTree -> TestTree
recoverFromEmpty TestTree
t = if Bool
allOnSuccess Bool -> Bool -> Bool
&& TestTree -> Bool
nullTestTree TestTree
t then TestTree
testTree else TestTree
t

      TestTree
filteredTestTree <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe TestTree
testTree (TestTree -> TestTree
recoverFromEmpty forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestTree -> Set Filter -> Map [TestName] TestResult -> TestTree
filterTestTree TestTree
testTree Set Filter
filter)
                           forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TestName -> IO (Maybe (Map [TestName] TestResult))
tryLoadStateFrom TestName
stateFile

      let tryAndRun :: Ingredient -> Maybe (IO Bool)
tryAndRun (Tasty.TestReporter [OptionDescription]
_ OptionSet -> TestTree -> Maybe (StatusMap -> IO (Time -> IO Bool))
f) = do
            StatusMap -> IO (Time -> IO Bool)
runner <- OptionSet -> TestTree -> Maybe (StatusMap -> IO (Time -> IO Bool))
f OptionSet
options TestTree
filteredTestTree
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
              (StatusMap
statusMap, Bool
outcome) <-
                forall a.
OptionSet -> TestTree -> (StatusMap -> IO (Time -> IO a)) -> IO a
Tasty.launchTestTree OptionSet
options TestTree
filteredTestTree forall a b. (a -> b) -> a -> b
$ \StatusMap
sMap ->
                  do Time -> IO Bool
f' <- StatusMap -> IO (Time -> IO Bool)
runner StatusMap
sMap
                     forall (m :: * -> *) a. Monad m => a -> m a
return (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Bool
a -> (StatusMap
sMap, Bool
a)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Time -> IO Bool
f')

              let getTestResults :: IO (Map [TestName] TestResult)
getTestResults =
                    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {k} a (b :: k). Const a b -> a
getConst forall a b. (a -> b) -> a -> b
$
                    forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
State.evalStateT 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 (StatusMap
-> TreeFold
     (Traversal
        (Compose (StateT Int IO) (Const (Map [TestName] TestResult))))
observeResults StatusMap
statusMap)
                                        OptionSet
options TestTree
filteredTestTree

              forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
updateLog (TestName -> IO (Map [TestName] TestResult) -> IO ()
saveStateTo TestName
stateFile IO (Map [TestName] TestResult)
getTestResults)
              forall (m :: * -> *) a. Monad m => a -> m a
return Bool
outcome

          tryAndRun (Tasty.TestManager [OptionDescription]
_ OptionSet -> TestTree -> Maybe (IO Bool)
f) =
            OptionSet -> TestTree -> Maybe (IO Bool)
f OptionSet
options TestTree
filteredTestTree

      case forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum (forall a b. (a -> b) -> [a] -> [b]
map Ingredient -> Maybe (IO Bool)
tryAndRun [Ingredient]
ingredients) of
        -- No Ingredients chose to run the tests, we should really return
        -- Nothing, but we've already committed to run by the act of
        -- filtering the TestTree.
        Maybe (IO Bool)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        -- Otherwise, an Ingredient did choose to run the tests, so we
        -- simply run the above constructed IO action.
        Just IO Bool
e -> IO Bool
e
  where
  rerunOptions :: [OptionDescription]
rerunOptions = [ forall v. IsOption v => Proxy v -> OptionDescription
Tasty.Option (forall {k} (t :: k). Proxy t
Proxy :: Proxy Rerun)
                 , forall v. IsOption v => Proxy v -> OptionDescription
Tasty.Option (forall {k} (t :: k). Proxy t
Proxy :: Proxy UpdateLog)
                 , forall v. IsOption v => Proxy v -> OptionDescription
Tasty.Option (forall {k} (t :: k). Proxy t
Proxy :: Proxy FilterOption)
                 , forall v. IsOption v => Proxy v -> OptionDescription
Tasty.Option (forall {k} (t :: k). Proxy t
Proxy :: Proxy AllOnSuccess)
                 , forall v. IsOption v => Proxy v -> OptionDescription
Tasty.Option (forall {k} (t :: k). Proxy t
Proxy :: Proxy RerunLogFile)
                 ]

  ------------------------------------------------------------------------------
  filterTestTree :: Tasty.TestTree -> Set.Set Filter -> Map.Map [String] TestResult -> Tasty.TestTree
  filterTestTree :: TestTree -> Set Filter -> Map [TestName] TestResult -> TestTree
filterTestTree TestTree
testTree Set Filter
filter Map [TestName] TestResult
lastRecord =
    let go :: [TestName] -> TestTree -> TestTree
go [TestName]
prefix (Tasty.SingleTest TestName
name t
t) =
          let requiredFilter :: Filter
requiredFilter = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ([TestName]
prefix forall a. [a] -> [a] -> [a]
++ [TestName
name]) Map [TestName] TestResult
lastRecord of
                Just (Completed Bool
False) -> Filter
Failures
                Just TestResult
ThrewException -> Filter
Exceptions
                Just (Completed Bool
True) -> Filter
Successful
                Maybe TestResult
Nothing -> Filter
New
          in if (Filter
requiredFilter forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Filter
filter)
               then forall t. IsTest t => TestName -> t -> TestTree
Tasty.SingleTest TestName
name t
t
               else TestName -> [TestTree] -> TestTree
Tasty.TestGroup TestName
"" []

        go [TestName]
prefix (Tasty.TestGroup TestName
name [TestTree]
tests) =
          TestName -> [TestTree] -> TestTree
Tasty.TestGroup TestName
name ([TestName] -> TestTree -> TestTree
go ([TestName]
prefix forall a. [a] -> [a] -> [a]
++ [TestName
name]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TestTree]
tests)

        go [TestName]
prefix (Tasty.PlusTestOptions OptionSet -> OptionSet
f TestTree
t) =
          (OptionSet -> OptionSet) -> TestTree -> TestTree
Tasty.PlusTestOptions OptionSet -> OptionSet
f ([TestName] -> TestTree -> TestTree
go [TestName]
prefix TestTree
t)

        go [TestName]
prefix (Tasty.WithResource ResourceSpec a
rSpec IO a -> TestTree
k) =
          forall a. ResourceSpec a -> (IO a -> TestTree) -> TestTree
Tasty.WithResource ResourceSpec a
rSpec ([TestName] -> TestTree -> TestTree
go [TestName]
prefix forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a -> TestTree
k)

        go [TestName]
prefix (Tasty.AskOptions OptionSet -> TestTree
k) =
          (OptionSet -> TestTree) -> TestTree
Tasty.AskOptions ([TestName] -> TestTree -> TestTree
go [TestName]
prefix forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OptionSet -> TestTree
k)

        go [TestName]
prefix (Tasty.After DependencyType
a Expr
b TestTree
c) =
          DependencyType -> Expr -> TestTree -> TestTree
Tasty.After DependencyType
a Expr
b ([TestName] -> TestTree -> TestTree
go [TestName]
prefix TestTree
c)

    in [TestName] -> TestTree -> TestTree
go [] TestTree
testTree

  tryLoadStateFrom :: FilePath -> IO (Maybe (Map.Map [String] TestResult))
  tryLoadStateFrom :: TestName -> IO (Maybe (Map [TestName] TestResult))
tryLoadStateFrom TestName
filePath = do
    Maybe TestName
fileContents <- (forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TestName -> IO TestName
readFile TestName
filePath)
                      forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` (\IOError
e -> if IOError -> Bool
isDoesNotExistError IOError
e
                                              then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                                              else forall a. IOError -> IO a
ioError IOError
e)
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Read a => TestName -> a
read forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe TestName
fileContents)

  ------------------------------------------------------------------------------
  saveStateTo :: FilePath -> IO (Map.Map [String] TestResult) -> IO ()
  saveStateTo :: TestName -> IO (Map [TestName] TestResult) -> IO ()
saveStateTo TestName
filePath IO (Map [TestName] TestResult)
getTestResults =
    IO (Map [TestName] TestResult)
getTestResults forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall a. Show a => a -> TestName
show forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> TestName -> TestName -> IO ()
writeFile TestName
filePath)

  ------------------------------------------------------------------------------
  observeResults
    :: IntMap.IntMap (STM.TVar Tasty.Status)
    -> Tasty.TreeFold (Tasty.Traversal (Functor.Compose (State.StateT Int IO) (Const (Map.Map [String] TestResult))))
  observeResults :: StatusMap
-> TreeFold
     (Traversal
        (Compose (StateT Int IO) (Const (Map [TestName] TestResult))))
observeResults StatusMap
statusMap =
    let foldSingle :: p
-> a
-> p
-> Traversal (Compose (t IO) (Const (Map [a] TestResult)))
foldSingle p
_ a
name p
_ = 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

          TestResult
status <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift 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 <- Int -> STM Status
lookupStatus Int
i
            case Status
status of
              Tasty.Done Result
result -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
                case Result -> Outcome
Tasty.resultOutcome Result
result of
                  Tasty.Failure (Tasty.TestThrewException SomeException
_) -> TestResult
ThrewException
                  Outcome
_ -> Bool -> TestResult
Completed (Result -> Bool
Tasty.resultSuccessful Result
result)

              Status
_ -> forall a. STM a
STM.retry

          forall {k} a (b :: k). a -> Const a b
Const (forall k a. k -> a -> Map k a
Map.singleton [a
name] TestResult
status) 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)

        foldGroup :: a
-> Traversal (Compose f (Const (Map [a] a)))
-> Traversal (Compose f (Const (Map [a] a)))
foldGroup a
name Traversal (Compose f (Const (Map [a] a)))
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 Map [a] a
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 f (Const (Map [a] a)))
children
          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 (forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys (a
name forall a. a -> [a] -> [a]
:) Map [a] a
soFar)

    in forall b. Monoid b => TreeFold b
Tasty.trivialFold
      { foldSingle :: forall t.
IsTest t =>
OptionSet
-> TestName
-> t
-> Traversal
     (Compose (StateT Int IO) (Const (Map [TestName] TestResult)))
Tasty.foldSingle = forall {t :: (* -> *) -> * -> *} {p} {a} {p}.
(MonadState Int (t IO), MonadTrans t) =>
p
-> a
-> p
-> Traversal (Compose (t IO) (Const (Map [a] TestResult)))
foldSingle
#if MIN_VERSION_tasty(1,5,0)
      , foldGroup :: OptionSet
-> TestName
-> [Traversal
      (Compose (StateT Int IO) (Const (Map [TestName] TestResult)))]
-> Traversal
     (Compose (StateT Int IO) (Const (Map [TestName] TestResult)))
Tasty.foldGroup = forall a b. a -> b -> a
const (\TestName
name -> forall {f :: * -> *} {a} {a}.
(Monad f, Ord a) =>
a
-> Traversal (Compose f (Const (Map [a] a)))
-> Traversal (Compose f (Const (Map [a] a)))
foldGroup TestName
name forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat)
#elif MIN_VERSION_tasty(1,4,0)
      , Tasty.foldGroup = const foldGroup
#else
      , Tasty.foldGroup = foldGroup
#endif
      }

    where
    lookupStatus :: Int -> STM Status
lookupStatus Int
i = 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 => TestName -> a
error TestName
"Attempted to lookup test by index outside bounds")
                (forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
i StatusMap
statusMap)