{-# OPTIONS_GHC -Wno-orphans #-} -- | Tasty integration -- -- This are the internal guts of the integration. Publicly visible API lives in -- "Test.Tasty.Falsify". module Test.Falsify.Internal.Driver.Tasty ( -- * Test property testProperty -- * Configure test behaviour , TestOptions(..) , Verbose(..) , ExpectFailure(..) , testPropertyWith ) where import Prelude hiding (log) import Data.Default import Data.Maybe import Data.Proxy import Data.Tagged import Test.Tasty import Test.Tasty.Options (IsOption(..), OptionSet) import Test.Tasty.Providers (IsTest(..)) import qualified Test.Tasty.Options as Tasty import Test.Falsify.Internal.Driver import Test.Falsify.Internal.Driver.ReplaySeed import Test.Falsify.Internal.Property import qualified Options.Applicative as Opts import qualified Test.Tasty.Providers as Tasty {------------------------------------------------------------------------------- Tasty integration -------------------------------------------------------------------------------} data Test = Test TestOptions (Property' String ()) data TestOptions = TestOptions { -- | Do we expect this test to fail? expectFailure :: ExpectFailure -- | Override verbose mode for this test , overrideVerbose :: Maybe Verbose -- | Override the maximum number of shrink steps for this test , overrideMaxShrinks :: Maybe Word -- | Override the number of tests , overrideNumTests :: Maybe Word -- | Override how many tests can be discarded per successful test , overrideMaxRatio :: Maybe Word } instance Default TestOptions where def = TestOptions { expectFailure = DontExpectFailure , overrideVerbose = Nothing , overrideMaxShrinks = Nothing , overrideNumTests = Nothing , overrideMaxRatio = Nothing } instance IsTest Test where -- @tasty@ docs (1.4.3) explicitly say to ignore the @reportProgress@ argument run opts (Test testOpts prop) _reportProgress = toTastyResult . renderTestResult verbose (expectFailure testOpts) <$> falsify driverOpts prop where verbose :: Verbose verbose = fromMaybe (Tasty.lookupOption opts) (overrideVerbose testOpts) driverOpts :: Options driverOpts = maybe id (\x o -> o{maxShrinks = Just x}) (overrideMaxShrinks testOpts) $ maybe id (\x o -> o{tests = x}) (overrideNumTests testOpts) $ maybe id (\x o -> o{maxRatio = x}) (overrideMaxRatio testOpts) $ driverOptions opts testOptions = Tagged [ Tasty.Option $ Proxy @Verbose , Tasty.Option $ Proxy @Tests , Tasty.Option $ Proxy @MaxShrinks , Tasty.Option $ Proxy @Replay , Tasty.Option $ Proxy @MaxRatio ] toTastyResult :: RenderedTestResult -> Tasty.Result toTastyResult RenderedTestResult{testPassed, testOutput} | testPassed = Tasty.testPassed testOutput | otherwise = Tasty.testFailed testOutput {------------------------------------------------------------------------------- User API -------------------------------------------------------------------------------} -- | Generalization of 'testPropertyWith' using default options testProperty :: TestName -> Property' String () -> TestTree testProperty = testPropertyWith def testPropertyWith :: TestOptions -> TestName -> Property' String () -> TestTree testPropertyWith testOpts name = Tasty.singleTest name . Test testOpts {------------------------------------------------------------------------------- Options specific to the tasty test runner Not all of these options are command line options; some are set on a test-by-test basis, such as 'ExpectFailure'. -------------------------------------------------------------------------------} instance IsOption Verbose where defaultValue = NotVerbose parseValue = fmap (\b -> if b then Verbose else NotVerbose) . Tasty.safeReadBool optionName = Tagged $ "falsify-verbose" optionHelp = Tagged $ "Show the generated test cases" optionCLParser = Tasty.mkFlagCLParser mempty Verbose {------------------------------------------------------------------------------- Options NOTE: If we add another option here, we must also add it in 'testOptions'. -------------------------------------------------------------------------------} newtype Tests = Tests { getTests :: Word } newtype MaxShrinks = MaxShrinks { getMaxShrinks :: Maybe Word } newtype Replay = Replay { getReplay :: Maybe ReplaySeed } newtype MaxRatio = MaxRatio { getMaxRatio :: Word } instance IsOption Tests where defaultValue = Tests (tests def) parseValue = fmap Tests . Tasty.safeRead . filter (/= '_') optionName = Tagged "falsify-tests" optionHelp = Tagged "Number of test cases to generate" instance IsOption MaxShrinks where defaultValue = MaxShrinks (maxShrinks def) parseValue = fmap (MaxShrinks . Just) . Tasty.safeRead optionName = Tagged "falsify-shrinks" optionHelp = Tagged "Random seed to use for replaying a previous test run" instance IsOption Replay where defaultValue = Replay (replay def) parseValue = fmap (Replay . Just) . safeReadReplaySeed optionName = Tagged "falsify-replay" optionHelp = Tagged "Random seed to use for replaying test" optionCLParser = Opts.option readReplaySeed $ mconcat [ Opts.long $ untag $ optionName @Replay , Opts.help $ untag $ optionHelp @Replay ] where readReplaySeed :: Opts.ReadM Replay readReplaySeed = Opts.str >>= fmap (Replay . Just) . parseReplaySeed instance IsOption MaxRatio where defaultValue = MaxRatio (maxRatio def) parseValue = fmap MaxRatio . Tasty.safeRead . filter (/= '_') optionName = Tagged "falsify-max-ratio" optionHelp = Tagged "Maximum number of discarded tests per successful test" driverOptions :: OptionSet -> Options driverOptions opts = Options { tests = getTests $ Tasty.lookupOption opts , maxShrinks = getMaxShrinks $ Tasty.lookupOption opts , replay = getReplay $ Tasty.lookupOption opts , maxRatio = getMaxRatio $ Tasty.lookupOption opts }