{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Cardano.Ledger.Conformance.Orphans where

import Cardano.Ledger.Hashes (standardAddrHashSize)
import Data.Bifunctor (Bifunctor (..))
import Data.Default (Default)
import Data.List (nub, sortOn)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.Set as Set
import Data.Text (Text)
import Data.Void (Void)
import GHC.Generics (Generic)
import MAlonzo.Code.Ledger.Foreign.API as Agda
import Test.Cardano.Ledger.Common (NFData, ToExpr)
import Test.Cardano.Ledger.Conformance.SpecTranslate.Base (OpaqueErrorString, SpecNormalize (..))
import Test.Cardano.Ledger.Conformance.Utils
import Test.Cardano.Ledger.Conway.TreeDiff (Expr (..), ToExpr (..))

deriving instance Generic HsRewardUpdate

deriving instance Ord DepositPurpose

deriving instance Ord Tag

deriving instance Ord HSLanguage

deriving instance Ord LanguageCostModels

deriving instance Ord Credential

deriving instance Ord GovRole

deriving instance Ord GovVotes

deriving instance Ord VDeleg

deriving instance Ord Vote

deriving instance Ord PoolThresholds

deriving instance Ord DrepThresholds

deriving instance Ord PParamsUpdate

deriving instance Ord RewardAddress

deriving instance Ord GovAction

deriving instance Ord GovActionState

instance (NFData k, NFData v) => NFData (HSMap k v)

instance NFData a => NFData (HSSet a)

instance NFData PParamsUpdate

instance NFData RewardAddress

instance NFData GovAction

instance NFData BaseAddr

instance NFData BootstrapAddr

instance NFData Timelock

instance NFData HSTimelock

instance NFData HSLanguage

instance NFData LanguageCostModels

instance NFData HSPlutusScript

instance NFData UTxOState

instance NFData Vote

instance NFData Credential

instance NFData GovRole

instance NFData GovVotes

instance NFData GovActionState

instance NFData Anchor

instance NFData GovVote

instance NFData GovProposal

instance NFData DrepThresholds

instance NFData PoolThresholds

instance NFData PParams

instance NFData EnactState

instance NFData GovEnv

instance NFData VDeleg

instance NFData StakePoolParams

instance NFData DCert

instance NFData TxBody

instance NFData Tag

instance NFData HSVKey

instance NFData TxWitnesses

instance NFData Tx

instance NFData UTxOEnv

instance NFData DepositPurpose

instance NFData CertEnv

instance NFData PState

instance NFData DState

instance NFData GState

instance NFData CertState

instance NFData StakeDistrs

instance NFData RatifyEnv

instance NFData RatifyState

instance NFData EnactEnv

instance NFData DelegEnv

instance NFData EpochState

instance NFData Snapshots

instance NFData Snapshot

instance NFData Acnt

instance NFData LState

instance NFData HsRewardUpdate

instance NFData NewEpochState

instance NFData LEnv

instance ToExpr a => ToExpr (HSSet a)

instance ToExpr Credential where
  toExpr :: Credential -> Expr
toExpr (KeyHashObj Integer
h) =
    ConstructorName -> [Expr] -> Expr
App
      ConstructorName
"KeyHashObj"
      [ Int -> Integer -> Expr
agdaHashToExpr Int
standardAddrHashSize Integer
h
      , Integer -> Expr
forall a. ToExpr a => a -> Expr
toExpr Integer
h
      ]
  toExpr (ScriptObj Integer
h) =
    ConstructorName -> [Expr] -> Expr
App
      ConstructorName
"ScriptObj"
      [ Int -> Integer -> Expr
agdaHashToExpr Int
standardAddrHashSize Integer
h
      , Integer -> Expr
forall a. ToExpr a => a -> Expr
toExpr Integer
h
      ]

instance (ToExpr k, ToExpr v) => ToExpr (HSMap k v)

instance ToExpr PParamsUpdate

instance ToExpr RewardAddress

instance ToExpr GovAction

instance ToExpr GovRole

instance ToExpr GovVotes

instance ToExpr Vote

instance ToExpr GovActionState

instance ToExpr Anchor

instance ToExpr GovProposal

instance ToExpr GovVote

instance ToExpr PoolThresholds

instance ToExpr DrepThresholds

instance ToExpr PParams

instance ToExpr GovEnv

instance ToExpr EnactState

instance ToExpr VDeleg

instance ToExpr StakePoolParams

instance ToExpr DCert

instance ToExpr BaseAddr

instance ToExpr BootstrapAddr

instance ToExpr Timelock

instance ToExpr HSTimelock

instance ToExpr HSLanguage

instance ToExpr LanguageCostModels

instance ToExpr HSPlutusScript

instance ToExpr TxBody

instance ToExpr Tag

instance ToExpr HSVKey

instance ToExpr TxWitnesses

instance ToExpr Tx

instance ToExpr UTxOState

instance ToExpr UTxOEnv

instance ToExpr DepositPurpose

instance ToExpr CertEnv

instance ToExpr DState

instance ToExpr PState

instance ToExpr GState

instance ToExpr CertState

instance ToExpr StakeDistrs

instance ToExpr RatifyEnv

instance ToExpr RatifyState

instance ToExpr EnactEnv

instance ToExpr DelegEnv

instance ToExpr EpochState

instance ToExpr Snapshots

instance ToExpr Snapshot

instance ToExpr LState

instance ToExpr Acnt

instance ToExpr HsRewardUpdate

instance ToExpr NewEpochState

instance ToExpr LEnv

instance Default (HSMap k v)

instance SpecNormalize Void

instance SpecNormalize a => SpecNormalize (NonEmpty a)

instance SpecNormalize Text where
  specNormalize :: Text -> Text
specNormalize = Text -> Text
forall a. a -> a
id

instance SpecNormalize OpaqueErrorString

instance SpecNormalize a => SpecNormalize [a]

instance SpecNormalize Char where
  specNormalize :: Char -> Char
specNormalize = Char -> Char
forall a. a -> a
id

instance
  ( Eq v
  , Ord k
  , SpecNormalize k
  , SpecNormalize v
  ) =>
  SpecNormalize (HSMap k v)
  where
  specNormalize :: HSMap k v -> HSMap k v
specNormalize (MkHSMap [(k, v)]
l) = [(k, v)] -> HSMap k v
forall k v. [(k, v)] -> HSMap k v
MkHSMap ([(k, v)] -> HSMap k v)
-> ([(k, v)] -> [(k, v)]) -> [(k, v)] -> HSMap k v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((k, v) -> k) -> [(k, v)] -> [(k, v)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (k, v) -> k
forall a b. (a, b) -> a
fst ([(k, v)] -> HSMap k v) -> [(k, v)] -> HSMap k v
forall a b. (a -> b) -> a -> b
$ (k -> k) -> (v -> v) -> (k, v) -> (k, v)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap k -> k
forall a. SpecNormalize a => a -> a
specNormalize v -> v
forall a. SpecNormalize a => a -> a
specNormalize ((k, v) -> (k, v)) -> [(k, v)] -> [(k, v)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(k, v)] -> [(k, v)]
forall a. Eq a => [a] -> [a]
nub [(k, v)]
l

instance (Ord a, SpecNormalize a) => SpecNormalize (HSSet a) where
  specNormalize :: HSSet a -> HSSet a
specNormalize (MkHSSet [a]
l) = [a] -> HSSet a
forall a. [a] -> HSSet a
MkHSSet ([a] -> HSSet a) -> ([a] -> [a]) -> [a] -> HSSet a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set a -> [a]
forall a. Set a -> [a]
Set.toList (Set a -> [a]) -> ([a] -> Set a) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList ([a] -> HSSet a) -> [a] -> HSSet a
forall a b. (a -> b) -> a -> b
$ a -> a
forall a. SpecNormalize a => a -> a
specNormalize (a -> a) -> [a] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
l

instance (SpecNormalize a, SpecNormalize b) => SpecNormalize (a, b)

instance SpecNormalize a => SpecNormalize (Maybe a)

instance (SpecNormalize a, SpecNormalize b) => SpecNormalize (Either a b)

instance SpecNormalize Bool

instance SpecNormalize TxId where
  specNormalize :: Integer -> Integer
specNormalize = Integer -> Integer
forall a. a -> a
id

instance SpecNormalize ()

instance SpecNormalize BaseAddr

instance SpecNormalize BootstrapAddr

instance SpecNormalize Timelock

instance SpecNormalize HSTimelock

instance SpecNormalize Agda.LanguageCostModels where
  specNormalize :: LanguageCostModels -> LanguageCostModels
specNormalize = [(HSLanguage, ())] -> LanguageCostModels
MkLanguageCostModels ([(HSLanguage, ())] -> LanguageCostModels)
-> (LanguageCostModels -> [(HSLanguage, ())])
-> LanguageCostModels
-> LanguageCostModels
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((HSLanguage, ()) -> HSLanguage)
-> [(HSLanguage, ())] -> [(HSLanguage, ())]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (HSLanguage, ()) -> HSLanguage
forall a b. (a, b) -> a
fst ([(HSLanguage, ())] -> [(HSLanguage, ())])
-> (LanguageCostModels -> [(HSLanguage, ())])
-> LanguageCostModels
-> [(HSLanguage, ())]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LanguageCostModels -> [(HSLanguage, ())]
lcmLanguageCostModels

instance SpecNormalize HSLanguage

instance SpecNormalize HSPlutusScript

instance SpecNormalize UTxOState

instance SpecNormalize Credential

instance SpecNormalize GovRole

instance SpecNormalize GovVotes

instance SpecNormalize VDeleg

instance SpecNormalize DepositPurpose

instance SpecNormalize DState

instance SpecNormalize StakePoolParams

instance SpecNormalize PState

instance SpecNormalize GState

instance SpecNormalize CertState

instance SpecNormalize Vote

instance SpecNormalize Agda.Rational where
  specNormalize :: Rational -> Rational
specNormalize = Rational -> Rational
forall a. a -> a
id

instance SpecNormalize PParamsUpdate

instance SpecNormalize RewardAddress

instance SpecNormalize GovAction

instance SpecNormalize GovActionState

instance SpecNormalize StakeDistrs

instance SpecNormalize PoolThresholds

instance SpecNormalize DrepThresholds

instance SpecNormalize PParams

instance SpecNormalize EnactState

instance SpecNormalize RatifyEnv

instance SpecNormalize RatifyState

instance SpecNormalize EpochState

instance SpecNormalize Snapshots

instance SpecNormalize Snapshot where
  specNormalize :: Snapshot -> Snapshot
specNormalize (MkSnapshot HSMap Credential Integer
s HSMap Credential Integer
d HSMap Integer StakePoolParams
p) =
    HSMap Credential Integer
-> HSMap Credential Integer
-> HSMap Integer StakePoolParams
-> Snapshot
MkSnapshot (HSMap Credential Integer -> HSMap Credential Integer
forall a. SpecNormalize a => a -> a
specNormalize HSMap Credential Integer
s') (HSMap Credential Integer -> HSMap Credential Integer
forall a. SpecNormalize a => a -> a
specNormalize HSMap Credential Integer
d') HSMap Integer StakePoolParams
p
    where
      s' :: HSMap Credential Integer
s' = HSMap Credential Integer -> HSMap Credential Integer
forall {b} {k}. (Eq b, Num b) => HSMap k b -> HSMap k b
removeZero HSMap Credential Integer
s
      -- Only keep delegations for credentials that have non-zero stake,
      -- since ActiveStake drops zero-stake credentials
      d' :: HSMap Credential Integer
d' = HSMap Credential Integer
-> HSMap Credential Integer -> HSMap Credential Integer
forall {b} {v} {v}. Ord b => HSMap b v -> HSMap b v -> HSMap b v
keepOnlyStaked HSMap Credential Integer
s' (HSMap Credential Integer -> HSMap Credential Integer
forall {b} {k}. (Eq b, Num b) => HSMap k b -> HSMap k b
removeZero HSMap Credential Integer
d)
      removeZero :: HSMap k b -> HSMap k b
removeZero (MkHSMap [(k, b)]
l) = [(k, b)] -> HSMap k b
forall k v. [(k, v)] -> HSMap k v
MkHSMap ([(k, b)] -> HSMap k b) -> [(k, b)] -> HSMap k b
forall a b. (a -> b) -> a -> b
$ ((k, b) -> Bool) -> [(k, b)] -> [(k, b)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((b -> b -> Bool
forall a. Eq a => a -> a -> Bool
/= b
0) (b -> Bool) -> ((k, b) -> b) -> (k, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (k, b) -> b
forall a b. (a, b) -> b
snd) [(k, b)]
l
      keepOnlyStaked :: HSMap b v -> HSMap b v -> HSMap b v
keepOnlyStaked (MkHSMap [(b, v)]
sl) (MkHSMap [(b, v)]
dl) =
        let stakeKeys :: Set b
stakeKeys = [b] -> Set b
forall a. Ord a => [a] -> Set a
Set.fromList (((b, v) -> b) -> [(b, v)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (b, v) -> b
forall a b. (a, b) -> a
fst [(b, v)]
sl)
         in [(b, v)] -> HSMap b v
forall k v. [(k, v)] -> HSMap k v
MkHSMap ([(b, v)] -> HSMap b v) -> [(b, v)] -> HSMap b v
forall a b. (a -> b) -> a -> b
$ ((b, v) -> Bool) -> [(b, v)] -> [(b, v)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((b -> Set b -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set b
stakeKeys) (b -> Bool) -> ((b, v) -> b) -> (b, v) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b, v) -> b
forall a b. (a, b) -> a
fst) [(b, v)]
dl

instance SpecNormalize Acnt

instance SpecNormalize LState

instance SpecNormalize HsRewardUpdate

instance SpecNormalize NewEpochState

deriving instance Semigroup (HSMap k v)

deriving instance Monoid (HSMap k v)