{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Test.Cardano.Ledger.Shelley.Generator.ShelleyEraGen (genCoin) where

import Cardano.Ledger.BaseTypes (StrictMaybe (..))
import Cardano.Ledger.Core
import Cardano.Ledger.Shelley (ShelleyEra)
import Cardano.Ledger.Shelley.API (
  Coin (..),
  Update,
 )
import Cardano.Ledger.Shelley.Scripts (
  MultiSig,
  pattern RequireAllOf,
  pattern RequireAnyOf,
  pattern RequireMOf,
  pattern RequireSignature,
 )
import Cardano.Ledger.Shelley.TxBody (
  TxBody (..),
  Withdrawals (..),
 )
import Cardano.Ledger.Shelley.TxOut (ShelleyTxOut (..))
import Cardano.Ledger.Shelley.TxWits (ShelleyTxWits (ShelleyTxWits))
import Cardano.Ledger.Slot (SlotNo (..))
import Cardano.Ledger.TxIn (TxIn (..))
import Cardano.Ledger.Val ((<+>))
import Control.Monad (replicateM)
import Data.Foldable (toList)
import Data.Sequence.Strict (StrictSeq ((:|>)), fromList)
import Data.Set (Set)
import Lens.Micro.Extras (view)
import Test.Cardano.Ledger.Shelley.Constants (Constants (..))
import Test.Cardano.Ledger.Shelley.Generator.Core (
  GenEnv (..),
  genCoin,
  genNatural,
 )
import Test.Cardano.Ledger.Shelley.Generator.EraGen (EraGen (..), MinGenTxout (..))
import Test.Cardano.Ledger.Shelley.Generator.ScriptClass (
  Quantifier (..),
  ScriptClass (..),
 )
import Test.Cardano.Ledger.Shelley.Generator.Trace.Chain ()
import Test.Cardano.Ledger.Shelley.Generator.TxAuxData (genMetadata)
import Test.Cardano.Ledger.Shelley.Generator.Update (genPParams, genShelleyPParamsUpdate)
import Test.QuickCheck (Gen)

{------------------------------------------------------------------------------
  ShelleyEra instances for EraGen and ScriptClass
 -----------------------------------------------------------------------------}

instance EraGen ShelleyEra where
  genGenesisValue :: forall c. GenEnv c ShelleyEra -> Gen (Value ShelleyEra)
genGenesisValue
    ( GenEnv
        KeySpace c ShelleyEra
_keySpace
        ScriptSpace ShelleyEra
_scriptspace
        Constants {Integer
minGenesisOutputVal :: Integer
minGenesisOutputVal :: Constants -> Integer
minGenesisOutputVal, Integer
maxGenesisOutputVal :: Integer
maxGenesisOutputVal :: Constants -> Integer
maxGenesisOutputVal}
      ) =
      Integer -> Integer -> Gen Coin
genCoin Integer
minGenesisOutputVal Integer
maxGenesisOutputVal
  genEraTxBody :: forall c.
GenEnv c ShelleyEra
-> UTxO ShelleyEra
-> PParams ShelleyEra
-> SlotNo
-> Set TxIn
-> StrictSeq (TxOut ShelleyEra)
-> StrictSeq (TxCert ShelleyEra)
-> Withdrawals
-> Coin
-> StrictMaybe (Update ShelleyEra)
-> StrictMaybe TxAuxDataHash
-> Gen (TxBody ShelleyEra, [Script ShelleyEra])
genEraTxBody GenEnv c ShelleyEra
_ge UTxO ShelleyEra
_utxo = PParams ShelleyEra
-> SlotNo
-> Set TxIn
-> StrictSeq (TxOut ShelleyEra)
-> StrictSeq (TxCert ShelleyEra)
-> Withdrawals
-> Coin
-> StrictMaybe (Update ShelleyEra)
-> StrictMaybe TxAuxDataHash
-> Gen (TxBody ShelleyEra, [Script ShelleyEra])
PParams ShelleyEra
-> SlotNo
-> Set TxIn
-> StrictSeq (TxOut ShelleyEra)
-> StrictSeq (TxCert ShelleyEra)
-> Withdrawals
-> Coin
-> StrictMaybe (Update ShelleyEra)
-> StrictMaybe TxAuxDataHash
-> Gen (TxBody ShelleyEra, [MultiSig ShelleyEra])
genTxBody
  genEraAuxiliaryData :: Constants -> Gen (StrictMaybe (TxAuxData ShelleyEra))
genEraAuxiliaryData = Constants -> Gen (StrictMaybe (TxAuxData ShelleyEra))
Constants -> Gen (StrictMaybe (ShelleyTxAuxData ShelleyEra))
forall era.
Era era =>
Constants -> Gen (StrictMaybe (ShelleyTxAuxData era))
genMetadata

  updateEraTxBody :: UTxO ShelleyEra
-> PParams ShelleyEra
-> TxWits ShelleyEra
-> TxBody ShelleyEra
-> Coin
-> Set TxIn
-> TxOut ShelleyEra
-> TxBody ShelleyEra
updateEraTxBody UTxO ShelleyEra
_utxo PParams ShelleyEra
_pp TxWits ShelleyEra
_wits TxBody ShelleyEra
body' Coin
fee Set TxIn
ins TxOut ShelleyEra
out =
    TxBody ShelleyEra
body'
      { stbTxFee = fee
      , stbInputs = stbInputs body' <> ins
      , stbOutputs = stbOutputs body' :|> out
      }
  genEraPParamsUpdate :: Constants -> PParams ShelleyEra -> Gen (PParamsUpdate ShelleyEra)
genEraPParamsUpdate = forall era.
(ProtVerAtMost era 4, ProtVerAtMost era 6, ProtVerAtMost era 8,
 EraPParams era) =>
Constants -> PParams era -> Gen (PParamsUpdate era)
genShelleyPParamsUpdate @ShelleyEra
  genEraPParams :: Constants -> Gen (PParams ShelleyEra)
genEraPParams = Constants -> Gen (PParams ShelleyEra)
forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
Constants -> Gen (PParams era)
genPParams

  genEraTxWits :: (UTxO ShelleyEra, TxBody ShelleyEra, ScriptInfo ShelleyEra)
-> Set (WitVKey 'Witness)
-> Map ScriptHash (Script ShelleyEra)
-> TxWits ShelleyEra
genEraTxWits (UTxO ShelleyEra, TxBody ShelleyEra, ScriptInfo ShelleyEra)
_ Set (WitVKey 'Witness)
setWitVKey Map ScriptHash (Script ShelleyEra)
mapScriptWit = Set (WitVKey 'Witness)
-> Map ScriptHash (Script ShelleyEra)
-> Set BootstrapWitness
-> ShelleyTxWits ShelleyEra
forall era.
EraScript era =>
Set (WitVKey 'Witness)
-> Map ScriptHash (Script era)
-> Set BootstrapWitness
-> ShelleyTxWits era
ShelleyTxWits Set (WitVKey 'Witness)
setWitVKey Map ScriptHash (Script ShelleyEra)
mapScriptWit Set BootstrapWitness
forall a. Monoid a => a
mempty

instance ScriptClass ShelleyEra where
  basescript :: Proxy ShelleyEra -> KeyHash 'Witness -> Script ShelleyEra
basescript Proxy ShelleyEra
_proxy = KeyHash 'Witness -> Script ShelleyEra
KeyHash 'Witness -> NativeScript ShelleyEra
forall era.
ShelleyEraScript era =>
KeyHash 'Witness -> NativeScript era
RequireSignature
  isKey :: Proxy ShelleyEra -> Script ShelleyEra -> Maybe (KeyHash 'Witness)
isKey Proxy ShelleyEra
_ (RequireSignature KeyHash 'Witness
hk) = KeyHash 'Witness -> Maybe (KeyHash 'Witness)
forall a. a -> Maybe a
Just KeyHash 'Witness
hk
  isKey Proxy ShelleyEra
_ Script ShelleyEra
_ = Maybe (KeyHash 'Witness)
forall a. Maybe a
Nothing
  quantify :: Proxy ShelleyEra
-> Script ShelleyEra -> Quantifier (Script ShelleyEra)
quantify Proxy ShelleyEra
_ (RequireAllOf StrictSeq (NativeScript ShelleyEra)
xs) = [MultiSig ShelleyEra] -> Quantifier (MultiSig ShelleyEra)
forall t. [t] -> Quantifier t
AllOf (StrictSeq (MultiSig ShelleyEra) -> [MultiSig ShelleyEra]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList StrictSeq (NativeScript ShelleyEra)
StrictSeq (MultiSig ShelleyEra)
xs)
  quantify Proxy ShelleyEra
_ (RequireAnyOf StrictSeq (NativeScript ShelleyEra)
xs) = [MultiSig ShelleyEra] -> Quantifier (MultiSig ShelleyEra)
forall t. [t] -> Quantifier t
AnyOf (StrictSeq (MultiSig ShelleyEra) -> [MultiSig ShelleyEra]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList StrictSeq (NativeScript ShelleyEra)
StrictSeq (MultiSig ShelleyEra)
xs)
  quantify Proxy ShelleyEra
_ (RequireMOf Int
n StrictSeq (NativeScript ShelleyEra)
xs) = Int -> [MultiSig ShelleyEra] -> Quantifier (MultiSig ShelleyEra)
forall t. Int -> [t] -> Quantifier t
MOf Int
n (StrictSeq (MultiSig ShelleyEra) -> [MultiSig ShelleyEra]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList StrictSeq (NativeScript ShelleyEra)
StrictSeq (MultiSig ShelleyEra)
xs)
  quantify Proxy ShelleyEra
_ Script ShelleyEra
t = MultiSig ShelleyEra -> Quantifier (MultiSig ShelleyEra)
forall t. t -> Quantifier t
Leaf Script ShelleyEra
MultiSig ShelleyEra
t
  unQuantify :: Proxy ShelleyEra
-> Quantifier (Script ShelleyEra) -> Script ShelleyEra
unQuantify Proxy ShelleyEra
_ (AllOf [Script ShelleyEra]
xs) = StrictSeq (NativeScript ShelleyEra) -> NativeScript ShelleyEra
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf ([MultiSig ShelleyEra] -> StrictSeq (MultiSig ShelleyEra)
forall a. [a] -> StrictSeq a
fromList [Script ShelleyEra]
[MultiSig ShelleyEra]
xs)
  unQuantify Proxy ShelleyEra
_ (AnyOf [Script ShelleyEra]
xs) = StrictSeq (NativeScript ShelleyEra) -> NativeScript ShelleyEra
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAnyOf ([MultiSig ShelleyEra] -> StrictSeq (MultiSig ShelleyEra)
forall a. [a] -> StrictSeq a
fromList [Script ShelleyEra]
[MultiSig ShelleyEra]
xs)
  unQuantify Proxy ShelleyEra
_ (MOf Int
n [Script ShelleyEra]
xs) = Int
-> StrictSeq (NativeScript ShelleyEra) -> NativeScript ShelleyEra
forall era.
ShelleyEraScript era =>
Int -> StrictSeq (NativeScript era) -> NativeScript era
RequireMOf Int
n ([MultiSig ShelleyEra] -> StrictSeq (MultiSig ShelleyEra)
forall a. [a] -> StrictSeq a
fromList [Script ShelleyEra]
[MultiSig ShelleyEra]
xs)
  unQuantify Proxy ShelleyEra
_ (Leaf Script ShelleyEra
t) = Script ShelleyEra
t

{------------------------------------------------------------------------------
  ShelleyEra generators
 -----------------------------------------------------------------------------}

genTxBody ::
  PParams ShelleyEra ->
  SlotNo ->
  Set TxIn ->
  StrictSeq (TxOut ShelleyEra) ->
  StrictSeq (TxCert ShelleyEra) ->
  Withdrawals ->
  Coin ->
  StrictMaybe (Update ShelleyEra) ->
  StrictMaybe TxAuxDataHash ->
  Gen (TxBody ShelleyEra, [MultiSig ShelleyEra])
genTxBody :: PParams ShelleyEra
-> SlotNo
-> Set TxIn
-> StrictSeq (TxOut ShelleyEra)
-> StrictSeq (TxCert ShelleyEra)
-> Withdrawals
-> Coin
-> StrictMaybe (Update ShelleyEra)
-> StrictMaybe TxAuxDataHash
-> Gen (TxBody ShelleyEra, [MultiSig ShelleyEra])
genTxBody PParams ShelleyEra
_pparams SlotNo
slot Set TxIn
inputs StrictSeq (TxOut ShelleyEra)
outputs StrictSeq (TxCert ShelleyEra)
certs Withdrawals
withdrawals Coin
fee StrictMaybe (Update ShelleyEra)
update StrictMaybe TxAuxDataHash
adHash = do
  SlotNo
ttl <- SlotNo -> Gen SlotNo
genTimeToLive SlotNo
slot
  (TxBody ShelleyEra, [MultiSig ShelleyEra])
-> Gen (TxBody ShelleyEra, [MultiSig ShelleyEra])
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return
    ( Set TxIn
-> StrictSeq (TxOut ShelleyEra)
-> StrictSeq (TxCert ShelleyEra)
-> Withdrawals
-> Coin
-> SlotNo
-> StrictMaybe (Update ShelleyEra)
-> StrictMaybe TxAuxDataHash
-> TxBody ShelleyEra
ShelleyTxBody
        Set TxIn
inputs
        StrictSeq (TxOut ShelleyEra)
outputs
        StrictSeq (TxCert ShelleyEra)
certs
        Withdrawals
withdrawals
        Coin
fee
        SlotNo
ttl
        StrictMaybe (Update ShelleyEra)
update
        StrictMaybe TxAuxDataHash
adHash
    , [] -- Shelley does not need any additional script witnesses
    )

genTimeToLive :: SlotNo -> Gen SlotNo
genTimeToLive :: SlotNo -> Gen SlotNo
genTimeToLive SlotNo
currentSlot = do
  Natural
ttl <- Natural -> Natural -> Gen Natural
genNatural Natural
50 Natural
100
  SlotNo -> Gen SlotNo
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SlotNo -> Gen SlotNo) -> SlotNo -> Gen SlotNo
forall a b. (a -> b) -> a -> b
$ SlotNo
currentSlot SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ Word64 -> SlotNo
SlotNo (Natural -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
ttl)

instance MinGenTxout ShelleyEra where
  calcEraMinUTxO :: TxOut ShelleyEra -> PParams ShelleyEra -> Coin
calcEraMinUTxO TxOut ShelleyEra
_txout = Getting Coin (PParams ShelleyEra) Coin
-> PParams ShelleyEra -> Coin
forall a s. Getting a s a -> s -> a
view Getting Coin (PParams ShelleyEra) Coin
forall era.
(EraPParams era, ProtVerAtMost era 4) =>
Lens' (PParams era) Coin
Lens' (PParams ShelleyEra) Coin
ppMinUTxOValueL
  addValToTxOut :: Value ShelleyEra -> TxOut ShelleyEra -> TxOut ShelleyEra
addValToTxOut Value ShelleyEra
v (ShelleyTxOut Addr
a Value ShelleyEra
u) = Addr -> Value ShelleyEra -> ShelleyTxOut ShelleyEra
forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
a (Value ShelleyEra
Coin
v Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> Value ShelleyEra
Coin
u)
  genEraTxOut :: forall c.
GenEnv c ShelleyEra
-> Gen (Value ShelleyEra) -> [Addr] -> Gen [TxOut ShelleyEra]
genEraTxOut GenEnv c ShelleyEra
_genenv Gen (Value ShelleyEra)
genVal [Addr]
addrs = do
    [Coin]
values <- Int -> Gen Coin -> Gen [Coin]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([Addr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Addr]
addrs) Gen (Value ShelleyEra)
Gen Coin
genVal
    [ShelleyTxOut ShelleyEra] -> Gen [ShelleyTxOut ShelleyEra]
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Addr -> Coin -> ShelleyTxOut ShelleyEra)
-> [Addr] -> [Coin] -> [ShelleyTxOut ShelleyEra]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Addr -> Value ShelleyEra -> TxOut ShelleyEra
Addr -> Coin -> ShelleyTxOut ShelleyEra
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut [Addr]
addrs [Coin]
values)