hspec-api-2.11.0: src/Test/Hspec/Api/Format/V1.hs

{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE LambdaCase #-}
-- |
-- Stability: stable
module Test.Hspec.Api.Format.V1 (
  Format
, FormatConfig(..)
, Event(..)
, Progress
, Path
, Location(..)
, Seconds(..)
, Item(..)
, Result(..)
, FailureReason(..)
, monadic

-- * Register a formatter
, registerFormatter
, useFormatter
, liftFormatter

-- * Re-exports
, SpecWith
, Config
, modifyConfig
) where

import qualified Test.Hspec.Core.Format as Latest
import qualified Test.Hspec.Api.Format.V2 as V2
import           Test.Hspec.Api.Format.V2 hiding (
    registerFormatter
  , useFormatter
  , liftFormatter
  , FormatConfig(..)
  , Item(..)
  , FailureReason(..)
  , Result(..)
  , Event(..)
  , Format
  , monadic
  )

import           Control.Monad.IO.Class
import           Test.Hspec.Api.Format.V1.Internal

-- |
-- Make a formatter available for use with @--format@.
registerFormatter :: (String, FormatConfig -> IO Format) -> Config -> Config
registerFormatter = V2.registerFormatter . liftFormatterToV2

-- |
-- Make a formatter available for use with @--format@ and use it by default.
useFormatter :: (String, FormatConfig -> IO Format) -> Config -> Config
useFormatter = V2.useFormatter . liftFormatterToV2

-- | Make a formatter compatible with types from "Test.Hspec.Core.Format".
liftFormatter :: (String, FormatConfig -> IO Format) -> (String, Latest.FormatConfig -> IO Latest.Format)
liftFormatter = V2.liftFormatter . liftFormatterToV2

liftFormatterToV2 :: (String, FormatConfig -> IO Format) -> (String, V2.FormatConfig -> IO V2.Format)
liftFormatterToV2 = fmap lift
  where
    lift :: (FormatConfig -> IO Format) -> V2.FormatConfig -> IO V2.Format
    lift format = fmap liftFormat . format . unliftFormatConfig

data FormatConfig = FormatConfig {
  formatConfigUseColor :: Bool
, formatConfigReportProgress :: Bool
, formatConfigOutputUnicode :: Bool
, formatConfigUseDiff :: Bool
, formatConfigDiffContext :: Maybe Int
, formatConfigExternalDiff :: Maybe (String -> String -> IO ())
, formatConfigPrettyPrint :: Bool -- ^ Deprecated: use `formatConfigPrettyPrintFunction` instead
, formatConfigPrettyPrintFunction :: Maybe (String -> String -> (String, String))
, formatConfigPrintTimes :: Bool
, formatConfigHtmlOutput :: Bool
, formatConfigPrintCpuTime :: Bool
, formatConfigUsedSeed :: Integer
, formatConfigExpectedTotalCount :: Int
}

unliftFormatConfig :: V2.FormatConfig -> FormatConfig
unliftFormatConfig config = FormatConfig {
  formatConfigUseColor = V2.formatConfigUseColor config
, formatConfigReportProgress = V2.formatConfigReportProgress config
, formatConfigOutputUnicode = V2.formatConfigOutputUnicode config
, formatConfigUseDiff = V2.formatConfigUseDiff config
, formatConfigDiffContext = V2.formatConfigDiffContext config
, formatConfigExternalDiff = V2.formatConfigExternalDiff config
, formatConfigPrettyPrint = maybe False (const True) $ V2.formatConfigPrettyPrintFunction config
, formatConfigPrettyPrintFunction = V2.formatConfigPrettyPrintFunction config
, formatConfigPrintTimes = V2.formatConfigPrintTimes config
, formatConfigHtmlOutput = V2.formatConfigHtmlOutput config
, formatConfigPrintCpuTime = V2.formatConfigPrintCpuTime config
, formatConfigUsedSeed = V2.formatConfigUsedSeed config
, formatConfigExpectedTotalCount = V2.formatConfigExpectedTotalCount config
}

type Format = Event -> IO ()

liftFormat :: Format -> V2.Format
liftFormat format event = format (unliftEvent event)

unliftFormat :: V2.Format -> Format
unliftFormat format event = format (liftEvent event)

data Event =
    Started
  | GroupStarted Path
  | GroupDone Path
  | Progress Path Progress
  | ItemStarted Path
  | ItemDone Path Item
  | Done [(Path, Item)]
  deriving Show

liftEvent :: Event -> V2.Event
liftEvent = \ case
  Started -> V2.Started
  GroupStarted path -> V2.GroupStarted path
  GroupDone path -> V2.GroupDone path
  Progress path progress -> V2.Progress path progress
  ItemStarted path -> V2.ItemStarted path
  ItemDone path item -> V2.ItemDone path (liftItem item)
  Done result -> V2.Done (map (fmap liftItem) result)

unliftEvent :: V2.Event -> Event
unliftEvent = \ case
  V2.Started -> Started
  V2.GroupStarted path -> GroupStarted path
  V2.GroupDone path -> GroupDone path
  V2.Progress path progress -> Progress path progress
  V2.ItemStarted path -> ItemStarted path
  V2.ItemDone path item -> ItemDone path (unliftItem item)
  V2.Done result -> Done (map (fmap unliftItem) result)

monadic :: MonadIO m => (m () -> IO ()) -> (Event -> m ()) -> IO Format
monadic run format = unliftFormat <$> V2.monadic run (format . unliftEvent)