module Test.Tasty.Silver.Interactive
(
defaultMain
, interactiveTests
, Interactive (..)
, runTestsInteractive
)
where
import Prelude hiding (fail)
import Test.Tasty hiding (defaultMain)
import Test.Tasty.Runners
import Test.Tasty.Options
import Test.Tasty.Silver.Internal
import Test.Tasty.Silver.Interactive.Run
import Data.Typeable
import Data.Tagged
import Data.Maybe
import Data.Monoid
import Data.Foldable (foldMap)
import Data.Char
import qualified Data.IntMap as IntMap
import Control.Monad.State hiding (fail)
import Control.Monad.STM
import Control.Monad.Reader hiding (fail)
import Control.Monad.Identity hiding (fail)
import Control.Concurrent.STM.TVar
import Control.Exception
import Text.Printf
import qualified Data.Text as T
import Data.Text.Encoding
import Options.Applicative
import System.Process.ByteString.Lazy as PL
import System.Process
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString as BS
import System.IO
import System.IO.Temp
import System.FilePath
import Test.Tasty.Providers
import qualified Data.Map as M
import System.Console.ANSI
defaultMain :: TestTree -> IO ()
defaultMain = defaultMainWithIngredients [interactiveTests, listingTests, consoleTestReporter]
newtype Interactive = Interactive Bool
deriving (Eq, Ord, Typeable)
instance IsOption Interactive where
defaultValue = Interactive False
parseValue = fmap Interactive . safeRead
optionName = return "interactive"
optionHelp = return "Run tests in interactive mode."
optionCLParser = flagCLParser (Just 'i') (Interactive True)
data ResultStatus = RPass | RFail | RInteract GoldenResultI
type GoldenStatus = GoldenResultI
type GoldenStatusMap = TVar (M.Map TestName GoldenStatus)
interactiveTests :: Ingredient
interactiveTests = TestManager [Option (Proxy :: Proxy Interactive)] $
\opts tree ->
case lookupOption opts of
Interactive False -> Nothing
Interactive True -> Just $
runTestsInteractive opts tree
runSingleTest :: IsTest t => GoldenStatusMap -> TestName -> OptionSet -> t -> (Progress -> IO ()) -> IO Result
runSingleTest gs n opts t cb = do
case (cast t :: Maybe Golden) of
Nothing -> run opts t cb
Just g -> do
(r, gr) <- runGolden g
gr' <- forceGoldenResult gr
atomically $ modifyTVar gs (M.insert n gr')
return r
runTestsInteractive :: OptionSet -> TestTree -> IO Bool
runTestsInteractive opts tests = do
gmap <- newTVarIO M.empty
let tests' = wrapRunTest (runSingleTest gmap) tests
r <- launchTestTree opts tests' $ \smap ->
do
isTerm <- hSupportsANSI stdout
(\k -> if isTerm
then (do hideCursor; k) `finally` showCursor
else k) $ do
hSetBuffering stdout NoBuffering
let
whenColor = lookupOption opts
HideSuccesses hideSuccesses = lookupOption opts
let
?colors = useColor whenColor isTerm
let
outp = produceOutput opts tests
case () of { _
| hideSuccesses && isTerm ->
consoleOutputHidingSuccesses outp smap gmap
| hideSuccesses && not isTerm ->
streamOutputHidingSuccesses outp smap gmap
| otherwise -> consoleOutput outp smap gmap
}
return $ \time -> do
stats <- computeStatistics smap
printStatistics stats time
return $ statFailures stats == 0
return r
showDiff :: TestName -> GDiff -> IO ()
showDiff n (DiffText _ tGold tAct) = do
withSystemTempFile (n <.> "golden") (\fGold hGold -> do
withSystemTempFile (n <.> "actual") (\fAct hAct -> do
hSetBinaryMode hGold True
hSetBinaryMode hAct True
BS.hPut hGold (encodeUtf8 tGold)
BS.hPut hAct (encodeUtf8 tAct)
hClose hGold
hClose hAct
callProcess "sh"
["-c", "git diff --color=always --no-index --text " ++ fGold ++ " " ++ fAct ++ " | less -r > /dev/tty"]
)
)
showDiff n (ShowDiffed _ t) = showInLess n t
showDiff _ Equal = error "Can't show diff for equal values..."
showValue :: TestName -> GShow -> IO ()
showValue n (ShowText t) = showInLess n t
showInLess :: String -> T.Text -> IO ()
showInLess _ t = do
_ <- PL.readProcessWithExitCode "sh" ["-c", "less > /dev/tty"] inp
return ()
where inp = B.fromStrict $ encodeUtf8 t
tryAccept :: String -> TestName -> (a -> IO ()) -> a -> IO Bool
tryAccept pref nm upd new = do
isTerm <- hSupportsANSI stdout
when isTerm showCursor
_ <- printf "%sAccept actual value as new golden value? [yn] " pref
ans <- getLine
case ans of
"y" -> do
upd new
printf "%s" pref
when isTerm hideCursor
return True
"n" -> do
printf "%s" pref
when isTerm hideCursor
return False
_ -> do
printf "%sInvalid answer.\n" pref
tryAccept pref nm upd new
data TestOutput
= PrintTest
(TestName)
(IO ())
((Result, ResultStatus) -> IO ())
| PrintHeading (IO ()) TestOutput
| Skip
| Seq TestOutput TestOutput
instance Monoid TestOutput where
mempty = Skip
mappend = Seq
type Level = Int
produceOutput :: (?colors :: Bool) => OptionSet -> TestTree -> TestOutput
produceOutput opts tree =
let
!alignment = computeAlignment opts tree
handleSingleTest
:: (IsTest t, ?colors :: Bool)
=> OptionSet -> TestName -> t -> Ap (Reader Level) TestOutput
handleSingleTest _opts name _test = Ap $ do
level <- ask
let
align = replicate (alignment indentSize * level length name) ' '
pref = indent level ++ replicate (length name) ' ' ++ " " ++ align
printTestName =
printf "%s%s: %s" (indent level) name align
printTestResult (result, resultStatus) = do
result' <- case resultStatus of
RInteract (GRNoGolden a shw upd) -> do
printf "Golden value missing. Press <enter> to show actual value.\n"
_ <- getLine
let a' = runIdentity a
shw' <- shw a'
showValue name shw'
isUpd <- tryAccept pref name upd a'
return $ if isUpd then testPassed "Created golden value." else testFailed "Golden value missing."
RInteract (GRDifferent _ a diff upd) -> do
printf "Golden value differs from actual value.\n"
showDiff name diff
isUpd <- tryAccept pref name upd a
return $ if isUpd then testPassed "Updated golden value." else testFailed "Golden value does not match actual output."
_ -> return result
rDesc <- formatMessage $ resultDescription result'
let
printFn =
if resultSuccessful result'
then ok
else fail
time = resultTime result
if resultSuccessful result'
then printFn "OK"
else printFn "FAIL"
when (time >= 0.01) $
printFn (printf " (%.2fs)" time)
printFn "\n"
when (not $ null rDesc) $
(if resultSuccessful result' then infoOk else infoFail) $
printf "%s%s\n" (indent $ level + 1) (formatDesc (level+1) rDesc)
return $ PrintTest name printTestName printTestResult
handleGroup :: TestName -> Ap (Reader Level) TestOutput -> Ap (Reader Level) TestOutput
handleGroup name grp = Ap $ do
level <- ask
let
printHeading = printf "%s%s\n" (indent level) name
printBody = runReader (getApp grp) (level + 1)
return $ PrintHeading printHeading printBody
in
flip runReader 0 $ getApp $
foldTestTree
trivialFold
{ foldSingle = handleSingleTest
, foldGroup = handleGroup
}
opts tree
foldTestOutput
:: (?colors :: Bool, Monoid b)
=> (IO () -> IO (Result, ResultStatus)
-> ((Result, ResultStatus) -> IO ())
-> b)
-> (IO () -> b -> b)
-> TestOutput -> StatusMap -> GoldenStatusMap -> b
foldTestOutput foldTest foldHeading outputTree smap gmap =
flip evalState 0 $ getApp $ go outputTree where
go (PrintTest nm printName printResult) = Ap $ do
ix <- get
put $! ix + 1
let
readStatusVar = getResultWithGolden smap gmap nm ix
return $ foldTest printName readStatusVar printResult
go (PrintHeading printName printBody) = Ap $
foldHeading printName <$> getApp (go printBody)
go (Seq a b) = mappend (go a) (go b)
go Skip = mempty
consoleOutput :: (?colors :: Bool) => TestOutput -> StatusMap -> GoldenStatusMap -> IO ()
consoleOutput outp smap gmap =
getTraversal . fst $ foldTestOutput foldTest foldHeading outp smap gmap
where
foldTest printName getResult printResult =
( Traversal $ do
_ <- printName
r <- getResult
printResult r
, Any True)
foldHeading printHeading (printBody, Any nonempty) =
( Traversal $ do
when nonempty $ printHeading >> getTraversal printBody
, Any nonempty
)
consoleOutputHidingSuccesses :: (?colors :: Bool) => TestOutput -> StatusMap -> GoldenStatusMap -> IO ()
consoleOutputHidingSuccesses outp smap gmap =
void . getApp $ foldTestOutput foldTest foldHeading outp smap gmap
where
foldTest printName getResult printResult =
Ap $ do
_ <- printName
r <- getResult
if resultSuccessful (fst r)
then clearThisLine >> (return $ Any False)
else printResult r >> (return $ Any True)
foldHeading printHeading printBody =
Ap $ do
_ <- printHeading
Any failed <- getApp printBody
unless failed clearAboveLine
return $ Any failed
clearAboveLine = do cursorUpLine 1; clearThisLine
clearThisLine = do clearLine; setCursorColumn 0
streamOutputHidingSuccesses :: (?colors :: Bool) => TestOutput -> StatusMap -> GoldenStatusMap -> IO ()
streamOutputHidingSuccesses outp smap gmap =
void . flip evalStateT [] . getApp $
foldTestOutput foldTest foldHeading outp smap gmap
where
foldTest printName getResult printResult =
Ap $ do
r <- liftIO $ getResult
if resultSuccessful (fst r)
then return $ Any False
else do
stack <- get
put []
_ <- liftIO $ do
sequence_ $ reverse stack
_ <- printName
printResult r
return $ Any True
foldHeading printHeading printBody =
Ap $ do
modify (printHeading :)
Any failed <- getApp printBody
unless failed $
modify $ \stack ->
case stack of
_:rest -> rest
[] -> []
return $ Any failed
data Statistics = Statistics
{ statTotal :: !Int
, statFailures :: !Int
}
instance Monoid Statistics where
Statistics t1 f1 `mappend` Statistics t2 f2 = Statistics (t1 + t2) (f1 + f2)
mempty = Statistics 0 0
computeStatistics :: StatusMap -> IO Statistics
computeStatistics = getApp . foldMap (\var -> Ap $
(\r -> Statistics 1 (if resultSuccessful r then 0 else 1))
<$> getResultFromTVar var)
printStatistics :: (?colors :: Bool) => Statistics -> Time -> IO ()
printStatistics st time = do
printf "\n"
case statFailures st of
0 -> do
ok $ printf "All %d tests passed (%.2fs)\n" (statTotal st) time
fs -> do
fail $ printf "%d out of %d tests failed (%.2fs)\n" fs (statTotal st) time
data FailureStatus
= Unknown
| Failed
| OK
instance Monoid FailureStatus where
mappend Failed _ = Failed
mappend _ Failed = Failed
mappend OK OK = OK
mappend _ _ = Unknown
mempty = OK
newtype HideSuccesses = HideSuccesses Bool
deriving (Eq, Ord, Typeable)
instance IsOption HideSuccesses where
defaultValue = HideSuccesses False
parseValue = fmap HideSuccesses . safeRead
optionName = return "hide-successes"
optionHelp = return "Do not print tests that passed successfully"
optionCLParser = flagCLParser Nothing (HideSuccesses True)
data UseColor
= Never | Always | Auto
deriving (Eq, Ord, Typeable)
instance IsOption UseColor where
defaultValue = Auto
parseValue = parseUseColor
optionName = return "color"
optionHelp = return "When to use colored output. Options are 'never', 'always' and 'auto' (default: 'auto')"
optionCLParser =
option parse
( long name
<> help (untag (optionHelp :: Tagged UseColor String))
)
where
name = untag (optionName :: Tagged UseColor String)
parse = str >>=
maybe (readerError $ "Could not parse " ++ name) pure <$> parseValue
useColor :: UseColor -> Bool -> Bool
useColor cond isTerm =
case cond of
Never -> False
Always -> True
Auto -> isTerm
parseUseColor :: String -> Maybe UseColor
parseUseColor s =
case map toLower s of
"never" -> return Never
"always" -> return Always
"auto" -> return Auto
_ -> Nothing
getResultWithGolden :: StatusMap -> GoldenStatusMap -> TestName -> Int -> IO (Result, ResultStatus)
getResultWithGolden smap gmap nm ix = do
r <- getResultFromTVar statusVar
gr <- atomically $ readTVar gmap
case nm `M.lookup` gr of
Just g@(GRDifferent {}) -> return (r, RInteract g)
Just g@(GRNoGolden {}) -> return (r, RInteract g)
_ | resultSuccessful r -> return (r, RPass)
_ | otherwise -> return (r, RFail)
where statusVar =
fromMaybe (error "internal error: index out of bounds") $
IntMap.lookup ix smap
getResultFromTVar :: TVar Status -> IO Result
getResultFromTVar statusVar = do
atomically $ do
status <- readTVar statusVar
case status of
Done r -> return r
_ -> retry
indentSize :: Int
indentSize = 2
indent :: Int -> String
indent n = replicate (indentSize * n) ' '
formatDesc
:: Int
-> String
-> String
formatDesc n desc =
let
chomped = reverse . dropWhile (== '\n') . reverse $ desc
multiline = '\n' `elem` chomped
paddedDesc = flip concatMap chomped $ \c ->
if c == '\n'
then c : indent n
else [c]
in
if multiline
then paddedDesc
else chomped
data Maximum a
= Maximum a
| MinusInfinity
instance Ord a => Monoid (Maximum a) where
mempty = MinusInfinity
Maximum a `mappend` Maximum b = Maximum (a `max` b)
MinusInfinity `mappend` a = a
a `mappend` MinusInfinity = a
computeAlignment :: OptionSet -> TestTree -> Int
computeAlignment opts =
fromMonoid .
foldTestTree
trivialFold
{ foldSingle = \_ name _ level -> Maximum (length name + level)
, foldGroup = \_ m -> m . (+ indentSize)
}
opts
where
fromMonoid m =
case m 0 of
MinusInfinity -> 0
Maximum x -> x
ok, fail, infoOk, infoFail :: (?colors :: Bool) => String -> IO ()
fail = output BoldIntensity Vivid Red
ok = output NormalIntensity Dull Green
infoOk = output NormalIntensity Dull White
infoFail = output NormalIntensity Dull Red
output
:: (?colors :: Bool)
=> ConsoleIntensity
-> ColorIntensity
-> Color
-> String
-> IO ()
output bold intensity color st
| ?colors =
(do
setSGR
[ SetColor Foreground intensity color
, SetConsoleIntensity bold
]
putStr st
) `finally` setSGR []
| otherwise = putStr st