{-# LANGUAGE GeneralizedNewtypeDeriving, PatternGuards, DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
-- | Golden test management, interactive mode. Runs the tests, and asks
-- the user how to proceed in case of failure or missing golden standard.
module Test.Tasty.Silver.Interactive
  (
  -- * Command line helpers
    defaultMain
  , defaultMain1

  -- * The ingredient
  , interactiveTests
  , Interactive (..)

  -- * Programmatic API
  , runTestsInteractive
  )
  where

import Prelude hiding (fail)
import Test.Tasty hiding (defaultMain)
import Test.Tasty.Runners
import Test.Tasty.Options
import Test.Tasty.Silver.Filter
import Test.Tasty.Silver.Internal
import Test.Tasty.Silver.Interactive.Run
import Data.Typeable
import Data.Tagged
import Data.Maybe
import Data.Monoid ( Any(..) )
import Data.Semigroup (Semigroup(..))
import qualified Data.Text.IO as TIO
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 hiding (Failure, Success)
import System.Process.ByteString as PS
import System.Process
import qualified Data.ByteString as BS
import System.Directory
import System.Exit
import System.IO
import System.IO.Temp
import System.FilePath
import Test.Tasty.Providers
import System.Console.ANSI
import qualified System.Process.Text as PTL

type DisabledTests = TestPath -> Bool

-- | Like @defaultMain@ from the main tasty package, but also includes the
-- golden test management capabilities.
defaultMain :: TestTree -> IO ()
defaultMain :: TestTree -> IO ()
defaultMain = [RegexFilter] -> TestTree -> IO ()
defaultMain1 []


defaultMain1 :: ([RegexFilter]) -> TestTree -> IO ()
defaultMain1 :: [RegexFilter] -> TestTree -> IO ()
defaultMain1 [RegexFilter]
filters = [Ingredient] -> TestTree -> IO ()
defaultMainWithIngredients
        [ Ingredient
listingTests
        , DisabledTests -> Ingredient
interactiveTests (Bool -> [RegexFilter] -> DisabledTests
checkRF Bool
False [RegexFilter]
filters)
        ]

newtype Interactive = Interactive Bool
  deriving (Interactive -> Interactive -> Bool
(Interactive -> Interactive -> Bool)
-> (Interactive -> Interactive -> Bool) -> Eq Interactive
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Interactive -> Interactive -> Bool
$c/= :: Interactive -> Interactive -> Bool
== :: Interactive -> Interactive -> Bool
$c== :: Interactive -> Interactive -> Bool
Eq, Eq Interactive
Eq Interactive
-> (Interactive -> Interactive -> Ordering)
-> (Interactive -> Interactive -> Bool)
-> (Interactive -> Interactive -> Bool)
-> (Interactive -> Interactive -> Bool)
-> (Interactive -> Interactive -> Bool)
-> (Interactive -> Interactive -> Interactive)
-> (Interactive -> Interactive -> Interactive)
-> Ord Interactive
Interactive -> Interactive -> Bool
Interactive -> Interactive -> Ordering
Interactive -> Interactive -> Interactive
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 :: Interactive -> Interactive -> Interactive
$cmin :: Interactive -> Interactive -> Interactive
max :: Interactive -> Interactive -> Interactive
$cmax :: Interactive -> Interactive -> Interactive
>= :: Interactive -> Interactive -> Bool
$c>= :: Interactive -> Interactive -> Bool
> :: Interactive -> Interactive -> Bool
$c> :: Interactive -> Interactive -> Bool
<= :: Interactive -> Interactive -> Bool
$c<= :: Interactive -> Interactive -> Bool
< :: Interactive -> Interactive -> Bool
$c< :: Interactive -> Interactive -> Bool
compare :: Interactive -> Interactive -> Ordering
$ccompare :: Interactive -> Interactive -> Ordering
$cp1Ord :: Eq Interactive
Ord, Typeable)
instance IsOption Interactive where
  defaultValue :: Interactive
defaultValue = Bool -> Interactive
Interactive Bool
False
  parseValue :: String -> Maybe Interactive
parseValue = (Bool -> Interactive) -> Maybe Bool -> Maybe Interactive
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Interactive
Interactive (Maybe Bool -> Maybe Interactive)
-> (String -> Maybe Bool) -> String -> Maybe Interactive
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe Bool
forall a. Read a => String -> Maybe a
safeRead
  optionName :: Tagged Interactive String
optionName = String -> Tagged Interactive String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"interactive"
  optionHelp :: Tagged Interactive String
optionHelp = String -> Tagged Interactive String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"Run tests in interactive mode."
  optionCLParser :: Parser Interactive
optionCLParser = Maybe Char -> Interactive -> Parser Interactive
forall v. IsOption v => Maybe Char -> v -> Parser v
flagCLParser (Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'i') (Bool -> Interactive
Interactive Bool
True)

data ResultType = RTSuccess | RTFail | RTIgnore
  deriving (ResultType -> ResultType -> Bool
(ResultType -> ResultType -> Bool)
-> (ResultType -> ResultType -> Bool) -> Eq ResultType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ResultType -> ResultType -> Bool
$c/= :: ResultType -> ResultType -> Bool
== :: ResultType -> ResultType -> Bool
$c== :: ResultType -> ResultType -> Bool
Eq)

data FancyTestException
  = Mismatch GoldenResultI
  | Disabled
  deriving (Int -> FancyTestException -> ShowS
[FancyTestException] -> ShowS
FancyTestException -> String
(Int -> FancyTestException -> ShowS)
-> (FancyTestException -> String)
-> ([FancyTestException] -> ShowS)
-> Show FancyTestException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FancyTestException] -> ShowS
$cshowList :: [FancyTestException] -> ShowS
show :: FancyTestException -> String
$cshow :: FancyTestException -> String
showsPrec :: Int -> FancyTestException -> ShowS
$cshowsPrec :: Int -> FancyTestException -> ShowS
Show, Typeable)

instance Exception FancyTestException

getResultType :: Result -> ResultType
getResultType :: Result -> ResultType
getResultType (Result { resultOutcome :: Result -> Outcome
resultOutcome = Outcome
Success}) = ResultType
RTSuccess
getResultType (Result { resultOutcome :: Result -> Outcome
resultOutcome = (Failure (TestThrewException SomeException
e))}) =
  case SomeException -> Maybe FancyTestException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
    Just FancyTestException
Disabled -> ResultType
RTIgnore
    Maybe FancyTestException
_ -> ResultType
RTFail
getResultType (Result { resultOutcome :: Result -> Outcome
resultOutcome = (Failure FailureReason
_)}) = ResultType
RTFail


interactiveTests :: DisabledTests
    -> Ingredient
interactiveTests :: DisabledTests -> Ingredient
interactiveTests DisabledTests
dis = [OptionDescription]
-> (OptionSet -> TestTree -> Maybe (IO Bool)) -> Ingredient
TestManager
    [ Proxy Interactive -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy Interactive
forall k (t :: k). Proxy t
Proxy :: Proxy Interactive)
    , Proxy HideSuccesses -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy HideSuccesses
forall k (t :: k). Proxy t
Proxy :: Proxy HideSuccesses)
    , Proxy AnsiTricks -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy AnsiTricks
forall k (t :: k). Proxy t
Proxy :: Proxy AnsiTricks)
    , Proxy UseColor -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy UseColor
forall k (t :: k). Proxy t
Proxy :: Proxy UseColor)
    , Proxy NumThreads -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy NumThreads
forall k (t :: k). Proxy t
Proxy :: Proxy NumThreads)
    , Proxy ExcludeFilters -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy ExcludeFilters
forall k (t :: k). Proxy t
Proxy :: Proxy ExcludeFilters)
    , Proxy IncludeFilters -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy IncludeFilters
forall k (t :: k). Proxy t
Proxy :: Proxy IncludeFilters)
    , Proxy AcceptTests -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy AcceptTests
forall k (t :: k). Proxy t
Proxy :: Proxy AcceptTests)
    ] ((OptionSet -> TestTree -> Maybe (IO Bool)) -> Ingredient)
-> (OptionSet -> TestTree -> Maybe (IO Bool)) -> Ingredient
forall a b. (a -> b) -> a -> b
$
  \OptionSet
opts TestTree
tree ->
      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
$ DisabledTests -> OptionSet -> TestTree -> IO Bool
runTestsInteractive DisabledTests
dis OptionSet
opts (OptionSet -> TestTree -> TestTree
filterWithRegex OptionSet
opts TestTree
tree)

runSingleTest ::  IsTest t => DisabledTests -> TestPath -> TestName -> OptionSet -> t -> (Progress -> IO ()) -> IO Result
runSingleTest :: DisabledTests
-> String
-> String
-> OptionSet
-> t
-> (Progress -> IO ())
-> IO Result
runSingleTest DisabledTests
dis String
tp String
_ OptionSet
_ t
_ Progress -> IO ()
_ | DisabledTests
dis String
tp = 
  Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ (String -> Result
testFailed String
"")
    { resultOutcome :: Outcome
resultOutcome = (FailureReason -> Outcome
Failure (FailureReason -> Outcome) -> FailureReason -> Outcome
forall a b. (a -> b) -> a -> b
$ SomeException -> FailureReason
TestThrewException (SomeException -> FailureReason) -> SomeException -> FailureReason
forall a b. (a -> b) -> a -> b
$ FancyTestException -> SomeException
forall e. Exception e => e -> SomeException
toException FancyTestException
Disabled) }
runSingleTest DisabledTests
_ String
_ String
_ OptionSet
opts t
t Progress -> IO ()
cb = do
  case (t -> Maybe Golden
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast t
t :: Maybe Golden) of
    Maybe Golden
Nothing -> OptionSet -> t -> (Progress -> IO ()) -> IO Result
forall t.
IsTest t =>
OptionSet -> t -> (Progress -> IO ()) -> IO Result
run OptionSet
opts t
t Progress -> IO ()
cb
    Just Golden
