{-# 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
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
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     = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Interactive
Interactive forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => String -> Maybe a
safeRead
  optionName :: Tagged Interactive String
optionName     = forall (m :: * -> *) a. Monad m => a -> m a
return String
"interactive"
  optionHelp :: Tagged Interactive String
optionHelp     = forall (m :: * -> *) a. Monad m => a -> m a
return String
"Run tests in interactive mode."
  optionCLParser :: Parser Interactive
optionCLParser = forall v. IsOption v => Maybe Char -> v -> Parser v
flagCLParser (forall a. a -> Maybe a
Just Char
'i') (Bool -> Interactive
Interactive Bool
True)

data ResultType = RTSuccess | RTFail | RTIgnore
  deriving (ResultType -> ResultType -> Bool
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
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 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
    [ forall v. IsOption v => Proxy v -> OptionDescription
Option (forall {k} (t :: k). Proxy t
Proxy :: Proxy Interactive)
    , forall v. IsOption v => Proxy v -> OptionDescription
Option (forall {k} (t :: k). Proxy t
Proxy :: Proxy HideSuccesses)
    , forall v. IsOption v => Proxy v -> OptionDescription
Option (forall {k} (t :: k). Proxy t
Proxy :: Proxy AnsiTricks)
    , forall v. IsOption v => Proxy v -> OptionDescription
Option (forall {k} (t :: k). Proxy t
Proxy :: Proxy UseColor)
    , forall v. IsOption v => Proxy v -> OptionDescription
Option (forall {k} (t :: k). Proxy t
Proxy :: Proxy NumThreads)
    , forall v. IsOption v => Proxy v -> OptionDescription
Option (forall {k} (t :: k). Proxy t
Proxy :: Proxy ExcludeFilters)
    , forall v. IsOption v => Proxy v -> OptionDescription
Option (forall {k} (t :: k). Proxy t
Proxy :: Proxy IncludeFilters)
    , forall v. IsOption v => Proxy v -> OptionDescription
Option (forall {k} (t :: k). Proxy t
Proxy :: Proxy AcceptTests)
    ] forall a b. (a -> b) -> a -> b
$
  \OptionSet
opts TestTree
tree ->
      forall a. a -> Maybe a
Just 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 =
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (String -> Result
testFailed String
"")
    { resultOutcome :: Outcome
resultOutcome = (FailureReason -> Outcome
Failure forall a b. (a -> b) -> a -> b
$ SomeException -> FailureReason
TestThrewException forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> SomeException
toException FancyTestException
Disabled) }
runSingleTest DisabledTests
_ String
_ String
_ OptionSet
opts t
t Progress -> IO ()
cb = do
  case (forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast t
t :: Maybe Golden) of
    Maybe Golden
Nothing -> 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return Result
r
            GoldenResultI
grd -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Result
r { resultOutcome :: Outcome
resultOutcome = (FailureReason -> Outcome
Failure forall a b. (a -> b) -> a -> b
$ SomeException -> FailureReason
TestThrewException forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> SomeException
toException 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 (forall t.
IsTest t =>
DisabledTests
-> String
-> String
-> OptionSet
-> t
-> (Progress -> IO ())
-> IO Result
runSingleTest DisabledTests
dis) TestTree
tests

  forall a.
OptionSet -> TestTree -> (StatusMap -> IO (Time -> IO a)) -> IO a
launchTestTree OptionSet
opts TestTree
tests' 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) forall a b. IO a -> IO b -> IO a
`finally` IO ()
showCursor
      else IO (Time -> IO Bool)
k) forall a b. (a -> b) -> a -> b
$ do

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

      let
        whenColor :: UseColor
whenColor = forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
        HideSuccesses Bool
hideSuccesses = forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
        AnsiTricks Bool
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
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
consoleOutputHidingSuccesses TestOutput
outp StatusMap
smap
        | Bool
hideSuccesses Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isTerm ->
            (?colors::Bool) => TestOutput -> StatusMap -> IO Statistics
streamOutputHidingSuccesses TestOutput
outp StatusMap
smap
        | Bool
otherwise -> (?colors::Bool) => TestOutput -> StatusMap -> IO Statistics
consoleOutput TestOutput
outp StatusMap
smap
      }

      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \Time
time -> do
            (?colors::Bool) => Statistics -> Time -> IO ()
printStatistics Statistics
stats Time
time
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Statistics -> Int
statFailures Statistics
stats 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                   = 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) =
  forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (String -> IO Bool
doesCmdExist String
"wdiff" forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
`and2M` IO Bool
haveColorDiff) IO ()
colorDiff forall a b. (a -> b) -> a -> b
$ {-else-}
  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 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 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 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?)
            ]
      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
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
useLess 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 forall a. [a] -> [a] -> [a]
++ [String]
args) Text
T.empty
  let done :: IO (Text, Text)
