sydtest 0.5.0.0 → 0.6.0.0
raw patch · 6 files changed
+90/−69 lines, 6 filesdep +autodocodecdep +autodocodec-yamldep −yamlparse-applicative
Dependencies added: autodocodec, autodocodec-yaml
Dependencies removed: yamlparse-applicative
Files
- CHANGELOG.md +7/−1
- src/Test/Syd/OptParse.hs +59/−49
- src/Test/Syd/Run.hs +11/−7
- src/Test/Syd/Runner.hs +4/−4
- src/Test/Syd/Runner/Asynchronous.hs +6/−6
- sydtest.cabal +3/−2
CHANGELOG.md view
@@ -1,5 +1,11 @@ # Changelog +## [0.6.0.0] - 2021-11-12++### Changed++* Started using `autodocodec` instead of `yamlparse-applicative`.+ ## [0.5.0.0] - 2021-11-12 ### Added@@ -8,7 +14,7 @@ * The `--fail-on-flaky` flag to falsify flakiness. * Experimental Windows support -## Changed+### Changed * Fixed the interpretation of `max-size` vs `max-success` in the configuration file and environment parsing.
src/Test/Syd/OptParse.hs view
@@ -6,12 +6,14 @@ 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 Data.Yaml+import qualified Data.Text.Encoding as TE import qualified Env import GHC.Generics (Generic) import Options.Applicative as OptParse@@ -19,7 +21,6 @@ import Path import Path.IO import Test.Syd.Run-import YamlParse.Applicative as YamlParse getSettings :: IO Settings getSettings = do@@ -90,14 +91,14 @@ | -- | As many threads as 'getNumCapabilities' tells you you have ByCapabilities | -- | A given number of threads- Asynchronous Int+ Asynchronous !Word deriving (Show, 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 Int+ Iterations !Word | -- | Run the test suite over and over, until we can find some flakiness Continuous deriving (Show, Eq, Generic)@@ -141,7 +142,7 @@ -- Do nothing clever here, just represent the configuration file. -- For example, use 'Maybe FilePath', not 'Path Abs File'. ----- Use 'YamlParse.readConfigFile' or 'YamlParse.readFirstConfigFile' to read a configuration.+-- Use 'readYamlConfigFile' or 'readFirstYamlConfigFile' to read a configuration. data Configuration = Configuration { configSeed :: !(Maybe SeedSetting), configRandomiseExecutionOrder :: !(Maybe Bool),@@ -161,48 +162,57 @@ } deriving (Show, Eq, Generic) -instance FromJSON Configuration where- parseJSON = viaYamlSchema---- | We use 'yamlparse-applicative' for parsing a YAML config.-instance YamlSchema Configuration where- yamlSchema =- objectParser "Configuration" $+-- | 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"- <*> alternatives- [ optionalField "randomise-execution-order" "Randomise the execution order of the tests in the test suite",- optionalField "randomize-execution-order" "Randomize the execution order of the tests in the test suite"- ]- <*> optionalField "parallelism" "How parallel to execute the tests"- <*> optionalField "max-size" "Maximum size parameter to pass to generators"- <*> optionalField "max-success" "Number of quickcheck examples to run"- <*> optionalField "max-discard" "Maximum number of discarded tests per successful test before giving up"- <*> optionalField "max-shrinks" "Maximum number of shrinks of a failing test input"- <*> optionalField "golden-start" "Whether to write golden tests if they do not exist yet"- <*> optionalField "golden-reset" "Whether to overwrite golden tests instead of having them fail"- <*> alternatives- [ optionalField "colour" "Whether to use coloured output",- optionalField "color" "Whether to use colored output"- ]- <*> optionalField "filter" "Filter to select which parts of the test tree to run"- <*> optionalField "fail-fast" "Whether to stop executing upon the first test failure"- <*> optionalField "iterations" "How many iterations to use to look diagnose flakiness"- <*> optionalField "fail-on-flaky" "Whether to fail when any flakiness is detected"- <*> optionalField "debug" "Turn on debug-mode. This implies randomise-execution-order: false, parallelism: 1 and fail-fast: true"+ <$> 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 "debug" "Turn on debug-mode. This implies randomise-execution-order: false, parallelism: 1 and fail-fast: true" .= configDebug -instance YamlSchema Threads where- yamlSchema = flip fmap yamlSchema $ \case- Nothing -> ByCapabilities- Just 1 -> Synchronous- Just n -> Asynchronous n+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 YamlSchema Iterations where- yamlSchema = flip fmap yamlSchema $ \case- Nothing -> OneIteration- Just 0 -> Continuous- Just 1 -> OneIteration- Just n -> Iterations 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 --@@ -211,10 +221,10 @@ getConfiguration :: Flags -> Environment -> IO (Maybe Configuration) getConfiguration Flags {..} Environment {..} = case flagConfigFile <|> envConfigFile of- Nothing -> defaultConfigFile >>= YamlParse.readConfigFile+ Nothing -> defaultConfigFile >>= readYamlConfigFile Just cf -> do afp <- resolveFile' cf- YamlParse.readConfigFile afp+ readYamlConfigFile afp -- | Where to get the configuration file by default. defaultConfigFile :: IO (Path Abs File)@@ -294,10 +304,10 @@ <*> 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) "DEBUG" (Env.def Nothing <> Env.help "Turn on debug mode. This implies RANDOMISE_EXECUTION_ORDER=False, PARALLELISM=1 and FAIL_FAST=True.") where- parseThreads :: Int -> Either e Threads+ parseThreads :: Word -> Either e Threads parseThreads 1 = Right Synchronous parseThreads i = Right (Asynchronous i)- parseIterations :: Int -> Either e Iterations+ parseIterations :: Word -> Either e Iterations parseIterations 0 = Right Continuous parseIterations 1 = Right OneIteration parseIterations i = Right (Iterations i)@@ -337,7 +347,7 @@ [ Env.helpDoc environmentParser, "", "Configuration file format:",- T.unpack (YamlParse.prettyColourisedSchemaDoc @Configuration)+ T.unpack (TE.decodeUtf8 (renderColouredSchemaViaCodec @Configuration)) ] -- | The flags that are common across commands.
src/Test/Syd/Run.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}@@ -11,6 +12,7 @@ -- | This module defines the 'IsTest' class and the different instances for it. module Test.Syd.Run where +import Autodocodec import Control.Concurrent import Control.Exception import Control.Monad.IO.Class@@ -29,7 +31,6 @@ import qualified Test.QuickCheck.Property as QCP import Test.QuickCheck.Random import Text.Printf-import YamlParse.Applicative class IsTest e where -- | The argument from 'aroundAll'@@ -381,12 +382,15 @@ | FixedSeed !Int deriving (Show, Eq, Generic) -instance YamlSchema SeedSetting where- yamlSchema =- alternatives- [ RandomSeed <$ literalString "random",- FixedSeed <$> yamlSchema- ]+instance HasCodec SeedSetting where+ codec = dimapCodec f g $ eitherCodec (literalTextCodec "random") codec+ where+ f = \case+ Left _ -> RandomSeed+ Right i -> FixedSeed i+ g = \case+ RandomSeed -> Left "random"+ FixedSeed i -> Right i data TestRunResult = TestRunResult { testRunResultStatus :: !TestStatus,
src/Test/Syd/Runner.hs view
@@ -48,7 +48,7 @@ withArgs [] $ case settingThreads sets of Synchronous -> runSpecForestInterleavedWithOutputSynchronously tc (settingFailFast sets) specForest ByCapabilities -> do- i <- getNumCapabilities+ i <- fromIntegral <$> getNumCapabilities when (i == 1) $ do let outputLine :: [Chunk] -> IO ()@@ -68,10 +68,10 @@ Asynchronous i -> runSpecForestInterleavedWithOutputAsynchronously tc (settingFailFast sets) i specForest -sydTestIterations :: Maybe Int -> Settings -> TestDefM '[] () r -> IO (Timed ResultForest)+sydTestIterations :: Maybe Word -> Settings -> TestDefM '[] () r -> IO (Timed ResultForest) sydTestIterations totalIterations sets spec = withArgs [] $ do- nbCapabilities <- getNumCapabilities+ nbCapabilities <- fromIntegral <$> getNumCapabilities let runOnce sets_ = do specForest <- execTestDefM sets_ spec@@ -85,7 +85,7 @@ let go iteration = do newSeedSetting <- case settingSeed sets of FixedSeed seed -> do- let newSeed = seed + iteration+ let newSeed = seed + fromIntegral iteration putStrLn $ printf "Running iteration: %4d with seed %4d" iteration newSeed pure $ FixedSeed newSeed RandomSeed -> do
src/Test/Syd/Runner/Asynchronous.hs view
@@ -27,7 +27,7 @@ import Test.Syd.SpecForest import Text.Colour -runSpecForestAsynchronously :: Bool -> Int -> TestForest '[] () -> IO ResultForest+runSpecForestAsynchronously :: Bool -> Word -> TestForest '[] () -> IO ResultForest runSpecForestAsynchronously failFast nbThreads testForest = do handleForest <- makeHandleForest testForest failFastVar <- newEmptyMVar@@ -36,7 +36,7 @@ ((), resultForest) <- concurrently runRunner runPrinter pure resultForest -runSpecForestInterleavedWithOutputAsynchronously :: TerminalCapabilities -> Bool -> Int -> TestForest '[] () -> IO (Timed ResultForest)+runSpecForestInterleavedWithOutputAsynchronously :: TerminalCapabilities -> Bool -> Word -> TestForest '[] () -> IO (Timed ResultForest) runSpecForestInterleavedWithOutputAsynchronously tc failFast nbThreads testForest = do handleForest <- makeHandleForest testForest failFastVar <- newEmptyMVar@@ -54,9 +54,9 @@ traverse $ \() -> newEmptyMVar -runner :: Bool -> Int -> MVar () -> HandleForest '[] () -> IO ()+runner :: Bool -> Word -> MVar () -> HandleForest '[] () -> IO () runner failFast nbThreads failFastVar handleForest = do- sem <- liftIO $ newQSemN nbThreads+ sem <- liftIO $ newQSemN $ fromIntegral nbThreads jobs <- newIORef (S.empty :: Set (Async ())) -- This is used to make sure that the 'after' part of the resources actually happens after the tests are done, not just when they are started. let waitForCurrentlyRunning :: IO ()@@ -80,7 +80,7 @@ -- 2. no other tests are started during execution. Sequential -> nbThreads Parallel -> 1- liftIO $ waitQSemN sem quantity+ liftIO $ waitQSemN sem $ fromIntegral quantity let job :: IO () job = do result <- runNow@@ -89,7 +89,7 @@ putMVar failFastVar () as <- readIORef jobs mapM_ cancel as- liftIO $ signalQSemN sem quantity+ liftIO $ signalQSemN sem $ fromIntegral quantity jobAsync <- async job modifyIORef jobs (S.insert jobAsync) link jobAsync
sydtest.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: sydtest-version: 0.5.0.0+version: 0.6.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@@ -66,6 +66,8 @@ , MonadRandom , QuickCheck , async+ , autodocodec+ , autodocodec-yaml , base >=4.7 && <5 , bytestring , containers@@ -84,7 +86,6 @@ , split , text , yaml- , yamlparse-applicative if os(windows) build-depends: ansi-terminal