{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Ledger.Common (
  module X,
  ledgerTestMain,
  ledgerTestMainWith,
  ledgerHspecConfig,
  NFData,
  runGen,

  -- * Expr
  ToExpr (..),
  showExpr,
  ansiExpr,
  ansiExprString,
  diffExpr,
  diffExprString,
  diffExprCompact,
  diffExprCompactString,
  ansiDocToString,

  -- * Expectations
  assertBool,
  assertFailure,
  assertColorFailure,

  -- ** Non-standard expectations
  shouldBeExpr,
  shouldBeRight,
  shouldBeLeft,
  shouldBeRightExpr,
  shouldBeLeftExpr,
  expectRight,
  expectRightDeep,
  expectRightDeep_,
  expectRightExpr,
  expectRightDeepExpr,
  expectRightDeepExpr_,
  expectLeft,
  expectLeftExpr,
  expectLeftDeep,
  expectLeftDeep_,
  expectLeftDeepExpr,
  expectLeftDeepExpr_,
  expectJust,
  expectJustDeep,
  expectJustDeep_,
  expectNothing,

  -- ** Golden testing
  Golden.Golden,
  itGolden,
  toPackageGolden,

  -- ** Aeson testing
  itGoldenToJSON,
  aesonGoldenSpec,
  goldenForToJSON,
  roundTripAesonProperty,

  -- * Miscellanous helpers
  tracedDiscard,
  forEachEraVersion,
) where

import Cardano.Ledger.Binary (Version)
import Cardano.Ledger.Core (Era, eraProtVersions)
import Control.DeepSeq (NFData)
import Control.Monad as X (forM_, replicateM, replicateM_, unless, void, when, (>=>))
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Encode.Pretty as Aeson
import qualified Data.Aeson.Types as Aeson (parseEither)
import qualified Data.ByteString.Lazy as BSL
import Data.Typeable
import qualified Debug.Trace as Debug
import Test.Cardano.Ledger.Binary.Golden (toPackageGolden)
import Test.Cardano.Ledger.Binary.TreeDiff (
  ToExpr (..),
  ansiExpr,
  ansiExprString,
  diffExpr,
  diffExprCompact,
  diffExprCompactString,
  diffExprString,
  expectExprEqualWithMessage,
  showExpr,
 )
import Test.Hspec as X
import qualified Test.Hspec.Golden as Golden (Golden (..))
import Test.Hspec.QuickCheck as X
import Test.Hspec.Runner
import Test.ImpSpec (ansiDocToString, impSpecConfig, impSpecMainWithConfig)
import Test.ImpSpec.Expectations
import Test.QuickCheck as X hiding (NonZero, Witness)
import Test.QuickCheck.Gen (Gen (..))
import Test.QuickCheck.Random (mkQCGen)
import UnliftIO.Exception (evaluateDeep)

infix 1 `shouldBeExpr`
        , `shouldBeRightExpr`
        , `shouldBeLeftExpr`

ledgerHspecConfig :: Config
ledgerHspecConfig :: Config
ledgerHspecConfig = Config
impSpecConfig

ledgerTestMainWith :: Config -> Spec -> IO ()
ledgerTestMainWith :: Config -> Spec -> IO ()
ledgerTestMainWith = Config -> Spec -> IO ()
impSpecMainWithConfig

ledgerTestMain :: Spec -> IO ()
ledgerTestMain :: Spec -> IO ()
ledgerTestMain = Config -> Spec -> IO ()
ledgerTestMainWith Config
ledgerHspecConfig

shouldBeExpr :: (HasCallStack, ToExpr a, Eq a) => a -> a -> IO ()
shouldBeExpr :: forall a. (HasCallStack, ToExpr a, Eq a) => a -> a -> IO ()
shouldBeExpr = String -> a -> a -> IO ()
forall a.
(ToExpr a, Eq a, HasCallStack) =>
String -> a -> a -> IO ()
expectExprEqualWithMessage String
""

-- | Same as `expectRight`, but use `ToExpr` instead of `Show`
expectRightExpr :: (HasCallStack, ToExpr a) => Either a b -> IO b
expectRightExpr :: forall a b. (HasCallStack, ToExpr a) => Either a b -> IO b
expectRightExpr (Right b
r) = b -> IO b
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> IO b) -> b -> IO b
forall a b. (a -> b) -> a -> b
$! b
r
expectRightExpr (Left a
l) = String -> IO b
forall a. HasCallStack => String -> IO a
assertFailure (String -> IO b) -> String -> IO b
forall a b. (a -> b) -> a -> b
$ String
"Expected Right, got Left:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. ToExpr a => a -> String
showExpr a
l

