{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.CLI.Shelley.Orphans () where

import           Cardano.Prelude

import           Control.SetAlgebra as SetAlgebra
import           Data.Aeson
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Encoding as Aeson
import qualified Data.ByteString.Base16 as Base16
import qualified Data.ByteString.Short as SBS
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text

import           Cardano.Crypto.Hash.Class as Crypto

import           Ouroboros.Consensus.Byron.Ledger.Block (ByronHash (..))
import           Ouroboros.Consensus.HardFork.Combinator (OneEraHash (..))
import           Ouroboros.Consensus.Shelley.Ledger.Block (ShelleyHash (..))
import           Ouroboros.Consensus.Shelley.Eras (ShelleyBasedEra, StandardCrypto, StandardShelley)
import           Ouroboros.Network.Block (BlockNo (..), HeaderHash, Tip (..))

import qualified Cardano.Ledger.Core as Core

import           Shelley.Spec.Ledger.BaseTypes (StrictMaybe)
import           Shelley.Spec.Ledger.BlockChain (HashHeader (..))
import           Shelley.Spec.Ledger.Coin (DeltaCoin (..))
import qualified Shelley.Spec.Ledger.Credential as Ledger
import qualified Shelley.Spec.Ledger.Delegation.Certificates as Ledger
import qualified Shelley.Spec.Ledger.EpochBoundary as Ledger
import qualified Shelley.Spec.Ledger.Keys as Ledger
import qualified Shelley.Spec.Ledger.LedgerState as Ledger
import           Shelley.Spec.Ledger.MetaData (MetaDataHash (..))
import qualified Shelley.Spec.Ledger.PParams as Ledger
import qualified Shelley.Spec.Ledger.Rewards as Ledger
import           Shelley.Spec.Ledger.TxBody (TxId (..), TxIn (..), TxOut (..))
import           Shelley.Spec.Ledger.UTxO (UTxO (..))

instance ShelleyBasedEra era => ToJSONKey (TxIn era) where
  toJSONKey :: ToJSONKeyFunction (TxIn era)
toJSONKey = (TxIn era -> Text)
-> (TxIn era -> Encoding' Text) -> ToJSONKeyFunction (TxIn era)
forall a.
(a -> Text) -> (a -> Encoding' Text) -> ToJSONKeyFunction a
ToJSONKeyText TxIn era -> Text
forall era. ShelleyBasedEra era => TxIn era -> Text
txInToText (Text -> Encoding' Text
forall a. Text -> Encoding' a
Aeson.text (Text -> Encoding' Text)
-> (TxIn era -> Text) -> TxIn era -> Encoding' Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. TxIn era -> Text
forall era. ShelleyBasedEra era => TxIn era -> Text
txInToText)

txInToText :: ShelleyBasedEra era => TxIn era -> Text
txInToText :: TxIn era -> Text
txInToText (TxIn (TxId Hash (Crypto era) EraIndependentTxBody
txidHash) Natural
ix) =
  Hash (Crypto era) EraIndependentTxBody -> Text
forall crypto a. Hash crypto a -> Text
hashToText Hash (Crypto era) EraIndependentTxBody
txidHash
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack String
"#"
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Natural -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Natural
ix)

hashToText :: Hash crypto a -> Text
hashToText :: Hash crypto a -> Text
hashToText = ByteString -> Text
Text.decodeLatin1 (ByteString -> Text)
-> (Hash crypto a -> ByteString) -> Hash crypto a -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Hash crypto a -> ByteString
forall h a. Hash h a -> ByteString
Crypto.hashToBytesAsHex

deriving instance ShelleyBasedEra era => ToJSON (TxIn era)

instance (ShelleyBasedEra era, ToJSON (Core.Value era)) => ToJSON (TxOut era) where
  toJSON :: TxOut era -> Value
toJSON (TxOut Addr era
addr Value era
amount) =
    [Pair] -> Value
Aeson.object
      [ Text
"address" Text -> Addr era -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Addr era
addr
      , Text
"amount" Text -> Value era -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Value era
amount
      ]

instance ToJSON (OneEraHash xs) where
  toJSON :: OneEraHash xs -> Value
toJSON = Text -> Value
forall a. ToJSON a => a -> Value
toJSON
         (Text -> Value)
-> (OneEraHash xs -> Text) -> OneEraHash xs -> Value
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> Text
Text.decodeLatin1
         (ByteString -> Text)
-> (OneEraHash xs -> ByteString) -> OneEraHash xs -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> ByteString
Base16.encode
         (ByteString -> ByteString)
-> (OneEraHash xs -> ByteString) -> OneEraHash xs -> ByteString
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ShortByteString -> ByteString
SBS.fromShort
         (ShortByteString -> ByteString)
-> (OneEraHash xs -> ShortByteString)
-> OneEraHash xs
-> ByteString
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. OneEraHash xs -> ShortByteString
forall k (xs :: [k]). OneEraHash xs -> ShortByteString
getOneEraHash

deriving newtype instance ToJSON ByronHash

-- This instance is temporarily duplicated in cardano-config

instance ToJSON (HeaderHash blk) => ToJSON (Tip blk) where
  toJSON :: Tip blk -> Value
toJSON Tip blk
TipGenesis = [Pair] -> Value
object [ Text
"genesis" Text -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Bool
True ]
  toJSON (Tip SlotNo
slotNo HeaderHash blk
headerHash BlockNo
blockNo) =
    [Pair] -> Value
object
      [ Text
"slotNo"     Text -> SlotNo -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SlotNo
slotNo
      , Text
"headerHash" Text -> HeaderHash blk -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= HeaderHash blk
headerHash
      , Text
"blockNo"    Text -> BlockNo -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= BlockNo
blockNo
      ]

-- This instance is temporarily duplicated in cardano-config
deriving newtype instance ToJSON BlockNo

--
-- Simple newtype wrappers JSON conversion
--

deriving newtype instance ToJSON (TxId era)

deriving newtype instance (ShelleyBasedEra era, ToJSON (Core.Value era)) => ToJSON (UTxO era)

deriving newtype instance ToJSON (ShelleyHash era)
deriving newtype instance ToJSON (HashHeader era)

deriving newtype instance ToJSON (MetaDataHash era)
deriving newtype instance ToJSON Ledger.LogWeight
deriving newtype instance ToJSON Ledger.Likelihood
deriving newtype instance ToJSON (Ledger.Stake StandardShelley)
deriving newtype instance ToJSON (Ledger.PoolDistr StandardCrypto)
deriving newtype instance ToJSON DeltaCoin

deriving anyclass instance ToJSON (Ledger.GenDelegs StandardCrypto)
deriving anyclass instance ToJSON (Ledger.IndividualPoolStake StandardCrypto)
deriving anyclass instance ToJSON (Ledger.ProposedPPUpdates StandardShelley)
deriving anyclass instance ToJSON (Ledger.PPUPState StandardShelley)
deriving anyclass instance ToJSON (Ledger.BlocksMade StandardShelley)

deriving instance ToJSON Ledger.Ptr
deriving instance ToJSON Ledger.AccountState

deriving instance ToJSON (Ledger.DPState StandardShelley)
deriving instance ToJSON (Ledger.DState StandardShelley)
deriving instance ToJSON (Ledger.FutureGenDeleg StandardCrypto)
deriving instance ToJSON (Ledger.InstantaneousRewards StandardShelley)
deriving instance ToJSON (Ledger.SnapShot StandardShelley)
deriving instance ToJSON (Ledger.SnapShots StandardShelley)
deriving instance ToJSON (Ledger.NonMyopic StandardShelley)
deriving instance ToJSON (Ledger.LedgerState StandardShelley)
deriving instance ToJSON (Ledger.EpochState StandardShelley)
deriving instance ToJSON (Ledger.RewardUpdate StandardShelley)
deriving instance ToJSON (Ledger.NewEpochState StandardShelley)
deriving instance ToJSON (Ledger.PParams' StrictMaybe StandardShelley)
deriving instance ToJSON (Ledger.PState StandardShelley)
deriving instance ToJSON (Ledger.StakeReference StandardShelley)
deriving instance ToJSON (Ledger.UTxOState StandardShelley)

deriving instance ToJSONKey Ledger.Ptr
deriving instance ToJSONKey (Ledger.FutureGenDeleg StandardCrypto)

instance (ToJSONKey k, ToJSON v) => ToJSON (SetAlgebra.BiMap v k v) where
  toJSON :: BiMap v k v -> Value
toJSON = Map k v -> Value
forall a. ToJSON a => a -> Value
toJSON (Map k v -> Value)
-> (BiMap v k v -> Map k v) -> BiMap v k v -> Value
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. BiMap v k v -> Map k v
forall v k. BiMap v k v -> Map k v
SetAlgebra.forwards -- to normal Map