{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE ExistentialQuantification #-}
module Test.Hspec.Core.Formatters.V1.Monad (
  Formatter(..)
, Item(..)
, Result(..)
, FailureReason (..)
, FormatM

, getSuccessCount
, getPendingCount
, getFailCount
, getTotalCount

, FailureRecord (..)
, getFailMessages
, usedSeed

, printTimes
, getCPUTime
, getRealTime

, write
, writeLine
, writeTransient

, withInfoColor
, withSuccessColor
, withPendingColor
, withFailColor

, useDiff
, extraChunk
, missingChunk

, Environment(..)
, interpretWith
) where

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

import           Control.Monad.IO.Class

import           Test.Hspec.Core.Formatters.V1.Free
import           Test.Hspec.Core.Clock
import           Test.Hspec.Core.Format

data Formatter = Formatter {

  Formatter -> FormatM ()
headerFormatter :: FormatM ()

-- | evaluated before each test group
, Formatter -> [String] -> String -> FormatM ()
exampleGroupStarted :: [String] -> String -> FormatM ()

-- | evaluated after each test group
, Formatter -> FormatM ()
exampleGroupDone :: FormatM ()

-- | evaluated before each example
, Formatter -> Path -> FormatM ()
exampleStarted :: Path -> FormatM ()

-- | used to notify the progress of the currently evaluated example
, Formatter -> Path -> Progress -> FormatM ()
exampleProgress :: Path -> Progress -> FormatM ()

-- | evaluated after each successful example
, Formatter -> Path -> String -> FormatM ()
exampleSucceeded :: Path -> String -> FormatM ()

-- | evaluated after each failed example
, Formatter -> Path -> String -> FailureReason -> FormatM ()
exampleFailed :: Path -> String -> FailureReason -> FormatM ()

-- | evaluated after each pending example
, Formatter -> Path -> String -> Maybe String -> FormatM ()
examplePending :: Path -> String -> Maybe String -> FormatM ()

-- | evaluated after a test run
, Formatter -> FormatM ()
failedFormatter :: FormatM ()

-- | evaluated after `failedFormatter`
, Formatter -> FormatM ()
footerFormatter :: FormatM ()
}

data FailureRecord = FailureRecord {
  FailureRecord -> Maybe Location
failureRecordLocation :: Maybe Location
, FailureRecord -> Path
failureRecordPath     :: Path
, FailureRecord -> FailureReason
failureRecordMessage  :: FailureReason
}

data FormatF next =
    GetSuccessCount (Int -> next)
  | GetPendingCount (Int -> next)
  | GetFailMessages ([FailureRecord] -> next)
  | UsedSeed (Integer -> next)
  | PrintTimes (Bool -> next)
  | GetCPUTime (Maybe Seconds -> next)
  | GetRealTime (Seconds -> next)
  | Write String next
  | WriteTransient String next
  | forall a. WithFailColor (FormatM a) (a -> next)
  | forall a. WithSuccessColor (FormatM a) (a -> next)
  | forall a. WithPendingColor (FormatM a) (a -> next)
  | forall a. WithInfoColor (FormatM a) (a -> next)
  | UseDiff (Bool -> next)
  | ExtraChunk String next
  | MissingChunk String next
  | forall a. LiftIO (IO a) (a -> next)

instance Functor FormatF where -- deriving this instance would require GHC >= 7.10.1
  fmap :: forall a b. (a -> b) -> FormatF a -> FormatF b
fmap a -> b
f FormatF a
x = case FormatF a
x of
    GetSuccessCount Int -> a
next -> forall next. (Int -> next) -> FormatF next
GetSuccessCount (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Int -> a
next)
    GetPendingCount Int -> a
next -> forall next. (Int -> next) -> FormatF next
GetPendingCount (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Int -> a
next)
    GetFailMessages [FailureRecord] -> a
next -> forall next. ([FailureRecord] -> next) -> FormatF next
GetFailMessages (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f [FailureRecord] -> a
next)
    UsedSeed Integer -> a
next -> forall next. (Integer -> next) -> FormatF next
UsedSeed (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Integer -> a
next)
    PrintTimes Bool -> a
next -> forall next. (Bool -> next) -> FormatF next
PrintTimes (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Bool -> a
next)
    GetCPUTime Maybe Seconds -> a
next -> forall next. (Maybe Seconds -> next) -> FormatF next
GetCPUTime (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Maybe Seconds -> a
next)
    GetRealTime Seconds -> a
next -> forall next. (Seconds -> next) -> FormatF next
GetRealTime (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Seconds -> a
next)
    Write String
s a
next -> forall next. String -> next -> FormatF next
Write String
s (a -> b
f a
next)
    WriteTransient String
s a
next -> forall next. String -> next -> FormatF next
WriteTransient String
s (a -> b
f a
next)
    WithFailColor FormatM a
action a -> a
next -> forall next a. FormatM a -> (a -> next) -> FormatF next
WithFailColor FormatM a
action (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f a -> a
next)
    WithSuccessColor FormatM a
action a -> a
next -> forall next a. FormatM a -> (a -> next) -> FormatF next
WithSuccessColor FormatM a
action (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f a -> a
next)
    WithPendingColor FormatM a
action a -> a
next -> forall next a. FormatM a -> (a -> next) -> FormatF next
WithPendingColor FormatM a
action (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f a -> a
next)
    WithInfoColor FormatM a
action a -> a
next -> forall next a. FormatM a -> (a -> next) -> FormatF next
WithInfoColor FormatM a
action (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f a -> a
next)
    UseDiff Bool -> a
next -> forall next. (Bool -> next) -> FormatF next
UseDiff (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Bool -> a
next)
    ExtraChunk String
s a
next -> forall next. String -> next -> FormatF next
ExtraChunk String
s (a -> b
f a
next)
    MissingChunk String
s a
next -> forall next. String -> next -> FormatF next
MissingChunk String
s (a -> b
f a
next)
    LiftIO IO a
action a -> a
next -> forall next a. IO a -> (a -> next) -> FormatF next
LiftIO IO a
action (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f a -> a
next)

type FormatM = Free FormatF

instance MonadIO FormatM where
  liftIO :: forall a. IO a -> FormatM a
liftIO IO a
s = forall (f :: * -> *) a. Functor f => f a -> Free f a
liftF (forall next a. IO a -> (a -> next) -> FormatF next
LiftIO IO a
s forall a. a -> a
id)

data Environment m = Environment {
  forall (m :: * -> *). Environment m -> m Int
environmentGetSuccessCount :: m Int
, forall (m :: * -> *). Environment m -> m Int
environmentGetPendingCount :: m Int
, forall (m :: * -> *). Environment m -> m [FailureRecord]
environmentGetFailMessages :: m [FailureRecord]
, forall (m :: * -> *). Environment m -> m Integer
environmentUsedSeed :: m Integer
, forall (m :: * -> *). Environment m -> m Bool
environmentPrintTimes :: m Bool
, forall (m :: * -> *). Environment m -> m (Maybe Seconds)
environmentGetCPUTime :: m (Maybe Seconds)
, forall (m :: * -> *). Environment m -> m Seconds
environmentGetRealTime :: m Seconds
, forall (m :: * -> *). Environment m -> String -> m ()
environmentWrite :: String -> m ()
, forall (m :: * -> *). Environment m -> String -> m ()
environmentWriteTransient :: String -> m ()
, forall (m :: * -> *). Environment m -> forall a. m a -> m a
environmentWithFailColor :: forall a. m a -> m a
, forall (m :: * -> *). Environment m -> forall a. m a -> m a
environmentWithSuccessColor :: forall a. m a -> m a
, forall (m :: * -> *). Environment m -> forall a. m a -> m a
environmentWithPendingColor :: forall a. m a -> m a
, forall (m :: * -> *). Environment m -> forall a. m a -> m a
environmentWithInfoColor :: forall a. m a -> m a
, forall (m :: * -> *). Environment m -> m Bool
environmentUseDiff :: m Bool
, forall (m :: * -> *). Environment m -> String -> m ()
environmentExtraChunk :: String -> m ()
, forall (m :: * -> *). Environment m -> String -> m ()
environmentMissingChunk :: String -> m ()
, forall (m :: * -> *). Environment m -> forall a. IO a -> m a
environmentLiftIO :: forall a. IO a -> m a
}

interpretWith :: forall m a. Monad m => Environment m -> FormatM a -> m a
interpretWith :: forall (m :: * -> *) a.
Monad m =>
Environment m -> FormatM a -> m a
interpretWith Environment{m Bool
m Int
m Integer
m [FailureRecord]
m (Maybe Seconds)
m Seconds
String -> m ()
forall a. m a -> m a
forall a. IO a -> m a
environmentLiftIO :: forall a. IO a -> m a
environmentMissingChunk :: String -> m ()
environmentExtraChunk :: String -> m ()
environmentUseDiff :: m Bool
environmentWithInfoColor :: forall a. m a -> m a
environmentWithPendingColor :: forall a. m a -> m a
environmentWithSuccessColor :: forall a. m a -> m a
environmentWithFailColor :: forall a. m a -> m a
environmentWriteTransient :: String -> m ()
environmentWrite :: String -> m ()
environmentGetRealTime :: m Seconds
environmentGetCPUTime :: m (Maybe Seconds)
environmentPrintTimes :: m Bool
environmentUsedSeed :: m Integer
environmentGetFailMessages :: m [FailureRecord]
environmentGetPendingCount :: m Int
environmentGetSuccessCount :: m Int
environmentLiftIO :: forall (m :: * -> *). Environment m -> forall a. IO a -> m a
environmentMissingChunk :: forall (m :: * -> *). Environment m -> String -> m ()
environmentExtraChunk :: forall (m :: * -> *). Environment m -> String -> m ()
environmentUseDiff :: forall (m :: * -> *). Environment m -> m Bool
environmentWithInfoColor :: forall (m :: * -> *). Environment m -> forall a. m a -> m a
environmentWithPendingColor :: forall (m :: * -> *). Environment m -> forall a. m a -> m a
environmentWithSuccessColor :: forall (m :: * -> *). Environment m -> forall a. m a -> m a
environmentWithFailColor :: forall (m :: * -> *). Environment m -> forall a. m a -> m a
environmentWriteTransient :: forall (m :: * -> *). Environment m -> String -> m ()
environmentWrite :: forall (m :: * -> *). Environment m -> String -> m ()
environmentGetRealTime :: forall (m :: * -> *). Environment m -> m Seconds
environmentGetCPUTime :: forall (m :: * -> *). Environment m -> m (Maybe Seconds)
environmentPrintTimes :: forall (m :: * -> *). Environment m -> m Bool
environmentUsedSeed :: forall (m :: * -> *). Environment m -> m Integer
environmentGetFailMessages :: forall (m :: * -> *). Environment m -> m [FailureRecord]
environmentGetPendingCount :: forall (m :: * -> *). Environment m -> m Int
environmentGetSuccessCount :: forall (m :: * -> *). Environment m -> m Int
..} = forall b. FormatM b -> m b
go
  where
    go :: forall b. FormatM b -> m b
    go :: forall b. FormatM b -> m b
go FormatM b
m = case FormatM b
m of
      Pure b
value -> forall (m :: * -> *) a. Monad m => a -> m a
return b
value
      Free FormatF (FormatM b)
action -> case FormatF (FormatM b)
action of
        GetSuccessCount Int -> FormatM b
next -> m Int
environmentGetSuccessCount forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b. FormatM b -> m b
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> FormatM b
next
        GetPendingCount Int -> FormatM b
next -> m Int
environmentGetPendingCount forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b. FormatM b -> m b
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> FormatM b
next
        GetFailMessages [FailureRecord] -> FormatM b
next -> m [FailureRecord]
environmentGetFailMessages forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b. FormatM b -> m b
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FailureRecord] -> FormatM b
next
        UsedSeed Integer -> FormatM b
