{-# 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 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

-- ** Helpers
, formatLocation
, formatException

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

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

import           Data.Char
import           Test.Hspec.Core.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

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

import           Test.Hspec.Core.Formatters.Diff

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

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

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

, formatterItemDone :: Path -> Item -> FormatM ()
formatterItemDone = \ ([[Char]]
nesting, [Char]
requirement) Item
item -> do
    Bool
unicode <- FormatM Bool
outputUnicode
    let fallback :: p -> p -> p
fallback p
a p
b = if Bool
unicode then p
a else p
b
    forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ([[Char]]
-> [Char]
-> Seconds
-> [Char]
-> (FormatM () -> FormatM ())
-> [Char]
-> FormatM ()
writeResult [[Char]]
nesting [Char]
requirement (Item -> Seconds
itemDuration Item
item) (Item -> [Char]
itemInfo Item
item)) forall a b. (a -> b) -> a -> b
$ case Item -> Result
itemResult Item
item of
      Success {} -> (forall a. FormatM a -> FormatM a
withSuccessColor, forall {p}. p -> p -> p
fallback [Char]
"✔" [Char]
"v")
      Pending {} -> (forall a. FormatM a -> FormatM a
withPendingColor, forall {p}. p -> p -> p
fallback [Char]
"‐" [Char]
"-")
      Failure {} -> (forall a. FormatM a -> FormatM a
withFailColor,    forall {p}. p -> p -> p
fallback [Char]
"✘" [Char]
"x")
    case Item -> Result
itemResult Item
item of
      Success {} -> forall (m :: * -> *). Applicative m => m ()
pass
      Failure {} -> forall (m :: * -> *). Applicative m => m ()
pass
      Pending Maybe Location
_ Maybe [Char]
reason -> forall a. FormatM a -> FormatM a
withPendingColor forall a b. (a -> b) -> a -> b
$ do
        [Char] -> FormatM ()
writeLine forall a b. (a -> b) -> a -> b
$ forall {t :: * -> *} {a}. Foldable t => t a -> [Char]
indentationFor ([Char]
"" forall a. a -> [a] -> [a]
: [[Char]]
nesting) forall a. [a] -> [a] -> [a]
++ [Char]
"# PENDING: " forall a. [a] -> [a] -> [a]
++ forall a. a -> Maybe a -> a
fromMaybe [Char]
"No reason given" Maybe [Char]
reason
} where
    indentationFor :: t a -> [Char]
indentationFor t a
nesting = forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
nesting 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
      Bool
shouldPrintTimes <- FormatM Bool
printTimes
      [Char] -> FormatM ()
write forall a b. (a -> b) -> a -> b
$ forall {t :: * -> *} {a}. Foldable t => t a -> [Char]
indentationFor [[Char]]
nesting forall a. [a] -> [a] -> [a]
++ [Char]
requirement forall a. [a] -> [a] -> [a]
++ [Char]
" ["
      FormatM () -> FormatM ()
withColor forall a b. (a -> b) -> a -> b
$ [Char] -> FormatM ()
write [Char]
symbol
      [Char] -> FormatM ()
writeLine forall a b. (a -> b) -> a -> b
$ [Char]
"]" forall a. [a] -> [a] -> [a]
++ if Bool
shouldPrintTimes then [Char]
times else [Char]
""
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Char] -> [[Char]]
lines [Char]
info) forall a b. (a -> b) -> a -> b
$ \ [Char]
s ->
        [Char] -> FormatM ()
writeLine forall a b. (a -> b) -> a -> b
$ forall {t :: * -> *} {a}. Foldable t => t a -> [Char]
indentationFor ([Char]
"" forall a. a -> [a] -> [a]
: [[Char]]
nesting) forall a. [a] -> [a] -> [a]
++ [Char]
s
      where
        dt :: Int
        dt :: Int
dt = Seconds -> Int
toMilliseconds Seconds
duration

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

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

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

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

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

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

, formatterItemDone :: Path -> Item -> FormatM ()
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 -> forall a. FormatM a -> FormatM a
withSuccessColor 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 -> forall a. FormatM a -> FormatM a
withPendingColor forall a b. (a -> b) -> a -> b
$ do
        [[Char]] -> [Char] -> Seconds -> [Char] -> FormatM ()
