{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}

module Cardano.Chain.Update.SoftforkRule
  ( SoftforkRule (..),
  )
where

import Cardano.Binary (FromCBOR (..), ToCBOR (..), encodeListLen, enforceSize)
import Cardano.Chain.Common (LovelacePortion)
import Cardano.Prelude
import qualified Data.Aeson as Aeson
import Formatting (bprint, build)
import qualified Formatting.Buildable as B
import NoThunks.Class (NoThunks (..))
import Text.JSON.Canonical (FromJSON (..), ToJSON (..), fromJSField, mkObject)

-- | Values defining softfork resolution rule
--
--   If a proposal is confirmed at the 's'-th epoch, softfork resolution
--   threshold at the 't'-th epoch will be 'max spMinThd (spInitThd - (t - s) *
--   spThdDecrement)'.
--
--   Softfork resolution threshold is the portion of total stake such that if
--   total stake of issuers of blocks with some block version is greater than
--   this portion, this block version becomes adopted.
data SoftforkRule = SoftforkRule
  { -- | Initial threshold (right after proposal is confirmed).
    SoftforkRule -> LovelacePortion
srInitThd :: !LovelacePortion,
    -- | Minimal threshold (i. e. threshold can't become less than this one).
    SoftforkRule -> LovelacePortion
srMinThd :: !LovelacePortion,
    -- | Theshold will be decreased by this value after each epoch.
    SoftforkRule -> LovelacePortion
srThdDecrement :: !LovelacePortion
  }
  deriving (Int -> SoftforkRule -> ShowS
[SoftforkRule] -> ShowS
SoftforkRule -> String
(Int -> SoftforkRule -> ShowS)
-> (SoftforkRule -> String)
-> ([SoftforkRule] -> ShowS)
-> Show SoftforkRule
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SoftforkRule] -> ShowS
$cshowList :: [SoftforkRule] -> ShowS
show :: SoftforkRule -> String
$cshow :: SoftforkRule -> String
showsPrec :: Int -> SoftforkRule -> ShowS
$cshowsPrec :: Int -> SoftforkRule -> ShowS
Show, SoftforkRule -> SoftforkRule -> Bool
(SoftforkRule -> SoftforkRule -> Bool)
-> (SoftforkRule -> SoftforkRule -> Bool) -> Eq SoftforkRule
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SoftforkRule -> SoftforkRule -> Bool
$c/= :: SoftforkRule -> SoftforkRule -> Bool
== :: SoftforkRule -> SoftforkRule -> Bool
$c== :: SoftforkRule -> SoftforkRule -> Bool
Eq, Eq SoftforkRule
Eq SoftforkRule
-> (SoftforkRule -> SoftforkRule -> Ordering)
-> (SoftforkRule -> SoftforkRule -> Bool)
-> (SoftforkRule -> SoftforkRule -> Bool)
-> (SoftforkRule -> SoftforkRule -> Bool)
-> (SoftforkRule -> SoftforkRule -> Bool)
-> (SoftforkRule -> SoftforkRule -> SoftforkRule)
-> (SoftforkRule -> SoftforkRule -> SoftforkRule)
-> Ord SoftforkRule
SoftforkRule -> SoftforkRule -> Bool
SoftforkRule -> SoftforkRule -> Ordering
SoftforkRule -> SoftforkRule -> SoftforkRule
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 :: SoftforkRule -> SoftforkRule -> SoftforkRule
$cmin :: SoftforkRule -> SoftforkRule -> SoftforkRule
max :: SoftforkRule -> SoftforkRule -> SoftforkRule
$cmax :: SoftforkRule -> SoftforkRule -> SoftforkRule
>= :: SoftforkRule -> SoftforkRule -> Bool
$c>= :: SoftforkRule -> SoftforkRule -> Bool
> :: SoftforkRule -> SoftforkRule -> Bool
$c> :: SoftforkRule -> SoftforkRule -> Bool
<= :: SoftforkRule -> SoftforkRule -> Bool
$c<= :: SoftforkRule -> SoftforkRule -> Bool
< :: SoftforkRule -> SoftforkRule -> Bool
$c< :: SoftforkRule -> SoftforkRule -> Bool
compare :: SoftforkRule -> SoftforkRule -> Ordering
$ccompare :: SoftforkRule -> SoftforkRule -> Ordering
$cp1Ord :: Eq SoftforkRule
Ord, (forall x. SoftforkRule -> Rep SoftforkRule x)
-> (forall x. Rep SoftforkRule x -> SoftforkRule)
-> Generic SoftforkRule
forall x. Rep SoftforkRule x -> SoftforkRule
forall x. SoftforkRule -> Rep SoftforkRule x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SoftforkRule x -> SoftforkRule
$cfrom :: forall x. SoftforkRule -> Rep SoftforkRule x
Generic)
  deriving anyclass (SoftforkRule -> ()
(SoftforkRule -> ()) -> NFData SoftforkRule
forall a. (a -> ()) -> NFData a
rnf :: SoftforkRule -> ()
$crnf :: SoftforkRule -> ()
NFData, Context -> SoftforkRule -> IO (Maybe ThunkInfo)
Proxy SoftforkRule -> String
(Context -> SoftforkRule -> IO (Maybe ThunkInfo))
-> (Context -> SoftforkRule -> IO (Maybe ThunkInfo))
-> (Proxy SoftforkRule -> String)
-> NoThunks SoftforkRule
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy SoftforkRule -> String
$cshowTypeOf :: Proxy SoftforkRule -> String
wNoThunks :: Context -> SoftforkRule -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> SoftforkRule -> IO (Maybe ThunkInfo)
noThunks :: Context -> SoftforkRule -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> SoftforkRule -> IO (Maybe ThunkInfo)
NoThunks)

