{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Cardano.Ledger.Mary.ValueSpec (spec) where

import Cardano.Ledger.BaseTypes (natVersion)
import Cardano.Ledger.Coin (Coin (Coin))
import Cardano.Ledger.Compactible (fromCompact, toCompact)
import Cardano.Ledger.Core (eraProtVerLow)
import Cardano.Ledger.Mary (MaryEra)
import Cardano.Ledger.Mary.Value
import Control.Exception (AssertionFailed (AssertionFailed), evaluate)
import qualified Data.ByteString.Base16 as BS16
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Short as SBS
import Data.CanonicalMaps (canonicalInsert)
import Data.Maybe (fromJust)
import GHC.Exts
import Test.Cardano.Data
import Test.Cardano.Ledger.Binary.RoundTrip (
  roundTripCborExpectation,
  roundTripCborFailureExpectation,
  roundTripCborRangeExpectation,
  roundTripCborRangeFailureExpectation,
 )
import Test.Cardano.Ledger.Common
import Test.Cardano.Ledger.Mary.Arbitrary (
  genEmptyMultiAsset,
  genMaryValue,
  genMultiAsset,
  genMultiAssetToFail,
  genMultiAssetZero,
  genNegativeInt,
 )

spec :: Spec
spec :: Spec
spec = do
  forall a. HasCallStack => [Char] -> SpecWith a -> SpecWith a
describe [Char]
"MultiAsset" forall a b. (a -> b) -> a -> b
$ do
    forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"Canonical construction agrees" forall a b. (a -> b) -> a -> b
$
      forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
10000 forall a b. (a -> b) -> a -> b
$
        [(PolicyID, AssetName, Integer)]
-> [(PolicyID, AssetName, Integer)] -> Property
propCanonicalConstructionAgrees
  forall a. HasCallStack => [Char] -> SpecWith a -> SpecWith a
describe [Char]
"CBOR roundtrip" forall a b. (a -> b) -> a -> b
$ do
    forall a. HasCallStack => [Char] -> SpecWith a -> SpecWith a
context [Char]
"Coin" forall a b. (a -> b) -> a -> b
$ do
      forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"Non-negative Coin succeeds for all eras" forall a b. (a -> b) -> a -> b
$
        \(NonNegative Integer
i) -> forall t.
(Show t, Eq t, EncCBOR t, DecCBOR t, HasCallStack) =>
t -> IO ()
roundTripCborExpectation (Integer -> Coin
Coin Integer
i)
      forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"Negative Coin succeeds for pre-Conway" forall a b. (a -> b) -> a -> b
$
        \(Negative Integer
i) -> forall t.
(Show t, Eq t, EncCBOR t, DecCBOR t, HasCallStack) =>
Version -> Version -> t -> IO ()
roundTripCborRangeExpectation forall a. Bounded a => a
minBound (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @8) (Integer -> Coin
Coin Integer
i)
      forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"Negative Coin fails to deserialise for Conway" forall a b. (a -> b) -> a -> b
$
        \(Negative Integer
i) -> forall t.
(EncCBOR t, DecCBOR t, Eq t, HasCallStack) =>
Version -> Version -> t -> IO ()
roundTripCborRangeFailureExpectation (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9) (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9) (Integer -> Coin
Coin Integer
i)
    forall a. HasCallStack => [Char] -> SpecWith a -> SpecWith a
context [Char]
"MultiAsset" forall a b. (a -> b) -> a -> b
$ do
      forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"Non-zero-valued MultiAsset succeeds for all eras" forall a b. (a -> b) -> a -> b
$
        forall t.
(Show t, Eq t, EncCBOR t, DecCBOR t, HasCallStack) =>
t -> IO ()
roundTripCborExpectation @MultiAsset
      forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"Zero-valued MultiAsset fails for Conway" forall a b. (a -> b) -> a -> b
$
        forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen MultiAsset
genMultiAssetZero forall a b. (a -> b) -> a -> b
$
          forall t.
(EncCBOR t, DecCBOR t, Eq t, HasCallStack) =>
Version -> Version -> t -> IO ()
roundTripCborRangeFailureExpectation (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9) forall a. Bounded a => a
maxBound
      forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"Empty MultiAsset fails for Conway" forall a b. (a -> b) -> a -> b
$
        forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen MultiAsset
genEmptyMultiAsset forall a b. (a -> b) -> a -> b
$
          forall t.
(EncCBOR t, DecCBOR t, Eq t, HasCallStack) =>
Version -> Version -> t -> IO ()
roundTripCborRangeFailureExpectation (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9) forall a. Bounded a => a
maxBound
    forall a. HasCallStack => [Char] -> SpecWith a -> SpecWith a
context [Char]
"MaryValue" forall a b. (a -> b) -> a -> b
$ do
      forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"Positive MaryValue succeeds for all eras" forall a b. (a -> b) -> a -> b
$ \(MaryValue
mv :: MaryValue) ->
        forall t.
(Show t, Eq t, EncCBOR t, DecCBOR t, HasCallStack) =>
t -> IO ()
roundTripCborExpectation MaryValue
mv
      forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"Negative MaryValue fails for all eras" forall a b. (a -> b) -> a -> b
$
        forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll
          (Gen MultiAsset -> Gen MaryValue
genMaryValue (Gen Integer -> Gen MultiAsset
genMultiAsset (forall a. Integral a => a -> Integer
toInteger forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Int
genNegativeInt)))
          forall t. (EncCBOR t, DecCBOR t, Eq t, HasCallStack) => t -> IO ()
roundTripCborFailureExpectation
      forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"Zero MaryValue fails for Conway" forall a b. (a -> b) -> a -> b
$
        forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Gen MultiAsset -> Gen MaryValue
genMaryValue Gen MultiAsset
genMultiAssetZero) forall a b. (a -> b) -> a -> b
$
          forall t.