g -> do
        (Result
r, GoldenResult
gr) <- Golden -> IO (Result, GoldenResult)
runGolden Golden
g

        -- we may be in a different thread here than the main ui.
        -- force evaluation of actual value here, as we have to evaluate it before
        -- leaving this test.
        GoldenResultI
gr' <- GoldenResult -> IO GoldenResultI
forceGoldenResult GoldenResult
gr
        case GoldenResultI
gr' of
            GoldenResultI
GREqual -> Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
r
            GoldenResultI
grd -> Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ Result
r { resultOutcome :: Outcome
resultOutcome = (FailureReason -> Outcome
Failure (FailureReason -> Outcome) -> FailureReason -> Outcome
forall a b. (a -> b) -> a -> b
$ SomeException -> FailureReason
TestThrewException (SomeException -> FailureReason) -> SomeException -> FailureReason
forall a b. (a -> b) -> a -> b
$ FancyTestException -> SomeException
forall e. Exception e => e -> SomeException
toException (FancyTestException -> SomeException)
-> FancyTestException -> SomeException
forall a b. (a -> b) -> a -> b
$ GoldenResultI -> FancyTestException
Mismatch GoldenResultI
grd) }

-- | A simple console UI
runTestsInteractive :: DisabledTests -> OptionSet -> TestTree -> IO Bool
runTestsInteractive :: DisabledTests -> OptionSet -> TestTree -> IO Bool
runTestsInteractive DisabledTests
dis OptionSet
opts TestTree
tests = do
  let tests' :: TestTree
tests' = (forall t.
 IsTest t =>
 String
 -> String -> OptionSet -> t -> (Progress -> IO ()) -> IO Result)
-> TestTree -> TestTree
wrapRunTest (DisabledTests
-> String
-> String
-> OptionSet
-> t
-> (Progress -> IO ())
-> IO Result
forall t.
IsTest t =>
DisabledTests
-> String
-> String
-> OptionSet
-> t
-> (Progress -> IO ())
-> IO Result
runSingleTest DisabledTests
dis) TestTree
tests

  Bool
r <- OptionSet
-> TestTree -> (StatusMap -> IO (Time -> IO Bool)) -> IO Bool
forall a.
OptionSet -> TestTree -> (StatusMap -> IO (Time -> IO a)) -> IO a
launchTestTree OptionSet
opts TestTree
tests' ((StatusMap -> IO (Time -> IO Bool)) -> IO Bool)
-> (StatusMap -> IO (Time -> IO Bool)) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \StatusMap
smap ->
    do
    Bool
isTerm <- Handle -> IO Bool
hSupportsANSI Handle
stdout

    (\IO (Time -> IO Bool)
k -> if Bool
isTerm
      then (do IO ()
hideCursor; IO (Time -> IO Bool)
k) IO (Time -> IO Bool) -> IO () -> IO (Time -> IO Bool)
forall a b. IO a -> IO b -> IO a
`finally` IO ()
showCursor
      else IO (Time -> IO Bool)
k) (IO (Time -> IO Bool) -> IO (Time -> IO Bool))
-> IO (Time -> IO Bool) -> IO (Time -> IO Bool)
forall a b. (a -> b) -> a -> b
$ do

      Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdout BufferMode
NoBuffering

      let
        whenColor :: UseColor
whenColor = OptionSet -> UseColor
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
        HideSuccesses Bool
hideSuccesses = OptionSet -> HideSuccesses
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
        AnsiTricks Bool
ansiTricks = OptionSet -> AnsiTricks
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts

      let
        ?colors = useColor whenColor isTerm

      let
        outp :: TestOutput
outp = (?colors::Bool) => OptionSet -> TestTree -> TestOutput
OptionSet -> TestTree -> TestOutput
produceOutput OptionSet
opts TestTree
tests

      Statistics
stats <- case () of { ()
_
        | Bool
hideSuccesses Bool -> Bool -> Bool
&& Bool
isTerm Bool -> Bool -> Bool
&& Bool
ansiTricks ->
            (?colors::Bool) => TestOutput -> StatusMap -> IO Statistics
TestOutput -> StatusMap -> IO Statistics
consoleOutputHidingSuccesses TestOutput
outp StatusMap
smap
        | Bool
hideSuccesses Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isTerm ->
            (?colors::Bool) => TestOutput -> StatusMap -> IO Statistics
TestOutput -> StatusMap -> IO Statistics
streamOutputHidingSuccesses TestOutput
outp StatusMap
smap
        | Bool
otherwise -> (?colors::Bool) => TestOutput -> StatusMap -> IO Statistics
TestOutput -> StatusMap -> IO Statistics
consoleOutput TestOutput
outp StatusMap
smap
      }

      (Time -> IO Bool) -> IO (Time -> IO Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Time -> IO Bool) -> IO (Time -> IO Bool))
-> (Time -> IO Bool) -> IO (Time -> IO Bool)
forall a b. (a -> b) -> a -> b
$ \Time
time -> do
            (?colors::Bool) => Statistics -> Time -> IO ()
Statistics -> Time -> IO ()
printStatistics Statistics
stats Time
time
            Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Statistics -> Int
statFailures Statistics
stats Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0



  Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
r


printDiff :: TestName -> GDiff -> IO ()
printDiff :: String -> GDiff -> IO ()
printDiff String
n (DiffText Maybe String
_ Text
tGold Text
tAct) = do
  Bool
hasGit <- String -> IO Bool
doesCmdExist String
"git"
  if Bool
hasGit then
    String -> Text -> Text -> (String -> String -> IO ()) -> IO ()
withDiffEnv String
n Text
tGold Text
tAct
      (\String
fGold String
fAct -> do
        (ExitCode, Text, Text)
ret <- String -> [String] -> Text -> IO (ExitCode, Text, Text)
PTL.readProcessWithExitCode String
"sh" [String
"-c", String
"git diff --no-index --text --exit-code " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fGold String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fAct] Text
T.empty
        case (ExitCode, Text, Text)
ret of
         (ExitCode
ExitSuccess, Text
stdOut, Text
_)   -> Text -> IO ()
TIO.putStrLn Text
stdOut
         (ExitFailure Int
1, Text
stdOut, Text
_) -> Text -> IO ()
TIO.putStrLn Text
stdOut
         ret :: (ExitCode, Text, Text)
ret@(ExitFailure Int
_, Text
_, Text
_)  -> String -> IO ()
forall a. HasCallStack => String -> a
error (String
"Call to `git diff` failed: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (ExitCode, Text, Text) -> String
forall a. Show a => a -> String
show (ExitCode, Text, Text)
ret)
      )
  else do
    String -> IO ()
putStrLn String
"`git diff` not available, cannot produce a diff."
    String -> IO ()
putStrLn String
"Golden value:"
    Text -> IO ()
TIO.putStrLn Text
tGold
    String -> IO ()
putStrLn String
"Actual value:"
    Text -> IO ()
TIO.putStrLn Text
tAct
printDiff String
_ (ShowDiffed Maybe String
_ Text
t) = Text -> IO ()
TIO.putStrLn Text
t
printDiff String
_ GDiff
Equal = String -> IO ()
forall a. HasCallStack => String -> a
error String
"Can't print diff for equal values."

showDiff :: TestName -> GDiff -> IO ()
showDiff :: String -> GDiff -> IO ()
showDiff String
n (DiffText Maybe String
_ Text
tGold Text
tAct) = do
  Bool
hasColorDiff' <- IO Bool
hasColorDiff

  String -> Text -> Text -> (String -> String -> IO ()) -> IO ()
withDiffEnv String
n Text
tGold Text
tAct
    (if Bool
hasColorDiff' then String -> String -> IO ()
colorDiff else String -> String -> IO ()
gitDiff)
  where
    gitDiff :: String -> String -> IO ()
gitDiff String
fGold String
fAct = String -> [String] -> IO ()
callProcess String
"sh"
        [String
"-c", String
"git diff --color=always --no-index --text " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fGold String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fAct String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" | less -r > /dev/tty"]

    hasColorDiff :: IO Bool
hasColorDiff = Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool) -> IO Bool -> IO (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Bool
doesCmdExist String
"wdiff" IO (Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> IO Bool
doesCmdExist String
"colordiff"

    colorDiff :: String -> String -> IO ()
colorDiff String
fGold String
fAct = String -> [String] -> IO ()
callProcess String
"sh" [String
"-c", String
"wdiff " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fGold String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fAct String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" | colordiff | less -r > /dev/tty"]
showDiff String
n (ShowDiffed Maybe String
_ Text
t) = String -> Text -> IO ()
showInLess String
n Text
t
showDiff String
_ GDiff
Equal = String -> IO ()
forall a. HasCallStack => String -> a
error String
"Can't show diff for equal values."

doesCmdExist :: String -> IO Bool
doesCmdExist :: String -> IO Bool
doesCmdExist String
cmd = Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool) -> IO (Maybe String) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
findExecutable String
cmd

-- Stores the golden/actual text in two files, so we can use it for git diff.
withDiffEnv :: TestName -> T.Text -> T.Text -> (FilePath -> FilePath -> IO ()) -> IO ()
withDiffEnv :: String -> Text -> Text -> (String -> String -> IO ()) -> IO ()
withDiffEnv String
n Text
tGold Text
tAct String -> String -> IO ()
cont = do
  String -> (String -> Handle -> IO ()) -> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> Handle -> m a) -> m a
withSystemTempFile (String
n String -> ShowS
<.> String
"golden") (\String
fGold Handle
hGold -> do
    String -> (String -> Handle -> IO ()) -> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> Handle -> m a) -> m a
withSystemTempFile (String
n String -> ShowS
<.> String
"actual") (\String
fAct Handle
hAct -> do
      Handle -> Bool -> IO ()
hSetBinaryMode Handle
hGold Bool
True
      Handle -> Bool -> IO ()
hSetBinaryMode Handle
hAct Bool
True
      Handle -> ByteString -> IO ()
BS.hPut Handle
hGold (Text -> ByteString
encodeUtf8 Text
tGold)
      Handle -> ByteString -> IO ()
BS.hPut Handle
hAct (Text -> ByteString
encodeUtf8 Text
tAct)
      Handle -> IO ()
hClose Handle
hGold
      Handle -> IO ()
hClose Handle
hAct
      String -> String -> IO ()
cont String
fGold String
fAct
      )
    )


