{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Cardano.Ledger.Binary.Arbitrary (
  genVersion,
) where

import Cardano.Ledger.Binary.Version
import qualified Codec.CBOR.ByteArray as CBOR
import Codec.CBOR.ByteArray.Sliced (SlicedByteArray (..))
import Codec.CBOR.Term
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import Data.IP (IPv4, IPv6, toIPv4w, toIPv6w)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Data.Word
import GHC.Stack
import Numeric.Half
import Test.Cardano.Base.Bytes (genByteArray, genByteString, genLazyByteString)
import Test.Data.VMap.Arbitrary ()
import Test.QuickCheck
import Test.QuickCheck.Instances ()

firstUnreservedTag :: Word64
firstUnreservedTag :: Word64
firstUnreservedTag = Word64
6

-- | Simple values that are either unassigned or don't have a specialized type already
simple :: [Word8]
simple :: [Word8]
simple = [Word8
0 .. Word8
19] [Word8] -> [Word8] -> [Word8]
forall a. [a] -> [a] -> [a]
++ [Word8
23] [Word8] -> [Word8] -> [Word8]
forall a. [a] -> [a] -> [a]
++ [Word8
32 ..]

instance Arbitrary Term where
  arbitrary :: Gen Term
arbitrary =
    [Gen Term] -> Gen Term
forall a. HasCallStack => [Gen a] -> Gen a
oneof
      [ Int -> Term
TInt (Int -> Term) -> Gen Int -> Gen Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
forall a. Bounded a => a
minBound, Int
forall a. Bounded a => a
maxBound)
      , Integer -> Term
TInteger
          (Integer -> Term) -> Gen Integer -> Gen Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Gen Integer] -> Gen Integer
forall a. HasCallStack => [Gen a] -> Gen a
oneof
            [ (Integer, Integer) -> Gen Integer
forall a. Random a => (a, a) -> Gen a
choose (Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int
forall a. Bounded a => a
maxBound :: Int) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1, Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Word64
forall a. Bounded a => a
maxBound :: Word64))
            , (Integer, Integer) -> Gen Integer
forall a. Random a => (a, a) -> Gen a
choose (Integer -> Integer
forall a. Num a => a -> a
negate (Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Word64
forall a. Bounded a => a
maxBound :: Word64)), Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int
forall a. Bounded a => a
minBound :: Int) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1)
            ]
      , ByteString -> Term
TBytes (ByteString -> Term) -> Gen ByteString -> Gen Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Gen ByteString
genByteString (Int -> Gen ByteString)
-> (NonNegative Int -> Int) -> NonNegative Int -> Gen ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonNegative Int -> Int
forall a. NonNegative a -> a
getNonNegative (NonNegative Int -> Gen ByteString)
-> Gen (NonNegative Int) -> Gen ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Gen (NonNegative Int)
forall a. Arbitrary a => Gen a
arbitrary)
      , ByteString -> Term
TBytesI (ByteString -> Term) -> Gen ByteString -> Gen Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Gen ByteString
genLazyByteString (Int -> Gen ByteString)
-> (NonNegative Int -> Int) -> NonNegative Int -> Gen ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonNegative Int -> Int
forall a. NonNegative a -> a
getNonNegative (NonNegative Int -> Gen ByteString)
-> Gen (NonNegative Int) -> Gen ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Gen (NonNegative Int)
forall a. Arbitrary a => Gen a
arbitrary)
      , Text -> Term
TString (Text -> Term) -> (String -> Text) -> String -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Term) -> Gen String -> Gen Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen String
forall a. Arbitrary a => Gen a
arbitrary
      , Text -> Term
TStringI (Text -> Term) -> (String -> Text) -> String -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
TL.pack (String -> Term) -> Gen String -> Gen Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen String
forall a. Arbitrary a => Gen a
arbitrary
      , [Term] -> Term
TList ([Term] -> Term) -> Gen [Term] -> Gen Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Term -> Gen [Term]
forall a. Gen a -> Gen [a]
listOf Gen Term
forall a. Arbitrary a => Gen a
smallerTerm
      , [Term] -> Term