next -> m Integer
environmentUsedSeed forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b. FormatM b -> m b
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> FormatM b
next
        PrintTimes Bool -> FormatM b
next -> m Bool
environmentPrintTimes forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b. FormatM b -> m b
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> FormatM b
next
        GetCPUTime Maybe Seconds -> FormatM b
next -> m (Maybe Seconds)
environmentGetCPUTime forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b. FormatM b -> m b
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Seconds -> FormatM b
next
        GetRealTime Seconds -> FormatM b
next -> m Seconds
environmentGetRealTime forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b. FormatM b -> m b
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seconds -> FormatM b
next
        Write String
s FormatM b
next -> String -> m ()
environmentWrite String
s forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall b. FormatM b -> m b
go FormatM b
next
        WriteTransient String
s FormatM b
next -> String -> m ()
environmentWriteTransient String
s forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall b. FormatM b -> m b
go FormatM b
next
        WithFailColor FormatM a
inner a -> FormatM b
next -> forall a. m a -> m a
environmentWithFailColor (forall b. FormatM b -> m b
go FormatM a
inner) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b. FormatM b -> m b
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> FormatM b
next
        WithSuccessColor FormatM a
inner a -> FormatM b
next -> forall a. m a -> m a
environmentWithSuccessColor (forall b. FormatM b -> m b
go FormatM a
inner) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b. FormatM b -> m b
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> FormatM b
next
        WithPendingColor FormatM a
