{-# LANGUAGE DeriveAnyClass       #-}
{-# LANGUAGE DeriveGeneric        #-}
{-# LANGUAGE DerivingStrategies   #-}
{-# LANGUAGE DerivingVia          #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE MonoLocalBinds       #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE TemplateHaskell      #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}


module Ledger.Tx.Orphans where

import Codec.Serialise.Class (Serialise (..))
import Data.Aeson (FromJSON (parseJSON), KeyValue ((.=)), ToJSON (toJSON), Value (Object), object, (.:))
import Data.Aeson.Types (parseFail, prependFailure, typeMismatch)
import Data.String (fromString)
import GHC.Generics (Generic)
import Prettyprinter (Pretty (pretty), hang, viaShow, vsep, (<+>))

import Cardano.Api qualified as C
import Cardano.Api.Shelley qualified as C

import Ledger.Address (toPlutusAddress)
import Ledger.Address.Orphans ()
import Ledger.Builtins.Orphans ()
import Ledger.Credential.Orphans ()
import Ledger.Scripts.Orphans ()
import Ledger.Tx.Orphans.V1 ()
import Ledger.Tx.Orphans.V2 ()
import Ledger.Value.Orphans ()

instance ToJSON (C.Tx C.BabbageEra) where
  toJSON :: Tx BabbageEra -> Value
toJSON Tx BabbageEra
tx =
    [Pair] -> Value
object [ Key
"tx" Key -> TextEnvelope -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe TextEnvelopeDescr -> Tx BabbageEra -> TextEnvelope
forall a.
HasTextEnvelope a =>
Maybe TextEnvelopeDescr -> a -> TextEnvelope
C.serialiseToTextEnvelope Maybe TextEnvelopeDescr
forall a. Maybe a
Nothing Tx BabbageEra
tx ]

instance FromJSON (C.Tx C.BabbageEra) where
  parseJSON :: Value -> Parser (Tx BabbageEra)
parseJSON (Object Object
v) = do
   TextEnvelope
envelope <- Object
v Object -> Key -> Parser TextEnvelope
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"tx"
   (TextEnvelopeError -> Parser (Tx BabbageEra))
-> (Tx BabbageEra -> Parser (Tx BabbageEra))
-> Either TextEnvelopeError (Tx BabbageEra)
-> Parser (Tx BabbageEra)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Parser (Tx BabbageEra)
-> TextEnvelopeError -> Parser (Tx BabbageEra)
forall a b. a -> b -> a
const (Parser (Tx BabbageEra)
 -> TextEnvelopeError -> Parser (Tx BabbageEra))
-> Parser (Tx BabbageEra)
-> TextEnvelopeError
-> Parser (Tx BabbageEra)
forall a b. (a -> b) -> a -> b
$ String -> Parser (Tx BabbageEra)
forall a. String -> Parser a
parseFail String
"Failed to parse BabbageEra 'tx' field from CardanoTx")
          Tx BabbageEra -> Parser (Tx BabbageEra)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          (Either TextEnvelopeError (Tx BabbageEra)
 -> Parser (Tx BabbageEra))
-> Either TextEnvelopeError (Tx BabbageEra)
-> Parser (Tx BabbageEra)
forall a b. (a -> b) -> a -> b
$ AsType (Tx BabbageEra)
-> TextEnvelope -> Either TextEnvelopeError (Tx BabbageEra)
forall a.
HasTextEnvelope a =>
AsType a -> TextEnvelope -> Either TextEnvelopeError a
C.deserialiseFromTextEnvelope (AsType BabbageEra -> AsType (Tx BabbageEra)
forall era. AsType era -> AsType (Tx era)
C.AsTx AsType BabbageEra
C.AsBabbageEra) TextEnvelope
envelope
  parseJSON Value
invalid =
    String -> Parser (Tx BabbageEra) -> Parser (Tx BabbageEra)
forall a. String -> Parser a -> Parser a
prependFailure String
"parsing CardanoTx failed, " (String -> Value -> Parser (Tx BabbageEra)
forall a. String -> Value -> Parser a
typeMismatch String
"Object" Value
invalid)

instance Pretty (C.TxOutDatum ctx era) => Pretty (C.TxOut ctx era) where
  pretty :: TxOut ctx era -> Doc ann
pretty (C.TxOut AddressInEra era
addr TxOutValue era
v TxOutDatum ctx era
d ReferenceScript era
rs) =
    Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
hang Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$
      [Doc ann
"-" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Value -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (TxOutValue era -> Value
forall era. TxOutValue era -> Value
C.txOutValueToValue TxOutValue era
v) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"addressed to"
      , Address -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (AddressInEra era -> Address
forall era. AddressInEra era -> Address
toPlutusAddress AddressInEra era
addr)
      ]
      [Doc ann] -> [Doc ann] -> [Doc ann]
forall a. Semigroup a => a -> a -> a
<> case TxOutDatum ctx era
d of
          TxOutDatum ctx era
C.TxOutDatumNone -> []
          TxOutDatum ctx era
_                -> [TxOutDatum ctx era -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty TxOutDatum ctx era
d]
      [Doc ann] -> [Doc ann] -> [Doc ann]
forall a. Semigroup a => a -> a -> a
<> case ReferenceScript era
rs of
          C.ReferenceScript ReferenceTxInsScriptsInlineDatumsSupportedInEra era
_ (C.ScriptInAnyLang ScriptLanguage lang
_ Script lang
s) ->
            [Doc ann
"with reference script hash" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ScriptHash -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow (Script lang -> ScriptHash
forall lang. Script lang -> ScriptHash
C.hashScript Script lang
s)]
          ReferenceScript era
C.ReferenceScriptNone -> []

instance Pretty (C.TxOutDatum C.CtxTx era) where
  pretty :: TxOutDatum CtxTx era -> Doc ann
pretty TxOutDatum CtxTx era
C.TxOutDatumNone          = Doc ann
"no datum"
  pretty (C.TxOutDatumInline ReferenceTxInsScriptsInlineDatumsSupportedInEra era
_ ScriptData
dv) = Doc ann
"with inline datum" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ScriptData -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow ScriptData
dv
  pretty (C.TxOutDatumInTx ScriptDataSupportedInEra era
_ ScriptData
dv)   = Doc ann
"with datum in tx" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ScriptData -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow ScriptData
dv
  pretty (C.TxOutDatumHash ScriptDataSupportedInEra era
_ Hash ScriptData
dh)   = Doc ann
"with datum hash" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall a. IsString a => String -> a
fromString (String -> String
forall a. [a] -> [a]
init (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
tail (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Hash ScriptData -> String
forall a. Show a => a -> String
show Hash ScriptData
dh)

instance Pretty (C.TxOutDatum C.CtxUTxO era) where
  pretty :: TxOutDatum CtxUTxO era -> Doc ann
pretty TxOutDatum CtxUTxO era
C.TxOutDatumNone          = Doc ann
"no datum"
  pretty (C.TxOutDatumInline ReferenceTxInsScriptsInlineDatumsSupportedInEra era
_ ScriptData
dv) = Doc ann
"with inline datum" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ScriptData -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow ScriptData
dv
  pretty (C.TxOutDatumHash ScriptDataSupportedInEra era
_ Hash ScriptData
dh)   = Doc ann
"with datum hash" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall a. IsString a => String -> a
fromString (String -> String
forall a. [a] -> [a]
init (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
tail (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Hash ScriptData -> String
forall a. Show a => a -> String
show Hash ScriptData
dh)

instance Pretty C.TxId where
  pretty :: TxId -> Doc ann
pretty (C.TxId Hash StandardCrypto EraIndependentTxBody
h) = String -> Doc ann
forall a. IsString a => String -> a
fromString (String -> String
forall a. [a] -> [a]
init (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
tail (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Hash Blake2b_256 EraIndependentTxBody -> String
forall a. Show a => a -> String
show Hash Blake2b_256 EraIndependentTxBody
Hash StandardCrypto EraIndependentTxBody
h)
instance Serialise C.TxId where
  encode :: TxId -> Encoding
encode = ByteString -> Encoding
forall a. Serialise a => a -> Encoding
encode (ByteString -> Encoding)
-> (TxId -> ByteString) -> TxId -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxId -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
C.serialiseToRawBytes
  decode :: Decoder s TxId
decode = do
    ByteString
bs <- Decoder s ByteString
forall a s. Serialise a => Decoder s a
decode
    Decoder s TxId
-> (TxId -> Decoder s TxId) -> Maybe TxId -> Decoder s TxId
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Decoder s TxId
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Can get back Tx ID")
      TxId -> Decoder s TxId
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (Maybe TxId -> Decoder s TxId) -> Maybe TxId -> Decoder s TxId
forall a b. (a -> b) -> a -> b
$ AsType TxId -> ByteString -> Maybe TxId
forall a.
SerialiseAsRawBytes a =>
AsType a -> ByteString -> Maybe a
C.deserialiseFromRawBytes AsType TxId
C.AsTxId ByteString
bs

instance Pretty C.TxIn where
  pretty :: TxIn -> Doc ann
pretty (C.TxIn TxId
txId (C.TxIx Word
txIx)) = TxId -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty TxId
txId Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"!" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Word -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow Word
txIx

deriving instance Generic C.TxIn
deriving instance Generic C.TxId
deriving instance Generic C.TxIx
deriving instance Serialise C.TxIn
deriving newtype instance Serialise C.TxIx