{-# LANGUAGE CPP                        #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TupleSections              #-}

module Test.Ouroboros.Network.Utils
  ( -- * Arbitrary Delays
    Delay (..)
  , genDelayWithPrecision
  , SmallDelay (..)
    -- * Set properties
  , isSubsetProperty
  , disjointSetsProperty
    -- * QuickCheck Utils
  , arbitrarySubset
  , shrinkVector
  , ShrinkCarefully (..)
  , prop_shrink_nonequal
  , prop_shrink_valid
    -- * Tracing Utils
  , WithName (..)
  , WithTime (..)
  , tracerWithName
  , tracerWithTime
  , tracerWithTimeName
  , swapTimeWithName
  , swapNameWithTime
  , splitWithNameTrace
    -- * Tracers
  , debugTracer
  , debugTracerG
  , sayTracer
    -- * Tasty Utils
  , nightlyTest
  , ignoreTest
    -- * Auxiliary functions
  , renderRanges
  ) where

import GHC.Real

import Control.Monad.Class.MonadSay
import Control.Monad.Class.MonadTime.SI
import Control.Monad.IOSim (IOSim, traceM)
import Control.Tracer (Contravariant (contramap), Tracer (..), contramapM)

import Data.Bitraversable (bimapAccumR)
import Data.List (delete)
import Data.List.Trace (Trace)
import Data.List.Trace qualified as Trace
import Data.Map qualified as Map
import Data.Maybe (fromJust, isJust)
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Typeable (Typeable)
import Text.Pretty.Simple (pPrint)

import Debug.Trace (traceShowM)
import Test.QuickCheck
import Test.Tasty (TestTree)
import Test.Tasty.ExpectedFailure (ignoreTest)


newtype Delay = Delay { Delay -> DiffTime
getDelay :: DiffTime }
  deriving Int -> Delay -> ShowS
[Delay] -> ShowS
Delay -> String
(Int -> Delay -> ShowS)
-> (Delay -> String) -> ([Delay] -> ShowS) -> Show Delay
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Delay -> ShowS
showsPrec :: Int -> Delay -> ShowS
$cshow :: Delay -> String
show :: Delay -> String
$cshowList :: [Delay] -> ShowS
showList :: [Delay] -> ShowS
Show
  deriving newtype (Delay -> Delay -> Bool
(Delay -> Delay -> Bool) -> (Delay -> Delay -> Bool) -> Eq Delay
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Delay -> Delay -> Bool
== :: Delay -> Delay -> Bool
$c/= :: Delay -> Delay -> Bool
/= :: Delay -> Delay -> Bool
Eq, Eq Delay
Eq Delay =>
(Delay -> Delay -> Ordering)
-> (Delay -> Delay -> Bool)
-> (Delay -> Delay -> Bool)
-> (Delay -> Delay -> Bool)
-> (Delay -> Delay -> Bool)
-> (Delay -> Delay -> Delay)
-> (Delay -> Delay -> Delay)
-> Ord Delay
Delay -> Delay -> Bool
Delay -> Delay -> Ordering
Delay -> Delay -> Delay
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Delay -> Delay -> Ordering
compare :: Delay -> Delay -> Ordering
$c< :: Delay -> Delay -> Bool
< :: Delay -> Delay -> Bool
$c<= :: Delay -> Delay -> Bool
<= :: Delay -> Delay -> Bool
$c> :: Delay -> Delay -> Bool
> :: Delay -> Delay -> Bool
$c>= :: Delay -> Delay -> Bool
>= :: Delay -> Delay -> Bool
$cmax :: Delay -> Delay -> Delay
max :: Delay -> Delay -> Delay
$cmin :: Delay -> Delay -> Delay
min :: Delay -> Delay -> Delay
Ord, Integer -> Delay
Delay -> Delay
Delay -> Delay -> Delay
(Delay -> Delay -> Delay)
-> (Delay -> Delay -> Delay)
-> (Delay -> Delay -> Delay)
-> (Delay -> Delay)
-> (Delay -> Delay)
-> (Delay -> Delay)
-> (Integer -> Delay)
-> Num Delay
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: Delay -> Delay -> Delay
+ :: Delay -> Delay -> Delay
$c- :: Delay -> Delay -> Delay
- :: Delay -> Delay -> Delay
$c* :: Delay -> Delay -> Delay
* :: Delay -> Delay -> Delay
$cnegate :: Delay -> Delay
negate :: Delay -> Delay
$cabs :: Delay -> Delay
abs :: Delay -> Delay
$csignum :: Delay -> Delay
signum :: Delay -> Delay
$cfromInteger :: Integer -> Delay
fromInteger :: Integer -> Delay
Num, Num Delay
Num Delay =>
(Delay -> Delay -> Delay)
-> (Delay -> Delay) -> (Rational -> Delay) -> Fractional Delay
Rational -> Delay
Delay -> Delay
Delay -> Delay -> Delay
forall a.
Num a =>
(a -> a -> a) -> (a -> a) -> (Rational -> a) -> Fractional a
$c/ :: Delay -> Delay -> Delay
/ :: Delay -> Delay -> Delay
$crecip :: Delay -> Delay
recip :: Delay -> Delay
$cfromRational :: Rational -> Delay
fromRational :: Rational -> Delay
Fractional, Num Delay
Ord Delay
(Num Delay, Ord Delay) => (Delay -> Rational) -> Real Delay
Delay -> Rational
forall a. (Num a, Ord a) => (a -> Rational) -> Real a
$ctoRational :: Delay -> Rational
toRational :: Delay -> Rational
Real)


genDelayWithPrecision :: Integer -> Gen DiffTime
genDelayWithPrecision :: Integer -> Gen DiffTime
genDelayWithPrecision Integer
precision =
    (Int -> Gen DiffTime) -> Gen DiffTime
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen DiffTime) -> Gen DiffTime)
-> (Int -> Gen DiffTime) -> Gen DiffTime
forall a b. (a -> b) -> a -> b
$ \Int
n -> do
      b <- (Integer, Integer) -> Gen Integer
