{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE TypeApplications #-}

module Cardano.Wallet.Primitive.Types.TokenQuantity
    (
      -- * Type
      TokenQuantity (..)

      -- * Values
    , zero

      -- * Arithmetic operations
    , add
    , subtract
    , pred
    , predZero
    , succ
    , difference

      -- * Partitioning
    , equipartition
    , partition
    , partitionDefault

      -- * Tests
    , isNonZero
    , isZero

      -- * Unsafe operations
    , unsafeSubtract

    ) where

import Prelude hiding
    ( pred, subtract, succ )

import Cardano.Numeric.Util
    ( equipartitionNatural, partitionNatural )
import Control.DeepSeq
    ( NFData (..) )
import Control.Monad
    ( guard )
import Data.Aeson
    ( FromJSON (..), ToJSON (..) )
import Data.Functor
    ( ($>) )
import Data.Hashable
    ( Hashable )
import Data.List.NonEmpty
    ( NonEmpty (..) )
import Data.Maybe
    ( fromMaybe )
import Data.Text.Class
    ( FromText (..), ToText (..) )
import Fmt
    ( Buildable (..) )
import GHC.Generics
    ( Generic )
import Numeric.Natural
    ( Natural )
import Quiet
    ( Quiet (..) )

--------------------------------------------------------------------------------
-- Type
--------------------------------------------------------------------------------

-- | Represents an integral quantity of tokens.
--
-- At present, we use 'Natural' as our underlying type, as the only use case
-- for these quantities is to be included in token bundles held within
-- transaction outputs, and these must never be negative.
--
-- When we build support for minting and burning of tokens, we may wish to
-- parameterize this type and allow it to be instantiated with 'Integer'.
--
newtype TokenQuantity = TokenQuantity
    { TokenQuantity -> Natural
unTokenQuantity :: Natural }
    deriving stock (TokenQuantity -> TokenQuantity -> Bool
(TokenQuantity -> TokenQuantity -> Bool)
-> (TokenQuantity -> TokenQuantity -> Bool) -> Eq TokenQuantity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TokenQuantity -> TokenQuantity -> Bool
$c/= :: TokenQuantity -> TokenQuantity -> Bool
== :: TokenQuantity -> TokenQuantity -> Bool
$c== :: TokenQuantity -> TokenQuantity -> Bool
Eq, Eq TokenQuantity
Eq TokenQuantity
-> (TokenQuantity -> TokenQuantity -> Ordering)
-> (TokenQuantity -> TokenQuantity -> Bool)
-> (TokenQuantity -> TokenQuantity -> Bool)
-> (TokenQuantity -> TokenQuantity -> Bool)
-> (TokenQuantity -> TokenQuantity -> Bool)
-> (TokenQuantity -> TokenQuantity -> TokenQuantity)
-> (TokenQuantity -> TokenQuantity -> TokenQuantity)
-> Ord TokenQuantity
TokenQuantity -> TokenQuantity -> Bool
TokenQuantity -> TokenQuantity -> Ordering
TokenQuantity -> TokenQuantity -> TokenQuantity
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 :: TokenQuantity -> TokenQuantity -> TokenQuantity
$cmin :: TokenQuantity -> TokenQuantity -> TokenQuantity
max :: TokenQuantity -> TokenQuantity -> TokenQuantity
$cmax :: TokenQuantity -> TokenQuantity -> TokenQuantity
>= :: TokenQuantity -> TokenQuantity -> Bool
$c>= :: TokenQuantity -> TokenQuantity -> Bool
> :: TokenQuantity -> TokenQuantity -> Bool
$c> :: TokenQuantity -> TokenQuantity -> Bool
<= :: TokenQuantity -> TokenQuantity -> Bool
$c<= :: TokenQuantity -> TokenQuantity -> Bool
< :: TokenQuantity -> TokenQuantity -> Bool
$c< :: TokenQuantity -> TokenQuantity -> Bool
compare :: TokenQuantity -> TokenQuantity -> Ordering
$ccompare :: TokenQuantity -> TokenQuantity -> Ordering
$cp1Ord :: Eq TokenQuantity
Ord, (forall x. TokenQuantity -> Rep TokenQuantity x)
-> (forall x. Rep TokenQuantity x -> TokenQuantity)
-> Generic TokenQuantity
forall x. Rep TokenQuantity x -> TokenQuantity
forall x. TokenQuantity -> Rep TokenQuantity x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TokenQuantity x -> TokenQuantity
$cfrom :: forall x. TokenQuantity -> Rep TokenQuantity x
Generic)
    deriving (ReadPrec [TokenQuantity]
ReadPrec TokenQuantity
Int -> ReadS TokenQuantity
ReadS [TokenQuantity]
(Int -> ReadS TokenQuantity)
-> ReadS [TokenQuantity]
-> ReadPrec TokenQuantity
-> ReadPrec [TokenQuantity]
-> Read TokenQuantity
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [TokenQuantity]
$creadListPrec :: ReadPrec [TokenQuantity]
readPrec :: ReadPrec TokenQuantity
$creadPrec :: ReadPrec TokenQuantity
readList :: ReadS [TokenQuantity]
$creadList :: ReadS [TokenQuantity]
readsPrec :: Int -> ReadS TokenQuantity
$creadsPrec :: Int -> ReadS TokenQuantity
Read, Int -> TokenQuantity -> ShowS
[TokenQuantity] -> ShowS
TokenQuantity -> String
(Int -> TokenQuantity -> ShowS)
-> (TokenQuantity -> String)
-> ([TokenQuantity] -> ShowS)
-> Show TokenQuantity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TokenQuantity] -> ShowS
$cshowList :: [TokenQuantity] -> ShowS
show :: TokenQuantity -> String
$cshow :: TokenQuantity -> String
showsPrec :: Int -> TokenQuantity -> ShowS
$cshowsPrec :: Int -> TokenQuantity -> ShowS
Show) via (Quiet TokenQuantity)
    deriving anyclass (TokenQuantity -> ()
(TokenQuantity -> ()) -> NFData TokenQuantity
forall a. (a -> ()) -> NFData a
rnf :: TokenQuantity -> ()
$crnf :: TokenQuantity -> ()
NFData, Int -> TokenQuantity -> Int
TokenQuantity -> Int
(Int -> TokenQuantity -> Int)
-> (TokenQuantity -> Int) -> Hashable TokenQuantity
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: TokenQuantity -> Int
$chash :: TokenQuantity -> Int
hashWithSalt :: Int -> TokenQuantity -> Int
$chashWithSalt :: Int -> TokenQuantity -> Int
Hashable)