done = 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
_ -> forall {m :: * -> *} {a}. MonadFail m => String -> m a
gitFailed forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (ExitCode, Text, Text)
ret
  where
  gitFailed :: String -> m a
gitFailed String
msg = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Call to `git diff` failed: " 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 = forall a b. (a -> b) -> [a] -> [b]
map 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 = forall a. Maybe a -> Bool
isJust 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 = forall (m :: * -> *). Monad m => [m Bool] -> m Bool
orM
  [ String -> IO Bool
doesCmdExist String
"colordiff"
  , forall (m :: * -> *). Monad m => [m Bool] -> m Bool
andM
    [ IO Bool
haveSh
    , forall a. IO a -> IO a
silence forall a b. (a -> b) -> a -> b
$ ExitCode -> Bool
exitCodeToBool 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
  forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> Handle -> m a) -> m a
withSystemTempFile (String
n String -> ShowS
<.> String
"golden") forall a b. (a -> b) -> a -> b
$ \ String
fGold Handle
hGold -> do
    forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> Handle -> m a) -> m a
withSystemTempFile (String
n String -> ShowS
<.> String
"actual") 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
  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-} 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") 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
_) -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (ExitCode, ByteString, ByteString)
ret
        (ExitCode, ByteString, ByteString)
_ -> 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 = 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
    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
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isANSI IO ()
hideCursor
        String -> IO ()
putStr String
prefix
        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; forall {b}. b -> IO b
done Bool
True
          String
"n" -> 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 = 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 = 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 = forall (f :: * -> *) a. f a -> Ap f a
Ap forall a b. (a -> b) -> a -> b
$ do
      Int
level <- forall r (m :: * -> *). MonadReader r m => m r
ask

      let
        align :: String
align = forall a. Int -> a -> [a]
replicate (Int
alignment forall a. Num a => a -> a -> a
- Int
indentSize forall a. Num a => a -> a -> a
* Int
level forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length String
name) Char
' '
        pref :: String
pref = Int -> String
indent Int
level forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
name) Char
' ' forall a. [a] -> [a] -> [a]
++ String
"  " forall a. [a] -> [a] -> [a]
++ String
align
        printTestName :: IO ()
printTestName =
          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 ()
ok
                ResultType
RTIgnore -> (?colors::Bool) => String -> IO ()
warn
                ResultType
RTFail -> (?colors::Bool) => 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
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Result -> Time
resultTime Result
result forall a. Ord a => a -> a -> Bool
>= Time
0.01 Bool -> Bool -> Bool
|| Bool
forceTime) forall a b. (a -> b) -> a -> b
$
            String -> IO ()
printFn (forall r. PrintfType r => String -> r
printf String
" (%.2fs)" 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 ()
printResultLine Result
result Bool
True

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

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

          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 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 ()
printResultLine Result
result Bool
False
                  Statistics
s <- (?colors::Bool) => String -> String -> Result -> IO Statistics
printTestOutput String
pref String
name Result
result
                  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
                  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' = 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 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."
                             , forall a. Monoid a => a
mempty { statCreatedGolden :: Int
statCreatedGolden = Int
1 } )
                        else ( String -> Result
testFailed String
"Golden value missing."
                             , forall a. Monoid a => a
mempty { statFailures :: Int
statFailures = Int
1 } )
                  (?colors::Bool) => Result -> Bool -> IO ()
printResultLine (forall a b. (a, b) -> a
fst (Result, Statistics)
r) Bool
False
                  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
                  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 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."
                             , forall a. Monoid a => a
mempty { statUpdatedGolden :: Int
statUpdatedGolden = Int
1 } )
                        else ( String -> Result
testFailed String
"Golden value does not match actual output."
                             , forall a. Monoid a => a
mempty { statFailures :: Int
statFailures = Int
1 } )
                  (?colors::Bool) => Result -> Bool -> IO ()
printResultLine (forall a b. (a, b) -> a
fst (Result, Statistics)
r) Bool
False
                  forall (m :: * -> *) a. Monad m => a -> m a
