{-# 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.BaseTypes (KeyValuePairs (..), ToKeyValuePairs (..))
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 (ToJSON (..), (.=))
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

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
    ]