{-# 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
import Test.Cardano.Ledger.Shelley.ImpTest

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

  fixupTx :: HasCallStack =>
Tx AllegraEra -> ImpTestM AllegraEra (Tx AllegraEra)
fixupTx = Tx AllegraEra -> ImpTestM AllegraEra (Tx AllegraEra)
forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
shelleyFixupTx
  expectTxSuccess :: HasCallStack => Tx AllegraEra -> ImpTestM AllegraEra ()
expectTxSuccess = Tx AllegraEra -> ImpTestM AllegraEra ()
forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx 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

impAllegraSatisfyNativeScript ::
  ( ShelleyEraImp era
  , AllegraEraScript era
  , AllegraEraTxBody era
  , NativeScript era ~ Timelock era
  ) =>
  Set.Set (KeyHash 'Witness) ->
  TxBody era ->
  NativeScript era ->
  ImpTestM era (Maybe (Map.Map (KeyHash 'Witness) (KeyPair 'Witness)))
impAllegraSatisfyNativeScript :: forall era.
(ShelleyEraImp era, AllegraEraScript era, AllegraEraTxBody era,
 NativeScript era ~ Timelock era) =>
Set (KeyHash 'Witness)
-> TxBody era
-> NativeScript era
-> ImpTestM era (Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness)))
impAllegraSatisfyNativeScript Set (KeyHash 'Witness)
providedVKeyHashes TxBody era
txBody NativeScript era
script = do
  let vi :: ValidityInterval
vi = TxBody era
txBody TxBody era
-> Getting ValidityInterval (TxBody era) ValidityInterval
-> ValidityInterval
forall s a. s -> Getting a s a -> a
^. Getting ValidityInterval (TxBody era) ValidityInterval
forall era.
AllegraEraTxBody era =>
Lens' (TxBody era) ValidityInterval
Lens' (TxBody 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 era
-> Int
-> StrictSeq (NativeScript era)
-> ImpTestM era (Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness)))
forall era.
ShelleyEraImp era =>
Set (KeyHash 'Witness)
-> TxBody era
-> Int
-> StrictSeq (NativeScript era)
-> ImpTestM era (Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness)))
impSatisfyMNativeScripts Set (KeyHash 'Witness)
providedVKeyHashes TxBody 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
      Int
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))]
      Set (KeyHash 'Witness)
-> TxBody era
-> Int
-> StrictSeq (NativeScript era)
-> ImpTestM era (Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness)))
forall era.
ShelleyEraImp era =>
Set (KeyHash 'Witness)
-> TxBody era
-> Int
-> StrictSeq (NativeScript era)
-> ImpTestM era (Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness)))
impSatisfyMNativeScripts Set (KeyHash 'Witness)
providedVKeyHashes TxBody era
txBody Int
m StrictSeq (NativeScript era)
ss
    RequireMOf Int
m StrictSeq (NativeScript era)
ss -> Set (KeyHash 'Witness)
-> TxBody era
-> Int
-> StrictSeq (NativeScript era)
-> ImpTestM era (Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness)))
forall era.
ShelleyEraImp era =>
Set (KeyHash 'Witness)
-> TxBody era
-> Int
-> StrictSeq (NativeScript era)
-> ImpTestM era (Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness)))
impSatisfyMNativeScripts Set (KeyHash 'Witness)
providedVKeyHashes TxBody 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"