{-# 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 ([Term] -> Term) -> Gen [Term] -> Gen Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Version -> Rep a p -> Gen [Term]
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 <- [[Term] -> Term] -> Gen ([Term] -> Term)
forall a. HasCallStack => [a] -> Gen a
elements [[Term] -> Term
TList, [Term] -> Term
TListI]
    [Term]
l' <- (a -> Gen Term) -> [a] -> Gen [Term]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Version -> a -> Gen Term
forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v) [a]
l
    Term -> Gen Term
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> Gen Term) -> Term -> Gen Term
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' <- [(k, v)] -> Gen [(k, v)]
forall a. [a] -> Gen [a]
shuffle ([(k, v)] -> Gen [(k, v)]) -> [(k, v)] -> Gen [(k, v)]
forall a b. (a -> b) -> a -> b
$ Map k v -> [(k, v)]
forall k a. Map k a -> [(k, a)]
Map.toList Map k v
m
    [(Term, Term)]
m'' <- ((k, v) -> Gen (Term, Term)) -> [(k, v)] -> Gen [(Term, Term)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((k -> Gen Term) -> (v -> Gen Term) -> (k, v) -> Gen (Term, Term)
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 (Version -> k -> Gen Term
forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v) (Version -> v -> Gen Term
forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v)) [(k, v)]
m'
    [(Term, Term)] -> Term
f <- [[(Term, Term)] -> Term] -> Gen ([(Term, Term)] -> Term)
forall a. HasCallStack => [a] -> Gen a
elements [[(Term, Term)] -> Term
TMap, [(Term, Term)] -> Term
TMapI]
    Term -> Gen Term
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> Gen Term) -> Term -> Gen Term
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 <- [ByteString -> Term] -> Gen (ByteString -> Term)
forall a. HasCallStack => [a] -> Gen a
elements [ByteString -> Term
TBytes, ByteString -> Term
TBytesI (ByteString -> Term)
-> (ByteString -> ByteString) -> ByteString -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
fromStrict]
    Term -> Gen Term
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> Gen Term) -> Term -> Gen Term
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 <- [Text -> Term] -> Gen (Text -> Term)
forall a. HasCallStack => [a] -> Gen a
elements [Text -> Term
TString, Text -> Term
TStringI (Text -> Term) -> (Text -> Text) -> Text -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.fromStrict]
    Term -> Gen Term
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> Gen Term) -> Term -> Gen Term
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
_ = Term -> Gen Term
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> Gen Term) -> (Int -> Term) -> Int -> Gen Term
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 <- Gen a
forall a. Arbitrary a => Gen a
arbitrary
    Version
v <- Gen Version
forall a. Arbitrary a => Gen a
arbitrary
    Term
enc' <- Version -> a -> Gen Term
forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v a
x
    Twiddler a -> Gen (Twiddler a)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Twiddler a -> Gen (Twiddler a)) -> Twiddler a -> Gen (Twiddler a)
forall a b. (a -> b) -> a -> b
$ Version -> a -> Term -> Twiddler a
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 = Version -> [a] -> Gen Term
forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v ([a] -> Gen Term) -> (Set a -> [a]) -> Set a -> Gen Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set a -> [a]
forall a. Set a -> [a]
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 = Version -> [a] -> Gen Term
forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v ([a] -> Gen Term) -> (Seq a -> [a]) -> Seq a -> Gen Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq a -> [a]
forall a. Seq a -> [a]
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 = Version -> [a] -> Gen Term
forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v ([a] -> Gen Term)
-> (StrictSeq a -> [a]) -> StrictSeq a -> Gen Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictSeq a -> [a]
forall a. StrictSeq a -> [a]
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 <- Decoder s Version
forall s. Decoder s Version
getDecoderVersion
    (\a
x -> Version -> a -> Term -> Twiddler a
forall a. Version -> a -> Term -> Twiddler a
Twiddler Version
v a
x (Term -> Twiddler a) -> Term -> Twiddler a
forall a b. (a -> b) -> a -> b
$ Version -> a -> Term
forall a. EncCBOR a => Version -> a -> Term
toTerm Version
v a
x) (a -> Twiddler a) -> Decoder s a -> Decoder s (Twiddler a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s a
forall s. Decoder s a
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 " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Version -> String
forall a. Show a => a -> String
show Version
v String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
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 Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
v2 Bool -> Bool -> Bool
&& a
x1 a -> a -> Bool
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 = [Term] -> Gen [Term]
forall a. a -> Gen a
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' <- Version -> l x -> Gen [Term]
forall a. TwiddleL a => Version -> a -> Gen [Term]
twiddleL Version
v l x
lx
    [Term]
rx' <- Version -> r x -> Gen [Term]
forall a. TwiddleL a => Version -> a -> Gen [Term]
twiddleL Version
v r x
rx
    [Term] -> Gen [Term]
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Term] -> Gen [Term]) -> [Term] -> Gen [Term]
forall a b. (a -> b) -> a -> b
$ [Term]
lx' [Term] -> [Term] -> [Term]
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) = Version -> l x -> Gen [Term]
forall a. TwiddleL a => Version -> a -> Gen [Term]
twiddleL Version
v l x
lx
  twiddleL Version
v (R1 r x
rx) = Version -> r x -> Gen [Term]
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) = Term -> [Term]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> [Term]) -> Gen Term -> Gen [Term]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Version -> c -> Gen Term
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) = Version -> f p -> Gen [Term]
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
_ = Term -> Gen Term
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> Gen Term) -> (Integer -> Term) -> Integer -> Gen Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Term
TInteger

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

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

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

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

