{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | 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
  , DisabledTests
  )
  where

import Prelude

import Control.Concurrent.STM.TVar
import Control.Exception
import Control.Monad
import Control.Monad.Identity
import Control.Monad.Reader
import Control.Monad.STM
import Control.Monad.State

import Data.Char
import Data.Maybe
import Data.Monoid    ( Any(..) )
#if !(MIN_VERSION_base(4,8,0))
import Data.Monoid    ( Monoid(..) )
#endif
import Data.Proxy
#if !(MIN_VERSION_base(4,11,0))
import Data.Semigroup ( Semigroup(..) )
#endif
import Data.Tagged
import Data.Text      ( Text )
import Data.Text.Encoding
import Data.Typeable
import qualified Data.ByteString as BS
import qualified Data.IntMap as IntMap
import qualified Data.Text as T
import qualified Data.Text.IO as TIO

import Options.Applicative hiding (Failure, Success)

import System.Console.ANSI
import System.Directory
import System.Exit
import System.FilePath
import System.IO
import System.IO.Silently (silence)
import System.IO.Temp
import System.Process
import System.Process.ByteString as PS
import qualified System.Process.Text as ProcessText

import Text.Printf

import Test.Tasty hiding (defaultMain)
import Test.Tasty.Options
import Test.Tasty.Providers
import Test.Tasty.Runners
import Test.Tasty.Silver.Filter
import Test.Tasty.Silver.Interactive.Run
import Test.Tasty.Silver.Internal

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)
        ]

-- | Option for interactive mode.

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
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 :: forall t.
IsTest t =>
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

  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 -> Bool -> Bool
useColor UseColor
whenColor Bool
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


-- | Show diff using available external tools.

printDiff :: TestName -> GDiff -> IO ()
printDiff :: String -> GDiff -> IO ()
printDiff = Bool -> String -> GDiff -> IO ()
showDiff_ Bool
False

-- | Like 'printDiff', but uses @less@ if available.

showDiff :: TestName -> GDiff -> IO ()
showDiff :: String -> GDiff -> IO ()
showDiff String
n GDiff
d = do
  Bool
useLess <- IO Bool
useLess
  Bool -> String -> GDiff -> IO ()
showDiff_ Bool
useLess String
n GDiff
d

