<commit_before>{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}
module Test.Hspec.Core.Formatters.Internal (
  FormatM
, FormatConfig(..)
, runFormatM
, interpret
, increaseSuccessCount
, increasePendingCount
, addFailMessage
, finally_
, formatterToFormat
#ifdef TEST
, overwriteWith
#endif
) where

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

import qualified System.IO as IO
import           System.IO (Handle)
import           Control.Exception (AsyncException(..), bracket_, try, throwIO)
import           System.Console.ANSI
import           Control.Monad.Trans.State hiding (state, gets, modify)
import           Control.Monad.IO.Class
import           Data.Char (isSpace)
import qualified System.CPUTime as CPUTime

import qualified Test.Hspec.Core.Formatters.Monad as M
import           Test.Hspec.Core.Formatters.Monad (Environment(..), interpretWith, FailureRecord(..))
import           Test.Hspec.Core.Format
import           Test.Hspec.Core.Clock

formatterToFormat :: M.Formatter -> FormatConfig -> Format FormatM
formatterToFormat formatter config = Format {
  formatRun = \action -> runFormatM config $ do
    interpret (M.headerFormatter formatter)
    a <- action `finally_` interpret (M.failedFormatter formatter)
    interpret (M.footerFormatter formatter)
    return a
, formatGroupStarted = \ (nesting, name) -> interpret $ M.exampleGroupStarted formatter nesting name
, formatGroupDone = \ _ -> interpret (M.exampleGroupDone formatter)
, formatProgress = \ path progress -> when useColor $ do
    interpret $ M.exampleProgress formatter path progress
, formatItem = \ path (Item loc _duration info result) -> do
    clearTransientOutput
    case result of
      Success -> do
        increaseSuccessCount
        interpret $ M.exampleSucceeded formatter path info
      Pending reason -> do
        increasePendingCount
        interpret $ M.examplePending formatter path info reason
      Failure err -> do
        addFailMessage loc path err
        interpret $ M.exampleFailed formatter path info err
} where
    useColor = formatConfigUseColor config

interpret :: M.FormatM a -> FormatM a
interpret = interpretWith Environment {
  environmentGetSuccessCount = getSuccessCount
, environmentGetPendingCount = getPendingCount
, environmentGetFailMessages = getFailMessages
, environmentUsedSeed = usedSeed
, environmentGetCPUTime = getCPUTime
, environmentGetRealTime = getRealTime
, environmentWrite = write
, environmentWriteTransient = writeTransient
, environmentWithFailColor = withFailColor
, environmentWithSuccessColor = withSuccessColor
, environmentWithPendingColor = withPendingColor
, environmentWithInfoColor = withInfoColor
, environmentUseDiff = gets (formatConfigUseDiff . stateConfig)
, environmentExtraChunk = extraChunk
, environmentMissingChunk = missingChunk
, environmentLiftIO = liftIO
}

-- | A lifted version of `Control.Monad.Trans.State.gets`
gets :: (FormatterState -> a) -> FormatM a
gets f = FormatM $ do
  f <$> (get >>= liftIO . readIORef)

-- | A lifted version of `Control.Monad.Trans.State.modify`
modify :: (FormatterState -> FormatterState) -> FormatM ()
modify f = FormatM $ do
  get >>= liftIO . (`modifyIORef'` f)

data FormatConfig = FormatConfig {
  formatConfigHandle :: Handle
, formatConfigUseColor :: Bool
, formatConfigUseDiff :: Bool
, formatConfigHtmlOutput :: Bool
, formatConfigPrintCpuTime :: Bool
, formatConfigUsedSeed :: Integer
} deriving (Eq, Show)

data FormatterState = FormatterState {
  stateSuccessCount    :: Int
, statePendingCount    :: Int
, stateFailMessages    :: [FailureRecord]
, stateCpuStartTime    :: Maybe Integer
, stateStartTime       :: Seconds
, stateTransientOutput :: String
, stateConfig :: FormatConfig
}

getConfig :: (FormatConfig -> a) -> FormatM a
getConfig f = gets (f . stateConfig)

getHandle :: FormatM Handle
getHandle = getConfig formatConfigHandle

-- | The random seed that is used for QuickCheck.
usedSeed :: FormatM Integer
usedSeed = getConfig formatConfigUsedSeed

-- NOTE: We use an IORef here, so that the state persists when UserInterrupt is<commit_msg>bug: Accumulate success / pending count strictly<commit_after>{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}
module Test.Hspec.Core.Formatters.Internal (
  FormatM
, FormatConfig(..)
, runFormatM
, interpret
, increaseSuccessCount
, increasePendingCount
, addFailMessage
, finally_
, formatterToFormat
#ifdef TEST
, overwriteWith
#endif
) where

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

