{-# LANGUAGE CPP #-}
{-# LANGUAGE ImplicitParams #-}

-- | 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     ( TVar, readTVar )
import Control.Exception               ( Exception(fromException, toException), finally )
import Control.Monad                   ( when, unless )
import Control.Monad.Identity          ( Identity(Identity) )
import Control.Monad.IO.Class          ( MonadIO(liftIO) )
import Control.Monad.Reader            ( Reader, runReader, MonadReader(ask) )
import Control.Monad.STM               ( atomically, retry )
import Control.Monad.State             ( MonadState(put, get), evalState, evalStateT, modify )

import Data.Char                       ( toLower )
import Data.Maybe                      ( fromMaybe, isJust )
import Data.Monoid                     ( Any(..) )
import Data.Proxy                      ( Proxy(..) )
#if !(MIN_VERSION_base(4,11,0))
import Data.Semigroup                  ( Semigroup(..) )
#endif
import Data.Tagged                     ( untag, Tagged )
import Data.Text                       ( Text )
import Data.Text.Encoding              ( encodeUtf8 )
import Data.Typeable                   ( cast )
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             ( help, long, option, str, readerError )

import System.Console.ANSI
import System.Directory                ( findExecutable )
import System.Exit                     ( ExitCode(..) )
import System.FilePath                 ( (<.>) )
import System.IO
import System.IO.Silently              ( silence )
import System.IO.Temp                  ( withSystemTempFile )
import System.Process                  ( callCommand, callProcess, rawSystem, shell )
import System.Process.ByteString as PS ( readCreateProcessWithExitCode )
import qualified System.Process.Text   as ProcessText

import Text.Printf                     ( 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)

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)

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. HasCallStack => String -> m a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
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)

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

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)

-- | 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
  | Bool
forall (x :: Symbol) a. IP x a => a
?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

-- }}}