{-# LANGUAGE DataKinds #-}
{-# LANGUAGE NumDecimals #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Chain.Common.Lovelace (
  tests,
) where

import Cardano.Chain.Common (
  LovelaceError (..),
  addLovelace,
  integerToLovelace,
  maxLovelaceVal,
  mkKnownLovelace,
  mkLovelace,
  scaleLovelace,
  subLovelace,
  unsafeGetLovelace,
 )
import Cardano.Prelude
import Data.Data (Constr, toConstr)
import Formatting (build, sformat)
import Hedgehog (Property, discover, forAll, property, (===))
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Test.Cardano.Chain.Common.Gen (genCustomLovelace, genLovelace)
import Test.Cardano.Prelude
import Test.Options (TSGroup, TSProperty, concatTSGroups, withTestsTS)

ts_prop_addLovelace :: TSProperty
ts_prop_addLovelace :: TSProperty
ts_prop_addLovelace = TestLimit -> Property -> TSProperty
withTestsTS TestLimit
1000 (Property -> TSProperty)
-> (PropertyT IO () -> Property) -> PropertyT IO () -> TSProperty
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property (PropertyT IO () -> TSProperty) -> PropertyT IO () -> TSProperty
forall a b. (a -> b) -> a -> b
$ do
  Lovelace
a <- Gen Lovelace -> PropertyT IO Lovelace
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen Lovelace
genLovelace
  let newRange :: Word64
newRange = Word64
maxLovelaceVal Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Lovelace -> Word64
unsafeGetLovelace Lovelace
a
  Lovelace
b <- Gen Lovelace -> PropertyT IO Lovelace
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen Lovelace -> PropertyT IO Lovelace)
-> Gen Lovelace -> PropertyT IO Lovelace
forall a b. (a -> b) -> a -> b
$ Word64 -> Gen Lovelace
genCustomLovelace Word64
newRange
  Either LovelaceError Lovelace -> PropertyT IO ()
forall a (m :: * -> *) b.
(Buildable a, HasCallStack, MonadTest m) =>
Either a b -> m ()
assertIsRight (Either LovelaceError Lovelace -> PropertyT IO ())
-> Either LovelaceError Lovelace -> PropertyT IO ()
forall a b. (a -> b) -> a -> b
$ Lovelace -> Lovelace -> Either LovelaceError Lovelace
addLovelace Lovelace
a Lovelace
b