printValue :: TestName -> GShow -> IO ()
printValue :: String -> GShow -> IO ()
printValue String
_ (ShowText Text
t) = Text -> IO ()
TIO.putStrLn Text
t

showValue :: TestName -> GShow -> IO ()
showValue :: String -> GShow -> IO ()
showValue String
n (ShowText Text
t) = String -> Text -> IO ()
showInLess String
n Text
t

showInLess :: String -> T.Text -> IO ()
showInLess :: String -> Text -> IO ()
showInLess String
_ Text
t = do
  Bool
isTerm <- Handle -> IO Bool
hSupportsANSI Handle
stdout
  if Bool
isTerm
    then do
      (ExitCode, ByteString, ByteString)
ret <- String
-> [String] -> ByteString -> IO (ExitCode, ByteString, ByteString)
PS.readProcessWithExitCode String
"sh" [String
"-c", String
"less > /dev/tty"] ByteString
inp
      case (ExitCode, ByteString, ByteString)
ret of
        ret :: (ExitCode, ByteString, ByteString)
ret@(ExitFailure Int
_, ByteString
_, ByteString
_) -> String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ (ExitCode, ByteString, ByteString) -> String
forall a. Show a => a -> String
show (ExitCode, ByteString, ByteString)
ret
        (ExitCode, ByteString, ByteString)
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    else
      Text -> IO ()
TIO.putStrLn Text
t
  where inp :: ByteString
inp = Text -> ByteString
encodeUtf8 Text
t

tryAccept :: String -> TestName -> (a -> IO ()) -> a -> IO Bool
tryAccept :: String -> String -> (a -> IO ()) -> a -> IO Bool
tryAccept String
pref String
nm a -> IO ()
upd a
new = do
  Bool
isTerm <- Handle -> IO Bool
hSupportsANSI Handle
stdout
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isTerm IO ()
showCursor
  ()
_ <- String -> String -> IO ()
forall r. PrintfType r => String -> r
printf String
"%sAccept actual value as new golden value? [yn] " String
pref
  String
ans <- IO String
getLine
  case String
ans of
    String
"y" -> do
        a -> IO ()
upd a
new
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isTerm IO ()
hideCursor
        String -> String -> IO ()
forall r. PrintfType r => String -> r
printf String
"%s" String
pref
        Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    String
"n" -> do
        String -> String -> IO ()
forall r. PrintfType r => String -> r
printf String
"%s" String
pref
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isTerm IO ()
hideCursor
        Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    String
_   -> do
        String -> String -> IO ()
forall r. PrintfType r => String -> r
printf String
"%sInvalid answer.\n" String
pref
        String -> String -> (a -> IO ()) -> a -> IO Bool
forall a. String -> String -> (a -> IO ()) -> a -> IO Bool
tryAccept String
pref String
nm a -> IO ()
upd a
new


--------------------------------------------------
-- TestOutput base definitions
--------------------------------------------------
-- {{{
-- | 'TestOutput' is an intermediary between output formatting and output
-- printing. It lets us have several different printing modes (normal; print
-- failures only; quiet).
data TestOutput
  = HandleTest
      {- test name, used for golden lookup #-} (TestName)
      {- print test name   -} (IO ())
      {- print test result -} (Result -> IO Statistics)
  | PrintHeading (IO ()) TestOutput
  | Skip
  | Seq TestOutput TestOutput

instance Semigroup TestOutput where
  <> :: TestOutput -> TestOutput -> TestOutput
(<>) = TestOutput -> TestOutput -> TestOutput
Seq

-- The monoid laws should hold observationally w.r.t. the semantics defined
-- in this module
instance Monoid TestOutput where
  mempty :: TestOutput
mempty = TestOutput
Skip
  mappend :: TestOutput -> TestOutput -> TestOutput
mappend = TestOutput -> TestOutput -> TestOutput
forall a. Semigroup a => a -> a -> a
(<>)

type Level = Int

produceOutput :: (?colors :: Bool) => OptionSet -> TestTree -> TestOutput
produceOutput :: OptionSet -> TestTree -> TestOutput
produceOutput OptionSet
opts TestTree
tree =
  let
    -- Do not retain the reference to the tree more than necessary
    !alignment :: Int
alignment = OptionSet -> TestTree -> Int
computeAlignment OptionSet
opts TestTree
tree
    Interactive Bool
isInteractive = OptionSet -> Interactive
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts

    handleSingleTest
      :: (IsTest t, ?colors :: Bool)
      => OptionSet -> TestName -> t -> Ap (Reader Level) TestOutput
    handleSingleTest :: OptionSet -> String -> t -> Ap (Reader Int) TestOutput
handleSingleTest OptionSet
_opts String
name t
_test = Reader Int TestOutput -> Ap (Reader Int) TestOutput
forall (f :: * -> *) a. f a -> Ap f a
Ap (Reader Int TestOutput -> Ap (Reader Int) TestOutput)
-> Reader Int TestOutput -> Ap (Reader Int) TestOutput
forall a b. (a -> b) -> a -> b
$ do
      Int
level <- Reader Int Int
forall r (m :: * -> *). MonadReader r m => m r
ask

      let
        align :: String
align = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
alignment Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
indentSize Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
level Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
name) Char
' '
        pref :: String
pref = Int -> String
indent Int
level String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
name) Char
' ' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
align
        printTestName :: IO ()
printTestName =
          String -> String -> String -> String -> IO ()
forall r. PrintfType r => String -> r
printf String
"%s%s: %s" (Int -> String
indent Int
level) String
name String
align
        printResultLine :: Result -> Bool -> IO ()
printResultLine Result
result Bool
forceTime = do
          -- use an appropriate printing function
          let
            resTy :: ResultType
resTy = Result -> ResultType
getResultType Result
result
            printFn :: String -> IO ()
printFn = case ResultType
resTy of
                ResultType
RTSuccess -> (?colors::Bool) => String -> IO ()
String -> IO ()
ok
                ResultType
RTIgnore -> (?colors::Bool) => String -> IO ()
String -> IO ()
warn
                ResultType
RTFail -> (?colors::Bool) => String -> IO ()
String -> IO ()
fail
          case ResultType
resTy of
            ResultType
RTSuccess -> String -> IO ()
printFn String
"OK"
            ResultType
RTIgnore -> String -> IO ()
printFn String
"DISABLED"
            ResultType
RTFail -> String -> IO ()
printFn String
"FAIL"
          -- print time only if it's significant
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Result -> Time
resultTime Result
result Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
>= Time
0.01 Bool -> Bool -> Bool
|| Bool
forceTime) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            String -> IO ()
printFn (String -> Time -> String
forall r. PrintfType r => String -> r
printf String
" (%.2fs)" (Time -> String) -> Time -> String
forall a b. (a -> b) -> a -> b
$ Result -> Time
resultTime Result
result)
          String -> IO ()
printFn String
"\n"


        handleTestResult :: Result -> IO Statistics
handleTestResult Result
result = do
          -- non-interactive mode. Uses different order of printing,
          -- as using the interactive layout doesn't go that well
          -- with printing the diffs to stdout.
          --
          (?colors::Bool) => Result -> Bool -> IO ()
Result -> Bool -> IO ()
printResultLine Result
result Bool
True

          String
rDesc <- String -> IO String
formatMessage (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ Result -> String
resultDescription Result
result
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ DisabledTests
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
rDesc) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (case Result -> ResultType
getResultType Result
result of
            ResultType
RTSuccess -> (?colors::Bool) => String -> IO ()
String -> IO ()
infoOk
            ResultType
RTIgnore -> (?colors::Bool) => String -> IO ()
String -> IO ()
infoWarn
            ResultType
RTFail -> (?colors::Bool) => String -> IO ()
String -> IO ()
infoFail) (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
              String -> String -> ShowS
forall r. PrintfType r => String -> r
printf String
"%s%s\n" String
pref (Int -> ShowS
formatDesc (Int
levelInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) String
rDesc)

          Statistics
stat' <- (?colors::Bool) => String -> String -> Result -> IO Statistics
String -> String -> Result -> IO Statistics
printTestOutput String
pref String
name Result
result

          Statistics -> IO Statistics
forall (m :: * -> *) a. Monad m => a -> m a
return Statistics
stat'

        handleTestResultInteractive :: Result -> IO Statistics
handleTestResultInteractive Result
result = do
          (Result
result', Statistics
stat') <- case (Result -> Outcome
resultOutcome Result
result) of
            Failure (TestThrewException SomeException
e) ->
              case SomeException -> Maybe FancyTestException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
                Just (Mismatch (GRDifferent a
_ a
_ GDiff
_ Maybe (a -> IO ())
Nothing)) -> do
                  (?colors::Bool) => Result -> Bool -> IO ()
Result -> Bool -> IO ()
printResultLine Result
result Bool
False
                  Statistics
s <- (?colors::Bool) => String -> String -> Result -> IO Statistics
String -> String -> Result -> IO Statistics
printTestOutput String
pref String
name Result
result
                  (Result, Statistics) -> IO (Result, Statistics)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Result
testFailed String
"", Statistics
s)
                Just (Mismatch (GRNoGolden Identity a
a a -> IO GShow
shw (Just a -> IO ()
upd))) -> do
                  String -> IO ()
forall r. PrintfType r => String -> r
printf String
"Golden value missing. Press <enter> to show actual value.\n"
                  String
_ <- IO String
getLine
                  let a' :: a
a' = Identity a -> a
forall a. Identity a -> a
runIdentity Identity a
a
                  GShow
shw' <- a -> IO GShow
shw a
a'
                  String -> GShow -> IO ()
showValue String
name GShow
shw'
                  Bool
isUpd <- String -> String -> (a -> IO ()) -> a -> IO Bool
forall a. String -> String -> (a -> IO ()) -> a -> IO Bool
tryAccept String
pref String
name a -> IO ()
upd a
a'
                  let r :: (Result, Statistics)
r =
                        if Bool
isUpd
                        then ( String -> Result
testPassed String
"Created golden value."
                             , Statistics
forall a. Monoid a => a
mempty { statCreatedGolden :: Int
statCreatedGolden = Int
1 } )
                        else ( String -> Result
testFailed String
"Golden value missing."
                             , Statistics
forall a. Monoid a => a
mempty { statFailures :: Int
statFailures = Int
1 } )
                  (?colors::Bool) => Result -> Bool -> IO ()
Result -> Bool -> IO ()
printResultLine ((Result, Statistics) -> Result
forall a b. (a, b) -> a
fst (Result, Statistics)
r) Bool
False
                  (Result, Statistics) -> IO (Result, Statistics)
forall (m :: * -> *) a. Monad m => a -> m a
return (Result, Statistics)
r
                Just (Mismatch (GRDifferent a
_ a
a GDiff
diff (Just a -> IO ()
upd))) -> do
                  String -> IO ()
forall r. PrintfType r => String -> r
printf String
"Golden value differs from actual value.\n"
                  String -> GDiff -> IO ()
showDiff String
name GDiff
diff
                  Bool
isUpd <- String -> String -> (a -> IO ()) -> a -> IO Bool
forall a. String -> String -> (a -> IO ()) -> a -> IO Bool
tryAccept String
pref String
name a -> IO ()
upd a
a
                  let r :: (Result, Statistics)
r =
                        if Bool
isUpd
                        then ( String -> Result
testPassed String
"Updated golden value."
                             , Statistics
forall a. Monoid a => a
mempty { statUpdatedGolden :: Int
statUpdatedGolden = Int
1 } )
                        else ( String -> Result
testFailed String
"Golden value does not match actual output."
                             , Statistics
forall a. Monoid a => a
mempty { statFailures :: Int
statFailures = Int
1 } )
                  (?colors::Bool) => Result -> Bool -> IO ()
Result -> Bool -> IO ()
printResultLine ((Result, Statistics) -> Result
forall a b. (a, b) -> a
fst (Result, Statistics)
r) Bool
False
                  (Result, Statistics) -> IO (Result, Statistics)
forall (m :: * -> *) a. Monad m => a -> m a
return (Result, Statistics)
r
                Just (Mismatch GoldenResultI
_) -> String -> IO (Result, Statistics)
forall a. HasCallStack => String -> a
error String
"Impossible case!"
                Just FancyTestException
Disabled -> do
                  (?colors::Bool) => Result -> Bool -> IO ()
Result -> Bool -> IO ()
printResultLine Result
result Bool
False
                  (Result, Statistics) -> IO (Result, Statistics)
forall (m :: * -> *) a. Monad m => a -> m a
return ( Result
result
                         , Statistics
forall a. Monoid a => a
mempty { statDisabled :: Int
statDisabled = Int
1 } )
                Maybe FancyTestException
Nothing -> do
                  (?colors::Bool) => Result -> Bool -> IO ()
Result -> Bool -> IO ()
printResultLine Result
result Bool
False
                  (Result, Statistics) -> IO (Result, Statistics)
forall (m :: * -> *) a. Monad m => a -> m a
return (Result
result, Statistics
forall a. Monoid a => a
mempty {statFailures :: Int
statFailures = Int
1})
            Outcome
Success -> do
              (?colors::Bool) => Result -> Bool -> IO ()
Result -> Bool -> IO ()
printResultLine Result
result Bool
False
              (Result, Statistics) -> IO (Result, Statistics)
forall (m :: * -> *) a. Monad m => a -> m a
return (Result
result, Statistics
forall a. Monoid a => a
mempty { statSuccesses :: Int
statSuccesses = Int
1 })
            Failure FailureReason
_ -> do
              (?colors::Bool) => Result -> Bool -> IO ()
Result -> Bool -> IO ()
printResultLine Result
result Bool
False
              (Result, Statistics) -> IO (Result, Statistics)
forall (m :: * -> *) a. Monad m => a -> m a
return (Result
result, Statistics
forall a. Monoid a => a
mempty { statFailures :: Int
statFailures = Int
1 })

          let result'' :: Result
result'' = Result
result' { resultTime :: Time
resultTime = Result -> Time
resultTime Result
result }

          String
