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

module Test.Cardano.Ledger.BaseTypesSpec (spec) where

import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Binary
import Data.Aeson
import Data.ByteString.Lazy (ByteString)
import Data.Either
import Data.GenValidity (GenValid (genValid))
import Data.GenValidity.Scientific ()
import Data.Scientific
import Data.Typeable
import Test.Cardano.Ledger.Binary.RoundTrip (roundTripCborExpectation)
import Test.Cardano.Ledger.Common
import Test.Cardano.Ledger.Core.Arbitrary ()

boundedRationalTests ::
  forall a.
  ( BoundedRational a
  , ToJSON a
  , FromJSON a
  , EncCBOR a
  , DecCBOR a
  , Arbitrary a
  , GenValid a
  , Show a
  , Ord a
  ) =>
  [(String, ByteString)] ->
  Spec
boundedRationalTests :: forall a.
(BoundedRational a, ToJSON a, FromJSON a, EncCBOR a, DecCBOR a,
 Arbitrary a, GenValid a, Show a, Ord a) =>
[(String, ByteString)] -> Spec
boundedRationalTests [(String, ByteString)]
badJSONValues = do
  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe (TypeRep -> ShowS
showsTypeRep (Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)) String
"") (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Rational roundtrip" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      String -> (a -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"(boundRational . unboundRational)" ((a -> Property) -> Spec) -> (a -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$ \(a
bi :: a) ->
        a -> Maybe a
