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

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

import Cardano.HeapWords (HeapWords)
import Cardano.Ledger.Binary (
  DecCBOR (..),
  EncCBOR (..),
  FromCBOR (..),
  ToCBOR (..),
  fromByronCBOR,
  toByronCBOR,
 )
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
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
Ord, LovelacePortion -> LovelacePortion -> Bool
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. 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
forall a. (a -> Int) -> HeapWords a
heapWords :: LovelacePortion -> Int
$cheapWords :: LovelacePortion -> Int
HeapWords, LovelacePortion -> ()
forall a. (a -> ()) -> NFData a
rnf :: LovelacePortion -> ()
$crnf :: LovelacePortion -> ()
NFData, Context -> LovelacePortion -> IO (Maybe ThunkInfo)
Proxy LovelacePortion -> String
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
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) =
    forall a. Format Builder a -> a
bprint
      (forall a r. Integral a => Format r (a -> r)
int 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)
"/" forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a r. Integral a => Format r (a -> r)
int 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. " forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a r. Real a => Format r (a -> r)
float 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
      (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 = forall a. EncCBOR a => a -> Encoding
toByronCBOR

instance FromCBOR LovelacePortion where
  fromCBOR :: forall s. Decoder s LovelacePortion
fromCBOR = forall a s. DecCBOR a => Decoder s a
fromByronCBOR

instance EncCBOR LovelacePortion where
  encCBOR :: LovelacePortion -> Encoding
encCBOR = forall a. EncCBOR a => a -> Encoding
encCBOR 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 DecCBOR LovelacePortion where
  decCBOR :: forall s. Decoder s LovelacePortion
decCBOR = do
    Word64
nominator <- forall a s. DecCBOR a => Decoder s a
decCBOR
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word64
nominator forall a. Ord a => a -> a -> Bool
> Word64
lovelacePortionDenominator)
      forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"LovelacePortion: value out of bounds [0..1e15]"
    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 = forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON 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 <- forall (m :: * -> *) a. FromJSON m a => JSValue -> m a
fromJSON JSValue
val
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word64
nominator forall a. Ord a => a -> a -> Bool
> Word64
lovelacePortionDenominator)
      forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
        SchemaError
          { seExpected :: Text
seExpected = Text
"LovelacePortion integer in bounds [0..1e15]"
          , seActual :: Maybe Text
seActual = forall a. a -> Maybe a
Just (forall a. Format Text a -> a
sformat forall a r. Buildable a => Format r (a -> r)
build Word64
nominator)
          }
    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 forall a. Ord a => a -> a -> Bool
>= Rational
0 Bool -> Bool -> Bool
&& Rational
r forall a. Ord a => a -> a -> Bool
<= Rational
1 =
      Word64 -> LovelacePortion
LovelacePortion
        (forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Rational
r forall a. Num a => a -> a -> a
* forall a. Real a => a -> Rational
toRational Word64
lovelacePortionDenominator))
  | Bool
otherwise = 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) =
  forall a. Integral a => a -> Integer
toInteger Word64
n forall a. Integral a => a -> a -> Ratio a
% forall a. Integral a => a -> Integer
toInteger Word64
lovelacePortionDenominator