inner a -> FormatM b
next -> forall a. m a -> m a
environmentWithPendingColor (forall b. FormatM b -> m b
go FormatM a
inner) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b. FormatM b -> m b
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> FormatM b
next
        WithInfoColor FormatM a
inner a -> FormatM b
next -> forall a. m a -> m a
environmentWithInfoColor (forall b. FormatM b -> m b
go FormatM a
inner) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b. FormatM b -> m b
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> FormatM b
next
        UseDiff Bool -> FormatM b
next -> m Bool
environmentUseDiff forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b. FormatM b -> m b
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> FormatM b
next
        ExtraChunk String
s FormatM b
next -> String -> m ()
environmentExtraChunk String
s forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall b. FormatM b -> m b
go FormatM b
next
        MissingChunk String
s FormatM b
next -> String -> m ()
environmentMissingChunk String
s forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall b. FormatM b -> m b
go FormatM b
next
        LiftIO IO a
inner a -> FormatM b
next -> forall a. IO a -> m a
environmentLiftIO IO a
inner forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b. FormatM b -> m b
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> FormatM b
next

-- | Get the number of successful examples encountered so far.
getSuccessCount :: FormatM Int
getSuccessCount :: FormatM Int
getSuccessCount = forall (f :: * -> *) a. Functor f => f a -> Free f a
liftF (forall next. (Int -> next) -> FormatF next
GetSuccessCount forall a. a -> a
id)