--------------------------------------------------------------------------------
-- Instances
--------------------------------------------------------------------------------

instance Semigroup TokenQuantity where
    <> :: TokenQuantity -> TokenQuantity -> TokenQuantity
(<>) = TokenQuantity -> TokenQuantity -> TokenQuantity
add

instance Monoid TokenQuantity where
    mempty :: TokenQuantity
mempty = TokenQuantity
zero

instance Buildable TokenQuantity where
    build :: TokenQuantity -> Builder
build = Text -> Builder
forall p. Buildable p => p -> Builder
build (Text -> Builder)
-> (TokenQuantity -> Text) -> TokenQuantity -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> Text
forall a. ToText a => a -> Text
toText (Natural -> Text)
-> (TokenQuantity -> Natural) -> TokenQuantity -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TokenQuantity -> Natural
unTokenQuantity

instance ToText TokenQuantity where
    toText :: TokenQuantity -> Text
toText = Natural -> Text
forall a. ToText a => a -> Text
toText (Natural -> Text)
-> (TokenQuantity -> Natural) -> TokenQuantity -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TokenQuantity -> Natural
unTokenQuantity

instance FromText TokenQuantity where
    fromText :: Text -> Either TextDecodingError TokenQuantity
fromText = (Integer -> TokenQuantity)
-> Either TextDecodingError Integer
-> Either TextDecodingError TokenQuantity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Natural -> TokenQuantity
TokenQuantity (Natural -> TokenQuantity)
-> (Integer -> Natural) -> Integer -> TokenQuantity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. (Integral Integer, Num b) => Integer -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral @Integer) (Either TextDecodingError Integer
 -> Either TextDecodingError TokenQuantity)
-> (Text -> Either TextDecodingError Integer)
-> Text
-> Either TextDecodingError TokenQuantity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either TextDecodingError Integer
forall a. FromText a => Text -> Either TextDecodingError a
fromText

instance FromJSON TokenQuantity where
    parseJSON :: Value -> Parser TokenQuantity
parseJSON = (Natural -> TokenQuantity)
-> Parser Natural -> Parser TokenQuantity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Natural -> TokenQuantity
TokenQuantity (Parser Natural -> Parser TokenQuantity)
-> (Value -> Parser Natural) -> Value -> Parser TokenQuantity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser Natural
forall a. FromJSON a => Value -> Parser a
parseJSON
instance ToJSON TokenQuantity where
    toJSON :: TokenQuantity -> Value
toJSON = Natural -> Value
forall a. ToJSON a => a -> Value
toJSON (Natural -> Value)
-> (TokenQuantity -> Natural) -> TokenQuantity -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TokenQuantity -> Natural
unTokenQuantity

--------------------------------------------------------------------------------
-- Values
--------------------------------------------------------------------------------

zero :: TokenQuantity
zero :: TokenQuantity
zero = Natural -> TokenQuantity
TokenQuantity Natural
0

