{-# 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.Allegra.TxBody (TxBody (AllegraTxBody))
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.Shelley.Tx (pattern ShelleyTx)
import Cardano.Ledger.Shelley.TxOut (ShelleyTxOut (..))
import Cardano.Ledger.Shelley.TxWits (pattern ShelleyTxWits)
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, NativeScript era ~ Timelock era) =>
KeyHash 'Witness -> NativeScript era
someLeaf @AllegraEra
  quantify :: Proxy AllegraEra
-> Script AllegraEra -> Quantifier (Script AllegraEra)
quantify Proxy AllegraEra
_ = Script AllegraEra -> Quantifier (Script AllegraEra)
NativeScript AllegraEra -> Quantifier (NativeScript AllegraEra)
forall era.
AllegraEraScript era =>
NativeScript era -> Quantifier (NativeScript era)
quantifyTL
  unQuantify :: Proxy AllegraEra
-> Quantifier (Script AllegraEra) -> Script AllegraEra
unQuantify Proxy AllegraEra
_ = Quantifier (Script AllegraEra) -> Script AllegraEra
Quantifier (NativeScript AllegraEra) -> NativeScript 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 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 AllegraEra, [Timelock AllegraEra])
SlotNo
-> Set TxIn
-> StrictSeq (TxOut AllegraEra)
-> StrictSeq (TxCert AllegraEra)
-> Withdrawals
-> Coin
-> StrictMaybe (Update AllegraEra)
-> StrictMaybe TxAuxDataHash
-> Gen (TxBody 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 AllegraEra
-> Coin
-> Set TxIn
-> TxOut AllegraEra
-> TxBody AllegraEra
updateEraTxBody UTxO AllegraEra
_utxo PParams AllegraEra
_pp TxWits AllegraEra
_wits TxBody AllegraEra
txBody Coin
fee Set TxIn
ins TxOut AllegraEra
out =
    TxBody AllegraEra
txBody
      TxBody AllegraEra
-> (TxBody AllegraEra -> TxBody AllegraEra) -> TxBody AllegraEra
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody AllegraEra -> Identity (TxBody AllegraEra)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody AllegraEra) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> TxBody AllegraEra -> Identity (TxBody AllegraEra))
-> (Set TxIn -> Set TxIn) -> TxBody AllegraEra -> TxBody 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 AllegraEra
-> (TxBody AllegraEra -> TxBody AllegraEra) -> TxBody AllegraEra
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxOut AllegraEra)
 -> Identity (StrictSeq (TxOut AllegraEra)))
-> TxBody AllegraEra -> Identity (TxBody AllegraEra)
(StrictSeq (ShelleyTxOut AllegraEra)
 -> Identity (StrictSeq (ShelleyTxOut AllegraEra)))
-> TxBody AllegraEra -> Identity (TxBody AllegraEra)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody AllegraEra) (StrictSeq (TxOut AllegraEra))
outputsTxBodyL ((StrictSeq (ShelleyTxOut AllegraEra)
  -> Identity (StrictSeq (ShelleyTxOut AllegraEra)))
 -> TxBody AllegraEra -> Identity (TxBody AllegraEra))
-> (StrictSeq (ShelleyTxOut AllegraEra)
    -> StrictSeq (ShelleyTxOut AllegraEra))
-> TxBody AllegraEra
-> TxBody 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 AllegraEra
-> (TxBody AllegraEra -> TxBody AllegraEra) -> TxBody AllegraEra
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin)
-> TxBody AllegraEra -> Identity (TxBody AllegraEra)
forall era. EraTxBody era => Lens' (TxBody era) Coin
Lens' (TxBody AllegraEra) Coin
feeTxBodyL ((Coin -> Identity Coin)
 -> TxBody AllegraEra -> Identity (TxBody AllegraEra))
-> Coin -> TxBody AllegraEra -> TxBody 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.
(ProtVerAtMost era 4, ProtVerAtMost era 6, ProtVerAtMost era 8,
 EraPParams era) =>
Constants -> PParams era -> Gen (PParamsUpdate era)
genShelleyPParamsUpdate
  genEraPParams :: Constants -> Gen (PParams AllegraEra)
genEraPParams = Constants -> Gen (PParams AllegraEra)
forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
Constants -> Gen (PParams era)
genPParams
  genEraTxWits :: (UTxO AllegraEra, TxBody AllegraEra, ScriptInfo AllegraEra)