-- | Same as `expectRightDeep`,  but use `ToExpr` instead of `Show`
expectRightDeepExpr :: (HasCallStack, ToExpr a, NFData b) => Either a b -> IO b
expectRightDeepExpr :: forall a b.
(HasCallStack, ToExpr a, NFData b) =>
Either a b -> IO b
expectRightDeepExpr = Either a b -> IO b
forall a b. (HasCallStack, ToExpr a) => Either a b -> IO b
expectRightExpr (Either a b -> IO b) -> (b -> IO b) -> Either a b -> IO b
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> b -> IO b
forall (m :: * -> *) a. (MonadIO m, NFData a) => a -> m a
evaluateDeep

-- | Same as `shouldBeExpr`, except it checks that the value is `Right`
shouldBeRightExpr :: (HasCallStack, ToExpr a, Eq b, ToExpr b) => Either a b -> b -> Expectation
shouldBeRightExpr :: forall a b.
(HasCallStack, ToExpr a, Eq b, ToExpr b) =>
Either a b -> b -> IO ()
shouldBeRightExpr Either a b
e b
x = Either a b -> IO b
forall a b. (HasCallStack, ToExpr a) => Either a b -> IO b
expectRightExpr Either a b
e IO b -> (b -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (b -> b -> IO ()
forall a. (HasCallStack, ToExpr a, Eq a) => a -> a -> IO ()
`shouldBeExpr` b
x)

-- | Same as `expectRightDeepExpr`, but discard the contents of `Right`
expectRightDeepExpr_ :: (HasCallStack, ToExpr a, NFData b) => Either a b -> IO ()
expectRightDeepExpr_ :: forall a b.
(HasCallStack, ToExpr a, NFData b) =>
Either a b -> IO ()
expectRightDeepExpr_ = IO b -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO b -> IO ()) -> (Either a b -> IO b) -> Either a b -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either a b -> IO b
forall a b.
(HasCallStack, ToExpr a, NFData b) =>
Either a b -> IO b
expectRightDeepExpr

-- | Same as `expectLeft`, but use `ToExpr` instead of `Show`
expectLeftExpr :: (HasCallStack, ToExpr b) => Either a b -> IO a
expectLeftExpr :: forall b a. (HasCallStack, ToExpr b) => Either a b -> IO a
expectLeftExpr (Left a
l) = a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$! a
l
expectLeftExpr (Right b
r) = String -> IO a
forall a. HasCallStack => String -> IO a
assertFailure (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ String
"Expected Left, got Right:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> b -> String
forall a. ToExpr a => a -> String
showExpr b
r

-- | Same as `expectLeftDeep`, but use `ToExpr` instead of `Show`
expectLeftDeepExpr :: (HasCallStack, ToExpr b, NFData a) => Either a b -> IO a
expectLeftDeepExpr :: forall b a.
(HasCallStack, ToExpr b, NFData a) =>
Either a b -> IO a
expectLeftDeepExpr = Either a b -> IO a
forall b a. (HasCallStack, ToExpr b) => Either a b -> IO a
expectLeftExpr (Either a b -> IO a) -> (a -> IO a) -> Either a b -> IO a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> a -> IO a
forall (m :: * -> *) a. (MonadIO m, NFData a) => a -> m a
evaluateDeep

-- | Same as `expectLeftDeepExpr`, but discard the contents of `Left`
expectLeftDeepExpr_ :: (HasCallStack, ToExpr b, NFData a) => Either a b -> IO ()
expectLeftDeepExpr_ :: forall b a.
(HasCallStack, ToExpr b, NFData a) =>
Either a b -> IO ()
expectLeftDeepExpr_ = IO a -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO a -> IO ()) -> (Either a b -> IO a) -> Either a b -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either a b -> IO a
forall b a.
(HasCallStack, ToExpr b, NFData a) =>
Either a b -> IO a
expectLeftDeepExpr