writeResult [[Char]]
nesting [Char]
requirement Seconds
duration [Char]
info
        [Char] -> FormatM ()
writeLine forall a b. (a -> b) -> a -> b
$ forall {t :: * -> *} {a}. Foldable t => t a -> [Char]
indentationFor ([Char]
"" forall a. a -> [a] -> [a]
: [[Char]]
nesting) forall a. [a] -> [a] -> [a]
++ [Char]
"# PENDING: " forall a. [a] -> [a] -> [a]
++ forall a. a -> Maybe a -> a
fromMaybe [Char]
"No reason given" Maybe [Char]
reason
      Failure {} -> forall a. FormatM a -> FormatM a
withFailColor forall a b. (a -> b) -> a -> b
$ do
        Int
n <- FormatM Int
getFailCount
        [[Char]] -> [Char] -> Seconds -> [Char] -> FormatM ()
writeResult [[Char]]
nesting ([Char]
requirement forall a. [a] -> [a] -> [a]
++ [Char]
" FAILED [" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
n forall a. [a] -> [a] -> [a]
++ [Char]
"]") Seconds
duration [Char]
info

, formatterDone :: FormatM ()
formatterDone = FormatM ()
defaultFailedFormatter forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FormatM ()
defaultFooter
} where
    indentationFor :: t a -> [Char]
indentationFor t a
nesting = forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
nesting 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
      Bool
shouldPrintTimes <- FormatM Bool
printTimes
      [Char] -> FormatM ()
writeLine forall a b. (a -> b) -> a -> b
$ forall {t :: * -> *} {a}. Foldable t => t a -> [Char]
indentationFor [[Char]]
nesting forall a. [a] -> [a] -> [a]
++ [Char]
requirement forall a. [a] -> [a] -> [a]
++ if Bool
shouldPrintTimes then [Char]
times else [Char]
""
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Char] -> [[Char]]
lines [Char]
info) forall a b. (a -> b) -> a -> b
$ \ [Char]
s ->
        [Char] -> FormatM ()
writeLine forall a b. (a -> b) -> a -> b
$ forall {t :: * -> *} {a}. Foldable t => t a -> [Char]
indentationFor ([Char]
"" forall a. a -> [a] -> [a]
: [[Char]]
nesting) forall a. [a] -> [a] -> [a]
++ [Char]
s
      where
        dt :: Int
        dt :: Int
dt = forall a b. (RealFrac a, Integral b) => a -> b
floor (Double
duration forall a. Num a => a -> a -> a
* Double
1000)

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

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

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

failed_examples :: Formatter
failed_examples :: Formatter
failed_examples   = Formatter
silent {
  formatterDone :: FormatM ()
formatterDone = FormatM ()
defaultFailedFormatter forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FormatM ()
defaultFooter
}

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

  [FailureRecord]
failures <- FormatM [FailureRecord]
getFailMessages

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FailureRecord]
failures) forall a b. (a -> b) -> a -> b
$ do
    [Char] -> FormatM ()
writeLine [Char]
"Failures:"
    [Char] -> FormatM ()
writeLine [Char]
""

    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [FailureRecord]
failures) forall a b. (a -> b) -> a -> b
$ \(Int, FailureRecord)
x -> do
      (Int, FailureRecord) -> FormatM ()
formatFailure (Int, FailureRecord)
x
      [Char] -> FormatM ()
writeLine [Char]
""

    [Char] -> FormatM ()
write [Char]
"Randomized with seed " forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FormatM Integer
usedSeed forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Char] -> FormatM ()
writeLine forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show
    [Char] -> FormatM ()
writeLine [Char]
""
  where
    formatFailure :: (Int, FailureRecord) -> FormatM ()
    formatFailure :: (Int, FailureRecord) -> FormatM ()
formatFailure (Int
n, FailureRecord Maybe Location
mLoc Path
path FailureReason
reason) = do
      Bool
unicode <- FormatM Bool
outputUnicode
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Location
mLoc forall a b. (a -> b) -> a -> b
$ \Location
loc -> do
        forall a. FormatM a -> FormatM a
