{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}

module Cardano.Ledger.DRep (
  DRep (DRepCredential, DRepKeyHash, DRepScriptHash, DRepAlwaysAbstain, DRepAlwaysNoConfidence),
  DRepState (..),
  drepExpiryL,
  drepAnchorL,
  drepDepositL,
  drepDelegsL,
) where

import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..))
import Cardano.Ledger.Binary.Coders (Decode (..), Encode (..), decode, encode, (!>), (<!))
import Cardano.Ledger.Coin (Coin)
import Cardano.Ledger.Credential (Credential (..), credToText, parseCredential)
import Cardano.Ledger.Hashes (ScriptHash)
import Cardano.Ledger.Keys (KeyHash (..), KeyRole (..))
import Control.DeepSeq (NFData (..))
import Data.Aeson (
  FromJSON (..),
  FromJSONKey (..),
  FromJSONKeyFunction (..),
  KeyValue (..),
  ToJSON (..),
  ToJSONKey (..),
  Value (..),
  object,
  withObject,
  withText,
  (.!=),
  (.:),
  (.:?),
 )
import Data.Aeson.Types (toJSONKeyText)
import Data.Set (Set)
import qualified Data.Text as T
import GHC.Generics (Generic)
import Lens.Micro
import NoThunks.Class (NoThunks (..))

-- =======================================
-- DRep and DRepState

data DRep
  = DRepKeyHash !(KeyHash 'DRepRole)
  | DRepScriptHash !ScriptHash
  | DRepAlwaysAbstain
  | DRepAlwaysNoConfidence
  deriving (Int -> DRep -> ShowS
[DRep] -> ShowS
DRep -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DRep] -> ShowS
$cshowList :: [DRep] -> ShowS
show :: DRep -> String
$cshow :: DRep -> String
showsPrec :: Int -> DRep -> ShowS
$cshowsPrec :: Int -> DRep -> ShowS
Show, DRep -> DRep -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DRep -> DRep -> Bool
$c/= :: DRep -> DRep -> Bool
== :: DRep -> DRep -> Bool
$c== :: DRep -> DRep -> Bool
Eq, Eq DRep
DRep -> DRep -> Bool
DRep -> DRep -> Ordering
DRep -> DRep -> DRep
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 :: DRep -> DRep -> DRep
$cmin :: DRep -> DRep -> DRep
max :: DRep -> DRep -> DRep
$cmax :: DRep -> DRep -> DRep
>= :: DRep -> DRep -> Bool
$c>= :: DRep -> DRep -> Bool
> :: DRep -> DRep -> Bool
$c> :: DRep -> DRep -> Bool
<= :: DRep -> DRep -> Bool
$c<= :: DRep -> DRep -> Bool
< :: DRep -> DRep -> Bool
$c< :: DRep -> DRep -> Bool
compare :: DRep -> DRep -> Ordering
$ccompare :: DRep -> DRep -> Ordering
Ord, forall x. Rep DRep x -> DRep
forall x. DRep -> Rep DRep x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep DRep x -> DRep
$cfrom :: forall x. DRep -> Rep DRep x
Generic, Context -> DRep -> IO (Maybe ThunkInfo)
Proxy DRep -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy DRep -> String
$cshowTypeOf :: Proxy DRep -> String
wNoThunks :: Context -> DRep -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> DRep -> IO (Maybe ThunkInfo)
noThunks :: Context -> DRep -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> DRep -> IO (Maybe ThunkInfo)
NoThunks, DRep -> ()
forall a. (a -> ()) -> NFData a
rnf :: DRep -> ()
$crnf :: DRep -> ()
NFData)

instance EncCBOR DRep where
  encCBOR :: DRep -> Encoding
encCBOR (DRepKeyHash KeyHash 'DRepRole
kh) =
    forall (w :: Wrapped) t. Encode w t -> Encoding
encode forall a b. (a -> b) -> a -> b
$
      forall t. t -> Word -> Encode 'Open t
Sum KeyHash 'DRepRole -> DRep
DRepKeyHash Word
0
        forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To KeyHash 'DRepRole
kh
  encCBOR (DRepScriptHash ScriptHash
sh) =
    forall (w :: Wrapped) t. Encode w t -> Encoding
encode forall a b. (a -> b) -> a -> b
$
      forall t. t -> Word -> Encode 'Open t
