-- |
-- 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'.

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 System.FilePath ((<.>), takeBaseName)
import System.IO (FilePath, IO, readFile', writeFile)
import System.IO.Error (catchIOError, isDoesNotExistError, ioError)
import System.IO.Unsafe (unsafePerformIO)
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 System.Environment
import qualified Test.Tasty.Options as Tasty
import qualified Test.Tasty.Runners as Tasty

--------------------------------------------------------------------------------
data RerunLogFile
  = DefaultRerunLogFile
  | CustomRerunLogFile FilePath

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

--------------------------------------------------------------------------------
newtype UpdateLog = UpdateLog Bool

instance Tasty.IsOption UpdateLog where
  optionName :: Tagged UpdateLog TestName
optionName = TestName -> Tagged UpdateLog TestName
forall a. a -> Tagged UpdateLog a
forall (m :: * -> *) a. Monad m => a -> m a
return TestName
"rerun-update"
  optionHelp :: Tagged UpdateLog TestName
optionHelp = TestName -> Tagged UpdateLog TestName
forall a. a -> Tagged UpdateLog a
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 = (Bool -> UpdateLog) -> Maybe Bool -> Maybe UpdateLog
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> UpdateLog
UpdateLog (Maybe Bool -> Maybe UpdateLog)
-> (TestName -> Maybe Bool) -> TestName -> Maybe UpdateLog
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> Maybe Bool
Tasty.safeReadBool
  optionCLParser :: Parser UpdateLog
optionCLParser = Mod FlagFields UpdateLog -> UpdateLog -> Parser UpdateLog
forall v. IsOption v => Mod FlagFields v -> v -> Parser v
Tasty.mkFlagCLParser Mod FlagFields UpdateLog
forall a. Monoid a => a
mempty (Bool -> UpdateLog
UpdateLog Bool
True)

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

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

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

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

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

--------------------------------------------------------------------------------
newtype AllOnSuccess = AllOnSuccess Bool

instance Tasty.IsOption AllOnSuccess where
  optionName :: Tagged AllOnSuccess TestName
optionName = TestName -> Tagged AllOnSuccess TestName
forall a. a -> Tagged AllOnSuccess a
forall (m :: * -> *) a. Monad m => a -> m a
return TestName
"rerun-all-on-success"
  optionHelp :: Tagged AllOnSuccess TestName
optionHelp = TestName -> Tagged AllOnSuccess TestName
forall a. a -> Tagged AllOnSuccess a
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 = (Bool -> AllOnSuccess) -> Maybe Bool -> Maybe AllOnSuccess
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> AllOnSuccess
AllOnSuccess (Maybe Bool -> Maybe AllOnSuccess)
-> (TestName -> Maybe Bool) -> TestName -> Maybe AllOnSuccess
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> Maybe Bool
Tasty.safeReadBool
  optionCLParser :: Parser AllOnSuccess
optionCLParser = Mod FlagFields AllOnSuccess -> AllOnSuccess -> Parser AllOnSuccess
forall v. IsOption v => Mod FlagFields v -> v -> Parser v
Tasty.mkFlagCLParser Mod FlagFields AllOnSuccess
forall a. Monoid a => a
mempty (Bool -> AllOnSuccess
AllOnSuccess Bool
True)

--------------------------------------------------------------------------------
newtype Rerun = Rerun { Rerun -> Bool
unRerun :: Bool }

instance Tasty.IsOption Rerun where
  optionName :: Tagged Rerun TestName
optionName = TestName -> Tagged Rerun TestName
forall a. a -> Tagged Rerun a
forall (m :: * -> *) a. Monad m => a -> m a
return TestName
"rerun"
  optionHelp :: Tagged Rerun TestName
optionHelp = TestName -> Tagged Rerun TestName
forall a. a -> Tagged Rerun a
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 = (Bool -> Rerun) -> Maybe Bool -> Maybe Rerun
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Rerun
Rerun (Maybe Bool -> Maybe Rerun)
-> (TestName -> Maybe Bool) -> TestName -> Maybe Rerun
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> Maybe Bool
Tasty.safeReadBool
  optionCLParser :: Parser Rerun
optionCLParser = Mod FlagFields Rerun -> Rerun -> Parser Rerun
forall v. IsOption v => Mod FlagFields v -> v -> Parser v
Tasty.mkFlagCLParser Mod FlagFields Rerun
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 ([Filter] -> Set Filter
forall a. Ord a => [a] -> Set a
Set.fromList [Filter
Failures, Filter
Exceptions]))