withInfoColor forall a b. (a -> b) -> a -> b
$ [Char] -> FormatM ()
writeLine ([Char]
"  " forall a. [a] -> [a] -> [a]
++ Location -> [Char]
formatLocation Location
loc)
      [Char] -> FormatM ()
write ([Char]
"  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
n forall a. [a] -> [a] -> [a]
++ [Char]
") ")
      [Char] -> FormatM ()
writeLine (Path -> [Char]
formatRequirement Path
path)
      case FailureReason
reason of
        FailureReason
NoReason -> forall (m :: * -> *). Applicative m => m ()
pass
        Reason [Char]
err -> forall a. FormatM a -> FormatM a
withFailColor 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
          Maybe ([Char] -> [Char] -> ([Char], [Char]))
pretty <- FormatM (Maybe ([Char] -> [Char] -> ([Char], [Char])))
prettyPrintFunction
          let
            ([Char]
expected, [Char]
actual) = case Maybe ([Char] -> [Char] -> ([Char], [Char]))
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_)

          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [Char] -> FormatM ()
indent Maybe [Char]
preface

          Bool
b <- FormatM Bool
useDiff

          let threshold :: Seconds
threshold = Seconds
2 :: Seconds


          Maybe ([Char] -> [Char] -> IO ())
mExternalDiff <- FormatM (Maybe ([Char] -> [Char] -> IO ()))
externalDiffAction

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

            Maybe ([Char] -> [Char] -> IO ())
Nothing -> do
              Maybe Int
context <- FormatM (Maybe Int)
diffContext
              Maybe [Diff]
mchunks <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ if Bool
b
                then forall a. Seconds -> IO a -> IO (Maybe a)
timeout Seconds
threshold (forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ Maybe Int -> [Char] -> [Char] -> [Diff]
diff Maybe Int
context [Char]
expected [Char]
actual)
                else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

              case Maybe [Diff]
mchunks of
                Just [Diff]
chunks -> do
                  [Diff]
-> ([Char] -> FormatM ()) -> ([Char] -> FormatM ()) -> FormatM ()
writeDiff [Diff]
chunks [Char] -> FormatM ()
extraChunk [Char] -> FormatM ()
missingChunk
                Maybe [Diff]
Nothing -> do
                  [Diff]
-> ([Char] -> FormatM ()) -> ([Char] -> FormatM ()) -> FormatM ()
writeDiff [[Char] -> Diff
First [Char]
expected, [Char] -> Diff
Second [Char]
actual] [Char] -> FormatM ()
write [Char] -> FormatM ()
write
          where
            writeDiff :: [Diff]
-> ([Char] -> FormatM ()) -> ([Char] -> FormatM ()) -> FormatM ()
writeDiff [Diff]
chunks [Char] -> FormatM ()
extra [Char] -> FormatM ()
missing = do
              [Char] -> [Chunk] -> ([Char] -> FormatM ()) -> FormatM ()
writeChunks [Char]
"expected: " ([Diff] -> [Chunk]
expectedChunks [Diff]
chunks) [Char] -> FormatM ()
extra
              [Char] -> [Chunk] -> ([Char] -> FormatM ()) -> FormatM ()
writeChunks [Char]
" but got: " ([Diff] -> [Chunk]
actualChunks [Diff]
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
              forall a. FormatM a -> FormatM a
withFailColor forall a b. (a -> b) -> a -> b
$ [Char] -> FormatM ()
write ([Char]
indentation forall a. [a] -> [a] -> [a]
++ [Char]
pre)
              forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Char] -> [Chunk] -> [ColorChunk]
indentChunks [Char]
indentation_ [Chunk]
chunks) forall a b. (a -> b) -> a -> b
$ \ case
                PlainChunk [Char]
a -> [Char] -> FormatM ()
write [Char]
a
                ColorChunk [Char]
a -> [Char] -> FormatM ()
colorize [Char]
a
                Informational [Char]
a -> forall a. FormatM a -> FormatM a
withInfoColor forall a b. (a -> b) -> a -> b
$ [Char] -> FormatM ()
write [Char]
a
              [Char] -> FormatM ()