rDesc <- String -> IO String
formatMessage (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ Result -> String
resultDescription Result
result''
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ DisabledTests
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
rDesc) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (case Result -> ResultType
getResultType Result
result'' of
            ResultType
RTSuccess -> (?colors::Bool) => String -> IO ()
String -> IO ()
infoOk
            ResultType
RTIgnore -> (?colors::Bool) => String -> IO ()
String -> IO ()
infoWarn
            ResultType
RTFail -> (?colors::Bool) => String -> IO ()
String -> IO ()
infoFail) (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
              String -> String -> ShowS
forall r. PrintfType r => String -> r
printf String
"%s%s\n" String
pref (Int -> ShowS
formatDesc (Int
levelInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) String
rDesc)

          Statistics -> IO Statistics
forall (m :: * -> *) a. Monad m => a -> m a
return Statistics
stat'

      let handleTestResult' :: Result -> IO Statistics
handleTestResult' = (if Bool
isInteractive then (?colors::Bool) => Result -> IO Statistics
Result -> IO Statistics
handleTestResultInteractive else (?colors::Bool) => Result -> IO Statistics
Result -> IO Statistics
handleTestResult)
      TestOutput -> Reader Int TestOutput
forall (m :: * -> *) a. Monad m => a -> m a
return (TestOutput -> Reader Int TestOutput)
-> TestOutput -> Reader Int TestOutput
forall a b. (a -> b) -> a -> b
$ String -> IO () -> (Result -> IO Statistics) -> TestOutput
HandleTest String
name IO ()
printTestName Result -> IO Statistics
handleTestResult'

    handleGroup :: OptionSet -> TestName -> Ap (Reader Level) TestOutput -> Ap (Reader Level) TestOutput
    handleGroup :: OptionSet
-> String
-> Ap (Reader Int) TestOutput
-> Ap (Reader Int) TestOutput
handleGroup OptionSet
_ String
name Ap (Reader Int) TestOutput
grp = Reader Int TestOutput -> Ap (Reader Int) TestOutput
forall (f :: * -> *) a. f a -> Ap f a
Ap (Reader Int TestOutput -> Ap (Reader Int) TestOutput)
-> Reader Int TestOutput -> Ap (Reader Int) TestOutput
forall a b. (a -> b) -> a -> b
$ do
      Int
level <- Reader Int Int
forall r (m :: * -> *). MonadReader r m => m r
ask
      let
        printHeading :: IO ()
printHeading = String -> String -> String -> IO ()
forall r. PrintfType r => String -> r
printf String
"%s%s\n" (Int -> String
indent Int
level) String
name
        printBody :: TestOutput
