diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,32 +1,53 @@ # Changelog +## [0.16.0.0] - 2024-08-03 + +### Changed + +* `opt-env-conf`-based settings parsing. + ## [0.15.1.3] - 2024-07-20 +### Changed + * Fix race condition in the asynchronous runner ## [0.15.1.2] - 2024-07-18 +### Changed + * Fix parsing filter flags so it becomes easy to select tests with spaces in their description ## [0.15.1.1] - 2023-10-04 +### Changed + * Compatibility with `optparse-applicative > 0.18`. * Compatibility with `GHC >= 9.7`. * Refactored out `fast-myers-diff` into its own package. ## [0.15.1.0] - 2023-07-28 +### Added + * `setupAroundWithAll`: so it's easier to use multiple outer resources to provide an inner resource, without the need of extra type annotation. ## [0.15.0.0] - 2023-04-08 +### Added + * `DefBeforeAllWithNode`: so that `beforeAllWith` can be defined in terms of it and have better parallelism properties. * `DefSetupNode`: so that `beforeAll_` can be defined in terms of it and have better parallelism properties. ## [0.14.0.0] - 2023-04-05 +### Added + * Profiling mode, for figuring out why your test suite is slow. Use `--profile` to turn it on. + +### Changed + * An improved asynchronous test runner. * Made `--debug` imply `--retries 0` diff --git a/src/Test/Syd/OptParse.hs b/src/Test/Syd/OptParse.hs --- a/src/Test/Syd/OptParse.hs +++ b/src/Test/Syd/OptParse.hs @@ -1,26 +1,20 @@ +{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} module Test.Syd.OptParse where import Autodocodec -import Autodocodec.Yaml import Control.Applicative -import Control.Monad import Data.Maybe -import Data.String import Data.Text (Text) -import qualified Data.Text as T -import qualified Env import GHC.Generics (Generic) -import Options.Applicative as OptParse -import Path +import OptEnvConf import Path.IO -import System.Exit +import Paths_sydtest (version) import Test.Syd.Run import Text.Colour @@ -32,11 +26,7 @@ #endif getSettings :: IO Settings -getSettings = do - flags <- getFlags - env <- getEnvironment - config <- getConfiguration flags env - combineToSettings flags env config +getSettings = runSettingsParser version "A sydtest test suite" -- | Test suite definition and run settings data Settings = Settings @@ -58,7 +48,7 @@ settingGoldenStart :: !Bool, -- | Whether to overwrite golden tests instead of having them fail settingGoldenReset :: !Bool, - -- | Whether to use colour in the output + -- | Whether to use colour in the output, 'Nothing' means "detect" settingColour :: !(Maybe Bool), -- | The filters to use to select which tests to run settingFilters :: ![Text], @@ -72,13 +62,79 @@ settingFailOnFlaky :: !Bool, -- | How to report progress settingReportProgress :: !ReportProgress, - -- | Debug mode - settingDebug :: !Bool, -- | Profiling mode settingProfile :: !Bool } deriving (Show, Eq, Generic) +instance HasParser Settings where + settingsParser = + subEnv_ "sydtest" $ + withConfigurableYamlConfig (runIO $ resolveFile' ".sydtest.yaml") $ + checkMapEither combine settingsParser + where + combine Flags {..} = do + let d func = func defaultSettings + let threads = + fromMaybe + ( if flagDebug + then Synchronous + else d settingThreads + ) + flagThreads + progress <- case flagReportProgress of + Nothing -> + pure $ + if threads == Synchronous + then + if flagDebug + then ReportProgress + else d settingReportProgress + else d settingReportProgress + Just ReportProgress -> + if threads /= Synchronous + then Left "Reporting progress in asynchronous runners is not supported. You can use --synchronous or --debug to use a synchronous runner." + else pure ReportProgress + Just ReportNoProgress -> pure ReportNoProgress + pure + Settings + { settingSeed = flagSeed, + settingRandomiseExecutionOrder = + fromMaybe + ( if flagDebug + then False + else d settingRandomiseExecutionOrder + ) + flagRandomiseExecutionOrder, + settingThreads = threads, + settingMaxSuccess = flagMaxSuccess, + settingMaxSize = flagMaxSize, + settingMaxDiscard = flagMaxDiscard, + settingMaxShrinks = flagMaxShrinks, + settingGoldenStart = flagGoldenStart, + settingGoldenReset = flagGoldenReset, + settingColour = flagColour, + settingFilters = flagFilters, + settingFailFast = + fromMaybe + ( if flagDebug + then True + else d settingFailFast + ) + flagFailFast, + settingIterations = flagIterations, + settingRetries = + fromMaybe + ( if flagDebug + then 0 + else d settingRetries + ) + flagRetries, + settingFailOnFlaky = flagFailOnFlaky, + settingReportProgress = progress, + settingProfile = flagProfile + } + defaultSettings :: Settings defaultSettings = let d func = func defaultTestRunSettings @@ -99,7 +155,6 @@ settingRetries = defaultRetries, settingFailOnFlaky = False, settingReportProgress = ReportNoProgress, - settingDebug = False, settingProfile = False } @@ -123,7 +178,151 @@ detectTerminalCapabilities :: IO TerminalCapabilities detectTerminalCapabilities = getTerminalCapabilitiesFromEnv #endif +-- We use an intermediate 'Flags' type so that default values can change based +-- on parse settings. For example, the default value for 'flagThreads' depends +-- on the value of 'flagDebug'. +data Flags = Flags + { flagSeed :: !SeedSetting, + flagRandomiseExecutionOrder :: !(Maybe Bool), + flagThreads :: !(Maybe Threads), + flagMaxSize :: !Int, + flagMaxSuccess :: !Int, + flagMaxDiscard :: !Int, + flagMaxShrinks :: !Int, + flagGoldenStart :: !Bool, + flagGoldenReset :: !Bool, + flagColour :: !(Maybe Bool), + flagFilters :: ![Text], + flagFailFast :: !(Maybe Bool), + flagIterations :: !Iterations, + flagRetries :: !(Maybe Word), + flagFailOnFlaky :: !Bool, + flagReportProgress :: !(Maybe ReportProgress), + flagDebug :: !Bool, + flagProfile :: !Bool + } + deriving (Show, Eq, Generic) +instance HasParser Flags where + settingsParser = do + flagSeed <- settingsParser + flagRandomiseExecutionOrder <- + optional $ + yesNoSwitch + [ help "Run test suite in a random order", + name "randomise-execution-order", + name "randomize-execution-order" + ] + flagThreads <- optional settingsParser + flagMaxSize <- + setting + [ help "Maximum size parameter to pass to generators", + reader auto, + name "max-size", + metavar "Int", + value $ settingMaxSize defaultSettings + ] + flagMaxSuccess <- + setting + [ help "Number of property test examples to run", + reader auto, + name "max-success", + metavar "Int", + value $ settingMaxSuccess defaultSettings + ] + flagMaxDiscard <- + setting + [ help "Maximum number of property test inputs to discard before considering the test failed", + reader auto, + name "max-discard", + metavar "Int", + value $ settingMaxDiscard defaultSettings + ] + flagMaxShrinks <- + setting + [ help "Maximum shrinks to try to apply to a failing property test input", + reader auto, + name "max-shrinks", + metavar "Int", + value $ settingMaxShrinks defaultSettings + ] + flagGoldenStart <- + yesNoSwitch + [ help "Produce initial golden output if it does not exist yet", + name "golden-start", + value $ settingGoldenStart defaultSettings + ] + flagGoldenReset <- + yesNoSwitch + [ help "Overwrite golden output", + name "golden-reset", + value $ settingGoldenReset defaultSettings + ] + flagColour <- + optional $ + yesNoSwitch + [ help "Use colour in output", + name "colour", + name "color" + ] + flagFilters <- + choice + [ some $ + setting + [ help "Filter to select parts of the test suite", + reader str, + argument, + metavar "FILTER" + ], + many $ + setting + [ help "Filter to select parts of the test suite", + reader str, + option, + short 'f', + long "filter", + short 'm', + long "match", + metavar "FILTER" + ] + ] + flagFailFast <- + optional $ + yesNoSwitch + [ help "Stop testing when a test failure occurs", + name "fail-fast" + ] + flagIterations <- settingsParser + flagRetries <- + optional $ + setting + [ help "The number of retries to use for flakiness diagnostics. 0 means 'no retries'", + reader auto, + name "retries", + metavar "INTEGER" + ] + flagFailOnFlaky <- + yesNoSwitch + [ help "Fail when any flakiness is detected, even when flakiness is allowed", + name "fail-on-flaky", + value $ settingFailOnFlaky defaultSettings + ] + flagReportProgress <- + optional settingsParser + flagDebug <- + yesNoSwitch + [ help "Turn on debug mode", + name "debug", + value False + ] + flagProfile <- + yesNoSwitch + [ help "Turn on profiling mode", + name "profile", + value $ settingProfile defaultSettings + ] + pure Flags {..} + data Threads = -- | One thread Synchronous @@ -133,176 +332,6 @@ Asynchronous !Word deriving (Show, Read, Eq, Generic) -data Iterations - = -- | Run the test suite once, the default - OneIteration - | -- | Run the test suite for the given number of iterations, or until we can find flakiness - Iterations !Word - | -- | Run the test suite over and over, until we can find some flakiness - Continuous - deriving (Show, Read, Eq, Generic) - -data ReportProgress - = -- | Don't report any progress, the default - ReportNoProgress - | -- | Report progress - ReportProgress - deriving (Show, Read, Eq, Generic) - --- | Combine everything to 'Settings' -combineToSettings :: Flags -> Environment -> Maybe Configuration -> IO Settings -combineToSettings Flags {..} Environment {..} mConf = do - let d func = func defaultSettings - let debugMode = - fromMaybe (d settingDebug) $ - flagDebug <|> envDebug <|> mc configDebug - let threads = - fromMaybe (if debugMode then Synchronous else d settingThreads) $ - flagThreads <|> envThreads <|> mc configThreads - setReportProgress <- - case flagReportProgress <|> envReportProgress <|> mc configReportProgress of - Nothing -> - pure $ - if threads == Synchronous - then - if debugMode - then ReportProgress - else d settingReportProgress - else d settingReportProgress - Just progress -> - if progress - then - if threads /= Synchronous - then die "Reporting progress in asynchronous runners is not supported. You can use --synchronous or --debug to use a synchronous runner." - else pure ReportProgress - else pure ReportNoProgress - - pure - Settings - { settingSeed = - fromMaybe (d settingSeed) $ - flagSeed <|> envSeed <|> mc configSeed, - settingRandomiseExecutionOrder = - fromMaybe (if debugMode then False else d settingRandomiseExecutionOrder) $ - flagRandomiseExecutionOrder <|> envRandomiseExecutionOrder <|> mc configRandomiseExecutionOrder, - settingThreads = threads, - settingMaxSuccess = - fromMaybe (d settingMaxSuccess) $ - flagMaxSuccess <|> envMaxSuccess <|> mc configMaxSuccess, - settingMaxSize = - fromMaybe (d settingMaxSize) $ - flagMaxSize <|> envMaxSize <|> mc configMaxSize, - settingMaxDiscard = - fromMaybe (d settingMaxDiscard) $ - flagMaxDiscard <|> envMaxDiscard <|> mc configMaxDiscard, - settingMaxShrinks = - fromMaybe (d settingMaxShrinks) $ - flagMaxShrinks <|> envMaxShrinks <|> mc configMaxShrinks, - settingGoldenStart = - fromMaybe (d settingGoldenStart) $ - flagGoldenStart <|> envGoldenStart <|> mc configGoldenStart, - settingGoldenReset = - fromMaybe (d settingGoldenReset) $ - flagGoldenReset <|> envGoldenReset <|> mc configGoldenReset, - settingColour = flagColour <|> envColour <|> mc configColour, - settingFilters = flagFilters <|> maybeToList envFilter <|> maybeToList (mc configFilter), - settingFailFast = - fromMaybe - (if debugMode then True else d settingFailFast) - (flagFailFast <|> envFailFast <|> mc configFailFast), - settingIterations = - fromMaybe (d settingIterations) $ - flagIterations <|> envIterations <|> mc configIterations, - settingRetries = - fromMaybe (if debugMode then 0 else d settingRetries) $ - flagRetries <|> envRetries <|> mc configRetries, - settingFailOnFlaky = - fromMaybe (d settingFailOnFlaky) $ - flagFailOnFlaky <|> envFailOnFlaky <|> mc configFailOnFlaky, - settingReportProgress = setReportProgress, - settingDebug = debugMode, - settingProfile = - fromMaybe False $ - flagProfile <|> envProfile <|> mc configProfile - } - where - mc :: (Configuration -> Maybe a) -> Maybe a - mc f = mConf >>= f - --- | What we find in the configuration variable. --- --- Do nothing clever here, just represent the configuration file. --- For example, use 'Maybe FilePath', not 'Path Abs File'. --- --- Use 'readYamlConfigFile' or 'readFirstYamlConfigFile' to read a configuration. -data Configuration = Configuration - { configSeed :: !(Maybe SeedSetting), - configRandomiseExecutionOrder :: !(Maybe Bool), - configThreads :: !(Maybe Threads), - configMaxSize :: !(Maybe Int), - configMaxSuccess :: !(Maybe Int), - configMaxDiscard :: !(Maybe Int), - configMaxShrinks :: !(Maybe Int), - configGoldenStart :: !(Maybe Bool), - configGoldenReset :: !(Maybe Bool), - configColour :: !(Maybe Bool), - configFilter :: !(Maybe Text), - configFailFast :: !(Maybe Bool), - configIterations :: !(Maybe Iterations), - configRetries :: !(Maybe Word), - configFailOnFlaky :: !(Maybe Bool), - configReportProgress :: !(Maybe Bool), - configDebug :: !(Maybe Bool), - configProfile :: !(Maybe Bool) - } - deriving (Show, Eq, Generic) - --- | We use 'autodocodec' for parsing a YAML config. -instance HasCodec Configuration where - codec = - object "Configuration" $ - Configuration - <$> optionalField "seed" "Seed for random generation of test cases" - .= configSeed - <*> parseAlternative - (optionalField "randomise-execution-order" "Randomise the execution order of the tests in the test suite") - (optionalField "randomize-execution-order" "American spelling") - .= configRandomiseExecutionOrder - <*> optionalField "parallelism" "How parallel to execute the tests" - .= configThreads - <*> optionalField "max-size" "Maximum size parameter to pass to generators" - .= configMaxSize - <*> optionalField "max-success" "Number of quickcheck examples to run" - .= configMaxSuccess - <*> optionalField "max-discard" "Maximum number of discarded tests per successful test before giving up" - .= configMaxDiscard - <*> optionalField "max-shrinks" "Maximum number of shrinks of a failing test input" - .= configMaxShrinks - <*> optionalField "golden-start" "Whether to write golden tests if they do not exist yet" - .= configGoldenStart - <*> optionalField "golden-reset" "Whether to overwrite golden tests instead of having them fail" - .= configGoldenReset - <*> parseAlternative - (optionalField "colour" "Whether to use coloured output") - (optionalField "color" "American spelling") - .= configColour - <*> optionalField "filter" "Filter to select which parts of the test tree to run" - .= configFilter - <*> optionalField "fail-fast" "Whether to stop executing upon the first test failure" - .= configFailFast - <*> optionalField "iterations" "How many iterations to use to look diagnose flakiness" - .= configIterations - <*> optionalField "retries" "The number of retries to use for flakiness diagnostics. 0 means 'no flakiness diagnostics'" - .= configRetries - <*> optionalField "fail-on-flaky" "Whether to fail when any flakiness is detected in tests marked as potentially flaky" - .= configFailOnFlaky - <*> optionalField "progress" "How to report progres" - .= configReportProgress - <*> optionalField "debug" "Turn on debug-mode. This implies randomise-execution-order: false, parallelism: 1 and fail-fast: true" - .= configDebug - <*> optionalField "profile" "Turn on profiling mode" - .= configProfile - instance HasCodec Threads where codec = dimapCodec f g codec where @@ -315,6 +344,55 @@ Synchronous -> Just 1 Asynchronous n -> Just n +instance HasParser Threads where + settingsParser = + choice + [ ( \case + 1 -> Synchronous + w -> Asynchronous w + ) + <$> setting + [ help "How many threads to use to execute tests in asynchrnously", + reader auto, + option, + long "jobs", + long "threads", + env "JOBS", + env "THREADS", + metavar "INT" + ], + setting + [ help "Use only one thread, to execute tests synchronously", + switch Synchronous, + long "synchronous" + ], + Synchronous + <$ setting + [ help "Use only one thread, to execute tests synchronously", + reader exists, + env "SYNCHRONOUS", + metavar "ANY" + ], + setting + [ help "How parallel to run the test suite", + confWith' "threads" $ + let f = \case + Nothing -> Just ByCapabilities + Just 1 -> Just Synchronous + Just n -> Just $ Asynchronous n + in f <$> codec + ] + ] + +data Iterations + = -- | Run the test suite once, the default + OneIteration + | -- | Run the test suite for the given number of iterations, or until we can find flakiness + Iterations !Word + | -- | Run the test suite over and over, until we can find some flakiness + Continuous + deriving (Show, Read, Eq, Generic) + instance HasCodec Iterations where codec = dimapCodec f g codec where @@ -328,370 +406,47 @@ Continuous -> Just 0 Iterations n -> Just n --- | Get the configuration --- --- We use the flags and environment because they can contain information to override where to look for the configuration files. --- We return a 'Maybe' because there may not be a configuration file. -getConfiguration :: Flags -> Environment -> IO (Maybe Configuration) -getConfiguration Flags {..} Environment {..} = - case flagConfigFile <|> envConfigFile of - Nothing -> defaultConfigFile >>= readYamlConfigFile - Just cf -> do - afp <- resolveFile' cf - readYamlConfigFile afp - --- | Where to get the configuration file by default. -defaultConfigFile :: IO (Path Abs File) -defaultConfigFile = resolveFile' ".sydtest.yaml" - --- | What we find in the configuration variable. --- --- Do nothing clever here, just represent the relevant parts of the environment. --- For example, use 'Text', not 'SqliteConfig'. -data Environment = Environment - { envConfigFile :: Maybe FilePath, - envSeed :: !(Maybe SeedSetting), - envRandomiseExecutionOrder :: !(Maybe Bool), - envThreads :: !(Maybe Threads), - envMaxSize :: !(Maybe Int), - envMaxSuccess :: !(Maybe Int), - envMaxDiscard :: !(Maybe Int), - envMaxShrinks :: !(Maybe Int), - envGoldenStart :: !(Maybe Bool), - envGoldenReset :: !(Maybe Bool), - envColour :: !(Maybe Bool), - envFilter :: !(Maybe Text), - envFailFast :: !(Maybe Bool), - envIterations :: !(Maybe Iterations), - envRetries :: !(Maybe Word), - envFailOnFlaky :: !(Maybe Bool), - envReportProgress :: !(Maybe Bool), - envDebug :: !(Maybe Bool), - envProfile :: !(Maybe Bool) - } - deriving (Show, Eq, Generic) - -defaultEnvironment :: Environment -defaultEnvironment = - Environment - { envConfigFile = Nothing, - envSeed = Nothing, - envRandomiseExecutionOrder = Nothing, - envThreads = Nothing, - envMaxSize = Nothing, - envMaxSuccess = Nothing, - envMaxDiscard = Nothing, - envMaxShrinks = Nothing, - envGoldenStart = Nothing, - envGoldenReset = Nothing, - envColour = Nothing, - envFilter = Nothing, - envFailFast = Nothing, - envIterations = Nothing, - envRetries = Nothing, - envFailOnFlaky = Nothing, - envReportProgress = Nothing, - envDebug = Nothing, - envProfile = Nothing - } - -getEnvironment :: IO Environment -getEnvironment = Env.parse (Env.header "Environment") environmentParser - --- | The 'envparse' parser for the 'Environment' -environmentParser :: Env.Parser Env.Error Environment -environmentParser = - Env.prefixed "SYDTEST_" $ - Environment - <$> Env.var (fmap Just . Env.str) "CONFIG_FILE" (Env.def Nothing <> Env.help "Config file") - <*> seedSettingEnvironmentParser - <*> ( Env.var (fmap Just . Env.auto) "RANDOMISE_EXECUTION_ORDER" (Env.def Nothing <> Env.help "Randomise the execution order of the tests in the test suite") - <|> Env.var (fmap Just . Env.auto) "RANDOMIZE_EXECUTION_ORDER" (Env.def Nothing <> Env.help "Randomize the execution order of the tests in the test suite") - ) - <*> Env.var (fmap Just . (Env.auto >=> parseThreads)) "PARALLELISM" (Env.def Nothing <> Env.help "How parallel to execute the tests") - <*> Env.var (fmap Just . Env.auto) "MAX_SIZE" (Env.def Nothing <> Env.help "Maximum size parameter to pass to generators") - <*> Env.var (fmap Just . Env.auto) "MAX_SUCCESS" (Env.def Nothing <> Env.help "Number of quickcheck examples to run") - <*> Env.var (fmap Just . Env.auto) "MAX_DISCARD" (Env.def Nothing <> Env.help "Maximum number of discarded tests per successful test before giving up") - <*> Env.var (fmap Just . Env.auto) "MAX_SHRINKS" (Env.def Nothing <> Env.help "Maximum number of shrinks of a failing test input") - <*> Env.var (fmap Just . Env.auto) "GOLDEN_START" (Env.def Nothing <> Env.help "Whether to write golden tests if they do not exist yet") - <*> Env.var (fmap Just . Env.auto) "GOLDEN_RESET" (Env.def Nothing <> Env.help "Whether to overwrite golden tests instead of having them fail") - <*> ( Env.var (fmap Just . Env.auto) "COLOUR" (Env.def Nothing <> Env.help "Whether to use coloured output") - <|> Env.var (fmap Just . Env.auto) "COLOR" (Env.def Nothing <> Env.help "Whether to use colored output") - ) - <*> Env.var (fmap Just . Env.str) "FILTER" (Env.def Nothing <> Env.help "Filter to select which parts of the test tree to run") - <*> Env.var (fmap Just . Env.auto) "FAIL_FAST" (Env.def Nothing <> Env.help "Whether to stop executing upon the first test failure") - <*> Env.var (fmap Just . (Env.auto >=> parseIterations)) "ITERATIONS" (Env.def Nothing <> Env.help "How many iterations to use to look diagnose flakiness") - <*> Env.var (fmap Just . Env.auto) "RETRIES" (Env.def Nothing <> Env.help "The number of retries to use for flakiness diagnostics. 0 means 'no flakiness diagnostics'") - <*> Env.var (fmap Just . Env.auto) "FAIL_ON_FLAKY" (Env.def Nothing <> Env.help "Whether to fail when flakiness is detected in tests marked as potentially flaky") - <*> Env.var (fmap Just . Env.auto) "PROGRESS" (Env.def Nothing <> Env.help "Report progress as tests run") - <*> Env.var (fmap Just . Env.auto) "DEBUG" (Env.def Nothing <> Env.help "Turn on debug mode. This implies RANDOMISE_EXECUTION_ORDER=False, PARALLELISM=1 and FAIL_FAST=True.") - <*> Env.var (fmap Just . Env.auto) "PROFILE" (Env.def Nothing <> Env.help "Turn on profiling mode.") - where - parseThreads :: Word -> Either e Threads - parseThreads 1 = Right Synchronous - parseThreads i = Right (Asynchronous i) - parseIterations :: Word -> Either e Iterations - parseIterations 0 = Right Continuous - parseIterations 1 = Right OneIteration - parseIterations i = Right (Iterations i) - -seedSettingEnvironmentParser :: Env.Parser Env.Error (Maybe SeedSetting) -seedSettingEnvironmentParser = - combine - <$> Env.var (fmap Just . Env.auto) "SEED" (Env.def Nothing <> Env.help "Seed for random generation of test cases") - <*> Env.switch "RANDOM_SEED" (Env.help "Use a random seed for every test case") - where - combine :: Maybe Int -> Bool -> Maybe SeedSetting - combine mSeed random = if random then Just RandomSeed else FixedSeed <$> mSeed - --- | Get the command-line flags -getFlags :: IO Flags -getFlags = customExecParser prefs_ flagsParser - --- | The 'optparse-applicative' parsing preferences -prefs_ :: OptParse.ParserPrefs -prefs_ = - -- I like these preferences. Use what you like. - OptParse.defaultPrefs - { OptParse.prefShowHelpOnError = True, - OptParse.prefShowHelpOnEmpty = True - } - --- | The @optparse-applicative@ parser for 'Flags' -flagsParser :: OptParse.ParserInfo Flags -flagsParser = - OptParse.info - (OptParse.helper <*> parseFlags) - (OptParse.fullDesc <> OptParse.footerDoc (Just $ fromString footerStr)) - where - -- Show the variables from the environment that we parse and the config file format - footerStr = - unlines - [ Env.helpDoc environmentParser, - "", - "Configuration file format:", - T.unpack (renderColouredSchemaViaCodec @Configuration) - ] - --- | The flags that are common across commands. -data Flags = Flags - { flagConfigFile :: !(Maybe FilePath), - flagSeed :: !(Maybe SeedSetting), - flagRandomiseExecutionOrder :: !(Maybe Bool), - flagThreads :: !(Maybe Threads), - flagMaxSize :: !(Maybe Int), - flagMaxSuccess :: !(Maybe Int), - flagMaxDiscard :: !(Maybe Int), - flagMaxShrinks :: !(Maybe Int), - flagGoldenStart :: !(Maybe Bool), - flagGoldenReset :: !(Maybe Bool), - flagColour :: !(Maybe Bool), - flagFilters :: ![Text], - flagFailFast :: !(Maybe Bool), - flagIterations :: !(Maybe Iterations), - flagRetries :: !(Maybe Word), - flagFailOnFlaky :: !(Maybe Bool), - flagReportProgress :: !(Maybe Bool), - flagDebug :: !(Maybe Bool), - flagProfile :: !(Maybe Bool) - } - deriving (Show, Eq, Generic) - -defaultFlags :: Flags -defaultFlags = - Flags - { flagConfigFile = Nothing, - flagSeed = Nothing, - flagRandomiseExecutionOrder = Nothing, - flagThreads = Nothing, - flagMaxSize = Nothing, - flagMaxSuccess = Nothing, - flagMaxDiscard = Nothing, - flagMaxShrinks = Nothing, - flagGoldenStart = Nothing, - flagGoldenReset = Nothing, - flagColour = Nothing, - flagFilters = mempty, - flagFailFast = Nothing, - flagIterations = Nothing, - flagRetries = Nothing, - flagFailOnFlaky = Nothing, - flagReportProgress = Nothing, - flagDebug = Nothing, - flagProfile = Nothing - } - --- | The 'optparse-applicative' parser for the 'Flags'. -parseFlags :: OptParse.Parser Flags -parseFlags = - Flags - <$> optional - ( strOption - ( mconcat - [ long "config-file", - help "Path to an altenative config file", - metavar "FILEPATH" - ] - ) - ) - <*> seedSettingFlags - <*> doubleSwitch ["randomise-execution-order", "randomize-execution-order"] (help "Randomise the execution order of the tests in the test suite") - <*> optional - ( ( ( \case - 1 -> Synchronous - i -> Asynchronous i - ) - <$> option - auto - ( mconcat - [ short 'j', - long "jobs", - help "How parallel to execute the tests", - metavar "JOBS" - ] - ) - ) - <|> flag' - Synchronous - ( mconcat - [ long "synchronous", - help "Execute tests synchronously" - ] - ) - ) - <*> optional - ( option - auto - ( mconcat - [ long "max-size", - long "qc-max-size", - help "Maximum size parameter to pass to generators", - metavar "MAXIMUM_SIZE_PARAMETER" - ] - ) - ) - <*> optional - ( option - auto - ( mconcat - [ long "max-success", - long "qc-max-success", - help "Number of quickcheck examples to run", - metavar "NUMBER_OF_SUCCESSES" - ] - ) - ) - <*> optional - ( option - auto - ( mconcat - [ long "max-discard", - long "qc-max-discard", - help "Maximum number of discarded tests per successful test before giving up", - metavar "MAXIMUM_DISCARD_RATIO" - ] - ) - ) - <*> optional - ( option - auto - ( mconcat - [ long "max-shrinks", - long "qc-max-shrinks", - help "Maximum number of shrinks of a failing test input", - metavar "MAXIMUM_SHRINKS" - ] - ) - ) - <*> doubleSwitch ["golden-start"] (help "Whether to write golden tests if they do not exist yet") - <*> doubleSwitch ["golden-reset"] (help "Whether to overwrite golden tests instead of having them fail") - <*> doubleSwitch ["colour", "color"] (help "Use colour in output") - <*> ( maybeToList - <$> optional - ( strArgument - ( mconcat - [ help "Filter to select which parts of the test tree to run", - metavar "FILTER" - ] - ) - ) - <|> manyOptional - ( mconcat - [ short 'f', - long "filter", - short 'm', - long "match", - help "Filter to select which parts of the test tree to run", - metavar "FILTER" - ] - ) - ) - <*> doubleSwitch ["fail-fast"] (help "Stop upon the first test failure") - <*> optional - ( ( ( \case - 0 -> Continuous - 1 -> OneIteration - i -> Iterations i - ) - <$> option - auto - ( mconcat - [ long "iterations", - help "How many iterations to use to look diagnose flakiness", - metavar "ITERATIONS" - ] - ) +instance HasParser Iterations where + settingsParser = + choice + [ setting + [ help "Run the test suite over and over again until it fails, for example to diagnose flakiness", + switch Continuous, + long "continuous" + ], + ( \case + 0 -> Continuous + 1 -> OneIteration + i -> Iterations i ) - <|> flag' - Continuous - ( mconcat - [ long "continuous", - help "Run the test suite over and over again until it fails, to diagnose flakiness" - ] - ) - ) - <*> optional - ( option - auto - ( mconcat - [ long "retries", - help "The number of retries to use for flakiness diagnostics. 0 means 'no flakiness diagnostics'", - metavar "INTEGER" - ] - ) - ) - <*> doubleSwitch ["fail-on-flaky"] (help "Fail when any flakiness is detected") - <*> doubleSwitch ["progress"] (help "Report progress") - <*> doubleSwitch ["debug"] (help "Turn on debug mode. This implies --no-randomise-execution-order, --synchronous, --progress and --fail-fast.") - <*> doubleSwitch ["profile"] (help "Turn on profiling mode.") - -manyOptional :: OptParse.Mod OptionFields Text -> OptParse.Parser [Text] -manyOptional modifier = many (option str modifier) + <$> setting + [ help "How many iterations of the suite to run, for example to diagnose flakiness", + reader auto, + option, + long "iterations", + metavar "INT" + ], + pure $ settingIterations defaultSettings + ] -seedSettingFlags :: OptParse.Parser (Maybe SeedSetting) -seedSettingFlags = - optional $ - ( FixedSeed - <$> option - auto - ( mconcat - [ long "seed", - help "Seed for random generation of test cases", - metavar "SEED" - ] - ) - ) - <|> flag' - RandomSeed - ( mconcat - [ long "random-seed", - help "Use a random seed instead of a fixed seed" - ] - ) +data ReportProgress + = -- | Don't report any progress, the default + ReportNoProgress + | -- | Report progress + ReportProgress + deriving (Show, Read, Eq, Generic) -doubleSwitch :: [String] -> OptParse.Mod FlagFields (Maybe Bool) -> OptParse.Parser (Maybe Bool) -doubleSwitch suffixes mods = - flag' (Just True) (hidden <> internal <> foldMap long suffixes <> mods) - <|> flag' (Just False) (hidden <> internal <> foldMap (long . ("no-" <>)) suffixes <> mods) - <|> flag' Nothing (foldMap (\suffix -> long ("[no-]" <> suffix)) suffixes <> mods) - <|> pure Nothing +instance HasParser ReportProgress where + settingsParser = + choice + [ setting + [ help "Report per-example progress", + switch ReportProgress, + long "progress" + ], + setting + [ help "Don't report per-example progress", + switch ReportNoProgress, + long "no-progress" + ] + ] diff --git a/src/Test/Syd/Run.hs b/src/Test/Syd/Run.hs --- a/src/Test/Syd/Run.hs +++ b/src/Test/Syd/Run.hs @@ -26,6 +26,7 @@ import Data.Word import GHC.Clock (getMonotonicTimeNSec) import GHC.Generics (Generic) +import OptEnvConf import Test.QuickCheck import Test.QuickCheck.Gen import Test.QuickCheck.IO () @@ -129,7 +130,7 @@ instance IsTest (outerArgs -> ReaderT env IO ()) where type Arg1 (outerArgs -> ReaderT env IO ()) = outerArgs type Arg2 (outerArgs -> ReaderT env IO ()) = env - runTest func = runTest (\outerArgs env -> runReaderT (func outerArgs) env) + runTest func = runTest (\outerArgs e -> runReaderT (func outerArgs) e) runIOTestWithArg :: (outerArgs -> innerArg -> IO ()) -> @@ -424,6 +425,37 @@ g = \case RandomSeed -> Left "random" FixedSeed i -> Right i + +instance HasParser SeedSetting where + settingsParser = + choice + [ setting + [ help "Use a random seed for pseudo-randomness", + switch RandomSeed, + long "random-seed" + ], + RandomSeed + <$ setting + [ help "Use a random seed for pseudo-randomness", + OptEnvConf.reader exists, + env "RANDOM_SEED", + metavar "ANY" + ], + FixedSeed + <$> setting + [ help "Seed for pseudo-randomness", + OptEnvConf.reader auto, + option, + long "seed", + env "SEED", + metavar "INT" + ], + setting + [ help "Seed for pseudo-randomness", + conf "seed" + ], + pure $ testRunSettingSeed defaultTestRunSettings + ] data TestRunResult = TestRunResult { testRunResultStatus :: !TestStatus, diff --git a/sydtest.cabal b/sydtest.cabal --- a/sydtest.cabal +++ b/sydtest.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: sydtest -version: 0.15.1.3 +version: 0.16.0.0 synopsis: A modern testing framework for Haskell with good defaults and advanced testing features. description: A modern testing framework for Haskell with good defaults and advanced testing features. Sydtest aims to make the common easy and the hard possible. See https://github.com/NorfairKing/sydtest#readme for more information. category: Testing @@ -63,16 +63,14 @@ , QuickCheck , async , autodocodec - , autodocodec-yaml >=0.2.0.0 , base >=4.7 && <5 , bytestring , containers , dlist - , envparse , fast-myers-diff , filepath , mtl - , optparse-applicative + , opt-env-conf >=0.5 , path , path-io , pretty-show