prop_addLovelaceOverflow :: Property
prop_addLovelaceOverflow :: Property
prop_addLovelaceOverflow =
  HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property
    (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$ Constr -> Either LovelaceError Lovelace -> PropertyT IO ()
forall b a (m :: * -> *).
(Buildable b, Data a, HasCallStack, MonadTest m) =>
Constr -> Either a b -> m ()
assertIsLeftConstr
      Constr
dummyLovelaceOverflow
      (Lovelace -> Lovelace -> Either LovelaceError Lovelace
addLovelace (forall (n :: Nat). (KnownNat n, n <= 45000000000000000) => Lovelace
mkKnownLovelace @1) Lovelace
forall a. Bounded a => a
maxBound)

ts_prop_integerToLovelace :: TSProperty
ts_prop_integerToLovelace :: TSProperty
ts_prop_integerToLovelace = TestLimit -> Property -> TSProperty
withTestsTS TestLimit
1000 (Property -> TSProperty)
-> (PropertyT IO () -> Property) -> PropertyT IO () -> TSProperty
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property (PropertyT IO () -> TSProperty) -> PropertyT IO () -> TSProperty
forall a b. (a -> b) -> a -> b
$ do
  Integer
testInt <-
    Gen Integer -> PropertyT IO Integer
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll
      (Range Integer -> Gen Integer
forall (m :: * -> *) a. (MonadGen m, Integral a) => Range a -> m a
Gen.integral (Range Integer -> Gen Integer) -> Range Integer -> Gen Integer
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Range Integer
forall a. Integral a => a -> a -> Range a
Range.linear Integer
0 (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
maxLovelaceVal :: Integer))
  Either LovelaceError Lovelace -> PropertyT IO ()
forall a (m :: * -> *) b.
(Buildable a, HasCallStack, MonadTest m) =>
Either a b -> m ()
assertIsRight (Either LovelaceError Lovelace -> PropertyT IO ())
-> Either LovelaceError Lovelace -> PropertyT IO ()
forall a b. (a -> b) -> a -> b
$ Integer -> Either LovelaceError Lovelace
integerToLovelace Integer
testInt

prop_integerToLovelaceTooLarge :: Property
prop_integerToLovelaceTooLarge :: Property
prop_integerToLovelaceTooLarge =
  HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property
    (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$ Constr -> Either LovelaceError Lovelace -> PropertyT IO ()
forall b a (m :: * -> *).
(Buildable b, Data a, HasCallStack, MonadTest m) =>
Constr -> Either a b -> m ()
assertIsLeftConstr
      Constr
dummyLovelaceTooLarge
      (Integer -> Either LovelaceError Lovelace
integerToLovelace (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
maxLovelaceVal Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1) :: Integer))

prop_integerToLovelaceTooSmall :: Property
prop_integerToLovelaceTooSmall :: Property
prop_integerToLovelaceTooSmall =
  HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property
    (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$ Constr -> Either LovelaceError Lovelace -> PropertyT IO ()
forall b a (m :: * -> *).
(Buildable b, Data a, HasCallStack, MonadTest m) =>
Constr -> Either a b -> m ()
assertIsLeftConstr Constr
dummyLovelaceTooSmall (Integer -> Either LovelaceError Lovelace
integerToLovelace (Integer -> Integer
forall a. Num a => a -> a
negate Integer
1))

prop_maxLovelaceUnchanged :: Property
prop_maxLovelaceUnchanged :: Property
prop_maxLovelaceUnchanged =
  HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$ (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
maxLovelaceVal :: Integer) Integer -> Integer -> PropertyT IO ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== Integer
45e15

ts_prop_mkLovelace :: TSProperty
ts_prop_mkLovelace :: TSProperty
ts_prop_mkLovelace = TestLimit -> Property -> TSProperty
withTestsTS TestLimit
1000 (Property -> TSProperty)
-> (PropertyT IO () -> Property) -> PropertyT IO () -> TSProperty
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property (PropertyT IO () -> TSProperty) -> PropertyT IO () -> TSProperty
forall a b. (a -> b) -> a -> b
$ do
  Word64
testWrd <- Gen Word64 -> PropertyT IO Word64
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Range Word64 -> Gen Word64
forall (m :: * -> *). MonadGen m => Range Word64 -> m Word64
Gen.word64 (Range Word64 -> Gen Word64) -> Range Word64 -> Gen Word64
forall a b. (a -> b) -> a -> b
$ Word64 -> Word64 -> Range Word64
forall a. Integral a => a -> a -> Range a
Range.linear Word64
0 Word64
maxLovelaceVal)
  Either LovelaceError Lovelace -> PropertyT IO ()
forall a (m :: * -> *) b.
(Buildable a, HasCallStack, MonadTest m) =>
Either a b -> m ()
assertIsRight (Either LovelaceError Lovelace -> PropertyT IO ())
-> Either LovelaceError Lovelace -> PropertyT IO ()
forall a b. (a -> b) -> a -> b
$ Word64 -> Either LovelaceError Lovelace
mkLovelace Word64
testWrd

prop_mkLovelaceTooLarge :: Property
prop_mkLovelaceTooLarge :: Property
prop_mkLovelaceTooLarge =
  HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property
    (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$ Constr -> Either LovelaceError Lovelace -> PropertyT IO ()
forall b a (m :: * -> *).
(Buildable b, Data a, HasCallStack, MonadTest m) =>
Constr -> Either a b -> m ()
assertIsLeftConstr Constr
dummyLovelaceTooLarge (Word64 -> Either LovelaceError Lovelace
mkLovelace (Word64
maxLovelaceVal Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1))

prop_scaleLovelaceTooLarge :: Property
prop_scaleLovelaceTooLarge :: Property
prop_scaleLovelaceTooLarge =
  HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property
    (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$ Constr -> Either LovelaceError Lovelace -> PropertyT IO ()
forall b a (m :: * -> *).
(Buildable b, Data a, HasCallStack, MonadTest m) =>
Constr -> Either a b -> m ()
assertIsLeftConstr
      Constr
dummyLovelaceTooLarge
      (Lovelace -> Integer -> Either LovelaceError Lovelace
forall b.
Integral b =>
Lovelace -> b -> Either LovelaceError Lovelace
scaleLovelace Lovelace
forall a. Bounded a => a
maxBound (Integer
2 :: Integer))

ts_prop_subLovelace :: TSProperty
ts_prop_subLovelace :: TSProperty
ts_prop_subLovelace = TestLimit -> Property -> TSProperty
withTestsTS TestLimit
1000 (Property -> TSProperty)
-> (PropertyT IO () -> Property) -> PropertyT IO () -> TSProperty
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property (PropertyT IO () -> TSProperty) -> PropertyT IO () -> TSProperty
forall a b. (a -> b) -> a -> b
$ do
  Lovelace
a <- Gen Lovelace -> PropertyT IO Lovelace
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen Lovelace
genLovelace
  Lovelace
b <- Gen Lovelace -> PropertyT IO Lovelace
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen Lovelace -> PropertyT IO Lovelace)
-> Gen Lovelace -> PropertyT IO Lovelace
forall a b. (a -> b) -> a -> b
$ Word64 -> Gen Lovelace
genCustomLovelace (Lovelace -> Word64
unsafeGetLovelace Lovelace
a)
  Either LovelaceError Lovelace -> PropertyT IO ()
forall a (m :: * -> *) b.
(Buildable a, HasCallStack, MonadTest m) =>
Either a b -> m ()
assertIsRight (Either LovelaceError Lovelace -> PropertyT IO ())
-> Either LovelaceError Lovelace -> PropertyT IO ()
forall a b. (a -> b) -> a -> b
$ Lovelace -> Lovelace -> Either LovelaceError Lovelace
subLovelace Lovelace
a Lovelace
b

ts_prop_subLovelaceUnderflow :: TSProperty
ts_prop_subLovelaceUnderflow :: TSProperty
ts_prop_subLovelaceUnderflow =
  TestLimit -> Property -> TSProperty
withTestsTS TestLimit
1000
    (Property -> TSProperty)
-> (PropertyT IO () -> Property) -> PropertyT IO () -> TSProperty
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property
    (PropertyT IO () -> TSProperty) -> PropertyT IO () -> TSProperty
forall a b. (a -> b) -> a -> b
$ do
      -- (maxLovelaveVal - 1) to avoid an overflow error in `addLovelace`
      -- in case expression
      Lovelace
a <- Gen Lovelace -> PropertyT IO Lovelace
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen Lovelace -> PropertyT IO Lovelace)
-> Gen Lovelace -> PropertyT IO Lovelace
forall a b. (a -> b) -> a -> b
$ Word64 -> Gen Lovelace
genCustomLovelace (Word64
maxLovelaceVal Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
1)
      case Lovelace -> Lovelace -> Either LovelaceError Lovelace
addLovelace Lovelace
a (forall (n :: Nat). (KnownNat n, n <= 45000000000000000) => Lovelace
mkKnownLovelace @1) of
        Right Lovelace
added ->
          Constr -> Either LovelaceError Lovelace -> PropertyT IO ()
forall b a (m :: * -> *).
(Buildable b, Data a, HasCallStack, MonadTest m) =>
Constr -> Either a b -> m ()
assertIsLeftConstr Constr
dummyLovelaceUnderflow (Lovelace -> Lovelace -> Either LovelaceError Lovelace
subLovelace Lovelace
a Lovelace
added)
        Left LovelaceError
err ->
          Text -> PropertyT IO ()
forall a. HasCallStack => Text -> a
panic
            (Text -> PropertyT IO ()) -> Text -> PropertyT IO ()
forall a b. (a -> b) -> a -> b
$ Format Text (LovelaceError -> Text) -> LovelaceError -> Text
forall a. Format Text a -> a
sformat
              (Format (LovelaceError -> Text) (LovelaceError -> Text)
"The impossible happened in subLovelaceUnderflow: " Format (LovelaceError -> Text) (LovelaceError -> Text)
-> Format Text (LovelaceError -> Text)
-> Format Text (LovelaceError -> Text)
forall b c a. Format b c -> Format a b -> Format a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format Text (LovelaceError -> Text)
forall a r. Buildable a => Format r (a -> r)
build)
              LovelaceError
err

tests :: TSGroup
tests :: TSGroup
tests = [TSGroup] -> TSGroup
concatTSGroups [Group -> TSGroup
forall a b. a -> b -> a
const $$String
[(PropertyName, Property)]
Property
String -> GroupName
String -> PropertyName
GroupName -> [(PropertyName, Property)] -> Group
prop_addLovelaceOverflow :: Property
prop_integerToLovelaceTooLarge :: Property
prop_integerToLovelaceTooSmall :: Property
prop_maxLovelaceUnchanged :: Property
prop_mkLovelaceTooLarge :: Property
prop_scaleLovelaceTooLarge :: Property
discover, $$discoverPropArg]

--------------------------------------------------------------------------------
-- Dummy values for constructor comparison in assertIsLeftConstr tests
--------------------------------------------------------------------------------

dummyLovelaceOverflow :: Constr
dummyLovelaceOverflow :: Constr
dummyLovelaceOverflow = LovelaceError -> Constr
forall a. Data a => a -> Constr
toConstr (LovelaceError -> Constr) -> LovelaceError -> Constr
forall a b. (a -> b) -> a -> b
$ Word64 -> LovelaceError
LovelaceOverflow Word64
1

dummyLovelaceTooLarge :: Constr
dummyLovelaceTooLarge :: Constr
dummyLovelaceTooLarge = LovelaceError -> Constr
forall a. Data a => a -> Constr
toConstr (LovelaceError -> Constr) -> LovelaceError -> Constr
forall a b. (a -> b) -> a -> b
$ Integer -> LovelaceError
LovelaceTooLarge Integer
1

dummyLovelaceTooSmall :: Constr
dummyLovelaceTooSmall :: Constr
dummyLovelaceTooSmall = LovelaceError -> Constr
forall a. Data a => a -> Constr
toConstr (LovelaceError -> Constr) -> LovelaceError -> Constr
forall a b. (a -> b) -> a -> b
$ Integer -> LovelaceError
LovelaceTooSmall Integer
1

dummyLovelaceUnderflow :: Constr
dummyLovelaceUnderflow :: Constr
dummyLovelaceUnderflow = LovelaceError -> Constr
forall a. Data a => a -> Constr
toConstr (LovelaceError -> Constr) -> LovelaceError -> Constr
forall a b. (a -> b) -> a -> b
$ Word64 -> Word64 -> LovelaceError
LovelaceUnderflow Word64
1 Word64
1