chooseInteger (Integer
1, Integer
precision)
      a <- chooseInteger (0, toInteger n * b)
      return (fromRational (a % b))

-- | This needs to be small, as we are using real time limits in block-fetch
-- examples.
--
instance Arbitrary Delay where
    arbitrary :: Gen Delay
arbitrary = DiffTime -> Delay
Delay (DiffTime -> Delay) -> Gen DiffTime -> Gen Delay
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer -> Gen DiffTime
genDelayWithPrecision Integer
10
    shrink :: Delay -> [Delay]
shrink Delay
delay | Delay
delay Delay -> Delay -> Bool
forall a. Ord a => a -> a -> Bool
> Delay
0.1 =
      (Delay -> Bool) -> [Delay] -> [Delay]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Delay -> Delay -> Bool
forall a. Ord a => a -> a -> Bool
>= Delay
0.1) ([Delay] -> [Delay]) -> (Delay -> [Delay]) -> Delay -> [Delay]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rational -> Delay) -> [Rational] -> [Delay]
forall a b. (a -> b) -> [a] -> [b]
map Rational -> Delay
forall a. Fractional a => Rational -> a
fromRational ([Rational] -> [Delay])
-> (Delay -> [Rational]) -> Delay -> [Delay]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> [Rational]
forall a. Arbitrary a => a -> [a]
shrink (Rational -> [Rational])
-> (Delay -> Rational) -> Delay -> [Rational]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Delay -> Rational
forall a. Real a => a -> Rational
toRational (Delay -> [Delay]) -> Delay -> [Delay]
forall a b. (a -> b) -> a -> b
$ Delay
delay
    shrink Delay
_delay = []


newtype SmallDelay = SmallDelay { SmallDelay -> DiffTime
getSmallDelay :: DiffTime }
  deriving Int -> SmallDelay -> ShowS