printBody = Reader Int TestOutput -> Int -> TestOutput
forall r a. Reader r a -> r -> a
runReader (Ap (Reader Int) TestOutput -> Reader Int TestOutput
forall (f :: * -> *) a. Ap f a -> f a
getApp Ap (Reader Int) TestOutput
grp) (Int
level Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
      TestOutput -> Reader Int TestOutput
forall (m :: * -> *) a. Monad m => a -> m a
return (TestOutput -> Reader Int TestOutput)
-> TestOutput -> Reader Int TestOutput
forall a b. (a -> b) -> a -> b
$ IO () -> TestOutput -> TestOutput
PrintHeading IO ()
printHeading TestOutput
printBody

  in
    (Reader Int TestOutput -> Int -> TestOutput)
-> Int -> Reader Int TestOutput -> TestOutput
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reader Int TestOutput -> Int -> TestOutput
forall r a. Reader r a -> r -> a
runReader Int
0 (Reader Int TestOutput -> TestOutput)
-> Reader Int TestOutput -> TestOutput
forall a b. (a -> b) -> a -> b
$ Ap (Reader Int) TestOutput -> Reader Int TestOutput
forall (f :: * -> *) a. Ap f a -> f a
getApp (Ap (Reader Int) TestOutput -> Reader Int TestOutput)
-> Ap (Reader Int) TestOutput -> Reader Int TestOutput
forall a b. (a -> b) -> a -> b
$
      TreeFold (Ap (Reader Int) TestOutput)
-> OptionSet -> TestTree -> Ap (Reader Int) TestOutput
forall b. Monoid b => TreeFold b -> OptionSet -> TestTree -> b
foldTestTree
        TreeFold (Ap (Reader Int) TestOutput)
forall b. Monoid b => TreeFold b
trivialFold
          { foldSingle :: forall t.
IsTest t =>
OptionSet -> String -> t -> Ap (Reader Int) TestOutput
foldSingle = forall t.
(IsTest t, ?colors::Bool) =>
OptionSet -> String -> t -> Ap (Reader Int) TestOutput
forall t.
IsTest t =>
OptionSet -> String -> t -> Ap (Reader Int) TestOutput
handleSingleTest
          , foldGroup :: OptionSet
-> String
-> Ap (Reader Int) TestOutput
-> Ap (Reader Int) TestOutput
foldGroup = OptionSet
-> String
-> Ap (Reader Int) TestOutput
-> Ap (Reader Int) TestOutput
handleGroup
          }
          OptionSet
opts TestTree
tree

printTestOutput :: (?colors :: Bool) => String -> TestName -> Result -> IO Statistics
printTestOutput :: String -> String -> Result -> IO Statistics
printTestOutput String
prefix String
name Result
result = case Result -> Outcome
resultOutcome Result
result of
  Failure (TestThrewException SomeException
e) ->
    case SomeException -> Maybe FancyTestException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
      Just (Mismatch (GRNoGolden Identity a
a a -> IO GShow
shw Maybe (a -> IO ())
_)) -> do
        (?colors::Bool) => String -> IO ()
String -> IO ()
infoFail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> ShowS
forall r. PrintfType r => String -> r
printf String
"%sActual value is:\n" String
prefix
        let a' :: a
a' = Identity a -> a
forall a. Identity a -> a
runIdentity Identity a
a
        GShow
shw' <- a -> IO GShow
shw a
a'
        IO ()
hsep
        String -> GShow -> IO ()
printValue String
name GShow
shw'
        IO ()
hsep
        Statistics -> IO Statistics
forall (m :: * -> *) a. Monad m => a -> m a
return ( Statistics
forall a. Monoid a => a
mempty { statFailures :: Int
statFailures = Int
1 } )
      Just (Mismatch (GRDifferent a
_ a
_ GDiff
diff Maybe (a -> IO ())
_)) -> do
        (?colors::Bool) => String -> IO ()
String -> IO ()
infoFail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> ShowS
forall r. PrintfType r => String -> r
printf String
"%sDiff between actual and golden value:\n" String
prefix
        IO ()
hsep
        String -> GDiff -> IO ()
printDiff String
name GDiff
diff
        IO ()
hsep
        Statistics -> IO Statistics
forall (m :: * -> *) a. Monad m => a -> m a
return ( Statistics
forall a. Monoid a => a
mempty { statFailures :: Int
statFailures = Int
1 } )
      Just (Mismatch GoldenResultI
_) -> String -> IO Statistics
forall a. HasCallStack => String -> a
error String
"Impossible case!"
      Just FancyTestException
Disabled -> Statistics -> IO Statistics
forall (m :: * -> *) a. Monad m => a -> m a
return ( Statistics
forall a. Monoid a => a
mempty { statDisabled :: Int
statDisabled = Int
1 } )
      Maybe FancyTestException
Nothing -> Statistics -> IO Statistics
forall (m :: * -> *) a. Monad m => a -> m a
return ( Statistics
forall a. Monoid a => a
mempty { statFailures :: Int
statFailures = Int
1 } )
  Failure FailureReason
_ -> Statistics -> IO Statistics
forall (m :: * -> *) a. Monad m => a -> m a
return ( Statistics
forall a. Monoid a => a
mempty { statFailures :: Int
statFailures = Int
1 } )
  Outcome
Success -> Statistics -> IO Statistics
forall (m :: * -> *) a. Monad m => a -> m a
return ( Statistics
forall a. Monoid a => a
mempty { statSuccesses :: Int
statSuccesses = Int
1 } )

hsep :: IO ()
hsep :: IO ()
hsep = String -> IO ()
putStrLn (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
40 Char
'=')

foldTestOutput
  :: (?colors :: Bool, Monoid b)
  => (IO () -> IO Result
    -> (Result -> IO Statistics)
    -> b)
  -> (IO () -> b -> b)
  -> TestOutput -> StatusMap -> b
foldTestOutput :: (IO () -> IO Result -> (Result -> IO Statistics) -> b)
-> (IO () -> b -> b) -> TestOutput -> StatusMap -> b
foldTestOutput IO () -> IO Result -> (Result -> IO Statistics) -> b
foldTest IO () -> b -> b
foldHeading TestOutput
outputTree StatusMap
smap =
  (State Int b -> Int -> b) -> Int -> State Int b -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip State Int b -> Int -> b
forall s a. State s a -> s -> a
evalState Int
0 (State Int b -> b) -> State Int b -> b
forall a b. (a -> b) -> a -> b
$ Ap (StateT Int Identity) b -> State Int b
forall (f :: * -> *) a. Ap f a -> f a
getApp (Ap (StateT Int Identity) b -> State Int b)
-> Ap (StateT Int Identity) b -> State Int b
forall a b. (a -> b) -> a -> b
$ TestOutput -> Ap (StateT Int Identity) b
forall (f :: * -> *). MonadState Int f => TestOutput -> Ap f b
go TestOutput
outputTree where
  go :: TestOutput -> Ap f b
go (HandleTest String
_ IO ()
printName Result -> IO Statistics
handleResult) = f b -> Ap f b
forall (f :: * -> *) a. f a -> Ap f a
Ap (f b -> Ap f b) -> f b -> Ap f b
forall a b. (a -> b) -> a -> b
$ do
    Int
ix <- f Int
forall s (m :: * -> *). MonadState s m => m s
get
    Int -> f ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Int -> f ()) -> Int -> f ()
forall a b. (a -> b) -> a -> b
$! Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
    let
      statusVar :: TVar Status
statusVar =
        TVar Status -> Maybe (TVar Status) -> TVar Status
forall a. a -> Maybe a -> a
fromMaybe (String -> TVar Status
forall a. HasCallStack => String -> a
error String
"internal error: index out of bounds") (Maybe (TVar Status) -> TVar Status)
-> Maybe (TVar Status) -> TVar Status
forall a b. (a -> b) -> a -> b
$
        Int -> StatusMap -> Maybe (TVar Status)
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
ix StatusMap
smap
      readStatusVar :: IO Result
readStatusVar = TVar Status -> IO Result
getResultFromTVar TVar Status
statusVar
    b -> f b
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> f b) -> b -> f b
forall a b. (a -> b) -> a -> b
$ IO () -> IO Result -> (Result -> IO Statistics) -> b
foldTest IO ()
printName IO Result
readStatusVar Result -> IO Statistics
handleResult
  go (PrintHeading IO ()
printName TestOutput
printBody) = f b -> Ap f b
forall (f :: * -> *) a. f a -> Ap f a
Ap (f b -> Ap f b) -> f b -> Ap f b
forall a b. (a -> b) -> a -> b
$
    IO () -> b -> b
foldHeading IO ()
printName (b -> b) -> f b -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ap f b -> f b
forall (f :: * -> *) a. Ap f a -> f a
getApp (TestOutput -> Ap f b
go TestOutput
printBody)
  go (Seq TestOutput
a TestOutput
b) = Ap f b -> Ap f b -> Ap f b
forall a. Monoid a => a -> a -> a
mappend (TestOutput -> Ap f b
go TestOutput
a) (TestOutput -> Ap f b
go TestOutput
b)
  go TestOutput
Skip = Ap f b
forall a. Monoid a => a
mempty

-- }}}

--------------------------------------------------
-- TestOutput modes
--------------------------------------------------
-- {{{
consoleOutput :: (?colors :: Bool) => TestOutput -> StatusMap -> IO Statistics
consoleOutput :: TestOutput -> StatusMap -> IO Statistics
consoleOutput TestOutput
outp StatusMap
smap =
  Ap IO Statistics -> IO Statistics
forall (f :: * -> *) a. Ap f a -> f a
getApp (Ap IO Statistics -> IO Statistics)
-> ((Ap IO Statistics, Any) -> Ap IO Statistics)
-> (Ap IO Statistics, Any)
-> IO Statistics
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ap IO Statistics, Any) -> Ap IO Statistics
forall a b. (a, b) -> a
fst ((Ap IO Statistics, Any) -> IO Statistics)
-> (Ap IO Statistics, Any) -> IO Statistics
forall a b. (a -> b) -> a -> b
$ (IO ()
 -> IO Result
 -> (Result -> IO Statistics)
 -> (Ap IO Statistics, Any))
-> (IO () -> (Ap IO Statistics, Any) -> (Ap IO Statistics, Any))
-> TestOutput
-> StatusMap
-> (Ap IO Statistics, Any)
forall b.
(?colors::Bool, Monoid b) =>
(IO () -> IO Result -> (Result -> IO Statistics) -> b)
-> (IO () -> b -> b) -> TestOutput -> StatusMap -> b
foldTestOutput IO ()
-> IO Result
-> (Result -> IO Statistics)
-> (Ap IO Statistics, Any)
forall (f :: * -> *) a t a.
Monad f =>
f a -> f t -> (t -> f a) -> (Ap f a, Any)
foldTest IO () -> (Ap IO Statistics, Any) -> (Ap IO Statistics, Any)
forall (f :: * -> *) a.
Monad f =>
f () -> (Ap f a, Any) -> (Ap f a, Any)
foldHeading TestOutput
outp StatusMap
smap
  where
    foldTest :: f a -> f t -> (t -> f a) -> (Ap f a, Any)
foldTest f a
printName f t
getResult t -> f a
handleResult =
      (f a -> Ap f a
forall (f :: * -> *) a. f a -> Ap f a
Ap (f a -> Ap f a) -> f a -> Ap f a
forall a b. (a -> b) -> a -> b
$ do
        a
_ <- f a
printName
        t
r <- f t
getResult
        t -> f a
handleResult t
r
      , Bool -> Any
Any Bool
True)
    foldHeading :: f () -> (Ap f a, Any) -> (Ap f a, Any)
foldHeading f ()
printHeading (Ap f a
printBody, Any Bool
nonempty) =
      (f a -> Ap f a
forall (f :: * -> *) a. f a -> Ap f a
Ap (f a -> Ap f a) -> f a -> Ap f a
forall a b. (a -> b) -> a -> b
$ do
        Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
nonempty (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$ f ()
printHeading
        a
stats <- Ap f a -> f a
forall (f :: * -> *) a. Ap f a -> f a
getApp Ap f a
printBody
        a -> f a
forall (m :: * -> *) a. Monad m => a -> m a
return a
stats
      , Bool -> Any
Any Bool
nonempty )

consoleOutputHidingSuccesses :: (?colors :: Bool) => TestOutput -> StatusMap -> IO Statistics
consoleOutputHidingSuccesses :: TestOutput -> StatusMap -> IO Statistics
consoleOutputHidingSuccesses TestOutput
outp StatusMap
smap =
  (Any, Statistics) -> Statistics
forall a b. (a, b) -> b
snd ((Any, Statistics) -> Statistics)
-> IO (Any, Statistics) -> IO Statistics
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ap IO (Any, Statistics) -> IO (Any, Statistics)
forall (f :: * -> *) a. Ap f a -> f a
getApp (Ap IO (Any, Statistics) -> IO (Any, Statistics))
-> Ap IO (Any, Statistics) -> IO (Any, Statistics)
forall a b. (a -> b) -> a -> b
$ (IO ()
 -> IO Result
 -> (Result -> IO Statistics)
 -> Ap IO (Any, Statistics))
-> (IO () -> Ap IO (Any, Statistics) -> Ap IO (Any, Statistics))
-> TestOutput
-> StatusMap
-> Ap IO (Any, Statistics)
forall b.
(?colors::Bool, Monoid b) =>
(IO () -> IO Result -> (Result -> IO Statistics) -> b)
-> (IO () -> b -> b) -> TestOutput -> StatusMap -> b
foldTestOutput IO ()
-> IO Result
-> (Result -> IO Statistics)
-> Ap IO (Any, Statistics)
forall a.
IO a
-> IO Result
-> (Result -> IO Statistics)
-> Ap IO (Any, Statistics)
foldTest IO () -> Ap IO (Any, Statistics) -> Ap IO (Any, Statistics)
forall a b. IO a -> Ap IO (Any, b) -> Ap IO (Any, b)
foldHeading TestOutput
outp StatusMap
smap)
  where
    foldTest :: IO a
-> IO Result
-> (Result -> IO Statistics)
-> Ap IO (Any, Statistics)
foldTest IO a
printName IO Result
getResult Result -> IO Statistics
handleResult =
      IO (Any, Statistics) -> Ap IO (Any, Statistics)
forall (f :: * -> *) a. f a -> Ap f a
Ap (IO (Any, Statistics) -> Ap IO (Any, Statistics))
-> IO (Any, Statistics) -> Ap IO (Any, Statistics)
forall a b. (a -> b) -> a -> b
$ do
          a
_ <- IO a
printName
          Result
r <- IO Result
getResult
          if Result -> Bool
resultSuccessful Result
r
            then do
                IO ()
clearThisLine
                (Any, Statistics) -> IO (Any, Statistics)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Any
Any Bool
False, Statistics
forall a. Monoid a => a
mempty { statSuccesses :: Int
statSuccesses = Int
1 })
            else do
                Statistics
stats <- Result -> IO Statistics
handleResult Result
r
                (Any, Statistics) -> IO (Any, Statistics)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Any
Any Bool
True, Statistics
stats)

    foldHeading :: IO a -> Ap IO (Any, b) -> Ap IO (Any, b)