TListI ([Term] -> Term) -> Gen [Term] -> Gen Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Term -> Gen [Term]
forall a. Gen a -> Gen [a]
listOf Gen Term
forall a. Arbitrary a => Gen a
smallerTerm
      , [(Term, Term)] -> Term
TMap ([(Term, Term)] -> Term) -> Gen [(Term, Term)] -> Gen Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Term, Term) -> Gen [(Term, Term)]
forall a. Gen a -> Gen [a]
listOf Gen (Term, Term)
forall a. Arbitrary a => Gen a
smallerTerm
      , [(Term, Term)] -> Term
TMapI ([(Term, Term)] -> Term) -> Gen [(Term, Term)] -> Gen Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Term, Term) -> Gen [(Term, Term)]
forall a. Gen a -> Gen [a]
listOf Gen (Term, Term)
forall a. Arbitrary a => Gen a
smallerTerm
      , Word64 -> Term -> Term
TTagged (Word64 -> Term -> Term) -> Gen Word64 -> Gen (Term -> Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
firstUnreservedTag, Word64
forall a. Bounded a => a
maxBound :: Word64) Gen (Term -> Term) -> Gen Term -> Gen Term
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Term
forall a. Arbitrary a => Gen a
smallerTerm
      , Bool -> Term
TBool (Bool -> Term) -> Gen Bool -> Gen Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Bool
forall a. Arbitrary a => Gen a
arbitrary
      , Term -> Gen Term
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
TNull
      , Word8 -> Term
TSimple (Word8 -> Term) -> Gen Word8 -> Gen Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Word8] -> Gen Word8
forall a. HasCallStack => [a] -> Gen a
elements [Word8]
simple
      , Float -> Term
THalf (Float -> Term) -> Gen Float -> Gen Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Float
genHalf
      , Float -> Term
TFloat (Float -> Term) -> Gen Float -> Gen Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Float
forall a. Arbitrary a => Gen a
arbitrary
      , Double -> Term
TDouble (Double -> Term) -> Gen Double -> Gen Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Double
forall a. Arbitrary a => Gen a
arbitrary
      ]
    where
      smallerTerm :: Arbitrary a => Gen a
      smallerTerm :: forall a. Arbitrary a => Gen a
smallerTerm = (Int -> Int) -> Gen a -> Gen a
forall a. (Int -> Int) -> Gen a -> Gen a
scale (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
5) Gen a
forall a. Arbitrary a => Gen a
arbitrary

  -- Shrinker was shamelessly stolen from cbor package.
  shrink :: Term -> [Term]
