{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE TypeApplications #-}
module Cardano.Wallet.Primitive.Types.Coin
(
Coin (..)
, fromIntegral
, fromNatural
, fromWord64
, toInteger
, toNatural
, toQuantity
, toWord64
, unsafeFromIntegral
, unsafeToQuantity
, unsafeToWord64
, add
, subtract
, difference
, distance
, equipartition
, partition
, partitionDefault
, unsafePartition
) where
import Prelude hiding
( fromIntegral, subtract, toInteger )
import Cardano.Numeric.Util
( equipartitionNatural, partitionNatural )
import Control.DeepSeq
( NFData (..) )
import Data.Bits
( Bits )
import Data.Hashable
( Hashable )
import Data.IntCast
( intCast, intCastMaybe )
import Data.List.NonEmpty
( NonEmpty (..) )
import Data.Maybe
( fromMaybe )
import Data.Quantity
( Quantity (..) )
import Data.Text.Class
( FromText (..), ToText (..) )
import Data.Word
( Word64 )
import Fmt
( Buildable (..), fixedF )
import GHC.Generics
( Generic )
import GHC.Stack
( HasCallStack )
import Numeric.Natural
( Natural )
import Quiet
( Quiet (..) )
import qualified Data.Text as T
import qualified Prelude
newtype Coin = Coin
{ Coin -> Natural
unCoin :: Natural
}
deriving stock (Eq Coin
Eq Coin
-> (Coin -> Coin -> Ordering)
-> (Coin -> Coin -> Bool)
-> (Coin -> Coin -> Bool)
-> (Coin -> Coin -> Bool)
-> (Coin -> Coin -> Bool)
-> (Coin -> Coin -> Coin)
-> (Coin -> Coin -> Coin)
-> Ord Coin
Coin -> Coin -> Bool
Coin -> Coin -> Ordering
Coin -> Coin -> Coin
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Coin -> Coin -> Coin
$cmin :: Coin -> Coin -> Coin
max :: Coin -> Coin -> Coin
$cmax :: Coin -> Coin -> Coin
>= :: Coin -> Coin -> Bool
$c>= :: Coin -> Coin -> Bool
> :: Coin -> Coin -> Bool
$c> :: Coin -> Coin -> Bool
<= :: Coin -> Coin -> Bool
$c<= :: Coin -> Coin -> Bool
< :: Coin -> Coin -> Bool
$c< :: Coin -> Coin -> Bool
compare :: Coin -> Coin -> Ordering
$ccompare :: Coin -> Coin -> Ordering
$cp1Ord :: Eq Coin
Ord, Coin -> Coin -> Bool
(Coin -> Coin -> Bool) -> (Coin -> Coin -> Bool) -> Eq Coin
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Coin -> Coin -> Bool
$c/= :: Coin -> Coin -> Bool
== :: Coin -> Coin -> Bool
$c== :: Coin -> Coin -> Bool
Eq, (forall x. Coin -> Rep Coin x)
-> (forall x. Rep Coin x -> Coin) -> Generic Coin
forall x. Rep Coin x -> Coin
forall x. Coin -> Rep Coin x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Coin x -> Coin
$cfrom :: forall x. Coin -> Rep Coin x
Generic)
deriving (ReadPrec [Coin]
ReadPrec Coin
Int -> ReadS Coin
ReadS [Coin]
(Int -> ReadS Coin)
-> ReadS [Coin] -> ReadPrec Coin -> ReadPrec [Coin] -> Read Coin
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Coin]
$creadListPrec :: ReadPrec [Coin]
readPrec :: ReadPrec Coin
$creadPrec :: ReadPrec Coin
readList :: ReadS [Coin]
$creadList :: ReadS [Coin]
readsPrec :: Int -> ReadS Coin
$creadsPrec :: Int -> ReadS Coin
Read, Int -> Coin -> ShowS
[Coin] -> ShowS
Coin -> String
(Int -> Coin -> ShowS)
-> (Coin -> String) -> ([Coin] -> ShowS) -> Show Coin
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Coin] -> ShowS
$cshowList :: [Coin] -> ShowS
show :: Coin -> String
$cshow :: Coin -> String
showsPrec :: Int -> Coin -> ShowS
$cshowsPrec :: Int -> Coin -> ShowS
Show) via (Quiet Coin)
instance Semigroup Coin where
<> :: Coin -> Coin -> Coin
(<>) = Coin -> Coin -> Coin
add
instance Monoid Coin where
mempty :: Coin
mempty = Natural -> Coin
Coin Natural
0
instance ToText Coin where
toText :: Coin -> Text
toText (Coin Natural
c) = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Natural -> String
forall a. Show a => a -> String
show Natural
c
instance FromText Coin where
fromText :: Text -> Either TextDecodingError Coin
fromText = (Natural -> Coin)
-> Either TextDecodingError Natural
-> Either TextDecodingError Coin
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Natural -> Coin
Coin (Either TextDecodingError Natural -> Either TextDecodingError Coin)
-> (Text -> Either TextDecodingError Natural)
-> Text
-> Either TextDecodingError Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FromText Natural => Text -> Either TextDecodingError Natural
forall a. FromText a => Text -> Either TextDecodingError a
fromText @Natural
instance NFData Coin
instance Hashable Coin
instance Buildable Coin where
build :: Coin -> Builder
build (Coin Natural
c) = Int -> Double -> Builder
forall a. Real a => Int -> a -> Builder
fixedF @Double Int
6 (Natural -> Double
forall a b. (Integral a, Num b) => a -> b
Prelude.fromIntegral Natural
c Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1e6)
fromIntegral :: (Bits i, Integral i) => i -> Maybe Coin
fromIntegral :: i -> Maybe Coin
fromIntegral i
i = Natural -> Coin
Coin (Natural -> Coin) -> Maybe Natural -> Maybe Coin
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> i -> Maybe Natural
forall a b.
(Integral a, Integral b, Bits a, Bits b) =>
a -> Maybe b
intCastMaybe i
i
fromNatural :: Natural -> Coin
fromNatural :: Natural -> Coin
fromNatural = Natural -> Coin
Coin
fromWord64 :: Word64 -> Coin
fromWord64 :: Word64 -> Coin
fromWord64 = Natural -> Coin
Coin (Natural -> Coin) -> (Word64 -> Natural) -> Word64 -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Natural
forall a b.
(Integral a, Integral b, IsIntSubType a b ~ 'True) =>
a -> b
intCast
toInteger :: Coin -> Integer
toInteger :: Coin -> Integer
toInteger = Natural -> Integer
forall a b.
(Integral a, Integral b, IsIntSubType a b ~ 'True) =>
a -> b
intCast (Natural -> Integer) -> (Coin -> Natural) -> Coin -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coin -> Natural
unCoin
toNatural :: Coin -> Natural
toNatural :: Coin -> Natural
toNatural = Coin -> Natural
unCoin
toQuantity :: (Bits i, Integral i) => Coin -> Maybe (Quantity n i)
toQuantity :: Coin -> Maybe (Quantity n i)
toQuantity (Coin Natural
c) = i -> Quantity n i
forall (unit :: Symbol) a. a -> Quantity unit a
Quantity (i -> Quantity n i) -> Maybe i -> Maybe (Quantity n i)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Natural -> Maybe i
forall a b.
(Integral a, Integral b, Bits a, Bits b) =>
a -> Maybe b
intCastMaybe Natural
c
toWord64 :: Coin -> Maybe Word64
toWord64 :: Coin -> Maybe Word64
toWord64 (Coin Natural
c) = Natural -> Maybe Word64
forall a b.
(Integral a, Integral b, Bits a, Bits b) =>
a -> Maybe b
intCastMaybe Natural
c
unsafeFromIntegral
:: HasCallStack
=> (Bits i, Integral i, Show i)
=> i
-> Coin
unsafeFromIntegral :: i -> Coin
unsafeFromIntegral i
i = Coin -> Maybe Coin -> Coin
forall a. a -> Maybe a -> a
fromMaybe Coin
forall a. a
onError (i -> Maybe Coin
forall i. (Bits i, Integral i) => i -> Maybe Coin
fromIntegral i
i)
where
onError :: a
onError = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords
[ String
"Coin.unsafeFromIntegral:"
, i -> String
forall a. Show a => a -> String
show i
i
, String
"is not a natural number."
]
unsafeToQuantity
:: HasCallStack
=> (Bits i, Integral i)
=> Coin
-> Quantity n i
unsafeToQuantity :: Coin -> Quantity n i
unsafeToQuantity Coin
c = Quantity n i -> Maybe (Quantity n i) -> Quantity n i
forall a. a -> Maybe a -> a
fromMaybe Quantity n i
forall a. a
onError (Coin -> Maybe (Quantity n i)
forall i (n :: Symbol).
(Bits i, Integral i) =>
Coin -> Maybe (Quantity n i)
toQuantity Coin
c)
where
onError :: a
onError = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords
[ String
"Coin.unsafeToQuantity:"
, Coin -> String
forall a. Show a => a -> String
show Coin
c
, String
"does not fit within the bounds of the target type."
]
unsafeToWord64 :: HasCallStack => Coin -> Word64
unsafeToWord64 :: Coin -> Word64
unsafeToWord64 Coin
c = Word64 -> Maybe Word64 -> Word64
forall a. a -> Maybe a -> a
fromMaybe Word64
forall a. a
onError (Coin -> Maybe Word64
toWord64 Coin
c)
where
onError :: a
onError = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords
[ String
"Coin.unsafeToWord64:"
, Coin -> String
forall a. Show a => a -> String
show Coin
c
, String
"does not fit within the bounds of a 64-bit word."
]
subtract :: Coin -> Coin -> Maybe Coin
subtract :: Coin -> Coin -> Maybe Coin
subtract (Coin Natural
a) (Coin Natural
b)
| Natural
a Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
>= Natural
b = Coin -> Maybe Coin
forall a. a -> Maybe a
Just (Coin -> Maybe Coin) -> Coin -> Maybe Coin
forall a b. (a -> b) -> a -> b
$ Natural -> Coin
Coin (Natural
a Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
b)
| Bool
otherwise = Maybe Coin
forall a. Maybe a
Nothing
add :: Coin -> Coin -> Coin
add :: Coin -> Coin -> Coin
add (Coin Natural
a) (Coin Natural
b) = Natural -> Coin
Coin (Natural
a Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
b)
difference :: Coin -> Coin -> Coin
difference :: Coin -> Coin -> Coin
difference Coin
a Coin
b = Coin -> Maybe Coin -> Coin
forall a. a -> Maybe a -> a
fromMaybe (Natural -> Coin
Coin Natural
0) (Coin -> Coin -> Maybe Coin
subtract Coin
a Coin
b)
distance :: Coin -> Coin -> Coin
distance :: Coin -> Coin -> Coin
distance (Coin Natural
a) (Coin Natural
b) = if Natural
a Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
< Natural
b then Natural -> Coin
Coin (Natural
b Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
a) else Natural -> Coin
Coin (Natural
a Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
b)
equipartition
:: Coin
-> NonEmpty a
-> NonEmpty Coin
equipartition :: Coin -> NonEmpty a -> NonEmpty Coin
equipartition Coin
c =
(Natural -> Coin) -> NonEmpty Natural -> NonEmpty Coin
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Natural -> Coin
fromNatural (NonEmpty Natural -> NonEmpty Coin)
-> (NonEmpty a -> NonEmpty Natural) -> NonEmpty a -> NonEmpty Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> NonEmpty a -> NonEmpty Natural
forall a. HasCallStack => Natural -> NonEmpty a -> NonEmpty Natural
equipartitionNatural (Coin -> Natural
toNatural Coin
c)
partition
:: Coin
-> NonEmpty Coin
-> Maybe (NonEmpty Coin)
partition :: Coin -> NonEmpty Coin -> Maybe (NonEmpty Coin)
partition Coin
c
= (NonEmpty Natural -> NonEmpty Coin)
-> Maybe (NonEmpty Natural) -> Maybe (NonEmpty Coin)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Natural -> Coin) -> NonEmpty Natural -> NonEmpty Coin
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Natural -> Coin
fromNatural)
(Maybe (NonEmpty Natural) -> Maybe (NonEmpty Coin))
-> (NonEmpty Coin -> Maybe (NonEmpty Natural))
-> NonEmpty Coin
-> Maybe (NonEmpty Coin)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> NonEmpty Natural -> Maybe (NonEmpty Natural)
partitionNatural (Coin -> Natural
toNatural Coin
c)
(NonEmpty Natural -> Maybe (NonEmpty Natural))
-> (NonEmpty Coin -> NonEmpty Natural)
-> NonEmpty Coin
-> Maybe (NonEmpty Natural)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Natural) -> NonEmpty Coin -> NonEmpty Natural
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Coin -> Natural
toNatural
partitionDefault
:: Coin
-> NonEmpty Coin
-> NonEmpty Coin
partitionDefault :: Coin -> NonEmpty Coin -> NonEmpty Coin
partitionDefault Coin
c NonEmpty Coin
ws = NonEmpty Coin -> Maybe (NonEmpty Coin) -> NonEmpty Coin
forall a. a -> Maybe a -> a
fromMaybe (Coin -> NonEmpty Coin -> NonEmpty Coin
forall a. Coin -> NonEmpty a -> NonEmpty Coin
equipartition Coin
c NonEmpty Coin
ws) (Coin -> NonEmpty Coin -> Maybe (NonEmpty Coin)
partition Coin
c NonEmpty Coin
ws)
unsafePartition
:: HasCallStack
=> Coin
-> NonEmpty Coin
-> NonEmpty Coin
unsafePartition :: Coin -> NonEmpty Coin -> NonEmpty Coin
unsafePartition = (NonEmpty Coin -> Maybe (NonEmpty Coin) -> NonEmpty Coin
forall a. a -> Maybe a -> a
fromMaybe NonEmpty Coin
forall a. a
zeroWeightSumError (Maybe (NonEmpty Coin) -> NonEmpty Coin)
-> (NonEmpty Coin -> Maybe (NonEmpty Coin))
-> NonEmpty Coin
-> NonEmpty Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((NonEmpty Coin -> Maybe (NonEmpty Coin))
-> NonEmpty Coin -> NonEmpty Coin)
-> (Coin -> NonEmpty Coin -> Maybe (NonEmpty Coin))
-> Coin
-> NonEmpty Coin
-> NonEmpty Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coin -> NonEmpty Coin -> Maybe (NonEmpty Coin)
partition
where
zeroWeightSumError :: a
zeroWeightSumError = String -> a
forall a. HasCallStack => String -> a
error
String
"Coin.unsafePartition: weights must have a non-zero sum."