--------------------------------------------------------------------------------
data TestResult = Completed Bool | ThrewException
  deriving (ReadPrec [TestResult]
ReadPrec TestResult
Key -> ReadS TestResult
ReadS [TestResult]
(Key -> ReadS TestResult)
-> ReadS [TestResult]
-> ReadPrec TestResult
-> ReadPrec [TestResult]
-> Read TestResult
forall a.
(Key -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Key -> ReadS TestResult
readsPrec :: Key -> ReadS TestResult
$creadList :: ReadS [TestResult]
readList :: ReadS [TestResult]
$creadPrec :: ReadPrec TestResult
readPrec :: ReadPrec TestResult
$creadListPrec :: ReadPrec [TestResult]
readListPrec :: ReadPrec [TestResult]
Read, Key -> TestResult -> TestName -> TestName
[TestResult] -> TestName -> TestName
TestResult -> TestName
(Key -> TestResult -> TestName -> TestName)
-> (TestResult -> TestName)
-> ([TestResult] -> TestName -> TestName)
-> Show TestResult
forall a.
(Key -> a -> TestName -> TestName)
-> (a -> TestName) -> ([a] -> TestName -> TestName) -> Show a
$cshowsPrec :: Key -> TestResult -> TestName -> TestName
showsPrec :: Key -> TestResult -> TestName -> TestName
$cshow :: TestResult -> TestName
show :: TestResult -> TestName
$cshowList :: [TestResult] -> TestName -> TestName
showList :: [TestResult] -> TestName -> TestName
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 [OptionDescription] -> [OptionDescription] -> [OptionDescription]
forall a. [a] -> [a] -> [a]
++ [Ingredient] -> [OptionDescription]
Tasty.ingredientsOptions [Ingredient]
ingredients) ((OptionSet -> TestTree -> Maybe (IO Bool)) -> Ingredient)
-> (OptionSet -> TestTree -> Maybe (IO Bool)) -> Ingredient
forall a b. (a -> b) -> a -> b
$
    \OptionSet
options TestTree
testTree -> IO Bool -> Maybe (IO Bool)
forall a. a -> Maybe a
Just (IO Bool -> Maybe (IO Bool)) -> IO Bool -> Maybe (IO Bool)
forall a b. (a -> b) -> a -> b
$ do
      TestName
stateFile <- case OptionSet -> RerunLogFile
forall v. IsOption v => OptionSet -> v
Tasty.lookupOption OptionSet
options of
        RerunLogFile
DefaultRerunLogFile -> IO TestName
getDefaultLogfileName
        CustomRerunLogFile TestName
stateFile -> TestName -> IO TestName
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return TestName
stateFile

      let (UpdateLog Bool
updateLog, AllOnSuccess Bool
allOnSuccess, FilterOption Set Filter
filter)
            | Rerun -> Bool
unRerun (OptionSet -> Rerun
forall v. IsOption v => OptionSet -> v
Tasty.lookupOption OptionSet
options) = (UpdateLog, AllOnSuccess, FilterOption)
rerunMeaning
            | Bool
otherwise = (OptionSet -> UpdateLog
forall v. IsOption v => OptionSet -> v
Tasty.lookupOption OptionSet
options, OptionSet -> AllOnSuccess
forall v. IsOption v => OptionSet -> v
Tasty.lookupOption OptionSet
options, OptionSet -> FilterOption
forall v. IsOption v => OptionSet -> v
Tasty.lookupOption OptionSet
options)

      let nonEmptyFold :: TreeFold Any
nonEmptyFold = TreeFold Any
forall b. Monoid b => TreeFold b
Tasty.trivialFold { Tasty.foldSingle = \OptionSet
_ TestName
_ t
_ -> Bool -> Any
Any Bool
True }
          nullTestTree :: TestTree -> Bool
nullTestTree = Bool -> Bool
not (Bool -> Bool) -> (TestTree -> Bool) -> TestTree -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Any -> Bool
getAny (Any -> Bool) -> (TestTree -> Any) -> TestTree -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TreeFold Any -> OptionSet -> TestTree -> Any
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 <- TestTree
-> (Map [TestName] TestResult -> TestTree)
-> Maybe (Map [TestName] TestResult)
-> TestTree
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TestTree
testTree (TestTree -> TestTree
recoverFromEmpty (TestTree -> TestTree)
-> (Map [TestName] TestResult -> TestTree)
-> Map [TestName] TestResult
-> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestTree -> Set Filter -> Map [TestName] TestResult -> TestTree
filterTestTree TestTree
testTree Set Filter
filter)
                           (Maybe (Map [TestName] TestResult) -> TestTree)
-> IO (Maybe (Map [TestName] TestResult)) -> IO TestTree
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
            IO Bool -> Maybe (IO Bool)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO Bool -> Maybe (IO Bool)) -> IO Bool -> Maybe (IO Bool)
