{-# LANGUAGE CPP #-}
-- |
-- Stability: experimental
--
-- This module contains formatters that can be used with
-- `Test.Hspec.Core.Runner.hspecWith`.
module Test.Hspec.Core.Formatters.V2 (

-- * 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 (..)
, 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
, prettyPrint
, extraChunk
, missingChunk

-- ** Helpers
, formatLocation
, formatException

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

import           Prelude ()
import           Test.Hspec.Core.Compat hiding (First)

import           Data.Char
import           Data.Maybe
import           Test.Hspec.Core.Util
import           Test.Hspec.Core.Clock
import           Test.Hspec.Core.Spec (Location(..))
import           Text.Printf
import           Text.Show.Unicode (ushow)
import           Control.Monad.IO.Class
import           Control.Exception

-- 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
  , prettyPrint
  , extraChunk
  , missingChunk
  )

import           Test.Hspec.Core.Formatters.Diff

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

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

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

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

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

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

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

  formatterStarted :: FormatM ()
formatterStarted = do
    String -> FormatM ()
writeLine String
""

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

, formatterProgress :: Path -> Progress -> FormatM ()
formatterProgress = \Path
_ Progress
p -> do
    String -> FormatM ()
writeTransient (Progress -> String
forall a a. (Eq a, Num a, Show a, Show a) => (a, a) -> String
formatProgress Progress
p)

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

, formatterDone :: FormatM ()
formatterDone = FormatM ()
defaultFailedFormatter FormatM () -> FormatM () -> FormatM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FormatM ()
defaultFooter
} where
    indentationFor :: t a -> String
indentationFor t a
nesting = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (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 ()
writeResult [String]
nesting String
requirement (Seconds Double
duration) String
info = do
      Bool
shouldPrintTimes <- FormatM Bool
printTimes
      String -> FormatM ()
writeLine (String -> FormatM ()) -> String -> FormatM ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t a -> String
indentationFor [String]
nesting String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
requirement String -> String -> String
forall a. [a] -> [a] -> [a]
++ if Bool
shouldPrintTimes then String
times else String
""
      [String] -> (String -> FormatM ()) -> FormatM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (String -> [String]
lines String
info) ((String -> FormatM ()) -> FormatM ())
-> (String -> FormatM ()) -> FormatM ()
forall a b. (a -> b) -> a -> b
$ \ String
s ->
        String -> FormatM ()
writeLine (String -> FormatM ()) -> String -> FormatM ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t a -> String
indentationFor (String
"" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
nesting) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
      where
        dt :: Int
        dt :: Int
dt = Double -> Int
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 :: String
times
          | Int
dt Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = String
""
          | Bool
otherwise = String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
dt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"ms)"

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

progress :: Formatter
progress :: Formatter
progress = Formatter
failed_examples {
  formatterItemDone :: Path -> Item -> FormatM ()
formatterItemDone = \ Path
_ Item
item -> 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
$ String -> FormatM ()
write String
"."
    Pending{} -> FormatM () -> FormatM ()
forall a. FormatM a -> FormatM a
withPendingColor (FormatM () -> FormatM ()) -> FormatM () -> FormatM ()
forall a b. (a -> b) -> a -> b
$ String -> FormatM ()
write String
"."
    Failure{} -> FormatM () -> FormatM ()
forall a. FormatM a -> FormatM a
withFailColor (FormatM () -> FormatM ()) -> FormatM () -> FormatM ()
forall a b. (a -> b) -> a -> b
$ String -> FormatM ()
write String
"F"
}

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

defaultFailedFormatter :: FormatM ()
defaultFailedFormatter :: FormatM ()
defaultFailedFormatter = do
  String -> FormatM ()
writeLine String
""

  [FailureRecord]
failures <- FormatM [FailureRecord]
getFailMessages

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

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

    String -> FormatM ()
write String
"Randomized with seed " FormatM () -> FormatM Integer -> FormatM Integer
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FormatM Integer
usedSeed FormatM Integer -> (Integer -> FormatM ()) -> FormatM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> FormatM ()
writeLine (String -> FormatM ())
-> (Integer -> String) -> Integer -> FormatM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> String
forall a. Show a => a -> String
show
    String -> FormatM ()
writeLine String
""
  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
      Maybe Location -> (Location -> FormatM ()) -> FormatM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Location
mLoc ((Location -> FormatM ()) -> FormatM ())
-> (Location -> FormatM ()) -> FormatM ()
forall a b. (a -> b) -> a -> b
$ \Location
loc -> do
        FormatM () -> FormatM ()
forall a. FormatM a -> FormatM a
withInfoColor (FormatM () -> FormatM ()) -> FormatM () -> FormatM ()
forall a b. (a -> b) -> a -> b
$ String -> FormatM ()
writeLine (String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Location -> String
formatLocation Location
loc)
      String -> FormatM ()
write (String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") ")
      String -> FormatM ()
writeLine (Path -> String
formatRequirement Path
path)
      case FailureReason
reason of
        FailureReason
NoReason -> () -> FormatM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Reason String
err -> FormatM () -> FormatM ()
forall a. FormatM a -> FormatM a
withFailColor (FormatM () -> FormatM ()) -> FormatM () -> FormatM ()
forall a b. (a -> b) -> a -> b
$ String -> FormatM ()
indent String
err
        ExpectedButGot Maybe String
preface String
expected_ String
actual_ -> do
          Bool
pretty <- FormatM Bool
prettyPrint
          let
            (String
expected, String
actual)
              | Bool
pretty = Bool -> String -> String -> (String, String)
recover Bool
unicode String
expected_ String
actual_
              | Bool
otherwise = (String
expected_, String
actual_)

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

          Bool
b <- FormatM Bool
useDiff

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

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

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

            writeChunks :: String -> [Chunk] -> (String -> FormatM ()) -> FormatM ()
            writeChunks :: String -> [Chunk] -> (String -> FormatM ()) -> FormatM ()
writeChunks String
pre [Chunk]
chunks String -> FormatM ()
colorize = do
              FormatM () -> FormatM ()
forall a. FormatM a -> FormatM a
withFailColor (FormatM () -> FormatM ()) -> FormatM () -> FormatM ()
forall a b. (a -> b) -> a -> b
$ String -> FormatM ()
write (String
indentation String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pre)
              [ColorChunk] -> (ColorChunk -> FormatM ()) -> FormatM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (String -> [Chunk] -> [ColorChunk]
indentChunks String
indentation_ [Chunk]
chunks) ((ColorChunk -> FormatM ()) -> FormatM ())
-> (ColorChunk -> FormatM ()) -> FormatM ()
forall a b. (a -> b) -> a -> b
$ \ ColorChunk
chunk -> case ColorChunk
chunk of
                PlainChunk String
a -> String -> FormatM ()
write String
a
                ColorChunk String
a -> String -> FormatM ()
colorize String
a
              String -> FormatM ()
writeLine String
""
              where
                indentation_ :: String
indentation_ = String
indentation String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
pre) Char
' '

        Error Maybe String
