{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstrainedClassMethods #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Test.Cardano.Ledger.Binary.Twiddle (
  Twiddler (..),
  Twiddle (..),
  encodingToTerm,
  toTwiddler,
  toTerm,
  twiddleInvariantProp,
  emptyOrNothing,
  twiddleStrictMaybe,
)
where

import Cardano.Ledger.Binary (
  DecCBOR (..),
  EncCBOR (..),
  Encoding,
  Term (..),
  Version,
  decodeFull,
  encodeTerm,
  getDecoderVersion,
  serialize,
 )
import Data.Bitraversable (bimapM)
import Data.ByteString (ByteString)
import Data.ByteString.Lazy (fromStrict, toStrict)
import Data.Foldable (toList)
import Data.Int (Int64)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe.Strict (StrictMaybe (..))
import Data.Sequence (Seq)
import Data.Sequence.Strict (StrictSeq)
import Data.Set (Set)
import Data.Text (Text)
import qualified Data.Text.Lazy as T
import Data.Typeable (Typeable)
import Data.Void (Void, absurd)
import GHC.Generics
import Test.Cardano.Ledger.Binary.Arbitrary ()
import Test.QuickCheck (Arbitrary (..), Gen, Property, elements, oneof, shuffle, (===))

data Twiddler a = Twiddler
  { forall a. Twiddler a -> Version
twiddlerVersion :: !Version
  , forall a. Twiddler a -> a
twiddlerType :: !a
  , forall a. Twiddler a -> Term
twiddlerTerm :: Term
  }

gTwiddleTList :: forall a p. (Generic a, TwiddleL (Rep a p)) => Version -> a -> Gen Term
gTwiddleTList :: forall a p.
(Generic a, TwiddleL (Rep a p)) =>
Version -> a -> Gen Term
gTwiddleTList Version
v a
a = [Term] -> Term
TList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TwiddleL a => Version -> a -> Gen [Term]
twiddleL Version
v (forall a x. Generic a => a -> Rep a x
from @a @p a
a)

-- | Introducing random variations into the CBOR encoding of a value while
--   preserving the round-trip properties.
--
--   For any value `x :: a`, where `a` derives `Twiddle`, and for any version
--   of the decoder, the following property must hold:
--   >>> fmap ((== x) . encodingToTerm version . encCBOR) (twiddle x)
class Twiddle a where
  -- | Given a value of type `a`, generates a CBOR `Term` that can contain
  -- slight variations without changing the semantics. After encoding and
  -- decoding the `Term`, we should get back the original value that was being
  -- twiddled.
  --
  -- In addition to varying the low-level CBOR tokens, `twiddle` can also
  -- be used to introduce higher level variations. For example if the schema
  -- of a value allows a field to be either an empty list or absent
  -- entirely, and both are interpreted the same way, then `twiddle`
  -- can be used to randomly pick either of these representations.
  twiddle :: Version -> a -> Gen Term
  default twiddle :: forall p. (Generic a, TwiddleL (Rep a p)) => Version -> a -> Gen Term
  twiddle = forall a p.
(Generic a, TwiddleL (Rep a p)) =>
Version -> a -> Gen Term
gTwiddleTList @a @p

instance Twiddle a => Twiddle [a] where
  twiddle :: Version -> [a] -> Gen Term
twiddle Version
v [a]
l = do
    [Term] -> Term
f <- forall a. HasCallStack => [a] -> Gen a
elements [[Term] -> Term
TList, [Term] -> Term
TListI]
    [Term]
l' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v) [a]
l
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Term] -> Term
f [Term]
l'

instance (Twiddle k, Twiddle v) => Twiddle (Map k v) where
  twiddle :: Version -> Map k v -> Gen Term
twiddle Version
v Map k v
m = do
    -- Elements of a map do not have to be in a specific order so we shuffle them
    [(k, v)]