(EncCBOR t, DecCBOR t, Eq t, HasCallStack) =>
Version -> Version -> t -> IO ()
roundTripCborRangeFailureExpectation (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9) forall a. Bounded a => a
maxBound
      forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"Empty MaryValue fails for Conway" forall a b. (a -> b) -> a -> b
$
        forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Gen MultiAsset -> Gen MaryValue
genMaryValue Gen MultiAsset
genEmptyMultiAsset) forall a b. (a -> b) -> a -> b
$
          forall t.
(EncCBOR t, DecCBOR t, Eq t, HasCallStack) =>
Version -> Version -> t -> IO ()
roundTripCborRangeFailureExpectation (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9) forall a. Bounded a => a
maxBound
      forall a.
(HasCallStack, Example a) =>
[Char] -> a -> SpecWith (Arg a)
it [Char]
"Too many assets should fail" forall a b. (a -> b) -> a -> b
$
        forall prop. Testable prop => prop -> Property
property forall a b. (a -> b) -> a -> b
$
          forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll
            (Gen MultiAsset -> Gen MaryValue
genMaryValue (Bool -> Gen MultiAsset
genMultiAssetToFail Bool
True))
            ( forall t.
(EncCBOR t, DecCBOR t, Eq t, HasCallStack) =>
Version -> Version -> t -> IO ()
roundTripCborRangeFailureExpectation @MaryValue
                (forall era. Era era => Version
eraProtVerLow @MaryEra)
                forall a. Bounded a => a
maxBound
            )
  forall a. HasCallStack => [Char] -> SpecWith a -> SpecWith a
describe [Char]
"MaryValue compacting" forall a b. (a -> b) -> a -> b
$ do
    forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"Canonical generator" forall a b. (a -> b) -> a -> b
$
      \(MaryValue
ma :: MaryValue) ->
        forall a. Compactible a => CompactForm a -> a
