{-# 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
$c== :: Interactive -> Interactive -> Bool
== :: Interactive -> Interactive -> Bool
$c/= :: Interactive -> Interactive -> Bool
/= :: 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
$ccompare :: Interactive -> Interactive -> Ordering
compare :: Interactive -> Interactive -> Ordering
$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
>= :: Interactive -> Interactive -> Bool
$cmax :: Interactive -> Interactive -> Interactive
max :: Interactive -> Interactive -> Interactive
$cmin :: Interactive -> Interactive -> Interactive
min :: Interactive -> Interactive -> Interactive
Ord, Typeable)

instance IsOption Interactive where
  defaultValue :: Interactive
defaultValue   = Bool -> Interactive
Interactive Bool
False
  parseValue :: String -> Maybe Interactive
parseValue     = (Bool -> Interactive) -> Maybe Bool -> Maybe Interactive
forall a b. (a -> b) -> Maybe a -> Maybe b
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 a. a -> Tagged Interactive a
forall (m :: * -> *) a. Monad m => a -> m a
return String
"interactive"
  optionHelp :: Tagged Interactive String
optionHelp     = String -> Tagged Interactive String
forall a. a -> Tagged Interactive a
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
$c== :: ResultType -> ResultType -> Bool
== :: ResultType -> ResultType -> Bool
$c/= :: ResultType -> ResultType -> Bool
/= :: 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
$cshowsPrec :: Int -> FancyTestException -> ShowS
showsPrec :: Int -> FancyTestException -> ShowS
$cshow :: FancyTestException -> String
show :: FancyTestException -> String
$cshowList :: [FancyTestException] -> ShowS
showList :: [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 a. a -> IO a
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 = (Failure $ TestThrewException $ toException 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
        (r, 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.
        gr' <- forceGoldenResult gr
        case gr' of
            GoldenResultI
GREqual -> Result -> IO Result
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
r
            GoldenResultI
grd -> Result -> IO Result
forall a. a -> IO a
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 = (Failure $ TestThrewException $ toException $ Mismatch 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
    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) $ do

      hSetBuffering stdout NoBuffering

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

      let
        ?colors = useColor whenColor isTerm

      outp <- produceOutput opts tests

      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
      }

      return $ \Time
time -> do
            (?colors::Bool) => Statistics -> Time -> IO ()
Statistics -> Time -> IO ()
printStatistics Statistics
stats Time
time
            Bool -> IO Bool
forall a. a -> IO a
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_ :: 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
          (out, err) <- [String] -> IO (Text, Text)
callGitDiff [ String
fGold, String
fAct ]
          TIO.putStrLn err
          TIO.putStrLn 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, stdOut, 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 = (Text, Text) -> IO (Text, Text)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
stdOut, Text
stdErr)
  case 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 a. 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
      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 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 a. a -> IO a
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
    isANSI <- Handle -> IO Bool
hSupportsANSI Handle
stdout
    when isANSI showCursor
    putStr prefix
    putStr "Accept actual value as new golden value? [yn] "
    let
      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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return b
b
      loop = do
        ans <- IO String
getLine
        case ans of
          String
"y" -> do IO ()
update; Bool -> IO Bool
forall a. a -> IO a
done Bool
True
          String
"n" -> Bool -> IO Bool
forall a. a -> IO a
done Bool
False
          String
_   -> do
            String -> IO ()
putStr String
prefix
            String -> IO ()
putStrLn String
"Invalid answer."
            IO Bool
loop
    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 -> IO TestOutput
produceOutput :: (?colors::Bool) => OptionSet -> TestTree -> IO TestOutput
produceOutput OptionSet
opts TestTree
tree = do
  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
    AcceptTests Bool
accept        = OptionSet -> AcceptTests
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
    -- We always print timing in non-interactive mode
    forceTime :: Bool
forceTime = Bool -> Bool
not Bool
isInteractive
  -- In batch mode, we never use 'less' to show result.
  useLess <- if Bool
isInteractive then IO Bool
useLess else Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

  let
    handleSingleTest
      :: (IsTest t, ?colors :: Bool)
      => OptionSet -> TestName -> t -> Ap (Reader Level) 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
      level <- ReaderT Int Identity Int
forall r (m :: * -> *). MonadReader r m => m r
ask

      let
        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 a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
name) Char
' '
        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 a. [a] -> 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 =
          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
