{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# 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 (Addr (..), CompactAddr, compactAddr, decompactAddr)
import Cardano.Ledger.Binary (
  DecCBOR (..),
  DecShareCBOR (..),
  EncCBOR (..),
  FromCBOR (..),
  Interns (..),
  ToCBOR (..),
  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 (KeyValue, ToJSON (..), object, pairs, (.=))
import Data.Maybe (fromMaybe)
import Data.MemPack
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))
  }

-- | 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 a s. MemPack a => a -> Pack s ()
forall s. CompactAddr -> 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 a s. MemPack a => a -> Pack s ()
forall s. CompactForm (Value era) -> Pack s ()
packM CompactForm (Value era)
cValue
  {-# INLINE packM #-}
  unpackM :: forall b. Buffer b => Unpack b (ShelleyTxOut era)
unpackM =
    Unpack b Tag
forall b. Buffer b => Unpack b Tag
unpackTagM Unpack b Tag
-> (Tag -> Unpack b (ShelleyTxOut era))
-> Unpack b (ShelleyTxOut era)
forall a b. Unpack b a -> (a -> Unpack b b) -> Unpack 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 b CompactAddr
-> Unpack b (CompactForm (Value era) -> ShelleyTxOut era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Unpack b CompactAddr
forall a b. (MemPack a, Buffer b) => Unpack b a
forall b. Buffer b => Unpack b CompactAddr
unpackM Unpack b (CompactForm (Value era) -> ShelleyTxOut era)
-> Unpack b (CompactForm (Value era))
-> Unpack b (ShelleyTxOut era)
forall a b. Unpack b (a -> b) -> Unpack b a -> Unpack b b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Unpack b (CompactForm (Value era))
forall a b. (MemPack a, Buffer b) => Unpack b a
forall b. Buffer b => Unpack 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, ProtVerAtMost era 4) =>
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)

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
      CompactAddr
cAddr <- Decoder s CompactAddr
forall s. Decoder s CompactAddr
forall a s. DecCBOR a => Decoder s a
decCBOR
      CompactAddr -> CompactForm (Value era) -> ShelleyTxOut era
forall era.
CompactAddr -> CompactForm (Value era) -> ShelleyTxOut era
TxOutCompact CompactAddr
cAddr (CompactForm (Value era) -> ShelleyTxOut era)
-> Decoder s (CompactForm (Value era))
-> Decoder s (ShelleyTxOut era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (CompactForm (Value era))
forall s. Decoder s (CompactForm (Value era))
forall a s. DecCBOR a => Decoder s a
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

instance (Era era, EncCBOR (CompactForm (Value era))) => ToCBOR (ShelleyTxOut era) where
  toCBOR :: ShelleyTxOut era -> Encoding
toCBOR = forall era t. (Era era, EncCBOR t) => t -> Encoding
toEraCBOR @era

instance (Era era, DecCBOR (CompactForm (Value era))) => FromCBOR (ShelleyTxOut era) where
  fromCBOR :: forall s. Decoder s (ShelleyTxOut era)
fromCBOR = forall era t s. (Era era, DecCBOR t) => Decoder s t
fromEraCBOR @era

instance (Era era, Val (Value era)) => ToJSON (ShelleyTxOut era) where
  toJSON :: ShelleyTxOut era -> Value
toJSON = [Pair] -> Value
object ([Pair] -> Value)
-> (ShelleyTxOut era -> [Pair]) -> ShelleyTxOut era -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyTxOut era -> [Pair]
forall e a era.
(KeyValue e a, Era era, Val (Value era)) =>
ShelleyTxOut era -> [a]
toTxOutPair
  toEncoding :: ShelleyTxOut era -> Encoding
toEncoding = Series -> Encoding
pairs (Series -> Encoding)
-> (ShelleyTxOut era -> Series) -> ShelleyTxOut era -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Series] -> Series
forall a. Monoid a => [a] -> a
mconcat ([Series] -> Series)
-> (ShelleyTxOut era -> [Series]) -> ShelleyTxOut era -> Series
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyTxOut era -> [Series]
forall e a era.
(KeyValue e a, Era era, Val (Value era)) =>
ShelleyTxOut era -> [a]
toTxOutPair

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