{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NumDecimals #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-}

module Cardano.Chain.Common.LovelacePortion
  ( LovelacePortion,
    rationalToLovelacePortion,
    lovelacePortionToRational,
  )
where

import Cardano.Binary (FromCBOR (..), ToCBOR (..))
import Cardano.Prelude
import Control.Monad (fail)
import qualified Data.Aeson as Aeson
import Formatting (bprint, build, float, int, sformat)
import qualified Formatting.Buildable as B
import NoThunks.Class (NoThunks (..))
import Quiet
import Text.JSON.Canonical (FromJSON (..), ToJSON (..))

-- | 'LovelacePortion' is a legacy Byron type that we keep only for
-- compatibility. It was originally intended to represent a fraction of stake
-- in the system. It is used only for the thresholds used in the update system
-- rules, most of which are now themselves unused. The remaining case is no
-- longer interpreted as a fraction of all stake, but as a fraction of the
-- number of genesis keys.
--
-- It has enormous precision, due to the fact that it was originally intended
-- to represent a fraction of all stake and can cover the precision of all the
-- Lovelace in the system.
--
-- It is represented as a rational nominator with a fixed implicit denominator
-- of 1e15. So the nominator must be in the range @[0..1e15]@. This is also the
-- representation used on-chain (in update proposals) and in the JSON
-- genesis file.
--
-- It is interpreted as a 'Rational' via the provided conversion functions.
newtype LovelacePortion = LovelacePortion
  { LovelacePortion -> Word64
unLovelacePortion :: Word64
  }
  deriving (Eq LovelacePortion
Eq LovelacePortion
-> (LovelacePortion -> LovelacePortion -> Ordering)
-> (LovelacePortion -> LovelacePortion -> Bool)
-> (LovelacePortion -> LovelacePortion -> Bool)
-> (LovelacePortion -> LovelacePortion -> Bool)
-> (LovelacePortion -> LovelacePortion -> Bool)
-> (LovelacePortion -> LovelacePortion -> LovelacePortion)
-> (LovelacePortion -> LovelacePortion -> LovelacePortion)
-> Ord LovelacePortion
LovelacePortion -> LovelacePortion -> Bool
LovelacePortion -> LovelacePortion -> Ordering
LovelacePortion -> LovelacePortion -> LovelacePortion
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 :: LovelacePortion -> LovelacePortion -> LovelacePortion
$cmin :: LovelacePortion -> LovelacePortion -> LovelacePortion
max :: LovelacePortion -> LovelacePortion -> LovelacePortion
$cmax :: LovelacePortion -> LovelacePortion -> LovelacePortion
>= :: LovelacePortion -> LovelacePortion -> Bool
$c>= :: LovelacePortion -> LovelacePortion -> Bool
> :: LovelacePortion -> LovelacePortion -> Bool
$c> :: LovelacePortion -> LovelacePortion -> Bool
<= :: LovelacePortion -> LovelacePortion -> Bool
$c<= :: LovelacePortion -> LovelacePortion -> Bool
< :: LovelacePortion -> LovelacePortion -> Bool
$c< :: LovelacePortion -> LovelacePortion -> Bool
compare :: LovelacePortion -> LovelacePortion -> Ordering
$ccompare :: LovelacePortion -> LovelacePortion -> Ordering
$cp1Ord :: Eq LovelacePortion
Ord, LovelacePortion -> LovelacePortion -> Bool
(LovelacePortion -> LovelacePortion -> Bool)
-> (LovelacePortion -> LovelacePortion -> Bool)
-> Eq LovelacePortion
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LovelacePortion -> LovelacePortion -> Bool
$c/= :: LovelacePortion -> LovelacePortion -> Bool
== :: LovelacePortion -> LovelacePortion -> Bool
$c== :: LovelacePortion -> LovelacePortion -> Bool
Eq, (forall x. LovelacePortion -> Rep LovelacePortion x)
-> (forall x. Rep LovelacePortion x -> LovelacePortion)
-> Generic LovelacePortion
forall x. Rep LovelacePortion x -> LovelacePortion
forall x. LovelacePortion -> Rep LovelacePortion x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep LovelacePortion x -> LovelacePortion
$cfrom :: forall x. LovelacePortion -> Rep LovelacePortion x
Generic, LovelacePortion -> Int
(LovelacePortion -> Int) -> HeapWords LovelacePortion
forall a. (a -> Int) -> HeapWords a
heapWords :: LovelacePortion -> Int
$cheapWords :: LovelacePortion -> Int
HeapWords, LovelacePortion -> ()
(LovelacePortion -> ()) -> NFData LovelacePortion
forall a. (a -> ()) -> NFData a
rnf :: LovelacePortion -> ()
$crnf :: LovelacePortion -> ()
NFData, Context -> LovelacePortion -> IO (Maybe ThunkInfo)
Proxy LovelacePortion -> String
(Context -> LovelacePortion -> IO (Maybe ThunkInfo))
-> (Context -> LovelacePortion -> IO (Maybe ThunkInfo))
-> (Proxy LovelacePortion -> String)
-> NoThunks LovelacePortion
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy LovelacePortion -> String
$cshowTypeOf :: Proxy LovelacePortion -> String
wNoThunks :: Context -> LovelacePortion -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> LovelacePortion -> IO (Maybe ThunkInfo)
noThunks :: Context -> LovelacePortion -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> LovelacePortion -> IO (Maybe ThunkInfo)
NoThunks)
  deriving (Int -> LovelacePortion -> ShowS
[LovelacePortion] -> ShowS
LovelacePortion -> String
(Int -> LovelacePortion -> ShowS)
-> (LovelacePortion -> String)
-> ([LovelacePortion] -> ShowS)
-> Show LovelacePortion
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LovelacePortion] -> ShowS
$cshowList :: [LovelacePortion] -> ShowS
show :: LovelacePortion -> String
$cshow :: LovelacePortion -> String
showsPrec :: Int -> LovelacePortion -> ShowS
$cshowsPrec :: Int -> LovelacePortion -> ShowS
Show) via (Quiet LovelacePortion)