[SmallDelay] -> ShowS
SmallDelay -> String
(Int -> SmallDelay -> ShowS)
-> (SmallDelay -> String)
-> ([SmallDelay] -> ShowS)
-> Show SmallDelay
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SmallDelay -> ShowS
showsPrec :: Int -> SmallDelay -> ShowS
$cshow :: SmallDelay -> String
show :: SmallDelay -> String
$cshowList :: [SmallDelay] -> ShowS
showList :: [SmallDelay] -> ShowS
Show
  deriving newtype (SmallDelay -> SmallDelay -> Bool
(SmallDelay -> SmallDelay -> Bool)
-> (SmallDelay -> SmallDelay -> Bool) -> Eq SmallDelay
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SmallDelay -> SmallDelay -> Bool
== :: SmallDelay -> SmallDelay -> Bool
$c/= :: SmallDelay -> SmallDelay -> Bool
/= :: SmallDelay -> SmallDelay -> Bool
Eq, Eq SmallDelay
Eq SmallDelay =>
(SmallDelay -> SmallDelay -> Ordering)
-> (SmallDelay -> SmallDelay -> Bool)
-> (SmallDelay -> SmallDelay -> Bool)
-> (SmallDelay -> SmallDelay -> Bool)
-> (SmallDelay -> SmallDelay -> Bool)
-> (SmallDelay -> SmallDelay -> SmallDelay)
-> (SmallDelay -> SmallDelay -> SmallDelay)
-> Ord SmallDelay
SmallDelay -> SmallDelay -> Bool
SmallDelay -> SmallDelay -> Ordering
SmallDelay -> SmallDelay -> SmallDelay
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SmallDelay -> SmallDelay -> Ordering
compare :: SmallDelay -> SmallDelay -> Ordering
$c< :: SmallDelay -> SmallDelay -> Bool
< :: SmallDelay -> SmallDelay -> Bool
$c<= :: SmallDelay -> SmallDelay -> Bool
<= :: SmallDelay -> SmallDelay -> Bool
$c> :: SmallDelay -> SmallDelay -> Bool
> :: SmallDelay -> SmallDelay -> Bool
$c>= :: SmallDelay -> SmallDelay -> Bool
>= :: SmallDelay -> SmallDelay -> Bool
$cmax :: SmallDelay -> SmallDelay -> SmallDelay
max :: SmallDelay -> SmallDelay -> SmallDelay
$cmin :: SmallDelay -> SmallDelay -> SmallDelay
min :: SmallDelay -> SmallDelay -> SmallDelay
Ord, Integer -> SmallDelay
SmallDelay -> SmallDelay
SmallDelay -> SmallDelay -> SmallDelay
(SmallDelay -> SmallDelay -> SmallDelay)
-> (SmallDelay -> SmallDelay -> SmallDelay)
-> (SmallDelay -> SmallDelay -> SmallDelay)
-> (SmallDelay -> SmallDelay)
-> (SmallDelay -> SmallDelay)
-> (SmallDelay -> SmallDelay)
-> (Integer -> SmallDelay)
-> Num SmallDelay
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: SmallDelay -> SmallDelay -> SmallDelay
+ :: SmallDelay -> SmallDelay -> SmallDelay
$c- :: SmallDelay -> SmallDelay -> SmallDelay
- :: SmallDelay -> SmallDelay -> SmallDelay
$c* :: SmallDelay -> SmallDelay -> SmallDelay
* :: SmallDelay -> SmallDelay -> SmallDelay
$cnegate :: SmallDelay -> SmallDelay
negate :: SmallDelay -> SmallDelay
$cabs :: SmallDelay -> SmallDelay
abs :: SmallDelay -> SmallDelay
$csignum :: SmallDelay -> SmallDelay
signum :: SmallDelay -> SmallDelay
$cfromInteger :: Integer -> SmallDelay
fromInteger :: Integer -> SmallDelay
Num, Num SmallDelay
Num SmallDelay =>
(SmallDelay -> SmallDelay -> SmallDelay)
-> (SmallDelay -> SmallDelay)
-> (Rational -> SmallDelay)
-> Fractional SmallDelay
Rational -> SmallDelay
SmallDelay -> SmallDelay
SmallDelay -> SmallDelay -> SmallDelay
forall a.
Num a =>
(a -> a -> a) -> (a -> a) -> (Rational -> a) -> Fractional a
$c/ :: SmallDelay -> SmallDelay -> SmallDelay
/ :: SmallDelay -> SmallDelay -> SmallDelay
$crecip :: SmallDelay -> SmallDelay
recip :: SmallDelay -> SmallDelay
$cfromRational :: Rational -> SmallDelay
fromRational :: Rational -> SmallDelay
Fractional, Num SmallDelay
Ord SmallDelay
(Num SmallDelay, Ord SmallDelay) =>
(SmallDelay -> Rational) -> Real SmallDelay
SmallDelay -> Rational
forall a. (Num a, Ord a) => (a -> Rational) -> Real a
$ctoRational :: SmallDelay -> Rational
toRational :: SmallDelay -> Rational
Real)

