{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Cardano.Ledger.Mary.ImpTest (
  MaryEraImp,
  module Test.Cardano.Ledger.Allegra.ImpTest,
  mkTokenMintingTx,
) where

import Cardano.Ledger.Allegra.Scripts
import Cardano.Ledger.Mary (MaryEra)
import Cardano.Ledger.Mary.Core
import Cardano.Ledger.Mary.Value
import Lens.Micro ((&), (.~))
import Test.Cardano.Ledger.Allegra.ImpTest
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Mary.Arbitrary ()
import Test.Cardano.Ledger.Mary.Era
import Test.Cardano.Ledger.Mary.TreeDiff ()

instance ShelleyEraImp MaryEra where
  impSatisfyNativeScript :: Set (KeyHash 'Witness)
-> TxBody MaryEra
-> NativeScript MaryEra
-> ImpTestM
     MaryEra (Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness)))
impSatisfyNativeScript = Set (KeyHash 'Witness)
-> TxBody MaryEra
-> NativeScript MaryEra
-> ImpTestM
     MaryEra (Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness)))
forall era.
(AllegraEraScript era, AllegraEraTxBody era) =>
Set (KeyHash 'Witness)
-> TxBody era
-> NativeScript era
-> ImpTestM era (Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness)))
impAllegraSatisfyNativeScript
  fixupTx :: HasCallStack => Tx MaryEra -> ImpTestM MaryEra (Tx MaryEra)
fixupTx = Tx MaryEra -> ImpTestM MaryEra (Tx MaryEra)
forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
shelleyFixupTx
  expectTxSuccess :: HasCallStack => Tx MaryEra -> ImpTestM MaryEra ()
expectTxSuccess = Tx MaryEra -> ImpTestM MaryEra ()
forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era -> ImpTestM era ()
impShelleyExpectTxSuccess

class
  ( ShelleyEraImp era
  , MaryEraTest era
  , NativeScript era ~ Timelock era
  , Value era ~ MaryValue
  ) =>
  MaryEraImp era

instance MaryEraImp MaryEra

mkTokenMintingTx :: MaryEraImp era => ScriptHash -> ImpTestM era (Tx era)
mkTokenMintingTx :: forall era. MaryEraImp era => ScriptHash -> ImpTestM era (Tx era)
mkTokenMintingTx ScriptHash
sh = do
  AssetName
name <- ImpM (LedgerSpec era) AssetName
forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
  Integer
count <- (Integer, Integer) -> ImpM (LedgerSpec era) Integer
forall a. Random a => (a, a) -> ImpM (LedgerSpec era) a
forall (g :: * -> *) a. (MonadGen g, Random a) => (a, a) -> g a
choose (Integer
1, Integer
10)
  let policyId :: PolicyID
policyId = ScriptHash -> PolicyID
PolicyID ScriptHash
sh
  let ma :: MultiAsset
ma = [(PolicyID, AssetName, Integer)] -> MultiAsset
multiAssetFromList [(PolicyID
policyId, AssetName
name, Integer
count)]
  Addr
addr <- ImpM (LedgerSpec era) Addr
forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadGen m) =>
m Addr
freshKeyAddr_
  Tx era -> ImpTestM era (Tx era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx era -> ImpTestM era (Tx era))
-> Tx era -> ImpTestM era (Tx era)
forall a b. (a -> b) -> a -> b
$
    TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
      Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((MultiAsset -> Identity MultiAsset)
    -> TxBody era -> Identity (TxBody era))
-> (MultiAsset -> Identity MultiAsset)
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MultiAsset -> Identity MultiAsset)
-> TxBody era -> Identity (TxBody era)
forall era. MaryEraTxBody era => Lens' (TxBody era) MultiAsset
Lens' (TxBody era) MultiAsset
mintTxBodyL ((MultiAsset -> Identity MultiAsset)
 -> Tx era -> Identity (Tx era))
-> MultiAsset -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ MultiAsset
ma
      Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
    -> TxBody era -> Identity (TxBody era))
-> (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody era -> Identity (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> Tx era -> Identity (Tx era))
-> StrictSeq (TxOut era) -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
addr (Coin -> MultiAsset -> MaryValue
MaryValue Coin
forall a. Monoid a => a
mempty MultiAsset
ma)]