-- |
-- 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 hiding (filter, mempty)

import Control.Applicative
import Control.Arrow ((>>>))
import Control.Monad (when)
import Control.Monad.Trans.Class (lift)
import Data.Char (isSpace, toLower)
import Data.Foldable (asum)
import Data.List (intercalate)
import Data.List.Split (endBy)
import Data.Maybe (fromMaybe)
import Data.Monoid (Any(..), mempty)
import Data.Proxy (Proxy(..))
import Data.Typeable (Typeable)
import System.IO.Error (catchIOError, isDoesNotExistError)

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

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

instance Tasty.IsOption UpdateLog where
  optionName :: Tagged UpdateLog String
optionName = String -> Tagged UpdateLog String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"rerun-update"
  optionHelp :: Tagged UpdateLog String
optionHelp = String -> Tagged UpdateLog String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"Update the log file to reflect latest test outcomes"
  defaultValue :: UpdateLog
defaultValue = Bool -> UpdateLog
UpdateLog Bool
False
  parseValue :: String -> Maybe UpdateLog
parseValue = (Bool -> UpdateLog) -> Maybe Bool -> Maybe UpdateLog
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> UpdateLog
UpdateLog (Maybe Bool -> Maybe UpdateLog)
-> (String -> Maybe Bool) -> String -> Maybe UpdateLog
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> 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
/= :: Filter -> Filter -> Bool
$c/= :: Filter -> Filter -> Bool
== :: Filter -> Filter -> Bool
$c== :: 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
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
$cp1Ord :: Eq Filter
Ord, Int -> Filter
Filter -> Int
Filter -> [Filter]
Filter -> Filter
Filter -> Filter -> [Filter]
Filter -> Filter -> Filter -> [Filter]
(Filter -> Filter)
-> (Filter -> Filter)
-> (Int -> Filter)
-> (Filter -> Int)
-> (Filter -> [Filter])
-> (Filter -> Filter -> [Filter])
-> (Filter -> Filter -> [Filter])
-> (Filter -> Filter -> Filter -> [Filter])
-> Enum 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
Filter -> Filter -> Bounded Filter
forall a. a -> a -> Bounded a
maxBound :: Filter
$cmaxBound :: Filter
minBound :: Filter
$cminBound :: Filter
Bounded, Int -> Filter -> ShowS
[Filter] -> ShowS
Filter -> String
(Int -> Filter -> ShowS)
-> (Filter -> String) -> ([Filter] -> ShowS) -> Show Filter
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Filter] -> ShowS
$cshowList :: [Filter] -> ShowS
show :: Filter -> String
$cshow :: Filter -> String
showsPrec :: Int -> Filter -> ShowS
$cshowsPrec :: Int -> Filter -> ShowS
Show)