-- | Same as `shouldBeExpr`, except it checks that the value is `Left`
shouldBeLeftExpr :: (HasCallStack, ToExpr a, ToExpr b, Eq a) => Either a b -> a -> Expectation
shouldBeLeftExpr :: forall a b.
(HasCallStack, ToExpr a, ToExpr b, Eq a) =>
Either a b -> a -> IO ()
shouldBeLeftExpr Either a b
e a
x = Either a b -> IO a
forall b a. (HasCallStack, ToExpr b) => Either a b -> IO a
expectLeftExpr Either a b
e IO a -> (a -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (a -> a -> IO ()
forall a. (HasCallStack, ToExpr a, Eq a) => a -> a -> IO ()
`shouldBeExpr` a
x)

-- | Same as `Test.QuickCheck.discard` but outputs a debug trace message
tracedDiscard :: String -> a
tracedDiscard :: forall a. String -> a
tracedDiscard String
message = (if Bool
False then String -> a -> a
forall a. String -> a -> a
Debug.trace (String -> a -> a) -> String -> a -> a
forall a b. (a -> b) -> a -> b
$ String
"\nDiscarded trace: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
message else a -> a
forall a. a -> a
id) a
forall a. a
discard

runGen ::
  -- | Seed
  Int ->
  -- | Size
  Int ->
  -- | Generator to run.
  Gen a ->
  a
runGen :: forall a. Int -> Int -> Gen a -> a
runGen Int
seed Int
size Gen a
gen = Gen a -> QCGen -> Int -> a
forall a. Gen a -> QCGen -> Int -> a
unGen Gen a
gen (Int -> QCGen
mkQCGen Int
seed) Int
size

forEachEraVersion :: forall era. (Era era, HasCallStack) => (Version -> Spec) -> Spec
forEachEraVersion :: forall era. (Era era, HasCallStack) => (Version -> Spec) -> Spec
forEachEraVersion Version -> Spec
sv = [Version] -> (Version -> Spec) -> Spec
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall era. Era era => [Version]
eraProtVersions @era) ((Version -> Spec) -> Spec) -> (Version -> Spec) -> Spec
forall a b. (a -> b) -> a -> b
$ \Version
version ->
  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe (Version -> String
forall a. Show a => a -> String
show Version
version) (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ Version -> Spec
sv Version
version

-- | `Golden` specification for `ToJSON`.
goldenForToJSON ::
  Aeson.ToJSON a =>
  -- | Path to the golden file relative to the package
  FilePath ->
  -- | Value, which in an encoded form will be expected to produce the same contents as in the
  -- golden file.
  a ->
  Golden.Golden BSL.ByteString
goldenForToJSON :: forall a. ToJSON a => String -> a -> Golden ByteString
goldenForToJSON String
goldenFileName a
actualOutput =
  Golden.Golden
    { output :: ByteString
Golden.output =
        -- Newline appended at the end for two reasons:
        --
        -- - Github in diffs shows an ugly symbol indicating there is no trailing newline
        --
        -- - Most editors will automatically add a trailing newline upon saving a file. Despite that
        --   these files are autogenerated, we do not want to prevent developers from adjusting them
        --   manually when they are experimenting with codecs
        a -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encodePretty a
actualOutput ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n"
    , encodePretty :: ByteString -> String
Golden.encodePretty = ByteString -> String
forall a. Show a => a -> String
show
    , writeToFile :: String -> ByteString -> IO ()
Golden.writeToFile = String -> ByteString -> IO ()
BSL.writeFile
    , readFromFile :: String -> IO ByteString
Golden.readFromFile = String -> IO ByteString
BSL.readFile
    , goldenFile :: String
Golden.goldenFile = String
goldenFileName
    , actualFile :: Maybe String
Golden.actualFile = Maybe String
forall a. Maybe a
Nothing
    , failFirstTime :: Bool
Golden.failFirstTime = Bool
False
    }

-- | Create a `Spec` for testing the `Golden.Golden` specification
itGolden ::
  (Eq g, HasCallStack) =>
  -- | Test name
  String ->
  -- | Action to get the full path, usually will be @Paths_<package_name>.getDataFileName@
  (FilePath -> IO FilePath) ->
  -- | Golden specification
  Golden.Golden g ->
  Spec
itGolden :: forall g.
(Eq g, HasCallStack) =>
String -> (String -> IO String) -> Golden g -> Spec
itGolden String
name String -> IO String
mkFullPath = String -> IO (Golden g) -> SpecWith (Arg (IO (Golden g)))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
name (IO (Golden g) -> Spec)
-> (Golden g -> IO (Golden g)) -> Golden g -> Spec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> IO String) -> Golden g -> IO (Golden g)
forall g. (String -> IO String) -> Golden g -> IO (Golden g)
toPackageGolden String -> IO String
mkFullPath