shrink (TInt Int
n) = [Int -> Term
TInt Int
n' | Int
n' <- Int -> [Int]
forall a. Arbitrary a => a -> [a]
shrink Int
n]
  shrink (TInteger Integer
n) = [Integer -> Term
TInteger Integer
n' | Integer
n' <- Integer -> [Integer]
forall a. Arbitrary a => a -> [a]
shrink Integer
n]
  shrink (TBytes ByteString
ws) = [ByteString -> Term
TBytes ([Word8] -> ByteString
BS.pack [Word8]
ws') | [Word8]
ws' <- [Word8] -> [[Word8]]
forall a. Arbitrary a => a -> [a]
shrink (ByteString -> [Word8]
BS.unpack ByteString
ws)]
  shrink (TBytesI ByteString
wss) =
    [ ByteString -> Term
TBytesI ([ByteString] -> ByteString
BSL.fromChunks (([Word8] -> ByteString) -> [[Word8]] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map [Word8] -> ByteString
BS.pack [[Word8]]
wss'))
    | [[Word8]]
wss' <- [[Word8]] -> [[[Word8]]]
forall a. Arbitrary a => a -> [a]
shrink ((ByteString -> [Word8]) -> [ByteString] -> [[Word8]]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> [Word8]
BS.unpack (ByteString -> [ByteString]
BSL.toChunks ByteString
wss))
    ]
  shrink (TString Text
cs) = [Text -> Term
TString (String -> Text
T.pack String
cs') | String
cs' <- String -> [String]
forall a. Arbitrary a => a -> [a]
shrink (Text -> String
T.unpack Text
cs)]
  shrink (TStringI Text
css) =
    [ Text -> Term
TStringI ([Text] -> Text
TL.fromChunks ((String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
T.pack [String]
css'))
    | [String]
css' <- [String] -> [[String]]
forall a. Arbitrary a => a -> [a]
shrink ((Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack (Text -> [Text]
TL.toChunks Text
css))
    ]
  shrink (TList xs :: [Term]
xs@[Term
x]) = Term
x Term -> [Term] -> [Term]
forall a. a -> [a] -> [a]
: [[Term] -> Term
TList [Term]
xs' | [Term]
xs' <- [Term] -> [[Term]]
forall a. Arbitrary a => a -> [a]
shrink [Term]
xs]
  shrink (TList [Term]
xs) = [[Term] -> Term
TList [Term]
xs' | [Term]
xs' <- [Term] -> [[Term]]
forall a. Arbitrary a => a -> [a]
shrink [Term]
xs]
  shrink (TListI xs :: [Term]
xs@[Term
x]) = Term
x Term -> [Term] -> [Term]
forall a. a -> [a] -> [a]
: [[Term] -> Term
TListI [Term]
xs' | [Term]
xs' <- [Term] -> [[Term]]
forall a. Arbitrary a => a -> [a]
shrink [Term]
xs]
  shrink (TListI [Term]
xs) = [[Term] -> Term
TListI [Term]
xs' | [Term]
xs' <- [Term] -> [[Term]]
forall a. Arbitrary a => a -> [a]
shrink [Term]
xs]
  shrink (TMap xys :: [(Term, Term)]
xys@[(Term
x, Term
y)]) = Term
x Term -> [Term] -> [Term]
forall a. a -> [a] -> [a]
: Term
y Term -> [Term] -> [Term]
forall a. a -> [a] -> [a]
: [[(Term, Term)] -> Term
TMap [(Term, Term)]
xys' | [(Term, Term)]
xys' <- [(Term, Term)] -> [[(Term, Term)]]
forall a. Arbitrary a => a -> [a]
shrink [(Term, Term)]
xys]
  shrink (TMap [(Term, Term)]
xys) = [[(Term, Term)] -> Term
TMap [(Term, Term)]
xys' | [(Term, Term)]
xys' <- [(Term, Term)] -> [[(Term, Term)]]
forall a. Arbitrary a => a -> [a]
shrink [(Term, Term)]
xys]
  shrink (TMapI xys :: [(Term, Term)]
xys@[(Term
x, Term
y)]) = Term
x Term -> [Term] -> [Term]
forall a. a -> [a] -> [a]
: Term
y Term -> [Term] -> [Term]
forall a. a -> [a] -> [a]
: [[(Term, Term)] -> Term
TMapI [(Term, Term)]
xys' | [(Term, Term)]
xys' <- [(Term, Term)] -> [[(Term, Term)]]
forall a. Arbitrary a => a -> [a]
shrink [(Term, Term)]
xys]
  shrink (TMapI [(Term, Term)]
xys) = [[(Term, Term)] -> Term
TMapI [(Term, Term)]
xys' | [(Term, Term)]
xys' <- [(Term, Term)] -> [[(Term, Term)]]
forall a. Arbitrary a => a -> [a]
shrink [(Term, Term)]
xys]
  shrink (TTagged Word64
w Term
t) =
    Term
t Term -> [Term] -> [Term]
forall a. a -> [a] -> [a]
: [Word64 -> Term -> Term
TTagged Word64
w' Term
t' | (Word64
w', Term
t') <- (Word64, Term) -> [(Word64, Term)]
forall a. Arbitrary a => a -> [a]
shrink (Word64
w, Term
t), Word64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
w' Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
firstUnreservedTag]
  shrink (TBool Bool
_) = []
  shrink Term
TNull = []
  shrink (TSimple Word8
w) = [Word8 -> Term
TSimple Word8
w' | Word8
w' <- Word8 -> [Word8]
forall a. Arbitrary a => a -> [a]
shrink Word8
w, Word8
w Word8 -> [Word8] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Word8]
simple]
  shrink (THalf Float
_f) = []
  shrink (TFloat Float
f) = [Float -> Term
TFloat Float
f' | Float
f' <- Float -> [Float]
forall a. Arbitrary a => a -> [a]
shrink Float
f]
  shrink (TDouble Double
f) = [Double -> Term
TDouble Double
f' | Double
f' <- Double -> [Double]
forall a. Arbitrary a => a -> [a]
shrink Double
f]

genHalf :: Gen Float
genHalf :: Gen Float
genHalf = do
  half <- CUShort -> Half
Half (CUShort -> Half) -> Gen CUShort -> Gen Half
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen CUShort
forall a. Arbitrary a => Gen a
arbitrary
  if isInfinite half || isDenormalized half || isNaN half
    then genHalf
    else pure $ fromHalf half

deriving instance Arbitrary CBOR.ByteArray

instance Arbitrary SlicedByteArray where
  arbitrary :: Gen SlicedByteArray
arbitrary = do
    NonNegative off <- Gen (NonNegative Int)
forall a. Arbitrary a => Gen a
arbitrary
    Positive count <- arbitrary
    NonNegative slack <- arbitrary
    let len = Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
slack
    ba <- genByteArray len
    pure $ SBA ba off count

instance Arbitrary IPv4 where
  arbitrary :: Gen IPv4
arbitrary = Word32 -> IPv4
toIPv4w (Word32 -> IPv4) -> Gen Word32 -> Gen IPv4
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Word32
forall a. Arbitrary a => Gen a
arbitrary

instance Arbitrary IPv6 where
  arbitrary :: Gen IPv6
arbitrary = do
    t <- (,,,) (Word32
 -> Word32 -> Word32 -> Word32 -> (Word32, Word32, Word32, Word32))
-> Gen Word32
-> Gen
     (Word32 -> Word32 -> Word32 -> (Word32, Word32, Word32, Word32))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Word32
forall a. Arbitrary a => Gen a
arbitrary Gen
  (Word32 -> Word32 -> Word32 -> (Word32, Word32, Word32, Word32))
-> Gen Word32
-> Gen (Word32 -> Word32 -> (Word32, Word32, Word32, Word32))
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Word32
forall a. Arbitrary a => Gen a
arbitrary Gen (Word32 -> Word32 -> (Word32, Word32, Word32, Word32))
-> Gen Word32 -> Gen (Word32 -> (Word32, Word32, Word32, Word32))
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Word32
forall a. Arbitrary a => Gen a
arbitrary Gen (Word32 -> (Word32, Word32, Word32, Word32))
-> Gen Word32 -> Gen (Word32, Word32, Word32, Word32)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Word32
forall a. Arbitrary a => Gen a
arbitrary
    pure $ toIPv6w t

instance Arbitrary Version where
  arbitrary :: Gen Version
arbitrary = HasCallStack => Version -> Version -> Gen Version
Version -> Version -> Gen Version
genVersion Version
forall a. Bounded a => a
minBound Version
forall a. Bounded a => a
maxBound

genVersion :: HasCallStack => Version -> Version -> Gen Version
genVersion :: HasCallStack => Version -> Version -> Gen Version
genVersion Version
minVersion Version
maxVersion =
  Word32 -> Word32 -> Gen Version
genVersion32 (Version -> Word32
getVersion32 Version
minVersion) (Version -> Word32
getVersion32 Version
maxVersion)
  where
    genVersion32 :: Word32 -> Word32 -> Gen Version
genVersion32 Word32
minVersion32 Word32
maxVersion32 = do
      v32 <- (Word32, Word32) -> Gen Word32
forall a. Random a => (a, a) -> Gen a
choose (Word32
minVersion32, Word32
maxVersion32)
      case mkVersion32 v32 of
        Maybe Version
Nothing -> String -> Gen Version
forall a. HasCallStack => String -> a
error (String -> Gen Version) -> String -> Gen Version
forall a b. (a -> b) -> a -> b
$ String
"Impossible: Invalid version generated: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word32 -> String
forall a. Show a => a -> String
show Word32
v32
        Just Version
v -> Version -> Gen Version
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Version
v