Change representation of Lovelace from Word64 to Natural

cardano-ledger/src/Cardano/Chain/Common/Lovelace.hs

@@ -23,8 +23,9 @@ module Cardano.Chain.Common.Lovelace
   (
   -- * Lovelace
     Lovelace
-  , LovelaceError(..)
-  , maxLovelaceVal
+
+    -- Only export the error cases that are still possible:
+  , LovelaceError(LovelaceTooSmall, LovelaceUnderflow)
 
   -- * Constructors
   , mkLovelace
@@ -34,15 +35,18 @@ module Cardano.Chain.Common.Lovelace
   , lovelaceF
 
   -- * Conversions
-  , unsafeGetLovelace
+  , naturalToLovelace
+  , lovelaceToNatural
   , lovelaceToInteger
+  , unsafeGetLovelace
   , integerToLovelace
 
   -- * Arithmetic operations
   , sumLovelace
   , addLovelace
   , subLovelace
   , scaleLovelace
+  , scaleLovelaceRational
   , divLovelace
   , modLovelace
   )
@@ -51,6 +55,7 @@ where
 import Cardano.Prelude
 
 import Data.Data (Data)
+import Data.Monoid (Monoid(..))
 import Formatting (Format, bprint, build, int, sformat)
 import qualified Formatting.Buildable as B
 import GHC.TypeLits (type (<=))
@@ -70,19 +75,21 @@ import Cardano.Binary
 
 -- | Lovelace is the least possible unit of currency
 newtype Lovelace = Lovelace