writeLine [Char]
""
              where
                indentation_ :: [Char]
indentation_ = [Char]
indentation forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
pre) Char
' '

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

      [Char] -> FormatM ()
writeLine [Char]
""

      let path_ :: [Char]
path_ = (if Bool
unicode then [Char] -> [Char]
ushow else forall a. Show a => a -> [Char]
show) (Path -> [Char]
joinPath Path
path)
      [Char] -> FormatM ()
writeLine ([Char]
"  To rerun use: --match " forall a. [a] -> [a] -> [a]
++ [Char]
path_)
      where
        indentation :: [Char]
indentation = [Char]
"       "
        indent :: [Char] -> FormatM ()
indent [Char]
message = do
          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Char] -> [[Char]]
lines [Char]
message) forall a b. (a -> b) -> a -> b
$ \[Char]
line -> do
            [Char] -> FormatM ()
writeLine ([Char]
indentation forall a. [a] -> [a] -> [a]
++ [Char]
line)

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

expectedChunks :: [Diff] -> [Chunk]
expectedChunks :: [Diff] -> [Chunk]
expectedChunks = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a b. (a -> b) -> a -> b
$ \ case
  Both [Char]
a -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Char] -> Chunk
Original [Char]
a
  First [Char]
a -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Char] -> Chunk
Modified [Char]
a
  Second [Char]
_ -> forall a. Maybe a
Nothing
  Omitted Int
n -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Int -> Chunk
OmittedLines Int
n

actualChunks :: [Diff] -> [Chunk]
actualChunks :: [Diff] -> [Chunk]
actualChunks = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a b. (a -> b) -> a -> b
$ \ case
  Both [Char]
a -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Char] -> Chunk
Original [Char]
a
  First [Char]
_ -> forall a. Maybe a
Nothing
  Second [Char]
a -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Char] -> Chunk
Modified [Char]
a
  Omitted Int
n -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Int -> Chunk
OmittedLines Int
n

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

data StartsWith = StartsWithNewline | StartsWithNonNewline
  deriving StartsWith -> StartsWith -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StartsWith -> StartsWith -> Bool
$c/= :: StartsWith -> StartsWith -> Bool
== :: StartsWith -> StartsWith -> Bool
$c== :: StartsWith -> StartsWith -> Bool
Eq

indentChunks :: String -> [Chunk] -> [ColorChunk]
indentChunks :: [Char] -> [Chunk] -> [ColorChunk]
indentChunks [Char]
indentation = [Chunk] -> [ColorChunk]
go
  where
    go :: [Chunk] -> [ColorChunk]
    go :: [Chunk] -> [ColorChunk]
go = \ case
      Original [Char]
x : [Chunk]
xs -> [Char] -> [Char] -> ColorChunk
indentOriginal [Char]
indentation [Char]
x forall a. a -> [a] -> [a]
: [Chunk] -> [ColorChunk]
go [Chunk]
xs
      Modified [Char]
x : [Chunk]
xs -> StartsWith -> [Char] -> [Char] -> [ColorChunk]
indentModified ([Chunk] -> StartsWith
startsWith [Chunk]
xs) [Char]
indentation [Char]
x forall a. [a] -> [a] -> [a]
++ [Chunk] -> [ColorChunk]
go [Chunk]
xs
      OmittedLines Int
n : [Chunk]
xs -> [Char] -> ColorChunk
Informational (Int -> [Char]
formatOmittedLines Int
n) forall a. a -> [a] -> [a]
: [Chunk] -> [ColorChunk]
go [Chunk]
xs
      [] -> []

    startsWith :: [Chunk] -> StartsWith
    startsWith :: [Chunk] -> StartsWith
startsWith [Chunk]
xs
      | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace (forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'\n') forall a b. (a -> b) -> a -> b
$ [Chunk] -> [Char]
unChunks [Chunk]
xs) = StartsWith
StartsWithNewline
      | Bool
otherwise = StartsWith
StartsWithNonNewline

    unChunks :: [Chunk] -> String
    unChunks :: [Chunk] -> [Char]
unChunks = \ case
      Original [Char]