_ SomeException
e -> FormatM () -> FormatM ()
forall a. FormatM a -> FormatM a
withFailColor (FormatM () -> FormatM ())
-> (String -> FormatM ()) -> String -> FormatM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FormatM ()
indent (String -> FormatM ()) -> String -> FormatM ()
forall a b. (a -> b) -> a -> b
$ ((String
"uncaught exception: " String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String)
-> (SomeException -> String) -> SomeException -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
formatException) SomeException
e

      String -> FormatM ()
writeLine String
""

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

data Chunk = Original String | Modified String
  deriving (Chunk -> Chunk -> Bool
(Chunk -> Chunk -> Bool) -> (Chunk -> Chunk -> Bool) -> Eq Chunk
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 -> String -> String
[Chunk] -> String -> String
Chunk -> String
(Int -> Chunk -> String -> String)
-> (Chunk -> String) -> ([Chunk] -> String -> String) -> Show Chunk
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Chunk] -> String -> String
$cshowList :: [Chunk] -> String -> String
show :: Chunk -> String
$cshow :: Chunk -> String
showsPrec :: Int -> Chunk -> String -> String
$cshowsPrec :: Int -> Chunk -> String -> String
Show)

expectedChunks :: [Diff] -> [Chunk]
expectedChunks :: [Diff] -> [Chunk]
expectedChunks = (Diff -> Maybe Chunk) -> [Diff] -> [Chunk]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((Diff -> Maybe Chunk) -> [Diff] -> [Chunk])
-> (Diff -> Maybe Chunk) -> [Diff] -> [Chunk]
forall a b. (a -> b) -> a -> b
$ \ Diff
chunk -> case Diff
chunk of
  Both String