result = 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"

        possiblyAccept String
msgPass String
msgFail IO ()
update = do
          isUpd <- if Bool
isInteractive then String -> IO () -> IO Bool
tryAccept String
pref IO ()
update else do
            String -> IO ()
putStr String
pref
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
accept IO ()
update
            Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
accept
          let r =
                if Bool
isUpd
                then ( String -> Result
testPassed String
msgPass
                     , Statistics
forall a. Monoid a => a
mempty { statCreatedGolden = 1 } )
                else ( String -> Result
testFailed String
msgFail
                     , Statistics
forall a. Monoid a => a
mempty { statFailures = 1 } )
          printResultLine (fst r)
          return r

        handleTestResult Result
result = do
          (result', 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 (GRNoGolden (Identity a
a) a -> IO GShow
shw (Just a -> IO ()
upd))) -> do
                  if Bool
isInteractive then do
                    String -> IO ()
forall r. PrintfType r => String -> r
printf String
"Golden value missing. Press <enter> to show actual value.\n"
                    _ <- IO String
getLine
                    showValue name =<< shw a
                  else 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
pref
                    IO ()
hsep
                    String -> GShow -> IO ()
printValue String
name (GShow -> IO ()) -> IO GShow -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< a -> IO GShow
shw a
a
                    IO ()
hsep
                  (?colors::Bool) =>
String -> String -> IO () -> IO (Result, Statistics)
String -> String -> IO () -> IO (Result, Statistics)
possiblyAccept String
"Created golden value." String
"Golden value missing." (IO () -> IO (Result, Statistics))
-> IO () -> IO (Result, Statistics)
forall a b. (a -> b) -> a -> b
$
                    a -> IO ()
upd a
a

                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"
                  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
useLess IO ()
hsep
                  Bool -> String -> GDiff -> IO ()
showDiff_ Bool
useLess String
name GDiff
diff
                  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
useLess IO ()
hsep
                  (?colors::Bool) =>
String -> String -> IO () -> IO (Result, Statistics)
String -> String -> IO () -> IO (Result, Statistics)
possiblyAccept String
"Updated golden value." String
"Golden value does not match actual output." (IO () -> IO (Result, Statistics))
-> IO () -> IO (Result, Statistics)
forall a b. (a -> b) -> a -> b
$
                    a -> IO ()
upd a
a

                Just (Mismatch (GRDifferent a
_ a
_ GDiff
diff Maybe (a -> IO ())
Nothing)) -> do
                  (?colors::Bool) => Result -> IO ()
Result -> IO ()
printResultLine Result
result
                  (?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
pref
                  IO ()
hsep
                  String -> GDiff -> IO ()
printDiff String
name GDiff
diff
                  IO ()
hsep
                  (Result, Statistics) -> IO (Result, Statistics)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Result
testFailed String
"", Statistics
forall a. Monoid a => a
mempty { statFailures = 1 })

                Just (Mismatch GoldenResultI
_) -> String -> IO (Result, Statistics)
forall a. HasCallStack => String -> a
error String
"Impossible case!"
                Just FancyTestException
Disabled -> do
                  (?colors::Bool) => Result -> IO ()
Result -> IO ()
printResultLine Result
result
                  (Result, Statistics) -> IO (Result, Statistics)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ( Result
result
                         , Statistics
forall a. Monoid a => a
mempty { statDisabled = 1 } )
                Maybe FancyTestException
Nothing -> do
                  (?colors::Bool) => Result -> IO ()
Result -> IO ()
printResultLine Result
result
                  (Result, Statistics) -> IO (Result, Statistics)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result
