{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
-- |
-- Stability: unstable
--
-- This is an unstable API.  Use
-- [Test.Hspec.Api.Formatters.V3](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Formatters-V3.html)
-- instead.
module Test.Hspec.Core.Formatters.V2
-- {-# WARNING "Use [Test.Hspec.Api.Formatters.V3](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Formatters-V3.html) instead." #-}
(
-- * Formatters
  silent
, checks
, specdoc
, progress
, failed_examples

-- * Implementing a custom Formatter
-- |
-- A formatter is a set of actions.  Each action is evaluated when a certain
-- situation is encountered during a test run.
--
-- Actions live in the `FormatM` monad.  It provides access to the runner state
-- and primitives for appending to the generated report.
, Formatter (..)
, Path
, Progress
, Location(..)
, Item(..)
, Result(..)
, FailureReason (..)
, FormatM
, formatterToFormat

-- ** Accessing config values
, getConfig
, getConfigValue
, FormatConfig(..)

-- ** Accessing the runner state
, getSuccessCount
, getPendingCount
, getFailCount
, getTotalCount
, getExpectedTotalCount

, FailureRecord (..)
, getFailMessages
, usedSeed

, printTimes

, Seconds(..)
, getCPUTime
, getRealTime

-- ** Appending to the generated report
, write
, writeLine
, writeTransient

-- ** Dealing with colors
, withInfoColor
, withSuccessColor
, withPendingColor
, withFailColor

, outputUnicode

, useDiff
, diffContext
, externalDiffAction
, prettyPrint
, prettyPrintFunction
, extraChunk
, missingChunk

-- ** expert mode
, unlessExpert

-- ** Helpers
, formatLocation
, Util.formatException

#ifdef TEST
, Chunk(..)
, ColorChunk(..)
#endif
) where

import           Prelude ()
import           Test.Hspec.Core.Compat
import           System.IO (hFlush, stdout)

import           Test.Hspec.Core.Util hiding (formatException)
import qualified Test.Hspec.Core.Util as Util
import           Test.Hspec.Core.Clock
import           Test.Hspec.Core.Example (Location(..), Progress)
import           Text.Printf
import           Test.Hspec.Core.Formatters.Pretty.Unicode (ushow)
import           Control.Monad.IO.Class

-- We use an explicit import list for "Test.Hspec.Formatters.Monad", to make
-- sure, that we only use the public API to implement formatters.
--
-- Everything imported here has to be re-exported, so that users can implement
-- their own formatters.
import Test.Hspec.Core.Formatters.Internal (
    Formatter(..)
  , Item(..)
  , Result(..)
  , FailureReason (..)
  , FormatM
  , formatterToFormat

  , getConfig
  , getConfigValue
  , FormatConfig(..)

  , getSuccessCount
  , getPendingCount
  , getFailCount
  , getTotalCount
  , getExpectedTotalCount

  , FailureRecord (..)
  , getFailMessages
  , usedSeed

  , printTimes
  , getCPUTime
  , getRealTime

  , write
  , writeLine
  , writeTransient

  , withInfoColor
  , withSuccessColor
  , withPendingColor
  , withFailColor

  , outputUnicode

  , useDiff
  , diffContext
  , externalDiffAction
  , prettyPrint
  , prettyPrintFunction
  , extraChunk
  , missingChunk

  , unlessExpert
  )

import           Test.Hspec.Core.Formatters.Diff

silent :: Formatter
silent :: Formatter
silent = Formatter {
  formatterStarted :: FormatM ()
formatterStarted      = FormatM ()
forall (m :: * -> *). Applicative m => m ()
pass
, formatterGroupStarted :: Path -> FormatM ()
formatterGroupStarted = \ Path
_ -> FormatM ()
forall (m :: * -> *). Applicative m => m ()
pass
, formatterGroupDone :: Path -> FormatM ()
formatterGroupDone    = \ Path
_ -> FormatM ()
forall (m :: * -> *). Applicative m => m ()
pass
, formatterProgress :: Path -> Progress -> FormatM ()
formatterProgress     = \ Path
_ Progress
_ -> FormatM ()
forall (m :: * -> *). Applicative m => m ()
pass
, formatterItemStarted :: Path -> FormatM ()
formatterItemStarted  = \ Path
_ -> FormatM ()
forall (m :: * -> *). Applicative m => m ()
pass
, formatterItemDone :: Path -> Item -> FormatM ()
formatterItemDone     = \ Path
_ Item
_ -> FormatM ()
forall (m :: * -> *). Applicative m => m ()
pass
, formatterDone :: FormatM ()
formatterDone         = FormatM ()
forall (m :: * -> *). Applicative m => m ()
pass
}

checks :: Formatter
checks :: Formatter
checks = Formatter
specdoc {
  formatterProgress = \([[Char]]
nesting, [Char]
requirement) Progress
p -> do
    [Char] -> FormatM ()
writeTransient ([Char] -> FormatM ()) -> [Char] -> FormatM ()
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
forall {t :: * -> *} {a}. Foldable t => t a -> [Char]
indentationFor [[Char]]
nesting [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
requirement [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" [" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Progress -> [Char]
forall {a} {a}. (Eq a, Num a, Show a, Show a) => (a, a) -> [Char]
formatProgress Progress
p [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"]"

, formatterItemStarted = \([[Char]]
nesting, [Char]
requirement) -> do
    [Char] -> FormatM ()
writeTransient ([Char] -> FormatM ()) -> [Char] -> FormatM ()
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
forall {t :: * -> *} {a}. Foldable t => t a -> [Char]
indentationFor [[Char]]
nesting [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
requirement [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" [ ]"

, formatterItemDone = \ ([[Char]]
nesting, [Char]
requirement) Item
item -> do
    unicode <- FormatM Bool
outputUnicode
    let fallback p
a p
b = if Bool
unicode then p
a else p
b
    uncurry (writeResult nesting requirement (itemDuration item) (itemInfo item)) $ case itemResult item of
      Success {} -> (FormatM () -> FormatM ()
forall a. FormatM a -> FormatM a
withSuccessColor, [Char] -> [Char] -> [Char]
forall {p}. p -> p -> p
fallback [Char]
"✔" [Char]
"v")
      Pending {} -> (FormatM () -> FormatM ()
forall a. FormatM a -> FormatM a
withPendingColor, [Char] -> [Char] -> [Char]
forall {p}. p -> p -> p
fallback [Char]
"‐" [Char]
"-")
      Failure {} -> (FormatM () -> FormatM ()
forall a. FormatM a -> FormatM a
withFailColor,    [Char] -> [Char] -> [Char]
forall {p}. p -> p -> p
fallback [Char]
"✘" [Char]
"x")
    case itemResult item of
      Success {} -> FormatM ()
forall (m :: * -> *). Applicative m => m ()
pass
      Failure {} -> FormatM ()
forall (m :: * -> *). Applicative m => m ()
pass
      Pending Maybe Location
_ Maybe [Char]
reason -> FormatM () -> FormatM ()
forall a. FormatM a -> FormatM a
withPendingColor (FormatM () -> FormatM ()) -> FormatM () -> FormatM ()
forall a b. (a -> b) -> a -> b
$ do
        [Char] -> [Char] -> FormatM ()
indentBy ([[Char]] -> [Char]
forall {t :: * -> *} {a}. Foldable t => t a -> [Char]
indentationFor ([Char]
"" [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
nesting)) ([Char] -> FormatM ()) -> [Char] -> FormatM ()
forall a b. (a -> b) -> a -> b
$ [Char]
"# PENDING: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char]
"No reason given" Maybe [Char]
reason
} where
    indentationFor :: t a -> [Char]
indentationFor t a
nesting = Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
nesting Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2) Char
' '

    writeResult :: [String] -> String -> Seconds -> String -> (FormatM () -> FormatM ()) -> String -> FormatM ()
    writeResult :: [[Char]]
-> [Char]
-> Seconds
-> [Char]
-> (FormatM () -> FormatM ())
-> [Char]
-> FormatM ()
writeResult [[Char]]
nesting [Char]
requirement Seconds
duration [Char]
info FormatM () -> FormatM ()
withColor [Char]
symbol = do
      shouldPrintTimes <- FormatM Bool
printTimes
      write $ indentationFor nesting ++ requirement ++ " ["
      withColor $ write symbol
      writeLine $ "]" ++ if shouldPrintTimes then times else ""
      indentBy (indentationFor ("" : nesting)) info
      where
        dt :: Int
        dt :: Int
dt = Seconds -> Int
toMilliseconds Seconds
duration

        times :: [Char]
times
          | Int
dt Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = [Char]
""
          | Bool
otherwise = [Char]
" (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
dt [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"ms)"

    formatProgress :: (a, a) -> [Char]
formatProgress (a
current, a
total)
      | a
total a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 = a -> [Char]
forall a. Show a => a -> [Char]
show a
current
      | Bool
otherwise  = a -> [Char]
forall a. Show a => a -> [Char]
show a
current [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
total

specdoc :: Formatter
specdoc :: Formatter
specdoc = Formatter
silent {

  formatterStarted = do
    writeLine ""

, formatterGroupStarted = \ ([[Char]]
nesting, [Char]
name) -> do
    [Char] -> FormatM ()
writeLine ([[Char]] -> [Char]
forall {t :: * -> *} {a}. Foldable t => t a -> [Char]
indentationFor [[Char]]
nesting [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name)

, formatterProgress = \Path
_ Progress
p -> do
    [Char] -> FormatM ()
writeTransient (Progress -> [Char]
forall {a} {a}. (Eq a, Num a, Show a, Show a) => (a, a) -> [Char]
formatProgress Progress
p)

, formatterItemDone = \([[Char]]
nesting, [Char]
requirement) Item
item -> do
    let duration :: Seconds
duration = Item -> Seconds
itemDuration Item
item
        info :: [Char]
info = Item -> [Char]
itemInfo Item
item

    case Item -> Result
itemResult Item
item of
      Result
Success -> FormatM () -> FormatM ()
forall a. FormatM a -> FormatM a
withSuccessColor (FormatM () -> FormatM ()) -> FormatM () -> FormatM ()
forall a b. (a -> b) -> a -> b
$ do
        [[Char]] -> [Char] -> Seconds -> [Char] -> FormatM ()
writeResult [[Char]]
nesting [Char]
requirement Seconds
duration [Char]
info
      Pending Maybe Location
_ Maybe [Char]
reason -> FormatM () -> FormatM ()
forall a. FormatM a -> FormatM a
withPendingColor (FormatM () -> FormatM ()) -> FormatM () -> FormatM ()
forall a b. (a -> b) -> a -> b
$ do
        [[Char]] -> [Char] -> Seconds -> [Char] -> FormatM ()
writeResult [[Char]]
nesting [Char]
requirement Seconds
duration [Char]
info
        [Char] -> [Char] -> FormatM ()
indentBy ([[Char]] -> [Char]
forall {t :: * -> *} {a}. Foldable t => t a -> [Char]
indentationFor ([Char]
"" [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
nesting)) ([Char] -> FormatM ()) -> [Char] -> FormatM ()
forall a b. (a -> b) -> a -> b
$ [Char]
"# PENDING: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char]
"No reason given" Maybe [Char]
reason
      Failure {} -> FormatM () -> FormatM ()
forall a. FormatM a -> FormatM a
withFailColor (FormatM () -> FormatM ()) -> FormatM () -> FormatM ()
forall a b. (a -> b) -> a -> b
$ do
        n <- FormatM Int
getFailCount
        writeResult nesting (requirement ++ " FAILED [" ++ show n ++ "]") duration info

, formatterDone = defaultFailedFormatter >> defaultFooter
} where
    indentationFor :: t a -> [Char]
indentationFor t a
nesting = Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
nesting Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2) Char
' '

    writeResult :: [[Char]] -> [Char] -> Seconds -> [Char] -> FormatM ()
writeResult [[Char]]
nesting [Char]
requirement (Seconds Double
duration) [Char]
info = do
      shouldPrintTimes <- FormatM Bool
printTimes
      writeLine $ indentationFor nesting ++ requirement ++ if shouldPrintTimes then times else ""
      indentBy (indentationFor ("" : nesting)) info
      where
        dt :: Int
        dt :: Int
dt = Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double
duration Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1000)

        times :: [Char]
times
          | Int
dt Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = [Char]
""
          | Bool
otherwise = [Char]
" (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
dt [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"ms)"

    formatProgress :: (a, a) -> [Char]
formatProgress (a
current, a
total)
      | a
total a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 = a -> [Char]
forall a. Show a => a -> [Char]
show a
current
      | Bool
otherwise  = a -> [Char]
forall a. Show a => a -> [Char]
show a
current [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
total

progress :: Formatter
progress :: Formatter
progress = Formatter
failed_examples {
  formatterItemDone = \ Path
_ Item
item -> do
    case Item -> Result
itemResult Item
item of
      Success{} -> FormatM () -> FormatM ()
forall a. FormatM a -> FormatM a
withSuccessColor (FormatM () -> FormatM ()) -> FormatM () -> FormatM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> FormatM ()
write [Char]
"."
      Pending{} -> FormatM () -> FormatM ()
forall a. FormatM a -> FormatM a
withPendingColor (FormatM () -> FormatM ()) -> FormatM () -> FormatM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> FormatM ()
write [Char]
"."
      Failure{} -> FormatM () -> FormatM ()
forall a. FormatM a -> FormatM a
withFailColor (FormatM () -> FormatM ()) -> FormatM () -> FormatM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> FormatM ()
write [Char]
"F"
    IO () -> FormatM ()
forall a. IO a -> FormatM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FormatM ()) -> IO () -> FormatM ()
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hFlush Handle
stdout
}

failed_examples :: Formatter
failed_examples :: Formatter
failed_examples   = Formatter
silent {
  formatterDone = defaultFailedFormatter >> defaultFooter
}

defaultFailedFormatter :: FormatM ()
defaultFailedFormatter :: FormatM ()
defaultFailedFormatter = do
  [Char] -> FormatM ()
writeLine [Char]
""

  failures <- FormatM [FailureRecord]
getFailMessages

  unless (null failures) $ do
    writeLine "Failures:"
    writeLine ""

    forM_ (zip [1..] failures) $ \(Int, FailureRecord)
x -> do
      (Int, FailureRecord) -> FormatM ()
formatFailure (Int, FailureRecord)
x
      [Char] -> FormatM ()
writeLine [Char]
""

    write "Randomized with seed " >> usedSeed >>= writeLine . show
    writeLine ""
  where
    formatFailure :: (Int, FailureRecord) -> FormatM ()
    formatFailure :: (Int, FailureRecord) -> FormatM ()
formatFailure (Int
n, FailureRecord Maybe Location
mLoc Path
path FailureReason
reason) = do
      unicode <- FormatM Bool
outputUnicode
      forM_ mLoc $ \Location
loc -> do
        FormatM () -> FormatM ()
forall a. FormatM a -> FormatM a
withInfoColor (FormatM () -> FormatM ()) -> FormatM () -> FormatM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> FormatM ()
writeLine ([Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Location -> [Char]
formatLocation Location
loc)
      write ("  " ++ show n ++ ") ")
      writeLine (formatRequirement path)
      case reason of
        FailureReason
NoReason -> FormatM ()
forall (m :: * -> *). Applicative m => m ()
pass
        Reason [Char]
err -> FormatM () -> FormatM ()
forall a. FormatM a -> FormatM a
withFailColor (FormatM () -> FormatM ()) -> FormatM () -> FormatM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> FormatM ()
indent [Char]
err
        ColorizedReason [Char]
err -> [Char] -> FormatM ()
indent [Char]
err
        ExpectedButGot Maybe [Char]
preface [Char]
expected_ [Char]
actual_ -> do
          pretty <- FormatM (Maybe ([Char] -> [Char] -> ([Char], [Char])))
prettyPrintFunction
          let
            (expected, actual) = case pretty of
              Just [Char] -> [Char] -> ([Char], [Char])
f -> [Char] -> [Char] -> ([Char], [Char])
f [Char]
expected_ [Char]
actual_
              Maybe ([Char] -> [Char] -> ([Char], [Char]))
Nothing -> ([Char]
expected_, [Char]
actual_)

          mapM_ indent preface

          b <- useDiff

          let threshold = Seconds
2 :: Seconds


          mExternalDiff <- externalDiffAction

          case mExternalDiff of
            Just [Char] -> [Char] -> IO ()
externalDiff -> do
              IO () -> FormatM ()
forall a. IO a -> FormatM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FormatM ()) -> IO () -> FormatM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
externalDiff [Char]
expected [Char]
actual

            Maybe ([Char] -> [Char] -> IO ())
Nothing -> do
              context <- FormatM (Maybe Int)
diffContext
              mchunks <- liftIO $ if b
                then timeout threshold (evaluate $ lineDiff context expected actual)
                else return Nothing

              case mchunks of
                Just [LineDiff]
chunks -> do
                  [LineDiff]
-> ([Char] -> FormatM ()) -> ([Char] -> FormatM ()) -> FormatM ()
writeDiff [LineDiff]
chunks [Char] -> FormatM ()
extraChunk [Char] -> FormatM ()
missingChunk
                Maybe [LineDiff]
Nothing -> do
                  [LineDiff]
-> ([Char] -> FormatM ()) -> ([Char] -> FormatM ()) -> FormatM ()
writeDiff [[[Char]] -> LineDiff
LinesFirst ([Char] -> [[Char]]
splitLines [Char]
expected), [[Char]] -> LineDiff
LinesSecond ([Char] -> [[Char]]
splitLines [Char]
actual)] [Char] -> FormatM ()
write [Char] -> FormatM ()
write
          where
            writeDiff :: [LineDiff] -> (String -> FormatM ()) -> (String -> FormatM ()) -> FormatM ()
            writeDiff :: [LineDiff]
-> ([Char] -> FormatM ()) -> ([Char] -> FormatM ()) -> FormatM ()
writeDiff [LineDiff]
chunks [Char] -> FormatM ()
extra [Char] -> FormatM ()
missing = do
              [Char] -> [Chunk] -> ([Char] -> FormatM ()) -> FormatM ()
writeChunks [Char]
"expected: " ([LineDiff] -> [Chunk]
expectedChunks [LineDiff]
chunks) [Char] -> FormatM ()
extra
              [Char] -> [Chunk] -> ([Char] -> FormatM ()) -> FormatM ()
writeChunks [Char]
" but got: " ([LineDiff] -> [Chunk]
actualChunks [LineDiff]
chunks) [Char] -> FormatM ()
missing

            writeChunks :: String -> [Chunk] -> (String -> FormatM ()) -> FormatM ()
            writeChunks :: [Char] -> [Chunk] -> ([Char] -> FormatM ()) -> FormatM ()
writeChunks [Char]
pre [Chunk]
chunks [Char] -> FormatM ()
colorize = do
              FormatM () -> FormatM ()
forall a. FormatM a -> FormatM a
withFailColor (FormatM () -> FormatM ()) -> FormatM () -> FormatM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> FormatM ()
write ([Char]
indentation [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
pre)
              FormatM () -> [Chunk] -> FormatM ()
go FormatM ()
forall (m :: * -> *). Applicative m => m ()
pass [Chunk]
chunks
              where
                indentation_ :: [Char]
                indentation_ :: [Char]
indentation_ = [Char]
indentation [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate ([Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
pre) Char
' '

                go :: FormatM () -> [Chunk] -> FormatM ()
                go :: FormatM () -> [Chunk] -> FormatM ()
go FormatM ()
indent_ = \ case
                  [] -> FormatM ()
forall (m :: * -> *). Applicative m => m ()
pass
                  Chunk
c : [Chunk]
cs -> do
                    FormatM ()
indent_
                    case Chunk
c of
                      Original [Char]
a -> [Char] -> FormatM ()
write [Char]
a
                      Modified [Char]
a -> [Char] -> FormatM ()
colorize [Char]
a
                      Info [Char]
text -> FormatM () -> FormatM ()
forall a. FormatM a -> FormatM a
withInfoColor (FormatM () -> FormatM ()) -> FormatM () -> FormatM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> FormatM ()
write [Char]
text
                      ModifiedChunks [ColorChunk]
xs -> [ColorChunk] -> (ColorChunk -> FormatM ()) -> FormatM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [ColorChunk]
xs ((ColorChunk -> FormatM ()) -> FormatM ())
-> (ColorChunk -> FormatM ()) -> FormatM ()
forall a b. (a -> b) -> a -> b
$ \ case
                        PlainChunk [Char]
a -> [Char] -> FormatM ()
write [Char]
a
                        ColorChunk [Char]
a -> [Char] -> FormatM ()
colorize [Char]
a
                    [Char] -> FormatM ()
write [Char]
"\n"
                    FormatM () -> [Chunk] -> FormatM ()
go ([Char] -> FormatM ()
write [Char]
indentation_) [Chunk]
cs

        Error Maybe [Char]
info SomeException
e -> do
          ([Char] -> FormatM ()) -> Maybe [Char] -> FormatM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [Char] -> FormatM ()
indent Maybe [Char]
info
          formatException <- (FormatConfig -> SomeException -> [Char])
-> FormatM (SomeException -> [Char])
forall a. (FormatConfig -> a) -> FormatM a
getConfigValue FormatConfig -> SomeException -> [Char]
formatConfigFormatException
          withFailColor . indent $ "uncaught exception: " ++ formatException e


      unlessExpert $ do
        let path_ = (if Bool
unicode then [Char] -> [Char]
ushow else [Char] -> [Char]
forall a. Show a => a -> [Char]
show) (Path -> [Char]
joinPath Path
path)
        writeLine ""
        seed <- usedSeed
        writeLine ("  To rerun use: --match " ++ path_ <> " --seed " <> show seed)
      where
        indentation :: [Char]
indentation = [Char]
"       "
        indent :: [Char] -> FormatM ()
indent = [Char] -> [Char] -> FormatM ()
indentBy [Char]
indentation

indentBy :: String -> String -> FormatM ()
indentBy :: [Char] -> [Char] -> FormatM ()
indentBy [Char]
indentation [Char]
message = do
  [[Char]] -> ([Char] -> FormatM ()) -> FormatM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Char] -> [[Char]]
lines [Char]
message) (([Char] -> FormatM ()) -> FormatM ())
-> ([Char] -> FormatM ()) -> FormatM ()
forall a b. (a -> b) -> a -> b
$ \ [Char]
line -> do
    [Char] -> FormatM ()
writeLine ([Char]
indentation [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
line)

data Chunk = Original String | Modified String | Info String | ModifiedChunks [ColorChunk]
  deriving (Chunk -> Chunk -> Bool
(Chunk -> Chunk -> Bool) -> (Chunk -> Chunk -> Bool) -> Eq Chunk
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Chunk -> Chunk -> Bool
== :: Chunk -> Chunk -> Bool
$c/= :: Chunk -> Chunk -> Bool
/= :: Chunk -> Chunk -> Bool
Eq, Int -> Chunk -> [Char] -> [Char]
[Chunk] -> [Char] -> [Char]
Chunk -> [Char]
(Int -> Chunk -> [Char] -> [Char])
-> (Chunk -> [Char]) -> ([Chunk] -> [Char] -> [Char]) -> Show Chunk
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> Chunk -> [Char] -> [Char]
showsPrec :: Int -> Chunk -> [Char] -> [Char]
$cshow :: Chunk -> [Char]
show :: Chunk -> [Char]
$cshowList :: [Chunk] -> [Char] -> [Char]
showList :: [Chunk] -> [Char] -> [Char]
Show)

expectedChunks :: [LineDiff] -> [Chunk]
expectedChunks :: [LineDiff] -> [Chunk]
expectedChunks = (LineDiff -> [Chunk]) -> [LineDiff] -> [Chunk]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((LineDiff -> [Chunk]) -> [LineDiff] -> [Chunk])
-> (LineDiff -> [Chunk]) -> [LineDiff] -> [Chunk]
forall a b. (a -> b) -> a -> b
$ \ case
  LinesBoth [[Char]]
a -> ([Char] -> Chunk) -> [[Char]] -> [Chunk]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Chunk
Original [[Char]]
a
  LinesFirst [[Char]]
a -> ([Char] -> Chunk) -> [[Char]] -> [Chunk]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Chunk
Modified [[Char]]
a
  LinesSecond [[Char]]
_ -> []
  LinesOmitted Int
n -> [[Char] -> Chunk
Info ([Char] -> Chunk) -> [Char] -> Chunk
forall a b. (a -> b) -> a -> b
$ Int -> [Char]
formatOmittedLines Int
n]
  SingleLineDiff [Diff]
diffs -> Chunk -> [Chunk]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (Chunk -> [Chunk])
-> ((Diff -> Maybe ColorChunk) -> Chunk)
-> (Diff -> Maybe ColorChunk)
-> [Chunk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ColorChunk] -> Chunk
ModifiedChunks ([ColorChunk] -> Chunk)
-> ((Diff -> Maybe ColorChunk) -> [ColorChunk])
-> (Diff -> Maybe ColorChunk)
-> Chunk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Diff -> Maybe ColorChunk) -> [Diff] -> [ColorChunk])
-> [Diff] -> (Diff -> Maybe ColorChunk) -> [ColorChunk]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Diff -> Maybe ColorChunk) -> [Diff] -> [ColorChunk]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [Diff]
diffs ((Diff -> Maybe ColorChunk) -> [Chunk])
-> (Diff -> Maybe ColorChunk) -> [Chunk]
forall a b. (a -> b) -> a -> b
$ \ case
    First [Char]
a -> ColorChunk -> Maybe ColorChunk
forall a. a -> Maybe a
Just (ColorChunk -> Maybe ColorChunk) -> ColorChunk -> Maybe ColorChunk
forall a b. (a -> b) -> a -> b
$ [Char] -> ColorChunk
ColorChunk [Char]
a
    Second [Char]
_ -> Maybe ColorChunk
forall a. Maybe a
Nothing
    Both [Char]
a -> ColorChunk -> Maybe ColorChunk
forall a. a -> Maybe a
Just (ColorChunk -> Maybe ColorChunk) -> ColorChunk -> Maybe ColorChunk
forall a b. (a -> b) -> a -> b
$ [Char] -> ColorChunk
PlainChunk [Char]
a

actualChunks :: [LineDiff] -> [Chunk]
actualChunks :: [LineDiff] -> [Chunk]
actualChunks = (LineDiff -> [Chunk]) -> [LineDiff] -> [Chunk]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((LineDiff -> [Chunk]) -> [LineDiff] -> [Chunk])
-> (LineDiff -> [Chunk]) -> [LineDiff] -> [Chunk]
forall a b. (a -> b) -> a -> b
$ \ case
  LinesBoth [[Char]]
a -> ([Char] -> Chunk) -> [[Char]] -> [Chunk]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Chunk
Original [[Char]]
a
  LinesFirst [[Char]]
_ -> []
  LinesSecond [[Char]]
a -> ([Char] -> Chunk) -> [[Char]] -> [Chunk]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Chunk
Modified [[Char]]
a
  LinesOmitted Int
n -> [[Char] -> Chunk
Info ([Char] -> Chunk) -> [Char] -> Chunk
forall a b. (a -> b) -> a -> b
$ Int -> [Char]
formatOmittedLines Int
n]
  SingleLineDiff [Diff]
diffs -> Chunk -> [Chunk]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (Chunk -> [Chunk])
-> ((Diff -> Maybe ColorChunk) -> Chunk)
-> (Diff -> Maybe ColorChunk)
-> [Chunk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ColorChunk] -> Chunk
ModifiedChunks ([ColorChunk] -> Chunk)
-> ((Diff -> Maybe ColorChunk) -> [ColorChunk])
-> (Diff -> Maybe ColorChunk)
-> Chunk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Diff -> Maybe ColorChunk) -> [Diff] -> [ColorChunk])
-> [Diff] -> (Diff -> Maybe ColorChunk) -> [ColorChunk]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Diff -> Maybe ColorChunk) -> [Diff] -> [ColorChunk]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [Diff]
diffs ((Diff -> Maybe ColorChunk) -> [Chunk])
-> (Diff -> Maybe ColorChunk) -> [Chunk]
forall a b. (a -> b) -> a -> b
$ \ case
    First [Char]
_ -> Maybe ColorChunk
forall a. Maybe a
Nothing
    Second [Char]
a -> ColorChunk -> Maybe ColorChunk
forall a. a -> Maybe a
Just (ColorChunk -> Maybe ColorChunk) -> ColorChunk -> Maybe ColorChunk
forall a b. (a -> b) -> a -> b
$ [Char] -> ColorChunk
ColorChunk [Char]
a
    Both [Char]
a -> ColorChunk -> Maybe ColorChunk
forall a. a -> Maybe a
Just (ColorChunk -> Maybe ColorChunk) -> ColorChunk -> Maybe ColorChunk
forall a b. (a -> b) -> a -> b
$ [Char] -> ColorChunk
PlainChunk [Char]
a

data ColorChunk = PlainChunk String | ColorChunk String
  deriving (ColorChunk -> ColorChunk -> Bool
(ColorChunk -> ColorChunk -> Bool)
-> (ColorChunk -> ColorChunk -> Bool) -> Eq ColorChunk
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ColorChunk -> ColorChunk -> Bool
== :: ColorChunk -> ColorChunk -> Bool
$c/= :: ColorChunk -> ColorChunk -> Bool
/= :: ColorChunk -> ColorChunk -> Bool
Eq, Int -> ColorChunk -> [Char] -> [Char]
[ColorChunk] -> [Char] -> [Char]
ColorChunk -> [Char]
(Int -> ColorChunk -> [Char] -> [Char])
-> (ColorChunk -> [Char])
-> ([ColorChunk] -> [Char] -> [Char])
-> Show ColorChunk
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> ColorChunk -> [Char] -> [Char]
showsPrec :: Int -> ColorChunk -> [Char] -> [Char]
$cshow :: ColorChunk -> [Char]
show :: ColorChunk -> [Char]
$cshowList :: [ColorChunk] -> [Char] -> [Char]
showList :: [ColorChunk] -> [Char] -> [Char]
Show)

formatOmittedLines :: Int -> String
formatOmittedLines :: Int -> [Char]
formatOmittedLines Int
n = [Char]
"@@ " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" lines omitted @@"

defaultFooter :: FormatM ()
defaultFooter :: FormatM ()
defaultFooter = do

  [Char] -> FormatM ()
writeLine ([Char] -> FormatM ()) -> FormatM [Char] -> FormatM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
(++)
    ([Char] -> [Char] -> [Char])
-> FormatM [Char] -> FormatM ([Char] -> [Char])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Char] -> Seconds -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"Finished in %1.4f seconds" (Seconds -> [Char]) -> FormatM Seconds -> FormatM [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FormatM Seconds
getRealTime)
    FormatM ([Char] -> [Char]) -> FormatM [Char] -> FormatM [Char]
forall a b. FormatM (a -> b) -> FormatM a -> FormatM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([Char] -> (Seconds -> [Char]) -> Maybe Seconds -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" ([Char] -> Seconds -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
", used %1.4f seconds of CPU time") (Maybe Seconds -> [Char])
-> FormatM (Maybe Seconds) -> FormatM [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FormatM (Maybe Seconds)
getCPUTime)

  fails   <- FormatM Int
getFailCount
  pending <- getPendingCount
  total   <- getTotalCount

  let
    output =
         Int -> [Char] -> [Char]
pluralize Int
total   [Char]
"example"
      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char] -> [Char]
pluralize Int
fails [Char]
"failure"
      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ if Int
pending Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then [Char]
"" else [Char]
", " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
pending [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" pending"

    color
      | Int
fails Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0   = FormatM a -> FormatM a
forall a. FormatM a -> FormatM a
withFailColor
      | Int
pending Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 = FormatM a -> FormatM a
forall a. FormatM a -> FormatM a
withPendingColor
      | Bool
otherwise    = FormatM a -> FormatM a
forall a. FormatM a -> FormatM a
withSuccessColor
  color $ writeLine output

formatLocation :: Location -> String
formatLocation :: Location -> [Char]
formatLocation (Location [Char]
file Int
line Int
column) = [Char]
file [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
":" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
line [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
":" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
column [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": "