a -> Chunk -> Maybe Chunk
forall a. a -> Maybe a
Just (Chunk -> Maybe Chunk) -> Chunk -> Maybe Chunk
forall a b. (a -> b) -> a -> b
$ String -> Chunk
Original String
a
  First String
a -> Chunk -> Maybe Chunk
forall a. a -> Maybe a
Just (Chunk -> Maybe Chunk) -> Chunk -> Maybe Chunk
forall a b. (a -> b) -> a -> b
$ String -> Chunk
Modified String
a
  Second String
_ -> Maybe Chunk
forall a. Maybe a
Nothing

actualChunks :: [Diff] -> [Chunk]
actualChunks :: [Diff] -> [Chunk]
actualChunks = (Diff -> Maybe Chunk) -> [Diff] -> [Chunk]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((Diff -> Maybe Chunk) -> [Diff] -> [Chunk])
-> (Diff -> Maybe Chunk) -> [Diff] -> [Chunk]
forall a b. (a -> b) -> a -> b
$ \ Diff
chunk -> case Diff
chunk of
  Both String
a -> Chunk -> Maybe Chunk
forall a. a -> Maybe a
Just (Chunk -> Maybe Chunk) -> Chunk -> Maybe Chunk
forall a b. (a -> b) -> a -> b
$ String -> Chunk
Original String
a
  First String
_ -> Maybe Chunk
forall a. Maybe a
Nothing
  Second String
a -> Chunk -> Maybe Chunk
forall a. a -> Maybe a
Just (Chunk -> Maybe Chunk) -> Chunk -> Maybe Chunk
forall a b. (a -> b) -> a -> b
$ String -> Chunk
Modified String
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
/= :: ColorChunk -> ColorChunk -> Bool
$c/= :: ColorChunk -> ColorChunk -> Bool
== :: ColorChunk -> ColorChunk -> Bool
$c== :: ColorChunk -> ColorChunk -> Bool
Eq, Int -> ColorChunk -> String -> String
[ColorChunk] -> String -> String
ColorChunk -> String
(Int -> ColorChunk -> String -> String)
-> (ColorChunk -> String)
-> ([ColorChunk] -> String -> String)
-> Show ColorChunk
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [ColorChunk] -> String -> String
$cshowList :: [ColorChunk] -> String -> String
show :: ColorChunk -> String
$cshow :: ColorChunk -> String
showsPrec :: Int -> ColorChunk -> String -> String
$cshowsPrec :: Int -> ColorChunk -> String -> String
Show)

indentChunks :: String -> [Chunk] -> [ColorChunk]
indentChunks :: String -> [Chunk] -> [ColorChunk]
indentChunks String
indentation = (Chunk -> [ColorChunk]) -> [Chunk] -> [ColorChunk]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Chunk -> [ColorChunk]) -> [Chunk] -> [ColorChunk])
-> (Chunk -> [ColorChunk]) -> [Chunk] -> [ColorChunk]
forall a b. (a -> b) -> a -> b
$ \ Chunk
chunk -> case Chunk
chunk of
  Original String
y -> [String -> String -> ColorChunk
indentOriginal String
indentation String
y]
  Modified String
y -> String -> String -> [ColorChunk]
indentModified String
indentation String
y

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

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

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

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

  String -> FormatM ()
writeLine (String -> FormatM ()) -> FormatM String -> FormatM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> String -> String
forall a. [a] -> [a] -> [a]
(++)
    (String -> String -> String)
-> FormatM String -> FormatM (String -> String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> Seconds -> String
forall r. PrintfType r => String -> r
printf String
"Finished in %1.4f seconds" (Seconds -> String) -> FormatM Seconds -> FormatM String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FormatM Seconds
getRealTime)
    FormatM (String -> String) -> FormatM String -> FormatM String
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (String -> (Seconds -> String) -> Maybe Seconds -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (String -> Seconds -> String
forall r. PrintfType r => String -> r
printf String
", used %1.4f seconds of CPU time") (Maybe Seconds -> String)
-> FormatM (Maybe Seconds) -> FormatM String
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 :: String
output =
         Int -> String -> String
pluralize Int
total   String
"example"
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
pluralize Int
fails String
"failure"
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ if Int
pending Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then String
"" else String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
pending String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" pending"
    c :: FormatM a -> FormatM a
c | 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
  FormatM () -> FormatM ()
forall a. FormatM a -> FormatM a
c (FormatM () -> FormatM ()) -> FormatM () -> FormatM ()
forall a b. (a -> b) -> a -> b
$ String -> FormatM ()
writeLine String
output

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