foldHeading IO a
printHeading Ap IO (Any, b)
printBody =
      IO (Any, b) -> Ap IO (Any, b)
forall (f :: * -> *) a. f a -> Ap f a
Ap (IO (Any, b) -> Ap IO (Any, b)) -> IO (Any, b) -> Ap IO (Any, b)
forall a b. (a -> b) -> a -> b
$ do
        a
_ <- IO a
printHeading
        b :: (Any, b)
b@(Any Bool
failed, b
_) <- Ap IO (Any, b) -> IO (Any, b)
forall (f :: * -> *) a. Ap f a -> f a
getApp Ap IO (Any, b)
printBody
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
failed IO ()
clearAboveLine
        (Any, b) -> IO (Any, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Any, b)
b

    clearAboveLine :: IO ()
clearAboveLine = do Int -> IO ()
cursorUpLine Int
1; IO ()
clearThisLine
    clearThisLine :: IO ()
clearThisLine = do IO ()
clearLine; Int -> IO ()
setCursorColumn Int
0

streamOutputHidingSuccesses :: (?colors :: Bool) => TestOutput -> StatusMap -> IO Statistics
streamOutputHidingSuccesses :: TestOutput -> StatusMap -> IO Statistics
streamOutputHidingSuccesses TestOutput
outp StatusMap
smap =
  (Any, Statistics) -> Statistics
forall a b. (a, b) -> b
snd ((Any, Statistics) -> Statistics)
-> IO (Any, Statistics) -> IO Statistics
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((StateT [IO ()] IO (Any, Statistics)
 -> [IO ()] -> IO (Any, Statistics))
-> [IO ()]
-> StateT [IO ()] IO (Any, Statistics)
-> IO (Any, Statistics)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT [IO ()] IO (Any, Statistics)
-> [IO ()] -> IO (Any, Statistics)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT [] (StateT [IO ()] IO (Any, Statistics) -> IO (Any, Statistics))
-> (Ap (StateT [IO ()] IO) (Any, Statistics)
    -> StateT [IO ()] IO (Any, Statistics))
-> Ap (StateT [IO ()] IO) (Any, Statistics)
-> IO (Any, Statistics)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ap (StateT [IO ()] IO) (Any, Statistics)
-> StateT [IO ()] IO (Any, Statistics)
forall (f :: * -> *) a. Ap f a -> f a
getApp (Ap (StateT [IO ()] IO) (Any, Statistics) -> IO (Any, Statistics))
-> Ap (StateT [IO ()] IO) (Any, Statistics) -> IO (Any, Statistics)
forall a b. (a -> b) -> a -> b
$
    (IO ()
 -> IO Result
 -> (Result -> IO Statistics)
 -> Ap (StateT [IO ()] IO) (Any, Statistics))
-> (IO ()
    -> Ap (StateT [IO ()] IO) (Any, Statistics)
    -> Ap (StateT [IO ()] IO) (Any, Statistics))
-> TestOutput
-> StatusMap
-> Ap (StateT [IO ()] IO) (Any, Statistics)
forall b.
(?colors::Bool, Monoid b) =>
(IO () -> IO Result -> (Result -> IO Statistics) -> b)
-> (IO () -> b -> b) -> TestOutput -> StatusMap -> b
foldTestOutput IO ()
-> IO Result
-> (Result -> IO Statistics)
-> Ap (StateT [IO ()] IO) (Any, Statistics)
forall a (f :: * -> *) a.
(MonadState [IO a] f, MonadIO f) =>
IO a
-> IO Result -> (Result -> IO Statistics) -> Ap f (Any, Statistics)
foldTest IO ()
-> Ap (StateT [IO ()] IO) (Any, Statistics)
-> Ap (StateT [IO ()] IO) (Any, Statistics)
forall a (f :: * -> *) b.
MonadState [a] f =>
a -> Ap f (Any, b) -> Ap f (Any, b)
foldHeading TestOutput
outp StatusMap
smap)
  where
    foldTest :: IO a
-> IO Result -> (Result -> IO Statistics) -> Ap f (Any, Statistics)
foldTest IO a
printName IO Result
getResult Result -> IO Statistics
handleResult =
      f (Any, Statistics) -> Ap f (Any, Statistics)
forall (f :: * -> *) a. f a -> Ap f a
Ap (f (Any, Statistics) -> Ap f (Any, Statistics))
-> f (Any, Statistics) -> Ap f (Any, Statistics)
forall a b. (a -> b) -> a -> b
$ do
          Result
r <- IO Result -> f Result
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Result -> f Result) -> IO Result -> f Result
forall a b. (a -> b) -> a -> b
$ IO Result
getResult
          if Result -> Bool
resultSuccessful Result
r
            then (Any, Statistics) -> f (Any, Statistics)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Any
Any Bool
False, Statistics
forall a. Monoid a => a
mempty { statSuccesses :: Int
statSuccesses = Int
1 })
            else do
              [IO a]
stack <- f [IO a]
forall s (m :: * -> *). MonadState s m => m s
get
              [IO a] -> f ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put []

              Statistics
stats <- IO Statistics -> f Statistics
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Statistics -> f Statistics) -> IO Statistics -> f Statistics
forall a b. (a -> b) -> a -> b
$ do
                [IO a] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([IO a] -> IO ()) -> [IO a] -> IO ()
forall a b. (a -> b) -> a -> b
$ [IO a] -> [IO a]
forall a. [a] -> [a]
reverse [IO a]
stack
                a
_ <- IO a
printName
                Result -> IO Statistics
handleResult Result
r

              (Any, Statistics) -> f (Any, Statistics)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Any
Any Bool
True, Statistics
stats)

    foldHeading :: a -> Ap f (Any, b) -> Ap f (Any, b)
foldHeading a
printHeading Ap f (Any, b)
printBody =
      f (Any, b) -> Ap f (Any, b)
forall (f :: * -> *) a. f a -> Ap f a
Ap (f (Any, b) -> Ap f (Any, b)) -> f (Any, b) -> Ap f (Any, b)
forall a b. (a -> b) -> a -> b
$ do
        ([a] -> [a]) -> f ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (a
printHeading a -> [a] -> [a]
forall a. a -> [a] -> [a]
:)
        b :: (Any, b)
b@(Any Bool
failed, b
_) <- Ap f (Any, b) -> f (Any, b)
forall (f :: * -> *) a. Ap f a -> f a
getApp Ap f (Any, b)
printBody
        Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
failed (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$
          ([a] -> [a]) -> f ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (([a] -> [a]) -> f ()) -> ([a] -> [a]) -> f ()
forall a b. (a -> b) -> a -> b
$ \[a]
stack ->
            case [a]
stack of
              a
_:[a]
rest -> [a]
rest
              [] -> [] -- shouldn't happen anyway
        (Any, b) -> f (Any, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Any, b)
b

-- }}}

