{-# 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]
(Int -> ReadS TestScenario)
-> ReadS [TestScenario]
-> ReadPrec TestScenario
-> ReadPrec [TestScenario]
-> Read TestScenario
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS TestScenario
readsPrec :: Int -> ReadS TestScenario
$creadList :: ReadS [TestScenario]
readList :: ReadS [TestScenario]
$creadPrec :: ReadPrec TestScenario
readPrec :: ReadPrec TestScenario
$creadListPrec :: ReadPrec [TestScenario]
readListPrec :: ReadPrec [TestScenario]
Read, Int -> TestScenario -> ShowS
[TestScenario] -> ShowS
TestScenario -> String
(Int -> TestScenario -> ShowS)
-> (TestScenario -> String)
-> ([TestScenario] -> ShowS)
-> Show TestScenario
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestScenario -> ShowS
showsPrec :: Int -> TestScenario -> ShowS
$cshow :: TestScenario -> String
show :: TestScenario -> String
$cshowList :: [TestScenario] -> ShowS
showList :: [TestScenario] -> ShowS
Show)

instance IsOption TestScenario where
  defaultValue :: TestScenario
defaultValue = TestScenario
Development
  parseValue :: String -> Maybe TestScenario
parseValue = String -> Maybe TestScenario
forall a. Read a => String -> Maybe a
safeRead
  optionName :: Tagged TestScenario String
optionName = String -> Tagged TestScenario String
forall a. a -> Tagged TestScenario a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"scenario"
  optionHelp :: Tagged TestScenario String
optionHelp = String -> Tagged TestScenario String
forall a. a -> Tagged TestScenario a
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 [] ((OptionSet
  -> TestTree -> Maybe (StatusMap -> IO (Time -> IO Bool)))
 -> Ingredient)
-> (OptionSet
    -> TestTree -> Maybe (StatusMap -> IO (Time -> IO Bool)))
-> Ingredient
forall a b. (a -> b) -> a -> b
$ \OptionSet
options TestTree
_ -> (StatusMap -> IO (Time -> IO Bool))
-> Maybe (StatusMap -> IO (Time -> IO Bool))
forall a. a -> Maybe a
Just ((StatusMap -> IO (Time -> IO Bool))
 -> Maybe (StatusMap -> IO (Time -> IO Bool)))
