|
| 1 | +{-# LANGUAGE DerivingStrategies #-} |
| 2 | +{-# LANGUAGE FlexibleContexts #-} |
| 3 | +{-# LANGUAGE GeneralizedNewtypeDeriving #-} |
| 4 | +{-# LANGUAGE ScopedTypeVariables #-} |
| 5 | +{-# LANGUAGE UndecidableInstances #-} |
| 6 | + |
| 7 | +module Cardano.Api.Internal.Tx.UTxO where |
| 8 | + |
| 9 | +import Cardano.Api.Internal.Eon.ShelleyBasedEra (IsShelleyBasedEra) |
| 10 | +import Cardano.Api.Internal.Eras.Core (IsCardanoEra) |
| 11 | +import Cardano.Api.Internal.Tx.Body (CtxUTxO, TxOut (..)) |
| 12 | +import Cardano.Api.Internal.TxIn (TxIn (..)) |
| 13 | + |
| 14 | +import Cardano.Ledger.Babbage () |
| 15 | + |
| 16 | +import Data.Aeson (FromJSON (..), ToJSON (..)) |
| 17 | +import qualified Data.Aeson as Aeson |
| 18 | +import qualified Data.Aeson.KeyMap as KeyMap |
| 19 | +import Data.Aeson.Types (Parser) |
| 20 | +import Data.Map (Map) |
| 21 | +import qualified Data.Map as Map |
| 22 | +import Data.Set (Set) |
| 23 | +import Data.Text (Text) |
| 24 | +import GHC.Exts (IsList (..)) |
| 25 | + |
| 26 | +newtype UTxO era = UTxO {unUTxO :: Map TxIn (TxOut CtxUTxO era)} |
| 27 | + deriving stock (Eq, Show) |
| 28 | + deriving newtype (Semigroup, Monoid, IsList) |
| 29 | + |
| 30 | +instance IsCardanoEra era => ToJSON (UTxO era) where |
| 31 | + toJSON (UTxO m) = toJSON m |
| 32 | + toEncoding (UTxO m) = toEncoding m |
| 33 | + |
| 34 | +instance |
| 35 | + IsShelleyBasedEra era |
| 36 | + => FromJSON (UTxO era) |
| 37 | + where |
| 38 | + parseJSON = Aeson.withObject "UTxO" $ \hm -> do |
| 39 | + let l = toList $ KeyMap.toHashMapText hm |
| 40 | + res <- mapM toTxIn l |
| 41 | + pure . UTxO $ Map.fromList res |
| 42 | + where |
| 43 | + toTxIn :: (Text, Aeson.Value) -> Parser (TxIn, TxOut CtxUTxO era) |
| 44 | + toTxIn (txinText, txOutVal) = do |
| 45 | + (,) |
| 46 | + <$> parseJSON (Aeson.String txinText) |
| 47 | + <*> parseJSON txOutVal |
| 48 | + |
| 49 | +-- | Infix version of `difference`. |
| 50 | +(\\) :: UTxO era -> UTxO era -> UTxO era |
| 51 | +a \\ b = difference a b |
| 52 | + |
| 53 | +-- | Create an empty `UTxO`. |
| 54 | +empty :: UTxO era |
| 55 | +empty = UTxO Map.empty |
| 56 | + |
| 57 | +-- | Create a `UTxO` from a single unspent transaction output. |
| 58 | +singleton :: TxIn -> TxOut CtxUTxO era -> UTxO era |
| 59 | +singleton i o = UTxO $ Map.singleton i o |
| 60 | + |
| 61 | +-- | Find a 'TxOut' for a given 'TxIn'. |
| 62 | +lookup :: TxIn -> UTxO era -> Maybe (TxOut CtxUTxO era) |
| 63 | +lookup k = Map.lookup k . unUTxO |
| 64 | + |
| 65 | +-- | Filter all `TxOut` that satisfy the predicate. |
| 66 | +filter :: (TxOut CtxUTxO era -> Bool) -> UTxO era -> UTxO era |
| 67 | +filter fn = UTxO . Map.filter fn . unUTxO |
| 68 | + |
| 69 | +-- | Filter all UTxO to only include 'out's satisfying given predicate. |
| 70 | +filterWithKey :: (TxIn -> TxOut CtxUTxO era -> Bool) -> UTxO era -> UTxO era |
| 71 | +filterWithKey fn = UTxO . Map.filterWithKey fn . unUTxO |
| 72 | + |
| 73 | +-- | Get the 'UTxO domain input's set |
| 74 | +inputSet :: UTxO (TxOut CtxUTxO era) -> Set TxIn |
| 75 | +inputSet = Map.keysSet . unUTxO |
| 76 | + |
| 77 | +-- | Remove the right hand side from the left hand side. |
| 78 | +difference :: UTxO era -> UTxO era -> UTxO era |
| 79 | +difference a b = UTxO $ Map.difference (unUTxO a) (unUTxO b) |
0 commit comments