--------------------------------------------------
-- Statistics
--------------------------------------------------
-- {{{

data Statistics = Statistics
  { Statistics -> Int
statSuccesses :: !Int
  , Statistics -> Int
statUpdatedGolden :: !Int
  , Statistics -> Int
statCreatedGolden :: !Int
  , Statistics -> Int
statFailures :: !Int
  , Statistics -> Int
statDisabled :: !Int
  }

instance Semigroup Statistics where
  Statistics Int
a1 Int
b1 Int
c1 Int
d1 Int
e1 <> :: Statistics -> Statistics -> Statistics
<> Statistics Int
a2 Int
b2 Int
c2 Int
d2 Int
e2 = Int -> Int -> Int -> Int -> Int -> Statistics
Statistics (Int
a1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
a2) (Int
b1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
b2) (Int
c1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
c2) (Int
d1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
d2) (Int
e1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
e2)
  

instance Monoid Statistics where
  mempty :: Statistics
mempty = Int -> Int -> Int -> Int -> Int -> Statistics
Statistics Int
0 Int
0 Int
0 Int
0 Int
0
  mappend :: Statistics -> Statistics -> Statistics
mappend = Statistics -> Statistics -> Statistics
forall a. Semigroup a => a -> a -> a
(<>)

printStatistics :: (?colors :: Bool) => Statistics -> Time -> IO ()
printStatistics :: Statistics -> Time -> IO ()
printStatistics Statistics
st Time
time = do
  String -> IO ()
forall r. PrintfType r => String -> r
printf String
"\n"

  let total :: Int
total = Statistics -> Int
statFailures Statistics
st Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Statistics -> Int
statUpdatedGolden Statistics
st Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Statistics -> Int
statCreatedGolden Statistics
st Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Statistics -> Int
statSuccesses Statistics
st

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Statistics -> Int
statCreatedGolden Statistics
st Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (String -> Int -> IO ()
forall r. PrintfType r => String -> r
printf String
"Created %d golden values.\n" (Statistics -> Int
statCreatedGolden Statistics
st))
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Statistics -> Int
statUpdatedGolden Statistics
st Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (String -> Int -> IO ()
forall r. PrintfType r => String -> r
printf String
"Updated %d golden values.\n" (Statistics -> Int
statUpdatedGolden Statistics
st))
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Statistics -> Int
statDisabled Statistics
st Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (String -> Int -> IO ()
forall r. PrintfType r => String -> r
printf String
"Ignored %d disabled tests.\n" (Statistics -> Int
statDisabled Statistics
st))

  case Statistics -> Int
statFailures Statistics
st of
    Int
0 -> do
      (?colors::Bool) => String -> IO ()
String -> IO ()
ok (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Int -> Time -> String
forall r. PrintfType r => String -> r
printf String
"All %d tests passed (%.2fs)\n" Int
total Time
time

    Int
fs -> do
      (?colors::Bool) => String -> IO ()
String -> IO ()
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Int -> Int -> Time -> String
forall r. PrintfType r => String -> r
printf String
"%d out of %d tests failed (%.2fs)\n" Int
fs Int
total Time
time

data FailureStatus
  = Unknown
  | Failed
  | OK

instance Semigroup FailureStatus where
  FailureStatus
Failed  <> :: FailureStatus -> FailureStatus -> FailureStatus
<> FailureStatus
_      = FailureStatus
Failed
  FailureStatus
_       <> FailureStatus
Failed = FailureStatus
Failed
  FailureStatus
OK      <> FailureStatus
OK     = FailureStatus
OK
  FailureStatus
_       <> FailureStatus
_      = FailureStatus
Unknown

instance Monoid FailureStatus where
  mempty :: FailureStatus
mempty = FailureStatus
OK
  mappend :: FailureStatus -> FailureStatus -> FailureStatus
mappend = FailureStatus -> FailureStatus -> FailureStatus
forall a. Semigroup a => a -> a -> a
(<>)

-- }}}

--------------------------------------------------
-- Console test reporter
--------------------------------------------------

-- | Report only failed tests
newtype HideSuccesses = HideSuccesses Bool
  deriving (HideSuccesses -> HideSuccesses -> Bool
(HideSuccesses -> HideSuccesses -> Bool)
-> (HideSuccesses -> HideSuccesses -> Bool) -> Eq HideSuccesses
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HideSuccesses -> HideSuccesses -> Bool
$c/= :: HideSuccesses -> HideSuccesses -> Bool
== :: HideSuccesses -> HideSuccesses -> Bool
$c== :: HideSuccesses -> HideSuccesses -> Bool
Eq, Eq HideSuccesses
Eq HideSuccesses
-> (HideSuccesses -> HideSuccesses -> Ordering)
-> (HideSuccesses -> HideSuccesses -> Bool)
-> (HideSuccesses -> HideSuccesses -> Bool)
-> (HideSuccesses -> HideSuccesses -> Bool)
-> (HideSuccesses -> HideSuccesses -> Bool)
-> (HideSuccesses -> HideSuccesses -> HideSuccesses)
-> (HideSuccesses -> HideSuccesses -> HideSuccesses)
-> Ord HideSuccesses
HideSuccesses -> HideSuccesses -> Bool
HideSuccesses -> HideSuccesses -> Ordering
HideSuccesses -> HideSuccesses -> HideSuccesses
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 :: HideSuccesses -> HideSuccesses -> HideSuccesses
$cmin :: HideSuccesses -> HideSuccesses -> HideSuccesses
max :: HideSuccesses -> HideSuccesses -> HideSuccesses
$cmax :: HideSuccesses -> HideSuccesses -> HideSuccesses
>= :: HideSuccesses -> HideSuccesses -> Bool
$c>= :: HideSuccesses -> HideSuccesses -> Bool
> :: HideSuccesses -> HideSuccesses -> Bool
$c> :: HideSuccesses -> HideSuccesses -> Bool
<= :: HideSuccesses -> HideSuccesses -> Bool
$c<= :: HideSuccesses -> HideSuccesses -> Bool
< :: HideSuccesses -> HideSuccesses -> Bool
$c< :: HideSuccesses -> HideSuccesses -> Bool
compare :: HideSuccesses -> HideSuccesses -> Ordering
$ccompare :: HideSuccesses -> HideSuccesses -> Ordering
$cp1Ord :: Eq HideSuccesses
Ord, Typeable)
instance IsOption HideSuccesses where
  defaultValue :: HideSuccesses
defaultValue = Bool -> HideSuccesses
HideSuccesses Bool
False
  parseValue :: String -> Maybe HideSuccesses
parseValue = (Bool -> HideSuccesses) -> Maybe Bool -> Maybe HideSuccesses
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> HideSuccesses
HideSuccesses (Maybe Bool -> Maybe HideSuccesses)
-> (String -> Maybe Bool) -> String -> Maybe HideSuccesses
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe Bool
forall a. Read a => String -> Maybe a
safeRead
  optionName :: Tagged HideSuccesses String
optionName = String -> Tagged HideSuccesses String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"hide-successes"
  optionHelp :: Tagged HideSuccesses String
optionHelp = String -> Tagged HideSuccesses String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"Do not print tests that passed successfully"
  optionCLParser :: Parser HideSuccesses
optionCLParser = Maybe Char -> HideSuccesses -> Parser HideSuccesses
forall v. IsOption v => Maybe Char -> v -> Parser v
flagCLParser Maybe Char
forall a. Maybe a
Nothing (Bool -> HideSuccesses
HideSuccesses Bool
True)

newtype AnsiTricks = AnsiTricks Bool
   deriving Typeable

instance IsOption AnsiTricks where
  defaultValue :: AnsiTricks
defaultValue = Bool -> AnsiTricks
AnsiTricks Bool
True
  parseValue :: String -> Maybe AnsiTricks
parseValue = (Bool -> AnsiTricks) -> Maybe Bool -> Maybe AnsiTricks
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> AnsiTricks
AnsiTricks (Maybe Bool -> Maybe AnsiTricks)
-> (String -> Maybe Bool) -> String -> Maybe AnsiTricks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe Bool
safeReadBool
  optionName :: Tagged AnsiTricks String
optionName = String -> Tagged AnsiTricks String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"ansi-tricks"
  optionHelp :: Tagged AnsiTricks String
optionHelp = String -> Tagged AnsiTricks String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Tagged AnsiTricks String)
-> String -> Tagged AnsiTricks String
forall a b. (a -> b) -> a -> b
$
    -- Multiline literals don't work because of -XCPP.
    String
"Enable various ANSI terminal tricks. " String -> ShowS
forall a. [a] -> [a] -> [a]
++
    String
"Can be set to 'true' (default) or 'false'."

-- | When to use color on the output
data UseColor
  = Never | Always | Auto
  deriving (UseColor -> UseColor -> Bool
(UseColor -> UseColor -> Bool)
-> (UseColor -> UseColor -> Bool) -> Eq UseColor
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UseColor -> UseColor -> Bool
$c/= :: UseColor -> UseColor -> Bool
== :: UseColor -> UseColor -> Bool
$c== :: UseColor -> UseColor -> Bool
Eq, Eq UseColor
Eq UseColor
-> (UseColor -> UseColor -> Ordering)
-> (UseColor -> UseColor -> Bool)
-> (UseColor -> UseColor -> Bool)
-> (UseColor -> UseColor -> Bool)
-> (UseColor -> UseColor -> Bool)
-> (UseColor -> UseColor -> UseColor)
-> (UseColor -> UseColor -> UseColor)
-> Ord UseColor
UseColor -> UseColor -> Bool
UseColor -> UseColor -> Ordering
UseColor -> UseColor -> UseColor
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 :: UseColor -> UseColor -> UseColor
$cmin :: UseColor -> UseColor -> UseColor
max :: UseColor -> UseColor -> UseColor
$cmax :: UseColor -> UseColor -> UseColor
>= :: UseColor -> UseColor -> Bool
$c>= :: UseColor -> UseColor -> Bool
> :: UseColor -> UseColor -> Bool
$c> :: UseColor -> UseColor -> Bool
<= :: UseColor -> UseColor -> Bool
$c<= :: UseColor -> UseColor -> Bool
< :: UseColor -> UseColor -> Bool
$c< :: UseColor -> UseColor -> Bool
compare :: UseColor -> UseColor -> Ordering
$ccompare :: UseColor -> UseColor -> Ordering
$cp1Ord :: Eq UseColor
Ord, Typeable)

-- | Control color output
instance IsOption UseColor where
  defaultValue :: UseColor
defaultValue = UseColor
Auto
  parseValue :: String -> Maybe UseColor
parseValue = String -> Maybe UseColor
parseUseColor
  optionName :: Tagged UseColor String
optionName = String -> Tagged UseColor String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"color"
  optionHelp :: Tagged UseColor String
optionHelp = String -> Tagged UseColor String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"When to use colored output. Options are 'never', 'always' and 'auto' (default: 'auto')"
  optionCLParser :: Parser UseColor