-- | Get the number of pending examples encountered so far.
getPendingCount :: FormatM Int
getPendingCount :: FormatM Int
getPendingCount = forall (f :: * -> *) a. Functor f => f a -> Free f a
liftF (forall next. (Int -> next) -> FormatF next
GetPendingCount forall a. a -> a
id)

-- | Get the number of failed examples encountered so far.
getFailCount :: FormatM Int
getFailCount :: FormatM Int
getFailCount = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FormatM [FailureRecord]
getFailMessages

-- | Get the total number of examples encountered so far.
getTotalCount :: FormatM Int
getTotalCount :: FormatM Int
getTotalCount = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [FormatM Int
getSuccessCount, FormatM Int
getFailCount, FormatM Int
getPendingCount]

-- | Get the list of accumulated failure messages.
getFailMessages :: FormatM [FailureRecord]
getFailMessages :: FormatM [FailureRecord]
getFailMessages = forall (f :: * -> *) a. Functor f => f a -> Free f a
liftF (forall next. ([FailureRecord] -> next) -> FormatF next
GetFailMessages forall a. a -> a
id)

-- | The random seed that is used for QuickCheck.
usedSeed :: FormatM Integer
usedSeed :: FormatM Integer
usedSeed = forall (f :: * -> *) a. Functor f => f a -> Free f a
liftF (forall next. (Integer -> next) -> FormatF next
UsedSeed forall a. a -> a
id)

-- | Return `True` if the user requested time reporting for individual spec
-- items, `False` otherwise.
printTimes :: FormatM Bool
printTimes :: FormatM Bool
printTimes = forall (f :: * -> *) a. Functor f => f a -> Free f a
liftF (forall next. (Bool -> next) -> FormatF next
PrintTimes forall a. a -> a
id)

