{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Test.Cardano.Ledger.AllegraEraGen (
  -- export EraGen instance for AllegraEra and helpers shared with MaryEra
  quantifyTL,
  unQuantifyTL,
  someLeaf,
  genValidityInterval,
) where

import Cardano.Ledger.Allegra (AllegraEra)
import Cardano.Ledger.Allegra.Core
import Cardano.Ledger.Allegra.Scripts (
  AllegraEraScript,
  Timelock (..),
  pattern RequireTimeExpire,
  pattern RequireTimeStart,
 )
import Cardano.Ledger.BaseTypes (StrictMaybe (..))
import Cardano.Ledger.Binary (encCBOR, serialize')
import Cardano.Ledger.Coin (Coin)
import Cardano.Ledger.Shelley.PParams (Update)
import Cardano.Ledger.Shelley.Scripts (
  pattern RequireAllOf,
  pattern RequireAnyOf,
  pattern RequireMOf,
  pattern RequireSignature,
 )
import Cardano.Ledger.TxIn (TxIn)
import Cardano.Ledger.Val ((<+>))
import Cardano.Slotting.Slot (SlotNo (SlotNo))
import Control.Monad (replicateM)
import Data.Hashable (hash)
import Data.Sequence.Strict (StrictSeq (..), fromList)
import qualified Data.Set as Set
import Lens.Micro
import Test.Cardano.Ledger.Allegra.Arbitrary ()
import Test.Cardano.Ledger.Shelley.Constants (Constants (..))
import Test.Cardano.Ledger.Shelley.Generator.Core (GenEnv (..), genCoin)
import Test.Cardano.Ledger.Shelley.Generator.EraGen (EraGen (..), MinGenTxout (..))
import Test.Cardano.Ledger.Shelley.Generator.ScriptClass (
  Quantifier (..),
  ScriptClass (..),
 )
import Test.Cardano.Ledger.Shelley.Generator.Update (genPParams, genShelleyPParamsUpdate)
import Test.Cardano.Ledger.ShelleyMA.Serialisation.Generators ()
import Test.QuickCheck (Arbitrary, Gen, arbitrary, frequency)

-- ==========================================================

{------------------------------------------------------------------------------
 EraGen instance for AllegraEra - This instance makes it possible to run the
 Shelley property tests for AllegraEra

 This instance is layered on top of the ShelleyMA instances
 in Cardano.Ledger.ShelleyMA.Scripts:

 `type instance Script AllegraEra = Timelock AllegraEra`
 `instance ValidateScript (ShelleyMAEra ma c) where ...`
------------------------------------------------------------------------------}

instance ScriptClass AllegraEra where
  isKey :: Proxy AllegraEra -> Script AllegraEra -> Maybe (KeyHash Witness)
isKey Proxy AllegraEra
_ (RequireSignature KeyHash Witness
hk) = KeyHash Witness -> Maybe (KeyHash Witness)
forall a. a -> Maybe a
Just KeyHash Witness
hk
  isKey Proxy AllegraEra
_ Script AllegraEra
_ = Maybe (KeyHash Witness)
forall a. Maybe a
Nothing
  basescript :: Proxy AllegraEra -> KeyHash Witness -> Script AllegraEra
basescript Proxy AllegraEra
_proxy = forall era.
AllegraEraScript era =>
KeyHash Witness -> NativeScript era
someLeaf @AllegraEra
  quantify :: Proxy AllegraEra
-> Script AllegraEra -> Quantifier (Script AllegraEra)
quantify Proxy AllegraEra
_ = NativeScript AllegraEra -> Quantifier (NativeScript AllegraEra)
Script AllegraEra -> Quantifier (Script AllegraEra)
forall era.
AllegraEraScript era =>
NativeScript era -> Quantifier (NativeScript era)
quantifyTL
  unQuantify :: Proxy AllegraEra
-> Quantifier (Script AllegraEra) -> Script AllegraEra
unQuantify Proxy AllegraEra
_ = Quantifier (NativeScript AllegraEra) -> NativeScript AllegraEra
Quantifier (Script AllegraEra) -> Script AllegraEra
forall era.
AllegraEraScript era =>
Quantifier (NativeScript era) -> NativeScript era
unQuantifyTL

instance EraGen AllegraEra where
  genGenesisValue :: forall c. GenEnv c AllegraEra -> Gen (Value AllegraEra)
genGenesisValue (GenEnv KeySpace c AllegraEra
_keySpace ScriptSpace AllegraEra
_scriptspace Constants {Integer
minGenesisOutputVal :: Integer
minGenesisOutputVal :: Constants -> Integer
minGenesisOutputVal, Integer
maxGenesisOutputVal :: Integer
maxGenesisOutputVal :: Constants -> Integer
maxGenesisOutputVal}) =
    Integer -> Integer -> Gen Coin
genCoin Integer
minGenesisOutputVal Integer
maxGenesisOutputVal
  genEraTxBody :: forall c.
GenEnv c AllegraEra
-> UTxO AllegraEra
-> PParams AllegraEra
-> SlotNo
-> Set TxIn
-> StrictSeq (TxOut AllegraEra)
-> StrictSeq (TxCert AllegraEra)
-> Withdrawals
-> Coin
-> StrictMaybe (Update AllegraEra)
-> StrictMaybe TxAuxDataHash
-> Gen (TxBody TopTx AllegraEra, [Script AllegraEra])
genEraTxBody GenEnv c AllegraEra
_ge UTxO AllegraEra
_utxo PParams AllegraEra
_pparams = SlotNo
-> Set TxIn
-> StrictSeq (TxOut AllegraEra)
-> StrictSeq (TxCert AllegraEra)
-> Withdrawals
-> Coin
-> StrictMaybe (Update AllegraEra)
-> StrictMaybe TxAuxDataHash
-> Gen (TxBody TopTx AllegraEra, [Timelock AllegraEra])
SlotNo
-> Set TxIn
-> StrictSeq (TxOut AllegraEra)
-> StrictSeq (TxCert AllegraEra)
-> Withdrawals
-> Coin
-> StrictMaybe (Update AllegraEra)
-> StrictMaybe TxAuxDataHash
-> Gen (TxBody TopTx AllegraEra, [Script AllegraEra])
genTxBody
  genEraAuxiliaryData :: Constants -> Gen (StrictMaybe (TxAuxData AllegraEra))
genEraAuxiliaryData = Constants -> Gen (StrictMaybe (TxAuxData AllegraEra))
forall era.
Arbitrary (TxAuxData era) =>
Constants -> Gen (StrictMaybe (TxAuxData era))
genAuxiliaryData
  updateEraTxBody :: UTxO AllegraEra
-> PParams AllegraEra
-> TxWits AllegraEra
-> TxBody TopTx AllegraEra
-> Coin
-> Set TxIn
-> TxOut AllegraEra
-> TxBody TopTx AllegraEra
updateEraTxBody UTxO AllegraEra
_utxo PParams AllegraEra
_pp TxWits AllegraEra
_wits TxBody TopTx AllegraEra
txBody Coin
fee Set TxIn
ins TxOut AllegraEra
out =
    TxBody TopTx AllegraEra
txBody
      TxBody TopTx AllegraEra
-> (TxBody TopTx AllegraEra -> TxBody TopTx AllegraEra)
-> TxBody TopTx AllegraEra
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody TopTx AllegraEra -> Identity (TxBody TopTx AllegraEra)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l AllegraEra) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> TxBody TopTx AllegraEra -> Identity (TxBody TopTx AllegraEra))
-> (Set TxIn -> Set TxIn)
-> TxBody TopTx AllegraEra
-> TxBody TopTx AllegraEra
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Set TxIn -> Set TxIn -> Set TxIn
forall a. Semigroup a => a -> a -> a
<> Set TxIn
ins)
      TxBody TopTx AllegraEra