return (Result, Statistics)
r
                Just (Mismatch GoldenResultI
_) -> forall a. HasCallStack => String -> a
error String
"Impossible case!"
                Just FancyTestException
Disabled -> do
                  (?colors::Bool) => Result -> Bool -> IO ()
printResultLine Result
result Bool
False
                  forall (m :: * -> *) a. Monad m => a -> m a
return ( Result
result
                         , forall a. Monoid a => a
mempty { statDisabled :: Int
statDisabled = Int
1 } )
                Maybe FancyTestException
Nothing -> do
                  (?colors::Bool) => Result -> Bool -> IO ()
printResultLine Result
result Bool
False
                  forall (m :: * -> *) a. Monad m => a -> m a
return (Result
result, forall a. Monoid a => a
mempty {statFailures :: Int
statFailures = Int
1})
            Outcome
Success -> do
              (?colors::Bool) => Result -> Bool -> IO ()
printResultLine Result
result Bool
False
              forall (m :: * -> *) a. Monad m => a -> m a
return (Result
result, forall a. Monoid a => a
mempty { statSuccesses :: Int
statSuccesses = Int
1 })
            Failure FailureReason
_ -> do
              (?colors::Bool) => Result -> Bool -> IO ()
printResultLine Result
result Bool
False
              forall (m :: * -> *) a. Monad m => a -> m a
return (Result
result, 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 forall a b. (a -> b) -> a -> b
$ Result -> String
resultDescription Result
result''
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
rDesc) forall a b. (a -> b) -> a -> b
$ (case Result -> ResultType
getResultType Result
result'' of
            ResultType
RTSuccess -> (?colors::Bool) => String -> IO ()
infoOk
            ResultType
RTIgnore -> (?colors::Bool) => String -> IO ()
infoWarn
            ResultType
RTFail -> (?colors::Bool) => String -> IO ()
infoFail) forall a b. (a -> b) -> a -> b
$
              forall r. PrintfType r => String -> r
printf String
"%s%s\n" String
pref (Int -> ShowS
formatDesc (Int
levelforall a. Num a => a -> a -> a
+Int
1) String
rDesc)

          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
handleTestResultInteractive else (?colors::Bool) => Result -> IO Statistics
handleTestResult)
      forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall (f :: * -> *) a. f a -> Ap f a
Ap forall a b. (a -> b) -> a -> b
$ do
      Int
level <- forall r (m :: * -> *). MonadReader r m => m r
ask
      let
        printHeading :: IO ()
printHeading = forall r. PrintfType r => String -> r
printf String
"%s%s\n" (Int -> String
indent Int
level) String
name
        printBody :: TestOutput
printBody = forall r a. Reader r a -> r -> a
runReader (forall (f :: * -> *) a. Ap f a -> f a
getApp forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [Ap (ReaderT Int Identity) TestOutput]
grp) (Int
level forall a. Num a => a -> a -> a
+ Int
1)
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ IO () -> TestOutput -> TestOutput
PrintHeading IO ()
printHeading TestOutput
printBody

  in
    forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r a. Reader r a -> r -> a
runReader Int
0 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Ap f a -> f a
getApp forall a b. (a -> b) -> a -> b
$
      forall b. Monoid b => TreeFold b -> OptionSet -> TestTree -> b
foldTestTree
        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
handleSingleTest
#if MIN_VERSION_tasty(1,5,0)
          , foldGroup :: OptionSet
-> String
-> [Ap (ReaderT Int Identity) TestOutput]
-> Ap (ReaderT Int Identity) TestOutput
foldGroup = \ OptionSet
opts String
name [Ap (ReaderT Int Identity) TestOutput]
ts -> OptionSet
-> String
-> [Ap (ReaderT Int Identity) TestOutput]
-> Ap (ReaderT Int Identity) TestOutput
handleGroup OptionSet
opts String
name [Ap (ReaderT Int Identity) TestOutput]
ts
#else
          , foldGroup = \ opts name t  -> handleGroup opts name [t]
#endif
          }
          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 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 ()
infoFail forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
"%sActual value is:\n" String
prefix
        let a' :: 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
        forall (m :: * -> *) a. Monad m => a -> m a
return ( 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 ()
infoFail forall a b. (a -> b) -> a -> b
$ 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
        forall (m :: * -> *) a. Monad m => a -> m a
return ( forall a. Monoid a => a
mempty { statFailures :: Int
statFailures = Int
1 } )
      Just (Mismatch GoldenResultI
_) -> forall a. HasCallStack => String -> a
error String
"Impossible case!"
      Just FancyTestException
Disabled -> forall (m :: * -> *) a. Monad m => a -> m a
return ( forall a. Monoid a => a
mempty { statDisabled :: Int
statDisabled = Int
1 } )
      Maybe FancyTestException
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ( forall a. Monoid a => a
mempty { statFailures :: Int
statFailures = Int
1 } )
  Failure FailureReason
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ( forall a. Monoid a => a
mempty { statFailures :: Int
statFailures = Int
1 } )
  Outcome
Success -> forall (m :: * -> *) a. Monad m => a -> m a
return ( forall a. Monoid a => a
mempty { statSuccesses :: Int
statSuccesses = Int
1 } )

hsep :: IO ()
hsep :: IO ()
hsep = String -> IO ()
putStrLn (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 =
  forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> a
evalState Int
0 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Ap f a -> f a
getApp forall a b. (a -> b) -> a -> 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) = forall (f :: * -> *) a. f a -> Ap f a
Ap forall a b. (a -> b) -> a -> b
$ do
    Int
ix <- forall s (m :: * -> *). MonadState s m => m s
get
    forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$! Int
ix forall a. Num a => a -> a -> a
+ Int
1
    let
      statusVar :: TVar Status
statusVar =
        forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"internal error: index out of bounds") forall a b. (a -> b) -> a -> b
$
        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
    forall (m :: * -> *) a. Monad m => a -> m a
return 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) = forall (f :: * -> *) a. f a -> Ap f a
Ap forall a b. (a -> b) -> a -> b
$
    IO () -> b -> b
foldHeading IO ()
printName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Ap f a -> f a
getApp (TestOutput -> Ap f b
go TestOutput
printBody)
  go (Seq TestOutput
a TestOutput
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 = 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 =
  forall (f :: * -> *) a. Ap f a -> f a
getApp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall b.
(?colors::Bool, Monoid b) =>
(IO () -> IO Result -> (Result -> IO Statistics) -> b)
-> (IO () -> b -> b) -> TestOutput -> StatusMap -> b
foldTestOutput forall {f :: * -> *} {a} {t} {a}.
Monad f =>
f a -> f t -> (t -> f a) -> (Ap f a, Any)
foldTest 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 =
      (forall (f :: * -> *) a. f a -> Ap f a
Ap 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) =
      (forall (f :: * -> *) a. f a -> Ap f a
Ap forall a b. (a -> b) -> a -> b
$ do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
nonempty forall a b. (a -> b) -> a -> b
$ f ()
printHeading
        a
stats <- forall (f :: * -> *) a. Ap f a -> f a
getApp Ap f a
printBody
        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 =
  forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (f :: * -> *) a. Ap f a -> f a
getApp forall a b. (a -> b) -> a -> b
$ forall b.
(?colors::Bool, Monoid b) =>
(IO () -> IO Result -> (Result -> IO Statistics) -> b)
-> (IO () -> b -> b) -> TestOutput -> StatusMap -> b
foldTestOutput forall {a}.
IO a
-> IO Result
-> (Result -> IO Statistics)
-> Ap IO (Any, Statistics)
foldTest 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 =
      forall (f :: * -> *) a. f a -> Ap f a
Ap 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
                forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Any
Any Bool
False, forall a. Monoid a => a
mempty { statSuccesses :: Int
statSuccesses = Int
1 })
            else do
                Statistics
stats <- Result -> IO Statistics
handleResult Result
r
                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 =
      forall (f :: * -> *) a. f a -> Ap f a
Ap forall a b. (a -> b) -> a -> b
$ do
        a
_ <- IO a
printHeading
        b :: (Any, b)
b@(Any Bool
failed, b
_) <- forall (f :: * -> *) a. Ap f a -> f a
getApp Ap IO (Any, b)
printBody
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
failed IO ()
clearAboveLine
        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 =
  forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Ap f a -> f a
getApp forall a b. (a -> b) -> a -> b
$
    forall b.
(?colors::Bool, Monoid b) =>
(IO () -> IO Result -> (Result -> IO Statistics) -> b)
-> (IO () -> b -> b) -> TestOutput -> StatusMap -> b
foldTestOutput forall {a} {f :: * -> *} {a}.
(MonadState [IO a] f, MonadIO f) =>
IO a
-> IO Result -> (Result -> IO Statistics) -> Ap f (Any, Statistics)
foldTest 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 =
      forall (f :: * -> *) a. f a -> Ap f a
Ap forall a b. (a -> b) -> a -> b
$ do
          Result
r <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO Result
getResult
          if Result -> Bool
resultSuccessful Result
r
            then forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Any
Any Bool
False, forall a. Monoid a => a
mempty { statSuccesses :: Int
statSuccesses = Int
1 })
            else do
              [IO a]