optionCLParser =
    ReadM UseColor -> Mod OptionFields UseColor -> Parser UseColor
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM UseColor
parse
      (  String -> Mod OptionFields UseColor
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
name
      Mod OptionFields UseColor
-> Mod OptionFields UseColor -> Mod OptionFields UseColor
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields UseColor
forall (f :: * -> *) a. String -> Mod f a
help (Tagged UseColor String -> String
forall k (s :: k) b. Tagged s b -> b
untag (Tagged UseColor String
forall v. IsOption v => Tagged v String
optionHelp :: Tagged UseColor String))
      )
    where
      name :: String
name = Tagged UseColor String -> String
forall k (s :: k) b. Tagged s b -> b
untag (Tagged UseColor String
forall v. IsOption v => Tagged v String
optionName :: Tagged UseColor String)
      parse :: ReadM UseColor
parse = ReadM String
forall s. IsString s => ReadM s
str ReadM String -> (String -> ReadM UseColor) -> ReadM UseColor
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
        ReadM UseColor
-> (UseColor -> ReadM UseColor) -> Maybe UseColor -> ReadM UseColor
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> ReadM UseColor
forall a. String -> ReadM a
readerError (String -> ReadM UseColor) -> String -> ReadM UseColor
forall a b. (a -> b) -> a -> b
$ String
"Could not parse " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name) UseColor -> ReadM UseColor
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe UseColor -> ReadM UseColor)
-> (String -> Maybe UseColor) -> String -> ReadM UseColor
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe UseColor
forall v. IsOption v => String -> Maybe v
parseValue

-- | @useColor when isTerm@ decides if colors should be used,
--   where @isTerm@ denotes where @stdout@ is a terminal device.
useColor :: UseColor -> Bool -> Bool
useColor :: UseColor -> Bool -> Bool
useColor UseColor
cond Bool
isTerm =
  case UseColor
cond of
    UseColor
Never  -> Bool
False
    UseColor
Always -> Bool
True
    UseColor
Auto   -> Bool
isTerm

parseUseColor :: String -> Maybe UseColor
parseUseColor :: String -> Maybe UseColor
parseUseColor String
s =
  case (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
s of
    String
"never"  -> UseColor -> Maybe UseColor
forall (m :: * -> *) a. Monad m => a -> m a
return UseColor
Never
    String
"always" -> UseColor -> Maybe UseColor
forall (m :: * -> *) a. Monad m => a -> m a
return UseColor
Always
    String
"auto"   -> UseColor -> Maybe UseColor
forall (m :: * -> *) a. Monad m => a -> m a
return UseColor
Auto
    String
_        -> Maybe UseColor
forall a. Maybe a
Nothing

-- }}}

--------------------------------------------------
-- Various utilities
--------------------------------------------------
-- {{{

{-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, RMismatch g)
    Just g@(GRNoGolden {})  -> return (r, RMismatch g)
    _ | resultSuccessful r  -> return (r, RPass)
    _ | resultOutcome r
    _ | otherwise           -> return (r, RFail)
  where statusVar =
            fromMaybe (error "internal error: index out of bounds") $
            IntMap.lookup ix smap
-}

getResultFromTVar :: TVar Status -> IO Result
getResultFromTVar :: TVar Status -> IO Result
getResultFromTVar TVar Status
statusVar = do
  STM Result -> IO Result
forall a. STM a -> IO a
atomically (STM Result -> IO Result) -> STM Result -> IO Result
forall a b. (a -> b) -> a -> b
$ do
    Status
status <- TVar Status -> STM Status
forall a. TVar a -> STM a
readTVar TVar Status
statusVar
    case Status
status of
      Done Result
r -> Result -> STM Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
r
      Status
_ -> STM Result
forall a. STM a
retry



-- }}}

--------------------------------------------------
-- Formatting
--------------------------------------------------
-- {{{

indentSize :: Int
indentSize :: Int
indentSize = Int
2

indent :: Int -> String
indent :: Int -> String
indent Int
n = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
indentSize Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
n) Char
' '

-- handle multi-line result descriptions properly
formatDesc
  :: Int -- indent
  -> String
  -> String
formatDesc :: Int -> ShowS
formatDesc Int
n String
desc =
  let
    -- remove all trailing linebreaks
    chomped :: String
chomped = 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 -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n') ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. [a] -> [a]
reverse ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
desc

    multiline :: Bool
multiline = Char
'\n' Char -> DisabledTests
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
chomped

    -- we add a leading linebreak to the description, to start it on a new
    -- line and add an indentation
    paddedDesc :: String
paddedDesc = ((Char -> String) -> ShowS) -> String -> (Char -> String) -> String
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Char -> String) -> ShowS
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String
chomped ((Char -> String) -> String) -> (Char -> String) -> String
forall a b. (a -> b) -> a -> b
$ \Char
c ->
      if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n'
        then Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> String
indent Int
n
        else [Char
c]
  in
    if Bool
multiline
      then String
paddedDesc
      else String
chomped

data Maximum a
  = Maximum a
  | MinusInfinity

instance Ord a => Semigroup (Maximum a) where
  Maximum a
a <> :: Maximum a -> Maximum a -> Maximum a
<> Maximum a
b = a -> Maximum a
forall a. a -> Maximum a
Maximum (a
a a -> a -> a
forall a. Ord a => a -> a -> a
`max` a
b)
  Maximum a
MinusInfinity <> Maximum a
a = Maximum a
a
  Maximum a
a <> Maximum a
MinusInfinity = Maximum a
a

instance Ord a => Monoid (Maximum a) where
  mempty :: Maximum a
mempty = Maximum a
forall a. Maximum a
MinusInfinity
  mappend :: Maximum a -> Maximum a -> Maximum a
mappend = Maximum a -> Maximum a -> Maximum a
forall a. Semigroup a => a -> a -> a
(<>)


-- | Compute the amount of space needed to align "OK"s and "FAIL"s
computeAlignment :: OptionSet -> TestTree -> Int
computeAlignment :: OptionSet -> TestTree -> Int
computeAlignment OptionSet
opts =
  (Int -> Maximum Int) -> Int
forall t p. (Num t, Num p) => (t -> Maximum p) -> p
fromMonoid ((Int -> Maximum Int) -> Int)
-> (TestTree -> Int -> Maximum Int) -> TestTree -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  TreeFold (Int -> Maximum Int)
-> OptionSet -> TestTree -> Int -> Maximum Int
forall b. Monoid b => TreeFold b -> OptionSet -> TestTree -> b
foldTestTree
    TreeFold (Int -> Maximum Int)
forall b. Monoid b => TreeFold b
trivialFold
      { foldSingle :: forall t.
IsTest t =>
OptionSet -> String -> t -> Int -> Maximum Int
foldSingle = \OptionSet
_ String
name t
_ Int
level -> Int -> Maximum Int
forall a. a -> Maximum a
Maximum (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
name Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
level)
      , foldGroup :: OptionSet -> String -> (Int -> Maximum Int) -> Int -> Maximum Int
foldGroup = \OptionSet
_ String
_ Int -> Maximum Int
m -> Int -> Maximum Int
m (Int -> Maximum Int) -> (Int -> Int) -> Int -> Maximum Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
indentSize)
      }
    OptionSet
opts
  where
    fromMonoid :: (t -> Maximum p) -> p
fromMonoid t -> Maximum p
m =
      case t -> Maximum p
m t
0 of
        Maximum p
MinusInfinity -> p
0
        Maximum p
x -> p
x

-- (Potentially) colorful output
ok, warn, fail, infoOk, infoWarn, infoFail :: (?colors :: Bool) => String -> IO ()
ok :: String -> IO ()
ok       = (?colors::Bool) =>
ConsoleIntensity -> ColorIntensity -> Color -> String -> IO ()
ConsoleIntensity -> ColorIntensity -> Color -> String -> IO ()
output ConsoleIntensity
NormalIntensity ColorIntensity
Dull  Color
Green
warn :: String -> IO ()
warn     = (?colors::Bool) =>
ConsoleIntensity -> ColorIntensity -> Color -> String -> IO ()
ConsoleIntensity -> ColorIntensity -> Color -> String -> IO ()
output ConsoleIntensity
NormalIntensity ColorIntensity
Dull  Color
Yellow
fail :: String -> IO ()
fail     = (?colors::Bool) =>
ConsoleIntensity -> ColorIntensity -> Color -> String -> IO ()
ConsoleIntensity -> ColorIntensity -> Color -> String -> IO ()
output ConsoleIntensity
BoldIntensity   ColorIntensity
Vivid Color
Red
infoOk :: String -> IO ()
infoOk   = (?colors::Bool) =>
ConsoleIntensity -> ColorIntensity -> Color -> String -> IO ()
ConsoleIntensity -> ColorIntensity -> Color -> String -> IO ()
output ConsoleIntensity
NormalIntensity ColorIntensity
Dull  Color
White
infoWarn :: String -> IO ()
infoWarn = (?colors::Bool) =>
ConsoleIntensity -> ColorIntensity -> Color -> String -> IO ()
ConsoleIntensity -> ColorIntensity -> Color -> String -> IO ()
output ConsoleIntensity
NormalIntensity ColorIntensity
Dull  Color
White
infoFail :: String -> IO ()
infoFail = (?colors::Bool) =>
ConsoleIntensity -> ColorIntensity -> Color -> String -> IO ()
ConsoleIntensity -> ColorIntensity -> Color -> String -> IO ()
output ConsoleIntensity
NormalIntensity ColorIntensity
Dull  Color
Red

output
  :: (?colors :: Bool)
  => ConsoleIntensity
  -> ColorIntensity
  -> Color
  -> String
  -> IO ()
output :: ConsoleIntensity -> ColorIntensity -> Color -> String -> IO ()
output ConsoleIntensity
bold ColorIntensity
intensity Color
color String
st
  | ?colors::Bool
Bool
?colors =
    (do
      [SGR] -> IO ()
setSGR
        [ ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
intensity Color
color
        , ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
bold
        ]
      String -> IO ()
putStr String
st
    ) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` [SGR] -> IO ()
setSGR []
  | Bool
otherwise = String -> IO ()
putStr String
st

-- }}}