m' <- forall a. [a] -> Gen [a]
shuffle forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map k v
m
    [(Term, Term)]
m'' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bimapM (forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v) (forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v)) [(k, v)]
m'
    [(Term, Term)] -> Term
f <- forall a. HasCallStack => [a] -> Gen a
elements [[(Term, Term)] -> Term
TMap, [(Term, Term)] -> Term
TMapI]
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [(Term, Term)] -> Term
f [(Term, Term)]
m''

instance Twiddle ByteString where
  twiddle :: Version -> ByteString -> Gen Term
twiddle Version
_ ByteString
bs = do
    ByteString -> Term
f <- forall a. HasCallStack => [a] -> Gen a
elements [ByteString -> Term
TBytes, ByteString -> Term
TBytesI forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
fromStrict]
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ByteString -> Term
f ByteString
bs

instance Twiddle Text where
  twiddle :: Version -> Text -> Gen Term
twiddle Version
_ Text
t = do
    Text -> Term
f <- forall a. HasCallStack => [a] -> Gen a
elements [Text -> Term
TString, Text -> Term
TStringI forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.fromStrict]
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> Term
f Text
t

instance Twiddle Int where
  -- TODO: Put small ints into bigger words (e.g. a Word16 value into Word32)
  --
  -- This is not possible with the CBOR AST provided by cborg
  twiddle :: Version -> Int -> Gen Term
twiddle Version
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Term
TInt

instance (Twiddle a, Arbitrary a, EncCBOR a) => Arbitrary (Twiddler a) where
  arbitrary :: Gen (Twiddler a)
arbitrary = do
    a
x <- forall a. Arbitrary a => Gen a
arbitrary
    Version
v <- forall a. Arbitrary a => Gen a
arbitrary
    Term
enc' <- forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v a
x
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Version -> a -> Term -> Twiddler a
Twiddler Version
v a
x Term
enc'

instance Twiddle a => Twiddle (Set a) where
  twiddle :: Version -> Set a -> Gen Term
twiddle Version
v = forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

instance Twiddle a => Twiddle (Seq a) where
  twiddle :: Version -> Seq a -> Gen Term
twiddle Version
v = forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

instance Twiddle a => Twiddle (StrictSeq a) where
  twiddle :: Version -> StrictSeq a -> Gen Term
twiddle Version
v = forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

instance Typeable a => EncCBOR (Twiddler a) where
  encCBOR :: Twiddler a -> Encoding
encCBOR (Twiddler Version
_ a
_ Term
x) = Term -> Encoding
encodeTerm Term
x

instance (EncCBOR a, DecCBOR a) => DecCBOR (Twiddler a) where
  decCBOR :: forall s. Decoder s (Twiddler a)
decCBOR = do
    Version
v <- forall s. Decoder s Version
getDecoderVersion
    (\a
x -> forall a. Version -> a -> Term -> Twiddler a
Twiddler Version
v a
x forall a b. (a -> b) -> a -> b
$ forall a. EncCBOR a => Version -> a -> Term
toTerm Version
v a
x) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR

instance Show a => Show (Twiddler a) where
  show :: Twiddler a -> String
show (Twiddler Version
v a
x Term
_) = String
"Twiddler " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Version
v forall a. Semigroup a => a -> a -> a
<> String
": " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show a
x

instance Eq a => Eq (Twiddler a) where
  Twiddler Version
v1 a
x1 Term
_ == :: Twiddler a -> Twiddler a -> Bool
== Twiddler Version
v2 a
x2 Term
_ = Version
v1 forall a. Eq a => a -> a -> Bool
== Version
v2 Bool -> Bool -> Bool
&& a
x1 forall a. Eq a => a -> a -> Bool
== a
x2

class TwiddleL a where
  twiddleL :: Version -> a -> Gen [Term]

instance TwiddleL (V1 p) where
  twiddleL :: Version -> V1 p -> Gen [Term]