--------------------------------------------------------------------------------
-- Arithmetic operations
--------------------------------------------------------------------------------

add :: TokenQuantity -> TokenQuantity -> TokenQuantity
add :: TokenQuantity -> TokenQuantity -> TokenQuantity
add (TokenQuantity Natural
x) (TokenQuantity Natural
y) = Natural -> TokenQuantity
TokenQuantity (Natural -> TokenQuantity) -> Natural -> TokenQuantity
forall a b. (a -> b) -> a -> b
$ Natural
x Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
y

-- | Subtracts the second token quantity from the first.
--
-- Returns 'Nothing' if the first quantity is less than the second quantity.
--
subtract :: TokenQuantity -> TokenQuantity -> Maybe TokenQuantity
subtract :: TokenQuantity -> TokenQuantity -> Maybe TokenQuantity
subtract TokenQuantity
x TokenQuantity
y = Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (TokenQuantity
x TokenQuantity -> TokenQuantity -> Bool
forall a. Ord a => a -> a -> Bool
>= TokenQuantity
y) Maybe () -> TokenQuantity -> Maybe TokenQuantity
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> TokenQuantity -> TokenQuantity -> TokenQuantity
unsafeSubtract TokenQuantity
x TokenQuantity
y

-- | Finds the predecessor of a given token quantity.
--
-- Returns 'Nothing' if the given quantity is zero.
--
pred :: TokenQuantity -> Maybe TokenQuantity
pred :: TokenQuantity -> Maybe TokenQuantity
pred = (TokenQuantity -> TokenQuantity -> Maybe TokenQuantity
`subtract` Natural -> TokenQuantity
TokenQuantity Natural
1)

-- | Finds the predecessor of a given token quantity.
--
-- Returns 'zero' if the given quantity is 'zero'.
--
-- Satisfies the following property:
--
-- >>> predZero x == x `difference` 1
--
predZero :: TokenQuantity -> TokenQuantity
predZero :: TokenQuantity -> TokenQuantity
predZero = TokenQuantity -> Maybe TokenQuantity -> TokenQuantity
forall a. a -> Maybe a -> a
fromMaybe TokenQuantity
zero (Maybe TokenQuantity -> TokenQuantity)
-> (TokenQuantity -> Maybe TokenQuantity)
-> TokenQuantity
-> TokenQuantity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TokenQuantity -> Maybe TokenQuantity
pred

-- | Finds the successor of a given token quantity.
--
succ :: TokenQuantity -> TokenQuantity
succ :: TokenQuantity -> TokenQuantity
succ = (TokenQuantity -> TokenQuantity -> TokenQuantity
`add` Natural -> TokenQuantity
TokenQuantity Natural
1)

-- | Subtracts the second token quantity from the first.
--
-- Returns 'zero' if the first quantity is less than the second quantity.
--
difference :: TokenQuantity -> TokenQuantity -> TokenQuantity
difference :: TokenQuantity -> TokenQuantity -> TokenQuantity
difference TokenQuantity
x TokenQuantity
y = TokenQuantity -> Maybe TokenQuantity -> TokenQuantity
forall a. a -> Maybe a -> a
fromMaybe TokenQuantity
zero (Maybe TokenQuantity -> TokenQuantity)
-> Maybe TokenQuantity -> TokenQuantity
forall a b. (a -> b) -> a -> b
$ TokenQuantity -> TokenQuantity -> Maybe TokenQuantity
subtract TokenQuantity
x TokenQuantity
y

--------------------------------------------------------------------------------
-- Partitioning
--------------------------------------------------------------------------------

-- | Computes the equipartition of a token quantity into 'n' smaller quantities.
--
-- An /equipartition/ of a token quantity is a /partition/ of that quantity
-- into 'n' smaller quantities whose values differ by no more than 1.
--
-- The resultant list is sorted in ascending order.
--
equipartition
    :: TokenQuantity
    -- ^ The token quantity to be partitioned.
    -> NonEmpty a
    -- ^ Represents the number of portions in which to partition the quantity.
    -> NonEmpty TokenQuantity
    -- ^ The partitioned quantities.
equipartition :: TokenQuantity -> NonEmpty a -> NonEmpty TokenQuantity
equipartition TokenQuantity
q =
    (Natural -> TokenQuantity)
-> NonEmpty Natural -> NonEmpty TokenQuantity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Natural -> TokenQuantity
TokenQuantity (NonEmpty Natural -> NonEmpty TokenQuantity)
-> (NonEmpty a -> NonEmpty Natural)
-> NonEmpty a
-> NonEmpty TokenQuantity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> NonEmpty a -> NonEmpty Natural
forall a. HasCallStack => Natural -> NonEmpty a -> NonEmpty Natural
equipartitionNatural (TokenQuantity -> Natural
unTokenQuantity TokenQuantity
q)

