diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. 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 @@ -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. 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 @@ -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, diff --git a/src/Test/Syd/Runner.hs b/src/Test/Syd/Runner.hs --- a/src/Test/Syd/Runner.hs +++ b/src/Test/Syd/Runner.hs @@ -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 diff --git a/src/Test/Syd/Runner/Asynchronous.hs b/src/Test/Syd/Runner/Asynchronous.hs --- a/src/Test/Syd/Runner/Asynchronous.hs +++ b/src/Test/Syd/Runner/Asynchronous.hs @@ -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 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.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