-> (TxBody TopTx AllegraEra -> TxBody TopTx AllegraEra)
-> TxBody TopTx AllegraEra
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxOut AllegraEra)
 -> Identity (StrictSeq (TxOut AllegraEra)))
-> TxBody TopTx AllegraEra -> Identity (TxBody TopTx AllegraEra)
(StrictSeq (ShelleyTxOut AllegraEra)
 -> Identity (StrictSeq (ShelleyTxOut AllegraEra)))
-> TxBody TopTx AllegraEra -> Identity (TxBody TopTx AllegraEra)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel).
Lens' (TxBody l AllegraEra) (StrictSeq (TxOut AllegraEra))
outputsTxBodyL ((StrictSeq (ShelleyTxOut AllegraEra)
  -> Identity (StrictSeq (ShelleyTxOut AllegraEra)))
 -> TxBody TopTx AllegraEra -> Identity (TxBody TopTx AllegraEra))
-> (StrictSeq (ShelleyTxOut AllegraEra)
    -> StrictSeq (ShelleyTxOut AllegraEra))
-> TxBody TopTx AllegraEra
-> TxBody TopTx AllegraEra
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (StrictSeq (TxOut AllegraEra)
-> TxOut AllegraEra -> StrictSeq (TxOut AllegraEra)
forall a. StrictSeq a -> a -> StrictSeq a
:|> TxOut AllegraEra
out)
      TxBody TopTx AllegraEra
-> (TxBody TopTx AllegraEra -> TxBody TopTx AllegraEra)
-> TxBody TopTx AllegraEra
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin)
-> TxBody TopTx AllegraEra -> Identity (TxBody TopTx AllegraEra)
forall era. EraTxBody era => Lens' (TxBody TopTx era) Coin
Lens' (TxBody TopTx AllegraEra) Coin
feeTxBodyL ((Coin -> Identity Coin)
 -> TxBody TopTx AllegraEra -> Identity (TxBody TopTx AllegraEra))
-> Coin -> TxBody TopTx AllegraEra -> TxBody TopTx AllegraEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
fee
  genEraPParamsUpdate :: Constants -> PParams AllegraEra -> Gen (PParamsUpdate AllegraEra)
genEraPParamsUpdate = Constants -> PParams AllegraEra -> Gen (PParamsUpdate AllegraEra)
forall era.
(AtMostEra "Mary" era, AtMostEra "Alonzo" era,
 AtMostEra "Babbage" era, EraPParams era) =>
Constants -> PParams era -> Gen (PParamsUpdate era)
genShelleyPParamsUpdate
  genEraPParams :: Constants -> Gen (PParams AllegraEra)
genEraPParams = Constants -> Gen (PParams AllegraEra)
forall era.
(EraPParams era, AtMostEra "Mary" era, AtMostEra "Alonzo" era) =>
Constants -> Gen (PParams era)
genPParams
  genEraTxWits :: (UTxO AllegraEra, TxBody TopTx AllegraEra, ScriptInfo AllegraEra)
-> Set (WitVKey Witness)
-> Map ScriptHash (Script AllegraEra)
-> TxWits AllegraEra
genEraTxWits (UTxO AllegraEra, TxBody TopTx AllegraEra, ScriptInfo AllegraEra)
_scriptinfo Set (WitVKey Witness)
setWitVKey Map ScriptHash (Script AllegraEra)
mapScriptWit =
    TxWits AllegraEra
forall era. EraTxWits era => TxWits era
mkBasicTxWits TxWits AllegraEra
-> (TxWits AllegraEra -> TxWits AllegraEra) -> TxWits AllegraEra
forall a b. a -> (a -> b) -> b
& (Set (WitVKey Witness) -> Identity (Set (WitVKey Witness)))
-> TxWits AllegraEra -> Identity (TxWits AllegraEra)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey Witness))
Lens' (TxWits AllegraEra) (Set (WitVKey Witness))
addrTxWitsL ((Set (WitVKey Witness) -> Identity (Set (WitVKey Witness)))
 -> TxWits AllegraEra -> Identity (TxWits AllegraEra))
-> Set (WitVKey Witness) -> TxWits AllegraEra -> TxWits AllegraEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Set (WitVKey Witness)
setWitVKey TxWits AllegraEra
-> (TxWits AllegraEra -> ShelleyTxWits AllegraEra)
-> ShelleyTxWits AllegraEra
forall a b. a -> (a -> b) -> b
& (Map ScriptHash (Script AllegraEra)
 -> Identity (Map ScriptHash (Script AllegraEra)))