stack <- forall s (m :: * -> *). MonadState s m => m s
get
              forall s (m :: * -> *). MonadState s m => s -> m ()
put []

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

              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 =
      forall (f :: * -> *) a. f a -> Ap f a
Ap forall a b. (a -> b) -> a -> b
$ do
        forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (a
printHeading forall a. a -> [a] -> [a]
:)
        b :: (Any, b)
b@(Any Bool
failed, b
_) <- forall (f :: * -> *) a. Ap f a -> f a
getApp Ap f (Any, b)
printBody
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
failed forall a b. (a -> b) -> a -> b
$
          forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \[a]
stack ->
            case [a]
stack of
              a
_:[a]
rest -> [a]
rest
              [] -> [] -- shouldn't happen anyway
        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 forall a. Num a => a -> a -> a
+ Int
a2) (Int
b1 forall a. Num a => a -> a -> a
+ Int
b2) (Int
c1 forall a. Num a => a -> a -> a
+ Int
c2) (Int
d1 forall a. Num a => a -> a -> a
+ Int
d2) (Int
e1 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 = 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
  forall r. PrintfType r => String -> r
printf String
"\n"

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

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Statistics -> Int
statCreatedGolden Statistics
st forall a. Ord a => a -> a -> Bool
> Int
0) (forall r. PrintfType r => String -> r
printf String
"Created %d golden values.\n" (Statistics -> Int
statCreatedGolden Statistics
st))
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Statistics -> Int
statUpdatedGolden Statistics
st forall a. Ord a => a -> a -> Bool
> Int
0) (forall r. PrintfType r => String -> r
printf String
"Updated %d golden values.\n" (Statistics -> Int
statUpdatedGolden Statistics
st))
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Statistics -> Int
statDisabled Statistics
st forall a. Ord a => a -> a -> Bool
> Int
0) (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 ()
ok forall a b. (a -> b) -> a -> b
$ 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 ()
failure forall a b. (a -> b) -> a -> b
$ 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 = forall a. Semigroup a => a -> a -> a
(<>)

-- }}}

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

-- | Report only failed tests
newtype HideSuccesses = HideSuccesses Bool
  deriving (HideSuccesses -> HideSuccesses -> Bool
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
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     = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> HideSuccesses
HideSuccesses forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => String -> Maybe a
safeRead
  optionName :: Tagged HideSuccesses String
optionName     = forall (m :: * -> *) a. Monad m => a -> m a
return String
"hide-successes"
  optionHelp :: Tagged HideSuccesses String
optionHelp     = forall (m :: * -> *) a. Monad m => a -> m a
return String
"Do not print tests that passed successfully"
  optionCLParser :: Parser HideSuccesses
optionCLParser = forall v. IsOption v => Maybe Char -> v -> Parser v
flagCLParser 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   = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> AnsiTricks
AnsiTricks forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe Bool
safeReadBool
  optionName :: Tagged AnsiTricks String
optionName   = forall (m :: * -> *) a. Monad m => a -> m a
return String
"ansi-tricks"
  optionHelp :: Tagged AnsiTricks String
optionHelp   = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
    -- Multiline literals don't work because of -XCPP.
    String
"Enable various ANSI terminal tricks. " 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
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
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     = forall (m :: * -> *) a. Monad m => a -> m a
return String
"color"
  optionHelp :: Tagged UseColor String
optionHelp     = 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 =
    forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM UseColor
parse
      (  forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
name
      forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
help (forall {k} (s :: k) b. Tagged s b -> b
untag (forall v. IsOption v => Tagged v String
optionHelp :: Tagged UseColor String))
      )
    where
      name :: String
name = forall {k} (s :: k) b. Tagged s b -> b
untag (forall v. IsOption v => Tagged v String
optionName :: Tagged UseColor String)
      parse :: ReadM UseColor
parse = forall s. IsString s => ReadM s
str forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. String -> ReadM a
readerError forall a b. (a -> b) -> a -> b
$ String
"Could not parse " forall a. [a] -> [a] -> [a]
++ String
name) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
s of
    String
