{-# 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 (
  ShelleyTxBody (ShelleyTxBody, stbInputs, stbOutputs, stbTxFee),
  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 :: GenEnv ShelleyEra -> Gen (Value ShelleyEra)
genGenesisValue
    ( GenEnv
        KeySpace ShelleyEra
_keySpace
        ScriptSpace ShelleyEra
_scriptspace
        Constants {Integer
minGenesisOutputVal :: Constants -> Integer
minGenesisOutputVal :: Integer
minGenesisOutputVal, Integer
maxGenesisOutputVal :: Constants -> Integer
maxGenesisOutputVal :: Integer
maxGenesisOutputVal}
      ) =
      Integer -> Integer -> Gen Coin
genCoin Integer
minGenesisOutputVal Integer
maxGenesisOutputVal
  genEraTxBody :: GenEnv 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 ShelleyEra
_ge UTxO ShelleyEra
_utxo = forall era.
(EraTxOut era, EraTxCert era) =>
PParams era
-> SlotNo
-> Set TxIn
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals
-> Coin
-> StrictMaybe (Update era)
-> StrictMaybe TxAuxDataHash
-> Gen (ShelleyTxBody era, [MultiSig era])
genTxBody
  genEraAuxiliaryData :: Constants -> Gen (StrictMaybe (TxAuxData ShelleyEra))
genEraAuxiliaryData = 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 :: Coin
stbTxFee = Coin
fee
      , stbInputs :: Set TxIn
stbInputs = forall era.
(EraTxOut era, EncCBOR (TxCert era)) =>
ShelleyTxBody era -> Set TxIn
stbInputs TxBody ShelleyEra
body' forall a. Semigroup a => a -> a -> a
<> Set TxIn
ins
      , stbOutputs :: StrictSeq (TxOut ShelleyEra)
stbOutputs = forall era.
(EraTxOut era, EncCBOR (TxCert era)) =>
ShelleyTxBody era -> StrictSeq (TxOut era)
stbOutputs TxBody ShelleyEra
body' forall a. StrictSeq a -> a -> StrictSeq a
:|> TxOut ShelleyEra
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 = 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 = 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 forall a. Monoid a => a
mempty

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

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

genTxBody ::
  ( EraTxOut era
  , EraTxCert era
  ) =>
  PParams era ->
  SlotNo ->
  Set TxIn ->
  StrictSeq (TxOut era) ->
  StrictSeq (TxCert era) ->
  Withdrawals ->
  Coin ->
  StrictMaybe (Update era) ->
  StrictMaybe TxAuxDataHash ->
  Gen (ShelleyTxBody era, [MultiSig era])
genTxBody :: forall era.
(EraTxOut era, EraTxCert era) =>
PParams era
-> SlotNo
-> Set TxIn
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals
-> Coin
-> StrictMaybe (Update era)
-> StrictMaybe TxAuxDataHash
-> Gen (ShelleyTxBody era, [MultiSig era])
genTxBody PParams era
_pparams SlotNo
slot Set TxIn
inputs StrictSeq (TxOut era)
outputs StrictSeq (TxCert era)
certs Withdrawals
withdrawals Coin
fee StrictMaybe (Update era)
update StrictMaybe TxAuxDataHash
adHash = do
  SlotNo
ttl <- SlotNo -> Gen SlotNo
genTimeToLive SlotNo
slot
  forall (m :: * -> *) a. Monad m => a -> m a
return
    ( forall era.
(EraTxOut era, EncCBOR (TxCert era)) =>
Set TxIn
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals
-> Coin
-> SlotNo
-> StrictMaybe (Update era)
-> StrictMaybe TxAuxDataHash
-> ShelleyTxBody era
ShelleyTxBody
        Set TxIn
inputs
        StrictSeq (TxOut era)
outputs
        StrictSeq (TxCert era)
certs
        Withdrawals
withdrawals
        Coin
fee
        SlotNo
ttl
        StrictMaybe (Update era)
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
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ SlotNo
currentSlot forall a. Num a => a -> a -> a
+ Word64 -> SlotNo
SlotNo (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 = forall a s. Getting a s a -> s -> a
view forall era.
(EraPParams era, ProtVerAtMost era 4) =>
Lens' (PParams era) Coin
ppMinUTxOValueL
  addValToTxOut :: Value ShelleyEra -> TxOut ShelleyEra -> TxOut ShelleyEra
addValToTxOut Value ShelleyEra
v (ShelleyTxOut Addr
a Value ShelleyEra
u) = forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
a (Value ShelleyEra
v forall t. Val t => t -> t -> t
<+> Value ShelleyEra
u)
  genEraTxOut :: GenEnv ShelleyEra
-> Gen (Value ShelleyEra) -> [Addr] -> Gen [TxOut ShelleyEra]
genEraTxOut GenEnv ShelleyEra
_genenv Gen (Value ShelleyEra)
genVal [Addr]
addrs = do
    [Coin]
values <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Addr]
addrs) Gen (Value ShelleyEra)
genVal
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut [Addr]
addrs [Coin]
values)