instance B.Buildable LovelacePortion where
  build :: LovelacePortion -> Builder
build cp :: LovelacePortion
cp@(LovelacePortion Word64
x) =
    Format Builder (Word64 -> Word64 -> Double -> Builder)
-> Word64 -> Word64 -> Double -> Builder
forall a. Format Builder a -> a
bprint
      (Format
  (Word64 -> Double -> Builder)
  (Word64 -> Word64 -> Double -> Builder)
forall a r. Integral a => Format r (a -> r)
int Format
  (Word64 -> Double -> Builder)
  (Word64 -> Word64 -> Double -> Builder)
-> Format Builder (Word64 -> Double -> Builder)
-> Format Builder (Word64 -> Word64 -> Double -> Builder)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format (Word64 -> Double -> Builder) (Word64 -> Double -> Builder)
"/" Format (Word64 -> Double -> Builder) (Word64 -> Double -> Builder)
-> Format Builder (Word64 -> Double -> Builder)
-> Format Builder (Word64 -> Double -> Builder)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format (Double -> Builder) (Word64 -> Double -> Builder)
forall a r. Integral a => Format r (a -> r)
int Format (Double -> Builder) (Word64 -> Double -> Builder)
-> Format Builder (Double -> Builder)
-> Format Builder (Word64 -> Double -> Builder)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format (Double -> Builder) (Double -> Builder)
" (approx. " Format (Double -> Builder) (Double -> Builder)
-> Format Builder (Double -> Builder)
-> Format Builder (Double -> Builder)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format Builder (Double -> Builder)
forall a r. Real a => Format r (a -> r)
float Format Builder (Double -> Builder)
-> Format Builder Builder -> Format Builder (Double -> Builder)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format Builder Builder
")")
      Word64
x
      Word64
lovelacePortionDenominator
      (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational (LovelacePortion -> Rational
lovelacePortionToRational LovelacePortion
cp) :: Double)

