{-# 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.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Env import GHC.Generics (Generic) import Options.Applicative as OptParse import qualified Options.Applicative.Help as OptParse (string) import Path import Path.IO import System.Exit import Test.Syd.Run import Text.Colour #ifdef mingw32_HOST_OS import System.Console.ANSI (hSupportsANSIColor) import System.IO (stdout) #else import Text.Colour.Capabilities.FromEnv #endif getSettings :: IO Settings getSettings = do flags <- getFlags env <- getEnvironment config <- getConfiguration flags env combineToSettings flags env config -- | Test suite definition and run settings data Settings = Settings { -- | The seed to use for deterministic randomness settingSeed :: !SeedSetting, -- | Randomise the execution order of the tests in the test suite settingRandomiseExecutionOrder :: !Bool, -- | How parallel to run the test suite settingThreads :: !Threads, -- | How many examples to run a property test with settingMaxSuccess :: !Int, -- | The maximum size parameter to supply to generators settingMaxSize :: !Int, -- | The maximum number of discarded examples per tested example settingMaxDiscard :: !Int, -- | The maximum number of tries to use while shrinking a counterexample. settingMaxShrinks :: !Int, -- | Whether to write golden tests if they do not exist yet settingGoldenStart :: !Bool, -- | Whether to overwrite golden tests instead of having them fail settingGoldenReset :: !Bool, -- | Whether to use colour in the output settingColour :: !(Maybe Bool), -- | The filter to use to select which tests to run settingFilter :: !(Maybe Text), -- | Whether to stop upon the first test failure settingFailFast :: !Bool, -- | How many iterations to use to look diagnose flakiness settingIterations :: Iterations, -- | Whether to fail when any flakiness is detected settingFailOnFlaky :: !Bool, -- | How to report progress settingReportProgress :: !ReportProgress, -- | Debug mode settingDebug :: !Bool } deriving (Show, Eq, Generic) defaultSettings :: Settings defaultSettings = let d func = func defaultTestRunSettings in Settings { settingSeed = d testRunSettingSeed, settingRandomiseExecutionOrder = True, settingThreads = ByCapabilities, settingMaxSuccess = d testRunSettingMaxSuccess, settingMaxSize = d testRunSettingMaxSize, settingMaxDiscard = d testRunSettingMaxDiscardRatio, settingMaxShrinks = d testRunSettingMaxShrinks, settingGoldenStart = d testRunSettingGoldenStart, settingGoldenReset = d testRunSettingGoldenReset, settingColour = Nothing, settingFilter = Nothing, settingFailFast = False, settingIterations = OneIteration, settingFailOnFlaky = False, settingReportProgress = ReportNoProgress, settingDebug = False } deriveTerminalCapababilities :: Settings -> IO TerminalCapabilities deriveTerminalCapababilities settings = case settingColour settings of Just False -> pure WithoutColours Just True -> pure With8BitColours Nothing -> detectTerminalCapabilities #ifdef mingw32_HOST_OS detectTerminalCapabilities :: IO TerminalCapabilities detectTerminalCapabilities = do supports <- hSupportsANSIColor stdout if supports then pure With8BitColours else pure WithoutColours #else detectTerminalCapabilities :: IO TerminalCapabilities detectTerminalCapabilities = getTerminalCapabilitiesFromEnv #endif data Threads = -- | One thread Synchronous | -- | As many threads as 'getNumCapabilities' tells you you have ByCapabilities | -- | A given number of threads 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, settingFilter = flagFilter <|> envFilter <|> mc configFilter, settingFailFast = fromMaybe (if debugMode then True else d settingFailFast) (flagFailFast <|> envFailFast <|> mc configFailFast), settingIterations = fromMaybe (d settingIterations) $ flagIterations <|> envIterations <|> mc configIterations, settingFailOnFlaky = fromMaybe (d settingFailOnFlaky) $ flagFailOnFlaky <|> envFailOnFlaky <|> mc configFailOnFlaky, settingReportProgress = setReportProgress, settingDebug = debugMode } 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), configFailOnFlaky :: !(Maybe Bool), configReportProgress :: !(Maybe Bool), configDebug :: !(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 "fail-on-flaky" "Whether to fail when any flakiness is detected" .= 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 instance HasCodec Threads where codec = dimapCodec f g codec where f = \case Nothing -> ByCapabilities Just 1 -> Synchronous Just n -> Asynchronous n g = \case ByCapabilities -> Nothing Synchronous -> Just 1 Asynchronous n -> Just n instance HasCodec Iterations where codec = dimapCodec f g codec where f = \case Nothing -> OneIteration Just 0 -> Continuous Just 1 -> OneIteration Just n -> Iterations n g = \case OneIteration -> Nothing 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), envFailOnFlaky :: !(Maybe Bool), envReportProgress :: !(Maybe Bool), envDebug :: !(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, envFailOnFlaky = Nothing, envReportProgress = Nothing, envDebug = 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) "FAIL_ON_FLAKY" (Env.def Nothing <> Env.help "Whether to fail when flakiness is detected") <*> 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.") 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 $ OptParse.string 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 (TE.decodeUtf8 (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), flagFilter :: !(Maybe Text), flagFailFast :: !(Maybe Bool), flagIterations :: !(Maybe Iterations), flagFailOnFlaky :: !(Maybe Bool), flagReportProgress :: !(Maybe Bool), flagDebug :: !(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, flagFilter = Nothing, flagFailFast = Nothing, flagIterations = Nothing, flagFailOnFlaky = Nothing, flagReportProgress = Nothing, flagDebug = 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") <*> ( optional ( strArgument ( mconcat [ help "Filter to select which parts of the test tree to run", metavar "FILTER" ] ) ) <|> optional ( strOption ( mconcat [ long "filter", 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" ] ) ) <|> flag' Continuous ( mconcat [ long "continuous", help "Run the test suite over and over again until it fails, to diagnose flakiness" ] ) ) <*> 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.") 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" ] ) 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 suffixes <> mods) <|> flag' Nothing (foldMap (\suffix -> long ("[no-]" <> suffix)) suffixes <> mods) <|> pure Nothing