-- | Partitions a token quantity into a number of parts, where the size of each
--   part is proportional (modulo rounding) to the size of its corresponding
--   element in the given list of weights, and the number of parts is equal to
--   the number of weights.
--
-- Returns 'Nothing' if the sum of weights is equal to zero.
--
partition
    :: TokenQuantity
    -- ^ The token quantity to be partitioned.
    -> NonEmpty TokenQuantity
    -- ^ The list of weights.
    -> Maybe (NonEmpty TokenQuantity)
    -- ^ The partitioned token quantities.
partition :: TokenQuantity
-> NonEmpty TokenQuantity -> Maybe (NonEmpty TokenQuantity)
partition TokenQuantity
c
    = (NonEmpty Natural -> NonEmpty TokenQuantity)
-> Maybe (NonEmpty Natural) -> Maybe (NonEmpty TokenQuantity)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Natural -> TokenQuantity)
-> NonEmpty Natural -> NonEmpty TokenQuantity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Natural -> TokenQuantity
TokenQuantity)
    (Maybe (NonEmpty Natural) -> Maybe (NonEmpty TokenQuantity))
-> (NonEmpty TokenQuantity -> Maybe (NonEmpty Natural))
-> NonEmpty TokenQuantity
-> Maybe (NonEmpty TokenQuantity)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> NonEmpty Natural -> Maybe (NonEmpty Natural)
partitionNatural (TokenQuantity -> Natural
unTokenQuantity TokenQuantity
c)
    (NonEmpty Natural -> Maybe (NonEmpty Natural))
-> (NonEmpty TokenQuantity -> NonEmpty Natural)
-> NonEmpty TokenQuantity
-> Maybe (NonEmpty Natural)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TokenQuantity -> Natural)
-> NonEmpty TokenQuantity -> NonEmpty Natural
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TokenQuantity -> Natural
unTokenQuantity

-- | Partitions a token quantity into a number of parts, where the size of each
--   part is proportional (modulo rounding) to the size of its corresponding
--   element in the given list of weights, and the number of parts is equal to
--   the number of weights.
--
-- This function always satisfies the following properties:
--
-- prop> fold   (partitionDefault q ws) == c
-- prop> length (partitionDefault q ws) == length ws
--
-- If the sum of weights is equal to zero, then this function returns an
-- 'equipartition' satisfying the following property:
--
-- prop> partitionDefault q ws == equipartition q ws
--
partitionDefault
    :: TokenQuantity
    -- ^ The token quantity to be partitioned.
    -> NonEmpty TokenQuantity
    -- ^ The list of weights.
    -> NonEmpty TokenQuantity
    -- ^ The partitioned token quantities.
partitionDefault :: TokenQuantity -> NonEmpty TokenQuantity -> NonEmpty TokenQuantity
partitionDefault TokenQuantity
q NonEmpty TokenQuantity
ws = NonEmpty TokenQuantity
-> Maybe (NonEmpty TokenQuantity) -> NonEmpty TokenQuantity
forall a. a -> Maybe a -> a
fromMaybe (TokenQuantity -> NonEmpty TokenQuantity -> NonEmpty TokenQuantity
forall a. TokenQuantity -> NonEmpty a -> NonEmpty TokenQuantity
equipartition TokenQuantity
q NonEmpty TokenQuantity
ws) (TokenQuantity
-> NonEmpty TokenQuantity -> Maybe (NonEmpty TokenQuantity)
partition TokenQuantity
q NonEmpty TokenQuantity
ws)

--------------------------------------------------------------------------------
-- Tests
--------------------------------------------------------------------------------

isNonZero :: TokenQuantity -> Bool
isNonZero :: TokenQuantity -> Bool
isNonZero = (TokenQuantity -> TokenQuantity -> Bool
forall a. Eq a => a -> a -> Bool
/= TokenQuantity
zero)

isZero :: TokenQuantity -> Bool
isZero :: TokenQuantity -> Bool
isZero = (TokenQuantity -> TokenQuantity -> Bool
forall a. Eq a => a -> a -> Bool
== TokenQuantity
zero)

--------------------------------------------------------------------------------
-- Unsafe operations
--------------------------------------------------------------------------------

-- | Subtracts the second token quantity from the first.
--
-- Pre-condition: the first quantity is not less than the second quantity.
--
-- Throws a run-time exception if the pre-condition is violated.
--
unsafeSubtract :: TokenQuantity -> TokenQuantity -> TokenQuantity
unsafeSubtract :: TokenQuantity -> TokenQuantity -> TokenQuantity
unsafeSubtract (TokenQuantity Natural
x) (TokenQuantity Natural
y) = Natural -> TokenQuantity
TokenQuantity (Natural -> TokenQuantity) -> Natural -> TokenQuantity
forall a b. (a -> b) -> a -> b
$ Natural
x Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
y