{-# 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 qualified Cardano.Crypto.Hash as HS
import Cardano.HeapWords (HeapWords (..))
import Cardano.Ledger.Address (Addr (..), CompactAddr, compactAddr, decompactAddr)
import Cardano.Ledger.Binary (
  DecCBOR (..),
  DecShareCBOR (..),
  EncCBOR (..),
  FromCBOR (..),
  Interns (..),
  ToCBOR (..),
  decodeRecordNamed,
  encodeListLen,
 )
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.ByteString.Short (ShortByteString, pack)
import Data.Maybe (fromMaybe)
import Data.Proxy (Proxy (..))
import Data.Word (Word8)
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))
  }

instance EraTxOut ShelleyEra where
  type TxOut ShelleyEra = ShelleyTxOut ShelleyEra

  mkBasicTxOut :: HasCallStack => Addr -> Value ShelleyEra -> TxOut ShelleyEra
mkBasicTxOut = 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 = 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 = forall era. Lens' (ShelleyTxOut era) (Either Addr CompactAddr)
addrEitherShelleyTxOutL
  {-# INLINE addrEitherTxOutL #-}

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

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

addrEitherShelleyTxOutL :: Lens' (ShelleyTxOut era) (Either Addr CompactAddr)
addrEitherShelleyTxOutL :: forall era. Lens' (ShelleyTxOut era) (Either Addr CompactAddr)
addrEitherShelleyTxOutL =
  forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens
    (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. ShelleyTxOut era -> CompactAddr
txOutCompactAddr)
    ( \ShelleyTxOut era
txOut -> \case
        Left Addr
addr -> ShelleyTxOut era
txOut {txOutCompactAddr :: CompactAddr
txOutCompactAddr = Addr -> CompactAddr
compactAddr Addr
addr}
        Right CompactAddr
cAddr -> ShelleyTxOut era
txOut {txOutCompactAddr :: CompactAddr
txOutCompactAddr = CompactAddr
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 =
  forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens
    (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. ShelleyTxOut era -> CompactForm (Value era)
txOutCompactValue)
    ( \ShelleyTxOut era
txOut -> \case
        Left Value era
value ->
          ShelleyTxOut era
txOut
            { txOutCompactValue :: CompactForm (Value era)
txOutCompactValue =
                forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Illegal value in TxOut: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Value era
value) forall a b. (a -> b) -> a -> b
$ forall a. Compactible a => a -> Maybe (CompactForm a)
toCompact Value era
value
            }
        Right CompactForm (Value era)
cValue -> ShelleyTxOut era
txOut {txOutCompactValue :: CompactForm (Value era)
txOutCompactValue = CompactForm (Value era)
cValue}
    )
{-# INLINE valueEitherShelleyTxOutL #-}

-- assume Shelley+ type address : payment addr, staking addr (same length as payment), plus 1 word overhead
instance (Era era, HeapWords (CompactForm (Value era))) => HeapWords (ShelleyTxOut era) where
  heapWords :: ShelleyTxOut era -> Int
heapWords (TxOutCompact CompactAddr
_ CompactForm (Value era)
vl) =
    Int
3 forall a. Num a => a -> a -> a
+ forall a. HeapWords a => a -> Int
heapWords ShortByteString
packedADDRHASH forall a. Num a => a -> a -> a
+ forall a. HeapWords a => a -> Int
heapWords CompactForm (Value era)
vl

instance (Era era, Val (Value era)) => Show (ShelleyTxOut era) where
  show :: ShelleyTxOut era -> [Char]
show = forall a. Show a => a -> [Char]
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = (seq :: 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 $bShelleyTxOut :: forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
$mShelleyTxOut :: forall {r} {era}.
(HasCallStack, Era era, Val (Value era)) =>
ShelleyTxOut era -> (Addr -> Value era -> r) -> ((# #) -> r) -> r
ShelleyTxOut addr vl <-
  (viewCompactTxOut -> (addr, vl))
  where
    ShelleyTxOut Addr
addr Value era
vl =
      forall era.
CompactAddr -> CompactForm (Value era) -> ShelleyTxOut era
TxOutCompact
        (Addr -> CompactAddr
compactAddr Addr
addr)
        (forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Illegal value in TxOut: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Value era
vl) forall a b. (a -> b) -> a -> b
$ 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 :: CompactAddr
txOutCompactAddr :: forall era. ShelleyTxOut era -> CompactAddr
txOutCompactAddr, CompactForm (Value era)
txOutCompactValue :: CompactForm (Value era)
txOutCompactValue :: forall era. ShelleyTxOut era -> CompactForm (Value era)
txOutCompactValue} =
  (HasCallStack => CompactAddr -> Addr
decompactAddr CompactAddr
txOutCompactAddr, 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
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR CompactAddr
addr
      forall a. Semigroup a => a -> a -> a
<> 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 =
    forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"ShelleyTxOut" (forall a b. a -> b -> a
const Int
2) forall a b. (a -> b) -> a -> b
$ do
      CompactAddr
cAddr <- forall a s. DecCBOR a => Decoder s a
decCBOR
      forall era.
CompactAddr -> CompactForm (Value era) -> ShelleyTxOut era
TxOutCompact CompactAddr
cAddr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR

instance (Era 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)
_ = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a era.
(KeyValue e a, Era era, Val (Value era)) =>
ShelleyTxOut era -> [a]
toTxOutPair
  toEncoding :: ShelleyTxOut era -> Encoding
toEncoding = Series -> Encoding
pairs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Addr
addr
  , Key
"amount" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Value era
amount
  ]

-- a ShortByteString of the same length as the ADDRHASH
-- used to calculate heapWords
packedADDRHASH :: ShortByteString
packedADDRHASH :: ShortByteString
packedADDRHASH =
  [Word8] -> ShortByteString
pack forall a b. (a -> b) -> a -> b
$
    forall a. Int -> a -> [a]
replicate
      (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word
1 forall a. Num a => a -> a -> a
+ Word
2 forall a. Num a => a -> a -> a
* forall h (proxy :: * -> *). HashAlgorithm h => proxy h -> Word
HS.sizeHash (forall {k} (t :: k). Proxy t
Proxy :: Proxy ADDRHASH)))
      (Word8
1 :: Word8)