showDiff_ :: Bool -> TestName -> GDiff -> IO ()
showDiff_ :: Bool -> String -> GDiff -> IO ()
showDiff_ Bool
_       String
_ GDiff
Equal                   = String -> IO ()
forall a. HasCallStack => String -> a
error String
"Can't show diff for equal values."
showDiff_ Bool
True    String
n (ShowDiffed Maybe String
_ Text
t)        = String -> Text -> IO ()
showInLess String
n Text
t
showDiff_ Bool
False   String
_ (ShowDiffed Maybe String
_ Text
t)        = Text -> IO ()
TIO.putStrLn Text
t
showDiff_ Bool
useLess String
n (DiffText Maybe String
_ Text
tGold Text
tAct) =
  IO Bool -> IO () -> IO () -> IO ()
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (String -> IO Bool
doesCmdExist String
"wdiff" IO Bool -> IO Bool -> IO Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
`and2M` IO Bool
haveColorDiff) IO ()
colorDiff (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ {-else-}
  IO Bool -> IO () -> IO () -> IO ()
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (String -> IO Bool
doesCmdExist String
"git") IO ()
gitDiff {-else-} IO ()
noDiff
  where

  -- Display diff using `git diff`.
  gitDiff :: IO ()
gitDiff = do
    String -> Text -> Text -> (String -> String -> IO ()) -> IO ()
withDiffEnv String
n Text
tGold Text
tAct ((String -> String -> IO ()) -> IO ())
-> (String -> String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ String
fGold String
fAct -> do
      -- Unless we use `less`, we simply call `git` directly.
      if Bool -> Bool
not Bool
useLess
        then do
          (Text
out, Text
err) <- [String] -> IO (Text, Text)
callGitDiff [ String
fGold, String
fAct ]
          Text -> IO ()
TIO.putStrLn Text
err
          Text -> IO ()
TIO.putStrLn Text
out
        else String -> IO ()
callCommand (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords
            [ String
"git"
            , [String] -> String
unwords [String]
gitDiffArgs
            , String
"--color=always"
            , ShowS
toSlashesFilename String
fGold
            , ShowS
toSlashesFilename String
fAct
            , String
"| less -r > /dev/tty"
              -- Option -r: display control characters raw (e.g. sound bell instead of printing ^G).
              -- Thus, ANSI escape sequences will be interpreted as that.
              -- /dev/tty is "terminal where process started"  ("CON" on Windows?)
            ]

  -- Display diff using `wdiff | colordiff`.
  colorDiff :: IO ()
colorDiff = do
    String -> Text -> Text -> (String -> String -> IO ()) -> IO ()
withDiffEnv String
n Text
tGold Text
tAct ((String -> String -> IO ()) -> IO ())
-> (String -> String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ String
fGold String
fAct -> do
      let cmd :: String
cmd = [String] -> String
unwords
            [ String
"wdiff"
            , ShowS
toSlashesFilename String
fGold
            , ShowS
toSlashesFilename String
fAct
            , String
"| colordiff"
              -- E.g.
            , if Bool
useLess then String
"| less -r > /dev/tty" else String
""
              -- Option -r: display control characters raw (e.g. sound bell instead of printing ^G).
              -- Thus, ANSI escape sequences will be interpreted, e.g. as coloring.
              -- /dev/tty is "terminal where process started"  ("CON" on Windows?)
            ]
      IO Bool -> IO () -> IO () -> IO ()
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (String -> IO Bool
doesCmdExist String
"colordiff")
        -- If `colordiff` is treated as executable binary, we do not indirect via `sh`,
        -- but can let the default shell do the piping for us.
        {-then-} (String -> IO ()
callCommand String
cmd)
        -- Otherwise, let `sh` do the piping for us.  (Needed e.g. for Cygwin.)
        {-else-} (String -> [String] -> IO ()
callProcess String
"sh" [ String
"-c", String
cmd ])

      -- Alt:
      --   -- We have to pipe ourselves; don't use `less` then.
      --   callProcessText "wdiff" [fGold, fAct] T.empty >>=
      --     void . callProcessText "colordiff" []
      --   -- TODO: invoke "colordiff" through callCommand

    -- Newline if we didn't go through less
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
useLess (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
""

  -- No diff tool: Simply print both golden and actual value.
  noDiff :: IO ()
noDiff = 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

-- | Call external tool @"git" 'gitDiffArgs'@ with given extra arguments, returning its output.
--   If @git diff@ prints to @stderr@ or returns a exitcode indicating failure, throw exception.

callGitDiff
  :: [String]
       -- ^ File arguments to @git diff@.
  -> IO (Text, Text)
       -- ^ @stdout@ and @stderr@ produced by the call.
callGitDiff :: [String] -> IO (Text, Text)
callGitDiff [String]
args = do
  ret :: (ExitCode, Text, Text)
ret@(ExitCode
exitcode, Text
stdOut, Text
stdErr) <-
    String -> [String] -> Text -> IO (ExitCode, Text, Text)
ProcessText.readProcessWithExitCode
      String
"git" ([String]
gitDiffArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
args) Text
T.empty
  let done :: IO (Text, Text)
done = (Text, Text) -> IO (Text, Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
stdOut, Text
stdErr)
  case ExitCode
exitcode of
    ExitCode
ExitSuccess   -> IO (Text, Text)
done
    -- With option --no-index, exitcode 1 indicates that files are different.
    ExitFailure Int
1 -> IO (Text, Text)
done
    -- Other failure codes indicate that something went wrong.
    ExitFailure Int
_ -> String -> IO (Text, Text)
forall {m :: * -> *} {a}. MonadFail m => String -> m a
gitFailed (String -> IO (Text, Text)) -> String -> IO (Text, Text)
forall a b. (a -> b) -> a -> b
$ (ExitCode, Text, Text) -> String
forall a. Show a => a -> String
show (ExitCode, Text, Text)
ret
  where
  gitFailed :: String -> m a
gitFailed String
msg = String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ String
"Call to `git diff` failed: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg

gitDiffArgs :: [String]
gitDiffArgs :: [String]
gitDiffArgs = [ String
"diff", String
"--no-index", String
"--text" ]

-- #16: filenames get mangled under Windows, backslashes disappearing.
-- We only use this function on names of tempfiles, which do not contain spaces,
-- so it should be enough to hackily replace backslashes by slashes.
-- | Turn backslashes to slashes, which can also be path separators on Windows.
toSlashesFilename :: String -> String
toSlashesFilename :: ShowS
toSlashesFilename = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Char) -> ShowS) -> (Char -> Char) -> ShowS
forall a b. (a -> b) -> a -> b
$ \ Char
c -> case Char
c of
  Char
'\\' -> Char
'/'
  Char
c    -> Char
c

-- | Look for a command on the PATH.  If @doesCmdExist cmd@, then
--   @callProcess cmd@ should be possible.
--
--   Note that there are OS-specific differences.
--   E.g. on @cygwin@, only binaries (@.exe@) are deemed to exist,
--   not scripts.  The latter also cannot be called directly with
--   @callProcess@, but need indirection via @sh -c@.
--   In particular, @colordiff@, which is a @perl@ script, is not
--   found by @doesCmdExist@ on @cygwin@.
--
--   On @macOS@, there isn't such a distinction, so @colordiff@
--   is both found by @doesCmdExist@ and can be run by @callProcess@.
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

-- | Since @colordiff@ is a script, it may not be found by 'findExecutable'
-- e.g. on Cygwin.  So we try also to find it using @which@.
haveColorDiff :: IO Bool
haveColorDiff :: IO Bool
haveColorDiff = [IO Bool] -> IO Bool
forall (m :: * -> *). Monad m => [m Bool] -> m Bool
orM
  [ String -> IO Bool
doesCmdExist String
"colordiff"
  , [IO Bool] -> IO Bool
forall (m :: * -> *). Monad m => [m Bool] -> m Bool
andM
    [ IO Bool
haveSh
    , IO Bool -> IO Bool
forall a. IO a -> IO a
silence (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ ExitCode -> Bool
exitCodeToBool (ExitCode -> Bool) -> IO ExitCode -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> IO ExitCode
rawSystem String
"which" [ String
"colordiff" ]
    ]
  ]

exitCodeToBool :: ExitCode -> Bool
exitCodeToBool :: ExitCode -> Bool
exitCodeToBool ExitCode
ExitSuccess   = Bool
True
exitCodeToBool ExitFailure{} = Bool
False

-- 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 -> Handle -> IO ()) -> IO ())
-> (String -> Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ 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 -> Handle -> IO ()) -> IO ())
-> (String -> Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ 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
  IO Bool -> IO () -> IO () -> IO ()
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifNotM IO Bool
useLess
    {-then-} (Text -> IO ()
TIO.putStrLn Text
t)
    {-else-} (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      (ExitCode, ByteString, ByteString)
ret <- CreateProcess
-> ByteString -> IO (ExitCode, ByteString, ByteString)
PS.readCreateProcessWithExitCode (String -> CreateProcess
shell String
"less > /dev/tty") (ByteString -> IO (ExitCode, ByteString, ByteString))
-> ByteString -> IO (ExitCode, ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
t
      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 ()

-- | Should we use external tool @less@ to display diffs and results?
useLess :: IO Bool
useLess :: IO Bool
useLess = [IO Bool] -> IO Bool
forall (m :: * -> *). Monad m => [m Bool] -> m Bool
andM [ Handle -> IO Bool
hIsTerminalDevice Handle
stdin, Handle -> IO Bool
hSupportsANSI Handle
stdout, String -> IO Bool
doesCmdExist String
"less" ]

-- | Is @sh@ available to take care of piping for us?
haveSh :: IO Bool
haveSh :: IO Bool
haveSh = String -> IO Bool
doesCmdExist String
"sh"

-- | Ask user whether to accept a new golden value, and run action if yes.

tryAccept
  :: String   -- ^ @prefix@ printed at the beginning of each line.
  -> IO ()    -- ^ Action to @update@ golden value.
  -> IO Bool  -- ^ Return decision whether to update the golden value.
tryAccept :: String -> IO () -> IO Bool
tryAccept String
prefix IO ()
update = do
  -- Andreas, 2021-09-18
  -- Accepting by default in batch mode is not the right thing,
  -- because CI may then falsely accept broken tests.
  --
  -- --   If terminal is non-interactive, just assume "yes" always.
  -- termIsInteractive <- hIsTerminalDevice stdin
  -- if not termIsInteractive then do
  --   putStr prefix
  --   putStr "Accepting actual value as new golden value."
  --   update
  --   return True
  -- else do
    Bool
isANSI <- Handle -> IO Bool
hSupportsANSI Handle
stdout
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isANSI IO ()
showCursor
    String -> IO ()
putStr String
prefix
    String -> IO ()
putStr String
"Accept actual value as new golden value? [yn] "
    let
      done :: b -> IO b
done b
b = do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isANSI IO ()
hideCursor
        String -> IO ()
putStr String
prefix
        b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
b
      loop :: IO Bool
loop = do
        String
ans <- IO String
getLine
        case String
ans of
          String
"y" -> do IO ()
update; Bool -> IO Bool
forall {b}. b -> IO b
done Bool
True
          String
"n" -> Bool -> IO Bool
forall {b}. b -> IO b
done Bool
False
          String
_   -> do
            String -> IO ()
putStr String
prefix
            String -> IO ()
putStrLn String
"Invalid answer."
            IO Bool
loop
    IO Bool
loop


--------------------------------------------------
-- 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 :: (?colors::Bool) => 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 :: forall t.
(IsTest t, ?colors::Bool) =>
OptionSet -> String -> t -> Ap (ReaderT Int Identity) TestOutput
handleSingleTest OptionSet
_opts String
name t
_test = Reader Int TestOutput -> Ap (ReaderT Int Identity) TestOutput
forall (f :: * -> *) a. f a -> Ap f a
Ap (Reader Int TestOutput -> Ap (ReaderT Int Identity) TestOutput)
-> Reader Int TestOutput -> Ap (ReaderT Int Identity) TestOutput
forall a b. (a -> b) -> a -> b
$ do
      Int
level <- ReaderT Int Identity 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 ()
failure
          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 -> IO () -> IO Bool
tryAccept String
pref (IO () -> IO Bool) -> IO () -> IO Bool
forall a b. (a -> b) -> a -> b
$ 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 -> IO () -> IO Bool
tryAccept String
pref (IO () -> IO Bool) -> IO () -> IO Bool
forall a b. (a -> b) -> a -> b
$ 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 (ReaderT Int Identity) TestOutput
-> Ap (ReaderT Int Identity) TestOutput
handleGroup OptionSet
_ String
name Ap (ReaderT Int Identity) TestOutput
grp = Reader Int TestOutput -> Ap (ReaderT Int Identity) TestOutput
forall (f :: * -> *) a. f a -> Ap f a
Ap (Reader Int TestOutput -> Ap (ReaderT Int Identity) TestOutput)
-> Reader Int TestOutput -> Ap (ReaderT Int Identity) TestOutput
forall a b. (a -> b) -> a -> b
$ do
      Int
level <- ReaderT Int Identity 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 (ReaderT Int Identity) TestOutput -> Reader Int TestOutput
forall (f :: * -> *) a. Ap f a -> f a
getApp Ap (ReaderT Int Identity) 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 (ReaderT Int Identity) TestOutput -> Reader Int TestOutput
forall (f :: * -> *) a. Ap f a -> f a
getApp (Ap (ReaderT Int Identity) TestOutput -> Reader Int TestOutput)
-> Ap (ReaderT Int Identity) TestOutput -> Reader Int TestOutput
forall a b. (a -> b) -> a -> b
$
      TreeFold (Ap (ReaderT Int Identity) TestOutput)
-> OptionSet -> TestTree -> Ap (ReaderT Int Identity) TestOutput
forall b. Monoid b => TreeFold b -> OptionSet -> TestTree -> b
foldTestTree
        TreeFold (Ap (ReaderT Int Identity) TestOutput)
forall b. Monoid b => TreeFold b
trivialFold
          { foldSingle :: forall t.
IsTest t =>
OptionSet -> String -> t -> Ap (ReaderT Int Identity) TestOutput
foldSingle = forall t.
(IsTest t, ?colors::Bool) =>
OptionSet -> String -> t -> Ap (ReaderT Int Identity) TestOutput
forall t.
IsTest t =>
OptionSet -> String -> t -> Ap (ReaderT Int Identity) TestOutput
handleSingleTest
          , foldGroup :: OptionSet
-> String
-> Ap (ReaderT Int Identity) TestOutput
-> Ap (ReaderT Int Identity) TestOutput
foldGroup = OptionSet
-> String
-> Ap (ReaderT Int Identity) TestOutput
-> Ap (ReaderT Int Identity) TestOutput
handleGroup
          }
          OptionSet
opts TestTree
tree

printTestOutput :: (?colors :: Bool) => String -> TestName -> Result -> IO Statistics
printTestOutput :: (?colors::Bool) => 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 :: 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) -> 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 :: (?colors::Bool) => 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 :: (?colors::Bool) => 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 :: (?colors::Bool) => 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 :: (?colors::Bool) => 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 ()
failure (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
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
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} {a}. (Num t, Num a) => (t -> Maximum a) -> a
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 a) -> a
fromMonoid t -> Maximum a
m =
      case t -> Maximum a
m t
0 of
        Maximum a
MinusInfinity -> a
0
        Maximum a
x -> a
x

-- (Potentially) colorful output
ok, warn, failure, infoOk, infoWarn, infoFail :: (?colors :: Bool) => String -> IO ()
ok :: (?colors::Bool) => String -> IO ()
ok       = (?colors::Bool) =>
ConsoleIntensity -> ColorIntensity -> Color -> String -> IO ()
ConsoleIntensity -> ColorIntensity -> Color -> String -> IO ()
output ConsoleIntensity
NormalIntensity ColorIntensity
Dull  Color
Green
warn :: (?colors::Bool) => String -> IO ()
warn     = (?colors::Bool) =>
ConsoleIntensity -> ColorIntensity -> Color -> String -> IO ()
ConsoleIntensity -> ColorIntensity -> Color -> String -> IO ()
output ConsoleIntensity
NormalIntensity ColorIntensity
Dull  Color
Yellow
failure :: (?colors::Bool) => String -> IO ()
failure  = (?colors::Bool) =>
ConsoleIntensity -> ColorIntensity -> Color -> String -> IO ()
ConsoleIntensity -> ColorIntensity -> Color -> String -> IO ()
output ConsoleIntensity
BoldIntensity   ColorIntensity
Vivid Color
Red
infoOk :: (?colors::Bool) => String -> IO ()
infoOk   = (?colors::Bool) =>
ConsoleIntensity -> ColorIntensity -> Color -> String -> IO ()
ConsoleIntensity -> ColorIntensity -> Color -> String -> IO ()
output ConsoleIntensity
NormalIntensity ColorIntensity
Dull  Color
White
infoWarn :: (?colors::Bool) => String -> IO ()
infoWarn = (?colors::Bool) =>
ConsoleIntensity -> ColorIntensity -> Color -> String -> IO ()
ConsoleIntensity -> ColorIntensity -> Color -> String -> IO ()
output ConsoleIntensity
NormalIntensity ColorIntensity
Dull  Color
White
infoFail :: (?colors::Bool) => 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 :: (?colors::Bool) =>
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

-- }}}