{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Test.Ouroboros.Consensus.Util.LeakyBucket.Tests (tests) where
import Control.Monad (foldM, void)
import Control.Monad.Class.MonadTimer (MonadTimer)
import Control.Monad.IOSim (IOSim, runSimOrThrow)
import Data.Either (isLeft, isRight)
import Data.Functor ((<&>))
import Data.List (intersperse)
import Data.Ratio ((%))
import Data.Time.Clock (DiffTime, picosecondsToDiffTime)
import Ouroboros.Consensus.Util.IOLike (Exception (displayException),
MonadAsync, MonadCatch (try), MonadDelay, MonadFork,
MonadMask, MonadSTM, MonadThrow (throwIO), NoThunks,
SomeException, Time (Time), addTime, fromException,
threadDelay)
import Ouroboros.Consensus.Util.LeakyBucket
import Test.QuickCheck (Arbitrary (arbitrary), Gen, Property,
classify, counterexample, forAllShrinkBlind, frequency,
ioProperty, liftArbitrary2, listOf1, scale, shrinkList,
suchThat)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck (property, testProperty)
import Test.Util.TestEnv (adjustQuickCheckTests)
tests :: TestTree
tests :: TestTree
tests = TestName -> [TestTree] -> TestTree
testGroup TestName
"Ouroboros.Consensus.Util.LeakyBucket" [
TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"play a bit" Property
prop_playABit,
TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"play too long" Property
prop_playTooLong,
TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"play too long harmless" Property
prop_playTooLongHarmless,
TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"play with pause" Property
prop_playWithPause,
TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"play with pause too long" Property
prop_playWithPauseTooLong,
TestName -> (Capacity -> Rate -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"wait almost too long" (Bool -> Capacity -> Rate -> Property
prop_noRefill Bool
False),
TestName -> (Capacity -> Rate -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"wait just too long" (Bool -> Capacity -> Rate -> Property
prop_noRefill Bool
True),
TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"propagates exceptions" Property
prop_propagateExceptions,
TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"propagates exceptions (IO)" Property
prop_propagateExceptionsIO,
TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"catch exception" Property
prop_catchException,
(Int -> Int) -> TestTree -> TestTree
adjustQuickCheckTests (Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$ TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"random" Property
prop_random
]
newtype Capacity = Capacity { Capacity -> Rational
unCapacity :: Rational }
deriving Int -> Capacity -> ShowS
[Capacity] -> ShowS
Capacity -> TestName
(Int -> Capacity -> ShowS)
-> (Capacity -> TestName) -> ([Capacity] -> ShowS) -> Show Capacity
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Capacity -> ShowS
showsPrec :: Int -> Capacity -> ShowS
$cshow :: Capacity -> TestName
show :: Capacity -> TestName
$cshowList :: [Capacity] -> ShowS
showList :: [Capacity] -> ShowS
Show
instance Arbitrary Capacity where
arbitrary :: Gen Capacity
arbitrary = Rational -> Capacity
Capacity (Rational -> Capacity) -> Gen Rational -> Gen Capacity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Rational
forall a. Arbitrary a => Gen a
arbitrary Gen Rational -> (Rational -> Bool) -> Gen Rational
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
> Rational
0)
newtype Rate = Rate { Rate -> Rational
unRate :: Rational }
deriving Int -> Rate -> ShowS
[Rate] -> ShowS
Rate -> TestName
(Int -> Rate -> ShowS)
-> (Rate -> TestName) -> ([Rate] -> ShowS) -> Show Rate
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Rate -> ShowS
showsPrec :: Int -> Rate -> ShowS
$cshow :: Rate -> TestName
show :: Rate -> TestName
$cshowList :: [Rate] -> ShowS
showList :: [Rate] -> ShowS
Show
instance Arbitrary Rate where
arbitrary :: Gen Rate
arbitrary = Rational -> Rate
Rate (Rational -> Rate) -> Gen Rational -> Gen Rate
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Rational
forall a. Arbitrary a => Gen a
arbitrary Gen Rational -> (Rational -> Bool) -> Gen Rational
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
> Rational
0)
newtype FillOnOverflow = FillOnOverflow { FillOnOverflow -> Bool
unFillOnOverflow :: Bool }
deriving Int -> FillOnOverflow -> ShowS
[FillOnOverflow] -> ShowS
FillOnOverflow -> TestName
(Int -> FillOnOverflow -> ShowS)
-> (FillOnOverflow -> TestName)
-> ([FillOnOverflow] -> ShowS)
-> Show FillOnOverflow
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FillOnOverflow -> ShowS
showsPrec :: Int -> FillOnOverflow -> ShowS
$cshow :: FillOnOverflow -> TestName
show :: FillOnOverflow -> TestName
$cshowList :: [FillOnOverflow] -> ShowS
showList :: [FillOnOverflow] -> ShowS
Show
instance Arbitrary FillOnOverflow where
arbitrary :: Gen FillOnOverflow
arbitrary = Bool -> FillOnOverflow
FillOnOverflow (Bool -> FillOnOverflow) -> Gen Bool -> Gen FillOnOverflow
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Bool
forall a. Arbitrary a => Gen a
arbitrary
newtype ThrowOnEmpty = ThrowOnEmpty { ThrowOnEmpty -> Bool
unThrowOnEmpty :: Bool }
deriving (ThrowOnEmpty -> ThrowOnEmpty -> Bool
(ThrowOnEmpty -> ThrowOnEmpty -> Bool)
-> (ThrowOnEmpty -> ThrowOnEmpty -> Bool) -> Eq ThrowOnEmpty
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ThrowOnEmpty -> ThrowOnEmpty -> Bool
== :: ThrowOnEmpty -> ThrowOnEmpty -> Bool
$c/= :: ThrowOnEmpty -> ThrowOnEmpty -> Bool
/= :: ThrowOnEmpty -> ThrowOnEmpty -> Bool
Eq, Int -> ThrowOnEmpty -> ShowS
[ThrowOnEmpty] -> ShowS
ThrowOnEmpty -> TestName
(Int -> ThrowOnEmpty -> ShowS)
-> (ThrowOnEmpty -> TestName)
-> ([ThrowOnEmpty] -> ShowS)
-> Show ThrowOnEmpty
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ThrowOnEmpty -> ShowS
showsPrec :: Int -> ThrowOnEmpty -> ShowS
$cshow :: ThrowOnEmpty -> TestName
show :: ThrowOnEmpty -> TestName
$cshowList :: [ThrowOnEmpty] -> ShowS
showList :: [ThrowOnEmpty] -> ShowS
Show)
instance Arbitrary ThrowOnEmpty where
arbitrary :: Gen ThrowOnEmpty
arbitrary = Bool -> ThrowOnEmpty
ThrowOnEmpty (Bool -> ThrowOnEmpty) -> Gen Bool -> Gen ThrowOnEmpty
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Bool
forall a. Arbitrary a => Gen a
arbitrary
data TestConfig = TestConfig
{ TestConfig -> Rational
testCapacity :: Rational,
TestConfig -> Rational
testRate :: Rational,
TestConfig -> Bool
testThrowOnEmpty :: Bool
}
deriving (TestConfig -> TestConfig -> Bool
(TestConfig -> TestConfig -> Bool)
-> (TestConfig -> TestConfig -> Bool) -> Eq TestConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TestConfig -> TestConfig -> Bool
== :: TestConfig -> TestConfig -> Bool
$c/= :: TestConfig -> TestConfig -> Bool
/= :: TestConfig -> TestConfig -> Bool
Eq, Int -> TestConfig -> ShowS
[TestConfig] -> ShowS
TestConfig -> TestName
(Int -> TestConfig -> ShowS)
-> (TestConfig -> TestName)
-> ([TestConfig] -> ShowS)
-> Show TestConfig
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestConfig -> ShowS
showsPrec :: Int -> TestConfig -> ShowS
$cshow :: TestConfig -> TestName
show :: TestConfig -> TestName
$cshowList :: [TestConfig] -> ShowS
showList :: [TestConfig] -> ShowS
Show)
data TestState = TestState
{ TestState -> Rational
testLevel :: Rational,
TestState -> Time
testTime :: Time,
TestState -> Bool
testPaused :: Bool
}
deriving (TestState -> TestState -> Bool
(TestState -> TestState -> Bool)
-> (TestState -> TestState -> Bool) -> Eq TestState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TestState -> TestState -> Bool
== :: TestState -> TestState -> Bool
$c/= :: TestState -> TestState -> Bool
/= :: TestState -> TestState -> Bool
Eq, Int -> TestState -> ShowS
[TestState] -> ShowS
TestState -> TestName
(Int -> TestState -> ShowS)
-> (TestState -> TestName)
-> ([TestState] -> ShowS)
-> Show TestState
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestState -> ShowS
showsPrec :: Int -> TestState -> ShowS
$cshow :: TestState -> TestName
show :: TestState -> TestName
$cshowList :: [TestState] -> ShowS
showList :: [TestState] -> ShowS
Show)
instance Arbitrary TestConfig where
arbitrary :: Gen TestConfig
arbitrary =
Rational -> Rational -> Bool -> TestConfig
TestConfig
(Rational -> Rational -> Bool -> TestConfig)
-> Gen Rational -> Gen (Rational -> Bool -> TestConfig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Capacity -> Rational
unCapacity (Capacity -> Rational) -> Gen Capacity -> Gen Rational
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Capacity
forall a. Arbitrary a => Gen a
arbitrary)
Gen (Rational -> Bool -> TestConfig)
-> Gen Rational -> Gen (Bool -> TestConfig)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Rate -> Rational
unRate (Rate -> Rational) -> Gen Rate -> Gen Rational
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Rate
forall a. Arbitrary a => Gen a
arbitrary)
Gen (Bool -> TestConfig) -> Gen Bool -> Gen TestConfig
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ThrowOnEmpty -> Bool
unThrowOnEmpty (ThrowOnEmpty -> Bool) -> Gen ThrowOnEmpty -> Gen Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ThrowOnEmpty
forall a. Arbitrary a => Gen a
arbitrary)
data EmptyBucket = EmptyBucket
deriving (EmptyBucket -> EmptyBucket -> Bool
(EmptyBucket -> EmptyBucket -> Bool)
-> (EmptyBucket -> EmptyBucket -> Bool) -> Eq EmptyBucket
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EmptyBucket -> EmptyBucket -> Bool
== :: EmptyBucket -> EmptyBucket -> Bool
$c/= :: EmptyBucket -> EmptyBucket -> Bool
/= :: EmptyBucket -> EmptyBucket -> Bool
Eq, Int -> EmptyBucket -> ShowS
[EmptyBucket] -> ShowS
EmptyBucket -> TestName
(Int -> EmptyBucket -> ShowS)
-> (EmptyBucket -> TestName)
-> ([EmptyBucket] -> ShowS)
-> Show EmptyBucket
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EmptyBucket -> ShowS
showsPrec :: Int -> EmptyBucket -> ShowS
$cshow :: EmptyBucket -> TestName
show :: EmptyBucket -> TestName
$cshowList :: [EmptyBucket] -> ShowS
showList :: [EmptyBucket] -> ShowS
Show)
instance Exception EmptyBucket
mkConfig :: MonadThrow m => TestConfig -> Config m
mkConfig :: forall (m :: * -> *). MonadThrow m => TestConfig -> Config m
mkConfig TestConfig {Rational
testCapacity :: TestConfig -> Rational
testCapacity :: Rational
testCapacity, Rational
testRate :: TestConfig -> Rational
testRate :: Rational
testRate, Bool
testThrowOnEmpty :: TestConfig -> Bool
testThrowOnEmpty :: Bool
testThrowOnEmpty} =
Config
{ capacity :: Rational
capacity = Rational
testCapacity,
rate :: Rational
rate = Rational
testRate,
fillOnOverflow :: Bool
fillOnOverflow = Bool
True,
onEmpty :: m ()
onEmpty =
if Bool
testThrowOnEmpty
then (EmptyBucket -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO EmptyBucket
EmptyBucket)
else (() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
}
configThrow :: Capacity -> Rate -> TestConfig
configThrow :: Capacity -> Rate -> TestConfig
configThrow (Capacity Rational
testCapacity) (Rate Rational
testRate) =
TestConfig{Rational
testCapacity :: Rational
testCapacity :: Rational
testCapacity, Rational
testRate :: Rational
testRate :: Rational
testRate, testThrowOnEmpty :: Bool
testThrowOnEmpty = Bool
True}
config11Throw :: TestConfig
config11Throw :: TestConfig
config11Throw = Capacity -> Rate -> TestConfig
configThrow (Rational -> Capacity
Capacity Rational
1) (Rational -> Rate
Rate Rational
1)
configPure :: Capacity -> Rate -> TestConfig
configPure :: Capacity -> Rate -> TestConfig
configPure (Capacity Rational
testCapacity) (Rate Rational
testRate) =
TestConfig{Rational
testCapacity :: Rational
testCapacity :: Rational
testCapacity, Rational
testRate :: Rational
testRate :: Rational
testRate, testThrowOnEmpty :: Bool
testThrowOnEmpty = Bool
False}
config11Pure :: TestConfig
config11Pure :: TestConfig
config11Pure = Capacity -> Rate -> TestConfig
configPure (Rational -> Capacity
Capacity Rational
1) (Rational -> Rate
Rate Rational
1)
stateToTestState :: State m -> TestState
stateToTestState :: forall (m :: * -> *). State m -> TestState
stateToTestState State{Rational
level :: Rational
level :: forall (m :: * -> *). State m -> Rational
level, Time
time :: Time
time :: forall (m :: * -> *). State m -> Time
time, Bool
paused :: Bool
paused :: forall (m :: * -> *). State m -> Bool
paused} =
TestState{testLevel :: Rational
testLevel = Rational
level, testTime :: Time
testTime = Time
time, testPaused :: Bool
testPaused = Bool
paused}
testExecAgainstBucket ::
( MonadDelay m,
MonadAsync m,
MonadFork m,
MonadMask m,
MonadTimer m,
NoThunks (m ())
) =>
TestConfig ->
(Handlers m -> m a) ->
m a
testExecAgainstBucket :: forall (m :: * -> *) a.
(MonadDelay m, MonadAsync m, MonadFork m, MonadMask m,
MonadTimer m, NoThunks (m ())) =>
TestConfig -> (Handlers m -> m a) -> m a
testExecAgainstBucket TestConfig
testConfig Handlers m -> m a
action =
Config m -> (Handlers m -> m a) -> m a
forall (m :: * -> *) a.
(MonadDelay m, MonadAsync m, MonadFork m, MonadMask m,
MonadTimer m, NoThunks (m ())) =>
Config m -> (Handlers m -> m a) -> m a
execAgainstBucket (TestConfig -> Config m
forall (m :: * -> *). MonadThrow m => TestConfig -> Config m
mkConfig TestConfig
testConfig) Handlers m -> m a
action
testEvalAgainstBucket ::
( MonadDelay m,
MonadAsync m,
MonadFork m,
MonadMask m,
MonadTimer m,
NoThunks (m ())
) =>
TestConfig ->
(Handlers m -> m a) ->
m TestState
testEvalAgainstBucket :: forall (m :: * -> *) a.
(MonadDelay m, MonadAsync m, MonadFork m, MonadMask m,
MonadTimer m, NoThunks (m ())) =>
TestConfig -> (Handlers m -> m a) -> m TestState
testEvalAgainstBucket TestConfig
testConfig Handlers m -> m a
action =
State m -> TestState
forall (m :: * -> *). State m -> TestState
stateToTestState (State m -> TestState) -> m (State m) -> m TestState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Config m -> (Handlers m -> m a) -> m (State m)
forall (m :: * -> *) a.
(MonadDelay m, MonadAsync m, MonadFork m, MonadMask m,
MonadTimer m, NoThunks (m ())) =>
Config m -> (Handlers m -> m a) -> m (State m)
evalAgainstBucket (TestConfig -> Config m
forall (m :: * -> *). MonadThrow m => TestConfig -> Config m
mkConfig TestConfig
testConfig) Handlers m -> m a
action
ioSimProperty :: forall a. (forall s. IOSim s a) -> a
ioSimProperty :: forall a. (forall s. IOSim s a) -> a
ioSimProperty = (forall s. IOSim s a) -> a
forall a. (forall s. IOSim s a) -> a
runSimOrThrow
shouldThrow :: (MonadCatch m, Show a, Exception e, Eq e) => m a -> e -> m Property
shouldThrow :: forall (m :: * -> *) a e.
(MonadCatch m, Show a, Exception e, Eq e) =>
m a -> e -> m Property
shouldThrow m a
a e
e =
m a -> m (Either SomeException a)
forall e a. Exception e => m a -> m (Either e a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try m a
a m (Either SomeException a)
-> (Either SomeException a -> Property) -> m Property
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
Left SomeException
exn
| SomeException -> Maybe e
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exn Maybe e -> Maybe e -> Bool
forall a. Eq a => a -> a -> Bool
== e -> Maybe e
forall a. a -> Maybe a
Just e
e -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
| Bool
otherwise -> TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"Expected exception " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ e -> TestName
forall a. Show a => a -> TestName
show e
e TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ TestName
"; got exception " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeException -> TestName
forall a. Show a => a -> TestName
show SomeException
exn) Bool
False
Right a
result -> TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"Expected exception " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ e -> TestName
forall a. Show a => a -> TestName
show e
e TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ TestName
"; got " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> TestName
forall a. Show a => a -> TestName
show a
result) Bool
False
shouldEvaluateTo :: (MonadCatch m, Eq a, Show a) => m a -> a -> m Property
shouldEvaluateTo :: forall (m :: * -> *) a.
(MonadCatch m, Eq a, Show a) =>
m a -> a -> m Property
shouldEvaluateTo m a
a a
v =
m a -> m (Either SomeException a)
forall e a. Exception e => m a -> m (Either e a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try m a
a m (Either SomeException a)
-> (Either SomeException a -> Property) -> m Property
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
Right a
result
| a
result a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
v -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
| Bool
otherwise -> TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"Expected " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> TestName
forall a. Show a => a -> TestName
show a
v TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ TestName
"; got " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> TestName
forall a. Show a => a -> TestName
show a
result) Bool
False
Left (SomeException
exn :: SomeException) -> TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"Expected " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> TestName
forall a. Show a => a -> TestName
show a
v TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ TestName
"; got exception " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeException -> TestName
forall e. Exception e => e -> TestName
displayException SomeException
exn) Bool
False
prop_playABit :: Property
prop_playABit :: Property
prop_playABit =
(forall s. IOSim s Property) -> Property
forall a. (forall s. IOSim s a) -> a
ioSimProperty ((forall s. IOSim s Property) -> Property)
-> (forall s. IOSim s Property) -> Property
forall a b. (a -> b) -> a -> b
$
TestConfig
-> (Handlers (IOSim s) -> IOSim s ()) -> IOSim s TestState
forall (m :: * -> *) a.
(MonadDelay m, MonadAsync m, MonadFork m, MonadMask m,
MonadTimer m, NoThunks (m ())) =>
TestConfig -> (Handlers m -> m a) -> m TestState
testEvalAgainstBucket TestConfig
config11Throw (\Handlers (IOSim s)
handlers -> do
DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
0.5
IOSim s FillResult -> IOSim s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IOSim s FillResult -> IOSim s ())
-> IOSim s FillResult -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ Handlers (IOSim s) -> Rational -> IOSim s FillResult
forall (m :: * -> *).
(MonadMonotonicTime m, MonadSTM m) =>
Handlers m -> Rational -> m FillResult
fill' Handlers (IOSim s)
handlers Rational
67
DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
0.9
) IOSim s TestState -> TestState -> IOSim s Property
forall (m :: * -> *) a.
(MonadCatch m, Eq a, Show a) =>
m a -> a -> m Property
`shouldEvaluateTo` TestState{testLevel :: Rational
testLevel = Integer
1 Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
10, testTime :: Time
testTime = DiffTime -> Time
Time DiffTime
1.4, testPaused :: Bool
testPaused = Bool
False}
prop_playTooLong :: Property
prop_playTooLong :: Property
prop_playTooLong =
(forall s. IOSim s Property) -> Property
forall a. (forall s. IOSim s a) -> a
ioSimProperty ((forall s. IOSim s Property) -> Property)
-> (forall s. IOSim s Property) -> Property
forall a b. (a -> b) -> a -> b
$
TestConfig
-> (Handlers (IOSim s) -> IOSim s ()) -> IOSim s TestState
forall (m :: * -> *) a.
(MonadDelay m, MonadAsync m, MonadFork m, MonadMask m,
MonadTimer m, NoThunks (m ())) =>
TestConfig -> (Handlers m -> m a) -> m TestState
testEvalAgainstBucket TestConfig
config11Throw (\Handlers (IOSim s)
handlers -> do
DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
0.5
IOSim s FillResult -> IOSim s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IOSim s FillResult -> IOSim s ())
-> IOSim s FillResult -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ Handlers (IOSim s) -> Rational -> IOSim s FillResult
forall (m :: * -> *).
(MonadMonotonicTime m, MonadSTM m) =>
Handlers m -> Rational -> m FillResult
fill' Handlers (IOSim s)
handlers Rational
67
DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1.1
) IOSim s TestState -> EmptyBucket -> IOSim s Property
forall (m :: * -> *) a e.
(MonadCatch m, Show a, Exception e, Eq e) =>
m a -> e -> m Property
`shouldThrow` EmptyBucket
EmptyBucket
prop_playTooLongHarmless :: Property
prop_playTooLongHarmless :: Property
prop_playTooLongHarmless =
(forall s. IOSim s Property) -> Property
forall a. (forall s. IOSim s a) -> a
ioSimProperty ((forall s. IOSim s Property) -> Property)
-> (forall s. IOSim s Property) -> Property
forall a b. (a -> b) -> a -> b
$
TestConfig
-> (Handlers (IOSim s) -> IOSim s ()) -> IOSim s TestState
forall (m :: * -> *) a.
(MonadDelay m, MonadAsync m, MonadFork m, MonadMask m,
MonadTimer m, NoThunks (m ())) =>
TestConfig -> (Handlers m -> m a) -> m TestState
testEvalAgainstBucket TestConfig
config11Pure (\Handlers (IOSim s)
handlers -> do
DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
0.5
IOSim s FillResult -> IOSim s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IOSim s FillResult -> IOSim s ())
-> IOSim s FillResult -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ Handlers (IOSim s) -> Rational -> IOSim s FillResult
forall (m :: * -> *).
(MonadMonotonicTime m, MonadSTM m) =>
Handlers m -> Rational -> m FillResult
fill' Handlers (IOSim s)
handlers Rational
67
DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1.1
) IOSim s TestState -> TestState -> IOSim s Property
forall (m :: * -> *) a.
(MonadCatch m, Eq a, Show a) =>
m a -> a -> m Property
`shouldEvaluateTo` TestState{testLevel :: Rational
testLevel = Rational
0, testTime :: Time
testTime = DiffTime -> Time
Time DiffTime
1.6, testPaused :: Bool
testPaused = Bool
False}
prop_playWithPause :: Property
prop_playWithPause :: Property
prop_playWithPause =
(forall s. IOSim s Property) -> Property
forall a. (forall s. IOSim s a) -> a
ioSimProperty ((forall s. IOSim s Property) -> Property)
-> (forall s. IOSim s Property) -> Property
forall a b. (a -> b) -> a -> b
$
TestConfig
-> (Handlers (IOSim s) -> IOSim s ()) -> IOSim s TestState
forall (m :: * -> *) a.
(MonadDelay m, MonadAsync m, MonadFork m, MonadMask m,
MonadTimer m, NoThunks (m ())) =>
TestConfig -> (Handlers m -> m a) -> m TestState
testEvalAgainstBucket TestConfig
config11Throw (\Handlers (IOSim s)
handlers -> do
DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
0.5
Handlers (IOSim s) -> Bool -> IOSim s ()
forall (m :: * -> *).
(MonadMonotonicTime m, MonadSTM m) =>
Handlers m -> Bool -> m ()
setPaused' Handlers (IOSim s)
handlers Bool
True
DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1.5
Handlers (IOSim s) -> Bool -> IOSim s ()
forall (m :: * -> *).
(MonadMonotonicTime m, MonadSTM m) =>
Handlers m -> Bool -> m ()
setPaused' Handlers (IOSim s)
handlers Bool
False
DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
0.4
) IOSim s TestState -> TestState -> IOSim s Property
forall (m :: * -> *) a.
(MonadCatch m, Eq a, Show a) =>
m a -> a -> m Property
`shouldEvaluateTo` TestState{testLevel :: Rational
testLevel = Integer
1 Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
10, testTime :: Time
testTime = DiffTime -> Time
Time DiffTime
2.4, testPaused :: Bool
testPaused = Bool
False}
prop_playWithPauseTooLong :: Property
prop_playWithPauseTooLong :: Property
prop_playWithPauseTooLong =
(forall s. IOSim s Property) -> Property
forall a. (forall s. IOSim s a) -> a
ioSimProperty ((forall s. IOSim s Property) -> Property)
-> (forall s. IOSim s Property) -> Property
forall a b. (a -> b) -> a -> b
$
TestConfig
-> (Handlers (IOSim s) -> IOSim s ()) -> IOSim s TestState
forall (m :: * -> *) a.
(MonadDelay m, MonadAsync m, MonadFork m, MonadMask m,
MonadTimer m, NoThunks (m ())) =>
TestConfig -> (Handlers m -> m a) -> m TestState
testEvalAgainstBucket TestConfig
config11Throw (\Handlers (IOSim s)
handlers -> do
DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
0.5
Handlers (IOSim s) -> Bool -> IOSim s ()
forall (m :: * -> *).
(MonadMonotonicTime m, MonadSTM m) =>
Handlers m -> Bool -> m ()
setPaused' Handlers (IOSim s)
handlers Bool
True
DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1.5
Handlers (IOSim s) -> Bool -> IOSim s ()
forall (m :: * -> *).
(MonadMonotonicTime m, MonadSTM m) =>
Handlers m -> Bool -> m ()
setPaused' Handlers (IOSim s)
handlers Bool
False
DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
0.6
) IOSim s TestState -> EmptyBucket -> IOSim s Property
forall (m :: * -> *) a e.
(MonadCatch m, Show a, Exception e, Eq e) =>
m a -> e -> m Property
`shouldThrow` EmptyBucket
EmptyBucket
prop_noRefill :: Bool -> Capacity -> Rate -> Property
prop_noRefill :: Bool -> Capacity -> Rate -> Property
prop_noRefill Bool
tooLong capacity :: Capacity
capacity@(Capacity Rational
c) rate :: Rate
rate@(Rate Rational
r) = do
let ps :: Integer
ps =
Rational -> Integer
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Rational
c Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
r Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Integer -> Rational
forall a. Num a => Integer -> a
fromInteger Integer
picosecondsPerSecond)
Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ (if Bool
tooLong then Integer
1 else -Integer
1) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
microsecondsPerSecond
time :: DiffTime
time = Integer -> DiffTime
picosecondsToDiffTime Integer
ps
level :: Rational
level = Rational
c Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- (Integer
ps Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
picosecondsPerSecond) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
r
if Bool
tooLong
then
(forall s. IOSim s Property) -> Property
forall a. (forall s. IOSim s a) -> a
ioSimProperty ((forall s. IOSim s Property) -> Property)
-> (forall s. IOSim s Property) -> Property
forall a b. (a -> b) -> a -> b
$
TestConfig
-> (Handlers (IOSim s) -> IOSim s ()) -> IOSim s TestState
forall (m :: * -> *) a.
(MonadDelay m, MonadAsync m, MonadFork m, MonadMask m,
MonadTimer m, NoThunks (m ())) =>
TestConfig -> (Handlers m -> m a) -> m TestState
testEvalAgainstBucket (Capacity -> Rate -> TestConfig
configThrow Capacity
capacity Rate
rate) (\Handlers (IOSim s)
_ -> DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
time)
IOSim s TestState -> EmptyBucket -> IOSim s Property
forall (m :: * -> *) a e.
(MonadCatch m, Show a, Exception e, Eq e) =>
m a -> e -> m Property
`shouldThrow` EmptyBucket
EmptyBucket
else
(forall s. IOSim s Property) -> Property
forall a. (forall s. IOSim s a) -> a
ioSimProperty ((forall s. IOSim s Property) -> Property)
-> (forall s. IOSim s Property) -> Property
forall a b. (a -> b) -> a -> b
$
TestConfig
-> (Handlers (IOSim s) -> IOSim s ()) -> IOSim s TestState
forall (m :: * -> *) a.
(MonadDelay m, MonadAsync m, MonadFork m, MonadMask m,
MonadTimer m, NoThunks (m ())) =>
TestConfig -> (Handlers m -> m a) -> m TestState
testEvalAgainstBucket (Capacity -> Rate -> TestConfig
configThrow Capacity
capacity Rate
rate) (\Handlers (IOSim s)
_ -> DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
time)
IOSim s TestState -> TestState -> IOSim s Property
forall (m :: * -> *) a.
(MonadCatch m, Eq a, Show a) =>
m a -> a -> m Property
`shouldEvaluateTo` TestState {testLevel :: Rational
testLevel = Rational
level, testTime :: Time
testTime = DiffTime -> Time
Time DiffTime
time, testPaused :: Bool
testPaused = Bool
False}
data NoPlumberException = NoPlumberException
deriving (NoPlumberException -> NoPlumberException -> Bool
(NoPlumberException -> NoPlumberException -> Bool)
-> (NoPlumberException -> NoPlumberException -> Bool)
-> Eq NoPlumberException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NoPlumberException -> NoPlumberException -> Bool
== :: NoPlumberException -> NoPlumberException -> Bool
$c/= :: NoPlumberException -> NoPlumberException -> Bool
/= :: NoPlumberException -> NoPlumberException -> Bool
Eq, Int -> NoPlumberException -> ShowS
[NoPlumberException] -> ShowS
NoPlumberException -> TestName
(Int -> NoPlumberException -> ShowS)
-> (NoPlumberException -> TestName)
-> ([NoPlumberException] -> ShowS)
-> Show NoPlumberException
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NoPlumberException -> ShowS
showsPrec :: Int -> NoPlumberException -> ShowS
$cshow :: NoPlumberException -> TestName
show :: NoPlumberException -> TestName
$cshowList :: [NoPlumberException] -> ShowS
showList :: [NoPlumberException] -> ShowS
Show)
instance Exception NoPlumberException
prop_propagateExceptions :: Property
prop_propagateExceptions :: Property
prop_propagateExceptions =
(forall s. IOSim s Property) -> Property
forall a. (forall s. IOSim s a) -> a
ioSimProperty ((forall s. IOSim s Property) -> Property)
-> (forall s. IOSim s Property) -> Property
forall a b. (a -> b) -> a -> b
$
TestConfig
-> (Handlers (IOSim s) -> IOSim s Any) -> IOSim s TestState
forall (m :: * -> *) a.
(MonadDelay m, MonadAsync m, MonadFork m, MonadMask m,
MonadTimer m, NoThunks (m ())) =>
TestConfig -> (Handlers m -> m a) -> m TestState
testEvalAgainstBucket TestConfig
config11Throw (\Handlers (IOSim s)
_ -> NoPlumberException -> IOSim s Any
forall e a. Exception e => e -> IOSim s a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO NoPlumberException
NoPlumberException)
IOSim s TestState -> NoPlumberException -> IOSim s Property
forall (m :: * -> *) a e.
(MonadCatch m, Show a, Exception e, Eq e) =>
m a -> e -> m Property
`shouldThrow`
NoPlumberException
NoPlumberException
prop_propagateExceptionsIO :: Property
prop_propagateExceptionsIO :: Property
prop_propagateExceptionsIO =
IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$
TestConfig -> (Handlers IO -> IO Any) -> IO TestState
forall (m :: * -> *) a.
(MonadDelay m, MonadAsync m, MonadFork m, MonadMask m,
MonadTimer m, NoThunks (m ())) =>
TestConfig -> (Handlers m -> m a) -> m TestState
testEvalAgainstBucket TestConfig
config11Throw (\Handlers IO
_ -> NoPlumberException -> IO Any
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO NoPlumberException
NoPlumberException)
IO TestState -> NoPlumberException -> IO Property
forall (m :: * -> *) a e.
(MonadCatch m, Show a, Exception e, Eq e) =>
m a -> e -> m Property
`shouldThrow`
NoPlumberException
NoPlumberException
prop_catchException :: Property
prop_catchException :: Property
prop_catchException =
(forall s. IOSim s Property) -> Property
forall a. (forall s. IOSim s a) -> a
ioSimProperty ((forall s. IOSim s Property) -> Property)
-> (forall s. IOSim s Property) -> Property
forall a b. (a -> b) -> a -> b
$
TestConfig
-> (Handlers (IOSim s) -> IOSim s (Either EmptyBucket ()))
-> IOSim s (Either EmptyBucket ())
forall (m :: * -> *) a.
(MonadDelay m, MonadAsync m, MonadFork m, MonadMask m,
MonadTimer m, NoThunks (m ())) =>
TestConfig -> (Handlers m -> m a) -> m a
testExecAgainstBucket TestConfig
config11Throw (\Handlers (IOSim s)
_ -> IOSim s () -> IOSim s (Either EmptyBucket ())
forall e a. Exception e => IOSim s a -> IOSim s (Either e a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (IOSim s () -> IOSim s (Either EmptyBucket ()))
-> IOSim s () -> IOSim s (Either EmptyBucket ())
forall a b. (a -> b) -> a -> b
$ DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1000)
IOSim s (Either EmptyBucket ())
-> Either EmptyBucket () -> IOSim s Property
forall (m :: * -> *) a.
(MonadCatch m, Eq a, Show a) =>
m a -> a -> m Property
`shouldEvaluateTo`
EmptyBucket -> Either EmptyBucket ()
forall a b. a -> Either a b
Left EmptyBucket
EmptyBucket
data Action
= Wait DiffTime
| Fill Rational
| SetPaused Bool
|
SetConfigWait TestConfig DiffTime
deriving (Action -> Action -> Bool
(Action -> Action -> Bool)
-> (Action -> Action -> Bool) -> Eq Action
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Action -> Action -> Bool
== :: Action -> Action -> Bool
$c/= :: Action -> Action -> Bool
/= :: Action -> Action -> Bool
Eq, Int -> Action -> ShowS
[Action] -> ShowS
Action -> TestName
(Int -> Action -> ShowS)
-> (Action -> TestName) -> ([Action] -> ShowS) -> Show Action
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Action -> ShowS
showsPrec :: Int -> Action -> ShowS
$cshow :: Action -> TestName
show :: Action -> TestName
$cshowList :: [Action] -> ShowS
showList :: [Action] -> ShowS
Show)
genAction :: Gen Action
genAction :: Gen Action
genAction =
[(Int, Gen Action)] -> Gen Action
forall a. [(Int, Gen a)] -> Gen a
frequency
[ (Int
1, DiffTime -> Action
Wait (DiffTime -> Action) -> Gen DiffTime -> Gen Action
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen DiffTime
genDelay),
(Int
1, Rational -> Action
Fill (Rational -> Action) -> Gen Rational -> Gen Action
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Int) -> Gen Rational -> Gen Rational
forall a. (Int -> Int) -> Gen a -> Gen a
scale (Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1_000_000_000_000_000) (Gen Rational
forall a. Arbitrary a => Gen a
arbitrary Gen Rational -> (Rational -> Bool) -> Gen Rational
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
>= Rational
0))),
(Int
1, Bool -> Action
SetPaused (Bool -> Action) -> Gen Bool -> Gen Action
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Bool
forall a. Arbitrary a => Gen a
arbitrary),
(Int
1, TestConfig -> DiffTime -> Action
SetConfigWait (TestConfig -> DiffTime -> Action)
-> Gen TestConfig -> Gen (DiffTime -> Action)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen TestConfig
forall a. Arbitrary a => Gen a
arbitrary Gen (DiffTime -> Action) -> Gen DiffTime -> Gen Action
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen DiffTime
genDelay)
]
where
genDelay :: Gen DiffTime
genDelay = Integer -> DiffTime
picosecondsToDiffTime (Integer -> DiffTime) -> Gen Integer -> Gen DiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Int) -> Gen Integer -> Gen Integer
forall a. (Int -> Int) -> Gen a -> Gen a
scale (Int -> Int -> Int
forall a. Num a => a -> a -> a
* Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
picosecondsPerSecond) (Gen Integer
forall a. Arbitrary a => Gen a
arbitrary Gen Integer -> (Integer -> Bool) -> Gen Integer
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0))
applyActions :: (MonadDelay m, MonadThrow m, MonadSTM m) => Handlers m -> [Action] -> m ()
applyActions :: forall (m :: * -> *).
(MonadDelay m, MonadThrow m, MonadSTM m) =>
Handlers m -> [Action] -> m ()
applyActions Handlers m
handlers = (Action -> m ()) -> [Action] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Action -> m ()) -> [Action] -> m ())
-> (Action -> m ()) -> [Action] -> m ()
forall a b. (a -> b) -> a -> b
$ \case
Wait DiffTime
t -> DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
t
Fill Rational
t -> m FillResult -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m FillResult -> m ()) -> m FillResult -> m ()
forall a b. (a -> b) -> a -> b
$ Handlers m -> Rational -> m FillResult
forall (m :: * -> *).
(MonadMonotonicTime m, MonadSTM m) =>
Handlers m -> Rational -> m FillResult
fill' Handlers m
handlers Rational
t
SetPaused Bool
p -> Handlers m -> Bool -> m ()
forall (m :: * -> *).
(MonadMonotonicTime m, MonadSTM m) =>
Handlers m -> Bool -> m ()
setPaused' Handlers m
handlers Bool
p
SetConfigWait TestConfig
cfg DiffTime
t -> do
Handlers m
-> ((Rational, Config m) -> (Rational, Config m)) -> m ()
forall (m :: * -> *).
(MonadMonotonicTime m, MonadSTM m) =>
Handlers m
-> ((Rational, Config m) -> (Rational, Config m)) -> m ()
updateConfig' Handlers m
handlers (((Rational, Config m) -> (Rational, Config m)) -> m ())
-> ((Rational, Config m) -> (Rational, Config m)) -> m ()
forall a b. (a -> b) -> a -> b
$ (\(Rational
l, Config m
_) -> (Rational
l, TestConfig -> Config m
forall (m :: * -> *). MonadThrow m => TestConfig -> Config m
mkConfig TestConfig
cfg))
DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
t
modelActions :: TestConfig -> [Action] -> Either EmptyBucket TestState
modelActions :: TestConfig -> [Action] -> Either EmptyBucket TestState
modelActions TestConfig
testConfig =
((TestConfig, TestState) -> TestState
forall a b. (a, b) -> b
snd ((TestConfig, TestState) -> TestState)
-> Either EmptyBucket (TestConfig, TestState)
-> Either EmptyBucket TestState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Either EmptyBucket (TestConfig, TestState)
-> Either EmptyBucket TestState)
-> ([Action] -> Either EmptyBucket (TestConfig, TestState))
-> [Action]
-> Either EmptyBucket TestState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TestConfig, TestState)
-> Action -> Either EmptyBucket (TestConfig, TestState))
-> (TestConfig, TestState)
-> [Action]
-> Either EmptyBucket (TestConfig, TestState)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (TestConfig, TestState)
-> Action -> Either EmptyBucket (TestConfig, TestState)
go (TestConfig
testConfig, TestState {testLevel :: Rational
testLevel = TestConfig -> Rational
testCapacity TestConfig
testConfig, testTime :: Time
testTime = DiffTime -> Time
Time DiffTime
0, testPaused :: Bool
testPaused = Bool
False})
where
go :: (TestConfig, TestState) -> Action -> Either EmptyBucket (TestConfig, TestState)
go :: (TestConfig, TestState)
-> Action -> Either EmptyBucket (TestConfig, TestState)
go (config :: TestConfig
config@TestConfig {Rational
testCapacity :: TestConfig -> Rational
testCapacity :: Rational
testCapacity, Rational
testRate :: TestConfig -> Rational
testRate :: Rational
testRate, Bool
testThrowOnEmpty :: TestConfig -> Bool
testThrowOnEmpty :: Bool
testThrowOnEmpty}, state :: TestState
state@TestState {Time
testTime :: TestState -> Time
testTime :: Time
testTime, Rational
testLevel :: TestState -> Rational
testLevel :: Rational
testLevel, Bool
testPaused :: TestState -> Bool
testPaused :: Bool
testPaused}) = \case
Fill Rational
t ->
(TestConfig, TestState)
-> Either EmptyBucket (TestConfig, TestState)
forall a b. b -> Either a b
Right (TestConfig
config, TestState
state {testLevel = clamp (0, testCapacity) (testLevel + t)})
Wait DiffTime
t ->
let newTime :: Time
newTime = DiffTime -> Time -> Time
addTime DiffTime
t Time
testTime
newLevel :: Rational
newLevel =
if Bool
testPaused
then Rational
testLevel
else (Rational, Rational) -> Rational -> Rational
forall a. Ord a => (a, a) -> a -> a
clamp (Rational
0, Rational
testCapacity) (Rational
testLevel Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- DiffTime -> Rational
diffTimeToSecondsRational DiffTime
t Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
testRate)
in if Rational
newLevel Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
<= Rational
0 Bool -> Bool -> Bool
&& Bool
testThrowOnEmpty
then EmptyBucket -> Either EmptyBucket (TestConfig, TestState)
forall a b. a -> Either a b
Left EmptyBucket
EmptyBucket
else (TestConfig, TestState)
-> Either EmptyBucket (TestConfig, TestState)
forall a b. b -> Either a b
Right (TestConfig
config, TestState
state {testTime = newTime, testLevel = newLevel})
SetPaused Bool
newPaused ->
(TestConfig, TestState)
-> Either EmptyBucket (TestConfig, TestState)
forall a b. b -> Either a b
Right (TestConfig
config, TestState
state {testPaused = newPaused})
SetConfigWait newConfig :: TestConfig
newConfig@TestConfig {testCapacity :: TestConfig -> Rational
testCapacity = Rational
newTestCapacity} DiffTime
t ->
(TestConfig, TestState)
-> Action -> Either EmptyBucket (TestConfig, TestState)
go (TestConfig
newConfig, TestState
state {testLevel = clamp (0, newTestCapacity) testLevel}) (DiffTime -> Action
Wait DiffTime
t)
prop_random :: Property
prop_random :: Property
prop_random =
Gen (TestConfig, [Action])
-> ((TestConfig, [Action]) -> [(TestConfig, [Action])])
-> ((TestConfig, [Action]) -> Property)
-> Property
forall prop a.
Testable prop =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrinkBlind
(Gen TestConfig -> Gen [Action] -> Gen (TestConfig, [Action])
forall a b. Gen a -> Gen b -> Gen (a, b)
forall (f :: * -> * -> *) a b.
Arbitrary2 f =>
Gen a -> Gen b -> Gen (f a b)
liftArbitrary2 Gen TestConfig
forall a. Arbitrary a => Gen a
arbitrary (Gen Action -> Gen [Action]
forall a. Gen a -> Gen [a]
listOf1 Gen Action
genAction))
(([Action] -> [[Action]])
-> (TestConfig, [Action]) -> [(TestConfig, [Action])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> (TestConfig, a) -> f (TestConfig, b)
traverse ((Action -> [Action]) -> [Action] -> [[Action]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList ([Action] -> Action -> [Action]
forall a b. a -> b -> a
const [])))
(((TestConfig, [Action]) -> Property) -> Property)
-> ((TestConfig, [Action]) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(TestConfig
testConfig, [Action]
actions) ->
let result :: Either EmptyBucket TestState
result =
(forall s. IOSim s (Either EmptyBucket TestState))
-> Either EmptyBucket TestState
forall a. (forall s. IOSim s a) -> a
runSimOrThrow
( IOSim s TestState -> IOSim s (Either EmptyBucket TestState)
forall e a. Exception e => IOSim s a -> IOSim s (Either e a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (IOSim s TestState -> IOSim s (Either EmptyBucket TestState))
-> IOSim s TestState -> IOSim s (Either EmptyBucket TestState)
forall a b. (a -> b) -> a -> b
$
TestConfig
-> (Handlers (IOSim s) -> IOSim s ()) -> IOSim s TestState
forall (m :: * -> *) a.
(MonadDelay m, MonadAsync m, MonadFork m, MonadMask m,
MonadTimer m, NoThunks (m ())) =>
TestConfig -> (Handlers m -> m a) -> m TestState
testEvalAgainstBucket TestConfig
testConfig ((Handlers (IOSim s) -> IOSim s ()) -> IOSim s TestState)
-> (Handlers (IOSim s) -> IOSim s ()) -> IOSim s TestState
forall a b. (a -> b) -> a -> b
$
(Handlers (IOSim s) -> [Action] -> IOSim s ())
-> [Action] -> Handlers (IOSim s) -> IOSim s ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Handlers (IOSim s) -> [Action] -> IOSim s ()
forall (m :: * -> *).
(MonadDelay m, MonadThrow m, MonadSTM m) =>
Handlers m -> [Action] -> m ()
applyActions [Action]
actions
)
modelResult :: Either EmptyBucket TestState
modelResult = TestConfig -> [Action] -> Either EmptyBucket TestState
modelActions TestConfig
testConfig [Action]
actions
nbActions :: Int
nbActions = [Action] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Action]
actions
in Bool -> TestName -> Property -> Property
forall prop. Testable prop => Bool -> TestName -> prop -> Property
classify (Either EmptyBucket TestState -> Bool
forall a b. Either a b -> Bool
isLeft Either EmptyBucket TestState
modelResult) TestName
"bucket finished empty" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
Bool -> TestName -> Property -> Property
forall prop. Testable prop => Bool -> TestName -> prop -> Property
classify (Either EmptyBucket TestState -> Bool
forall a b. Either a b -> Bool
isRight Either EmptyBucket TestState
modelResult) TestName
"bucket finished non-empty" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
Bool -> TestName -> Property -> Property
forall prop. Testable prop => Bool -> TestName -> prop -> Property
classify (Int
nbActions Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
10) TestName
"<= 10 actions" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
Bool -> TestName -> Property -> Property
forall prop. Testable prop => Bool -> TestName -> prop -> Property
classify (Int
10 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
nbActions Bool -> Bool -> Bool
&& Int
nbActions Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
20) TestName
"11-20 actions" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
Bool -> TestName -> Property -> Property
forall prop. Testable prop => Bool -> TestName -> prop -> Property
classify (Int
20 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
nbActions Bool -> Bool -> Bool
&& Int
nbActions Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
50) TestName
"21-50 actions" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
Bool -> TestName -> Property -> Property
forall prop. Testable prop => Bool -> TestName -> prop -> Property
classify (Int
50 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
nbActions) TestName
"> 50 actions" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"Config: " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ TestConfig -> TestName
forall a. Show a => a -> TestName
show TestConfig
testConfig) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"Actions:\n" TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ ([TestName] -> TestName
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([TestName] -> TestName) -> [TestName] -> TestName
forall a b. (a -> b) -> a -> b
$ TestName -> [TestName] -> [TestName]
forall a. a -> [a] -> [a]
intersperse TestName
"\n" ([TestName] -> [TestName]) -> [TestName] -> [TestName]
forall a b. (a -> b) -> a -> b
$ (Action -> TestName) -> [Action] -> [TestName]
forall a b. (a -> b) -> [a] -> [b]
map ((TestName
" - " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> (Action -> TestName) -> Action -> TestName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Action -> TestName
forall a. Show a => a -> TestName
show) [Action]
actions)) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"Result: " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ Either EmptyBucket TestState -> TestName
forall a. Show a => a -> TestName
show Either EmptyBucket TestState
result) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"Model: " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ Either EmptyBucket TestState -> TestName
forall a. Show a => a -> TestName
show Either EmptyBucket TestState
modelResult) (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$
Either EmptyBucket TestState
result Either EmptyBucket TestState
-> Either EmptyBucket TestState -> Bool
forall a. Eq a => a -> a -> Bool
== Either EmptyBucket TestState
modelResult
clamp :: Ord a => (a, a) -> a -> a
clamp :: forall a. Ord a => (a, a) -> a -> a
clamp (a
low, a
high) a
x = a -> a -> a
forall a. Ord a => a -> a -> a
min a
high (a -> a -> a
forall a. Ord a => a -> a -> a
max a
low a
x)