{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Shelley.TxOut (
  ShelleyTxOut (ShelleyTxOut, TxOutCompact),

  -- * Helpers
  addrEitherShelleyTxOutL,
  valueEitherShelleyTxOutL,
) where

import Cardano.Ledger.Address (CompactAddr, compactAddr, decompactAddr)
import Cardano.Ledger.BaseTypes (KeyValuePairs (..), ToKeyValuePairs (..))
import Cardano.Ledger.Binary (
  DecCBOR (..),
  DecShareCBOR (..),
  EncCBOR (..),
  Interns (..),
  TokenType (..),
  decodeMemPack,
  decodeRecordNamed,
  encodeListLen,
  peekTokenType,
 )
import Cardano.Ledger.Compactible (Compactible (CompactForm, fromCompact, toCompact))
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential)
import Cardano.Ledger.Shelley.Era (ShelleyEra)
import Cardano.Ledger.Shelley.PParams ()
import Cardano.Ledger.Val (Val)
import Control.DeepSeq (NFData (rnf))
import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.=))
import qualified Data.Aeson as Aeson
import Data.Maybe (fromMaybe)
import Data.MemPack
import GHC.Generics (Generic)
import GHC.Stack (HasCallStack)
import Lens.Micro
import NoThunks.Class (InspectHeapNamed (..), NoThunks (..))

