{-# 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,
  evalTimelock,
  pattern RequireTimeExpire,
  pattern RequireTimeStart,
 )
import Cardano.Ledger.Shelley.Scripts (
  pattern RequireAllOf,
  pattern RequireAnyOf,
  pattern RequireMOf,
  pattern RequireSignature,
 )
import Control.Monad.State.Strict (get)
import qualified Data.Map.Strict as Map
import Data.Sequence.Strict (StrictSeq (..))
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.Core.KeyPair (KeyPair)
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.
(AllegraEraScript era, AllegraEraTxBody 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

impAllegraSatisfyNativeScript ::
  ( AllegraEraScript era
  , AllegraEraTxBody era
  ) =>
  Set.Set (KeyHash 'Witness) ->
  TxBody era ->
  NativeScript era ->
  ImpTestM era (Maybe (Map.Map (KeyHash 'Witness) (KeyPair 'Witness)))
impAllegraSatisfyNativeScript :: forall era.
(AllegraEraScript era, AllegraEraTxBody 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
  ImpTestState era
impState <- ImpM (LedgerSpec era) (ImpTestState era)
forall s (m :: * -> *). MonadState s m => m s
get
  let
    keyPairs :: Map (KeyHash 'Witness) (KeyPair 'Witness)
keyPairs = ImpTestState era
impState ImpTestState era
-> Getting
     (Map (KeyHash 'Witness) (KeyPair 'Witness))
     (ImpTestState era)
     (Map (KeyHash 'Witness) (KeyPair 'Witness))
-> Map (KeyHash 'Witness) (KeyPair 'Witness)
forall s a. s -> Getting a s a -> a
^. Getting
  (Map (KeyHash 'Witness) (KeyPair 'Witness))
  (ImpTestState era)
  (Map (KeyHash 'Witness) (KeyPair 'Witness))
forall era r.
Getting
  r (ImpTestState era) (Map (KeyHash 'Witness) (KeyPair 'Witness))
impKeyPairsG
    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
    satisfyMOf :: Int
-> StrictSeq (NativeScript era)
-> Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness))
satisfyMOf Int
m StrictSeq (NativeScript era)
Empty
      | Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = 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))
forall a. Maybe a
Nothing
    satisfyMOf Int
m (NativeScript era
x :<| StrictSeq (NativeScript era)
xs) =
      case NativeScript era
-> Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness))
satisfyScript NativeScript era
x of
        Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness))
Nothing -> Int
-> StrictSeq (NativeScript era)
-> Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness))
satisfyMOf Int
m StrictSeq (NativeScript era)
xs
        Just Map (KeyHash 'Witness) (KeyPair 'Witness)
kps -> do
          Map (KeyHash 'Witness) (KeyPair 'Witness)
kps' <- Int
-> StrictSeq (NativeScript era)
-> Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness))
satisfyMOf (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) StrictSeq (NativeScript era)
xs
          Map (KeyHash 'Witness) (KeyPair 'Witness)
-> Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness))
forall a. a -> Maybe a
Just (Map (KeyHash 'Witness) (KeyPair 'Witness)
 -> Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness)))
-> Map (KeyHash 'Witness) (KeyPair 'Witness)
-> Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness))
forall a b. (a -> b) -> a -> b
$ Map (KeyHash 'Witness) (KeyPair 'Witness)
kps Map (KeyHash 'Witness) (KeyPair 'Witness)
-> Map (KeyHash 'Witness) (KeyPair 'Witness)
-> Map (KeyHash 'Witness) (KeyPair 'Witness)
forall a. Semigroup a => a -> a -> a
<> Map (KeyHash 'Witness) (KeyPair 'Witness)
kps'
    satisfyScript :: NativeScript era
-> Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness))
satisfyScript = \case
      RequireSignature KeyHash 'Witness
keyHash
        | KeyHash 'Witness
keyHash KeyHash 'Witness -> Set (KeyHash 'Witness) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (KeyHash 'Witness)
providedVKeyHashes -> 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 -> do
            KeyPair 'Witness
keyPair <- KeyHash 'Witness
-> Map (KeyHash 'Witness) (KeyPair 'Witness)
-> Maybe (KeyPair 'Witness)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'Witness
keyHash Map (KeyHash 'Witness) (KeyPair 'Witness)
keyPairs
            Map (KeyHash 'Witness) (KeyPair 'Witness)
-> Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness))
forall a. a -> Maybe a
Just (Map (KeyHash 'Witness) (KeyPair 'Witness)
 -> Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness)))
-> Map (KeyHash 'Witness) (KeyPair 'Witness)
-> Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness))
forall a b. (a -> b) -> a -> b
$ KeyHash 'Witness
-> KeyPair 'Witness -> Map (KeyHash 'Witness) (KeyPair 'Witness)
forall k a. k -> a -> Map k a
Map.singleton KeyHash 'Witness
keyHash KeyPair 'Witness
keyPair
      RequireAllOf StrictSeq (NativeScript era)
ss -> Int
-> StrictSeq (NativeScript era)
-> Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness))
satisfyMOf (StrictSeq (NativeScript era) -> Int
forall a. StrictSeq a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length StrictSeq (NativeScript era)
ss) StrictSeq (NativeScript era)
ss
      RequireAnyOf StrictSeq (NativeScript era)
ss -> Int
-> StrictSeq (NativeScript era)
-> Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness))
satisfyMOf Int
1 StrictSeq (NativeScript era)
ss
      RequireMOf Int
m StrictSeq (NativeScript era)
ss -> Int
-> StrictSeq (NativeScript era)
-> Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness))
satisfyMOf Int
m StrictSeq (NativeScript era)
ss
      lock :: NativeScript era
lock@(RequireTimeStart SlotNo
_)
        | Set (KeyHash 'Witness)
-> ValidityInterval -> NativeScript era -> Bool
forall era.
AllegraEraScript era =>
Set (KeyHash 'Witness)
-> ValidityInterval -> NativeScript era -> Bool
evalTimelock Set (KeyHash 'Witness)
forall a. Monoid a => a
mempty ValidityInterval
vi NativeScript era
lock -> 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))
forall a. Maybe a
Nothing
      lock :: NativeScript era
lock@(RequireTimeExpire SlotNo
_)
        | Set (KeyHash 'Witness)
-> ValidityInterval -> NativeScript era -> Bool
forall era.
AllegraEraScript era =>
Set (KeyHash 'Witness)
-> ValidityInterval -> NativeScript era -> Bool
evalTimelock Set (KeyHash 'Witness)
forall a. Monoid a => a
mempty ValidityInterval
vi NativeScript era
lock -> 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))
forall a. Maybe a
Nothing
  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
$ NativeScript era
-> Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness))
satisfyScript NativeScript era
script