"never"  -> forall (m :: * -> *) a. Monad m => a -> m a
return UseColor
Never
    String
"always" -> forall (m :: * -> *) a. Monad m => a -> m a
return UseColor
Always
    String
"auto"   -> forall (m :: * -> *) a. Monad m => a -> m a
return UseColor
Auto
    String
_        -> 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
  forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
    Status
status <- forall a. TVar a -> STM a
readTVar TVar Status
statusVar
    case Status
status of
      Done Result
r -> forall (m :: * -> *) a. Monad m => a -> m a
return Result
r
      Status
_ -> forall a. STM a
retry



-- }}}

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

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

indent :: Int -> String
indent :: Int -> String
indent Int
n = forall a. Int -> a -> [a]
replicate (Int
indentSize 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 = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
== Char
'\n') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ String
desc

    multiline :: Bool
multiline = Char
'\n' 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 = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String
chomped forall a b. (a -> b) -> a -> b
$ \Char
c ->
      if Char
c forall a. Eq a => a -> a -> Bool
== Char
'\n'
        then Char
c 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 = forall a. a -> Maximum a
Maximum (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 = forall a. Maximum a
MinusInfinity
  mappend :: Maximum a -> Maximum a -> Maximum a
mappend = 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
fromMonoid forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. Monoid b => TreeFold b -> OptionSet -> TestTree -> b
foldTestTree TreeFold (Int -> Maximum Int)
f OptionSet
opts
  where
    fromMonoid :: (Int -> Maximum Int) -> Int
    fromMonoid :: (Int -> Maximum Int) -> Int
fromMonoid Int -> Maximum Int
m =
      case Int -> Maximum Int
m Int
0 of
        Maximum Int
MinusInfinity -> Int
0
        Maximum Int
x -> Int
x

    f :: TreeFold (Int -> Maximum Int)
    f :: TreeFold (Int -> Maximum Int)
f = forall b. Monoid b => TreeFold b
trivialFold
      { foldSingle :: forall t.
IsTest t =>
OptionSet -> String -> t -> Int -> Maximum Int
foldSingle = \ OptionSet
_opts  String
name t
_test Int
level -> String -> Int -> Maximum Int
addName   String
name Int
level
      , foldGroup :: OptionSet -> String -> [Int -> Maximum Int] -> Int -> Maximum Int
foldGroup  = \ OptionSet
_opts String
_name [Int -> Maximum Int]
group Int
level -> Int -> [Int -> Maximum Int] -> Maximum Int
addIndent Int
level [Int -> Maximum Int]
group
      }

    addName :: TestName -> Int -> Maximum Int
    addName :: String -> Int -> Maximum Int
addName String
name Int
level = forall a. a -> Maximum a
Maximum forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length String
name forall a. Num a => a -> a -> a
+ Int
level

#if MIN_VERSION_tasty(1,5,0)
    addIndent :: Int -> [Int -> Maximum Int] -> Maximum Int
    addIndent :: Int -> [Int -> Maximum Int] -> Maximum Int
addIndent Int
level = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a b. (a -> b) -> a -> b
$ (Int
level forall a. Num a => a -> a -> a
+ Int
indentSize))
#else
    addIndent :: Int -> (Int -> Maximum Int) -> Maximum Int
    addIndent level = id      ($ (level + indentSize))
#endif

-- (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 ()
output ConsoleIntensity
NormalIntensity ColorIntensity
Dull  Color
Green
warn :: (?colors::Bool) => String -> IO ()
warn     = (?colors::Bool) =>
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 ()
output ConsoleIntensity
BoldIntensity   ColorIntensity
Vivid Color
Red
infoOk :: (?colors::Bool) => String -> IO ()
infoOk   = (?colors::Bool) =>
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 ()
output ConsoleIntensity
NormalIntensity ColorIntensity
Dull  Color
White
infoFail :: (?colors::Bool) => String -> IO ()
infoFail = (?colors::Bool) =>
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
?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
    ) forall a b. IO a -> IO b -> IO a
`finally` [SGR] -> IO ()
setSGR []
  | Bool
otherwise = String -> IO ()
putStr String
st

-- }}}