{-# 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.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 = 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 = forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
shelleyFixupTx

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 <- forall s (m :: * -> *). MonadState s m => m s
get
  let
    keyPairs :: Map (KeyHash 'Witness) (KeyPair 'Witness)
keyPairs = ImpTestState era
impState forall s a. s -> Getting a s a -> a
^. forall era.
SimpleGetter
  (ImpTestState era) (Map (KeyHash 'Witness) (KeyPair 'Witness))
impKeyPairsG
    vi :: ValidityInterval
vi = TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era.
AllegraEraTxBody era =>
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 forall a. Ord a => a -> a -> Bool
<= Int
0 = forall a. a -> Maybe a
Just forall a. Monoid a => a
mempty
      | Bool
otherwise = 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 forall a. Num a => a -> a -> a
- Int
1) StrictSeq (NativeScript era)
xs
          forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Map (KeyHash 'Witness) (KeyPair 'Witness)
kps 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 forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (KeyHash 'Witness)
providedVKeyHashes -> forall a. a -> Maybe a
Just forall a. Monoid a => a
mempty
        | Bool
otherwise -> do
            KeyPair 'Witness
keyPair <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'Witness
keyHash Map (KeyHash 'Witness) (KeyPair 'Witness)
keyPairs
            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ 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 (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
_)
        | forall era.
AllegraEraScript era =>
Set (KeyHash 'Witness)
-> ValidityInterval -> NativeScript era -> Bool
evalTimelock forall a. Monoid a => a
mempty ValidityInterval
vi NativeScript era
lock -> forall a. a -> Maybe a
Just forall a. Monoid a => a
mempty
        | Bool
otherwise -> forall a. Maybe a
Nothing
      lock :: NativeScript era
lock@(RequireTimeExpire SlotNo
_)
        | forall era.
AllegraEraScript era =>
Set (KeyHash 'Witness)
-> ValidityInterval -> NativeScript era -> Bool
evalTimelock forall a. Monoid a => a
mempty ValidityInterval
vi NativeScript era
lock -> forall a. a -> Maybe a
Just forall a. Monoid a => a
mempty
        | Bool
otherwise -> forall a. Maybe a
Nothing
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ NativeScript era
-> Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness))
satisfyScript NativeScript era
script