{-# 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 = return "rerun-log-file"
optionHelp = return "Location of the log file (default: .tasty-rerun-log)"
defaultValue = RerunLogFile ".tasty-rerun-log"
parseValue = Just . RerunLogFile
optionCLParser = Tasty.mkOptionCLParser (OptParse.metavar "FILE")
newtype UpdateLog = UpdateLog Bool
deriving (Typeable)
instance Tasty.IsOption UpdateLog where
optionName = return "rerun-update"
optionHelp = return "Update the log file to reflect latest test outcomes"
defaultValue = UpdateLog False
parseValue = fmap UpdateLog . Tasty.safeReadBool
optionCLParser = Tasty.mkFlagCLParser mempty (UpdateLog True)
data Filter = Failures | Exceptions | New | Successful
deriving (Eq, Ord, Enum, Bounded, Show)
parseFilter :: String -> Maybe Filter
parseFilter s = lookup s (map (\x -> (map toLower (show x), x)) everything)
everything :: [Filter]
everything = [minBound..maxBound]
newtype FilterOption = FilterOption (Set.Set Filter)
deriving (Typeable)
instance Tasty.IsOption FilterOption where
optionName = return "rerun-filter"
optionHelp = return
$ "Read the log file and rerun only tests from a given comma-separated list of categories: "
++ map toLower (intercalate ", " (map show everything))
++ ". If this option is omitted or the log file is missing, rerun everything."
defaultValue = FilterOption (Set.fromList everything)
parseValue =
fmap (FilterOption . Set.fromList) . mapM (parseFilter . trim) . endBy ","
where trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace
optionCLParser = Tasty.mkOptionCLParser (OptParse.metavar "CATEGORIES")
newtype AllOnSuccess = AllOnSuccess Bool
deriving (Typeable)
instance Tasty.IsOption AllOnSuccess where
optionName = return "rerun-all-on-success"
optionHelp = 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 False
parseValue = fmap AllOnSuccess . Tasty.safeReadBool
optionCLParser = Tasty.mkFlagCLParser mempty (AllOnSuccess True)
newtype Rerun = Rerun { unRerun :: Bool }
deriving (Typeable)
instance Tasty.IsOption Rerun where
optionName = return "rerun"
optionHelp = 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 False
parseValue = fmap Rerun . Tasty.safeReadBool
optionCLParser = Tasty.mkFlagCLParser mempty (Rerun True)
rerunMeaning :: (UpdateLog, AllOnSuccess, FilterOption)
rerunMeaning = (UpdateLog True, AllOnSuccess True, FilterOption (Set.fromList [Failures, Exceptions]))
data TestResult = Completed Bool | ThrewException
deriving (Read, Show)
defaultMainWithRerun :: Tasty.TestTree -> IO ()
defaultMainWithRerun =
Tasty.defaultMainWithIngredients
[ rerunningTests [ Tasty.listingTests, Tasty.consoleTestReporter ] ]
rerunningTests :: [Tasty.Ingredient] -> Tasty.Ingredient
rerunningTests ingredients =
Tasty.TestManager (rerunOptions ++ Tasty.ingredientsOptions ingredients) $
\options testTree -> Just $ do
let RerunLogFile stateFile = Tasty.lookupOption options
(UpdateLog updateLog, AllOnSuccess allOnSuccess, FilterOption filter)
| unRerun (Tasty.lookupOption options) = rerunMeaning
| otherwise = (Tasty.lookupOption options, Tasty.lookupOption options, Tasty.lookupOption options)
let nonEmptyFold = Tasty.trivialFold { Tasty.foldSingle = \_ _ _ -> Any True }
nullTestTree = not . getAny . Tasty.foldTestTree nonEmptyFold options
recoverFromEmpty t = if allOnSuccess && nullTestTree t then testTree else t
filteredTestTree <- maybe testTree (recoverFromEmpty . filterTestTree testTree filter)
<$> tryLoadStateFrom stateFile
let tryAndRun (Tasty.TestReporter _ f) = do
runner <- f options filteredTestTree
return $ do
(statusMap, outcome) <-
Tasty.launchTestTree options filteredTestTree $ \sMap ->
do f' <- runner sMap
return (fmap (\a -> (sMap, a)) . f')
let getTestResults =
fmap getConst $
flip State.evalStateT 0 $
Functor.getCompose $
Tasty.getTraversal $
Tasty.foldTestTree (observeResults statusMap)
options filteredTestTree
when updateLog (saveStateTo stateFile getTestResults)
return outcome
tryAndRun (Tasty.TestManager _ f) =
f options filteredTestTree
case asum (map tryAndRun ingredients) of
Nothing -> return False
Just e -> e
where
rerunOptions = [ Tasty.Option (Proxy :: Proxy Rerun)
, Tasty.Option (Proxy :: Proxy UpdateLog)
, Tasty.Option (Proxy :: Proxy FilterOption)
, Tasty.Option (Proxy :: Proxy AllOnSuccess)
, Tasty.Option (Proxy :: Proxy RerunLogFile)
]
filterTestTree :: Tasty.TestTree -> Set.Set Filter -> Map.Map [String] TestResult -> Tasty.TestTree
filterTestTree testTree filter lastRecord =
let go prefix (Tasty.SingleTest name t) =
let requiredFilter = case Map.lookup (prefix ++ [name]) lastRecord of
Just (Completed False) -> Failures
Just ThrewException -> Exceptions
Just (Completed True) -> Successful
Nothing -> New
in if (requiredFilter `Set.member` filter)
then Tasty.SingleTest name t
else Tasty.TestGroup "" []
go prefix (Tasty.TestGroup name tests) =
Tasty.TestGroup name (go (prefix ++ [name]) <$> tests)
go prefix (Tasty.PlusTestOptions f t) =
Tasty.PlusTestOptions f (go prefix t)
go prefix (Tasty.WithResource rSpec k) =
Tasty.WithResource rSpec (go prefix <$> k)
go prefix (Tasty.AskOptions k) =
Tasty.AskOptions (go prefix <$> k)
go prefix (Tasty.After a b c) =
Tasty.After a b (go prefix c)
in go [] testTree
tryLoadStateFrom :: FilePath -> IO (Maybe (Map.Map [String] TestResult))
tryLoadStateFrom filePath = do
fileContents <- (Just <$> readFile filePath)
`catchIOError` (\e -> if isDoesNotExistError e
then return Nothing
else ioError e)
return (read <$> fileContents)
saveStateTo :: FilePath -> IO (Map.Map [String] TestResult) -> IO ()
saveStateTo filePath getTestResults =
getTestResults >>= (show >>> writeFile 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 =
let foldSingle _ name _ = Tasty.Traversal $ Functor.Compose $ do
i <- State.get
status <- lift $ STM.atomically $ do
status <- lookupStatus i
case status of
Tasty.Done result -> return $
case Tasty.resultOutcome result of
Tasty.Failure (Tasty.TestThrewException _) -> ThrewException
_ -> Completed (Tasty.resultSuccessful result)
_ -> STM.retry
Const (Map.singleton [name] status) <$ State.modify (+ 1)
foldGroup name children = Tasty.Traversal $ Functor.Compose $ do
Const soFar <- Functor.getCompose $ Tasty.getTraversal children
pure $ Const (Map.mapKeys (name :) soFar)
in Tasty.trivialFold
{ Tasty.foldSingle = foldSingle
, Tasty.foldGroup = foldGroup
}
where
lookupStatus i = STM.readTVar $
fromMaybe (error "Attempted to lookup test by index outside bounds")
(IntMap.lookup i statusMap)