-- Used for debugging purposes only
instance Aeson.ToJSON LovelacePortion

instance ToCBOR LovelacePortion where
  toCBOR :: LovelacePortion -> Encoding
toCBOR = Word64 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word64 -> Encoding)
-> (LovelacePortion -> Word64) -> LovelacePortion -> Encoding
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. LovelacePortion -> Word64
unLovelacePortion

instance FromCBOR LovelacePortion where
  fromCBOR :: Decoder s LovelacePortion
fromCBOR = do
    Word64
nominator <- Decoder s Word64
forall a s. FromCBOR a => Decoder s a
fromCBOR
    Bool -> Decoder s () -> Decoder s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word64
nominator Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
lovelacePortionDenominator) (Decoder s () -> Decoder s ()) -> Decoder s () -> Decoder s ()
forall a b. (a -> b) -> a -> b
$
      String -> Decoder s ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"LovelacePortion: value out of bounds [0..1e15]"
    LovelacePortion -> Decoder s LovelacePortion
forall (m :: * -> *) a. Monad m => a -> m a
return (Word64 -> LovelacePortion
LovelacePortion Word64
nominator)

-- The canonical JSON instance for LovelacePortion uses only the nominator in
-- the external representation,  rather than a real in the range [0,1].
-- This is because 'canonical-json' only supports numbers of type @Int54@.
instance Monad m => ToJSON m LovelacePortion where
  toJSON :: LovelacePortion -> m JSValue
toJSON = Word64 -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON (Word64 -> m JSValue)
-> (LovelacePortion -> Word64) -> LovelacePortion -> m JSValue
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. LovelacePortion -> Word64
unLovelacePortion

instance MonadError SchemaError m => FromJSON m LovelacePortion where
  fromJSON :: JSValue -> m LovelacePortion
fromJSON JSValue
val = do
    Word64
nominator <- JSValue -> m Word64
forall (m :: * -> *) a. FromJSON m a => JSValue -> m a
fromJSON JSValue
val
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word64
nominator Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
lovelacePortionDenominator) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      SchemaError -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
        SchemaError :: Text -> Maybe Text -> SchemaError
SchemaError
          { seExpected :: Text
seExpected = Text
"LovelacePortion integer in bounds [0..1e15]",
            seActual :: Maybe Text
seActual = Text -> Maybe Text
forall a. a -> Maybe a
Just (Format Text (Word64 -> Text) -> Word64 -> Text
forall a. Format Text a -> a
sformat Format Text (Word64 -> Text)
forall a r. Buildable a => Format r (a -> r)
build Word64
nominator)
          }
    LovelacePortion -> m LovelacePortion
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word64 -> LovelacePortion
LovelacePortion Word64
nominator)

-- | Denominator used by 'LovelacePortion'.
lovelacePortionDenominator :: Word64
lovelacePortionDenominator :: Word64
lovelacePortionDenominator = Word64
1e15

-- | Make a 'LovelacePortion' from a 'Rational'
-- which must be in the range @[0..1]@.
rationalToLovelacePortion :: Rational -> LovelacePortion
rationalToLovelacePortion :: Rational -> LovelacePortion
rationalToLovelacePortion Rational
r
  | Rational
r Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
>= Rational
0 Bool -> Bool -> Bool
&& Rational
r Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
<= Rational
1 =
      Word64 -> LovelacePortion
LovelacePortion
        (Rational -> Word64
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Rational
r Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Word64 -> Rational
forall a. Real a => a -> Rational
toRational Word64
lovelacePortionDenominator))
  | Bool
otherwise = Text -> LovelacePortion
forall a. HasCallStack => Text -> a
panic Text
"rationalToLovelacePortion: out of range [0..1]"

-- | Turn a 'LovelacePortion' into a 'Rational' in the range @[0..1]@.
lovelacePortionToRational :: LovelacePortion -> Rational
lovelacePortionToRational :: LovelacePortion -> Rational
lovelacePortionToRational (LovelacePortion Word64
n) =
  Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger Word64
n Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger Word64
lovelacePortionDenominator