{-# OPTIONS_GHC -Wno-deprecations #-}

module Test.Util where

import Hydra.Prelude
import Test.Hydra.Prelude hiding (shouldBe)

import Control.Monad.Class.MonadSay (say)
import Control.Monad.IOSim (
  Failure (FailureException),
  IOSim,
  SimTrace,
  runSimTrace,
  selectTraceEventsDynamic',
  traceM,
  traceResult,
 )
import Control.Tracer (Tracer (Tracer))
import Data.Aeson (encode)
import Data.Aeson qualified as Aeson
import Data.List (isInfixOf)
import Hydra.Ledger.Simple (SimpleTx)
import Hydra.Node (HydraNodeLog)
import Test.HUnit.Lang (FailureReason (ExpectedButGot))
import Test.QuickCheck (forAll, withMaxSuccess)

-- | Run given 'action' in 'IOSim' and rethrow any exceptions.
shouldRunInSim ::
  (forall s. IOSim s a) ->
  IO a
shouldRunInSim :: forall a. (forall s. IOSim s a) -> IO a
shouldRunInSim forall s. IOSim s a
action =
  case Bool -> SimTrace a -> Either Failure a
forall a. Bool -> SimTrace a -> Either Failure a
traceResult Bool
False SimTrace a
tr of
    Right a
x -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
    Left (FailureException (SomeException e
ex)) -> do
      IO ()
dumpTrace
      e -> IO a
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO e
ex
    Left Failure
ex -> do
      IO ()
dumpTrace
      Failure -> IO a
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO Failure
ex
 where
  tr :: SimTrace a
tr = (forall s. IOSim s a) -> SimTrace a
forall a. (forall s. IOSim s a) -> SimTrace a
runSimTrace IOSim s a
forall s. IOSim s a
action
  dumpTrace :: IO ()
dumpTrace = String -> IO ()
forall (m :: * -> *). MonadSay m => String -> m ()
say (Text -> String
forall a. ToString a => a -> String
toString (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Proxy (HydraNodeLog SimpleTx) -> SimTrace a -> Text
forall log a.
(Typeable log, ToJSON log) =>
Proxy log -> SimTrace a -> Text
printTrace (Proxy (HydraNodeLog SimpleTx)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (HydraNodeLog SimpleTx)) SimTrace a
tr)

-- | Utility function to dump logs given a `SimTrace`.
printTrace :: forall log a. (Typeable log, ToJSON log) => Proxy log -> SimTrace a -> Text
printTrace :: forall log a.
(Typeable log, ToJSON log) =>
Proxy log -> SimTrace a -> Text
printTrace Proxy log
_ SimTrace a
tr =
  [Text] -> Text
forall t. IsText t "unlines" => [t] -> t
unlines ([Text] -> Text) -> ([log] -> [Text]) -> [log] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (log -> Text) -> [log] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (ByteString -> Text) -> (log -> ByteString) -> log -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. log -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode) ([log] -> Text) -> [log] -> Text
forall a b. (a -> b) -> a -> b
$
    forall a b. Typeable b => SimTrace a -> [b]
selectTraceEventsDynamic' @_ @log SimTrace a
tr

-- | Lifted variant of Hspec's 'shouldBe'.
shouldBe :: (HasCallStack, MonadThrow m, Eq a, Show a) => a -> a -> m ()
shouldBe :: forall (m :: * -> *) a.
(HasCallStack, MonadThrow m, Eq a, Show a) =>
a -> a -> m ()
shouldBe a
actual a
expected =
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (a
actual a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
expected) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    HUnitFailure -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (HUnitFailure -> m ()) -> HUnitFailure -> m ()
forall a b. (a -> b) -> a -> b
$
      Maybe SrcLoc -> FailureReason -> HUnitFailure
HUnitFailure Maybe SrcLoc
HasCallStack => Maybe SrcLoc
location FailureReason
reason
 where
  reason :: FailureReason
reason = Maybe String -> String -> String -> FailureReason
ExpectedButGot Maybe String
forall a. Maybe a
Nothing (a -> String
forall b a. (Show a, IsString b) => a -> b
show a
expected) (a -> String
forall b a. (Show a, IsString b) => a -> b
show a
actual)

-- | Lifted variant of Hspec's 'shouldReturn'.
shouldReturn :: (HasCallStack, MonadThrow m, Eq a, Show a) => m a -> a -> m ()
shouldReturn :: forall (m :: * -> *) a.
(HasCallStack, MonadThrow m, Eq a, Show a) =>
m a -> a -> m ()
shouldReturn m a
ma a
expected = m a
ma m a -> (a -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (a -> a -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m, Eq a, Show a) =>
a -> a -> m ()
`shouldBe` a
expected)

-- | Lifted variant of Hspec's 'shouldSatisfy'.
shouldSatisfy :: (HasCallStack, MonadThrow m, Show a) => a -> (a -> Bool) -> m ()
shouldSatisfy :: forall (m :: * -> *) a.
(HasCallStack, MonadThrow m, Show a) =>
a -> (a -> Bool) -> m ()
shouldSatisfy a
v a -> Bool
p
  | a -> Bool
p a
v = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  | Bool
otherwise = String -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"predicate failed on: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall b a. (Show a, IsString b) => a -> b
show a
v

-- | Lifted variant of Hspec's 'shouldNotBe'.
shouldNotBe :: (HasCallStack, MonadThrow m, Eq a, Show a) => a -> a -> m ()
shouldNotBe :: forall (m :: * -> *) a.
(HasCallStack, MonadThrow m, Eq a, Show a) =>
a -> a -> m ()
shouldNotBe a
actual a
expected
  | a
actual a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
expected = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  | Bool
otherwise = String -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"not expected: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall b a. (Show a, IsString b) => a -> b
show a
actual

-- | Lifted variant of Hspec's 'shouldContain'.
shouldContain :: (HasCallStack, MonadThrow m, Eq a, Show a) => [a] -> [a] -> m ()
shouldContain :: forall (m :: * -> *) a.
(HasCallStack, MonadThrow m, Eq a, Show a) =>
[a] -> [a] -> m ()
shouldContain [a]
actual [a]
expected
  | [a]
expected [a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` [a]
actual = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  | Bool
otherwise = String -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ [a] -> String
forall b a. (Show a, IsString b) => a -> b
show [a]
actual String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" does not contain " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [a] -> String
forall b a. (Show a, IsString b) => a -> b
show [a]
expected

-- | A 'Tracer' that works in 'IOSim' monad.
-- This tracer uses the 'Output' event which uses converts value traced to 'Dynamic'
-- which requires 'Typeable' constraint. To retrieve the trace use 'selectTraceEventsDynamic'
-- applied to the correct type.
traceInIOSim :: Typeable a => Tracer (IOSim s) a
traceInIOSim :: forall a s. Typeable a => Tracer (IOSim s) a
traceInIOSim = (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

-- | Useful when one needs to /also/ trace logs to `stderr`.
-- Thanks to the monoidal nature of `Tracer` it's straightforward to add this to
-- any existing tracer:
--
-- @@
-- someCode tracer = do
--   foo <- makeFoo
--   withTracer (tr <> traceDebug) SomeTraceFoo
-- ...
-- @@
traceDebug :: (Applicative m, ToJSON a) => Tracer m a
traceDebug :: forall (m :: * -> *) a. (Applicative m, ToJSON a) => Tracer m a
traceDebug = (a -> m ()) -> Tracer m a
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer (\a
a -> String -> m () -> m ()
forall a. String -> a -> a
trace (ByteString -> String
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. ToJSON a => a -> ByteString
encode a
a) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

-- | This creates an hspec test case about a property which ensures the given generator
-- does not produce equals values within a reasonable number of generated values.
propCollisionResistant :: (Show a, Eq a) => String -> Gen a -> Spec
propCollisionResistant :: forall a. (Show a, Eq a) => String -> Gen a -> Spec
propCollisionResistant String
name Gen a
gen =
  String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop (String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" is reasonably collision resistant") (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
    Int -> Property -> Property
forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
100_000 (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
      Gen a -> (a -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen a
gen ((a -> Property) -> Property) -> (a -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \a
a ->
        Gen a -> (a -> Bool) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen a
gen ((a -> Bool) -> Property) -> (a -> Bool) -> Property
forall a b. (a -> b) -> a -> b
$ \a
b ->
          a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
b

-- | Predicate which decides whether given list is continuous.
isContinuous :: (Eq a, Enum a) => [a] -> Bool
isContinuous :: forall a. (Eq a, Enum a) => [a] -> Bool
isContinuous = \case
  [] -> Bool
True
  [a
_] -> Bool
True
  (a
a : a
b : [a]
as) -> a -> a
forall a. Enum a => a -> a
succ a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
b Bool -> Bool -> Bool
&& [a] -> Bool
forall a. (Eq a, Enum a) => [a] -> Bool
isContinuous (a
b a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
as)

-- | Predicate which decides whether given list is monotonic.
isMonotonic :: Ord a => [a] -> Bool
isMonotonic :: forall a. Ord a => [a] -> Bool
isMonotonic = \case
  [] -> Bool
True
  [a
_] -> Bool
True
  (a
a : a
b : [a]
as) -> a
a a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
b Bool -> Bool -> Bool
&& [a] -> Bool
forall a. Ord a => [a] -> Bool
isMonotonic (a
b a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
as)

-- | Predicate which decides whether given list is strictly monotonic.
isStrictlyMonotonic :: Ord a => [a] -> Bool
isStrictlyMonotonic :: forall a. Ord a => [a] -> Bool
isStrictlyMonotonic = \case
  [] -> Bool
True
  [a
_] -> Bool
True
  (a
a : a
b : [a]
as) -> a
a a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
b Bool -> Bool -> Bool
&& [a] -> Bool
forall a. Ord a => [a] -> Bool
isStrictlyMonotonic (a
b a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
as)