{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
module Cardano.Wallet.Primitive.Types.TokenBundle
(
TokenBundle (..)
, AssetId (..)
, empty
, fromFlatList
, fromNestedList
, fromNestedMap
, fromTokenMap
, toFlatList
, fromCoin
, toCoin
, isCoin
, getCoin
, setCoin
, add
, subtract
, difference
, getQuantity
, hasQuantity
, setQuantity
, equipartitionAssets
, equipartitionQuantitiesWithUpperBound
, Lexicographic (..)
, Flat (..)
, Nested (..)
, getAssets
, mapAssetIds
, unsafeSubtract
) where
import Prelude hiding
( subtract )
import Algebra.PartialOrd
( PartialOrd (..) )
import Cardano.Wallet.Primitive.Types.Coin
( Coin (..) )
import Cardano.Wallet.Primitive.Types.TokenMap
( AssetId (..), Flat (..), Lexicographic (..), Nested (..), TokenMap )
import Cardano.Wallet.Primitive.Types.TokenPolicy
( TokenName, TokenPolicyId )
import Cardano.Wallet.Primitive.Types.TokenQuantity
( TokenQuantity (..) )
import Control.DeepSeq
( NFData )
import Control.Monad
( guard )
import Data.Bifunctor
( first )
import Data.Functor
( ($>) )
import Data.Hashable
( Hashable )
import Data.List.NonEmpty
( NonEmpty (..) )
import Data.Map.Strict
( Map )
import Data.Map.Strict.NonEmptyMap
( NonEmptyMap )
import Data.Ord
( comparing )
import Data.Set
( Set )
import Fmt
( Buildable (..), Builder, blockMapF )
import GHC.Generics
( Generic )
import GHC.TypeLits
( ErrorMessage (..), TypeError )
import qualified Cardano.Wallet.Primitive.Types.Coin as Coin
import qualified Cardano.Wallet.Primitive.Types.TokenMap as TokenMap
import qualified Data.List.NonEmpty as NE
data TokenBundle = TokenBundle
{ TokenBundle -> Coin
coin
:: !Coin
, TokenBundle -> TokenMap
tokens
:: !TokenMap
}
deriving stock (TokenBundle -> TokenBundle -> Bool
(TokenBundle -> TokenBundle -> Bool)
-> (TokenBundle -> TokenBundle -> Bool) -> Eq TokenBundle
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TokenBundle -> TokenBundle -> Bool
$c/= :: TokenBundle -> TokenBundle -> Bool
== :: TokenBundle -> TokenBundle -> Bool
$c== :: TokenBundle -> TokenBundle -> Bool
Eq, (forall x. TokenBundle -> Rep TokenBundle x)
-> (forall x. Rep TokenBundle x -> TokenBundle)
-> Generic TokenBundle
forall x. Rep TokenBundle x -> TokenBundle
forall x. TokenBundle -> Rep TokenBundle x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TokenBundle x -> TokenBundle
$cfrom :: forall x. TokenBundle -> Rep TokenBundle x
Generic, ReadPrec [TokenBundle]
ReadPrec TokenBundle
Int -> ReadS TokenBundle
ReadS [TokenBundle]
(Int -> ReadS TokenBundle)
-> ReadS [TokenBundle]
-> ReadPrec TokenBundle
-> ReadPrec [TokenBundle]
-> Read TokenBundle
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [TokenBundle]
$creadListPrec :: ReadPrec [TokenBundle]
readPrec :: ReadPrec TokenBundle
$creadPrec :: ReadPrec TokenBundle
readList :: ReadS [TokenBundle]
$creadList :: ReadS [TokenBundle]
readsPrec :: Int -> ReadS TokenBundle
$creadsPrec :: Int -> ReadS TokenBundle
Read, Int -> TokenBundle -> ShowS
[TokenBundle] -> ShowS
TokenBundle -> String
(Int -> TokenBundle -> ShowS)
-> (TokenBundle -> String)
-> ([TokenBundle] -> ShowS)
-> Show TokenBundle
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TokenBundle] -> ShowS
$cshowList :: [TokenBundle] -> ShowS
show :: TokenBundle -> String
$cshow :: TokenBundle -> String
showsPrec :: Int -> TokenBundle -> ShowS
$cshowsPrec :: Int -> TokenBundle -> ShowS
Show)
deriving anyclass (TokenBundle -> ()
(TokenBundle -> ()) -> NFData TokenBundle
forall a. (a -> ()) -> NFData a
rnf :: TokenBundle -> ()
$crnf :: TokenBundle -> ()
NFData, Int -> TokenBundle -> Int
TokenBundle -> Int
(Int -> TokenBundle -> Int)
-> (TokenBundle -> Int) -> Hashable TokenBundle
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: TokenBundle -> Int
$chash :: TokenBundle -> Int
hashWithSalt :: Int -> TokenBundle -> Int
$chashWithSalt :: Int -> TokenBundle -> Int
Hashable)
instance Semigroup TokenBundle where
<> :: TokenBundle -> TokenBundle -> TokenBundle
(<>) = TokenBundle -> TokenBundle -> TokenBundle
add
instance Monoid TokenBundle where
mempty :: TokenBundle
mempty = TokenBundle
empty
instance TypeError ('Text "Ord not supported for token bundles")
=> Ord TokenBundle where
compare :: TokenBundle -> TokenBundle -> Ordering
compare = String -> TokenBundle -> TokenBundle -> Ordering
forall a. HasCallStack => String -> a
error String
"Ord not supported for token bundles"
instance PartialOrd TokenBundle where
TokenBundle
b1 leq :: TokenBundle -> TokenBundle -> Bool
`leq` TokenBundle
b2 = Bool -> Bool -> Bool
(&&)
(TokenBundle -> Coin
coin TokenBundle
b1 Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
<= TokenBundle -> Coin
coin TokenBundle
b2)
(TokenBundle -> TokenMap
tokens TokenBundle
b1 TokenMap -> TokenMap -> Bool
forall a. PartialOrd a => a -> a -> Bool
`leq` TokenBundle -> TokenMap
tokens TokenBundle
b2)
instance Ord (Lexicographic TokenBundle) where
compare :: Lexicographic TokenBundle -> Lexicographic TokenBundle -> Ordering
compare = (Lexicographic TokenBundle -> (Coin, Lexicographic TokenMap))
-> Lexicographic TokenBundle
-> Lexicographic TokenBundle
-> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Lexicographic TokenBundle -> (Coin, Lexicographic TokenMap)
projection
where
projection :: Lexicographic TokenBundle -> (Coin, Lexicographic TokenMap)
projection (Lexicographic (TokenBundle Coin
c TokenMap
m)) = (Coin
c, TokenMap -> Lexicographic TokenMap
forall a. a -> Lexicographic a
Lexicographic TokenMap
m)
instance Buildable (Flat TokenBundle) where
build :: Flat TokenBundle -> Builder
build = (TokenMap -> Flat TokenMap) -> TokenBundle -> Builder
forall (style :: * -> *).
Buildable (style TokenMap) =>
(TokenMap -> style TokenMap) -> TokenBundle -> Builder
buildBundle TokenMap -> Flat TokenMap
forall a. a -> Flat a
Flat (TokenBundle -> Builder)
-> (Flat TokenBundle -> TokenBundle) -> Flat TokenBundle -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flat TokenBundle -> TokenBundle
forall a. Flat a -> a
getFlat
instance Buildable (Nested TokenBundle) where
build :: Nested TokenBundle -> Builder
build = (TokenMap -> Nested TokenMap) -> TokenBundle -> Builder
forall (style :: * -> *).
Buildable (style TokenMap) =>
(TokenMap -> style TokenMap) -> TokenBundle -> Builder
buildBundle TokenMap -> Nested TokenMap
forall a. a -> Nested a
Nested (TokenBundle -> Builder)
-> (Nested TokenBundle -> TokenBundle)
-> Nested TokenBundle
-> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Nested TokenBundle -> TokenBundle
forall a. Nested a -> a
getNested
buildBundle
:: Buildable (style TokenMap)
=> (TokenMap -> style TokenMap)
-> TokenBundle
-> Builder
buildBundle :: (TokenMap -> style TokenMap) -> TokenBundle -> Builder
buildBundle TokenMap -> style TokenMap
style TokenBundle {Coin
coin :: Coin
$sel:coin:TokenBundle :: TokenBundle -> Coin
coin, TokenMap
tokens :: TokenMap
$sel:tokens:TokenBundle :: TokenBundle -> TokenMap
tokens} = [(String, Builder)] -> Builder
buildMap
[ (String
"coin"
, Coin -> Builder
forall p. Buildable p => p -> Builder
build Coin
coin)
, (String
"tokens"
, style TokenMap -> Builder
forall p. Buildable p => p -> Builder
build (style TokenMap -> Builder) -> style TokenMap -> Builder
forall a b. (a -> b) -> a -> b
$ TokenMap -> style TokenMap
style TokenMap
tokens)
]
buildMap :: [(String, Builder)] -> Builder
buildMap :: [(String, Builder)] -> Builder
buildMap = [(String, Builder)] -> Builder
forall t k v.
(IsList t, Item t ~ (k, v), Buildable k, Buildable v) =>
t -> Builder
blockMapF ([(String, Builder)] -> Builder)
-> ([(String, Builder)] -> [(String, Builder)])
-> [(String, Builder)]
-> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, Builder) -> (String, Builder))
-> [(String, Builder)] -> [(String, Builder)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ShowS -> (String, Builder) -> (String, Builder)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ShowS -> (String, Builder) -> (String, Builder))
-> ShowS -> (String, Builder) -> (String, Builder)
forall a b. (a -> b) -> a -> b
$ ShowS
forall a. a -> a
id @String)
empty :: TokenBundle
empty :: TokenBundle
empty = Coin -> TokenMap -> TokenBundle
TokenBundle (Natural -> Coin
Coin Natural
0) TokenMap
forall a. Monoid a => a
mempty
fromFlatList
:: Coin
-> [(AssetId, TokenQuantity)]
-> TokenBundle
fromFlatList :: Coin -> [(AssetId, TokenQuantity)] -> TokenBundle
fromFlatList Coin
c = Coin -> TokenMap -> TokenBundle
TokenBundle Coin
c (TokenMap -> TokenBundle)
-> ([(AssetId, TokenQuantity)] -> TokenMap)
-> [(AssetId, TokenQuantity)]
-> TokenBundle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(AssetId, TokenQuantity)] -> TokenMap
TokenMap.fromFlatList
fromNestedList
:: Coin
-> [(TokenPolicyId, NonEmpty (TokenName, TokenQuantity))]
-> TokenBundle
fromNestedList :: Coin
-> [(TokenPolicyId, NonEmpty (TokenName, TokenQuantity))]
-> TokenBundle
fromNestedList Coin
c = Coin -> TokenMap -> TokenBundle
TokenBundle Coin
c (TokenMap -> TokenBundle)
-> ([(TokenPolicyId, NonEmpty (TokenName, TokenQuantity))]
-> TokenMap)
-> [(TokenPolicyId, NonEmpty (TokenName, TokenQuantity))]
-> TokenBundle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(TokenPolicyId, NonEmpty (TokenName, TokenQuantity))] -> TokenMap
TokenMap.fromNestedList
fromNestedMap
:: (Coin, Map TokenPolicyId (NonEmptyMap TokenName TokenQuantity))
-> TokenBundle
fromNestedMap :: (Coin, Map TokenPolicyId (NonEmptyMap TokenName TokenQuantity))
-> TokenBundle
fromNestedMap (Coin
c, Map TokenPolicyId (NonEmptyMap TokenName TokenQuantity)
m) = Coin -> TokenMap -> TokenBundle
TokenBundle Coin
c (Map TokenPolicyId (NonEmptyMap TokenName TokenQuantity) -> TokenMap
TokenMap.fromNestedMap Map TokenPolicyId (NonEmptyMap TokenName TokenQuantity)
m)
fromTokenMap :: TokenMap -> TokenBundle
fromTokenMap :: TokenMap -> TokenBundle
fromTokenMap = Coin -> TokenMap -> TokenBundle
TokenBundle (Natural -> Coin
Coin Natural
0)
toFlatList :: TokenBundle -> (Coin, [(AssetId, TokenQuantity)])
toFlatList :: TokenBundle -> (Coin, [(AssetId, TokenQuantity)])
toFlatList (TokenBundle Coin
c TokenMap
m) = (Coin
c, TokenMap -> [(AssetId, TokenQuantity)]
TokenMap.toFlatList TokenMap
m)
fromCoin :: Coin -> TokenBundle
fromCoin :: Coin -> TokenBundle
fromCoin Coin
c = Coin -> TokenMap -> TokenBundle
TokenBundle Coin
c TokenMap
forall a. Monoid a => a
mempty
toCoin :: TokenBundle -> Maybe Coin
toCoin :: TokenBundle -> Maybe Coin
toCoin (TokenBundle Coin
c TokenMap
ts)
| TokenMap -> Bool
TokenMap.isEmpty TokenMap
ts = Coin -> Maybe Coin
forall a. a -> Maybe a
Just Coin
c
| Bool
otherwise = Maybe Coin
forall a. Maybe a
Nothing
isCoin :: TokenBundle -> Bool
isCoin :: TokenBundle -> Bool
isCoin (TokenBundle Coin
_ TokenMap
m) = TokenMap -> Bool
TokenMap.isEmpty TokenMap
m
getCoin :: TokenBundle -> Coin
getCoin :: TokenBundle -> Coin
getCoin (TokenBundle Coin
c TokenMap
_) = Coin
c
setCoin :: TokenBundle -> Coin -> TokenBundle
setCoin :: TokenBundle -> Coin -> TokenBundle
setCoin TokenBundle
b Coin
c = TokenBundle
b { $sel:coin:TokenBundle :: Coin
coin = Coin
c }
add :: TokenBundle -> TokenBundle -> TokenBundle
add :: TokenBundle -> TokenBundle -> TokenBundle
add (TokenBundle (Coin Natural
c1) TokenMap
m1) (TokenBundle (Coin Natural
c2) TokenMap
m2) =
Coin -> TokenMap -> TokenBundle
TokenBundle (Natural -> Coin
Coin (Natural -> Coin) -> Natural -> Coin
forall a b. (a -> b) -> a -> b
$ Natural
c1 Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
c2) (TokenMap -> TokenMap -> TokenMap
TokenMap.add TokenMap
m1 TokenMap
m2)
subtract :: TokenBundle -> TokenBundle -> Maybe TokenBundle
subtract :: TokenBundle -> TokenBundle -> Maybe TokenBundle
subtract TokenBundle
a TokenBundle
b = Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (TokenBundle
b TokenBundle -> TokenBundle -> Bool
forall a. PartialOrd a => a -> a -> Bool
`leq` TokenBundle
a) Maybe () -> TokenBundle -> Maybe TokenBundle
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> TokenBundle -> TokenBundle -> TokenBundle
unsafeSubtract TokenBundle
a TokenBundle
b
difference :: TokenBundle -> TokenBundle -> TokenBundle
difference :: TokenBundle -> TokenBundle -> TokenBundle
difference (TokenBundle Coin
c1 TokenMap
m1) (TokenBundle Coin
c2 TokenMap
m2) =
Coin -> TokenMap -> TokenBundle
TokenBundle
(Coin -> Coin -> Coin
Coin.difference Coin
c1 Coin
c2)
(TokenMap -> TokenMap -> TokenMap
TokenMap.difference TokenMap
m1 TokenMap
m2)
getQuantity :: TokenBundle -> AssetId -> TokenQuantity
getQuantity :: TokenBundle -> AssetId -> TokenQuantity
getQuantity = TokenMap -> AssetId -> TokenQuantity
TokenMap.getQuantity (TokenMap -> AssetId -> TokenQuantity)
-> (TokenBundle -> TokenMap)
-> TokenBundle
-> AssetId
-> TokenQuantity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TokenBundle -> TokenMap
tokens
hasQuantity :: TokenBundle -> AssetId -> Bool
hasQuantity :: TokenBundle -> AssetId -> Bool
hasQuantity = TokenMap -> AssetId -> Bool
TokenMap.hasQuantity (TokenMap -> AssetId -> Bool)
-> (TokenBundle -> TokenMap) -> TokenBundle -> AssetId -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TokenBundle -> TokenMap
tokens
setQuantity :: TokenBundle -> AssetId -> TokenQuantity -> TokenBundle
setQuantity :: TokenBundle -> AssetId -> TokenQuantity -> TokenBundle
setQuantity (TokenBundle Coin
c TokenMap
m) AssetId
a TokenQuantity
q = Coin -> TokenMap -> TokenBundle
TokenBundle Coin
c (TokenMap -> AssetId -> TokenQuantity -> TokenMap
TokenMap.setQuantity TokenMap
m AssetId
a TokenQuantity
q)
equipartitionAssets
:: TokenBundle
-> NonEmpty a
-> NonEmpty TokenBundle
equipartitionAssets :: TokenBundle -> NonEmpty a -> NonEmpty TokenBundle
equipartitionAssets (TokenBundle Coin
c TokenMap
m) NonEmpty a
count =
(Coin -> TokenMap -> TokenBundle)
-> NonEmpty Coin -> NonEmpty TokenMap -> NonEmpty TokenBundle
forall a b c.
(a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c
NE.zipWith Coin -> TokenMap -> TokenBundle
TokenBundle NonEmpty Coin
cs NonEmpty TokenMap
ms
where
cs :: NonEmpty Coin
cs = Coin -> NonEmpty a -> NonEmpty Coin
forall a. Coin -> NonEmpty a -> NonEmpty Coin
Coin.equipartition Coin
c NonEmpty a
count
ms :: NonEmpty TokenMap
ms = TokenMap -> NonEmpty a -> NonEmpty TokenMap
forall a. TokenMap -> NonEmpty a -> NonEmpty TokenMap
TokenMap.equipartitionAssets TokenMap
m NonEmpty a
count
equipartitionQuantitiesWithUpperBound
:: TokenBundle
-> TokenQuantity
-> NonEmpty TokenBundle
equipartitionQuantitiesWithUpperBound :: TokenBundle -> TokenQuantity -> NonEmpty TokenBundle
equipartitionQuantitiesWithUpperBound (TokenBundle Coin
c TokenMap
m) TokenQuantity
maxQuantity =
(Coin -> TokenMap -> TokenBundle)
-> NonEmpty Coin -> NonEmpty TokenMap -> NonEmpty TokenBundle
forall a b c.
(a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c
NE.zipWith Coin -> TokenMap -> TokenBundle
TokenBundle NonEmpty Coin
cs NonEmpty TokenMap
ms
where
cs :: NonEmpty Coin
cs = Coin -> NonEmpty TokenMap -> NonEmpty Coin
forall a. Coin -> NonEmpty a -> NonEmpty Coin
Coin.equipartition Coin
c NonEmpty TokenMap
ms
ms :: NonEmpty TokenMap
ms = TokenMap -> TokenQuantity -> NonEmpty TokenMap
TokenMap.equipartitionQuantitiesWithUpperBound TokenMap
m TokenQuantity
maxQuantity
getAssets :: TokenBundle -> Set AssetId
getAssets :: TokenBundle -> Set AssetId
getAssets = TokenMap -> Set AssetId
TokenMap.getAssets (TokenMap -> Set AssetId)
-> (TokenBundle -> TokenMap) -> TokenBundle -> Set AssetId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TokenBundle -> TokenMap
tokens
mapAssetIds :: (AssetId -> AssetId) -> TokenBundle -> TokenBundle
mapAssetIds :: (AssetId -> AssetId) -> TokenBundle -> TokenBundle
mapAssetIds AssetId -> AssetId
f (TokenBundle Coin
c TokenMap
m) = Coin -> TokenMap -> TokenBundle
TokenBundle Coin
c ((AssetId -> AssetId) -> TokenMap -> TokenMap
TokenMap.mapAssetIds AssetId -> AssetId
f TokenMap
m)
unsafeSubtract :: TokenBundle -> TokenBundle -> TokenBundle
unsafeSubtract :: TokenBundle -> TokenBundle -> TokenBundle
unsafeSubtract (TokenBundle (Coin Natural
c1) TokenMap
m1) (TokenBundle (Coin Natural
c2) TokenMap
m2) =
Coin -> TokenMap -> TokenBundle
TokenBundle (Natural -> Coin
Coin (Natural -> Coin) -> Natural -> Coin
forall a b. (a -> b) -> a -> b
$ Natural
c1 Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
c2) (TokenMap -> TokenMap -> TokenMap
TokenMap.unsafeSubtract TokenMap
m1 TokenMap
m2)