{-# LANGUAGE CPP #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}

module Test.Options (
  TestScenario (..),
  mainWithTestScenario,
  scenarioScaled,
  scenarioScaleDefault,
  eachOfTS,
  withTestsTS,
  TSProperty,
  TSGroup,
  concatGroups,
  concatTSGroups,
  tsGroupToTree,
  ShouldAssertNF (..),
)
where

import Cardano.Prelude
import Hedgehog (Gen, Group (..), Property, PropertyT, TestLimit, withTests)
import Hedgehog.Internal.Property (GroupName (..), PropertyName (..))
import Test.Cardano.Prelude
import Test.Tasty (
  TestName,
  TestTree,
  askOption,
  defaultMainWithIngredients,
  includingOptions,
  testGroup,
 )
import Test.Tasty.Hedgehog hiding (testProperty)
import Test.Tasty.Ingredients (Ingredient (..), composeReporters)
import Test.Tasty.Ingredients.Basic (consoleTestReporter, listingTests)
import Test.Tasty.Options (
  IsOption (..),
  OptionDescription (..),
  lookupOption,
  safeRead,
 )

-- | testProperty has been deprecated. We make our own version here.
testProperty :: TestName -> Property -> TestTree
testProperty :: String -> Property -> TestTree
testProperty String
s Property
p = String -> PropertyName -> Property -> TestTree
testPropertyNamed String
s (String -> PropertyName
Hedgehog.Internal.Property.PropertyName String
s) Property
p

--------------------------------------------------------------------------------
-- TestScenario
--------------------------------------------------------------------------------

data TestScenario
  = ContinuousIntegration
  | Development
  | QualityAssurance
  deriving (ReadPrec [TestScenario]
ReadPrec TestScenario
Int -> ReadS TestScenario
ReadS [TestScenario]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [TestScenario]
$creadListPrec :: ReadPrec [TestScenario]
readPrec :: ReadPrec TestScenario
$creadPrec :: ReadPrec TestScenario
readList :: ReadS [TestScenario]
$creadList :: ReadS [TestScenario]
readsPrec :: Int -> ReadS TestScenario
$creadsPrec :: Int -> ReadS TestScenario
Read, Int -> TestScenario -> ShowS
[TestScenario] -> ShowS
TestScenario -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TestScenario] -> ShowS
$cshowList :: [TestScenario] -> ShowS
show :: TestScenario -> String
$cshow :: TestScenario -> String
showsPrec :: Int -> TestScenario -> ShowS
$cshowsPrec :: Int -> TestScenario -> ShowS
Show)

instance IsOption TestScenario where
  defaultValue :: TestScenario
defaultValue = TestScenario
Development
  parseValue :: String -> Maybe TestScenario
parseValue = forall a. Read a => String -> Maybe a
safeRead
  optionName :: Tagged TestScenario String
optionName = forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"scenario"
  optionHelp :: Tagged TestScenario String
optionHelp = forall (f :: * -> *) a. Applicative f => a -> f a
pure String
helpText

logScenario :: Ingredient
logScenario :: Ingredient
logScenario = [OptionDescription]
-> (OptionSet
    -> TestTree -> Maybe (StatusMap -> IO (Time -> IO Bool)))
-> Ingredient
TestReporter [] forall a b. (a -> b) -> a -> b
$ \OptionSet
options TestTree
_ -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ \StatusMap
_ -> do
  let scenario :: TestScenario
scenario = forall v. IsOption v => OptionSet -> v
lookupOption @TestScenario OptionSet
options
  Text -> IO ()
putTextLn forall a b. (a -> b) -> a -> b
$ Text
"\nRunning in scenario: " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, ConvertText String b) => a -> b
show TestScenario
scenario
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> b -> a
const (forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True))

mainWithTestScenario :: TestTree -> IO ()
mainWithTestScenario :: TestTree -> IO ()
mainWithTestScenario =
  [Ingredient] -> TestTree -> IO ()
defaultMainWithIngredients
    [ [OptionDescription] -> Ingredient
includingOptions [forall v. IsOption v => Proxy v -> OptionDescription
Option (forall {k} (t :: k). Proxy t
Proxy @TestScenario)]
    , Ingredient
listingTests
    , Ingredient -> Ingredient -> Ingredient
composeReporters Ingredient
logScenario Ingredient
consoleTestReporter
    ]

helpText :: [Char]
helpText :: String
helpText =
  String
"Run under one of Development (default), ContinuousIntegration, or "
    forall a. Semigroup a => a -> a -> a
<> String
"QualityAssurance, to affect how tests are run"

--------------------------------------------------------------------------------
-- TestLimit scaling functions & helpers
--------------------------------------------------------------------------------

-- | Convenient alias for TestScenario-dependent @Group@s
type TSGroup = TestScenario -> Group

concatGroups :: [Group] -> Group
concatGroups :: [Group] -> Group
concatGroups [] = forall a. HasCallStack => Text -> a
panic Text
"concatGroups: No tests in test Group"
concatGroups gs :: [Group]
gs@(Group
g : [Group]
_) = GroupName -> [(PropertyName, Property)] -> Group
Group (Group -> GroupName
groupName Group
g) (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ Group -> [(PropertyName, Property)]
groupProperties forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Group]
gs)

concatTSGroups :: [TSGroup] -> TSGroup
concatTSGroups :: [TSGroup] -> TSGroup
concatTSGroups [TSGroup]
gs TestScenario
ts = [Group] -> Group
concatGroups forall a b. (a -> b) -> a -> b
$ (forall a b. (a -> b) -> a -> b
$ TestScenario
ts) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TSGroup]
gs