-> TxWits AllegraEra -> Identity (TxWits AllegraEra)
(Map ScriptHash (Script AllegraEra)
 -> Identity (Map ScriptHash (Script AllegraEra)))
-> TxWits AllegraEra -> Identity (ShelleyTxWits AllegraEra)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Map ScriptHash (Script era))
Lens' (TxWits AllegraEra) (Map ScriptHash (Script AllegraEra))
scriptTxWitsL ((Map ScriptHash (Script AllegraEra)
  -> Identity (Map ScriptHash (Script AllegraEra)))
 -> TxWits AllegraEra -> Identity (ShelleyTxWits AllegraEra))
-> Map ScriptHash (Script AllegraEra)
-> TxWits AllegraEra
-> ShelleyTxWits AllegraEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map ScriptHash (Script AllegraEra)
mapScriptWit
  constructTx :: TxBody TopTx AllegraEra
-> TxWits AllegraEra
-> StrictMaybe (TxAuxData AllegraEra)
-> Tx TopTx AllegraEra
constructTx TxBody TopTx AllegraEra
body TxWits AllegraEra
wits StrictMaybe (TxAuxData AllegraEra)
auxData =
    TxBody TopTx AllegraEra -> Tx TopTx AllegraEra
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l AllegraEra -> Tx l AllegraEra
mkBasicTx TxBody TopTx AllegraEra
body Tx TopTx AllegraEra
-> (Tx TopTx AllegraEra -> Tx TopTx AllegraEra)
-> Tx TopTx AllegraEra
forall a b. a -> (a -> b) -> b
& (TxWits AllegraEra -> Identity (TxWits AllegraEra))
-> Tx TopTx AllegraEra -> Identity (Tx TopTx AllegraEra)
(ShelleyTxWits AllegraEra -> Identity (ShelleyTxWits AllegraEra))
-> Tx TopTx AllegraEra -> Identity (Tx TopTx AllegraEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l AllegraEra) (TxWits AllegraEra)
witsTxL ((ShelleyTxWits AllegraEra -> Identity (ShelleyTxWits AllegraEra))
 -> Tx TopTx AllegraEra -> Identity (Tx TopTx AllegraEra))
-> ShelleyTxWits AllegraEra
-> Tx TopTx AllegraEra
-> Tx TopTx AllegraEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxWits AllegraEra
ShelleyTxWits AllegraEra
wits Tx TopTx AllegraEra
-> (Tx TopTx AllegraEra -> Tx TopTx AllegraEra)
-> Tx TopTx AllegraEra
forall a b. a -> (a -> b) -> b
& (StrictMaybe (AllegraTxAuxData AllegraEra)
 -> Identity (StrictMaybe (AllegraTxAuxData AllegraEra)))
-> Tx TopTx AllegraEra -> Identity (Tx TopTx AllegraEra)
(StrictMaybe (TxAuxData AllegraEra)
 -> Identity (StrictMaybe (TxAuxData AllegraEra)))
