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

module Ouroboros.Network.Testing.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
  , sayTracer
  -- * Tasty Utils
  , nightlyTest
  , ignoreTest
  -- * Auxiliary functions
  , renderRanges
  ) where

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

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

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


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)


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 DiffTime
delay) | DiffTime
delay DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
>= DiffTime
0.1 = [ DiffTime -> Delay
Delay (DiffTime
delay DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
- DiffTime
0.1) ]
                         | Bool
otherwise    = []


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)

instance Arbitrary SmallDelay where
    arbitrary :: Gen SmallDelay
arbitrary = Int -> Gen SmallDelay -> Gen SmallDelay
forall a. 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 DiffTime
delay) | DiffTime
delay DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
>= DiffTime
0.1 = [ DiffTime -> SmallDelay
SmallDelay (DiffTime
delay DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
- DiffTime
0.1) ]
                              | Bool
otherwise    = []

-- | 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 (Int -> WithName name event -> ShowS
[WithName name event] -> ShowS
WithName name event -> String
(Int -> WithName name event -> ShowS)
-> (WithName name event -> String)
-> ([WithName name event] -> ShowS)
-> Show (WithName name event)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall name event.
(Show name, Show event) =>
Int -> WithName name event -> ShowS
forall name event.
(Show name, Show event) =>
[WithName name event] -> ShowS
forall name event.
(Show name, Show event) =>
WithName name event -> String
$cshowsPrec :: forall name event.
(Show name, Show event) =>
Int -> WithName name event -> ShowS
showsPrec :: Int -> WithName name event -> ShowS
$cshow :: forall name event.
(Show name, Show event) =>
WithName name event -> String
show :: WithName name event -> String
$cshowList :: forall name event.
(Show name, Show event) =>
[WithName name event] -> ShowS
showList :: [WithName name event] -> ShowS
Show, (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)

data WithTime event = WithTime {
    forall event. WithTime event -> Time
wtTime  :: Time,
    forall event. WithTime event -> event
wtEvent :: event
  }
  deriving (Int -> WithTime event -> ShowS
[WithTime event] -> ShowS
WithTime event -> String
(Int -> WithTime event -> ShowS)
-> (WithTime event -> String)
-> ([WithTime event] -> ShowS)
-> Show (WithTime event)
forall event. Show event => Int -> WithTime event -> ShowS
forall event. Show event => [WithTime event] -> ShowS
forall event. Show event => WithTime event -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall event. Show event => Int -> WithTime event -> ShowS
showsPrec :: Int -> WithTime event -> ShowS
$cshow :: forall event. Show event => WithTime event -> String
show :: WithTime event -> String
$cshowList :: forall event. Show event => [WithTime event] -> ShowS
showList :: [WithTime event] -> ShowS
Show, (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)

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)


--
-- Nightly tests
--

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