forall a b. (a -> b) -> a -> b
$ do
              (StatusMap
statusMap, Bool
outcome) <-
                OptionSet
-> TestTree
-> (StatusMap -> IO (Time -> IO (StatusMap, Bool)))
-> IO (StatusMap, Bool)
forall a.
OptionSet -> TestTree -> (StatusMap -> IO (Time -> IO a)) -> IO a
Tasty.launchTestTree OptionSet
options TestTree
filteredTestTree ((StatusMap -> IO (Time -> IO (StatusMap, Bool)))
 -> IO (StatusMap, Bool))
-> (StatusMap -> IO (Time -> IO (StatusMap, Bool)))
-> IO (StatusMap, Bool)
forall a b. (a -> b) -> a -> b
$ \StatusMap
sMap ->
                  do Time -> IO Bool
f' <- StatusMap -> IO (Time -> IO Bool)
runner StatusMap
sMap
                     (Time -> IO (StatusMap, Bool)) -> IO (Time -> IO (StatusMap, Bool))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bool -> (StatusMap, Bool)) -> IO Bool -> IO (StatusMap, Bool)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Bool
a -> (StatusMap
sMap, Bool
a)) (IO Bool -> IO (StatusMap, Bool))
-> (Time -> IO Bool) -> Time -> IO (StatusMap, Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Time -> IO Bool
f')

              let getTestResults :: IO (Map [TestName] TestResult)
getTestResults =
                    (Const (Map [TestName] TestResult) () -> Map [TestName] TestResult)
-> IO (Const (Map [TestName] TestResult) ())
-> IO (Map [TestName] TestResult)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Const (Map [TestName] TestResult) () -> Map [TestName] TestResult
forall {k} a (b :: k). Const a b -> a
getConst (IO (Const (Map [TestName] TestResult) ())
 -> IO (Map [TestName] TestResult))
-> IO (Const (Map [TestName] TestResult) ())
-> IO (Map [TestName] TestResult)
forall a b. (a -> b) -> a -> b
$
                    (StateT Key IO (Const (Map [TestName] TestResult) ())
 -> Key -> IO (Const (Map [TestName] TestResult) ()))
-> Key
-> StateT Key IO (Const (Map [TestName] TestResult) ())
-> IO (Const (Map [TestName] TestResult) ())
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT Key IO (Const (Map [TestName] TestResult) ())
-> Key -> IO (Const (Map [TestName] TestResult) ())
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
State.evalStateT Key
0 (StateT Key IO (Const (Map [TestName] TestResult) ())
 -> IO (Const (Map [TestName] TestResult) ()))
-> StateT Key IO (Const (Map [TestName] TestResult) ())
-> IO (Const (Map [TestName] TestResult) ())
forall a b. (a -> b) -> a -> b
$
                    Compose (StateT Key IO) (Const (Map [TestName] TestResult)) ()
-> StateT Key IO (Const (Map [TestName] TestResult) ())
forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
Functor.getCompose (Compose (StateT Key IO) (Const (Map [TestName] TestResult)) ()
 -> StateT Key IO (Const (Map [TestName] TestResult) ()))
-> Compose (StateT Key IO) (Const (Map [TestName] TestResult)) ()
-> StateT Key IO (Const (Map [TestName] TestResult) ())
forall a b. (a -> b) -> a -> b
$
                    Traversal
  (Compose (StateT Key IO) (Const (Map [TestName] TestResult)))
-> Compose (StateT Key IO) (Const (Map [TestName] TestResult)) ()
forall (f :: * -> *). Traversal f -> f ()
Tasty.getTraversal (Traversal
   (Compose (StateT Key IO) (Const (Map [TestName] TestResult)))
 -> Compose (StateT Key IO) (Const (Map [TestName] TestResult)) ())
-> Traversal
     (Compose (StateT Key IO) (Const (Map [TestName] TestResult)))
-> Compose (StateT Key IO) (Const (Map [TestName] TestResult)) ()
forall a b. (a -> b) -> a -> b
$
                    TreeFold
  (Traversal
     (Compose (StateT Key IO) (Const (Map [TestName] TestResult))))
-> OptionSet
-> TestTree
-> Traversal
     (Compose (StateT Key IO) (Const (Map [TestName] TestResult)))
forall b. Monoid b => TreeFold b -> OptionSet -> TestTree -> b
Tasty.foldTestTree (StatusMap
-> TreeFold
     (Traversal
        (Compose (StateT Key IO) (Const (Map [TestName] TestResult))))
observeResults StatusMap
statusMap)
                                        OptionSet
options TestTree
filteredTestTree

              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
updateLog (TestName -> IO (Map [TestName] TestResult) -> IO ()
saveStateTo TestName
stateFile IO (Map [TestName] TestResult)
getTestResults)
              Bool -> IO Bool
forall a. a -> IO a
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 [Maybe (IO Bool)] -> Maybe (IO Bool)
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum ((Ingredient -> Maybe (IO Bool))
-> [Ingredient] -> [Maybe (IO Bool)]
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 -> Bool -> IO Bool
forall a. a -> IO a
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 = [ Proxy Rerun -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Tasty.Option (Proxy Rerun
forall {k} (t :: k). Proxy t
Proxy :: Proxy Rerun)
                 , Proxy UpdateLog -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Tasty.Option (Proxy UpdateLog
forall {k} (t :: k). Proxy t
Proxy :: Proxy UpdateLog)
                 , Proxy FilterOption -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Tasty.Option (Proxy FilterOption
forall {k} (t :: k). Proxy t
Proxy :: Proxy FilterOption)
                 , Proxy AllOnSuccess -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Tasty.Option (Proxy AllOnSuccess
forall {k} (t :: k). Proxy t
Proxy :: Proxy AllOnSuccess)
                 , Proxy RerunLogFile -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Tasty.Option (Proxy RerunLogFile
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 [TestName] -> Map [TestName] TestResult -> Maybe TestResult
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ([TestName]
prefix [TestName] -> [TestName] -> [TestName]
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 Filter -> Set Filter -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Filter
filter)
               then TestName -> t -> TestTree
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 [TestName] -> [TestName] -> [TestName]
forall a. [a] -> [a] -> [a]
++ [TestName
name]) (TestTree -> TestTree) -> [TestTree] -> [TestTree]
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) =
          ResourceSpec a -> (IO a -> TestTree) -> TestTree
forall a. ResourceSpec a -> (IO a -> TestTree) -> TestTree
Tasty.WithResource ResourceSpec a
rSpec ([TestName] -> TestTree -> TestTree
go [TestName]
prefix (TestTree -> TestTree) -> (IO a -> TestTree) -> IO a -> TestTree
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 (TestTree -> TestTree)
-> (OptionSet -> TestTree) -> OptionSet -> TestTree
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 <- (TestName -> Maybe TestName
forall a. a -> Maybe a
Just (TestName -> Maybe TestName) -> IO TestName -> IO (Maybe TestName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TestName -> IO TestName
readFile' TestName
filePath)
                      IO (Maybe TestName)
-> (IOError -> IO (Maybe TestName)) -> IO (Maybe TestName)
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` (\IOError
e -> if IOError -> Bool
isDoesNotExistError IOError
e
                                              then Maybe TestName -> IO (Maybe TestName)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TestName
forall a. Maybe a
Nothing
                                              else IOError -> IO (Maybe TestName)
forall a. IOError -> IO a
ioError IOError
e)
    Maybe (Map [TestName] TestResult)
-> IO (Maybe (Map [TestName] TestResult))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TestName -> Map [TestName] TestResult
forall a. Read a => TestName -> a
read (TestName -> Map [TestName] TestResult)
-> Maybe TestName -> Maybe (Map [TestName] TestResult)
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 IO (Map [TestName] TestResult)
-> (Map [TestName] TestResult -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Map [TestName] TestResult -> TestName
forall a. Show a => a -> TestName
show (Map [TestName] TestResult -> TestName)
-> (TestName -> IO ()) -> Map [TestName] TestResult -> IO ()
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 Key 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
_ = Compose (t IO) (Const (Map [a] TestResult)) ()
-> Traversal (Compose (t IO) (Const (Map [a] TestResult)))
forall (f :: * -> *). f () -> Traversal f
Tasty.Traversal (Compose (t IO) (Const (Map [a] TestResult)) ()
 -> Traversal (Compose (t IO) (Const (Map [a] TestResult))))
-> Compose (t IO) (Const (Map [a] TestResult)) ()
-> Traversal (Compose (t IO) (Const (Map [a] TestResult)))
forall a b. (a -> b) -> a -> b
$ t IO (Const (Map [a] TestResult) ())
-> Compose (t IO) (Const (Map [a] TestResult)) ()
forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Functor.Compose (t IO (Const (Map [a] TestResult) ())
 -> Compose (t IO) (Const (Map [a] TestResult)) ())
-> t IO (Const (Map [a] TestResult) ())
-> Compose (t IO) (Const (Map [a] TestResult)) ()
forall a b. (a -> b) -> a -> b
$ do
          Key
i <- t IO Key
forall s (m :: * -> *). MonadState s m => m s
State.get

          TestResult
status <- IO TestResult -> t IO TestResult
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO TestResult -> t IO TestResult)
-> IO TestResult -> t IO TestResult
forall a b. (a -> b) -> a -> b
$ STM TestResult -> IO TestResult
forall a. STM a -> IO a
STM.atomically (STM TestResult -> IO TestResult)
-> STM TestResult -> IO TestResult
forall a b. (a -> b) -> a -> b
$ do
            Status
status <- Key -> STM Status
lookupStatus Key
i
            case Status
status of
              Tasty.Done Result
result -> TestResult -> STM TestResult
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (TestResult -> STM TestResult) -> TestResult -> STM TestResult
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
_ -> STM TestResult
forall a. STM a
STM.retry

          Map [a] TestResult -> Const (Map [a] TestResult) ()
forall {k} a (b :: k). a -> Const a b
Const ([a] -> TestResult -> Map [a] TestResult
forall k a. k -> a -> Map k a
Map.singleton [a
name] TestResult
status) Const (Map [a] TestResult) ()
-> t IO () -> t IO (Const (Map [a] TestResult) ())
forall a b. a -> t IO b -> t IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Key -> Key) -> t IO ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
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 = Compose f (Const (Map [a] a)) ()
-> Traversal (Compose f (Const (Map [a] a)))
forall (f :: * -> *). f () -> Traversal f
Tasty.Traversal (Compose f (Const (Map [a] a)) ()
 -> Traversal (Compose f (Const (Map [a] a))))
-> Compose f (Const (Map [a] a)) ()
-> Traversal (Compose f (Const (Map [a] a)))
forall a b. (a -> b) -> a -> b
$ f (Const (Map [a] a) ()) -> Compose f (Const (Map [a] a)) ()
forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Functor.Compose (f (Const (Map [a] a) ()) -> Compose f (Const (Map [a] a)) ())
-> f (Const (Map [a] a) ()) -> Compose f (Const (Map [a] a)) ()
forall a b. (a -> b) -> a -> b
$ do
          Const Map [a] a
soFar <- Compose f (Const (Map [a] a)) () -> f (Const (Map [a] a) ())
forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
Functor.getCompose (Compose f (Const (Map [a] a)) () -> f (Const (Map [a] a) ()))
-> Compose f (Const (Map [a] a)) () -> f (Const (Map [a] a) ())
forall a b. (a -> b) -> a -> b
$ Traversal (Compose f (Const (Map [a] a)))
-> Compose f (Const (Map [a] a)) ()
forall (f :: * -> *). Traversal f -> f ()
Tasty.getTraversal Traversal (Compose f (Const (Map [a] a)))
children
          Const (Map [a] a) () -> f (Const (Map [a] a) ())
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Const (Map [a] a) () -> f (Const (Map [a] a) ()))
-> Const (Map [a] a) () -> f (Const (Map [a] a) ())
forall a b. (a -> b) -> a -> b
$ Map [a] a -> Const (Map [a] a) ()
forall {k} a (b :: k). a -> Const a b
Const (([a] -> [a]) -> Map [a] a -> Map [a] a
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys (a
name :) Map [a] a
soFar)

    in TreeFold
  (Traversal
     (Compose (StateT Key IO) (Const (Map [TestName] TestResult))))
forall b. Monoid b => TreeFold b
Tasty.trivialFold
      { Tasty.foldSingle = foldSingle
      , Tasty.foldGroup = const (\TestName
name -> TestName
-> Traversal
     (Compose (StateT Key IO) (Const (Map [TestName] TestResult)))
-> Traversal
     (Compose (StateT Key IO) (Const (Map [TestName] TestResult)))
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 (Traversal
   (Compose (StateT Key IO) (Const (Map [TestName] TestResult)))
 -> Traversal
      (Compose (StateT Key IO) (Const (Map [TestName] TestResult))))
-> ([Traversal
       (Compose (StateT Key IO) (Const (Map [TestName] TestResult)))]
    -> Traversal
         (Compose (StateT Key IO) (Const (Map [TestName] TestResult))))
-> [Traversal
      (Compose (StateT Key IO) (Const (Map [TestName] TestResult)))]
-> Traversal
     (Compose (StateT Key IO) (Const (Map [TestName] TestResult)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Traversal
   (Compose (StateT Key IO) (Const (Map [TestName] TestResult)))]
-> Traversal
     (Compose (StateT Key IO) (Const (Map [TestName] TestResult)))
forall a. Monoid a => [a] -> a
mconcat)
      }

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

-- | Get the default log file name.
-- Whether a package-wide or a per-component log file name is returned depends
-- on the possibility to determine the path to the test executable reliably; See
-- 'System.Environment.executablePath'.
getDefaultLogfileName :: IO FilePath
getDefaultLogfileName :: IO TestName
getDefaultLogfileName =
  Maybe TestName -> TestName
logfileName (Maybe TestName -> TestName) -> IO (Maybe TestName) -> IO TestName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    IO (Maybe TestName)
-> Maybe (IO (Maybe TestName)) -> IO (Maybe TestName)
forall a. a -> Maybe a -> a
fromMaybe (Maybe TestName -> IO (Maybe TestName)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TestName
forall a. Maybe a
Nothing) Maybe (IO (Maybe TestName))
System.Environment.executablePath

-- | Returns the default log file name.
-- The argument passed should be the file path of the test executable, if that
-- path is available. If @Nothing@ is passed, then a package-wide log file name
-- is returned, which may lead to problems; See
-- https://github.com/ocharles/tasty-rerun/issues/22 .
logfileName
  :: Maybe FilePath -- ^ The file path of the test executable.
  -> String -- ^ The Tasty Rerun log file name.
logfileName :: Maybe TestName -> TestName
logfileName Maybe TestName
Nothing = TestName
".tasty-rerun-log"
logfileName (Just TestName
executablePath) =
    Maybe TestName -> TestName
logfileName Maybe TestName
forall a. Maybe a
Nothing TestName -> TestName -> TestName
<.> TestName -> TestName
takeBaseName TestName
executablePath