-> Tx TopTx AllegraEra -> Identity (Tx TopTx AllegraEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (StrictMaybe (TxAuxData era))
forall (l :: TxLevel).
Lens' (Tx l AllegraEra) (StrictMaybe (TxAuxData AllegraEra))
auxDataTxL ((StrictMaybe (AllegraTxAuxData AllegraEra)
  -> Identity (StrictMaybe (AllegraTxAuxData AllegraEra)))
 -> Tx TopTx AllegraEra -> Identity (Tx TopTx AllegraEra))
-> StrictMaybe (AllegraTxAuxData AllegraEra)
-> Tx TopTx AllegraEra
-> Tx TopTx AllegraEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictMaybe (AllegraTxAuxData AllegraEra)
StrictMaybe (TxAuxData AllegraEra)
auxData

genTxBody ::
  SlotNo ->
  Set.Set TxIn ->
  StrictSeq (TxOut AllegraEra) ->
  StrictSeq (TxCert AllegraEra) ->
  Withdrawals ->
  Coin ->
  StrictMaybe (Update AllegraEra) ->
  StrictMaybe TxAuxDataHash ->
  Gen (TxBody TopTx AllegraEra, [Timelock AllegraEra])
genTxBody :: SlotNo
-> Set TxIn
-> StrictSeq (TxOut AllegraEra)
-> StrictSeq (TxCert AllegraEra)
-> Withdrawals
-> Coin
-> StrictMaybe (Update AllegraEra)
-> StrictMaybe TxAuxDataHash
-> Gen (TxBody TopTx AllegraEra, [Timelock AllegraEra])
genTxBody SlotNo
slot Set TxIn
ins StrictSeq (TxOut AllegraEra)
outs StrictSeq (TxCert AllegraEra)
cert Withdrawals
wdrl Coin
fee StrictMaybe (Update AllegraEra)
upd StrictMaybe TxAuxDataHash
ad = do
  validityInterval <- SlotNo -> Gen ValidityInterval
genValidityInterval SlotNo
slot
  pure
    ( mkBasicTxBody
        & inputsTxBodyL .~ ins
        & outputsTxBodyL .~ outs
        & certsTxBodyL .~ cert
        & withdrawalsTxBodyL .~ wdrl
        & feeTxBodyL .~ fee
        & vldtTxBodyL .~ validityInterval
        & updateTxBodyL .~ upd
        & auxDataHashTxBodyL .~ ad
    , [] -- Allegra does not need any additional script witnesses
    )

instance MinGenTxout AllegraEra where
  calcEraMinUTxO :: TxOut AllegraEra -> PParams AllegraEra -> Coin
calcEraMinUTxO TxOut AllegraEra
_txout PParams AllegraEra
pp = PParams AllegraEra
pp PParams AllegraEra
-> Getting Coin (PParams AllegraEra) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (PParams AllegraEra) Coin
forall era.
(EraPParams era, AtMostEra "Mary" era, HasCallStack) =>
Lens' (PParams era) Coin
Lens' (PParams AllegraEra) Coin
ppMinUTxOValueL
  addValToTxOut :: Value AllegraEra -> TxOut AllegraEra -> TxOut AllegraEra
addValToTxOut Value AllegraEra
v TxOut AllegraEra
txout = TxOut AllegraEra
ShelleyTxOut AllegraEra
txout ShelleyTxOut AllegraEra
-> (ShelleyTxOut AllegraEra -> ShelleyTxOut AllegraEra)
-> ShelleyTxOut AllegraEra
forall a b. a -> (a -> b) -> b
& (Value AllegraEra -> Identity (Value AllegraEra))
-> TxOut AllegraEra -> Identity (TxOut AllegraEra)
(Value AllegraEra -> Identity (Value AllegraEra))
-> ShelleyTxOut AllegraEra -> Identity (ShelleyTxOut AllegraEra)
forall era. EraTxOut era => Lens' (TxOut era) (Value era)
Lens' (TxOut AllegraEra) (Value AllegraEra)
valueTxOutL ((Value AllegraEra -> Identity (Value AllegraEra))
 -> ShelleyTxOut AllegraEra -> Identity (ShelleyTxOut AllegraEra))
-> (Value AllegraEra -> Value AllegraEra)
-> ShelleyTxOut AllegraEra
-> ShelleyTxOut AllegraEra
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Value AllegraEra
v Value AllegraEra -> Value AllegraEra -> Value AllegraEra
forall t. Val t => t -> t -> t
<+>)
  genEraTxOut :: forall c.
GenEnv c AllegraEra
-> Gen (Value AllegraEra) -> [Addr] -> Gen [TxOut AllegraEra]
genEraTxOut GenEnv c AllegraEra
_genenv Gen (Value AllegraEra)
genVal [Addr]
addrs = do
    values <- Int -> Gen Coin -> Gen [Coin]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([Addr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Addr]
addrs) Gen (Value AllegraEra)
Gen Coin
genVal
    pure (zipWith mkBasicTxOut addrs values)

{------------------------------------------------------------------------------
  ShelleyMA helpers, shared by Allegra and Mary
------------------------------------------------------------------------------}

quantifyTL ::
  AllegraEraScript era =>
  NativeScript era ->
  Quantifier (NativeScript era)
