{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Cardano.Ledger.Shelley.Era (
  module Test.Cardano.Ledger.Era,
  ShelleyEraTest,
  mkShelleyTestAccountState,
  nativeAlwaysFails,
  nativeAlwaysSucceeds,
  shelleyAccountsFromAccountsMap,
  shelleyAccountsToUMap,
) where

import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Coin
import Cardano.Ledger.Core
import Cardano.Ledger.Credential
import Cardano.Ledger.Plutus (emptyCostModels)
import Cardano.Ledger.Shelley
import Cardano.Ledger.Shelley.LedgerState
import Cardano.Ledger.Shelley.Scripts
import Cardano.Ledger.Shelley.State
import Cardano.Ledger.Shelley.Transition
import Cardano.Ledger.UMap
import Data.Default
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Lens.Micro
import Test.Cardano.Ledger.Common
import Test.Cardano.Ledger.Era
import Test.Cardano.Ledger.Shelley.Arbitrary ()
import Test.Cardano.Ledger.Shelley.TreeDiff ()

class
  ( EraTest era
  , ShelleyEraScript era
  , EraTransition era
  , Arbitrary (TransitionConfig era)
  , Eq (StashedAVVMAddresses era)
  , Show (StashedAVVMAddresses era)
  , ToExpr (StashedAVVMAddresses era)
  , NFData (StashedAVVMAddresses era)
  , Default (StashedAVVMAddresses era)
  , Arbitrary (StashedAVVMAddresses era)
  , ToExpr (ScriptsNeeded era)
  ) =>
  ShelleyEraTest era

instance EraTest ShelleyEra where
  zeroCostModels :: CostModels
zeroCostModels = CostModels
emptyCostModels

  mkTestAccountState :: HasCallStack =>
Maybe Ptr
-> CompactForm Coin
-> Maybe (KeyHash 'StakePool)
-> Maybe DRep
-> AccountState ShelleyEra
mkTestAccountState = Maybe Ptr
-> CompactForm Coin
-> Maybe (KeyHash 'StakePool)
-> Maybe DRep
-> AccountState ShelleyEra
forall era.
(HasCallStack, ShelleyEraAccounts era) =>
Maybe Ptr
-> CompactForm Coin
-> Maybe (KeyHash 'StakePool)
-> Maybe DRep
-> AccountState era
mkShelleyTestAccountState

  accountsFromAccountsMap :: Map (Credential 'Staking) (AccountState ShelleyEra)
-> Accounts ShelleyEra
accountsFromAccountsMap = Map (Credential 'Staking) (AccountState ShelleyEra)
-> Accounts ShelleyEra
forall era.
(Accounts era ~ ShelleyAccounts era,
 AccountState era ~ ShelleyAccountState era,
 ShelleyEraAccounts era) =>
Map (Credential 'Staking) (AccountState era) -> Accounts era
shelleyAccountsFromAccountsMap

  accountsToUMap :: Accounts ShelleyEra -> UMap
accountsToUMap = Accounts ShelleyEra -> UMap
forall era. ShelleyEraAccounts era => Accounts era -> UMap
shelleyAccountsToUMap

instance ShelleyEraTest ShelleyEra

mkShelleyTestAccountState ::
  (HasCallStack, ShelleyEraAccounts era) =>
  Maybe Ptr ->
  CompactForm Coin ->
  Maybe (KeyHash 'StakePool) ->
  Maybe DRep ->
  AccountState era
mkShelleyTestAccountState :: forall era.
(HasCallStack, ShelleyEraAccounts era) =>
Maybe Ptr
-> CompactForm Coin
-> Maybe (KeyHash 'StakePool)
-> Maybe DRep
-> AccountState era
mkShelleyTestAccountState Maybe Ptr
mPtr CompactForm Coin
deposit Maybe (KeyHash 'StakePool)
mStakePool Maybe DRep
mDRep =
  case Maybe Ptr
mPtr of
    Maybe Ptr
Nothing -> [Char] -> AccountState era
forall a. HasCallStack => [Char] -> a
error [Char]
"When registering Account in Shelley through Babbage eras Ptr is required"
    Just Ptr
ptr ->
      case Maybe DRep
mDRep of
        Maybe DRep
Nothing -> Ptr -> CompactForm Coin -> AccountState era
forall era.
ShelleyEraAccounts era =>
Ptr -> CompactForm Coin -> AccountState era
mkShelleyAccountState Ptr
ptr CompactForm Coin
deposit AccountState era
-> (AccountState era -> AccountState era) -> AccountState era
forall a b. a -> (a -> b) -> b
& (Maybe (KeyHash 'StakePool)
 -> Identity (Maybe (KeyHash 'StakePool)))
-> AccountState era -> Identity (AccountState era)
forall era.
EraAccounts era =>
Lens' (AccountState era) (Maybe (KeyHash 'StakePool))
Lens' (AccountState era) (Maybe (KeyHash 'StakePool))
stakePoolDelegationAccountStateL ((Maybe (KeyHash 'StakePool)
  -> Identity (Maybe (KeyHash 'StakePool)))
 -> AccountState era -> Identity (AccountState era))
-> Maybe (KeyHash 'StakePool)
-> AccountState era
-> AccountState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe (KeyHash 'StakePool)
mStakePool
        Just DRep
_ -> [Char] -> AccountState era
forall a. HasCallStack => [Char] -> a
error [Char]
"Delegation to DRep is not supported until Conway"

shelleyAccountsFromAccountsMap ::
  ( Accounts era ~ ShelleyAccounts era
  , AccountState era ~ ShelleyAccountState era
  , ShelleyEraAccounts era
  ) =>
  Map.Map (Credential 'Staking) (AccountState era) -> Accounts era
shelleyAccountsFromAccountsMap :: forall era.
(Accounts era ~ ShelleyAccounts era,
 AccountState era ~ ShelleyAccountState era,
 ShelleyEraAccounts era) =>
Map (Credential 'Staking) (AccountState era) -> Accounts era
shelleyAccountsFromAccountsMap Map (Credential 'Staking) (AccountState era)
accountsMap =
  ShelleyAccounts
    { saStates :: Map (Credential 'Staking) (ShelleyAccountState era)
saStates = Map (Credential 'Staking) (AccountState era)
Map (Credential 'Staking) (ShelleyAccountState era)
accountsMap
    , saPtrs :: Map Ptr (Credential 'Staking)
saPtrs =
        [(Ptr, Credential 'Staking)] -> Map Ptr (Credential 'Staking)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
          [(ShelleyAccountState era
accountState ShelleyAccountState era
-> Getting Ptr (ShelleyAccountState era) Ptr -> Ptr
forall s a. s -> Getting a s a -> a
^. Getting Ptr (AccountState era) Ptr
Getting Ptr (ShelleyAccountState era) Ptr
forall era.
ShelleyEraAccounts era =>
SimpleGetter (AccountState era) Ptr
SimpleGetter (AccountState era) Ptr
ptrAccountStateG, Credential 'Staking
cred) | (Credential 'Staking
cred, ShelleyAccountState era
accountState) <- Map (Credential 'Staking) (ShelleyAccountState era)
-> [(Credential 'Staking, ShelleyAccountState era)]
forall k a. Map k a -> [(k, a)]
Map.toList Map (Credential 'Staking) (AccountState era)
Map (Credential 'Staking) (ShelleyAccountState era)
accountsMap]
    }

shelleyAccountsToUMap :: ShelleyEraAccounts era => Accounts era -> UMap
shelleyAccountsToUMap :: forall era. ShelleyEraAccounts era => Accounts era -> UMap
shelleyAccountsToUMap Accounts era
accounts =
  UMap
    { umElems :: Map (Credential 'Staking) UMElem
umElems = (AccountState era -> UMElem)
-> Map (Credential 'Staking) (AccountState era)
-> Map (Credential 'Staking) UMElem
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map AccountState era -> UMElem
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 ...),
 ShelleyEraAccounts era) =>
AccountState era -> UMElem
toUMElem (Accounts era
accounts Accounts era
-> Getting
     (Map (Credential 'Staking) (AccountState era))
     (Accounts era)
     (Map (Credential 'Staking) (AccountState era))
-> Map (Credential 'Staking) (AccountState era)
forall s a. s -> Getting a s a -> a
^. Getting
  (Map (Credential 'Staking) (AccountState era))
  (Accounts era)
  (Map (Credential 'Staking) (AccountState era))
forall era.
EraAccounts era =>
Lens' (Accounts era) (Map (Credential 'Staking) (AccountState era))
Lens' (Accounts era) (Map (Credential 'Staking) (AccountState era))
accountsMapL)
    , umPtrs :: Map Ptr (Credential 'Staking)
umPtrs = Accounts era
accounts Accounts era
-> Getting
     (Map Ptr (Credential 'Staking))
     (Accounts era)
     (Map Ptr (Credential 'Staking))
-> Map Ptr (Credential 'Staking)
forall s a. s -> Getting a s a -> a
^. Getting
  (Map Ptr (Credential 'Staking))
  (Accounts era)
  (Map Ptr (Credential 'Staking))
forall era.
ShelleyEraAccounts era =>
SimpleGetter (Accounts era) (Map Ptr (Credential 'Staking))
SimpleGetter (Accounts era) (Map Ptr (Credential 'Staking))
accountsPtrsMapG
    }
  where
    toUMElem :: AccountState era -> UMElem
toUMElem AccountState era
accountState =
      StrictMaybe RDPair
-> Set Ptr
-> StrictMaybe (KeyHash 'StakePool)
-> StrictMaybe DRep
-> UMElem
UMElem
        (RDPair -> StrictMaybe RDPair
forall a. a -> StrictMaybe a
SJust (CompactForm Coin -> CompactForm Coin -> RDPair
RDPair (AccountState era
accountState AccountState era
-> Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
-> CompactForm Coin
forall s a. s -> Getting a s a -> a
^. Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
forall era.
EraAccounts era =>
Lens' (AccountState era) (CompactForm Coin)
Lens' (AccountState era) (CompactForm Coin)
balanceAccountStateL) (AccountState era
accountState AccountState era
-> Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
-> CompactForm Coin
forall s a. s -> Getting a s a -> a
^. Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
forall era.
EraAccounts era =>
Lens' (AccountState era) (CompactForm Coin)
Lens' (AccountState era) (CompactForm Coin)
depositAccountStateL)))
        (Ptr -> Set Ptr
forall a. a -> Set a
Set.singleton (AccountState era
accountState AccountState era -> Getting Ptr (AccountState era) Ptr -> Ptr
forall s a. s -> Getting a s a -> a
^. Getting Ptr (AccountState era) Ptr
forall era.
ShelleyEraAccounts era =>
SimpleGetter (AccountState era) Ptr
SimpleGetter (AccountState era) Ptr
ptrAccountStateG))
        (Maybe (KeyHash 'StakePool) -> StrictMaybe (KeyHash 'StakePool)
forall a. Maybe a -> StrictMaybe a
maybeToStrictMaybe (AccountState era
accountState AccountState era
-> Getting
     (Maybe (KeyHash 'StakePool))
     (AccountState era)
     (Maybe (KeyHash 'StakePool))
-> Maybe (KeyHash 'StakePool)
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe (KeyHash 'StakePool))
  (AccountState era)
  (Maybe (KeyHash 'StakePool))
forall era.
EraAccounts era =>
Lens' (AccountState era) (Maybe (KeyHash 'StakePool))
Lens' (AccountState era) (Maybe (KeyHash 'StakePool))
stakePoolDelegationAccountStateL))
        StrictMaybe DRep
forall a. StrictMaybe a
SNothing

-- Minimal native scripts that can be used in all post-Shelley eras

nativeAlwaysFails :: forall era. ShelleyEraScript era => Script era
nativeAlwaysFails :: forall era. ShelleyEraScript era => Script era
nativeAlwaysFails = NativeScript era -> Script era
forall era. EraScript era => NativeScript era -> Script era
fromNativeScript (NativeScript era -> Script era) -> NativeScript era -> Script era
forall a b. (a -> b) -> a -> b
$ StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAnyOf []

nativeAlwaysSucceeds :: forall era. ShelleyEraScript era => Script era
nativeAlwaysSucceeds :: forall era. ShelleyEraScript era => Script era
nativeAlwaysSucceeds = NativeScript era -> Script era
forall era. EraScript era => NativeScript era -> Script era
fromNativeScript (NativeScript era -> Script era) -> NativeScript era -> Script era
forall a b. (a -> b) -> a -> b
$ StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf []