module Test.Tasty.Travis
( travisTestReporter
, TravisConfig(..)
, defaultConfig
, FoldGroup(..)
, FoldWhen(..)
, SummaryWhen(..)
, listingTests
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative (Applicative(..), (<$>), (<$), (<*>))
import Data.Monoid (Monoid(..))
#endif
import Control.Monad (when)
import Data.Char (isSpace)
import Data.Monoid (Sum(..))
import System.Environment (lookupEnv)
import System.Exit (exitFailure)
import System.IO
(BufferMode(LineBuffering), hPutStrLn, hSetBuffering, stderr, stdout)
import Test.Tasty.Ingredients.ConsoleReporter
import Test.Tasty.Options (IsOption(..), OptionSet, setOption)
import Test.Tasty.Runners
newtype WrapIO a = WrapIO { unwrapIO :: IO a }
deriving (Applicative, Functor, Monad)
instance Monoid a => Monoid (WrapIO a) where
mempty = WrapIO $ return mempty
mappend x y = mappend <$> x <*> y
data TravisConfig
= TravisConfig
{ travisQuiet :: Bool
, travisHideSuccesses :: Bool
, travisUseColour :: Bool
, travisFoldGroup :: FoldGroup
, travisFoldWhen :: FoldWhen
, travisSummaryWhen :: SummaryWhen
}
defaultConfig :: TravisConfig
defaultConfig = TravisConfig
{ travisQuiet = quiet
, travisHideSuccesses = hide
, travisUseColour = True
, travisFoldGroup = FoldAll
, travisFoldWhen = FoldSuccess
, travisSummaryWhen = SummaryFailures
} where
HideSuccesses hide = defaultValue
Quiet quiet = defaultValue
data FoldGroup
= FoldMoreThan Int
| FoldBelow Int
| FoldTop Int
| FoldAll
deriving (Eq, Show)
data FoldWhen
= FoldNever
| FoldSuccess
| FoldAlways
deriving (Eq, Show)
data SummaryWhen
= SummaryNever
| SummaryFailures
| SummaryAlways
deriving (Eq, Show)
travisTestReporter :: TravisConfig -> Ingredient
travisTestReporter cfg@TravisConfig{..} = TestReporter baseOpts runTests
where
TestReporter baseOpts consoleReporter = consoleTestReporter
runTests :: OptionSet -> TestTree
-> Maybe (StatusMap -> IO (Time -> IO Bool))
runTests opts tree = Just $ \smap -> do
isTravis <- maybe False (=="true") <$> lookupEnv "TRAVIS"
if isTravis
then runTravisTestReporter cfg travisOptions tree smap
else runConsoleReporter smap
where
travisOptions :: OptionSet
travisOptions = setOption (Quiet travisQuiet)
. setOption (HideSuccesses travisHideSuccesses)
. setOption (if travisUseColour then Always else Auto)
$ opts
errMsg :: String
errMsg = "Unexpected failure in Tasty's 'consoleTestReporter'!"
runConsoleReporter :: StatusMap -> IO (Time -> IO Bool)
runConsoleReporter = case consoleReporter opts tree of
Just f -> f
Nothing -> const $ do
hPutStrLn stderr errMsg
exitFailure
runTravisTestReporter
:: TravisConfig
-> OptionSet
-> TestTree
-> StatusMap
-> IO (Time -> IO Bool)
runTravisTestReporter cfg@TravisConfig{..} opts tree smap = do
let ?colors = travisUseColour
let testOutput = buildTestOutput opts tree
hSetBuffering stdout LineBuffering
(output, stats) <- travisOutput cfg testOutput smap
when (not travisQuiet) $ unwrapIO $ output "" 0
return $ \time ->
(statFailures stats == 0) <$ printStatistics stats time
travisOutput
:: (?colors :: Bool)
=> TravisConfig
-> TestOutput
-> StatusMap
-> IO (String -> Int -> WrapIO (), Statistics)
travisOutput TravisConfig{..} output smap =
fmap strip . unwrapIO $ foldTestOutput foldTest foldHeading output smap
where
strip (x,y,_) = (x,y)
foldTest
:: String
-> IO ()
-> IO Result
-> (Result -> IO ())
-> WrapIO (String -> Int -> WrapIO (), Statistics, Sum Int)
foldTest _name printName getResult printResult = WrapIO $ do
r <- getResult
return $ case resultOutcome r of
Success -> (success r, Statistics 1 0, Sum 1)
Failure{} -> (doPrint r, Statistics 1 1, Sum 1)
where
success r | travisHideSuccesses = \_ _ -> return ()
| otherwise = doPrint r
doPrint r _ _ = WrapIO $ printName >> printResult r
foldHeading
:: String
-> IO ()
-> WrapIO (String -> Int -> WrapIO (), Statistics, Sum Int)
-> WrapIO (String -> Int -> WrapIO (), Statistics, Sum Int)
foldHeading name printHeading foldBody = do
(printBody, stats@Statistics{..}, kids) <- foldBody
let act label n = WrapIO $ do
when mustFold $
putStrLn $ "travis_fold:start:" ++ foldMarker ++ "\\r"
if mustSummarise
then do
putStr $ replicate (2*n) ' ' ++ name ++ ": "
printStatisticsNoTime stats
else printHeading
unwrapIO $ printBody (foldMarker ++ ".") (n+1)
when mustFold $
putStrLn $ "travis_fold:end:" ++ foldMarker ++ "\\r"
where
replace c | isSpace c = '_'
| otherwise = c
foldMarker = label ++ map replace name
mustFold = doFold travisFoldWhen stats travisFoldGroup kids n
mustSummarise = and [ n /= 0, mustFold
, doSummary travisSummaryWhen stats]
if statTotal == 0 || (statFailures == 0 && travisHideSuccesses)
then return (\_ _ -> return (), stats, Sum 0)
else return (act, stats, Sum 1)
doFold :: FoldWhen -> Statistics -> FoldGroup -> Sum Int -> Int -> Bool
doFold FoldNever _ = \_ _ _ -> False
doFold FoldSuccess stats
| statFailures stats == 0 = doFoldGroup
| otherwise = \_ _ _ -> False
doFold FoldAlways _ = doFoldGroup
doFoldGroup :: FoldGroup -> Sum Int -> Int -> Bool
doFoldGroup FoldAll _ _ = True
doFoldGroup (FoldBelow n) _ i = i > n
doFoldGroup (FoldTop n) _ i = i <= n
doFoldGroup (FoldMoreThan n) kids _ = getSum kids > n
doSummary :: SummaryWhen -> Statistics -> Bool
doSummary SummaryNever _ = False
doSummary SummaryFailures stats = statFailures stats /= 0
doSummary SummaryAlways _ = True