{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Cardano.Ledger.Allegra.Arbitrary (
  sizedTimelock,
  maxTimelockDepth,
) where

import Cardano.Ledger.Allegra (AllegraEra)
import Cardano.Ledger.Allegra.Rules (AllegraUtxoPredFailure)
import Cardano.Ledger.Allegra.Scripts (
  AllegraEraScript (..),
  Timelock (..),
  ValidityInterval (..),
  pattern RequireTimeExpire,
  pattern RequireTimeStart,
 )
import Cardano.Ledger.Allegra.TxAuxData (AllegraTxAuxData (..))
import Cardano.Ledger.Allegra.TxBody (pattern AllegraTxBody)
import Cardano.Ledger.Core
import Cardano.Ledger.Shelley.API (ShelleyTxAuxData (ShelleyTxAuxData))
import Cardano.Ledger.Shelley.Scripts (
  pattern RequireSignature,
 )
import Data.Sequence.Strict (StrictSeq, fromList)
import Generic.Random (genericArbitraryU)
import Test.Cardano.Ledger.Shelley.Arbitrary (genMetadata', sizedNativeScriptGens)
import Test.QuickCheck (
  Arbitrary (arbitrary, shrink),
  Gen,
  choose,
  genericShrink,
  oneof,
  scale,
  vectorOf,
 )

maxTimelockDepth :: Int
maxTimelockDepth :: Int
maxTimelockDepth = Int
3

sizedTimelock ::
  AllegraEraScript era =>
  Int ->
  Gen (NativeScript era)
sizedTimelock :: forall era. AllegraEraScript era => Int -> Gen (NativeScript era)
sizedTimelock Int
0 = KeyHash 'Witness -> NativeScript era
forall era.
ShelleyEraScript era =>
KeyHash 'Witness -> NativeScript era
RequireSignature (KeyHash 'Witness -> NativeScript era)
-> Gen (KeyHash 'Witness) -> Gen (NativeScript era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (KeyHash 'Witness)
forall a. Arbitrary a => Gen a
arbitrary
sizedTimelock Int
n =
  [Gen (NativeScript era)] -> Gen (NativeScript era)
forall a. HasCallStack => [Gen a] -> Gen a
oneof ([Gen (NativeScript era)] -> Gen (NativeScript era))
-> [Gen (NativeScript era)] -> Gen (NativeScript era)
forall a b. (a -> b) -> a -> b
$
    Int -> [Gen (NativeScript era)]
forall era. ShelleyEraScript era => Int -> [Gen (NativeScript era)]
sizedNativeScriptGens Int
n
      [Gen (NativeScript era)]
-> [Gen (NativeScript era)] -> [Gen (NativeScript era)]
forall a. Semigroup a => a -> a -> a
<> [ SlotNo -> NativeScript era
forall era. AllegraEraScript era => SlotNo -> NativeScript era
RequireTimeStart (SlotNo -> NativeScript era)
-> Gen SlotNo -> Gen (NativeScript era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen SlotNo
forall a. Arbitrary a => Gen a
arbitrary
         , SlotNo -> NativeScript era
forall era. AllegraEraScript era => SlotNo -> NativeScript era
RequireTimeExpire (SlotNo -> NativeScript era)
-> Gen SlotNo -> Gen (NativeScript era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen SlotNo
forall a. Arbitrary a => Gen a
arbitrary
         ]

-- TODO Generate metadata with script preimages
instance
  forall era.
  ( AllegraEraScript era
  , NativeScript era ~ Timelock era
  , Arbitrary (Script era)
  , Era era
  ) =>
  Arbitrary (AllegraTxAuxData era)
  where
  -- Why do we use the \case instead of a do statement? like this:
  --
  -- @
  -- arbitrary = do
  --   ShelleyTxAuxData m <- genMetadata'
  --   AllegraTxAuxData m <$> genScriptSeq
  -- @
  --
  -- The above leads to an error about a failable
  -- pattern, despite the pattern being COMPLETE, resulting
  -- in an unsatisfied `MonadFail` constraint.
  arbitrary :: Gen (AllegraTxAuxData era)
arbitrary =
    forall era. Era era => Gen (ShelleyTxAuxData era)
genMetadata' @era Gen (ShelleyTxAuxData era)
-> (ShelleyTxAuxData era -> Gen (AllegraTxAuxData era))
-> Gen (AllegraTxAuxData era)
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      ShelleyTxAuxData Map Word64 Metadatum
m -> Map Word64 Metadatum
-> StrictSeq (Timelock era) -> AllegraTxAuxData era
forall era.
Era era =>
Map Word64 Metadatum
-> StrictSeq (Timelock era) -> AllegraTxAuxData era
AllegraTxAuxData Map Word64 Metadatum
m (StrictSeq (Timelock era) -> AllegraTxAuxData era)
-> Gen (StrictSeq (Timelock era)) -> Gen (AllegraTxAuxData era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall era.
Arbitrary (NativeScript era) =>
Gen (StrictSeq (NativeScript era))
genScriptSeq @era)

genScriptSeq :: Arbitrary (NativeScript era) => Gen (StrictSeq (NativeScript era))
genScriptSeq :: forall era.
Arbitrary (NativeScript era) =>
Gen (StrictSeq (NativeScript era))
genScriptSeq = do
  Int
n <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
3)
  [NativeScript era]
l <- Int -> Gen (NativeScript era) -> Gen [NativeScript era]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
n Gen (NativeScript era)
forall a. Arbitrary a => Gen a
arbitrary
  StrictSeq (NativeScript era) -> Gen (StrictSeq (NativeScript era))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([NativeScript era] -> StrictSeq (NativeScript era)
forall a. [a] -> StrictSeq a
fromList [NativeScript era]
l)

instance
  ( Era era
  , Arbitrary (Value era)
  , Arbitrary (TxOut era)
  , Arbitrary (EraRuleFailure "PPUP" era)
  ) =>
  Arbitrary (AllegraUtxoPredFailure era)
  where
  arbitrary :: Gen (AllegraUtxoPredFailure era)
arbitrary = Gen (AllegraUtxoPredFailure era)
forall a. (GArbitrary UnsizedOpts a, GUniformWeight a) => Gen a
genericArbitraryU

instance Arbitrary (TxBody AllegraEra) where
  arbitrary :: Gen (TxBody AllegraEra)
arbitrary =
    Set TxIn
-> StrictSeq (TxOut AllegraEra)
-> StrictSeq (TxCert AllegraEra)
-> Withdrawals
-> Coin
-> ValidityInterval
-> StrictMaybe (Update AllegraEra)
-> StrictMaybe TxAuxDataHash
-> TxBody AllegraEra
Set TxIn
-> StrictSeq (ShelleyTxOut AllegraEra)
-> StrictSeq (ShelleyTxCert AllegraEra)
-> Withdrawals
-> Coin
-> ValidityInterval
-> StrictMaybe (Update AllegraEra)
-> StrictMaybe TxAuxDataHash
-> TxBody AllegraEra
(EraTxOut AllegraEra, EraTxCert AllegraEra) =>
Set TxIn
-> StrictSeq (TxOut AllegraEra)
-> StrictSeq (TxCert AllegraEra)
-> Withdrawals
-> Coin
-> ValidityInterval
-> StrictMaybe (Update AllegraEra)
-> StrictMaybe TxAuxDataHash
-> TxBody AllegraEra
AllegraTxBody
      (Set TxIn
 -> StrictSeq (ShelleyTxOut AllegraEra)
 -> StrictSeq (ShelleyTxCert AllegraEra)
 -> Withdrawals
 -> Coin
 -> ValidityInterval
 -> StrictMaybe (Update AllegraEra)
 -> StrictMaybe TxAuxDataHash
 -> TxBody AllegraEra)
-> Gen (Set TxIn)
-> Gen
     (StrictSeq (ShelleyTxOut AllegraEra)
      -> StrictSeq (ShelleyTxCert AllegraEra)
      -> Withdrawals
      -> Coin
      -> ValidityInterval
      -> StrictMaybe (Update AllegraEra)
      -> StrictMaybe TxAuxDataHash
      -> TxBody AllegraEra)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Set TxIn)
forall a. Arbitrary a => Gen a
arbitrary
      Gen
  (StrictSeq (ShelleyTxOut AllegraEra)
   -> StrictSeq (ShelleyTxCert AllegraEra)
   -> Withdrawals
   -> Coin
   -> ValidityInterval
   -> StrictMaybe (Update AllegraEra)
   -> StrictMaybe TxAuxDataHash
   -> TxBody AllegraEra)
-> Gen (StrictSeq (ShelleyTxOut AllegraEra))
-> Gen
     (StrictSeq (ShelleyTxCert AllegraEra)
      -> Withdrawals
      -> Coin
      -> ValidityInterval
      -> StrictMaybe (Update AllegraEra)
      -> StrictMaybe TxAuxDataHash
      -> TxBody AllegraEra)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (StrictSeq (ShelleyTxOut AllegraEra))
forall a. Arbitrary a => Gen a
arbitrary
      Gen
  (StrictSeq (ShelleyTxCert AllegraEra)
   -> Withdrawals
   -> Coin
   -> ValidityInterval
   -> StrictMaybe (Update AllegraEra)
   -> StrictMaybe TxAuxDataHash
   -> TxBody AllegraEra)
-> Gen (StrictSeq (ShelleyTxCert AllegraEra))
-> Gen
     (Withdrawals
      -> Coin
      -> ValidityInterval
      -> StrictMaybe (Update AllegraEra)
      -> StrictMaybe TxAuxDataHash
      -> TxBody AllegraEra)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (StrictSeq (ShelleyTxCert AllegraEra))
forall a. Arbitrary a => Gen a
arbitrary
      Gen
  (Withdrawals
   -> Coin
   -> ValidityInterval
   -> StrictMaybe (Update AllegraEra)
   -> StrictMaybe TxAuxDataHash
   -> TxBody AllegraEra)
-> Gen Withdrawals
-> Gen
     (Coin
      -> ValidityInterval
      -> StrictMaybe (Update AllegraEra)
      -> StrictMaybe TxAuxDataHash
      -> TxBody AllegraEra)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Withdrawals
forall a. Arbitrary a => Gen a
arbitrary
      Gen
  (Coin
   -> ValidityInterval
   -> StrictMaybe (Update AllegraEra)
   -> StrictMaybe TxAuxDataHash
   -> TxBody AllegraEra)
-> Gen Coin
-> Gen
     (ValidityInterval
      -> StrictMaybe (Update AllegraEra)
      -> StrictMaybe TxAuxDataHash
      -> TxBody AllegraEra)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Coin
forall a. Arbitrary a => Gen a
arbitrary
      Gen
  (ValidityInterval
   -> StrictMaybe (Update AllegraEra)
   -> StrictMaybe TxAuxDataHash
   -> TxBody AllegraEra)
-> Gen ValidityInterval
-> Gen
     (StrictMaybe (Update AllegraEra)
      -> StrictMaybe TxAuxDataHash -> TxBody AllegraEra)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen ValidityInterval
forall a. Arbitrary a => Gen a
arbitrary
      Gen
  (StrictMaybe (Update AllegraEra)
   -> StrictMaybe TxAuxDataHash -> TxBody AllegraEra)
-> Gen (StrictMaybe (Update AllegraEra))
-> Gen (StrictMaybe TxAuxDataHash -> TxBody AllegraEra)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Int -> Int)
-> Gen (StrictMaybe (Update AllegraEra))
-> Gen (StrictMaybe (Update AllegraEra))
forall a. (Int -> Int) -> Gen a -> Gen a
scale (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
15) Gen (StrictMaybe (Update AllegraEra))
forall a. Arbitrary a => Gen a
arbitrary
      Gen (StrictMaybe TxAuxDataHash -> TxBody AllegraEra)
-> Gen (StrictMaybe TxAuxDataHash) -> Gen (TxBody AllegraEra)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (StrictMaybe TxAuxDataHash)
forall a. Arbitrary a => Gen a
arbitrary

instance
  ( AllegraEraScript era
  , NativeScript era ~ Timelock era
  ) =>
  Arbitrary (Timelock era)
  where
  arbitrary :: Gen (Timelock era)
arbitrary = Int -> Gen (NativeScript era)
forall era. AllegraEraScript era => Int -> Gen (NativeScript era)
sizedTimelock Int
maxTimelockDepth

instance Arbitrary ValidityInterval where
  arbitrary :: Gen ValidityInterval
arbitrary = Gen ValidityInterval
forall a. (GArbitrary UnsizedOpts a, GUniformWeight a) => Gen a
genericArbitraryU
  shrink :: ValidityInterval -> [ValidityInterval]
shrink = ValidityInterval -> [ValidityInterval]
forall a.
(Generic a, RecursivelyShrink (Rep a), GSubterms (Rep a) a) =>
a -> [a]
genericShrink