-- |
-- 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 DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}

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

import Prelude hiding (filter)

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 "rerun-log-file"
  optionHelp :: Tagged RerunLogFile String
optionHelp = String -> Tagged RerunLogFile String
forall (m :: * -> *) a. Monad m => a -> m a
return "Location of the log file (default: .tasty-rerun-log)"
  defaultValue :: RerunLogFile
defaultValue = String -> RerunLogFile
RerunLogFile ".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 "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 "rerun-update"
  optionHelp :: Tagged UpdateLog String
optionHelp = String -> Tagged UpdateLog String
forall (m :: * -> *) a. Monad m => a -> m a
return "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 s :: 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 (\x :: 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 "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
$  "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 ", " ((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]
++ ". 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 ","
    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 "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 "rerun-all-on-success"
  optionHelp :: Tagged AllOnSuccess String
optionHelp = String -> Tagged AllOnSuccess String
forall (m :: * -> *) a. Monad m => a -> m a
return "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 "rerun"
  optionHelp :: Tagged Rerun String
optionHelp = String -> Tagged Rerun String
forall (m :: * -> *) a. Monad m => a -> m a
return "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 ingredients :: [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
$
    \options :: OptionSet
options testTree :: 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 stateFile :: String
stateFile = OptionSet -> RerunLogFile
forall v. IsOption v => OptionSet -> v
Tasty.lookupOption OptionSet
options
          (UpdateLog updateLog :: Bool
updateLog, AllOnSuccess allOnSuccess :: Bool
allOnSuccess, FilterOption filter :: 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 = \_ _ _ -> 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 t :: 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 _ f :: 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
statusMap, outcome :: 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
$ \sMap :: 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 (\a :: 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 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 _ f :: 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.
        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 e :: 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
testTree filter :: Set Filter
filter lastRecord :: Map [String] TestResult
lastRecord =
    let go :: [String] -> TestTree -> TestTree
go prefix :: [String]
prefix (Tasty.SingleTest name :: String
name t :: 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 False) -> Filter
Failures
                Just ThrewException -> Filter
Exceptions
                Just (Completed True) -> Filter
Successful
                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 "" []

        go prefix :: [String]
prefix (Tasty.TestGroup name :: String
name tests :: [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 prefix :: [String]
prefix (Tasty.PlusTestOptions f :: OptionSet -> OptionSet
f t :: TestTree
t) =
          (OptionSet -> OptionSet) -> TestTree -> TestTree
Tasty.PlusTestOptions OptionSet -> OptionSet
f ([String] -> TestTree -> TestTree
go [String]
prefix TestTree
t)

        go prefix :: [String]
prefix (Tasty.WithResource rSpec :: ResourceSpec a
rSpec k :: 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 prefix :: [String]
prefix (Tasty.AskOptions k :: 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 prefix :: [String]
prefix (Tasty.After a :: DependencyType
a b :: Expr
b c :: 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 filePath :: 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` (\e :: 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 filePath :: String
filePath getTestResults :: 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
statusMap =
    let foldSingle :: p
-> a
-> p
-> Traversal (Compose (t IO) (Const (Map [a] TestResult)))
foldSingle _ name :: a
name _ = 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
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 _) -> TestResult
ThrewException
                  _ -> Bool -> TestResult
Completed (Result -> Bool
Tasty.resultSuccessful Result
result)

              _ -> 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
+ 1)

        foldGroup :: a
-> Traversal (Compose f (Const (Map [a] a)))
-> Traversal (Compose f (Const (Map [a] a)))
foldGroup name :: a
name children :: 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 soFar :: 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
      , foldGroup :: 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)))
forall (f :: * -> *) a a.
(Monad f, Ord a) =>
a
-> Traversal (Compose f (Const (Map [a] a)))
-> Traversal (Compose f (Const (Map [a] a)))
foldGroup
      }

    where
    lookupStatus :: Int -> STM Status
lookupStatus i :: 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 "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)