forall a. a -> Maybe a
Just a
bi Maybe a -> Maybe a -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Rational -> Maybe a
forall r. BoundedRational r => Rational -> Maybe r
boundRational (a -> Rational
forall r. BoundedRational r => r -> Rational
unboundRational a
bi)
      String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"(unboundRational . boundRational)" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
        Gen Rational -> (Rational -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen Rational
forall a. GenValid a => Gen a
genValid ((Rational -> Property) -> Property)
-> (Rational -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Rational
r ->
          Property -> (a -> Property) -> Maybe a -> Property
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
            (Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True)
            ((Rational
r Rational -> Rational -> Property
forall a. (Eq a, Show a) => a -> a -> Property
===) (Rational -> Property) -> (a -> Rational) -> a -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rational
forall r. BoundedRational r => r -> Rational
unboundRational)
            (Rational -> Maybe a
forall r. BoundedRational r => Rational -> Maybe r
boundRational Rational
r :: Maybe a)
      String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"bounding produces valid values within bounds" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
        Gen Rational -> (Rational -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen Rational
forall a. GenValid a => Gen a
genValid ((Rational -> Property) -> Property)
-> (Rational -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Rational
r ->
          case Rational -> Maybe a
forall r. BoundedRational r => Rational -> Maybe r
boundRational Rational
r of
            Maybe a
Nothing -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
            Just (a
br :: a) ->
              [Bool] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
                [ a
forall a. Bounded a => a
minBound a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
br
                , a
br a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
forall a. Bounded a => a
maxBound
                , a -> Rational
forall r. BoundedRational r => r -> Rational
unboundRational (a
forall a. Bounded a => a
minBound :: a) Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
<= Rational
r
                , Rational
r Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
<= a -> Rational
forall r. BoundedRational r => r -> Rational
unboundRational (a
forall a. Bounded a => a
maxBound :: a)
                ]
    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"JSON" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"ToJSON/FromJSON roundtrip" (Property -> Spec) -> Property -> Spec
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
forall a. GenValid a => Gen a
genValid ((a -> Property) -> Property) -> (a -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(a
br :: a) ->
          Int -> Property -> Property
forall prop. Testable prop => Int -> prop -> Property
within Int
500000 (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
            case ByteString -> Either String a
boundedFromJSON (a -> ByteString
forall a. ToJSON a => a -> ByteString
encode a
br) of
              Left String
err -> String -> Property
forall a. HasCallStack => String -> a
error String
err
              Right (a
br' :: a) -> a -> Rational
forall r. BoundedRational r => r -> Rational
unboundRational a
br Rational -> Rational -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== a -> Rational
forall r. BoundedRational r => r -> Rational
unboundRational a
br'
      String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Roundtrip from valid Scientific and back exactly" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
        Int -> Property -> Property
forall prop. Testable prop => Int -> prop -> Property
within Int
500000 (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
          Gen Scientific -> (Scientific -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen Scientific
forall a. GenValid a => Gen a
genValid ((Scientific -> Property) -> Property)
-> (Scientific -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(Scientific
s :: Scientific) ->
            case ByteString -> Either String a
boundedFromJSON (Scientific -> ByteString
forall a. ToJSON a => a -> ByteString
encode Scientific
s) of
              Right (a
ui :: a) -> Scientific
s Scientific -> Scientific -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Rational -> Scientific
forall a. Fractional a => Rational -> a
fromRational (a -> Rational
forall r. BoundedRational r => r -> Rational
unboundRational a
ui)
              Left String
_ -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
      String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Bad Values" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
        String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Check divergence" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
          Int -> Expectation -> Property
forall prop. Testable prop => Int -> prop -> Property
within Int
500000 (Expectation -> Property) -> Expectation -> Property
forall a b. (a -> b) -> a -> b
$
            ByteString -> Either String a
boundedFromJSON ByteString
"10e1234567893456" Either String a -> (Either String a -> Bool) -> Expectation
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> Expectation
`shouldSatisfy` Either String a -> Bool
forall a b. Either a b -> Bool
isLeft
        [(String, ByteString)] -> ((String, ByteString) -> Spec) -> Spec
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(String, ByteString)]
badJSONValues (((String, ByteString) -> Spec) -> Spec)
-> ((String, ByteString) -> Spec) -> Spec
forall a b. (a -> b) -> a -> b
$ \(String
testName, ByteString
invalidInput) ->
          String -> Expectation -> SpecM (Arg Expectation) ()
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
testName (Expectation -> SpecM (Arg Expectation) ())
-> Expectation -> SpecM (Arg Expectation) ()
forall a b. (a -> b) -> a -> b
$
            ByteString -> Either String a
boundedFromJSON ByteString
invalidInput Either String a -> (Either String a -> Bool) -> Expectation
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> Expectation
`shouldSatisfy` Either String a -> Bool
forall a b. Either a b -> Bool
isLeft
    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"CBOR roundtrip" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      Gen a -> (a -> Expectation) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen a
forall a. GenValid a => Gen a
genValid ((a -> Expectation) -> Property) -> (a -> Expectation) -> Property
forall a b. (a -> b) -> a -> b
$
        \(a
br :: a) -> a -> Expectation
forall t.
(Show t, Eq t, EncCBOR t, DecCBOR t, HasCallStack) =>
t -> Expectation
roundTripCborExpectation a
br
  where
    boundedFromJSON :: ByteString -> Either String a
boundedFromJSON = ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
eitherDecode :: ByteString -> Either String a

spec :: Spec
spec :: Spec
spec = do
  let badJSONValues :: [(String, ByteString)]
badJSONValues =
        [(String
"Word64 denominator overflow", ByteString
"3.14159265358979323e-7"), (String
"Negative value", ByteString
"-1e-3")]
  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"BoundedRational" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    forall a.
(BoundedRational a, ToJSON a, FromJSON a, EncCBOR a, DecCBOR a,
 Arbitrary a, GenValid a, Show a, Ord a) =>
[(String, ByteString)] -> Spec
boundedRationalTests @UnitInterval ([(String, ByteString)] -> Spec) -> [(String, ByteString)] -> Spec
forall a b. (a -> b) -> a -> b
$ [(String, ByteString)]
badJSONValues [(String, ByteString)]
-> [(String, ByteString)] -> [(String, ByteString)]
forall a. [a] -> [a] -> [a]
++ [(String
"Too big", ByteString
"1.01")]
    forall a.
(BoundedRational a, ToJSON a, FromJSON a, EncCBOR a, DecCBOR a,
 Arbitrary a, GenValid a, Show a, Ord a) =>
[(String, ByteString)] -> Spec
boundedRationalTests @PositiveUnitInterval ([(String, ByteString)] -> Spec) -> [(String, ByteString)] -> Spec
forall a b. (a -> b) -> a -> b
$
      [(String, ByteString)]
badJSONValues [(String, ByteString)]
-> [(String, ByteString)] -> [(String, ByteString)]
forall a. [a] -> [a] -> [a]
++ [(String
"Zero", ByteString
"0"), (String
"Too big", ByteString
"1.01")]
    forall a.
(BoundedRational a, ToJSON a, FromJSON a, EncCBOR a, DecCBOR a,
 Arbitrary a, GenValid a, Show a, Ord a) =>
[(String, ByteString)] -> Spec
boundedRationalTests @PositiveInterval ([(String, ByteString)] -> Spec) -> [(String, ByteString)] -> Spec
forall a b. (a -> b) -> a -> b
$ [(String, ByteString)]
badJSONValues [(String, ByteString)]
-> [(String, ByteString)] -> [(String, ByteString)]
forall a. [a] -> [a] -> [a]
++ [(String
"Zero", ByteString
"0")]
    forall a.
(BoundedRational a, ToJSON a, FromJSON a, EncCBOR a, DecCBOR a,
 Arbitrary a, GenValid a, Show a, Ord a) =>
[(String, ByteString)] -> Spec
boundedRationalTests @NonNegativeInterval [(String, ByteString)]
badJSONValues