tsGroupToTree :: TSGroup -> TestTree
tsGroupToTree :: TSGroup -> TestTree
tsGroupToTree TSGroup
tsGroup = forall v. IsOption v => (v -> TestTree) -> TestTree
askOption forall a b. (a -> b) -> a -> b
$ \TestScenario
scenario -> case TSGroup
tsGroup TestScenario
scenario of
  Group {GroupName
groupName :: GroupName
groupName :: Group -> GroupName
groupName, [(PropertyName, Property)]
groupProperties :: [(PropertyName, Property)]
groupProperties :: Group -> [(PropertyName, Property)]
groupProperties} ->
    String -> [TestTree] -> TestTree
testGroup
      (GroupName -> String
unGroupName GroupName
groupName)
      (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> Property -> TestTree
testProperty forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first PropertyName -> String
unPropertyName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PropertyName, Property)]
groupProperties)

-- | Convenient alias for TestScenario-dependent @Property@s
type TSProperty = TestScenario -> Property

-- | Default ratio of tests in development
devTestDefault :: Ratio TestLimit
devTestDefault :: Ratio TestLimit
devTestDefault = TestLimit
1 forall a. Integral a => a -> a -> Ratio a
% TestLimit
2

-- | Default ratio of tests in CI
ciTestDefault :: Ratio TestLimit
ciTestDefault :: Ratio TestLimit
ciTestDefault = TestLimit
1 forall a. Integral a => a -> a -> Ratio a
% TestLimit
1

-- | Default ratio of tests in QA
qaTestDefault :: Ratio TestLimit
qaTestDefault :: Ratio TestLimit
qaTestDefault = TestLimit
2 forall a. Integral a => a -> a -> Ratio a
% TestLimit
1

-- | Return an Int number of tests, using the above-defined defaults
scenarioScaleDefault :: TestScenario -> Ratio TestLimit
scenarioScaleDefault :: TestScenario -> Ratio TestLimit
scenarioScaleDefault TestScenario
ts = case TestScenario
ts of
  TestScenario
Development -> Ratio TestLimit
devTestDefault
  TestScenario
ContinuousIntegration -> Ratio TestLimit
ciTestDefault
  TestScenario
QualityAssurance -> Ratio TestLimit
qaTestDefault

-- | Multiply the default scenario values by a scalar
scenarioScaled :: TestLimit -> TestScenario -> TestLimit
scenarioScaled :: TestLimit -> TestScenario -> TestLimit
scenarioScaled TestLimit
count TestScenario
ts =
  if TestLimit
scaledCount forall a. Ord a => a -> a -> Bool
> TestLimit
0
    then TestLimit
scaledCount
    else
      forall a. HasCallStack => Text -> a
panic
        forall a b. (a -> b) -> a -> b
$ Text
"scenarioScaled: produced a non-positive TestLimit: "
        forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, ConvertText String b) => a -> b
show TestLimit
scaledCount
  where
    scaledCount :: TestLimit
    scaledCount :: TestLimit
scaledCount = forall a b. (RealFrac a, Integral b) => a -> b
round forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ((TestLimit
count forall a. Integral a => a -> a -> Ratio a
% TestLimit
1) forall a. Num a => a -> a -> a
*) forall a b. (a -> b) -> a -> b
$ TestScenario -> Ratio TestLimit
scenarioScaleDefault TestScenario
ts

-- | A modified `eachOf` which uses the default TestScenario values,
-- multiplied by a scalar
eachOfTS ::
  (Show a, HasCallStack) =>
  TestLimit ->
  Gen a ->
  (a -> PropertyT IO ()) ->
  TestScenario ->
  Property
eachOfTS :: forall a.
(Show a, HasCallStack) =>
TestLimit
-> Gen a -> (a -> PropertyT IO ()) -> TestScenario -> Property
eachOfTS TestLimit
count Gen a
gen a -> PropertyT IO ()
predicate TestScenario
scenario =
  forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall a.
(Show a, HasCallStack) =>
TestLimit -> Gen a -> (a -> PropertyT IO ()) -> Property
eachOf (TestLimit -> TestScenario -> TestLimit
scenarioScaled TestLimit
count TestScenario
scenario) Gen a
gen a -> PropertyT IO ()
predicate

-- | A modified `withTests` which uses the default TestScenario values,
-- multiplied by a scalar
withTestsTS ::
  TestLimit ->
  Property ->
  TestScenario ->
  Property
withTestsTS :: TestLimit -> Property -> TestScenario -> Property
withTestsTS TestLimit
count Property
prop TestScenario
scenario =
  TestLimit -> Property -> Property
withTests (TestLimit -> TestScenario -> TestLimit
scenarioScaled TestLimit
count TestScenario
scenario) Property
prop

--------------------------------------------------------------------------------
-- ShouldAssertNF
--------------------------------------------------------------------------------

data ShouldAssertNF
  = AssertNF
  | NoAssertNF
  deriving (ShouldAssertNF -> ShouldAssertNF -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ShouldAssertNF -> ShouldAssertNF -> Bool
$c/= :: ShouldAssertNF -> ShouldAssertNF -> Bool
== :: ShouldAssertNF -> ShouldAssertNF -> Bool
$c== :: ShouldAssertNF -> ShouldAssertNF -> Bool
Eq, Int -> ShouldAssertNF -> ShowS
[ShouldAssertNF] -> ShowS
ShouldAssertNF -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ShouldAssertNF] -> ShowS
$cshowList :: [ShouldAssertNF] -> ShowS
show :: ShouldAssertNF -> String
$cshow :: ShouldAssertNF -> String
showsPrec :: Int -> ShouldAssertNF -> ShowS
$cshowsPrec :: Int -> ShouldAssertNF -> ShowS
Show)