-- | Check `ToJSON` golden spec. in case when type also has `FromJSON` use `aesonGoldenSpec` instead.
itGoldenToJSON ::
  (Aeson.ToJSON a, Typeable a) =>
  -- | Action to get the full path, usually will be @Paths_<package_name>.getDataFileName@
  (FilePath -> IO FilePath) ->
  -- | File path to the golden file relative to the root of the package
  FilePath ->
  a ->
  Spec
itGoldenToJSON :: forall a.
(ToJSON a, Typeable a) =>
(String -> IO String) -> String -> a -> Spec
itGoldenToJSON String -> IO String
mkFullPath String
goldenFileName a
a =
  String -> (String -> IO String) -> Golden ByteString -> Spec
forall g.
(Eq g, HasCallStack) =>
String -> (String -> IO String) -> Golden g -> Spec
itGolden (TypeRep -> String
forall a. Show a => a -> String
show (a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
a)) String -> IO String
mkFullPath (Golden ByteString -> Spec) -> Golden ByteString -> Spec
forall a b. (a -> b) -> a -> b
$ String -> a -> Golden ByteString
forall a. ToJSON a => String -> a -> Golden ByteString
goldenForToJSON String
goldenFileName a
a

-- | Same as `itGoldenToJSON`, but also test `FromJSON` through roundtripping
aesonGoldenSpec ::
  forall a.
  ( Eq a
  , ToExpr a
  , NFData a
  , Typeable a
  , Aeson.ToJSON a
  , Aeson.FromJSON a
  , HasCallStack
  ) =>
  -- | Action to get the full path, usually will be @Paths_<package_name>.getDataFileName@
  (FilePath -> IO FilePath) ->
  -- | File path to the golden file relative to the root of the package
  FilePath ->
  -- | Value, which in an encoded form will be expected to produce the same contents as in the
  -- golden file.
  a ->
  Spec
aesonGoldenSpec :: forall a.
(Eq a, ToExpr a, NFData a, Typeable a, ToJSON a, FromJSON a,
 HasCallStack) =>
(String -> IO String) -> String -> a -> Spec
aesonGoldenSpec String -> IO String
mkFullPath String
goldenFileName a
a = do
  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe (TypeRep -> String
forall a. Show a => a -> String
show (a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
a)) (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    String -> (String -> IO String) -> Golden ByteString -> Spec
forall g.
(Eq g, HasCallStack) =>
String -> (String -> IO String) -> Golden g -> Spec
itGolden String
"Golden" String -> IO String
mkFullPath (Golden ByteString -> Spec) -> Golden ByteString -> Spec
forall a b. (a -> b) -> a -> b
$ String -> a -> Golden ByteString
forall a. ToJSON a => String -> a -> Golden ByteString
goldenForToJSON String
goldenFileName a
a
    String -> Property -> SpecM (Arg Property) ()
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"RoundTrip Golden Example" (Property -> SpecM (Arg Property) ())
-> Property -> SpecM (Arg Property) ()
forall a b. (a -> b) -> a -> b
$ a -> Property
forall a.
(Eq a, NFData a, ToExpr a, ToJSON a, FromJSON a, HasCallStack) =>
a -> Property
roundTripAesonProperty a
a

-- | Test Aeson roundtripping
roundTripAesonProperty ::
  forall a.
  (Eq a, NFData a, ToExpr a, Aeson.ToJSON a, Aeson.FromJSON a, HasCallStack) =>
  a ->
  Property
roundTripAesonProperty :: forall a.
(Eq a, NFData a, ToExpr a, ToJSON a, FromJSON a, HasCallStack) =>
a -> Property
roundTripAesonProperty a
expected = IO () -> Property
forall prop. Testable prop => prop -> Property
property (IO () -> Property) -> IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
  let jsonValue :: Value
jsonValue = a -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON a
expected
  -- There is no need to go through `ByteString` if we fully force the `Value`.
  produced <- Either String a -> IO a
forall a b. (HasCallStack, Show a, NFData b) => Either a b -> IO b
expectRightDeep (Either String a -> IO a) -> Either String a -> IO a
forall a b. (a -> b) -> a -> b
$ (Value -> Parser a) -> Value -> Either String a
forall a b. (a -> Parser b) -> a -> Either String b
Aeson.parseEither Value -> Parser a
forall a. FromJSON a => Value -> Parser a
Aeson.parseJSON Value
jsonValue
  produced `shouldBeExpr` expected