fromCompact (forall a. HasCallStack => Maybe a -> a
fromJust (forall a. Compactible a => a -> Maybe (CompactForm a)
toCompact MaryValue
ma)) forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` MaryValue
ma
    forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"Failing generator" forall a b. (a -> b) -> a -> b
$
      forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Gen MultiAsset -> Gen MaryValue
genMaryValue (Bool -> Gen MultiAsset
genMultiAssetToFail Bool
True)) forall a b. (a -> b) -> a -> b
$
        \MaryValue
ma ->
          forall a. a -> IO a
evaluate (forall a. Compactible a => CompactForm a -> a
fromCompact (forall a. HasCallStack => Maybe a -> a
fromJust (forall a. Compactible a => a -> Maybe (CompactForm a)
toCompact MaryValue
ma)))
            forall e a.
(HasCallStack, Exception e) =>
IO a -> Selector e -> IO ()
`shouldThrow` (\(AssertionFailed [Char]
errorMsg) -> forall a. Int -> [a] -> [a]
take Int
16 [Char]
errorMsg forall a. Eq a => a -> a -> Bool
== [Char]
"Assertion failed")

instance IsString AssetName where
  fromString :: [Char] -> AssetName
fromString = ShortByteString -> AssetName
AssetName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => [Char] -> a
error ByteString -> ShortByteString
SBS.toShort forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either [Char] ByteString
BS16.decode forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ByteString
BS8.pack

propCanonicalConstructionAgrees ::
  [(PolicyID, AssetName, Integer)] ->
  [(PolicyID, AssetName, Integer)] ->
  Property
propCanonicalConstructionAgrees :: [(PolicyID, AssetName, Integer)]
-> [(PolicyID, AssetName, Integer)] -> Property
propCanonicalConstructionAgrees [(PolicyID, AssetName, Integer)]
xs [(PolicyID, AssetName, Integer)]
ys = forall prop. Testable prop => prop -> Property
property forall a b. (a -> b) -> a -> b
$ do
  let ma1 :: MultiAsset
ma1@(MultiAsset Map PolicyID (Map AssetName Integer)
a1) = [(PolicyID, AssetName, Integer)] -> MultiAsset
multiAssetFromList [(PolicyID, AssetName, Integer)]
xs
      ma2 :: MultiAsset
ma2@(MultiAsset Map PolicyID (Map AssetName Integer)
a2) = [(PolicyID, AssetName, Integer)] -> MultiAsset
multiAssetFromList [(PolicyID, AssetName, Integer)]
ys
  forall k a.
(HasCallStack, Ord k, Show k, Show a) =>
Map k a -> IO ()
expectValidMap Map PolicyID (Map AssetName Integer)
a1
  forall k a.
(HasCallStack, Ord k, Show k, Show a) =>
Map k a -> IO ()
expectValidMap Map PolicyID (Map AssetName Integer)
a2
  let mb1 :: MultiAsset
mb1@(MultiAsset Map PolicyID (Map AssetName Integer)
b1) =
        forall a. Monoid a => [a] -> a
mconcat
          [ Map PolicyID (Map AssetName Integer) -> MultiAsset
MultiAsset forall a b. (a -> b) -> a -> b
$
              forall k a.
(Ord k, CanonicalZero a) =>
(a -> a -> a) -> k -> a -> Map k a -> Map k a
canonicalInsert forall a b. a -> b -> a
const PolicyID
pid (forall k a.
(Ord k, CanonicalZero a) =>
(a -> a -> a) -> k -> a -> Map k a -> Map k a
canonicalInsert forall a b. a -> b -> a
const AssetName
an Integer
i forall a. Monoid a => a
mempty) forall a. Monoid a => a
mempty
          | (PolicyID
pid, AssetName
an, Integer
i) <- [(PolicyID, AssetName, Integer)]
xs
          ]
      mb2 :: MultiAsset
mb2@(MultiAsset Map PolicyID (Map AssetName Integer)
b2) =
        forall a. Monoid a => [a] -> a
mconcat
          [ Map PolicyID (Map AssetName Integer) -> MultiAsset
MultiAsset forall a b. (a -> b) -> a -> b
$
              forall k a.
(Ord k, CanonicalZero a) =>
(a -> a -> a) -> k -> a -> Map k a -> Map k a
canonicalInsert forall a b. a -> b -> a
const PolicyID
pid (forall k a.
(Ord k, CanonicalZero a) =>
(a -> a -> a) -> k -> a -> Map k a -> Map k a
canonicalInsert forall a b. a -> b -> a
const AssetName
an Integer
i forall a. Monoid a => a
mempty) forall a. Monoid a => a
mempty
          | (PolicyID
pid, AssetName
an, Integer
i) <- [(PolicyID, AssetName, Integer)]
ys
          ]
  forall k a.
(HasCallStack, Ord k, Show k, Show a) =>
Map k a -> IO ()
expectValidMap Map PolicyID (Map AssetName Integer)
b1
  forall k a.
(HasCallStack, Ord k, Show k, Show a) =>
Map k a -> IO ()
expectValidMap Map PolicyID (Map AssetName Integer)
b2
  MultiAsset
ma1 forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` MultiAsset
mb1
  MultiAsset
ma2 forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` MultiAsset
mb2
  MultiAsset
ma1 forall a. Semigroup a => a -> a -> a
<> MultiAsset
ma2 forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` MultiAsset
mb1 forall a. Semigroup a => a -> a -> a
<> MultiAsset
mb2
  MultiAsset
ma1 forall a. Semigroup a => a -> a -> a
<> MultiAsset
mb2 forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` MultiAsset
mb1 forall a. Semigroup a => a -> a -> a
<> MultiAsset
ma2