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

module Test.Cardano.Binary.Arbitrary () where

import qualified Codec.CBOR.ByteArray as CBOR
import qualified Codec.CBOR.ByteArray.Sliced as CBOR
import Codec.CBOR.Term
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Data.Word
import Numeric.Half
import Test.Cardano.Base.Bytes (genByteArray, genByteString, genLazyByteString)
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 ..]

genHalf :: Gen Float
genHalf :: Gen Float
genHalf = do
  Half
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 Half -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Half
half Bool -> Bool -> Bool
|| Half -> Bool
forall a. RealFloat a => a -> Bool
isDenormalized Half
half Bool -> Bool -> Bool
|| Half -> Bool
forall a. RealFloat a => a -> Bool
isNaN Half
half
    then Gen Float
genHalf
    else Float -> Gen Float
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Float -> Gen Float) -> Float -> Gen Float
forall a b. (a -> b) -> a -> b
$ Half -> Float
fromHalf Half
half

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]

deriving instance Arbitrary CBOR.ByteArray

instance Arbitrary CBOR.SlicedByteArray where
  arbitrary :: Gen SlicedByteArray
arbitrary = do
    NonNegative Int
off <- Gen (NonNegative Int)
forall a. Arbitrary a => Gen a
arbitrary
    Positive Int
count <- Gen (Positive Int)
forall a. Arbitrary a => Gen a
arbitrary
    NonNegative Int
slack <- Gen (NonNegative Int)
forall a. Arbitrary a => Gen a
arbitrary
    let len :: Int
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
    ByteArray
ba <- Int -> Gen ByteArray
genByteArray Int
len
    SlicedByteArray -> Gen SlicedByteArray
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SlicedByteArray -> Gen SlicedByteArray)
-> SlicedByteArray -> Gen SlicedByteArray
forall a b. (a -> b) -> a -> b
$ ByteArray -> Int -> Int -> SlicedByteArray
CBOR.SBA ByteArray
ba Int
off Int
count