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

module Ouroboros.Network.Testing.Utils
  ( -- * Arbitrary Delays
    Delay (..)
  , genDelayWithPrecision
  , SmallDelay (..)
    -- * QuickCheck Utils
  , arbitrarySubset
  , shrinkVector
  , prop_shrink_valid
  , prop_shrink_nonequal
  -- * 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
import           Control.Tracer (Contravariant (contramap), Tracer (..),
                     contramapM)

import           Data.Bitraversable (bimapAccumR)
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           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
showList :: [Delay] -> ShowS
$cshowList :: [Delay] -> ShowS
show :: Delay -> String
$cshow :: Delay -> String
showsPrec :: Int -> Delay -> ShowS
$cshowsPrec :: Int -> 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
/= :: Delay -> Delay -> Bool
$c/= :: Delay -> Delay -> Bool
== :: Delay -> Delay -> Bool
$c== :: 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
min :: Delay -> Delay -> Delay
$cmin :: Delay -> Delay -> Delay
max :: Delay -> Delay -> Delay
$cmax :: Delay -> Delay -> Delay
>= :: Delay -> Delay -> Bool
$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
compare :: Delay -> Delay -> Ordering
$ccompare :: Delay -> Delay -> Ordering
$cp1Ord :: Eq 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
fromInteger :: Integer -> Delay
$cfromInteger :: Integer -> Delay
signum :: Delay -> Delay
$csignum :: Delay -> Delay
abs :: Delay -> Delay
$cabs :: Delay -> Delay
negate :: Delay -> Delay
$cnegate :: Delay -> Delay
* :: Delay -> Delay -> Delay
$c* :: Delay -> Delay -> Delay
- :: Delay -> Delay -> Delay
$c- :: Delay -> Delay -> Delay
+ :: Delay -> Delay -> Delay
$c+ :: Delay -> Delay -> 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
      Integer
b <- (Integer, Integer) -> Gen Integer
chooseInteger (Integer
1, Integer
precision)
      Integer
a <- (Integer, Integer) -> Gen Integer
chooseInteger (Integer
0, Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
b)
      DiffTime -> Gen DiffTime
forall (m :: * -> *) a. Monad m => a -> m a
return (Rational -> DiffTime
forall a. Fractional a => Rational -> a
fromRational (Integer
a Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
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
showList :: [SmallDelay] -> ShowS
$cshowList :: [SmallDelay] -> ShowS
show :: SmallDelay -> String
$cshow :: SmallDelay -> String
showsPrec :: Int -> SmallDelay -> ShowS
$cshowsPrec :: Int -> 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
/= :: SmallDelay -> SmallDelay -> Bool
$c/= :: SmallDelay -> SmallDelay -> Bool
== :: SmallDelay -> SmallDelay -> Bool
$c== :: 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
min :: SmallDelay -> SmallDelay -> SmallDelay
$cmin :: SmallDelay -> SmallDelay -> SmallDelay
max :: SmallDelay -> SmallDelay -> SmallDelay
$cmax :: SmallDelay -> SmallDelay -> SmallDelay
>= :: SmallDelay -> SmallDelay -> Bool
$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
compare :: SmallDelay -> SmallDelay -> Ordering
$ccompare :: SmallDelay -> SmallDelay -> Ordering
$cp1Ord :: Eq 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
fromInteger :: Integer -> SmallDelay
$cfromInteger :: Integer -> SmallDelay
signum :: SmallDelay -> SmallDelay
$csignum :: SmallDelay -> SmallDelay
abs :: SmallDelay -> SmallDelay
$cabs :: SmallDelay -> SmallDelay
negate :: SmallDelay -> SmallDelay
$cnegate :: SmallDelay -> SmallDelay
* :: SmallDelay -> SmallDelay -> SmallDelay
$c* :: SmallDelay -> SmallDelay -> SmallDelay
- :: SmallDelay -> SmallDelay -> SmallDelay
$c- :: SmallDelay -> SmallDelay -> SmallDelay
+ :: SmallDelay -> SmallDelay -> SmallDelay
$c+ :: SmallDelay -> SmallDelay -> 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 :: Set a -> Gen (Set a)
arbitrarySubset Set a
s = do
    [Bool]
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' :: Set a
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
    Set a -> Gen (Set a)
forall (m :: * -> *) a. Monad m => a -> m a
return Set a
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 :: (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 ]


-- | Check that each shrink satisfies some invariant or validity condition.
--
prop_shrink_valid :: (Arbitrary a, Show a)
                  => (a -> Bool) -> Fixed a -> Property
prop_shrink_valid :: (a -> Bool) -> Fixed a -> Property
prop_shrink_valid a -> Bool
valid (Fixed a
x) =
    let invalid :: [a]
invalid = [ a
x' | a
x' <- a -> [a]
forall a. Arbitrary a => a -> [a]
shrink a
x, Bool -> Bool
not (a -> Bool
valid a
x') ]
     in case [a]
invalid of
          []     -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
          (a
x':[a]
_) -> String -> Property -> 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') (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
                    Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False


-- | The 'shrink' function needs to give a valid value that is /smaller/ than
-- the original, otherwise the shrinking procedure is not well-founded and can
-- cycle.
--
-- This property does not check size, as that would need significant extra
-- infrastructure to define an appropriate measure. Instead this property
-- simply checks each shrink is not the same as the original. This catches
-- simple 1-cycles, but not bigger cycles. These are fortunately the most
-- common case, so it is still a useful property in practice.
--
prop_shrink_nonequal :: (Arbitrary a, Eq a) => Fixed a -> Property
prop_shrink_nonequal :: Fixed a -> Property
prop_shrink_nonequal (Fixed a
x) =
    String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"A shrink result equals as the original.\n" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"This will cause non-termination for shrinking." (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$
    a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem 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)

--
-- Tracing tools
--

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

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

tracerWithName :: name -> Tracer m (WithName name a) -> Tracer m a
tracerWithName :: 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 (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> 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 :: 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 :: 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 :: 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 :: 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 :: 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 (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 (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 :: 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 :: 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