instance Arbitrary SmallDelay where
    arbitrary :: Gen SmallDelay
arbitrary = Int -> Gen SmallDelay -> Gen SmallDelay
forall a. HasCallStack => Int -> Gen a -> Gen a
resize Int
5 (Gen SmallDelay -> Gen SmallDelay)
-> Gen SmallDelay -> Gen SmallDelay
forall a b. (a -> b) -> a -> b
$ DiffTime -> SmallDelay
SmallDelay (DiffTime -> SmallDelay)
-> (Delay -> DiffTime) -> Delay -> SmallDelay
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Delay -> DiffTime
getDelay (Delay -> SmallDelay) -> Gen Delay -> Gen SmallDelay
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Delay -> (Delay -> Bool) -> Gen Delay
forall a. Gen a -> (a -> Bool) -> Gen a
suchThat Gen Delay
forall a. Arbitrary a => Gen a
arbitrary (\(Delay DiffTime
d ) -> DiffTime
d DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< DiffTime
5)
    shrink :: SmallDelay -> [SmallDelay]
shrink SmallDelay
delay | SmallDelay
delay SmallDelay -> SmallDelay -> Bool
forall a. Ord a => a -> a -> Bool
> SmallDelay
0.1 =
      (SmallDelay -> Bool) -> [SmallDelay] -> [SmallDelay]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (SmallDelay -> SmallDelay -> Bool
forall a. Ord a => a -> a -> Bool
>= SmallDelay
0.1) ([SmallDelay] -> [SmallDelay])
-> (SmallDelay -> [SmallDelay]) -> SmallDelay -> [SmallDelay]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rational -> SmallDelay) -> [Rational] -> [SmallDelay]
forall a b. (a -> b) -> [a] -> [b]
map Rational -> SmallDelay
forall a. Fractional a => Rational -> a
fromRational ([Rational] -> [SmallDelay])
-> (SmallDelay -> [Rational]) -> SmallDelay -> [SmallDelay]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> [Rational]
forall a. Arbitrary a => a -> [a]
shrink (Rational -> [Rational])
-> (SmallDelay -> Rational) -> SmallDelay -> [Rational]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SmallDelay -> Rational
forall a. Real a => a -> Rational
toRational (SmallDelay -> [SmallDelay]) -> SmallDelay -> [SmallDelay]
forall a b. (a -> b) -> a -> b
$ SmallDelay
delay
    shrink SmallDelay
_delay = []

-- | Pick a subset of a set, using a 50:50 chance for each set element.
--
arbitrarySubset :: Ord a => Set a -> Gen (Set a)
arbitrarySubset :: forall a. Ord a => Set a -> Gen (Set a)
arbitrarySubset Set a
s = do
    picks <- Int -> Gen Bool -> Gen [Bool]
forall a. Int -> Gen a -> Gen [a]
vectorOf (Set a -> Int
forall a. Set a -> Int
Set.size Set a
s) (Gen Bool
forall a. Arbitrary a => Gen a
arbitrary :: Gen Bool)
    let s' = [a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList
           ([a] -> Set a) -> (Set a -> [a]) -> Set a -> Set a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Bool, a) -> a) -> [(Bool, a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (Bool, a) -> a
forall a b. (a, b) -> b
snd
           ([(Bool, a)] -> [a]) -> (Set a -> [(Bool, a)]) -> Set a -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Bool, a) -> Bool) -> [(Bool, a)] -> [(Bool, a)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool, a) -> Bool
forall a b. (a, b) -> a
fst
           ([(Bool, a)] -> [(Bool, a)])
