{-# 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.Rules (AllegraUtxoPredFailure)
import Cardano.Ledger.Allegra.Scripts (
  AllegraEraScript (..),
  Timelock (..),
  ValidityInterval (..),
  pattern RequireTimeExpire,
  pattern RequireTimeStart,
 )
import Cardano.Ledger.Shelley.Scripts (
  pattern RequireSignature,
 )

import Cardano.Ledger.Allegra.TxAuxData (AllegraTxAuxData (..))
import Cardano.Ledger.Allegra.TxBody (AllegraTxBody (AllegraTxBody))
import Cardano.Ledger.Core
import Cardano.Ledger.Shelley.API (ShelleyTxAuxData (ShelleyTxAuxData))
import Data.Maybe.Strict (StrictMaybe)
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 = forall era.
ShelleyEraScript era =>
KeyHash 'Witness (EraCrypto era) -> NativeScript era
RequireSignature forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
sizedTimelock Int
n =
  forall a. HasCallStack => [Gen a] -> Gen a
oneof forall a b. (a -> b) -> a -> b
$
    forall era. ShelleyEraScript era => Int -> [Gen (NativeScript era)]
sizedNativeScriptGens Int
n
      forall a. Semigroup a => a -> a -> a
<> [ forall era. AllegraEraScript era => SlotNo -> NativeScript era
RequireTimeStart forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
         , forall era. AllegraEraScript era => SlotNo -> NativeScript era
RequireTimeExpire forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      ShelleyTxAuxData Map Word64 Metadatum
m -> forall era.
Era era =>
Map Word64 Metadatum
-> StrictSeq (Timelock era) -> AllegraTxAuxData era
AllegraTxAuxData Map Word64 Metadatum
m 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 <- forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
3)
  [NativeScript era]
l <- forall a. Int -> Gen a -> Gen [a]
vectorOf Int
n forall a. Arbitrary a => Gen a
arbitrary
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 = forall a. (GArbitrary UnsizedOpts a, GUniformWeight a) => Gen a
genericArbitraryU

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

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

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