quantifyTL :: forall era.
AllegraEraScript era =>
NativeScript era -> Quantifier (NativeScript era)
quantifyTL (RequireAllOf StrictSeq (NativeScript era)
xs) = [NativeScript era] -> Quantifier (NativeScript era)
forall t. [t] -> Quantifier t
AllOf ((NativeScript era -> [NativeScript era] -> [NativeScript era])
-> [NativeScript era]
-> StrictSeq (NativeScript era)
-> [NativeScript era]
forall a b. (a -> b -> b) -> b -> StrictSeq a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (:) [] StrictSeq (NativeScript era)
xs)
quantifyTL (RequireAnyOf StrictSeq (NativeScript era)
xs) = [NativeScript era] -> Quantifier (NativeScript era)
forall t. [t] -> Quantifier t
AnyOf ((NativeScript era -> [NativeScript era] -> [NativeScript era])
-> [NativeScript era]
-> StrictSeq (NativeScript era)
-> [NativeScript era]
forall a b. (a -> b -> b) -> b -> StrictSeq a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (:) [] StrictSeq (NativeScript era)
xs)
quantifyTL (RequireMOf Int
n StrictSeq (NativeScript era)
xs) = Int -> [NativeScript era] -> Quantifier (NativeScript era)
forall t. Int -> [t] -> Quantifier t
MOf Int
n ((NativeScript era -> [NativeScript era] -> [NativeScript era])
-> [NativeScript era]
-> StrictSeq (NativeScript era)
-> [NativeScript era]
forall a b. (a -> b -> b) -> b -> StrictSeq a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (:) [] StrictSeq (NativeScript era)
xs)
quantifyTL NativeScript era
t = NativeScript era -> Quantifier (NativeScript era)
forall t. t -> Quantifier t
Leaf NativeScript era
t

unQuantifyTL :: AllegraEraScript era => Quantifier (NativeScript era) -> NativeScript era
unQuantifyTL :: forall era.
AllegraEraScript era =>
Quantifier (NativeScript era) -> NativeScript era
unQuantifyTL (AllOf [NativeScript era]
xs) = StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf ([NativeScript era] -> StrictSeq (NativeScript era)
forall a. [a] -> StrictSeq a
fromList [NativeScript era]
xs)
unQuantifyTL (AnyOf [NativeScript era]
xs) = StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAnyOf ([NativeScript era] -> StrictSeq (NativeScript era)
forall a. [a] -> StrictSeq a
fromList [NativeScript era]
xs)
unQuantifyTL (MOf Int
n [NativeScript era]
xs) = Int -> StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
Int -> StrictSeq (NativeScript era) -> NativeScript era
RequireMOf Int
n ([NativeScript era] -> StrictSeq (NativeScript era)
forall a. [a] -> StrictSeq a
fromList [NativeScript era]
xs)
unQuantifyTL (Leaf NativeScript era
t) = NativeScript era
t

genAuxiliaryData ::
  Arbitrary (TxAuxData era) =>
  Constants ->
  Gen (StrictMaybe (TxAuxData era))
genAuxiliaryData :: forall era.
Arbitrary (TxAuxData era) =>
Constants -> Gen (StrictMaybe (TxAuxData era))
genAuxiliaryData Constants {Int
frequencyTxWithMetadata :: Int
frequencyTxWithMetadata :: Constants -> Int
frequencyTxWithMetadata} =
  [(Int, Gen (StrictMaybe (TxAuxData era)))]