-> (Set a -> [(Bool, a)]) -> Set a -> [(Bool, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Bool] -> [a] -> [(Bool, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Bool]
picks
           ([a] -> [(Bool, a)]) -> (Set a -> [a]) -> Set a -> [(Bool, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set a -> [a]
forall a. Set a -> [a]
Set.toList
           (Set a -> Set a) -> Set a -> Set a
forall a b. (a -> b) -> a -> b
$ Set a
s
    return s'


-- | Like 'shrinkList' but only shrink the elems, don't drop elements.
--
-- Useful when you want a custom strategy for dropping elements.
--
shrinkVector :: (a -> [a]) -> [a] -> [[a]]
shrinkVector :: forall a. (a -> [a]) -> [a] -> [[a]]
shrinkVector a -> [a]
_   []     = []
shrinkVector a -> [a]
shr (a
x:[a]
xs) = [ a
x'a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs | a
x'  <- a -> [a]
shr a
x ]
                          [[a]] -> [[a]] -> [[a]]
forall a. [a] -> [a] -> [a]
++ [ a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs' | [a]
xs' <- (a -> [a]) -> [a] -> [[a]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkVector a -> [a]
shr [a]
xs ]

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

instance (Eq a, Arbitrary a) => Arbitrary (ShrinkCarefully a) where
  arbitrary :: Gen (ShrinkCarefully a)
arbitrary = a -> ShrinkCarefully a
forall a. a -> ShrinkCarefully a
ShrinkCarefully (a -> ShrinkCarefully a) -> Gen a -> Gen (ShrinkCarefully a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen a
forall a. Arbitrary a => Gen a
arbitrary
  shrink :: ShrinkCarefully a -> [ShrinkCarefully a]
shrink (ShrinkCarefully a
a) = a -> ShrinkCarefully a
forall a. a -> ShrinkCarefully a
ShrinkCarefully (a -> ShrinkCarefully a) -> [a] -> [ShrinkCarefully a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> [a] -> [a]
forall a. Eq a => a -> [a] -> [a]
delete a
a (a -> [a]
forall a. Arbitrary a => a -> [a]
shrink a
a)

prop_shrink_nonequal :: (Arbitrary a, Eq a, Show a) => ShrinkCarefully a -> Property
prop_shrink_nonequal :: forall a.
(Arbitrary a, Eq a, Show a) =>
ShrinkCarefully a -> Property
prop_shrink_nonequal (ShrinkCarefully a
e) =
    IO () -> Bool -> Property
forall prop. Testable prop => IO () -> prop -> Property
whenFail (a -> IO ()
forall (m :: * -> *) a. (MonadIO m, Show a) => a -> m ()
pPrint a
e) (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$
    a
e a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` a -> [a]
forall a. Arbitrary a => a -> [a]
shrink a
e

-- | Check that each shrink satisfies some invariant or validity condition.
--
prop_shrink_valid :: (Arbitrary a, Show a, Testable prop)
                  => (a -> prop) -> ShrinkCarefully a -> Property
prop_shrink_valid :: forall a prop.
(Arbitrary a, Show a, Testable prop) =>
(a -> prop) -> ShrinkCarefully a -> Property
prop_shrink_valid a -> prop
valid (ShrinkCarefully a
x) =
    [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin [ String -> prop -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"shrink result invalid:\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x') (a -> prop
valid a
x')
            | a
x' <- a -> [a]
forall a. Arbitrary a => a -> [a]
shrink a
x ]


-- | Use in 'tabulate' to help summarise data into buckets.
--
renderRanges :: Int -> Int -> String
renderRanges :: Int -> Int -> String
renderRanges Int
r Int
n = Int -> String
forall a. Show a => a -> String
show Int
lower String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" -- " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
upper
  where
    lower :: Int
lower = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
r
    upper :: Int
upper = Int
lower Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
rInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)

--
-- Set properties
--

isSubsetProperty :: (Ord a, Show a) => String -> Set a -> Set a -> Property
isSubsetProperty :: forall a. (Ord a, Show a) => String -> Set a -> Set a -> Property
isSubsetProperty String
name Set a
a Set a
b =
    let d :: Set a
d = Set a
a Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set a
b
    in String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample
        (String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"violates subset property: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Set a -> String
forall a. Show a => a -> String
show Set a
d)
        (Set a -> Bool
forall a. Set a -> Bool
Set.null Set a
d)

disjointSetsProperty :: (Ord a, Show a) => String -> Set a -> Set a -> Property
disjointSetsProperty :: forall a. (Ord a, Show a) => String -> Set a -> Set a -> Property
disjointSetsProperty String
name Set a
a Set a
b =
    let d :: Set a
d = Set a
a Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection` Set a
b
    in String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample
        (String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"vaiolates disjoint set property: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Set a -> String
forall a. Show a => a -> String
show Set a
d)
        (Set a -> Bool
forall a. Set a -> Bool
Set.null Set a
d)

--
-- Tracing tools
--

data WithName name event = WithName {
    forall name event. WithName name event -> name
wnName  :: name,
    forall name event. WithName name event -> event
wnEvent :: event
  }
  deriving ((forall a b. (a -> b) -> WithName name a -> WithName name b)
-> (forall a b. a -> WithName name b -> WithName name a)
-> Functor (WithName name)
forall a b. a -> WithName name b -> WithName name a
forall a b. (a -> b) -> WithName name a -> WithName name b
forall name a b. a -> WithName name b -> WithName name a
forall name a b. (a -> b) -> WithName name a -> WithName name b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall name a b. (a -> b) -> WithName name a -> WithName name b
fmap :: forall a b. (a -> b) -> WithName name a -> WithName name b
$c<$ :: forall name a b. a -> WithName name b -> WithName name a
<$ :: forall a b. a -> WithName name b -> WithName name a
Functor)

instance (Show name, Show event) => Show (WithName name event) where
  show :: WithName name event -> String
show (WithName name
name event
ev) = String
"#" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> name -> String
forall a. Show a => a -> String
show name
name String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" %" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> event -> String
forall a. Show a => a -> String
show event
ev

data WithTime event = WithTime {
    forall event. WithTime event -> Time
wtTime  :: Time,
    forall event. WithTime event -> event
wtEvent :: event
  }
  deriving ((forall a b. (a -> b) -> WithTime a -> WithTime b)
-> (forall a b. a -> WithTime b -> WithTime a) -> Functor WithTime
forall a b. a -> WithTime b -> WithTime a
forall a b. (a -> b) -> WithTime a -> WithTime b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> WithTime a -> WithTime b
fmap :: forall a b. (a -> b) -> WithTime a -> WithTime b
$c<$ :: forall a b. a -> WithTime b -> WithTime a
<$ :: forall a b. a -> WithTime b -> WithTime a
Functor)

instance Show event => Show (WithTime event) where
  show :: WithTime event -> String
show (WithTime Time
t event
ev) = String
"@" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Time -> String
forall a. Show a => a -> String
show Time
t String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> event -> String
forall a. Show a => a -> String
show event
ev

tracerWithName :: name -> Tracer m (WithName name a) -> Tracer m a
tracerWithName :: forall name (m :: * -> *) a.
name -> Tracer m (WithName name a) -> Tracer m a
tracerWithName name
name = (a -> WithName name a) -> Tracer m (WithName name a) -> Tracer m a
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (name -> a -> WithName name a
forall name event. name -> event -> WithName name event
WithName name
name)

tracerWithTime :: MonadMonotonicTime m => Tracer m (WithTime a) -> Tracer m a
tracerWithTime :: forall (m :: * -> *) a.
MonadMonotonicTime m =>
Tracer m (WithTime a) -> Tracer m a
tracerWithTime = (a -> m (WithTime a)) -> Tracer m (WithTime a) -> Tracer m a
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Tracer m b -> Tracer m a
contramapM ((a -> m (WithTime a)) -> Tracer m (WithTime a) -> Tracer m a)
-> (a -> m (WithTime a)) -> Tracer m (WithTime a) -> Tracer m a
forall a b. (a -> b) -> a -> b
$ \a
a -> (Time -> a -> WithTime a) -> a -> Time -> WithTime a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Time -> a -> WithTime a
forall event. Time -> event -> WithTime event
WithTime a
a (Time -> WithTime a) -> m Time -> m (WithTime a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime

tracerWithTimeName :: MonadMonotonicTime m
                   => name
                   -> Tracer m (WithTime (WithName name a))
                   -> Tracer m a
tracerWithTimeName :: forall (m :: * -> *) name a.
MonadMonotonicTime m =>
name -> Tracer m (WithTime (WithName name a)) -> Tracer m a
tracerWithTimeName name
name =
  (a -> m (WithTime (WithName name a)))
-> Tracer m (WithTime (WithName name a)) -> Tracer m a
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Tracer m b -> Tracer m a
contramapM ((a -> m (WithTime (WithName name a)))
 -> Tracer m (WithTime (WithName name a)) -> Tracer m a)
-> (a -> m (WithTime (WithName name a)))
-> Tracer m (WithTime (WithName name a))
-> Tracer m a
forall a b. (a -> b) -> a -> b
$ \a
a -> (Time -> WithName name a -> WithTime (WithName name a))
-> WithName name a -> Time -> WithTime (WithName name a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Time -> WithName name a -> WithTime (WithName name a)
forall event. Time -> event -> WithTime event
WithTime (name -> a -> WithName name a
forall name event. name -> event -> WithName name event
WithName name
name a
a) (Time -> WithTime (WithName name a))
-> m Time -> m (WithTime (WithName name a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime

swapNameWithTime :: WithName name (WithTime b) -> WithTime (WithName name b)
swapNameWithTime :: forall name b.
WithName name (WithTime b) -> WithTime (WithName name b)
swapNameWithTime (WithName name
name (WithTime Time
t b
b)) = Time -> WithName name b -> WithTime (WithName name b)
forall event. Time -> event -> WithTime event
WithTime Time
t (name -> b -> WithName name b
forall name event. name -> event -> WithName name event
WithName name
name b
b)

swapTimeWithName :: WithTime (WithName name b) -> WithName name (WithTime b)
swapTimeWithName :: forall name b.
WithTime (WithName name b) -> WithName name (WithTime b)
swapTimeWithName (WithTime Time
t (WithName name
name b
b)) = name -> WithTime b -> WithName name (WithTime b)
forall name event. name -> event -> WithName name event
WithName name
name (Time -> b -> WithTime b
forall event. Time -> event -> WithTime event
WithTime Time
t b
b)

-- | Split Trace events into separate traces indexed by a given name.
--
splitWithNameTrace :: Ord name
                   => Trace r (WithName name b)
                   -> Trace r [WithName name b]
splitWithNameTrace :: forall name r b.
Ord name =>
Trace r (WithName name b) -> Trace r [WithName name b]
splitWithNameTrace =
    (Maybe [WithName name b] -> [WithName name b])
-> Trace r (Maybe [WithName name b]) -> Trace r [WithName name b]
forall a b. (a -> b) -> Trace r a -> Trace r b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe [WithName name b] -> [WithName name b]
forall a. HasCallStack => Maybe a -> a
fromJust
  (Trace r (Maybe [WithName name b]) -> Trace r [WithName name b])
-> (Trace r (WithName name b) -> Trace r (Maybe [WithName name b]))
-> Trace r (WithName name b)
-> Trace r [WithName name b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe [WithName name b] -> Bool)
-> Trace r (Maybe [WithName name b])
-> Trace r (Maybe [WithName name b])
forall b a. (b -> Bool) -> Trace a b -> Trace a b
Trace.filter Maybe [WithName name b] -> Bool
forall a. Maybe a -> Bool
isJust
  -- there might be some connections in the state, push them onto the 'Trace'
  (Trace r (Maybe [WithName name b])
 -> Trace r (Maybe [WithName name b]))
-> (Trace r (WithName name b) -> Trace r (Maybe [WithName name b]))
-> Trace r (WithName name b)
-> Trace r (Maybe [WithName name b])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(Map name [WithName name b]
s, Trace r (Maybe [WithName name b])
o) -> ([WithName name b]
 -> Trace r (Maybe [WithName name b])
 -> Trace r (Maybe [WithName name b]))
-> Trace r (Maybe [WithName name b])
-> [[WithName name b]]
-> Trace r (Maybe [WithName name b])
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\[WithName name b]
a Trace r (Maybe [WithName name b])
as -> Maybe [WithName name b]
-> Trace r (Maybe [WithName name b])
-> Trace r (Maybe [WithName name b])
forall a b. b -> Trace a b -> Trace a b
Trace.Cons ([WithName name b] -> Maybe [WithName name b]
forall a. a -> Maybe a
Just [WithName name b]
a) Trace r (Maybe [WithName name b])
as) Trace r (Maybe [WithName name b])
o (Map name [WithName name b] -> [[WithName name b]]
forall k a. Map k a -> [a]
Map.elems Map name [WithName name b]
s))
  ((Map name [WithName name b], Trace r (Maybe [WithName name b]))
 -> Trace r (Maybe [WithName name b]))
-> (Trace r (WithName name b)
    -> (Map name [WithName name b], Trace r (Maybe [WithName name b])))
-> Trace r (WithName name b)
-> Trace r (Maybe [WithName name b])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map name [WithName name b]
 -> r -> (Map name [WithName name b], r))
-> (Map name [WithName name b]
    -> WithName name b
    -> (Map name [WithName name b], Maybe [WithName name b]))
-> Map name [WithName name b]
-> Trace r (WithName name b)
-> (Map name [WithName name b], Trace r (Maybe [WithName name b]))
forall (t :: * -> * -> *) a b c d e.
Bitraversable t =>
(a -> b -> (a, c))
-> (a -> d -> (a, e)) -> a -> t b d -> (a, t c e)
bimapAccumR
      ( \ Map name [WithName name b]
s r
a -> (Map name [WithName name b]
s, r
a))
      ( \ Map name [WithName name b]
s wn :: WithName name b
wn@(WithName name
name b
_) ->
        ( (Maybe [WithName name b] -> Maybe [WithName name b])
-> name -> Map name [WithName name b] -> Map name [WithName name b]
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter
            ( \ case
                 Maybe [WithName name b]
Nothing  -> [WithName name b] -> Maybe [WithName name b]
forall a. a -> Maybe a
Just [WithName name b
wn]
                 Just [WithName name b]
wns -> [WithName name b] -> Maybe [WithName name b]
forall a. a -> Maybe a
Just (WithName name b
wn WithName name b -> [WithName name b] -> [WithName name b]
forall a. a -> [a] -> [a]
: [WithName name b]
wns)
            ) name
name Map name [WithName name b]
s
        , Maybe [WithName name b]
forall a. Maybe a
Nothing
        )
      )
      Map name [WithName name b]
forall k a. Map k a
Map.empty

--
-- Debugging tools
--

debugTracer :: ( Show a, Applicative m) => Tracer m a
debugTracer :: forall a (m :: * -> *). (Show a, Applicative m) => Tracer m a
debugTracer = (a -> m ()) -> Tracer m a
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer a -> m ()
forall a (f :: * -> *). (Show a, Applicative f) => a -> f ()
traceShowM

sayTracer :: ( Show a, MonadSay m) => Tracer m a
sayTracer :: forall a (m :: * -> *). (Show a, MonadSay m) => Tracer m a
sayTracer = (a -> m ()) -> Tracer m a
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer (String -> m ()
forall (m :: * -> *). MonadSay m => String -> m ()
say (String -> m ()) -> (a -> String) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show)

-- | Redefine this tracer to get valuable tracing information from various
-- components:
--
-- * connection-manager
-- * inbound governor
-- * server
--
debugTracerG :: (Show a, Typeable a) => Tracer (IOSim s) a
debugTracerG :: forall a s. (Show a, Typeable a) => Tracer (IOSim s) a
debugTracerG =    (a -> IOSim s ()) -> Tracer (IOSim s) a
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer (\a
msg -> IOSim s UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime IOSim s UTCTime -> (UTCTime -> IOSim s ()) -> IOSim s ()
forall a b. IOSim s a -> (a -> IOSim s b) -> IOSim s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IOSim s ()
forall (m :: * -> *). MonadSay m => String -> m ()
say (String -> IOSim s ())
-> (UTCTime -> String) -> UTCTime -> IOSim s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UTCTime, a) -> String
forall a. Show a => a -> String
show ((UTCTime, a) -> String)
-> (UTCTime -> (UTCTime, a)) -> UTCTime -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,a
msg))
               Tracer (IOSim s) a -> Tracer (IOSim s) a -> Tracer (IOSim s) a
forall a. Semigroup a => a -> a -> a
<> (a -> IOSim s ()) -> Tracer (IOSim s) a
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer a -> IOSim s ()
forall a s. Typeable a => a -> IOSim s ()
traceM
            -- <> Tracer Debug.traceShowM

--
-- Nightly tests
--

nightlyTest :: TestTree -> TestTree
nightlyTest :: TestTree -> TestTree
nightlyTest =
#ifndef NIGHTLY
  TestTree -> TestTree
ignoreTest
#else
  id
#endif