parseFilter :: String -> Maybe Filter
parseFilter :: String -> Maybe Filter
parseFilter String
s = String -> [(String, Filter)] -> Maybe Filter
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
s ((Filter -> (String, Filter)) -> [Filter] -> [(String, Filter)]
forall a b. (a -> b) -> [a] -> [b]
map (\Filter
x -> ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (Filter -> String
forall a. Show a => a -> String
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)
  deriving (Typeable)

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

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

instance Tasty.IsOption AllOnSuccess where
  optionName :: Tagged AllOnSuccess String
optionName = String -> Tagged AllOnSuccess String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"rerun-all-on-success"
  optionHelp :: Tagged AllOnSuccess String
optionHelp = String -> Tagged AllOnSuccess String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"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 :: String -> Maybe AllOnSuccess
parseValue = (Bool -> AllOnSuccess) -> Maybe Bool -> Maybe AllOnSuccess
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> AllOnSuccess
AllOnSuccess (Maybe Bool -> Maybe AllOnSuccess)
-> (String -> Maybe Bool) -> String -> Maybe AllOnSuccess
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> 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 }
  deriving (Typeable)

instance Tasty.IsOption Rerun where
  optionName :: Tagged Rerun String
optionName = String -> Tagged Rerun String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"rerun"
  optionHelp :: Tagged Rerun String
optionHelp = String -> Tagged Rerun String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"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 :: String -> Maybe Rerun
parseValue = (Bool -> Rerun) -> Maybe Bool -> Maybe Rerun
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Rerun
Rerun (Maybe Bool -> Maybe Rerun)
-> (String -> Maybe Bool) -> String -> Maybe Rerun
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> 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
Int -> ReadS TestResult
ReadS [TestResult]
(Int -> ReadS TestResult)
-> ReadS [TestResult]
-> ReadPrec TestResult
-> ReadPrec [TestResult]
-> Read 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 -> String
(Int -> TestResult -> ShowS)
-> (TestResult -> String)
-> ([TestResult] -> ShowS)
-> Show TestResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TestResult] -> ShowS
$cshowList :: [TestResult] -> ShowS
show :: TestResult -> String
$cshow :: TestResult -> String
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 [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
      let RerunLogFile String
stateFile = OptionSet -> RerunLogFile
forall v. IsOption v => OptionSet -> v
Tasty.lookupOption OptionSet
options
          (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 { foldSingle :: forall t. IsTest t => OptionSet -> String -> t -> Any
Tasty.foldSingle = \OptionSet
_ String
_ 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 [String] TestResult -> TestTree)
-> Maybe (Map [String] TestResult)
-> TestTree
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TestTree
testTree (TestTree -> TestTree
recoverFromEmpty (TestTree -> TestTree)
-> (Map [String] TestResult -> TestTree)
-> Map [String] TestResult
-> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestTree -> Set Filter -> Map [String] TestResult -> TestTree
filterTestTree TestTree
testTree Set Filter
filter)
                           (Maybe (Map [String] TestResult) -> TestTree)
-> IO (Maybe (Map [String] TestResult)) -> IO TestTree
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe (Map [String] TestResult))
tryLoadStateFrom String
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 (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 (m :: * -> *) a. Monad m => a -> m a
return ((Bool -> (StatusMap, Bool)) -> IO Bool -> IO (StatusMap, Bool)
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 [String] TestResult)
getTestResults =
                    (Const (Map [String] TestResult) () -> Map [String] TestResult)
-> IO (Const (Map [String] TestResult) ())
-> IO (Map [String] TestResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Const (Map [String] TestResult) () -> Map [String] TestResult
forall a k (b :: k). Const a b -> a
getConst (IO (Const (Map [String] TestResult) ())
 -> IO (Map [String] TestResult))
-> IO (Const (Map [String] TestResult) ())
-> IO (Map [String] TestResult)
forall a b. (a -> b) -> a -> b
$
                    (StateT Int IO (Const (Map [String] TestResult) ())
 -> Int -> IO (Const (Map [String] TestResult) ()))
-> Int
-> StateT Int IO (Const (Map [String] TestResult) ())
-> IO (Const (Map [String] TestResult) ())
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT Int IO (Const (Map [String] TestResult) ())
-> Int -> IO (Const (Map [String] TestResult) ())
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
State.evalStateT Int
0 (StateT Int IO (Const (Map [String] TestResult) ())
 -> IO (Const (Map [String] TestResult) ()))
-> StateT Int IO (Const (Map [String] TestResult) ())
-> IO (Const (Map [String] TestResult) ())
forall a b. (a -> b) -> a -> b
$
                    Compose (StateT Int IO) (Const (Map [String] TestResult)) ()
-> StateT Int IO (Const (Map [String] TestResult) ())
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
Functor.getCompose (Compose (StateT Int IO) (Const (Map [String] TestResult)) ()
 -> StateT Int IO (Const (Map [String] TestResult) ()))
-> Compose (StateT Int IO) (Const (Map [String] TestResult)) ()
-> StateT Int IO (Const (Map [String] TestResult) ())
forall a b. (a -> b) -> a -> b
$
                    Traversal
  (Compose (StateT Int IO) (Const (Map [String] TestResult)))
-> Compose (StateT Int IO) (Const (Map [String] TestResult)) ()
forall (f :: * -> *). Traversal f -> f ()
Tasty.getTraversal (Traversal
   (Compose (StateT Int IO) (Const (Map [String] TestResult)))
 -> Compose (StateT Int IO) (Const (Map [String] TestResult)) ())
-> Traversal
     (Compose (StateT Int IO) (Const (Map [String] TestResult)))
-> Compose (StateT Int IO) (Const (Map [String] TestResult)) ()
forall a b. (a -> b) -> a -> b
$
                    TreeFold
  (Traversal
     (Compose (StateT Int IO) (Const (Map [String] TestResult))))
-> OptionSet
-> TestTree
-> Traversal
     (Compose (StateT Int IO) (Const (Map [String] TestResult)))
forall b. Monoid b => TreeFold b -> OptionSet -> TestTree -> b
Tasty.foldTestTree (StatusMap
-> TreeFold
     (Traversal
        (Compose (StateT Int IO) (Const (Map [String] TestResult))))
observeResults StatusMap
statusMap)
                                        OptionSet
options TestTree
filteredTestTree

              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
updateLog (String -> IO (Map [String] TestResult) -> IO ()
saveStateTo String
stateFile IO (Map [String] TestResult)
getTestResults)
              Bool -> IO Bool
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 (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 [String] TestResult -> TestTree
filterTestTree TestTree
testTree Set Filter
filter Map [String] TestResult
lastRecord =
    let go :: [String] -> TestTree -> TestTree
go [String]
prefix (Tasty.SingleTest String
name t
t) =
          let requiredFilter :: Filter
requiredFilter = case [String] -> Map [String] TestResult -> Maybe TestResult
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ([String]
prefix [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
name]) Map [String] 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 String -> t -> TestTree
forall t. IsTest t => String -> t -> TestTree
Tasty.SingleTest String
name t
t
               else String -> [TestTree] -> TestTree
Tasty.TestGroup String
"" []

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

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

        go [String]
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 ([String] -> TestTree -> TestTree
go [String]
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 [String]
prefix (Tasty.AskOptions OptionSet -> TestTree
k) =
          (OptionSet -> TestTree) -> TestTree
Tasty.AskOptions ([String] -> TestTree -> TestTree
go [String]
prefix (TestTree -> TestTree)
-> (OptionSet -> TestTree) -> OptionSet -> TestTree
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OptionSet -> TestTree
k)

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

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

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

  ------------------------------------------------------------------------------
  saveStateTo :: FilePath -> IO (Map.Map [String] TestResult) -> IO ()
  saveStateTo :: String -> IO (Map [String] TestResult) -> IO ()
saveStateTo String
filePath IO (Map [String] TestResult)
getTestResults =
    IO (Map [String] TestResult)
getTestResults IO (Map [String] TestResult)
-> (Map [String] TestResult -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Map [String] TestResult -> String
forall a. Show a => a -> String
show (Map [String] TestResult -> String)
-> (String -> IO ()) -> Map [String] TestResult -> IO ()
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> String -> String -> IO ()
writeFile String
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 [String] 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
          Int
i <- t IO Int
forall s (m :: * -> *). MonadState s m => m s
State.get

          TestResult
status <- IO TestResult -> t IO TestResult
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 <- Int -> STM Status
lookupStatus Int
i
            case Status
status of
              Tasty.Done Result
result -> TestResult -> STM TestResult
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 (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Int -> Int) -> t IO ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (Int -> Int -> Int
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 = 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 (f :: k1 -> *) k2 (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 (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 a -> [a] -> [a]
forall a. a -> [a] -> [a]
:) Map [a] a
soFar)

    in TreeFold
  (Traversal
     (Compose (StateT Int IO) (Const (Map [String] TestResult))))
forall b. Monoid b => TreeFold b
Tasty.trivialFold
      { foldSingle :: forall t.
IsTest t =>
OptionSet
-> String
-> t
-> Traversal
     (Compose (StateT Int IO) (Const (Map [String] TestResult)))
Tasty.foldSingle = forall t.
IsTest t =>
OptionSet
-> String
-> t
-> Traversal
     (Compose (StateT Int IO) (Const (Map [String] TestResult)))
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,4,0)
      , foldGroup :: OptionSet
-> String
-> Traversal
     (Compose (StateT Int IO) (Const (Map [String] TestResult)))
-> Traversal
     (Compose (StateT Int IO) (Const (Map [String] TestResult)))
Tasty.foldGroup = (String
 -> Traversal
      (Compose (StateT Int IO) (Const (Map [String] TestResult)))
 -> Traversal
      (Compose (StateT Int IO) (Const (Map [String] TestResult))))
-> OptionSet
-> String
-> Traversal
     (Compose (StateT Int IO) (Const (Map [String] TestResult)))
-> Traversal
     (Compose (StateT Int IO) (Const (Map [String] TestResult)))
forall a b. a -> b -> a
const String
-> Traversal
     (Compose (StateT Int IO) (Const (Map [String] TestResult)))
-> Traversal
     (Compose (StateT Int IO) (Const (Map [String] 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
#else
      , Tasty.foldGroup = foldGroup
#endif
      }

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