{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Cardano.Ledger.Allegra.ImpTest (
  impAllegraSatisfyNativeScript,
  module Test.Cardano.Ledger.Shelley.ImpTest,
) where

import Cardano.Ledger.Allegra (AllegraEra)
import Cardano.Ledger.Allegra.Core
import Cardano.Ledger.Allegra.Scripts (
  AllegraEraScript,
  Timelock,
  evalTimelock,
  pattern RequireTimeExpire,
  pattern RequireTimeStart,
 )
import Cardano.Ledger.Shelley.Scripts (
  pattern RequireAllOf,
  pattern RequireAnyOf,
  pattern RequireMOf,
  pattern RequireSignature,
 )
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Lens.Micro ((^.))
import Test.Cardano.Ledger.Allegra.Era ()
import Test.Cardano.Ledger.Allegra.TreeDiff ()
import Test.Cardano.Ledger.Imp.Common (KeyPair (..), choose, frequency)
import Test.Cardano.Ledger.Shelley.ImpTest

instance ShelleyEraImp AllegraEra where
  impSatisfyNativeScript :: forall (l :: TxLevel).
Set (KeyHash Witness)
-> TxBody l AllegraEra
-> NativeScript AllegraEra
-> ImpTestM
     AllegraEra (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
impSatisfyNativeScript = Set (KeyHash Witness)
-> TxBody l AllegraEra
-> NativeScript AllegraEra
-> ImpTestM
     AllegraEra (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
forall era (l :: TxLevel).
(ShelleyEraImp era, AllegraEraScript era, AllegraEraTxBody era,
 NativeScript era ~ Timelock era) =>
Set (KeyHash Witness)
-> TxBody l era
-> NativeScript era
-> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
impAllegraSatisfyNativeScript

  fixupTx :: HasCallStack =>
Tx TopTx AllegraEra -> ImpTestM AllegraEra (Tx TopTx AllegraEra)
fixupTx = Tx TopTx AllegraEra -> ImpTestM AllegraEra (Tx TopTx AllegraEra)
forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
shelleyFixupTx
  expectTxSuccess :: HasCallStack => Tx TopTx AllegraEra -> ImpTestM AllegraEra ()
expectTxSuccess = Tx TopTx AllegraEra -> ImpTestM AllegraEra ()
forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx TopTx era -> ImpTestM era ()
impShelleyExpectTxSuccess
  modifyImpInitProtVer :: ShelleyEraImp AllegraEra =>
Version
-> SpecWith (ImpInit (LedgerSpec AllegraEra))
-> SpecWith (ImpInit (LedgerSpec AllegraEra))
modifyImpInitProtVer = Version
-> SpecWith (ImpInit (LedgerSpec AllegraEra))
-> SpecWith (ImpInit (LedgerSpec AllegraEra))
forall era.
ShelleyEraImp era =>
Version
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
shelleyModifyImpInitProtVer
  genRegTxCert :: Credential Staking -> ImpTestM AllegraEra (TxCert AllegraEra)
genRegTxCert = Credential Staking -> ImpTestM AllegraEra (TxCert AllegraEra)
forall era.
ShelleyEraTxCert era =>
Credential Staking -> ImpTestM era (TxCert era)
shelleyGenRegTxCert
  genUnRegTxCert :: Credential Staking -> ImpTestM AllegraEra (TxCert AllegraEra)
genUnRegTxCert = Credential Staking -> ImpTestM AllegraEra (TxCert AllegraEra)
forall era.
ShelleyEraTxCert era =>
Credential Staking -> ImpTestM era (TxCert era)
shelleyGenUnRegTxCert
  delegStakeTxCert :: Credential Staking -> KeyHash StakePool -> TxCert AllegraEra
delegStakeTxCert = Credential Staking -> KeyHash StakePool -> TxCert AllegraEra
forall era.
ShelleyEraTxCert era =>
Credential Staking -> KeyHash StakePool -> TxCert era
shelleyDelegStakeTxCert

impAllegraSatisfyNativeScript ::
  ( ShelleyEraImp era
  , AllegraEraScript era
  , AllegraEraTxBody era
  , NativeScript era ~ Timelock era
  ) =>
  Set.Set (KeyHash Witness) ->
  TxBody l era ->
  NativeScript era ->
  ImpTestM era (Maybe (Map.Map (KeyHash Witness) (KeyPair Witness)))
impAllegraSatisfyNativeScript :: forall era (l :: TxLevel).
(ShelleyEraImp era, AllegraEraScript era, AllegraEraTxBody era,
 NativeScript era ~ Timelock era) =>
Set (KeyHash Witness)
-> TxBody l era
-> NativeScript era
-> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
impAllegraSatisfyNativeScript Set (KeyHash Witness)
providedVKeyHashes TxBody l era
txBody NativeScript era
script = do
  let vi :: ValidityInterval
vi = TxBody l era
txBody TxBody l era
-> Getting ValidityInterval (TxBody l era) ValidityInterval
-> ValidityInterval
forall s a. s -> Getting a s a -> a
^. Getting ValidityInterval (TxBody l era) ValidityInterval
forall era (l :: TxLevel).
AllegraEraTxBody era =>
Lens' (TxBody l era) ValidityInterval
forall (l :: TxLevel). Lens' (TxBody l era) ValidityInterval
vldtTxBodyL
  case NativeScript era
script of
    RequireSignature KeyHash Witness
keyHash -> KeyHash Witness
-> Set (KeyHash Witness)
-> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
forall era.
KeyHash Witness
-> Set (KeyHash Witness)
-> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
impSatisfySignature KeyHash Witness
keyHash Set (KeyHash Witness)
providedVKeyHashes
    RequireAllOf StrictSeq (NativeScript era)
ss -> Set (KeyHash Witness)
-> TxBody l era
-> Int
-> StrictSeq (NativeScript era)
-> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
forall era (l :: TxLevel).
ShelleyEraImp era =>
Set (KeyHash Witness)
-> TxBody l era
-> Int
-> StrictSeq (NativeScript era)
-> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
impSatisfyMNativeScripts Set (KeyHash Witness)
providedVKeyHashes TxBody l era
txBody (StrictSeq (Timelock era) -> Int
forall a. StrictSeq a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length StrictSeq (Timelock era)
StrictSeq (NativeScript era)
ss) StrictSeq (NativeScript era)
ss
    RequireAnyOf StrictSeq (NativeScript era)
ss -> do
      m <- [(Int, ImpM (LedgerSpec era) Int)] -> ImpM (LedgerSpec era) Int
forall (m :: * -> *) a. MonadGen m => [(Int, m a)] -> m a
frequency [(Int
9, Int -> ImpM (LedgerSpec era) Int
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
1), (Int
1, (Int, Int) -> ImpM (LedgerSpec era) Int
forall a. Random a => (a, a) -> ImpM (LedgerSpec era) a
forall (g :: * -> *) a. (MonadGen g, Random a) => (a, a) -> g a
choose (Int
1, StrictSeq (Timelock era) -> Int
forall a. StrictSeq a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length StrictSeq (Timelock era)
StrictSeq (NativeScript era)
ss))]
      impSatisfyMNativeScripts providedVKeyHashes txBody m ss
    RequireMOf Int
m StrictSeq (NativeScript era)
ss -> Set (KeyHash Witness)
-> TxBody l era
-> Int
-> StrictSeq (NativeScript era)
-> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
forall era (l :: TxLevel).
ShelleyEraImp era =>
Set (KeyHash Witness)
-> TxBody l era
-> Int
-> StrictSeq (NativeScript era)
-> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
impSatisfyMNativeScripts Set (KeyHash Witness)
providedVKeyHashes TxBody l era
txBody Int
m StrictSeq (NativeScript era)
ss
    lock :: NativeScript era
lock@(RequireTimeStart SlotNo
_)
      | Set (KeyHash Witness)
-> ValidityInterval -> NativeScript era -> Bool
forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era) =>
Set (KeyHash Witness)
-> ValidityInterval -> NativeScript era -> Bool
evalTimelock Set (KeyHash Witness)
forall a. Monoid a => a
mempty ValidityInterval
vi NativeScript era
lock -> Maybe (Map (KeyHash Witness) (KeyPair Witness))
-> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Map (KeyHash Witness) (KeyPair Witness))
 -> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness))))