-- | Get the used CPU time since the test run has been started.
getCPUTime :: FormatM (Maybe Seconds)
getCPUTime :: FormatM (Maybe Seconds)
getCPUTime = forall (f :: * -> *) a. Functor f => f a -> Free f a
liftF (forall next. (Maybe Seconds -> next) -> FormatF next
GetCPUTime forall a. a -> a
id)

-- | Get the passed real time since the test run has been started.
getRealTime :: FormatM Seconds
getRealTime :: FormatM Seconds
getRealTime = forall (f :: * -> *) a. Functor f => f a -> Free f a
liftF (forall next. (Seconds -> next) -> FormatF next
GetRealTime forall a. a -> a
id)

-- | Append some output to the report.
write :: String -> FormatM ()
write :: String -> FormatM ()
write String
s = forall (f :: * -> *) a. Functor f => f a -> Free f a
liftF (forall next. String -> next -> FormatF next
Write String
s ())

-- | The same as `write`, but adds a newline character.
writeLine :: String -> FormatM ()
writeLine :: String -> FormatM ()
writeLine String
s = String -> FormatM ()
write String
s forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> FormatM ()
write String
"\n"

writeTransient :: String -> FormatM ()
writeTransient :: String -> FormatM ()
writeTransient String
s = forall (f :: * -> *) a. Functor f => f a -> Free f a
liftF (forall next. String -> next -> FormatF next
WriteTransient String
s ())

-- | Set output color to red, run given action, and finally restore the default
-- color.
withFailColor :: FormatM a -> FormatM a
withFailColor :: forall a. FormatM a -> FormatM a
withFailColor FormatM a
s = forall (f :: * -> *) a. Functor f => f a -> Free f a
liftF (forall next a. FormatM a -> (a -> next) -> FormatF next
WithFailColor FormatM a
s forall a. a -> a
id)

-- | Set output color to green, run given action, and finally restore the
-- default color.
withSuccessColor :: FormatM a -> FormatM a
withSuccessColor :: forall a. FormatM a -> FormatM a
withSuccessColor FormatM a
s = forall (f :: * -> *) a. Functor f => f a -> Free f a
liftF (forall next a. FormatM a -> (a -> next) -> FormatF next
WithSuccessColor FormatM a
s forall a. a -> a
id)

-- | Set output color to yellow, run given action, and finally restore the
-- default color.
withPendingColor :: FormatM a -> FormatM a
withPendingColor :: forall a. FormatM a -> FormatM a
withPendingColor FormatM a
s = forall (f :: * -> *) a. Functor f => f a -> Free f a
liftF (forall next a. FormatM a -> (a -> next) -> FormatF next
WithPendingColor FormatM a
s forall a. a -> a
id)

-- | Set output color to cyan, run given action, and finally restore the
-- default color.
withInfoColor :: FormatM a -> FormatM a
withInfoColor :: forall a. FormatM a -> FormatM a
withInfoColor FormatM a
s = forall (f :: * -> *) a. Functor f => f a -> Free f a
liftF (forall next a. FormatM a -> (a -> next) -> FormatF next
WithInfoColor FormatM a
s forall a. a -> a
id)

-- | Return `True` if the user requested colorized diffs, `False` otherwise.
useDiff :: FormatM Bool
useDiff :: FormatM Bool
useDiff = forall (f :: * -> *) a. Functor f => f a -> Free f a
liftF (forall next. (Bool -> next) -> FormatF next
UseDiff forall a. a -> a
id)

-- | Output given chunk in red.
extraChunk :: String -> FormatM ()
extraChunk :: String -> FormatM ()
extraChunk String
s = forall (f :: * -> *) a. Functor f => f a -> Free f a
liftF (forall next. String -> next -> FormatF next
ExtraChunk String
s ())

-- | Output given chunk in green.
missingChunk :: String -> FormatM ()
missingChunk :: String -> FormatM ()
missingChunk String
s = forall (f :: * -> *) a. Functor f => f a -> Free f a
liftF (forall next. String -> next -> FormatF next
MissingChunk String
s ())