-> (StatusMap -> IO (Time -> IO Bool))
-> Maybe (StatusMap -> IO (Time -> IO Bool))
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 (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"\nRunning in scenario: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TestScenario -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show TestScenario
scenario
  (Time -> IO Bool) -> IO (Time -> IO Bool)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO Bool -> Time -> IO Bool
forall a b. a -> b -> a
const (Bool -> IO Bool
forall a. a -> IO a
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 [Proxy TestScenario -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (forall t. Proxy t
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 "
    String -> ShowS
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 [] = Text -> Group
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) ([[(PropertyName, Property)]] -> [(PropertyName, Property)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(PropertyName, Property)]] -> [(PropertyName, Property)])
-> [[(PropertyName, Property)]] -> [(PropertyName, Property)]
forall a b. (a -> b) -> a -> b
$ Group -> [(PropertyName, Property)]
groupProperties (Group -> [(PropertyName, Property)])
-> [Group] -> [[(PropertyName, Property)]]
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 ([Group] -> Group) -> [Group] -> Group
forall a b. (a -> b) -> a -> b
$ (TSGroup -> TSGroup
forall a b. (a -> b) -> a -> b
$ TestScenario
ts) (TSGroup -> Group) -> [TSGroup] -> [Group]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TSGroup]
gs

tsGroupToTree :: TSGroup -> TestTree
tsGroupToTree :: TSGroup -> TestTree
tsGroupToTree TSGroup
tsGroup = (TestScenario -> TestTree) -> TestTree
forall v. IsOption v => (v -> TestTree) -> TestTree
askOption ((TestScenario -> TestTree) -> TestTree)
-> (TestScenario -> TestTree) -> TestTree
forall a b. (a -> b) -> a -> b
$ \TestScenario
scenario -> case TSGroup
tsGroup TestScenario
scenario of
  Group {GroupName
groupName :: Group -> GroupName
groupName :: GroupName
groupName, [(PropertyName, Property)]
groupProperties :: Group -> [(PropertyName, Property)]
groupProperties :: [(PropertyName, Property)]
groupProperties} ->
    String -> [TestTree] -> TestTree
testGroup
      (GroupName -> String
unGroupName GroupName
groupName)
      ((String -> Property -> TestTree) -> (String, Property) -> TestTree
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> Property -> TestTree
testProperty ((String, Property) -> TestTree)
-> ((PropertyName, Property) -> (String, Property))
-> (PropertyName, Property)
-> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (PropertyName -> String)
-> (PropertyName, Property) -> (String, Property)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first PropertyName -> String
unPropertyName ((PropertyName, Property) -> TestTree)
-> [(PropertyName, Property)] -> [TestTree]
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 TestLimit -> TestLimit -> Ratio TestLimit
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 TestLimit -> TestLimit -> Ratio TestLimit
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 TestLimit -> TestLimit -> Ratio TestLimit
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 TestLimit -> TestLimit -> Bool
forall a. Ord a => a -> a -> Bool
> TestLimit
0
    then TestLimit
scaledCount
    else
      Text -> TestLimit
forall a. HasCallStack => Text -> a
panic
        (Text -> TestLimit) -> Text -> TestLimit
forall a b. (a -> b) -> a -> b
$ Text
"scenarioScaled: produced a non-positive TestLimit: "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TestLimit -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show TestLimit
scaledCount
  where
    scaledCount :: TestLimit
    scaledCount :: TestLimit
scaledCount = Ratio TestLimit -> TestLimit
forall b. Integral b => Ratio TestLimit -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Ratio TestLimit -> TestLimit)
-> (Ratio TestLimit -> Ratio TestLimit)
-> Ratio TestLimit
-> TestLimit
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ((TestLimit
count TestLimit -> TestLimit -> Ratio TestLimit
forall a. Integral a => a -> a -> Ratio a
% TestLimit
1) Ratio TestLimit -> Ratio TestLimit -> Ratio TestLimit
forall a. Num a => a -> a -> a
*) (Ratio TestLimit -> TestLimit) -> Ratio TestLimit -> TestLimit
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 =
  (HasCallStack => Property) -> Property
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Property) -> Property)
-> (HasCallStack => Property) -> Property
forall a b. (a -> b) -> a -> b
$ TestLimit -> Gen a -> (a -> PropertyT IO ()) -> Property
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
(ShouldAssertNF -> ShouldAssertNF -> Bool)
-> (ShouldAssertNF -> ShouldAssertNF -> Bool) -> Eq ShouldAssertNF
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ShouldAssertNF -> ShouldAssertNF -> Bool
== :: ShouldAssertNF -> ShouldAssertNF -> Bool
$c/= :: ShouldAssertNF -> ShouldAssertNF -> Bool
/= :: ShouldAssertNF -> ShouldAssertNF -> Bool
Eq, Int -> ShouldAssertNF -> ShowS
[ShouldAssertNF] -> ShowS
ShouldAssertNF -> String
(Int -> ShouldAssertNF -> ShowS)
-> (ShouldAssertNF -> String)
-> ([ShouldAssertNF] -> ShowS)
-> Show ShouldAssertNF
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ShouldAssertNF -> ShowS
showsPrec :: Int -> ShouldAssertNF -> ShowS
$cshow :: ShouldAssertNF -> String
show :: ShouldAssertNF -> String
$cshowList :: [ShouldAssertNF] -> ShowS
showList :: [ShouldAssertNF] -> ShowS
Show)