x : [Chunk]
xs -> [Char]
x forall a. [a] -> [a] -> [a]
++ [Chunk] -> [Char]
unChunks [Chunk]
xs
      Modified [Char]
x : [Chunk]
xs -> [Char]
x forall a. [a] -> [a] -> [a]
++ [Chunk] -> [Char]
unChunks [Chunk]
xs
      OmittedLines {} : [Chunk]
_ -> [Char]
""
      [] -> [Char]
""

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

indentOriginal :: String -> String -> ColorChunk
indentOriginal :: [Char] -> [Char] -> ColorChunk
indentOriginal [Char]
indentation = [Char] -> ColorChunk
PlainChunk forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
go
  where
    go :: [Char] -> [Char]
go [Char]
text = case forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
'\n') [Char]
text of
      ([Char]
xs, Char
_ : [Char]
ys) -> [Char]
xs forall a. [a] -> [a] -> [a]
++ [Char]
"\n" forall a. [a] -> [a] -> [a]
++ [Char]
indentation forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
go [Char]
ys
      ([Char]
xs, [Char]
"") -> [Char]
xs

indentModified :: StartsWith -> String -> String -> [ColorChunk]
indentModified :: StartsWith -> [Char] -> [Char] -> [ColorChunk]
indentModified StartsWith
nextChunk [Char]
indentation = [Char] -> [ColorChunk]
go
  where
    go :: String -> [ColorChunk]
    go :: [Char] -> [ColorChunk]
go = \ case
      [Char]
"" -> []
      [Char]
"\n" -> [[Char] -> ColorChunk
PlainChunk [Char]
"\n", [Char] -> ColorChunk
ColorChunk [Char]
indentation]
      Char
'\n' : ys :: [Char]
ys@(Char
'\n' : [Char]
_) -> [Char] -> ColorChunk
PlainChunk [Char]
"\n" forall a. a -> [a] -> [a]
: [Char] -> ColorChunk
ColorChunk [Char]
indentation forall a. a -> [a] -> [a]
: [Char] -> [ColorChunk]
go [Char]
ys
      Char
'\n' : [Char]
xs -> [Char] -> ColorChunk
PlainChunk (Char
'\n' forall a. a -> [a] -> [a]
: [Char]
indentation) forall a. a -> [a] -> [a]
: [Char] -> [ColorChunk]
go [Char]
xs
      [Char]
text -> case forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
'\n') [Char]
text of
        ([Char]
xs, [Char]
"") | StartsWith
nextChunk forall a. Eq a => a -> a -> Bool
== StartsWith
StartsWithNonNewline -> [[Char] -> ColorChunk
ColorChunk [Char]
xs]
        ([Char]
xs, [Char]
ys) -> [Char] -> [ColorChunk]
segment [Char]
xs forall a. [a] -> [a] -> [a]
++ [Char] -> [ColorChunk]
go [Char]
ys

    segment :: String -> [ColorChunk]
    segment :: [Char] -> [ColorChunk]
segment [Char]
xs = case forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isSpace forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [Char]
xs of
      ([Char]
"", [Char]
_) -> [[Char] -> ColorChunk
ColorChunk [Char]
xs]
      ([Char]
_, [Char]
"") -> [[Char] -> ColorChunk
ColorChunk [Char]
xs]
      ([Char]
ys, [Char]
zs) -> [[Char] -> ColorChunk
ColorChunk (forall a. [a] -> [a]
reverse [Char]
zs), [Char] -> ColorChunk
ColorChunk (forall a. [a] -> [a]
reverse [Char]
ys)]

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

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

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

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

    color :: FormatM a -> FormatM a
color
      | Int
fails forall a. Eq a => a -> a -> Bool
/= Int
0   = forall a. FormatM a -> FormatM a
withFailColor
      | Int
pending forall a. Eq a => a -> a -> Bool
/= Int
0 = forall a. FormatM a -> FormatM a
withPendingColor
      | Bool
otherwise    = forall a. FormatM a -> FormatM a
withSuccessColor
  forall a. FormatM a -> FormatM a
color forall a b. (a -> b) -> a -> b
$ [Char] -> FormatM ()
writeLine [Char]
output

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