result, Statistics
forall a. Monoid a => a
mempty {statFailures = 1})
            Outcome
Success -> do
              (?colors::Bool) => Result -> IO ()
Result -> IO ()
printResultLine Result
result
              (Result, Statistics) -> IO (Result, Statistics)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result
result, Statistics
forall a. Monoid a => a
mempty { statSuccesses = 1 })
            Failure FailureReason
_ -> do
              (?colors::Bool) => Result -> IO ()
Result -> IO ()
printResultLine Result
result
              (Result, Statistics) -> IO (Result, Statistics)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result
result, Statistics
forall a. Monoid a => a
mempty { statFailures = 1 })

          let result'' = Result
result' { resultTime = resultTime result }

          rDesc <- formatMessage $ resultDescription result''
          when (not $ null rDesc) $ (case getResultType 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) $
              printf "%s%s\n" pref (formatDesc (level+1) rDesc)

          return stat'

      return $ HandleTest name printTestName handleTestResult

    handleGroup :: OptionSet -> TestName -> [Ap (Reader Level) TestOutput] -> Ap (Reader Level) 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
      level <- ReaderT Int Identity Int
forall r (m :: * -> *). MonadReader r m => m r
ask
      let
        printHeading = String -> String -> String -> IO ()
forall r. PrintfType r => String -> r
printf String
"%s%s\n" (Int -> String
indent Int
level) String
name
        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 -> Reader Int TestOutput)