twiddleL Version
_ V1 p
v1 = case V1 p
v1 of {}

instance TwiddleL (U1 p) where
  twiddleL :: Version -> U1 p -> Gen [Term]
twiddleL Version
_ U1 p
U1 = forall (f :: * -> *) a. Applicative f => a -> f a
pure []

instance (TwiddleL (l x), TwiddleL (r x)) => TwiddleL ((l :*: r) x) where
  twiddleL :: Version -> (:*:) l r x -> Gen [Term]
twiddleL Version
v (l x
lx :*: r x
rx) = do
    [Term]
lx' <- forall a. TwiddleL a => Version -> a -> Gen [Term]
twiddleL Version
v l x
lx
    [Term]
rx' <- forall a. TwiddleL a => Version -> a -> Gen [Term]
twiddleL Version
v r x
rx
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Term]
lx' forall a. Semigroup a => a -> a -> a
<> [Term]
rx'

instance (TwiddleL (l x), TwiddleL (r x)) => TwiddleL ((l :+: r) x) where
  twiddleL :: Version -> (:+:) l r x -> Gen [Term]
twiddleL Version
v (L1 l x
lx) = forall a. TwiddleL a => Version -> a -> Gen [Term]
twiddleL Version
v l x
lx
  twiddleL Version
v (R1 r x
rx) = forall a. TwiddleL a => Version -> a -> Gen [Term]
twiddleL Version
v r x
rx

instance Twiddle c => TwiddleL (K1 i c p) where
  twiddleL :: Version -> K1 i c p -> Gen [Term]
twiddleL Version
v (K1 c
c) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v c
c

instance TwiddleL (f p) => TwiddleL (M1 i c f p) where
  twiddleL :: Version -> M1 i c f p -> Gen [Term]
twiddleL Version
v (M1 f p
fp) = forall a. TwiddleL a => Version -> a -> Gen [Term]
twiddleL Version
v f p
fp

instance Twiddle Integer where
  twiddle :: Version -> Integer -> Gen Term
twiddle Version
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Term
TInteger

instance Twiddle Void where
  twiddle :: Version -> Void -> Gen Term
twiddle Version
_ = forall a. Void -> a
absurd

instance Twiddle Bool where
  twiddle :: Version -> Bool -> Gen Term
twiddle Version
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Term
TBool

instance Twiddle Float where
  twiddle :: Version -> Float -> Gen Term
twiddle Version
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Term
TFloat

instance Twiddle Double where
  twiddle :: Version -> Double -> Gen Term
twiddle Version
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Term
TDouble

instance Twiddle Int64 where
  twiddle :: Version -> Int64 -> Gen Term
twiddle Version
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Term
TInt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral

instance Twiddle Term where
  twiddle :: Version -> Term -> Gen Term
twiddle Version
v (TInt Int
n) = forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v Int
n
  twiddle Version
v (TInteger Integer
n) = forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v Integer
n
  twiddle Version
v (TBytes ByteString
bs) = forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v ByteString
bs
  twiddle Version
v (TBytesI ByteString
bs) = forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
toStrict ByteString
bs
  twiddle Version
v (TString Text
txt) = forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v Text
txt
  twiddle Version
v (TStringI Text
txt) = forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v forall a b. (a -> b) -> a -> b
$ Text -> Text
T.toStrict Text
txt
  twiddle Version
v (TList [Term]
tes) = forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v [Term]
tes
  twiddle Version
v (TListI [Term]
tes) = forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v [Term]
tes
  twiddle Version
v (TMap [(Term, Term)]
x0) = forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Term, Term)]
x0
  twiddle Version
v (TMapI [(Term, Term)]
x0) = forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Term, Term)]
x0
  twiddle Version