-  { getLovelace :: Word64
+  { getLovelace :: Natural
   } deriving (Show, Ord, Eq, Generic, Data, NFData, NoUnexpectedThunks)
 
+instance Semigroup Lovelace where
+  Lovelace a <> Lovelace b = Lovelace (a + b)
+
+instance Monoid Lovelace where
+  mempty = Lovelace 0
+
 instance B.Buildable Lovelace where
   build (Lovelace n) = bprint (int . " lovelace") n
 
-instance Bounded Lovelace where
-  minBound = Lovelace 0
-  maxBound = Lovelace maxLovelaceVal
-
 instance ToCBOR Lovelace where
   toCBOR = toCBOR . unsafeGetLovelace
-  encodedSizeExpr size pxy = size (unsafeGetLovelace <$> pxy)
+  encodedSizeExpr size _pxy = encodedSizeExpr size (Proxy :: Proxy Word64)
 
 instance FromCBOR Lovelace where
   fromCBOR = do
@@ -95,7 +102,17 @@ instance Monad m => Canonical.ToJSON m Lovelace where
   toJSON = Canonical.toJSON . unsafeGetLovelace
 
 instance Canonical.ReportSchemaErrors m => Canonical.FromJSON m Lovelace where
-  fromJSON = fmap Lovelace . Canonical.fromJSON
+  fromJSON = fmap (Lovelace . (fromIntegral :: Word64 -> Natural))
+           . Canonical.fromJSON
+
+naturalToLovelace :: Natural -> Lovelace
+naturalToLovelace = Lovelace
+
+lovelaceToNatural :: Lovelace -> Natural
+lovelaceToNatural (Lovelace n) = n
+
+lovelaceToInteger :: Lovelace -> Integer
+lovelaceToInteger = toInteger . lovelaceToNatural
 
 data LovelaceError
   = LovelaceOverflow Word64
@@ -116,7 +133,7 @@ instance B.Buildable LovelaceError where
     LovelaceTooSmall c -> bprint
       ("Lovelace value, " . build . ", is less than minimum, " . build)
       c
-      (minBound :: Lovelace)
+      (Lovelace 0)
     LovelaceUnderflow c c' -> bprint
       ("Lovelace underflow when subtracting " . build . " from " . build)
       c'
@@ -152,9 +169,7 @@ maxLovelaceVal = 45e15
 -- | Constructor for 'Lovelace' returning 'LovelaceError' when @c@ exceeds
 --   'maxLovelaceVal'
 mkLovelace :: Word64 -> Either LovelaceError Lovelace
-mkLovelace c
-  | c <= maxLovelaceVal = Right (Lovelace c)
-  | otherwise           = Left (LovelaceTooLarge (toInteger c))
+mkLovelace c = Right (Lovelace (fromIntegral c))
 {-# INLINE mkLovelace #-}
 
 -- | Construct a 'Lovelace' from a 'KnownNat', known to be less than
@@ -169,7 +184,7 @@ lovelaceF = build
 -- | Unwraps 'Lovelace'. It's called “unsafe” so that people wouldn't use it
 --   willy-nilly if they want to sum lovelace or something. It's actually safe.
 unsafeGetLovelace :: Lovelace -> Word64
-unsafeGetLovelace = getLovelace
+unsafeGetLovelace = fromIntegral . getLovelace
 {-# INLINE unsafeGetLovelace #-}
 
 -- | Compute sum of all lovelace in container. Result is 'Integer' as a
@@ -178,30 +193,32 @@ sumLovelace
   :: (Foldable t, Functor t) => t Lovelace -> Either LovelaceError Lovelace
 sumLovelace = integerToLovelace . sum . map lovelaceToInteger
 
-lovelaceToInteger :: Lovelace -> Integer
-lovelaceToInteger = toInteger . unsafeGetLovelace
-{-# INLINE lovelaceToInteger #-}
-
--- | Addition of lovelace, returning 'LovelaceError' in case of overflow
+-- | Addition of lovelace.
 addLovelace :: Lovelace -> Lovelace -> Either LovelaceError Lovelace
-addLovelace (Lovelace a) (Lovelace b)
-  | res >= a && res >= b && res <= maxLovelaceVal = Right (Lovelace res)
-  | otherwise = Left (LovelaceOverflow res)
-  where res = a + b
+addLovelace (Lovelace a) (Lovelace b) = Right (Lovelace (a + b))
 {-# INLINE addLovelace #-}
 
 -- | Subtraction of lovelace, returning 'LovelaceError' on underflow
 subLovelace :: Lovelace -> Lovelace -> Either LovelaceError Lovelace
 subLovelace (Lovelace a) (Lovelace b)
   | a >= b    = Right (Lovelace (a - b))
-  | otherwise = Left (LovelaceUnderflow a b)
+  | otherwise = Left (LovelaceUnderflow (fromIntegral a) (fromIntegral b))
 
 -- | Scale a 'Lovelace' by an 'Integral' factor, returning 'LovelaceError' when
 --   the result is too large
 scaleLovelace :: Integral b => Lovelace -> b -> Either LovelaceError Lovelace
 scaleLovelace (Lovelace a) b = integerToLovelace $ toInteger a * toInteger b
 {-# INLINE scaleLovelace #-}
 
+-- | Scale a 'Lovelace' by a rational factor between @0..1@, rounding down.
+scaleLovelaceRational :: Lovelace -> Rational -> Lovelace
+scaleLovelaceRational (Lovelace a) b =
+    Lovelace $ fromInteger $ toInteger a * n `div` d
+  where
+    n, d :: Integer
+    n = numerator b
+    d = denominator b
+
 -- | Integer division of a 'Lovelace' by an 'Integral' factor
 divLovelace :: Integral b => Lovelace -> b -> Either LovelaceError Lovelace
 divLovelace (Lovelace a) b = integerToLovelace $ toInteger a `div` toInteger b
@@ -215,6 +232,5 @@ modLovelace (Lovelace a) b = integerToLovelace $ toInteger a `mod` toInteger b
 integerToLovelace :: Integer -> Either LovelaceError Lovelace
 integerToLovelace n
   | n < 0 = Left (LovelaceTooSmall n)
-  | n <= lovelaceToInteger (maxBound :: Lovelace) = Right
-  $ Lovelace (fromInteger n)
-  | otherwise = Left (LovelaceTooLarge n)
+  | otherwise = Right (Lovelace (fromInteger n))
+

cardano-ledger/src/Cardano/Chain/Common/LovelacePortion.hs

@@ -1,176 +1,100 @@
-{-# LANGUAGE AllowAmbiguousTypes        #-}
-{-# LANGUAGE DataKinds                  #-}
 {-# LANGUAGE DeriveGeneric              #-}
-{-# LANGUAGE ExplicitNamespaces         #-}
-{-# LANGUAGE FlexibleContexts           #-}
 {-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE LambdaCase                 #-}
 {-# LANGUAGE MultiParamTypeClasses      #-}
 {-# LANGUAGE NumDecimals                #-}
 {-# LANGUAGE OverloadedStrings          #-}
-{-# LANGUAGE ScopedTypeVariables        #-}
-{-# LANGUAGE TypeApplications           #-}
-{-# LANGUAGE TypeFamilies               #-}
-{-# LANGUAGE TypeOperators              #-}
 {-# LANGUAGE UndecidableInstances       #-}
-{-# LANGUAGE ViewPatterns               #-}
-
--- This is for 'mkKnownLovelacePortion''s @n <= 45000000000000000@ constraint,
--- which is considered redundant. TODO: investigate this.
-{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 
 module Cardano.Chain.Common.LovelacePortion
-  ( LovelacePortion(..)
-  , LovelacePortionError
-  , mkLovelacePortion
-  , mkKnownLovelacePortion
-  , lovelacePortionDenominator
-  , lovelacePortionFromDouble
-  , lovelacePortionToDouble
-  , applyLovelacePortionDown
-  , applyLovelacePortionUp
+  ( LovelacePortion
+  , rationalToLovelacePortion
+  , lovelacePortionToRational
   )
 where
 
 import Cardano.Prelude
 
+import Control.Monad (fail)
 import Control.Monad.Except (MonadError(..))
-import Formatting (bprint, build, float, int, sformat)
+import Formatting (sformat, build, bprint, float, int)
 import qualified Formatting.Buildable as B
-import GHC.TypeLits (type (<=))
 import Text.JSON.Canonical (FromJSON(..), ToJSON(..))
 
 import Cardano.Binary (FromCBOR(..), ToCBOR(..))
-import Cardano.Chain.Common.Lovelace
 
 
--- | LovelacePortion is some portion of Lovelace; it is interpreted as a fraction with
---   denominator of 'lovelacePortionDenominator'. The numerator must be in the
---   interval of [0, lovelacePortionDenominator].
+-- | '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.
 --
---   Usually 'LovelacePortion' is used to determine some threshold expressed as
---   portion of total stake.
+-- It is interpreted as a 'Rational' via the provided conversion functions.
 --
---   To multiply a lovelace portion by 'Lovelace', use 'applyLovelacePortionDown' (when
---   calculating number of lovelace) or 'applyLovelacePortionUp' (when calculating a
---   threshold).
 newtype LovelacePortion = LovelacePortion
   { getLovelacePortion :: Word64
   } deriving (Show, Ord, Eq, Generic, HeapWords, NFData, NoUnexpectedThunks)
 
 instance B.Buildable LovelacePortion where
-  build cp@(getLovelacePortion -> x) = bprint
+  build cp@(LovelacePortion x) = bprint
     (int . "/" . int . " (approx. " . float . ")")
     x
     lovelacePortionDenominator
-    (lovelacePortionToDouble cp)
+    (fromRational (lovelacePortionToRational cp) :: Double)
 
 instance ToCBOR LovelacePortion where
   toCBOR = toCBOR . getLovelacePortion
 
 instance FromCBOR LovelacePortion where
-  fromCBOR = LovelacePortion <$> fromCBOR
-
--- The Canonical and Aeson instances for LovelacePortion are inconsistent -
--- Canonical reads/writes an integer, but Aeson reads/write a Real in range [0,1]
+  fromCBOR = do
+    nominator <- fromCBOR
+    when (nominator > lovelacePortionDenominator) $
+      fail "LovelacePortion: value out of bounds [0..1e15]"
+    return (LovelacePortion 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 = toJSON . getLovelacePortion
 
 instance MonadError SchemaError m => FromJSON m LovelacePortion where
   fromJSON val = do
-    number <- fromJSON val
-    pure $ LovelacePortion number
+    nominator <- fromJSON val
+    when (nominator > lovelacePortionDenominator) $
+      throwError SchemaError {
+        seExpected = "LovelacePortion integer in bounds [0..1e15]",
+        seActual   = Just (sformat build nominator)
+      }
+    pure (LovelacePortion nominator)
 
 -- | Denominator used by 'LovelacePortion'.
 lovelacePortionDenominator :: Word64
 lovelacePortionDenominator = 1e15
 
-instance Bounded LovelacePortion where
-  minBound = LovelacePortion 0
-  maxBound = LovelacePortion lovelacePortionDenominator
-
-data LovelacePortionError
-  = LovelacePortionDoubleOutOfRange Double
-  | LovelacePortionTooLarge Word64
-  deriving Show
-
-instance B.Buildable LovelacePortionError where
-  build = \case
-    LovelacePortionDoubleOutOfRange d -> bprint
-      ( "Double, "
-      . build
-      . " , out of range [0, 1] when constructing LovelacePortion"
-      )
-      d
-    LovelacePortionTooLarge c -> bprint
-      ("LovelacePortion, " . build . ", exceeds maximum, " . build)
-      c
-      lovelacePortionDenominator
-
--- | Constructor for 'LovelacePortion', returning 'LovelacePortionError' when @c@
---   exceeds 'lovelacePortionDenominator'
-mkLovelacePortion :: Word64 -> Either LovelacePortionError LovelacePortion
-mkLovelacePortion c
-  | c <= lovelacePortionDenominator = Right (LovelacePortion c)
-  | otherwise                       = Left (LovelacePortionTooLarge c)
-
--- | Construct a 'LovelacePortion' from a 'KnownNat', known to be less than
---   'lovelacePortionDenominator'
-mkKnownLovelacePortion
-  :: forall n . (KnownNat n, n <= 1000000000000000) => LovelacePortion
-mkKnownLovelacePortion = LovelacePortion . fromIntegral . natVal $ Proxy @n
-
--- | Make LovelacePortion from Double. Caller must ensure that value is in [0..1].
---   Internally 'LovelacePortion' stores 'Word64' which is divided by
---   'lovelacePortionDenominator' to get actual value. So some rounding may take
---   place.
-lovelacePortionFromDouble
-  :: Double -> Either LovelacePortionError LovelacePortion
-lovelacePortionFromDouble x
-  | 0 <= x && x <= 1 = Right (LovelacePortion v)
-  | otherwise        = Left (LovelacePortionDoubleOutOfRange x)
- where
-  v :: Word64
-  v = round $ realToFrac lovelacePortionDenominator * x
-{-# INLINE lovelacePortionFromDouble #-}
-
-lovelacePortionToDouble :: LovelacePortion -> Double
-lovelacePortionToDouble (getLovelacePortion -> x) =
-  realToFrac x / realToFrac lovelacePortionDenominator
-{-# INLINE lovelacePortionToDouble #-}
-
--- | Apply LovelacePortion to Lovelace (with rounding down)
+-- | Make a 'LovelacePortion' from a 'Rational'
+-- which must be in the range @[0..1]@.
 --
---   Use it for calculating lovelace amounts.
-applyLovelacePortionDown :: LovelacePortion -> Lovelace -> Lovelace
-applyLovelacePortionDown (getLovelacePortion -> p) (unsafeGetLovelace -> c) =
-  case c' of
-    Right lovelace -> lovelace
-    Left  err      -> panic $ sformat
-      ("The impossible happened in applyLovelacePortionDown: " . build)
-      err
- where
-  c' =
-    mkLovelace
-      .     fromInteger
-      $     toInteger p
-      *     toInteger c
-      `div` toInteger lovelacePortionDenominator
+rationalToLovelacePortion :: Rational -> LovelacePortion
+rationalToLovelacePortion r
+  | r >= 0 && r <= 1 = LovelacePortion
+                         (ceiling (r * toRational lovelacePortionDenominator))
+  | otherwise        = panic "rationalToLovelacePortion: out of range [0..1]"
 
--- | Apply LovelacePortion to Lovelace (with rounding up)
+-- | Turn a 'LovelacePortion' into a 'Rational' in the range @[0..1]@.
 --
---   Use it for calculating thresholds.
-applyLovelacePortionUp :: LovelacePortion -> Lovelace -> Lovelace
-applyLovelacePortionUp (getLovelacePortion -> p) (unsafeGetLovelace -> c) =
-  case mkLovelace c' of
-    Right lovelace -> lovelace
-    Left  err      -> panic $ sformat
-      ("The impossible happened in applyLovelacePortionUp: " . build)
-      err
- where
-  (d, m) =
-    divMod (toInteger p * toInteger c) (toInteger lovelacePortionDenominator)
-  c' :: Word64
-  c' = if m > 0 then fromInteger (d + 1) else fromInteger d
+lovelacePortionToRational :: LovelacePortion -> Rational
+lovelacePortionToRational (LovelacePortion n) =
+  toInteger n % toInteger lovelacePortionDenominator
+