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

-- |
-- Copyright: © 2018-2020 IOHK
-- License: Apache-2.0
--
-- This module provides the 'Coin' data type, which represents a quantity of
-- lovelace.
--
module Cardano.Wallet.Primitive.Types.Coin
    ( -- * Type
      Coin (..)

      -- * Conversions (Safe)
    , fromIntegral
    , fromNatural
    , fromWord64
    , toInteger
    , toNatural
    , toQuantity
    , toWord64

      -- * Conversions (Unsafe)
    , unsafeFromIntegral
    , unsafeToQuantity
    , unsafeToWord64

      -- * Arithmetic operations
    , add
    , subtract
    , difference
    , distance

      -- * Partitioning
    , 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

-- | A 'Coin' represents a quantity of lovelace.
--
-- Reminder: 1 ada = 1,000,000 lovelace.
--
-- The 'Coin' type has 'Semigroup' and 'Monoid' instances that correspond
-- to ordinary addition and summation.
--
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)

-- | The 'Semigroup' instance for 'Coin' corresponds to ordinary addition.
--
instance Semigroup Coin where
    -- Natural doesn't have a default Semigroup instance.
    <> :: 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)

--------------------------------------------------------------------------------
-- Conversions (Safe)
--------------------------------------------------------------------------------

-- | Constructs a 'Coin' from an 'Integral' value.
--
-- Returns 'Nothing' if the given value is negative.
--
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

-- | Constructs a 'Coin' from a 'Natural' value.
--
fromNatural :: Natural -> Coin
fromNatural :: Natural -> Coin
fromNatural = Natural -> Coin
Coin

-- | Constructs a 'Coin' from a 'Word64' value.
--
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

-- | Converts a 'Coin' to an 'Integer' value.
--
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

-- | Converts a 'Coin' to a 'Natural' value.
--
toNatural :: Coin -> Natural
toNatural :: Coin -> Natural
toNatural = Coin -> Natural
unCoin

-- | Converts a 'Coin' to a 'Quantity'.
--
-- Returns 'Nothing' if the given value does not fit within the bounds of
-- the target type.
--
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

-- | Converts a 'Coin' to a 'Word64' value.
--
-- Returns 'Nothing' if the given value does not fit within the bounds of a
-- 64-bit word.
--
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

--------------------------------------------------------------------------------
-- Conversions (Unsafe)
-------------------------------------------------------------------------------

-- | Constructs a 'Coin' from an 'Integral' value.
--
-- Callers of this function must take responsibility for checking that the
-- given value is not negative.
--
-- Produces a run-time error if the given value is negative.
--
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."
        ]

-- | Converts a 'Coin' to a 'Quantity'.
--
-- Callers of this function must take responsibility for checking that the
-- given value will fit within the bounds of the target type.
--
-- Produces a run-time error if the given value is out of bounds.
--
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."
        ]

-- | Converts a 'Coin' to a 'Word64' value.
--
-- Callers of this function must take responsibility for checking that the
-- given value will fit within the bounds of a 64-bit word.
--
-- Produces a run-time error if the given value is out of bounds.
--
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."
        ]

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

-- | Subtracts the second coin from the first.
--
-- Returns 'Nothing' if the second coin is strictly greater than the first.
--
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

-- | Calculates the combined value of two coins.
--
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)

-- | Subtracts the second coin from the first.
--
-- Returns 'Coin 0' if the second coin is strictly greater than the first.
--
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)

-- | Absolute difference between two coin amounts. The result is never negative.
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)

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

-- | Computes the equipartition of a coin into 'n' smaller coins.
--
-- An /equipartition/ of a coin is a /partition/ of that coin into 'n' smaller
-- coins whose values differ by no more than 1.
--
-- The resultant list is sorted in ascending order.
--
equipartition
    :: Coin
    -- ^ The coin to be partitioned.
    -> NonEmpty a
    -- ^ Represents the number of portions in which to partition the coin.
    -> NonEmpty Coin
    -- ^ The partitioned coins.
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)

-- | Partitions a coin 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
    :: Coin
    -- ^ The coin to be partitioned.
    -> NonEmpty Coin
    -- ^ The list of weights.
    -> Maybe (NonEmpty Coin)
    -- ^ The partitioned coins.
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

-- | Partitions a coin 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 c ws) == c
-- prop> length (partitionDefault c ws) == length ws
--
-- If the sum of weights is equal to zero, then this function returns an
-- 'equipartition' satisfying the following property:
--
-- prop> partitionDefault c ws == equipartition c ws
--
partitionDefault
    :: Coin
    -- ^ The token quantity to be partitioned.
    -> NonEmpty Coin
    -- ^ The list of weights.
    -> NonEmpty Coin
    -- ^ The partitioned token quantities.
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)

-- | Partitions a coin 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.
--
-- Throws a run-time error if the sum of weights is equal to zero.
--
unsafePartition
    :: HasCallStack
    => Coin
    -- ^ The coin to be partitioned.
    -> NonEmpty Coin
    -- ^ The list of weights.
    -> NonEmpty Coin
    -- ^ The partitioned coins.
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."