-> Ap (ReaderT Int Identity) TestOutput -> Reader Int TestOutput
forall a b. (a -> b) -> a -> b
$ [Ap (ReaderT Int Identity) TestOutput]
-> Ap (ReaderT Int Identity) TestOutput
forall a. Monoid a => [a] -> a
mconcat [Ap (ReaderT Int Identity) TestOutput]
grp) (Int
level Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
      return $ PrintHeading printHeading printBody


  return $ flip runReader 0 $ getApp $
      foldTestTree
        trivialFold
          { foldSingle = handleSingleTest
#if MIN_VERSION_tasty(1,5,0)
          , 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
          }
          opts tree

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
    ix <- f Int
forall s (m :: * -> *). MonadState s m => m s
get
    put $! ix + 1
    let
      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 = TVar Status -> IO Result
getResultFromTVar TVar Status
statusVar
    return $ foldTest printName readStatusVar 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
        _ <- f a
printName
        r <- getResult
        handleResult 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
        stats <- Ap f a -> f a
forall (f :: * -> *) a. Ap f a -> f a
getApp Ap f a
printBody
        return 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
          _ <- IO a
printName
          r <- getResult
          if resultSuccessful r
            then do
                clearThisLine
                return (Any False, mempty { statSuccesses = 1 })
            else do
                stats <- handleResult r
                return (Any True, 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
        _ <- IO a
printHeading
        b@(Any failed, _) <- getApp printBody
        unless failed clearAboveLine
        return 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 {f :: * -> *} {a} {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
          r <- IO Result -> f Result
forall a. IO a -> f a
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 resultSuccessful r
            then return (Any False, mempty { statSuccesses = 1 })
            else do
              stack <- get
              put []

              stats <- liftIO $ do
                sequence_ $ reverse stack
                _ <- printName
                handleResult r

              return (Any True, 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 failed, _) <- Ap f (Any, b) -> f (Any, b)
forall (f :: * -> *) a. Ap f a -> f a
getApp Ap f (Any, b)
printBody
        unless failed $
          modify $ \[a]
stack ->
            case [a]
stack of
              a
_:[a]
rest -> [a]
rest
              [] -> [] -- shouldn't happen anyway
        return 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
$c== :: HideSuccesses -> HideSuccesses -> Bool
== :: HideSuccesses -> HideSuccesses -> Bool
$c/= :: HideSuccesses -> HideSuccesses -> Bool
/= :: 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
$ccompare :: HideSuccesses -> HideSuccesses -> Ordering
compare :: HideSuccesses -> HideSuccesses -> Ordering
$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
>= :: HideSuccesses -> HideSuccesses -> Bool
$cmax :: HideSuccesses -> HideSuccesses -> HideSuccesses
max :: HideSuccesses -> HideSuccesses -> HideSuccesses
$cmin :: HideSuccesses -> HideSuccesses -> HideSuccesses
min :: HideSuccesses -> HideSuccesses -> HideSuccesses
Ord, Typeable)

instance IsOption HideSuccesses where
  defaultValue :: HideSuccesses
defaultValue   = Bool -> HideSuccesses
HideSuccesses Bool
False
  parseValue :: String -> Maybe HideSuccesses
parseValue     = (Bool -> HideSuccesses) -> Maybe Bool -> Maybe HideSuccesses
forall a b. (a -> b) -> Maybe a -> Maybe b
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 a. a -> Tagged HideSuccesses a
forall (m :: * -> *) a. Monad m => a -> m a
return String
"hide-successes"
  optionHelp :: Tagged HideSuccesses String
optionHelp     = String -> Tagged HideSuccesses String
forall a. a -> Tagged HideSuccesses a
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 a b. (a -> b) -> Maybe a -> Maybe b
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 a. a -> Tagged AnsiTricks a
forall (m :: * -> *) a. Monad m => a -> m a
return String
"ansi-tricks"
  optionHelp :: Tagged AnsiTricks String
optionHelp   = String -> Tagged AnsiTricks String
forall a. a -> Tagged AnsiTricks a
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
$c== :: UseColor -> UseColor -> Bool
== :: UseColor -> UseColor -> Bool
$c/= :: UseColor -> UseColor -> Bool
/= :: 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
$ccompare :: UseColor -> UseColor -> Ordering
compare :: UseColor -> UseColor -> Ordering
$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
>= :: UseColor -> UseColor -> Bool
$cmax :: UseColor -> UseColor -> UseColor
max :: UseColor -> UseColor -> UseColor
$cmin :: UseColor -> UseColor -> UseColor
min :: UseColor -> UseColor -> UseColor
Ord, Typeable)

-- | Control color output
instance IsOption UseColor where
  defaultValue :: UseColor
defaultValue   = UseColor
Auto
  parseValue :: String -> Maybe UseColor
parseValue     = String -> Maybe UseColor
parseUseColor
  optionName :: Tagged UseColor String
optionName     = String -> Tagged UseColor String
forall a. a -> Tagged UseColor a
forall (m :: * -> *) a. Monad m => a -> m a
return String
"color"
  optionHelp :: Tagged UseColor String
optionHelp     = String -> Tagged UseColor String
forall a. a -> Tagged UseColor a
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 a b. ReadM a -> (a -> ReadM b) -> ReadM b
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 a. a -> ReadM a
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 a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return UseColor
Never
    String
"always" -> UseColor -> Maybe UseColor
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return UseColor
Always
    String
"auto"   -> UseColor -> Maybe UseColor
forall a. a -> Maybe a
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 <- TVar Status -> STM Status
forall a. TVar a -> STM a
readTVar TVar Status
statusVar
    case status of
      Done Result
r -> Result -> STM Result
forall a. a -> STM a
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 a. Eq a => a -> [a] -> Bool
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
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)
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 = TreeFold (Int -> Maximum Int)
forall b. Monoid b => TreeFold b
trivialFold
      { foldSingle = \ OptionSet
_opts  String
name t
_test Int
level -> String -> Int -> Maximum Int
addName   String
name Int
level
      , 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 = Int -> Maximum Int
forall a. a -> Maximum a
Maximum (Int -> Maximum Int) -> Int -> Maximum Int
forall a b. (a -> b) -> a -> b
$ String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
name Int -> Int -> Int
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 = ((Int -> Maximum Int) -> Maximum Int)
-> [Int -> Maximum Int] -> Maximum Int
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Int -> Maximum Int) -> Int -> Maximum Int
forall a b. (a -> b) -> a -> b
$ (Int
level Int -> Int -> Int
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 ()
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

-- }}}