Sum ScriptHash -> DRep
DRepScriptHash Word
1
        forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To ScriptHash
sh
  encCBOR DRep
DRepAlwaysAbstain =
    forall (w :: Wrapped) t. Encode w t -> Encoding
encode forall a b. (a -> b) -> a -> b
$
      forall t. t -> Word -> Encode 'Open t
Sum DRep
DRepAlwaysAbstain Word
2
  encCBOR DRep
DRepAlwaysNoConfidence =
    forall (w :: Wrapped) t. Encode w t -> Encoding
encode forall a b. (a -> b) -> a -> b
$
      forall t. t -> Word -> Encode 'Open t
Sum DRep
DRepAlwaysNoConfidence Word
3

instance DecCBOR DRep where
  decCBOR :: forall s. Decoder s DRep
decCBOR = forall (w :: Wrapped) t s. Decode w t -> Decoder s t
decode forall a b. (a -> b) -> a -> b
$
    forall t.
Text -> (Word -> Decode 'Open t) -> Decode ('Closed 'Dense) t
Summands Text
"DRep" forall a b. (a -> b) -> a -> b
$ \case
      Word
0 -> forall t. t -> Decode 'Open t
SumD KeyHash 'DRepRole -> DRep
DRepKeyHash forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
      Word
1 -> forall t. t -> Decode 'Open t
SumD ScriptHash -> DRep
DRepScriptHash forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
      Word
2 -> forall t. t -> Decode 'Open t
SumD DRep
DRepAlwaysAbstain
      Word
3 -> forall t. t -> Decode 'Open t
SumD DRep
DRepAlwaysNoConfidence
      Word
k -> forall (w :: Wrapped) t. Word -> Decode w t
Invalid Word
k

dRepToCred :: DRep -> Maybe (Credential 'DRepRole)
dRepToCred :: DRep -> Maybe (Credential 'DRepRole)
dRepToCred (DRepKeyHash KeyHash 'DRepRole
kh) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'DRepRole
kh
dRepToCred (DRepScriptHash ScriptHash
sh) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
sh
dRepToCred DRep
_ = forall a. Maybe a
Nothing

instance ToJSON DRep where
  toJSON :: DRep -> Value
toJSON = Text -> Value
String forall b c a. (b -> c) -> (a -> b) -> a -> c
. DRep -> Text
dRepToText

instance ToJSONKey DRep where
  toJSONKey :: ToJSONKeyFunction DRep
toJSONKey = forall a. (a -> Text) -> ToJSONKeyFunction a
toJSONKeyText DRep -> Text
dRepToText

dRepToText :: DRep -> T.Text
dRepToText :: DRep -> Text
dRepToText = \case
  DRep
DRepAlwaysAbstain -> Text
"drep-alwaysAbstain"
  DRep
DRepAlwaysNoConfidence -> Text
"drep-alwaysNoConfidence"
  DRepCredential Credential 'DRepRole
cred -> Text
"drep-" forall a. Semigroup a => a -> a -> a
<> forall (kr :: KeyRole). Credential kr -> Text
credToText Credential 'DRepRole
cred

instance FromJSON DRep where
  parseJSON :: Value -> Parser DRep
parseJSON = forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"DRep" forall (f :: * -> *). MonadFail f => Text -> f DRep
parseDRep

instance FromJSONKey DRep where
  fromJSONKey :: FromJSONKeyFunction DRep
fromJSONKey = forall a. (Text -> Parser a) -> FromJSONKeyFunction a
FromJSONKeyTextParser forall (f :: * -> *). MonadFail f => Text -> f DRep
parseDRep

parseDRep :: MonadFail f => T.Text -> f DRep
parseDRep :: forall (f :: * -> *). MonadFail f => Text -> f DRep
parseDRep Text
t = case (Char -> Bool) -> Text -> (Text, Text)
T.span (forall a. Eq a => a -> a -> Bool
/= Char
'-') Text
t of
  (Text
"drep", Text
restWithDash)
    | Text
restWithDash forall a. Eq a => a -> a -> Bool
== Text
"-alwaysAbstain" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure DRep
DRepAlwaysAbstain
    | Text
restWithDash forall a. Eq a => a -> a -> Bool
== Text
"-alwaysNoConfidence" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure DRep
DRepAlwaysNoConfidence
    | (Text
"-", Text
rest) <- (Char -> Bool) -> Text -> (Text, Text)
T.span (forall a. Eq a => a -> a -> Bool
== Char
'-') Text
restWithDash ->
        Credential 'DRepRole -> DRep
DRepCredential forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) (kr :: KeyRole).
MonadFail m =>
Text -> m (Credential kr)
parseCredential Text
rest
  (Text, Text)
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Invalid DRep: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Text
t

pattern DRepCredential :: Credential 'DRepRole -> DRep
pattern $bDRepCredential :: Credential 'DRepRole -> DRep
$mDRepCredential :: forall {r}.
DRep -> (Credential 'DRepRole -> r) -> ((# #) -> r) -> r
DRepCredential c <- (dRepToCred -> Just c)
  where
    DRepCredential Credential 'DRepRole
c = case Credential 'DRepRole
c of
      ScriptHashObj ScriptHash
sh -> ScriptHash -> DRep
DRepScriptHash ScriptHash
sh
      KeyHashObj KeyHash 'DRepRole
kh -> KeyHash 'DRepRole -> DRep
DRepKeyHash KeyHash 'DRepRole
kh

{-# COMPLETE DRepCredential, DRepAlwaysAbstain, DRepAlwaysNoConfidence :: DRep #-}

data DRepState = DRepState
  { DRepState -> EpochNo
drepExpiry :: !EpochNo
  , DRepState -> StrictMaybe Anchor
drepAnchor :: !(StrictMaybe Anchor)
  , DRepState -> Coin
drepDeposit :: !Coin
  , DRepState -> Set (Credential 'Staking)
drepDelegs :: !(Set (Credential 'Staking))
  }
  deriving (Int -> DRepState -> ShowS
[DRepState] -> ShowS
DRepState -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DRepState] -> ShowS
$cshowList :: [DRepState] -> ShowS
show :: DRepState -> String
$cshow :: DRepState -> String
showsPrec :: Int -> DRepState -> ShowS
$cshowsPrec :: Int -> DRepState -> ShowS
Show, DRepState -> DRepState -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DRepState -> DRepState -> Bool
$c/= :: DRepState -> DRepState -> Bool
== :: DRepState -> DRepState -> Bool
$c== :: DRepState -> DRepState -> Bool
Eq, Eq DRepState
DRepState -> DRepState -> Bool
DRepState -> DRepState -> Ordering
DRepState -> DRepState -> DRepState
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 :: DRepState -> DRepState -> DRepState
$cmin :: DRepState -> DRepState -> DRepState
max :: DRepState -> DRepState -> DRepState
$cmax :: DRepState -> DRepState -> DRepState
>= :: DRepState -> DRepState -> Bool
$c>= :: DRepState -> DRepState -> Bool
> :: DRepState -> DRepState -> Bool
$c> :: DRepState -> DRepState -> Bool
<= :: DRepState -> DRepState -> Bool
$c<= :: DRepState -> DRepState -> Bool
< :: DRepState -> DRepState -> Bool
$c< :: DRepState -> DRepState -> Bool
compare :: DRepState -> DRepState -> Ordering
$ccompare :: DRepState -> DRepState -> Ordering
Ord, forall x. Rep DRepState x -> DRepState
forall x. DRepState -> Rep DRepState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep DRepState x -> DRepState
$cfrom :: forall x. DRepState -> Rep DRepState x
Generic)

instance NoThunks DRepState

instance NFData DRepState

instance DecCBOR DRepState where
  decCBOR :: forall s. Decoder s DRepState
decCBOR = do
    forall (w :: Wrapped) t s. Decode w t -> Decoder s t
decode forall a b. (a -> b) -> a -> b
$
      forall t. t -> Decode ('Closed 'Dense) t
RecD EpochNo
-> StrictMaybe Anchor
-> Coin
-> Set (Credential 'Staking)
-> DRepState
DRepState
        forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
        forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
        forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
        forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From

instance EncCBOR DRepState where
  encCBOR :: DRepState -> Encoding
encCBOR DRepState {Set (Credential 'Staking)
StrictMaybe Anchor
EpochNo
Coin
drepDelegs :: Set (Credential 'Staking)
drepDeposit :: Coin
drepAnchor :: StrictMaybe Anchor
drepExpiry :: EpochNo
drepDelegs :: DRepState -> Set (Credential 'Staking)
drepDeposit :: DRepState -> Coin
drepAnchor :: DRepState -> StrictMaybe Anchor
drepExpiry :: DRepState -> EpochNo
..} =
    forall (w :: Wrapped) t. Encode w t -> Encoding
encode forall a b. (a -> b) -> a -> b
$
      forall t. t -> Encode ('Closed 'Dense) t
Rec EpochNo
-> StrictMaybe Anchor
-> Coin
-> Set (Credential 'Staking)
-> DRepState
DRepState
        forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To EpochNo
drepExpiry
        forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To StrictMaybe Anchor
drepAnchor
        forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Coin
drepDeposit
        forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Set (Credential 'Staking)
drepDelegs

instance ToJSON DRepState where
  toJSON :: DRepState -> Value
toJSON x :: DRepState
x@(DRepState EpochNo
_ StrictMaybe Anchor
_ Coin
_ Set (Credential 'Staking)
_) =
    let DRepState {Set (Credential 'Staking)
StrictMaybe Anchor
EpochNo
Coin
drepDelegs :: Set (Credential 'Staking)
drepDeposit :: Coin
drepAnchor :: StrictMaybe Anchor
drepExpiry :: EpochNo
drepDelegs :: DRepState -> Set (Credential 'Staking)
drepDeposit :: DRepState -> Coin
drepAnchor :: DRepState -> StrictMaybe Anchor
drepExpiry :: DRepState -> EpochNo
..} = DRepState
x
     in forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$
          [Pair] -> Value
object forall a b. (a -> b) -> a -> b
$
            [ Key
"expiry" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> Value
toJSON EpochNo
drepExpiry
            , Key
"deposit" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> Value
toJSON Coin
drepDeposit
            , Key
"delegators" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> Value
toJSON Set (Credential 'Staking)
drepDelegs
            ]
              forall a. [a] -> [a] -> [a]
++ [Key
"anchor" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> Value
toJSON Anchor
anchor | SJust Anchor
anchor <- [StrictMaybe Anchor
drepAnchor]]

instance FromJSON DRepState where
  parseJSON :: Value -> Parser DRepState
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"DRepState" forall a b. (a -> b) -> a -> b
$ \Object
o ->
    EpochNo
-> StrictMaybe Anchor
-> Coin
-> Set (Credential 'Staking)
-> DRepState
DRepState
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"expiry"
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"anchor" forall a. Parser (Maybe a) -> a -> Parser a
.!= forall a. StrictMaybe a
SNothing
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"deposit"
      -- Construction of DRep state with deleagations is intentionally prohibited, since
      -- there is a requirement to retain the invariant of delegations in the UMap
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty

drepExpiryL :: Lens' DRepState EpochNo
drepExpiryL :: Lens' DRepState EpochNo
drepExpiryL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens DRepState -> EpochNo
drepExpiry (\DRepState
x EpochNo
y -> DRepState
x {drepExpiry :: EpochNo
drepExpiry = EpochNo
y})

drepAnchorL :: Lens' DRepState (StrictMaybe Anchor)
drepAnchorL :: Lens' DRepState (StrictMaybe Anchor)
drepAnchorL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens DRepState -> StrictMaybe Anchor
drepAnchor (\DRepState
x StrictMaybe Anchor
y -> DRepState
x {drepAnchor :: StrictMaybe Anchor
drepAnchor = StrictMaybe Anchor
y})

drepDepositL :: Lens' DRepState Coin
drepDepositL :: Lens' DRepState Coin
drepDepositL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens DRepState -> Coin
drepDeposit (\DRepState
x Coin
y -> DRepState
x {drepDeposit :: Coin
drepDeposit = Coin
y})

drepDelegsL :: Lens' DRepState (Set (Credential 'Staking))
drepDelegsL :: Lens' DRepState (Set (Credential 'Staking))
drepDelegsL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens DRepState -> Set (Credential 'Staking)
drepDelegs (\DRepState
x Set (Credential 'Staking)
y -> DRepState
x {drepDelegs :: Set (Credential 'Staking)
drepDelegs = Set (Credential 'Staking)
y})