{-# 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,
  roundTripCborRangeFailureExpectation,
 )
import Test.Cardano.Ledger.Common
import Test.Cardano.Ledger.Mary.Arbitrary (
  genEmptyMultiAsset,
  genMaryValue,
  genMultiAsset,
  genMultiAssetToFail,
  genMultiAssetZero,
  genNegativeInt,
 )

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

instance IsString AssetName where
  fromString :: [Char] -> AssetName
fromString = ShortByteString -> AssetName
AssetName (ShortByteString -> AssetName)
-> ([Char] -> ShortByteString) -> [Char] -> AssetName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> ShortByteString)
-> (ByteString -> ShortByteString)
-> Either [Char] ByteString
-> ShortByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Char] -> ShortByteString
forall a. HasCallStack => [Char] -> a
error ByteString -> ShortByteString
SBS.toShort (Either [Char] ByteString -> ShortByteString)
-> ([Char] -> Either [Char] ByteString)
-> [Char]
-> ShortByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either [Char] ByteString
BS16.decode (ByteString -> Either [Char] ByteString)
-> ([Char] -> ByteString) -> [Char] -> Either [Char] ByteString
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 = IO () -> Property
forall prop. Testable prop => prop -> Property
property (IO () -> Property) -> IO () -> 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
  Map PolicyID (Map AssetName Integer) -> IO ()
forall k a.
(HasCallStack, Ord k, Show k, Show a) =>
Map k a -> IO ()
expectValidMap Map PolicyID (Map AssetName Integer)
a1
  Map PolicyID (Map AssetName Integer) -> IO ()
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) =
        [MultiAsset] -> MultiAsset
forall a. Monoid a => [a] -> a
mconcat
          [ Map PolicyID (Map AssetName Integer) -> MultiAsset
MultiAsset (Map PolicyID (Map AssetName Integer) -> MultiAsset)
-> Map PolicyID (Map AssetName Integer) -> MultiAsset
forall a b. (a -> b) -> a -> b
$
              (Map AssetName Integer
 -> Map AssetName Integer -> Map AssetName Integer)
-> PolicyID
-> Map AssetName Integer
-> Map PolicyID (Map AssetName Integer)
-> Map PolicyID (Map AssetName Integer)
forall k a.
(Ord k, CanonicalZero a) =>
(a -> a -> a) -> k -> a -> Map k a -> Map k a
canonicalInsert Map AssetName Integer
-> Map AssetName Integer -> Map AssetName Integer
forall a b. a -> b -> a
const PolicyID
pid ((Integer -> Integer -> Integer)
-> AssetName
-> Integer
-> Map AssetName Integer
-> Map AssetName Integer
forall k a.
(Ord k, CanonicalZero a) =>
(a -> a -> a) -> k -> a -> Map k a -> Map k a
canonicalInsert Integer -> Integer -> Integer
forall a b. a -> b -> a
const AssetName
an Integer
i Map AssetName Integer
forall a. Monoid a => a
mempty) Map PolicyID (Map AssetName Integer)
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) =
        [MultiAsset] -> MultiAsset
forall a. Monoid a => [a] -> a
mconcat
          [ Map PolicyID (Map AssetName Integer) -> MultiAsset
MultiAsset (Map PolicyID (Map AssetName Integer) -> MultiAsset)
-> Map PolicyID (Map AssetName Integer) -> MultiAsset
forall a b. (a -> b) -> a -> b
$
              (Map AssetName Integer
 -> Map AssetName Integer -> Map AssetName Integer)
-> PolicyID
-> Map AssetName Integer
-> Map PolicyID (Map AssetName Integer)
-> Map PolicyID (Map AssetName Integer)
forall k a.
(Ord k, CanonicalZero a) =>
(a -> a -> a) -> k -> a -> Map k a -> Map k a
canonicalInsert Map AssetName Integer
-> Map AssetName Integer -> Map AssetName Integer
forall a b. a -> b -> a
const PolicyID
pid ((Integer -> Integer -> Integer)
-> AssetName
-> Integer
-> Map AssetName Integer
-> Map AssetName Integer
forall k a.
(Ord k, CanonicalZero a) =>
(a -> a -> a) -> k -> a -> Map k a -> Map k a
canonicalInsert Integer -> Integer -> Integer
forall a b. a -> b -> a
const AssetName
an Integer
i Map AssetName Integer
forall a. Monoid a => a
mempty) Map PolicyID (Map AssetName Integer)
forall a. Monoid a => a
mempty
          | (PolicyID
pid, AssetName
an, Integer
i) <- [(PolicyID, AssetName, Integer)]
ys
          ]
  Map PolicyID (Map AssetName Integer) -> IO ()
forall k a.
(HasCallStack, Ord k, Show k, Show a) =>
Map k a -> IO ()
expectValidMap Map PolicyID (Map AssetName Integer)
b1
  Map PolicyID (Map AssetName Integer) -> IO ()
forall k a.
(HasCallStack, Ord k, Show k, Show a) =>
Map k a -> IO ()
expectValidMap Map PolicyID (Map AssetName Integer)
b2
  MultiAsset
ma1 MultiAsset -> MultiAsset -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` MultiAsset
mb1
  MultiAsset
ma2 MultiAsset -> MultiAsset -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` MultiAsset
mb2
  MultiAsset
ma1 MultiAsset -> MultiAsset -> MultiAsset
forall a. Semigroup a => a -> a -> a
<> MultiAsset
ma2 MultiAsset -> MultiAsset -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` MultiAsset
mb1 MultiAsset -> MultiAsset -> MultiAsset
forall a. Semigroup a => a -> a -> a
<> MultiAsset
mb2
  MultiAsset
ma1 MultiAsset -> MultiAsset -> MultiAsset
forall a. Semigroup a => a -> a -> a
<> MultiAsset
mb2 MultiAsset -> MultiAsset -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` MultiAsset
mb1 MultiAsset -> MultiAsset -> MultiAsset
forall a. Semigroup a => a -> a -> a
<> MultiAsset
ma2