diff --git a/lib/read/cardano-wallet-read.cabal b/lib/read/cardano-wallet-read.cabal index ac9ab15510e..70e14ea141d 100644 --- a/lib/read/cardano-wallet-read.cabal +++ b/lib/read/cardano-wallet-read.cabal @@ -64,6 +64,7 @@ library Cardano.Read.Ledger.Tx.Validity Cardano.Read.Ledger.Tx.Withdrawals Cardano.Read.Ledger.Tx.Witnesses + Cardano.Read.Ledger.Value Cardano.Wallet.Read Cardano.Wallet.Read.Block Cardano.Wallet.Read.Block.BHeader @@ -98,6 +99,7 @@ library Cardano.Wallet.Read.Tx.Inputs Cardano.Wallet.Read.Tx.TxId Cardano.Wallet.Read.Tx.TxIn + Cardano.Wallet.Read.Value build-depends: , base diff --git a/lib/read/lib/Cardano/Read/Ledger/Value.hs b/lib/read/lib/Cardano/Read/Ledger/Value.hs new file mode 100644 index 00000000000..e38b2c9fb59 --- /dev/null +++ b/lib/read/lib/Cardano/Read/Ledger/Value.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{- | +Copyright: © 2024 Cardano Foundation +License: Apache-2.0 + +Era-indexed value. +-} +module Cardano.Read.Ledger.Value + ( ValueType + , Value (..) + , maryValueFromByronValue + , maryValueFromShelleyValue + ) + where + +import Prelude + +import Cardano.Ledger.Crypto + ( StandardCrypto + ) +import Cardano.Wallet.Read.Eras + ( Allegra + , Alonzo + , Babbage + , Byron + , Conway + , Mary + , Shelley + ) + +import qualified Cardano.Chain.Common as BY +import qualified Cardano.Ledger.BaseTypes as SH +import qualified Cardano.Ledger.Coin as SH +import qualified Cardano.Ledger.Mary.Value as MA + +{----------------------------------------------------------------------------- + Value +------------------------------------------------------------------------------} + +type family ValueType era where + ValueType Byron = BY.Lovelace + ValueType Shelley = SH.Coin + ValueType Allegra = SH.Coin + ValueType Mary = MA.MaryValue StandardCrypto + ValueType Alonzo = MA.MaryValue StandardCrypto + ValueType Babbage = MA.MaryValue StandardCrypto + ValueType Conway = MA.MaryValue StandardCrypto + +newtype Value era = Value (ValueType era) + +deriving instance Show (ValueType era) => Show (Value era) +deriving instance Eq (ValueType era) => Eq (Value era) + +maryValueFromByronValue :: ValueType Byron -> ValueType Mary +maryValueFromByronValue = SH.inject . SH.Coin . BY.lovelaceToInteger + +maryValueFromShelleyValue :: ValueType Shelley -> ValueType Mary +maryValueFromShelleyValue = SH.inject diff --git a/lib/read/lib/Cardano/Wallet/Read/Value.hs b/lib/read/lib/Cardano/Wallet/Read/Value.hs new file mode 100644 index 00000000000..b9917aac000 --- /dev/null +++ b/lib/read/lib/Cardano/Wallet/Read/Value.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE StandaloneDeriving #-} + +{- | +Copyright: © 2024 Cardano Foundation +License: Apache-2.0 + +'Value' — ADA and native assets. +-} +module Cardano.Wallet.Read.Value + ( -- * Coin + Coin (unCoin) + + -- * MultiAsset + , MultiAsset + , AssetName + , PolicyID + , AssetID (..) + , Quantity + + -- * Value + , Value (ValueC,getCoin,getAssets) + , lookupAssetID + , injectCoin + , valueFromList + , add + , subtract + , lessOrEqual + + -- * Internal + , fromMaryValue + , toMaryValue + ) where + +import Prelude hiding + ( subtract + ) + +import Cardano.Ledger.Coin + ( Coin (unCoin) + ) +import Cardano.Ledger.Crypto + ( StandardCrypto + ) +import Cardano.Ledger.Val + ( pointwise + , (<->) + ) + +import qualified Cardano.Ledger.BaseTypes as SH +import qualified Cardano.Ledger.Mary.Value as MA + +{----------------------------------------------------------------------------- + MultiAssets +------------------------------------------------------------------------------} + +type AssetName = MA.AssetName + +type PolicyID = MA.PolicyID StandardCrypto + +type Quantity = Integer + +-- | Identifier for an asset. +data AssetID + = AdaID + | Asset PolicyID AssetName + +deriving instance Eq AssetID +deriving instance Ord AssetID + +type MultiAsset = MA.MultiAsset StandardCrypto + +{----------------------------------------------------------------------------- + Value +------------------------------------------------------------------------------} +-- | Monetary values, representing both ADA and native assets/tokens. +newtype Value = Value (MA.MaryValue StandardCrypto) + +-- | Internal: Convert from ledger 'MaryValue'. +fromMaryValue :: MA.MaryValue StandardCrypto -> Value +fromMaryValue = Value + +-- | Internal: Convert to ledger 'MaryValue'. +toMaryValue :: Value -> MA.MaryValue StandardCrypto +toMaryValue (Value v) = v + +instance Eq Value where + (Value x) == (Value y) = x == y + +instance Show Value where + show (Value x) = show x + +{-# COMPLETE ValueC #-} +pattern ValueC :: Coin -> MultiAsset -> Value +pattern ValueC{getCoin,getAssets} = Value (MA.MaryValue getCoin getAssets) + +-- | Look up the quantity corresponding to an 'AssetID'. +lookupAssetID :: AssetID -> Value -> Quantity +lookupAssetID AdaID value = unCoin $ getCoin value +lookupAssetID (Asset policyId assetName) (Value value) = + MA.lookupMultiAsset policyId assetName value + +-- | Turn a 'Coin' into a 'Value', @inject@ from the specification. +injectCoin :: Coin -> Value +injectCoin = Value . SH.inject + +-- | Construct a 'Value' from a 'Coin' and a list of assets. +valueFromList :: Coin -> [(PolicyID, AssetName, Quantity)] -> Value +valueFromList coin = Value . MA.valueFromList coin + +-- | '(<>)' adds monetary values. +instance Semigroup Value where + (Value x) <> (Value y) = Value (x <> y) + +instance Monoid Value where + mempty = Value mempty + +-- | Add all quantities in the second argument to the first argument. +-- Synonym of '(<>)'. +-- +-- > ∀ a. lookupAssetID a (x `add` y) +-- > = lookupAssetID a x + lookupAssetID a y +add :: Value -> Value -> Value +add = (<>) + +-- | Subtract the quantities in the second argument from the first argument. +-- +-- > ∀ a. lookupAssetID a (x `subtract` y) +-- > = lookupAssetID a x - lookupAssetID a y +subtract :: Value -> Value -> Value +subtract (Value x) (Value y) = Value (x <-> y) + +-- | Check whether all assets in the first argument +-- are present in less or equal quantity +-- than the assets in the second argument. +lessOrEqual :: Value -> Value -> Bool +lessOrEqual (Value value1) (Value value2) = + pointwise (<=) value1 value2