import qualified System.IO as IO
import           System.IO (Handle)
import           Control.Exception (AsyncException(..), bracket_, try, throwIO)
import           System.Console.ANSI
import           Control.Monad.Trans.State hiding (state, gets, modify)
import           Control.Monad.IO.Class
import           Data.Char (isSpace)
import qualified System.CPUTime as CPUTime

import qualified Test.Hspec.Core.Formatters.Monad as M
import           Test.Hspec.Core.Formatters.Monad (Environment(..), interpretWith, FailureRecord(..))
import           Test.Hspec.Core.Format
import           Test.Hspec.Core.Clock

formatterToFormat :: M.Formatter -> FormatConfig -> Format FormatM
formatterToFormat formatter config = Format {
  formatRun = \action -> runFormatM config $ do
    interpret (M.headerFormatter formatter)
    a <- action `finally_` interpret (M.failedFormatter formatter)
    interpret (M.footerFormatter formatter)
    return a
, formatGroupStarted = \ (nesting, name) -> interpret $ M.exampleGroupStarted formatter nesting name
, formatGroupDone = \ _ -> interpret (M.exampleGroupDone formatter)
, formatProgress = \ path progress -> when useColor $ do
    interpret $ M.exampleProgress formatter path progress
, formatItem = \ path (Item loc _duration info result) -> do
    clearTransientOutput
    case result of
      Success -> do
        increaseSuccessCount
        interpret $ M.exampleSucceeded formatter path info
      Pending reason -> do
        increasePendingCount
        interpret $ M.examplePending formatter path info reason
      Failure err -> do
        addFailMessage loc path err
        interpret $ M.exampleFailed formatter path info err
} where
    useColor = formatConfigUseColor config

interpret :: M.FormatM a -> FormatM a
interpret = interpretWith Environment {
  environmentGetSuccessCount = getSuccessCount
, environmentGetPendingCount = getPendingCount
, environmentGetFailMessages = getFailMessages
, environmentUsedSeed = usedSeed
, environmentGetCPUTime = getCPUTime
, environmentGetRealTime = getRealTime
, environmentWrite = write
, environmentWriteTransient = writeTransient
, environmentWithFailColor = withFailColor
, environmentWithSuccessColor = withSuccessColor
, environmentWithPendingColor = withPendingColor
, environmentWithInfoColor = withInfoColor
, environmentUseDiff = gets (formatConfigUseDiff . stateConfig)
, environmentExtraChunk = extraChunk
, environmentMissingChunk = missingChunk
, environmentLiftIO = liftIO
}

-- | A lifted version of `Control.Monad.Trans.State.gets`
gets :: (FormatterState -> a) -> FormatM a
gets f = FormatM $ do
  f <$> (get >>= liftIO . readIORef)

-- | A lifted version of `Control.Monad.Trans.State.modify`
modify :: (FormatterState -> FormatterState) -> FormatM ()
modify f = FormatM $ do
  get >>= liftIO . (`modifyIORef'` f)

data FormatConfig = FormatConfig {
  formatConfigHandle :: Handle
, formatConfigUseColor :: Bool
, formatConfigUseDiff :: Bool
, formatConfigHtmlOutput :: Bool
, formatConfigPrintCpuTime :: Bool
, formatConfigUsedSeed :: Integer
} deriving (Eq, Show)

data FormatterState = FormatterState {
  stateSuccessCount    :: !Int
, statePendingCount    :: !Int
, stateFailMessages    :: [FailureRecord]
, stateCpuStartTime    :: Maybe Integer
, stateStartTime       :: Seconds
, stateTransientOutput :: String
, stateConfig :: FormatConfig
}

getConfig :: (FormatConfig -> a) -> FormatM a
getConfig f = gets (f . stateConfig)

getHandle :: FormatM Handle
getHandle = getConfig formatConfigHandle

-- | The random seed that is used for QuickCheck.
usedSeed :: FormatM Integer
usedSeed = getConfig formatConfigUsedSeed

-- NOTE: We use an IORef here, so that the state persists when UserInterrupt is
{'fraction_non_alphanumeric': 0.0829593693147362, 'fraction_numerical': 0.0, 'mean_word_length': 3.9734620024125453, 'pattern_counts': {'":': 0, '<': 7, '<?xml version=': 0, '>': 47, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '411398', 'n_tokens_mistral': 2254, 'n_tokens_neox': 2235, 'n_words': 654}