-> Gen (StrictMaybe (TxAuxData era))
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
    [ (Int
frequencyTxWithMetadata, TxAuxData era -> StrictMaybe (TxAuxData era)
forall a. a -> StrictMaybe a
SJust (TxAuxData era -> StrictMaybe (TxAuxData era))
-> Gen (TxAuxData era) -> Gen (StrictMaybe (TxAuxData era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (TxAuxData era)
forall a. Arbitrary a => Gen a
arbitrary)
    , (Int
100 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
frequencyTxWithMetadata, StrictMaybe (TxAuxData era) -> Gen (StrictMaybe (TxAuxData era))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StrictMaybe (TxAuxData era)
forall a. StrictMaybe a
SNothing)
    ]

-- | Generates a trivial validity interval that is valid for the current slot.
--
-- Note: the validity interval must be a subset of all timelock
-- script intervals that apply to the transaction. This depends on
-- which generated scripts are actually required to validate the transaction
-- (which is itself not always deterministic, e.g. 'RequireMOf n scripts').
--
-- A more sophisticated generator would compute which set of scripts
-- would validate the transaction, and from that compute a minimal
-- ValidityInterval that fits into all timelock slot ranges.
genValidityInterval :: SlotNo -> Gen ValidityInterval
genValidityInterval :: SlotNo -> Gen ValidityInterval
genValidityInterval cs :: SlotNo
cs@(SlotNo Word64
currentSlot) =
  ValidityInterval -> Gen ValidityInterval
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ValidityInterval -> Gen ValidityInterval)
-> ValidityInterval -> Gen ValidityInterval
forall a b. (a -> b) -> a -> b
$
    StrictMaybe SlotNo -> StrictMaybe SlotNo -> ValidityInterval
ValidityInterval
      (SlotNo -> StrictMaybe SlotNo
forall a. a -> StrictMaybe a
SJust SlotNo
cs)
      (SlotNo -> StrictMaybe SlotNo
forall a. a -> StrictMaybe a
SJust (SlotNo -> StrictMaybe SlotNo)
-> (Word64 -> SlotNo) -> Word64 -> StrictMaybe SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> SlotNo
SlotNo (Word64 -> StrictMaybe SlotNo) -> Word64 -> StrictMaybe SlotNo
forall a b. (a -> b) -> a -> b
$ Word64
currentSlot Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1)

-- | Generate some Leaf Timelock (i.e. a Signature or TimeStart or TimeExpire).
--
-- Because we don't know how these "leaf scripts" will be situated in larger scripts
-- (e.g. the script generated here might form part of a 'RequireAll' or 'RequireMOf' script)
-- we must make sure that all timelocks generated here are valid for all slots.
--
-- To achieve this we arrange the timelock scripts like so:
--  RequireAnyOf [
--     RequireAllOf [RequireTimeExpire k, RequireSignature x],
--     RequireAllOf [RequireTimeStart k, RequireSignature x]
--  ]
-- where k is arbitrary. This means that regardless of slot, there will be a
-- valid sub-branch of script.
someLeaf ::
  forall era.
  AllegraEraScript era =>
  KeyHash Witness ->
  NativeScript era
someLeaf :: forall era.
AllegraEraScript era =>
KeyHash Witness -> NativeScript era
someLeaf KeyHash Witness
x =
  let n :: Int
n = Int -> Int -> Int
forall a. Integral a => a -> a -> a
mod (ByteString -> Int
forall a. Hashable a => a -> Int
hash (Version -> Encoding -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
serialize' (forall era. Era era => Version
eraProtVerLow @era) (KeyHash Witness -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR KeyHash Witness
x))) Int
200
   in forall era.
AllegraEraScript era =>
[Int] -> [NativeScript era] -> NativeScript era
partition @era [Int
n] [KeyHash Witness -> NativeScript era
forall era.
ShelleyEraScript era =>
KeyHash Witness -> NativeScript era
RequireSignature KeyHash Witness
x]

partition ::
  forall era.
  AllegraEraScript era =>
  [Int] ->
  [NativeScript era] ->
  NativeScript era
partition :: forall era.
AllegraEraScript era =>
[Int] -> [NativeScript era] -> NativeScript era
partition [Int]
splits [NativeScript era]
scripts =
  StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAnyOf (StrictSeq (NativeScript era) -> NativeScript era)
-> ([NativeScript era] -> StrictSeq (NativeScript era))
-> [NativeScript era]
-> NativeScript era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [NativeScript era] -> StrictSeq (NativeScript era)
forall a. [a] -> StrictSeq a
fromList ([NativeScript era] -> NativeScript era)
-> [NativeScript era] -> NativeScript era
forall a b. (a -> b) -> a -> b
$
    (NativeScript era -> NativeScript era -> NativeScript era)