instance Twiddle Int64 where
  twiddle :: Version -> Int64 -> Gen Term
twiddle Version
_ = Term -> Gen Term
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> Gen Term) -> (Int64 -> Term) -> Int64 -> Gen Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Term
TInt (Int -> Term) -> (Int64 -> Int) -> Int64 -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Int
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) = Version -> Int -> Gen Term
forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v Int
n
  twiddle Version
v (TInteger Integer
n) = Version -> Integer -> Gen Term
forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v Integer
n
  twiddle Version
v (TBytes ByteString
bs) = Version -> ByteString -> Gen Term
forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v ByteString
bs
  twiddle Version
v (TBytesI ByteString
bs) = Version -> ByteString -> Gen Term
forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v (ByteString -> Gen Term) -> ByteString -> Gen Term
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
toStrict ByteString
bs
  twiddle Version
v (TString Text
txt) = Version -> Text -> Gen Term
forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v Text
txt
  twiddle Version
v (TStringI Text
txt) = Version -> Text -> Gen Term
forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v (Text -> Gen Term) -> Text -> Gen Term
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.toStrict Text
txt
  twiddle Version
v (TList [Term]
tes) = Version -> [Term] -> Gen Term
forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v [Term]
tes
  twiddle Version
v (TListI [Term]
tes) = Version -> [Term] -> Gen Term
forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v [Term]
tes
  twiddle Version
v (TMap [(Term, Term)]
x0) = Version -> Map Term Term -> Gen Term
forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v (Map Term Term -> Gen Term) -> Map Term Term -> Gen Term
forall a b. (a -> b) -> a -> b
$ [(Term, Term)] -> Map Term Term
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Term, Term)]
x0
  twiddle Version
v (TMapI [(Term, Term)]
x0) = Version -> Map Term Term -> Gen Term
forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v (Map Term Term -> Gen Term) -> Map Term Term -> Gen Term
forall a b. (a -> b) -> a -> b
$ [(Term, Term)] -> Map Term Term
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 (Term -> Term) -> Gen Term -> Gen Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Version -> Term -> Gen Term
forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v Term
te'
  twiddle Version
v (TBool Bool
b) = Version -> Bool -> Gen Term
forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v Bool
b
  twiddle Version
_ Term
TNull = Term -> Gen Term
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
TNull
  twiddle Version
_ (TSimple Word8
wo) = Term -> Gen Term
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> Gen Term) -> Term -> Gen Term
forall a b. (a -> b) -> a -> b
$ Word8 -> Term
TSimple Word8
wo
  twiddle Version
_ (THalf Float
x) = Term -> Gen Term
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> Gen Term) -> Term -> Gen Term
forall a b. (a -> b) -> a -> b
$ Float -> Term
THalf Float
x
  twiddle Version
v (TFloat Float
x) = Version -> Float -> Gen Term
forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v Float
x
  twiddle Version
v (TDouble Double
x) = Version -> Double -> Gen Term
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 Version -> ByteString -> Either DecoderError Term
forall a.
DecCBOR a =>
Version -> ByteString -> Either DecoderError a
decodeFull Version
version (Version -> Encoding -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
serialize Version
version Encoding
enc) of
    Right Term
t -> Term
t
    Left DecoderError
err -> String -> Term
forall a. HasCallStack => String -> a
error (String -> Term) -> String -> Term
forall a b. (a -> b) -> a -> b
$ DecoderError -> String
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 (Encoding -> Term) -> (a -> Encoding) -> a -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Encoding
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 = Version -> a -> Term -> Twiddler a
forall a. Version -> a -> Term -> Twiddler a
Twiddler Version
v a
x (Term -> Twiddler a) -> Gen Term -> Gen (Twiddler a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Version -> a -> Gen Term
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 <- Version -> a -> Gen Term
forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
version a
x
  let t' :: Term
t' = Version -> Encoding -> Term
encodingToTerm Version
version (Encoding -> Term) -> Encoding -> Term
forall a b. (a -> b) -> a -> b
$ Term -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Term
t
  Property -> Gen Property
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> Gen Property) -> Property -> Gen Property
forall a b. (a -> b) -> a -> b
$ Term
t Term -> Term -> Property
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 t b -> Bool
forall a. t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t b
x
    then
      [Gen (Maybe Term)] -> Gen (Maybe Term)
forall a. HasCallStack => [Gen a] -> Gen a
oneof
        [ Term -> Maybe Term
forall a. a -> Maybe a
Just (Term -> Maybe Term) -> Gen Term -> Gen (Maybe Term)
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 t Void
forall a. Monoid a => a
mempty
        , Maybe Term -> Gen (Maybe Term)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Term
forall a. Maybe a
Nothing
        ]
    else Term -> Maybe Term
forall a. a -> Maybe a
Just (Term -> Maybe Term) -> Gen Term -> Gen (Maybe Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Version -> t b -> Gen Term
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 = Maybe Term -> Gen (Maybe Term)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Term
forall a. Maybe a
Nothing
twiddleStrictMaybe Version
v (SJust a
x) = Term -> Maybe Term
forall a. a -> Maybe a
Just (Term -> Maybe Term) -> Gen Term -> Gen (Maybe Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Version -> a -> Gen Term
forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v a
x