-> Set (WitVKey 'Witness)
-> Map ScriptHash (Script AllegraEra)
-> TxWits AllegraEra
genEraTxWits (UTxO AllegraEra, TxBody AllegraEra, ScriptInfo AllegraEra)
_scriptinfo Set (WitVKey 'Witness)
setWitVKey Map ScriptHash (Script AllegraEra)
mapScriptWit = Set (WitVKey 'Witness)
-> Map ScriptHash (Script AllegraEra)
-> Set BootstrapWitness
-> ShelleyTxWits AllegraEra
forall era.
EraScript era =>
Set (WitVKey 'Witness)
-> Map ScriptHash (Script era)
-> Set BootstrapWitness
-> ShelleyTxWits era
ShelleyTxWits Set (WitVKey 'Witness)
setWitVKey Map ScriptHash (Script AllegraEra)
mapScriptWit Set BootstrapWitness
forall a. Monoid a => a
mempty
  constructTx :: TxBody AllegraEra
-> TxWits AllegraEra
-> StrictMaybe (TxAuxData AllegraEra)
-> Tx AllegraEra
constructTx = TxBody AllegraEra
-> TxWits AllegraEra
-> StrictMaybe (TxAuxData AllegraEra)
-> Tx AllegraEra
TxBody AllegraEra
-> TxWits AllegraEra
-> StrictMaybe (TxAuxData AllegraEra)
-> ShelleyTx AllegraEra
forall era.
EraTx era =>
TxBody era
-> TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx era
ShelleyTx

genTxBody ::
  SlotNo ->
  Set.Set TxIn ->
  StrictSeq (TxOut AllegraEra) ->
  StrictSeq (TxCert AllegraEra) ->
  Withdrawals ->
  Coin ->
  StrictMaybe (Update AllegraEra) ->
  StrictMaybe TxAuxDataHash ->
  Gen (TxBody AllegraEra, [Timelock AllegraEra])
genTxBody :: SlotNo
-> Set TxIn
-> StrictSeq (TxOut AllegraEra)
-> StrictSeq (TxCert AllegraEra)
-> Withdrawals
-> Coin
-> StrictMaybe (Update AllegraEra)
-> StrictMaybe TxAuxDataHash
-> Gen (TxBody 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
validityInterval <- SlotNo -> Gen ValidityInterval
genValidityInterval SlotNo
slot
  (TxBody AllegraEra, [Timelock AllegraEra])
-> Gen (TxBody AllegraEra, [Timelock AllegraEra])
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( Set TxIn
-> StrictSeq (TxOut AllegraEra)
-> StrictSeq (TxCert AllegraEra)
-> Withdrawals
-> Coin
-> ValidityInterval
-> StrictMaybe (Update AllegraEra)
-> StrictMaybe TxAuxDataHash
-> TxBody AllegraEra
(EraTxOut AllegraEra, EraTxCert AllegraEra) =>
Set TxIn
-> StrictSeq (TxOut AllegraEra)
-> StrictSeq (TxCert AllegraEra)
-> Withdrawals
-> Coin
-> ValidityInterval
-> StrictMaybe (Update AllegraEra)
-> StrictMaybe TxAuxDataHash
-> TxBody AllegraEra
AllegraTxBody
        Set TxIn
ins
        StrictSeq (TxOut AllegraEra)
outs
        StrictSeq (TxCert AllegraEra)
cert
        Withdrawals
wdrl
        Coin
fee
        ValidityInterval
validityInterval
        StrictMaybe (Update AllegraEra)
upd
        StrictMaybe TxAuxDataHash
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, ProtVerAtMost era 4) =>
Lens' (PParams era) Coin
Lens' (PParams AllegraEra) Coin
ppMinUTxOValueL
  addValToTxOut :: Value AllegraEra -> TxOut AllegraEra -> TxOut AllegraEra
addValToTxOut Value AllegraEra
v (ShelleyTxOut Addr
a Value AllegraEra
u) = Addr -> Value AllegraEra -> ShelleyTxOut AllegraEra
forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
a (Value AllegraEra
Coin
v Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> Value AllegraEra
Coin
u)
  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
    [Coin]
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
    [ShelleyTxOut AllegraEra] -> Gen [ShelleyTxOut AllegraEra]
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Addr -> Coin -> ShelleyTxOut AllegraEra)
-> [Addr] -> [Coin] -> [ShelleyTxOut AllegraEra]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Addr -> Value AllegraEra -> TxOut AllegraEra
Addr -> Coin -> ShelleyTxOut AllegraEra
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut [Addr]
addrs [Coin]
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, NativeScript era ~ Timelock era) =>
  KeyHash 'Witness ->
  NativeScript era
someLeaf :: forall era.
(AllegraEraScript era, NativeScript era ~ Timelock 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