data ShelleyTxOut era = TxOutCompact
  { forall era. ShelleyTxOut era -> CompactAddr
txOutCompactAddr :: {-# UNPACK #-} !CompactAddr
  , forall era. ShelleyTxOut era -> CompactForm (Value era)
txOutCompactValue :: !(CompactForm (Value era))
  }
  deriving ((forall x. ShelleyTxOut era -> Rep (ShelleyTxOut era) x)
-> (forall x. Rep (ShelleyTxOut era) x -> ShelleyTxOut era)
-> Generic (ShelleyTxOut era)
forall x. Rep (ShelleyTxOut era) x -> ShelleyTxOut era
forall x. ShelleyTxOut era -> Rep (ShelleyTxOut era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (ShelleyTxOut era) x -> ShelleyTxOut era
forall era x. ShelleyTxOut era -> Rep (ShelleyTxOut era) x
$cfrom :: forall era x. ShelleyTxOut era -> Rep (ShelleyTxOut era) x
from :: forall x. ShelleyTxOut era -> Rep (ShelleyTxOut era) x
$cto :: forall era x. Rep (ShelleyTxOut era) x -> ShelleyTxOut era
to :: forall x. Rep (ShelleyTxOut era) x -> ShelleyTxOut era
Generic)

-- | This instance uses a zero Tag for forward compatibility in binary representation with TxOut
-- instances for future eras
instance (Era era, MemPack (CompactForm (Value era))) => MemPack (ShelleyTxOut era) where
  packedByteCount :: ShelleyTxOut era -> Int
packedByteCount = \case
    TxOutCompact CompactAddr
cAddr CompactForm (Value era)
cValue ->
      Int
packedTagByteCount Int -> Int -> Int
forall a. Num a => a -> a -> a
+ CompactAddr -> Int
forall a. MemPack a => a -> Int
packedByteCount CompactAddr
cAddr Int -> Int -> Int
forall a. Num a => a -> a -> a
+ CompactForm (Value era) -> Int
forall a. MemPack a => a -> Int
packedByteCount CompactForm (Value era)
cValue
  {-# INLINE packedByteCount #-}
  packM :: forall s. ShelleyTxOut era -> Pack s ()
packM = \case
    TxOutCompact CompactAddr
cAddr CompactForm (Value era)
cValue ->
      Tag -> Pack s ()
forall s. Tag -> Pack s ()
packTagM Tag
0 Pack s () -> Pack s () -> Pack s ()
forall a b. Pack s a -> Pack s b -> Pack s b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CompactAddr -> Pack s ()
forall s. CompactAddr -> Pack s ()
forall a s. MemPack a => a -> Pack s ()
packM CompactAddr
cAddr Pack s () -> Pack s () -> Pack s ()
forall a b. Pack s a -> Pack s b -> Pack s b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CompactForm (Value era) -> Pack s ()
forall s. CompactForm (Value era) -> Pack s ()
forall a s. MemPack a => a -> Pack s ()
packM CompactForm (Value era)
cValue
  {-# INLINE packM #-}
  unpackM :: forall b s. Buffer b => Unpack s b (ShelleyTxOut era)
unpackM =
    Unpack s b Tag
forall b s. Buffer b => Unpack s b Tag
unpackTagM Unpack s b Tag
-> (Tag -> Unpack s b (ShelleyTxOut era))
-> Unpack s b (ShelleyTxOut era)
forall a b. Unpack s b a -> (a -> Unpack s b b) -> Unpack s b b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Tag
0 -> CompactAddr -> CompactForm (Value era) -> ShelleyTxOut era
forall era.
CompactAddr -> CompactForm (Value era) -> ShelleyTxOut era
TxOutCompact (CompactAddr -> CompactForm (Value era) -> ShelleyTxOut era)
-> Unpack s b CompactAddr
-> Unpack s b (CompactForm (Value era) -> ShelleyTxOut era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Unpack s b CompactAddr
forall a b s. (MemPack a, Buffer b) => Unpack s b a
forall b s. Buffer b => Unpack s b CompactAddr
unpackM Unpack s b (CompactForm (Value era) -> ShelleyTxOut era)
-> Unpack s b (CompactForm (Value era))
-> Unpack s b (ShelleyTxOut era)
forall a b. Unpack s b (a -> b) -> Unpack s b a -> Unpack s b b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Unpack s b (CompactForm (Value era))
forall a b s. (MemPack a, Buffer b) => Unpack s b a
forall b s. Buffer b => Unpack s b (CompactForm (Value era))
unpackM
      Tag
n -> forall a (m :: * -> *) b. (MemPack a, MonadFail m) => Tag -> m b
unknownTagM @(ShelleyTxOut era) Tag
n
  {-# INLINE unpackM #-}

instance EraTxOut ShelleyEra where
  type TxOut ShelleyEra = ShelleyTxOut ShelleyEra

  mkBasicTxOut :: HasCallStack => Addr -> Value ShelleyEra -> TxOut ShelleyEra
mkBasicTxOut = Addr -> Value ShelleyEra -> TxOut ShelleyEra
Addr -> Value ShelleyEra -> ShelleyTxOut ShelleyEra
forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut

  -- Calling this partial function will result in compilation error, since ByronEra has
  -- no instance for EraTxOut type class.
  upgradeTxOut :: EraTxOut (PreviousEra ShelleyEra) =>
TxOut (PreviousEra ShelleyEra) -> TxOut ShelleyEra
upgradeTxOut = [Char] -> TxOut ByronEra -> ShelleyTxOut ShelleyEra
forall a. HasCallStack => [Char] -> a
error [Char]
"It is not possible to translate Byron TxOut with 'upgradeTxOut'"

  addrEitherTxOutL :: Lens' (TxOut ShelleyEra) (Either Addr CompactAddr)
addrEitherTxOutL = (Either Addr CompactAddr -> f (Either Addr CompactAddr))
-> TxOut ShelleyEra -> f (TxOut ShelleyEra)
(Either Addr CompactAddr -> f (Either Addr CompactAddr))
-> ShelleyTxOut ShelleyEra -> f (ShelleyTxOut ShelleyEra)
forall era (f :: * -> *).
Functor f =>
(Either Addr CompactAddr -> f (Either Addr CompactAddr))
-> ShelleyTxOut era -> f (ShelleyTxOut era)
addrEitherShelleyTxOutL
  {-# INLINE addrEitherTxOutL #-}

  valueEitherTxOutL :: Lens'
  (TxOut ShelleyEra)
  (Either (Value ShelleyEra) (CompactForm (Value ShelleyEra)))
valueEitherTxOutL = (Either (Value ShelleyEra) (CompactForm (Value ShelleyEra))
 -> f (Either (Value ShelleyEra) (CompactForm (Value ShelleyEra))))
-> TxOut ShelleyEra -> f (TxOut ShelleyEra)
(Either (Value ShelleyEra) (CompactForm (Value ShelleyEra))
 -> f (Either (Value ShelleyEra) (CompactForm (Value ShelleyEra))))
-> ShelleyTxOut ShelleyEra -> f (ShelleyTxOut ShelleyEra)
forall era.
Val (Value era) =>
Lens'
  (ShelleyTxOut era) (Either (Value era) (CompactForm (Value era)))
Lens'
  (ShelleyTxOut ShelleyEra)
  (Either (Value ShelleyEra) (CompactForm (Value ShelleyEra)))
valueEitherShelleyTxOutL
  {-# INLINE valueEitherTxOutL #-}

  getMinCoinTxOut :: PParams ShelleyEra -> TxOut ShelleyEra -> Coin
getMinCoinTxOut PParams ShelleyEra
pp TxOut ShelleyEra
_ = PParams ShelleyEra
pp PParams ShelleyEra
-> Getting Coin (PParams ShelleyEra) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (PParams ShelleyEra) Coin
forall era.
(EraPParams era, AtMostEra "Mary" era, HasCallStack) =>
Lens' (PParams era) Coin
Lens' (PParams ShelleyEra) Coin
ppMinUTxOValueL

addrEitherShelleyTxOutL :: Lens' (ShelleyTxOut era) (Either Addr CompactAddr)
addrEitherShelleyTxOutL :: forall era (f :: * -> *).
Functor f =>
(Either Addr CompactAddr -> f (Either Addr CompactAddr))
-> ShelleyTxOut era -> f (ShelleyTxOut era)
addrEitherShelleyTxOutL =
  (ShelleyTxOut era -> Either Addr CompactAddr)
-> (ShelleyTxOut era
    -> Either Addr CompactAddr -> ShelleyTxOut era)
-> Lens
     (ShelleyTxOut era)
     (ShelleyTxOut era)
     (Either Addr CompactAddr)
     (Either Addr CompactAddr)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens
    (CompactAddr -> Either Addr CompactAddr
forall a b. b -> Either a b
Right (CompactAddr -> Either Addr CompactAddr)
-> (ShelleyTxOut era -> CompactAddr)
-> ShelleyTxOut era
-> Either Addr CompactAddr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyTxOut era -> CompactAddr
forall era. ShelleyTxOut era -> CompactAddr
txOutCompactAddr)
    ( \ShelleyTxOut era
txOut -> \case
        Left Addr
addr -> ShelleyTxOut era
txOut {txOutCompactAddr = compactAddr addr}
        Right CompactAddr
cAddr -> ShelleyTxOut era
txOut {txOutCompactAddr = cAddr}
    )
{-# INLINE addrEitherShelleyTxOutL #-}

valueEitherShelleyTxOutL ::
  Val (Value era) => Lens' (ShelleyTxOut era) (Either (Value era) (CompactForm (Value era)))
valueEitherShelleyTxOutL :: forall era.
Val (Value era) =>
Lens'
  (ShelleyTxOut era) (Either (Value era) (CompactForm (Value era)))
valueEitherShelleyTxOutL =
  (ShelleyTxOut era -> Either (Value era) (CompactForm (Value era)))
-> (ShelleyTxOut era
    -> Either (Value era) (CompactForm (Value era))
    -> ShelleyTxOut era)
-> Lens
     (ShelleyTxOut era)
     (ShelleyTxOut era)
     (Either (Value era) (CompactForm (Value era)))
     (Either (Value era) (CompactForm (Value era)))
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens
    (CompactForm (Value era)
-> Either (Value era) (CompactForm (Value era))
forall a b. b -> Either a b
Right (CompactForm (Value era)
 -> Either (Value era) (CompactForm (Value era)))
-> (ShelleyTxOut era -> CompactForm (Value era))
-> ShelleyTxOut era
-> Either (Value era) (CompactForm (Value era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyTxOut era -> CompactForm (Value era)
forall era. ShelleyTxOut era -> CompactForm (Value era)
txOutCompactValue)
    ( \ShelleyTxOut era
txOut -> \case
        Left Value era
value ->
          ShelleyTxOut era
txOut
            { txOutCompactValue =
                fromMaybe (error $ "Illegal value in TxOut: " <> show value) $ toCompact value
            }
        Right CompactForm (Value era)
cValue -> ShelleyTxOut era
txOut {txOutCompactValue = cValue}
    )
{-# INLINE valueEitherShelleyTxOutL #-}

instance (Era era, Val (Value era)) => Show (ShelleyTxOut era) where
  show :: ShelleyTxOut era -> [Char]
show = (Addr, Value era) -> [Char]
forall a. Show a => a -> [Char]
show ((Addr, Value era) -> [Char])
-> (ShelleyTxOut era -> (Addr, Value era))
-> ShelleyTxOut era
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyTxOut era -> (Addr, Value era)
forall era.
Val (Value era) =>
ShelleyTxOut era -> (Addr, Value era)
viewCompactTxOut -- FIXME: showing TxOut as a tuple is just sad

deriving instance Eq (CompactForm (Value era)) => Eq (ShelleyTxOut era)

deriving instance Ord (CompactForm (Value era)) => Ord (ShelleyTxOut era)

instance NFData (ShelleyTxOut era) where
  rnf :: ShelleyTxOut era -> ()
rnf = (ShelleyTxOut era -> () -> ()
forall a b. a -> b -> b
`seq` ())

deriving via InspectHeapNamed "TxOut" (ShelleyTxOut era) instance NoThunks (ShelleyTxOut era)

pattern ShelleyTxOut ::
  (HasCallStack, Era era, Val (Value era)) =>
  Addr ->
  Value era ->
  ShelleyTxOut era
pattern $mShelleyTxOut :: forall {r} {era}.
(HasCallStack, Era era, Val (Value era)) =>
ShelleyTxOut era -> (Addr -> Value era -> r) -> ((# #) -> r) -> r
$bShelleyTxOut :: forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut addr vl <-
  (viewCompactTxOut -> (addr, vl))
  where
    ShelleyTxOut Addr
addr Value era
vl =
      CompactAddr -> CompactForm (Value era) -> ShelleyTxOut era
forall era.
CompactAddr -> CompactForm (Value era) -> ShelleyTxOut era
TxOutCompact
        (Addr -> CompactAddr
compactAddr Addr
addr)
        (CompactForm (Value era)
-> Maybe (CompactForm (Value era)) -> CompactForm (Value era)
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> CompactForm (Value era)
forall a. HasCallStack => [Char] -> a
error ([Char] -> CompactForm (Value era))
-> [Char] -> CompactForm (Value era)
forall a b. (a -> b) -> a -> b
$ [Char]
"Illegal value in TxOut: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Value era -> [Char]
forall a. Show a => a -> [Char]
show Value era
vl) (Maybe (CompactForm (Value era)) -> CompactForm (Value era))
-> Maybe (CompactForm (Value era)) -> CompactForm (Value era)
forall a b. (a -> b) -> a -> b
$ Value era -> Maybe (CompactForm (Value era))
forall a. Compactible a => a -> Maybe (CompactForm a)
toCompact Value era
vl)

{-# COMPLETE ShelleyTxOut #-}

viewCompactTxOut :: Val (Value era) => ShelleyTxOut era -> (Addr, Value era)
viewCompactTxOut :: forall era.
Val (Value era) =>
ShelleyTxOut era -> (Addr, Value era)
viewCompactTxOut TxOutCompact {CompactAddr
txOutCompactAddr :: forall era. ShelleyTxOut era -> CompactAddr
txOutCompactAddr :: CompactAddr
txOutCompactAddr, CompactForm (Value era)
txOutCompactValue :: forall era. ShelleyTxOut era -> CompactForm (Value era)
txOutCompactValue :: CompactForm (Value era)
txOutCompactValue} =
  (HasCallStack => CompactAddr -> Addr
CompactAddr -> Addr
decompactAddr CompactAddr
txOutCompactAddr, CompactForm (Value era) -> Value era
forall a. Compactible a => CompactForm a -> a
fromCompact CompactForm (Value era)
txOutCompactValue)

instance (Era era, EncCBOR (CompactForm (Value era))) => EncCBOR (ShelleyTxOut era) where
  encCBOR :: ShelleyTxOut era -> Encoding
encCBOR (TxOutCompact CompactAddr
addr CompactForm (Value era)
coin) =
    Word -> Encoding
encodeListLen Word
2
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> CompactAddr -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR CompactAddr
addr
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> CompactForm (Value era) -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR CompactForm (Value era)
coin

instance (Era era, DecCBOR (CompactForm (Value era))) => DecCBOR (ShelleyTxOut era) where
  decCBOR :: forall s. Decoder s (ShelleyTxOut era)
decCBOR =
    Text
-> (ShelleyTxOut era -> Int)
-> Decoder s (ShelleyTxOut era)
-> Decoder s (ShelleyTxOut era)
forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"ShelleyTxOut" (Int -> ShelleyTxOut era -> Int
forall a b. a -> b -> a
const Int
2) (Decoder s (ShelleyTxOut era) -> Decoder s (ShelleyTxOut era))
-> Decoder s (ShelleyTxOut era) -> Decoder s (ShelleyTxOut era)
forall a b. (a -> b) -> a -> b
$ do
      cAddr <- Decoder s CompactAddr
forall s. Decoder s CompactAddr
forall a s. DecCBOR a => Decoder s a
decCBOR
      TxOutCompact cAddr <$> decCBOR

instance
  ( Era era
  , MemPack (CompactForm (Value era))
  , DecCBOR (CompactForm (Value era))
  ) =>
  DecShareCBOR (ShelleyTxOut era)
  where
  type Share (ShelleyTxOut era) = Interns (Credential Staking)
  decShareCBOR :: forall s. Share (ShelleyTxOut era) -> Decoder s (ShelleyTxOut era)
decShareCBOR Share (ShelleyTxOut era)
_ = do
    Decoder s TokenType
forall s. Decoder s TokenType
peekTokenType Decoder s TokenType
-> (TokenType -> Decoder s (ShelleyTxOut era))
-> Decoder s (ShelleyTxOut era)
forall a b. Decoder s a -> (a -> Decoder s b) -> Decoder s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      TokenType
TypeBytes -> Decoder s (ShelleyTxOut era)
forall a s. MemPack a => Decoder s a
decodeMemPack
      TokenType
TypeBytesIndef -> Decoder s (ShelleyTxOut era)
forall a s. MemPack a => Decoder s a
decodeMemPack
      TokenType
_ -> Decoder s (ShelleyTxOut era)
forall s. Decoder s (ShelleyTxOut era)
forall a s. DecCBOR a => Decoder s a
decCBOR

deriving via
  KeyValuePairs (ShelleyTxOut era)
  instance
    (Era era, Val (Value era)) => ToJSON (ShelleyTxOut era)

instance (Era era, Val (Value era)) => ToKeyValuePairs (ShelleyTxOut era) where
  toKeyValuePairs :: forall e kv. KeyValue e kv => ShelleyTxOut era -> [kv]
toKeyValuePairs (ShelleyTxOut !Addr
addr !Value era
amount) =
    [ Key
"address" Key -> Addr -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Addr
addr
    , Key
"amount" Key -> Value era -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Value era
amount
    ]

instance (Era era, Val (Value era)) => FromJSON (ShelleyTxOut era) where
  parseJSON :: Value -> Parser (ShelleyTxOut era)
parseJSON = [Char]
-> (Object -> Parser (ShelleyTxOut era))
-> Value
-> Parser (ShelleyTxOut era)
forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject [Char]
"ShelleyTxOut" ((Object -> Parser (ShelleyTxOut era))
 -> Value -> Parser (ShelleyTxOut era))
-> (Object -> Parser (ShelleyTxOut era))
-> Value
-> Parser (ShelleyTxOut era)
forall a b. (a -> b) -> a -> b
$ \Object
o ->
    Addr -> Value era -> ShelleyTxOut era
forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut
      (Addr -> Value era -> ShelleyTxOut era)
-> Parser Addr -> Parser (Value era -> ShelleyTxOut era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Addr
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"address"
      Parser (Value era -> ShelleyTxOut era)
-> Parser (Value era) -> Parser (ShelleyTxOut era)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Value era)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"amount"