instance B.Buildable SoftforkRule where
  build :: SoftforkRule -> Builder
build SoftforkRule
sr =
    Format
  Builder
  (LovelacePortion -> LovelacePortion -> LovelacePortion -> Builder)
-> LovelacePortion -> LovelacePortion -> LovelacePortion -> Builder
forall a. Format Builder a -> a
bprint
      (Format
  (LovelacePortion -> LovelacePortion -> LovelacePortion -> Builder)
  (LovelacePortion -> LovelacePortion -> LovelacePortion -> Builder)
"(init = " Format
  (LovelacePortion -> LovelacePortion -> LovelacePortion -> Builder)
  (LovelacePortion -> LovelacePortion -> LovelacePortion -> Builder)
-> Format
     Builder
     (LovelacePortion -> LovelacePortion -> LovelacePortion -> Builder)
-> Format
     Builder
     (LovelacePortion -> LovelacePortion -> LovelacePortion -> Builder)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format
  (LovelacePortion -> LovelacePortion -> Builder)
  (LovelacePortion -> LovelacePortion -> LovelacePortion -> Builder)
forall a r. Buildable a => Format r (a -> r)
build Format
  (LovelacePortion -> LovelacePortion -> Builder)
  (LovelacePortion -> LovelacePortion -> LovelacePortion -> Builder)
-> Format Builder (LovelacePortion -> LovelacePortion -> Builder)
-> Format
     Builder
     (LovelacePortion -> LovelacePortion -> LovelacePortion -> Builder)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format
  (LovelacePortion -> LovelacePortion -> Builder)
  (LovelacePortion -> LovelacePortion -> Builder)
", min = " Format
  (LovelacePortion -> LovelacePortion -> Builder)
  (LovelacePortion -> LovelacePortion -> Builder)
-> Format Builder (LovelacePortion -> LovelacePortion -> Builder)
-> Format Builder (LovelacePortion -> LovelacePortion -> Builder)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format
  (LovelacePortion -> Builder)
  (LovelacePortion -> LovelacePortion -> Builder)
forall a r. Buildable a => Format r (a -> r)
build Format
  (LovelacePortion -> Builder)
  (LovelacePortion -> LovelacePortion -> Builder)
-> Format Builder (LovelacePortion -> Builder)
-> Format Builder (LovelacePortion -> LovelacePortion -> Builder)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format (LovelacePortion -> Builder) (LovelacePortion -> Builder)
", decrement = " Format (LovelacePortion -> Builder) (LovelacePortion -> Builder)
-> Format Builder (LovelacePortion -> Builder)
-> Format Builder (LovelacePortion -> 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 (LovelacePortion -> Builder)
forall a r. Buildable a => Format r (a -> r)
build Format Builder (LovelacePortion -> Builder)
-> Format Builder Builder
-> Format Builder (LovelacePortion -> 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
")")
      (SoftforkRule -> LovelacePortion
srInitThd SoftforkRule
sr)
      (SoftforkRule -> LovelacePortion
srMinThd SoftforkRule
sr)
      (SoftforkRule -> LovelacePortion
srThdDecrement SoftforkRule
sr)

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

instance ToCBOR SoftforkRule where
  toCBOR :: SoftforkRule -> Encoding
toCBOR SoftforkRule
sr =
    Word -> Encoding
encodeListLen Word
3 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> LovelacePortion -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (SoftforkRule -> LovelacePortion
srInitThd SoftforkRule
sr) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> LovelacePortion -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (SoftforkRule -> LovelacePortion
srMinThd SoftforkRule
sr)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> LovelacePortion -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR
        (SoftforkRule -> LovelacePortion
srThdDecrement SoftforkRule
sr)

instance FromCBOR SoftforkRule where
  fromCBOR :: Decoder s SoftforkRule
fromCBOR = do
    Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"SoftforkRule" Int
3
    LovelacePortion
-> LovelacePortion -> LovelacePortion -> SoftforkRule
SoftforkRule (LovelacePortion
 -> LovelacePortion -> LovelacePortion -> SoftforkRule)
-> Decoder s LovelacePortion
-> Decoder s (LovelacePortion -> LovelacePortion -> SoftforkRule)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s LovelacePortion
forall a s. FromCBOR a => Decoder s a
fromCBOR Decoder s (LovelacePortion -> LovelacePortion -> SoftforkRule)
-> Decoder s LovelacePortion
-> Decoder s (LovelacePortion -> SoftforkRule)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s LovelacePortion
forall a s. FromCBOR a => Decoder s a
fromCBOR Decoder s (LovelacePortion -> SoftforkRule)
-> Decoder s LovelacePortion -> Decoder s SoftforkRule
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s LovelacePortion
forall a s. FromCBOR a => Decoder s a
fromCBOR

instance Monad m => ToJSON m SoftforkRule where
  toJSON :: SoftforkRule -> m JSValue
toJSON SoftforkRule
sr =
    [(JSString, m JSValue)] -> m JSValue
forall (m :: * -> *).
Monad m =>
[(JSString, m JSValue)] -> m JSValue
mkObject
      [ (JSString
"initThd", LovelacePortion -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON (LovelacePortion -> m JSValue) -> LovelacePortion -> m JSValue
forall a b. (a -> b) -> a -> b
$ SoftforkRule -> LovelacePortion
srInitThd SoftforkRule
sr),
        (JSString
"minThd", LovelacePortion -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON (LovelacePortion -> m JSValue) -> LovelacePortion -> m JSValue
forall a b. (a -> b) -> a -> b
$ SoftforkRule -> LovelacePortion
srMinThd SoftforkRule
sr),
        (JSString
"thdDecrement", LovelacePortion -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON (LovelacePortion -> m JSValue) -> LovelacePortion -> m JSValue
forall a b. (a -> b) -> a -> b
$ SoftforkRule -> LovelacePortion
srThdDecrement SoftforkRule
sr)
      ]

instance MonadError SchemaError m => FromJSON m SoftforkRule where
  fromJSON :: JSValue -> m SoftforkRule
fromJSON JSValue
obj =
    LovelacePortion
-> LovelacePortion -> LovelacePortion -> SoftforkRule
SoftforkRule
      (LovelacePortion
 -> LovelacePortion -> LovelacePortion -> SoftforkRule)
-> m LovelacePortion
-> m (LovelacePortion -> LovelacePortion -> SoftforkRule)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue -> JSString -> m LovelacePortion
forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> JSString -> m a
fromJSField JSValue
obj JSString
"initThd"
      m (LovelacePortion -> LovelacePortion -> SoftforkRule)
-> m LovelacePortion -> m (LovelacePortion -> SoftforkRule)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> JSValue -> JSString -> m LovelacePortion
forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> JSString -> m a
fromJSField JSValue
obj JSString
"minThd"
      m (LovelacePortion -> SoftforkRule)
-> m LovelacePortion -> m SoftforkRule
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> JSValue -> JSString -> m LovelacePortion
forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> JSString -> m a
fromJSField JSValue
obj JSString
"thdDecrement"