-> [NativeScript era] -> [NativeScript era] -> [NativeScript era]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith NativeScript era -> NativeScript era -> NativeScript era
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 ShelleyEraScript era) =>
NativeScript era -> NativeScript era -> NativeScript era
pair (forall era. AllegraEraScript era => [Int] -> [NativeScript era]
intervals @era [Int]
splits) ([NativeScript era] -> [NativeScript era]
forall a. HasCallStack => [a] -> [a]
cycle [NativeScript era]
scripts)
  where
    pair :: NativeScript era -> NativeScript era -> NativeScript era
pair NativeScript era
a NativeScript era
b = StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf (StrictSeq (NativeScript era) -> NativeScript era)
-> StrictSeq (NativeScript era) -> NativeScript era
forall a b. (a -> b) -> a -> b
$ [NativeScript era] -> StrictSeq (NativeScript era)
forall a. [a] -> StrictSeq a
fromList [NativeScript era
a, NativeScript era
b]

intervals ::
  forall era.
  AllegraEraScript era =>
  [Int] ->
  [NativeScript era]
intervals :: forall era. AllegraEraScript era => [Int] -> [NativeScript era]
intervals [Int]
xs = (Maybe SlotNo -> Maybe SlotNo -> NativeScript era)
-> [Maybe SlotNo] -> [Maybe SlotNo] -> [NativeScript era]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Maybe SlotNo -> Maybe SlotNo -> NativeScript era
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 AllegraEraScript era) =>
Maybe SlotNo -> Maybe SlotNo -> NativeScript era
mkInterval [Maybe SlotNo]
padded (Int -> [Maybe SlotNo] -> [Maybe SlotNo]
forall a. Int -> [a] -> [a]
drop Int
1 [Maybe SlotNo]
padded)
  where
    padded :: [Maybe SlotNo]
padded = Maybe SlotNo
forall a. Maybe a
Nothing Maybe SlotNo -> [Maybe SlotNo] -> [Maybe SlotNo]
forall a. a -> [a] -> [a]
: (SlotNo -> Maybe SlotNo
forall a. a -> Maybe a
Just (SlotNo -> Maybe SlotNo) -> (Int -> SlotNo) -> Int -> Maybe SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> (Int -> Word64) -> Int -> SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Maybe SlotNo) -> [Int] -> [Maybe SlotNo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int]
xs) [Maybe SlotNo] -> [Maybe SlotNo] -> [Maybe SlotNo]
forall a. [a] -> [a] -> [a]
++ [Maybe SlotNo
forall a. Maybe a
Nothing]
    start :: Maybe SlotNo -> [NativeScript era]
start Maybe SlotNo
Nothing = []
    start (Just SlotNo
x) = [SlotNo -> NativeScript era
forall era. AllegraEraScript era => SlotNo -> NativeScript era
RequireTimeStart SlotNo
x]
    end :: Maybe SlotNo -> [NativeScript era]
end Maybe SlotNo
Nothing = []
    end (Just SlotNo
x) = [SlotNo -> NativeScript era
forall era. AllegraEraScript era => SlotNo -> NativeScript era
RequireTimeExpire SlotNo
x]
    mkInterval :: Maybe SlotNo -> Maybe SlotNo -> NativeScript era
mkInterval Maybe SlotNo
s Maybe SlotNo
e = StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf (StrictSeq (NativeScript era) -> NativeScript era)
-> ([NativeScript era] -> StrictSeq (NativeScript era))
-> [NativeScript era]
-> NativeScript era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [NativeScript era] -> StrictSeq (NativeScript era)
forall a. [a] -> StrictSeq a
fromList ([NativeScript era] -> NativeScript era)
-> [NativeScript era] -> NativeScript era
forall a b. (a -> b) -> a -> b
$ Maybe SlotNo -> [NativeScript era]
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 AllegraEraScript era) =>
Maybe SlotNo -> [NativeScript era]
start Maybe SlotNo
s [NativeScript era] -> [NativeScript era] -> [NativeScript era]
forall a. [a] -> [a] -> [a]
++ Maybe SlotNo -> [NativeScript era]
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 AllegraEraScript era) =>
Maybe SlotNo -> [NativeScript era]
end Maybe SlotNo
e