-> Maybe (Map (KeyHash Witness) (KeyPair Witness))
-> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
forall a b. (a -> b) -> a -> b
$ Map (KeyHash Witness) (KeyPair Witness)
-> Maybe (Map (KeyHash Witness) (KeyPair Witness))
forall a. a -> Maybe a
Just Map (KeyHash Witness) (KeyPair Witness)
forall a. Monoid a => a
mempty
      | Bool
otherwise -> Maybe (Map (KeyHash Witness) (KeyPair Witness))
-> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Map (KeyHash Witness) (KeyPair Witness))
forall a. Maybe a
Nothing
    lock :: NativeScript era
lock@(RequireTimeExpire SlotNo
_)
      | Set (KeyHash Witness)
-> ValidityInterval -> NativeScript era -> Bool
forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era) =>
Set (KeyHash Witness)
-> ValidityInterval -> NativeScript era -> Bool
evalTimelock Set (KeyHash Witness)
forall a. Monoid a => a
mempty ValidityInterval
vi NativeScript era
lock -> Maybe (Map (KeyHash Witness) (KeyPair Witness))
-> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Map (KeyHash Witness) (KeyPair Witness))
 -> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness))))
-> Maybe (Map (KeyHash Witness) (KeyPair Witness))
-> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
forall a b. (a -> b) -> a -> b
$ Map (KeyHash Witness) (KeyPair Witness)
-> Maybe (Map (KeyHash Witness) (KeyPair Witness))
forall a. a -> Maybe a
Just Map (KeyHash Witness) (KeyPair Witness)
forall a. Monoid a => a
mempty
      | Bool
otherwise -> Maybe (Map (KeyHash Witness) (KeyPair Witness))
-> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Map (KeyHash Witness) (KeyPair Witness))
forall a. Maybe a
Nothing
    NativeScript era
_ -> [Char]
-> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
forall a. HasCallStack => [Char] -> a
error [Char]
"Impossible: All NativeScripts should have been accounted for"