v (TTagged Word64
wo Term
te') = Word64 -> Term -> Term
TTagged Word64
wo forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v Term
te'
  twiddle Version
v (TBool Bool
b) = forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v Bool
b
  twiddle Version
_ Term
TNull = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
TNull
  twiddle Version
_ (TSimple Word8
wo) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Word8 -> Term
TSimple Word8
wo
  twiddle Version
_ (THalf Float
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Float -> Term
THalf Float
x
  twiddle Version
v (TFloat Float
x) = forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v Float
x
  twiddle Version
v (TDouble Double
x) = forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v Double
x

encodingToTerm :: Version -> Encoding -> Term
encodingToTerm :: Version -> Encoding -> Term
encodingToTerm Version
version Encoding
enc =
  case forall a.
DecCBOR a =>
Version -> ByteString -> Either DecoderError a
decodeFull Version
version (forall a. EncCBOR a => Version -> a -> ByteString
serialize Version
version Encoding
enc) of
    Right Term
t -> Term
t
    Left DecoderError
err -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show DecoderError
err

toTerm :: EncCBOR a => Version -> a -> Term
toTerm :: forall a. EncCBOR a => Version -> a -> Term
toTerm Version
version = Version -> Encoding -> Term
encodingToTerm Version
version forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. EncCBOR a => a -> Encoding
encCBOR

-- | Wraps an arbitrary value into a `Twiddler`
toTwiddler :: Twiddle a => Version -> a -> Gen (Twiddler a)
toTwiddler :: forall a. Twiddle a => Version -> a -> Gen (Twiddler a)
toTwiddler Version
v a
x = forall a. Version -> a -> Term -> Twiddler a
Twiddler Version
v a
x forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v a
x

-- | Function for testing the invariant of a `Twiddle` instance. For a correct
-- implementation, this property should always hold.
twiddleInvariantProp :: forall a. Twiddle a => Version -> a -> Gen Property
twiddleInvariantProp :: forall a. Twiddle a => Version -> a -> Gen Property
twiddleInvariantProp Version
version a
x = do
  Term
t <- forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
version a
x
  let t' :: Term
t' = Version -> Encoding -> Term
encodingToTerm Version
version forall a b. (a -> b) -> a -> b
$ forall a. EncCBOR a => a -> Encoding
encCBOR Term
t
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Term
t forall a. (Eq a, Show a) => a -> a -> Property
=== Term
t'

-- | Optional containers have two "empty" representations. One of
-- them is to return an empty container and the other is to omit the field.
-- This utility function randomly picks one of these representations, where
-- omission is represented by `Nothing` and empty container is returned with
-- `Just`. These values can then be easily concatenated with `catMaybes`.
emptyOrNothing ::
  forall t b.
  ( Foldable t
  , Twiddle (t Void)
  , Monoid (t Void)
  , Twiddle (t b)
  ) =>
  Version ->
  t b ->
  Gen (Maybe Term)
emptyOrNothing :: forall (t :: * -> *) b.
(Foldable t, Twiddle (t Void), Monoid (t Void), Twiddle (t b)) =>
Version -> t b -> Gen (Maybe Term)
emptyOrNothing Version
v t b
x =
  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null t b
x
    then
      forall a. HasCallStack => [Gen a] -> Gen a
oneof
        [ forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Twiddle a => Version -> a -> Gen Term
twiddle @(t Void) Version
v forall a. Monoid a => a
mempty
        , forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        ]
    else forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v t b
x

-- | Utility function for twiddling optional fields. It works similarly to
-- the twiddle method of StrictMaybe, but lifts the Maybe constructor out from
-- the term so it can be easily concatenated with `catMaybes`.
twiddleStrictMaybe :: Twiddle a => Version -> StrictMaybe a -> Gen (Maybe Term)
twiddleStrictMaybe :: forall a. Twiddle a => Version -> StrictMaybe a -> Gen (Maybe Term)
twiddleStrictMaybe Version
_ StrictMaybe a
SNothing = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
twiddleStrictMaybe Version
v (SJust a
x) = forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v a
x