Definition.hs

{-# LANGUAGE CPP #-}
module Test.Hspec.Core.Config.Definition (
  Config(..)
, ColorMode(..)
, UnicodeMode(..)
, mkDefaultConfig

, filterOr

, setConfigAnnotation
, getConfigAnnotation

, addExtensionOptions
, getExtensionOptions

, getSeed
#ifdef ENABLE_LEGACY_V1_FORMATTERS
, getFormatter
#endif

, commandLineOnlyOptions
, formatterOptions
, smallCheckOptions
, quickCheckOptions
, runnerOptions

, flag
, option

#ifdef TEST
, splitOn
#endif
) where

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

import           System.Directory (getTemporaryDirectory, removeFile)
import           System.IO (openTempFile, hClose)
import           System.Process (system)

import           Test.Hspec.Core.Annotations (Annotations)
import qualified Test.Hspec.Core.Annotations as Annotations

import           Test.Hspec.Core.Format (Format, FormatConfig)
import           Test.Hspec.Core.Formatters.Pretty (pretty2)
#ifdef ENABLE_LEGACY_V1_FORMATTERS
import qualified Test.Hspec.Core.Formatters.V1.Monad as V1
import qualified Test.Hspec.Core.Formatters.V1.Internal as V1 (formatterToFormat)
#endif
import           Test.Hspec.Core.Util

import           GetOpt.Declarative

setConfigAnnotation :: Typeable value => value -> Config -> Config
setConfigAnnotation value config = config { configAnnotations = Annotations.setValue value $ configAnnotations config }

getConfigAnnotation :: Typeable value => Config -> Maybe value
getConfigAnnotation = Annotations.getValue . configAnnotations

newtype ExtensionOptions = ExtensionOptions { unExtensionOptions :: [(String, [Option Config])] }

addExtensionOptions :: String -> [Option Config] -> Config -> Config
addExtensionOptions section opts config = setExtensionOptions ((section, opts) : getExtensionOptions config) config

setExtensionOptions :: [(String, [Option Config])] -> Config -> Config
setExtensionOptions = setConfigAnnotation . ExtensionOptions

getExtensionOptions :: Config -> [(String, [Option Config])]
getExtensionOptions = maybe [] unExtensionOptions . getConfigAnnotation

#ifdef ENABLE_LEGACY_V1_FORMATTERS
getFormatter :: Config -> Maybe (FormatConfig -> IO Format)
getFormatter config = configFormat config <|> V1.formatterToFormat <$> configFormatter config
#endif

getSeed :: Config -> Maybe Integer
getSeed config = configSeed config <|> configQuickCheckSeed config

data ColorMode = ColorAuto | ColorNever | ColorAlways
  deriving (Eq, Show)

data UnicodeMode = UnicodeAuto | UnicodeNever | UnicodeAlways
  deriving (Eq, Show)

data Config = Config {
  configIgnoreConfigFile :: Bool
, configDryRun :: Bool
, configFocusedOnly :: Bool
, configFailOnEmpty :: Bool
, configFailOnFocused :: Bool
, configFailOnPending :: Bool
, configFailOnEmptyDescription :: Bool
, configPrintSlowItems :: Maybe Int
, configPrintCpuTime :: Bool
, configFailFast :: Bool
, configRandomize :: Bool
, configSeed :: Maybe Integer
, configQuickCheckSeed :: Maybe Integer
, configFailureReport :: Maybe FilePath
, configRerun :: Bool
, configRerunAllOnSuccess :: Bool

-- |
-- A predicate that is used to filter the spec before it is run.  Only examples
-- that satisfy the predicate are run.
, configFilterPredicate :: Maybe (Path -> Bool)
, configSkipPredicate :: Maybe (Path -> Bool)
, configQuickCheckMaxSuccess :: Maybe Int
, configQuickCheckMaxDiscardRatio :: Maybe Int
, configQuickCheckMaxSize :: Maybe Int
, configQuickCheckMaxShrinks :: Maybe Int
, configSmallCheckDepth :: Maybe Int
, configColorMode :: ColorMode
, configUnicodeMode :: UnicodeMode
, configDiff :: Bool
, configDiffContext :: Maybe Int

-- |
-- An action that is used to print diffs.  The first argument is the value of
-- `configDiffContext`.  The remaining two arguments are the @expected@ and
-- @actual@ value.
--
-- @since 2.10.6
, configExternalDiff :: Maybe (Maybe Int -> String -> String -> IO ())

, configPrettyPrint :: Bool
, configPrettyPrintFunction :: Bool -> String -> String -> (String, String)
, configFormatException :: SomeException -> String -- ^ @since 2.11.5
, configTimes :: Bool
, configExpertMode :: Bool -- ^ @since 2.11.2
, configAvailableFormatters :: [(String, FormatConfig -> IO Format)] -- ^ @since 2.9.0
, configFormat :: Maybe (FormatConfig -> IO Format)
#ifdef ENABLE_LEGACY_V1_FORMATTERS
, configFormatter :: Maybe V1.Formatter
#endif
, configHtmlOutput :: Bool
, configConcurrentJobs :: Maybe Int
, configAnnotations :: Annotations
}
#ifdef ENABLE_LEGACY_V1_FORMATTERS
{-# DEPRECATED configFormatter "Use [@useFormatter@](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Formatters-V1.html#v:useFormatter) instead." #-}
#endif
{-# DEPRECATED configQuickCheckSeed "Use `configSeed` instead." #-}

mkDefaultConfig :: [(String, FormatConfig -> IO Format)] -> Config
mkDefaultConfig formatters = Config {
  configIgnoreConfigFile = False
, configDryRun = False
, configFocusedOnly = False
, configFailOnEmpty = False
, configFailOnFocused = False
, configFailOnPending = False
, configFailOnEmptyDescription = False
, configPrintSlowItems = Nothing
, configPrintCpuTime = False
, configFailFast = False
, configRandomize = False
, configSeed = Nothing
, configQuickCheckSeed = Nothing
, configFailureReport = Nothing
, configRerun = False
, configRerunAllOnSuccess = False
, configFilterPredicate = Nothing
, configSkipPredicate = Nothing
, configQuickCheckMaxSuccess = Nothing
, configQuickCheckMaxDiscardRatio = Nothing
, configQuickCheckMaxSize = Nothing
, configQuickCheckMaxShrinks = Nothing
, configSmallCheckDepth = Nothing
, configColorMode = ColorAuto
, configUnicodeMode = UnicodeAuto
, configDiff = True
, configDiffContext = Just defaultDiffContext
, configExternalDiff = Nothing
, configPrettyPrint = True
, configPrettyPrintFunction = pretty2
, configFormatException = formatExceptionWith show
, configTimes = False
, configExpertMode = False
, configAvailableFormatters = formatters
, configFormat = Nothing
#ifdef ENABLE_LEGACY_V1_FORMATTERS
, configFormatter = Nothing
#endif
, configHtmlOutput = False
, configConcurrentJobs = Nothing
, configAnnotations = mempty
}

defaultDiffContext :: Int
defaultDiffContext = 3

externalDiff :: String -> String -> String -> IO ()
externalDiff command expected actual = do
  tmp <- getTemporaryDirectory
  withTempFile tmp "hspec-expected" expected $ \ expectedFile -> do
    withTempFile tmp "hspec-actual" actual $ \ actualFile -> do
      void . system $ unwords [command, expectedFile, actualFile]

withTempFile :: FilePath -> FilePath -> String -> (FilePath -> IO a) -> IO a
withTempFile dir file contents action = do
  bracket (openTempFile dir file) (removeFile . fst) $ \ (path, h) -> do
    hClose h
    writeFile path contents
    action path

option :: String -> OptionSetter config -> String -> Option config
option name arg help = Option name Nothing arg help True

flag :: String -> (Bool -> config -> config) -> String -> Option config
flag name setter = option name (Flag setter)

mkOptionNoArg :: String -> Maybe Char -> (Config -> Config) -> String -> Option Config
mkOptionNoArg name shortcut setter help = Option name shortcut (NoArg setter) help True

mkOption :: String -> Maybe Char -> OptionSetter Config -> String -> Option Config
mkOption name shortcut arg help = Option name shortcut arg help True

undocumented :: Option config -> Option config
undocumented opt = opt {optionDocumented = False}

argument :: String -> (String -> Maybe a) -> (a -> config -> config) -> OptionSetter config
argument name parser setter = Arg name $ \ input c -> flip setter c <$> parser input

formatterOptions :: [(String, FormatConfig -> IO Format)] -> [Option Config]
formatterOptions formatters = [
    mkOption "format" (Just 'f') (argument "NAME" readFormatter setFormatter) helpForFormat
  , flag "color" setColor "colorize the output"
  , flag "unicode" setUnicode "output unicode"
  , flag "diff" setDiff "show colorized diffs"
  , option "diff-context" (argument "N" readDiffContext setDiffContext) $ unlines [
        "output N lines of diff context (default: " <> show defaultDiffContext <> ")"
      , "use a value of 'full' to see the full context"
      ]
  , option "diff-command" (argument "CMD" return setDiffCommand) "use an external diff command\nexample: --diff-command=\"git diff\""
  , flag "pretty" setPretty "try to pretty-print diff values"
  , mkOptionNoArg "show-exceptions" Nothing setShowException "use `show` when formatting exceptions"
  , mkOptionNoArg "display-exceptions" Nothing setDisplayException "use `displayException` when formatting exceptions"

  , flag "times" setTimes "report times for individual spec items"
  , mkOptionNoArg "print-cpu-time" Nothing setPrintCpuTime "include used CPU time in summary"
  , printSlowItemsOption
  , flag "expert" setExpertMode "be less verbose"

    -- undocumented for now, as we probably want to change this to produce a
    -- standalone HTML report in the future
  , undocumented $ mkOptionNoArg "html" Nothing setHtml "produce HTML output"
  ]
  where
    setDiffCommand :: String -> Config -> Config
    setDiffCommand command config = config {
      configExternalDiff = case strip command of
        "" -> Nothing
        _ -> Just $ \ _context -> externalDiff command
    }

    setHtml config = config {configHtmlOutput = True}

    helpForFormat :: String
    helpForFormat = "use a custom formatter; this can be one of " ++ (formatOrList $ map fst formatters)

    readFormatter :: String -> Maybe (FormatConfig -> IO Format)
    readFormatter = (`lookup` formatters)

    setFormatter :: (FormatConfig -> IO Format) -> Config -> Config
    setFormatter f c = c {configFormat = Just f}

    setColor :: Bool -> Config -> Config
    setColor v config = config {configColorMode = if v then ColorAlways else ColorNever}

    setUnicode :: Bool -> Config -> Config
    setUnicode v config = config {configUnicodeMode = if v then UnicodeAlways else UnicodeNever}

    setDiff :: Bool -> Config -> Config
    setDiff v config = config {configDiff = v}

    readDiffContext :: String -> Maybe (Maybe Int)
    readDiffContext input = case input of
      "full" -> Just Nothing
      _ -> case readMaybe input of
        Nothing -> Nothing
        mn -> Just (find (>= 0) mn)

    setDiffContext :: Maybe Int -> Config -> Config
    setDiffContext value c = c { configDiffContext = value }

    setPretty :: Bool -> Config -> Config
    setPretty v config = config {configPrettyPrint = v}

    setShowException :: Config -> Config
    setShowException config = config {configFormatException = formatExceptionWith show}

    setDisplayException :: Config -> Config
    setDisplayException config = config {configFormatException = formatExceptionWith displayException}

    setTimes :: Bool -> Config -> Config
    setTimes v config = config {configTimes = v}

    setPrintCpuTime config = config {configPrintCpuTime = True}

    setExpertMode :: Bool -> Config -> Config
    setExpertMode v config = config {configExpertMode = v}

printSlowItemsOption :: Option Config
printSlowItemsOption = Option name (Just 'p') (OptArg "N" arg) "print the N slowest spec items (default: 10)" True
  where
    name = "print-slow-items"

    setter :: Maybe Int -> Config -> Config
    setter v c = c {configPrintSlowItems = v}

    arg :: Maybe String -> Config -> Maybe Config
    arg = maybe (Just . (setter $ Just 10)) parseArg

    parseArg :: String -> Config -> Maybe Config
    parseArg input c = case readMaybe input of
      Nothing -> Nothing
      mn -> Just (setter (find (> 0) mn) c)

smallCheckOptions :: [Option Config]
smallCheckOptions = [
    option "depth" (argument "N" readMaybe setDepth) "maximum depth of generated test values for SmallCheck properties"
  ]

setDepth :: Int -> Config -> Config
setDepth n c = c {configSmallCheckDepth = Just n}

quickCheckOptions :: [Option Config]
quickCheckOptions = [
    Option "qc-max-success" (Just 'a') (argument "N" readMaybe setMaxSuccess) "maximum number of successful tests before a QuickCheck property succeeds" True
  , option "qc-max-discard" (argument "N" readMaybe setMaxDiscardRatio) "maximum number of discarded tests per successful test before giving up"
  , option "qc-max-size" (argument "N" readMaybe setMaxSize) "size to use for the biggest test cases"
  , option "qc-max-shrinks" (argument "N" readMaybe setMaxShrinks) "maximum number of shrinks to perform before giving up (a value of 0 turns shrinking off)"

    -- for compatibility with test-framework
  , undocumented $ option "maximum-generated-tests" (argument "NUMBER" readMaybe setMaxSuccess) "how many automated tests something like QuickCheck should try, by default"
  ]

setMaxSuccess :: Int -> Config -> Config
setMaxSuccess n c = c {configQuickCheckMaxSuccess = Just n}

setMaxDiscardRatio :: Int -> Config -> Config
setMaxDiscardRatio n c = c {configQuickCheckMaxDiscardRatio = Just n}

setMaxSize :: Int -> Config -> Config
setMaxSize n c = c {configQuickCheckMaxSize = Just n}

setMaxShrinks :: Int -> Config -> Config
setMaxShrinks n c = c {configQuickCheckMaxShrinks = Just n}

setSeed :: Integer -> Config -> Config
setSeed n c = c {configSeed = Just n}

data FailOn =
    FailOnEmpty
  | FailOnFocused
  | FailOnPending
  | FailOnEmptyDescription
  deriving (Bounded, Enum)

allFailOnItems :: [FailOn]
allFailOnItems = [minBound .. maxBound]

showFailOn :: FailOn -> String
showFailOn item = case item of
  FailOnEmpty -> "empty"
  FailOnFocused -> "focused"
  FailOnPending -> "pending"
  FailOnEmptyDescription -> "empty-description"

readFailOn :: String -> Maybe FailOn
readFailOn = (`lookup` items)
  where
    items = map (showFailOn &&& id) allFailOnItems

splitOn :: Char -> String -> [String]
splitOn sep = go
  where
    go xs =  case break (== sep) xs of
      ("", "") -> []
      (y, "") -> [y]
      (y, _ : ys) -> y : go ys

runnerOptions :: [Option Config]
runnerOptions = [
    flag "dry-run" setDryRun "pretend that everything passed; don't verify anything"
  , flag "focused-only" setFocusedOnly "do not run anything, unless there are focused spec items"

  , undocumented $ flag "fail-on-focused" setFailOnFocused "fail on focused spec items"
  , undocumented $ flag "fail-on-pending" setFailOnPending "fail on pending spec items"

  , mkOption    "fail-on" Nothing (argument "ITEMS" readFailOnItems (setFailOnItems True )) helpForFailOn
  , mkOption "no-fail-on" Nothing (argument "ITEMS" readFailOnItems (setFailOnItems False)) helpForFailOn
  , flag "strict" setStrict $ "same as --fail-on=" <> showFailOnItems strict

  , flag "fail-fast" setFailFast "abort on first failure"
  , flag "randomize" setRandomize "randomize execution order"
  , (flag "rerun" setRerun "rerun all examples that failed in the previous test run (only works in combination with --failure-report or in GHCi)") {optionShortcut = Just 'r'}
  , option "failure-report" (argument "FILE" return setFailureReport) "read/write a failure report for use with --rerun"
  , flag "rerun-all-on-success" setRerunAllOnSuccess "run the whole test suite after a previously failing rerun succeeds for the first time (only works in combination with --rerun)"
  , mkOption "jobs" (Just 'j') (argument "N" readMaxJobs setMaxJobs) "run at most N parallelizable tests simultaneously (default: number of available processors)"
  , option "seed" (argument "N" readMaybe setSeed) "used seed for --randomize and QuickCheck properties"
  ]
  where
    strict = [FailOnFocused, FailOnPending]

    readFailOnItems :: String -> Maybe [FailOn]
    readFailOnItems = mapM readFailOn . splitOn ','

    showFailOnItems :: [FailOn] -> String
    showFailOnItems = intercalate "," . map showFailOn

    helpForFailOn :: String
    helpForFailOn = unlines . flip map allFailOnItems $ \ item ->
      showFailOn item <> ": " <> help item
      where
        help item = case item of
          FailOnEmpty -> "fail if all spec items have been filtered"
          FailOnFocused -> "fail on focused spec items"
          FailOnPending -> "fail on pending spec items"
          FailOnEmptyDescription -> "fail on empty descriptions"

    setFailOnItems :: Bool -> [FailOn] -> Config -> Config
    setFailOnItems value = flip $ foldr (`setItem` value)
      where
        setItem item = case item of
          FailOnEmpty -> setFailOnEmpty
          FailOnFocused -> setFailOnFocused
          FailOnPending -> setFailOnPending
          FailOnEmptyDescription -> setFailOnEmptyDescription

    readMaxJobs :: String -> Maybe Int
    readMaxJobs s = do
      n <- readMaybe s
      guard $ n > 0
      return n

    setFailureReport :: String -> Config -> Config
    setFailureReport file c = c {configFailureReport = Just file}

    setMaxJobs :: Int -> Config -> Config
    setMaxJobs n c = c {configConcurrentJobs = Just n}

    setDryRun :: Bool -> Config -> Config
    setDryRun value config = config {configDryRun = value}

    setFocusedOnly :: Bool -> Config -> Config
    setFocusedOnly value config = config {configFocusedOnly = value}

    setFailOnEmpty :: Bool -> Config -> Config
    setFailOnEmpty value config = config {configFailOnEmpty = value}

    setFailOnFocused :: Bool -> Config -> Config
    setFailOnFocused value config = config {configFailOnFocused = value}

    setFailOnPending :: Bool -> Config -> Config
    setFailOnPending value config = config {configFailOnPending = value}

    setFailOnEmptyDescription :: Bool -> Config -> Config
    setFailOnEmptyDescription value config = config {configFailOnEmptyDescription = value}

    setStrict :: Bool -> Config -> Config
    setStrict = (`setFailOnItems` strict)

    setFailFast :: Bool -> Config -> Config
    setFailFast value config = config {configFailFast = value}

    setRandomize :: Bool -> Config -> Config
    setRandomize value config = config {configRandomize = value}

    setRerun :: Bool -> Config -> Config
    setRerun value config = config {configRerun = value}

    setRerunAllOnSuccess :: Bool -> Config -> Config
    setRerunAllOnSuccess value config = config {configRerunAllOnSuccess = value}

commandLineOnlyOptions :: [Option Config]
commandLineOnlyOptions = [
    mkOptionNoArg "ignore-dot-hspec" Nothing setIgnoreConfigFile "do not read options from ~/.hspec and .hspec"
  , mkOption "match" (Just 'm') (argument "PATTERN" return addMatch) "only run examples that match given PATTERN"
  , option "skip" (argument "PATTERN" return addSkip) "skip examples that match given PATTERN"
  ]
  where
    setIgnoreConfigFile config = config {configIgnoreConfigFile = True}

addMatch :: String -> Config -> Config
addMatch s c = c {configFilterPredicate = Just (filterPredicate s) `filterOr` configFilterPredicate c}

addSkip :: String -> Config -> Config
addSkip s c = c {configSkipPredicate = Just (filterPredicate s) `filterOr` configSkipPredicate c}

filterOr :: Maybe (Path -> Bool) -> Maybe (Path -> Bool) -> Maybe (Path -> Bool)
filterOr p1_ p2_ = case (p1_, p2_) of
  (Just p1, Just p2) -> Just $ \path -> p1 path || p2 path
  _ -> p1_ <|> p2_

formatOrList :: [String] -> String
formatOrList xs = case xs of
  [] -> ""
  x : ys -> (case ys of
    [] -> x
    _ : [] -> x ++ " or "
    _ : _ : _ -> x ++ ", ") ++ formatOrList ys