{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.CLI.Orphan
  (
  )
where

import Cardano.Api
import Cardano.Api.Byron qualified as Byron
import Cardano.Api.Experimental as Exp
import Cardano.Api.Ledger qualified as L

import Cardano.CLI.Type.Error.ScriptDecodeError
import Cardano.Ledger.Conway.Governance qualified as L
import Cardano.Ledger.Conway.State qualified as L

import Control.Exception
import Data.Aeson
import Data.List qualified as List
import Data.Text (Text)
import Data.Typeable
import Data.Word

instance ToJSON L.DefaultVote where
  toJSON :: DefaultVote -> Value
toJSON DefaultVote
defaultVote =
    case DefaultVote
defaultVote of
      DefaultVote
L.DefaultNo -> Text -> Value
String Text
"DefaultNo"
      DefaultVote
L.DefaultAbstain -> Text -> Value
String Text
"DefaultAbstain"
      DefaultVote
L.DefaultNoConfidence -> Text -> Value
String Text
"DefaultNoConfidence"

instance Error [Bech32DecodeError] where
  prettyError :: forall ann. [Bech32DecodeError] -> Doc ann
prettyError [Bech32DecodeError]
errs = [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
$ (Bech32DecodeError -> Doc ann) -> [Bech32DecodeError] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map Bech32DecodeError -> Doc ann
forall e ann. Error e => e -> Doc ann
forall ann. Bech32DecodeError -> Doc ann
prettyError [Bech32DecodeError]
errs

instance Error [RawBytesHexError] where
  prettyError :: forall ann. [RawBytesHexError] -> Doc ann
prettyError [RawBytesHexError]
errs = [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
$ (RawBytesHexError -> Doc ann) -> [RawBytesHexError] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map RawBytesHexError -> Doc ann
forall e ann. Error e => e -> Doc ann
forall ann. RawBytesHexError -> Doc ann
prettyError [RawBytesHexError]
errs

-- TODO upstream this orphaned instance to the ledger
instance
  (L.EraTxOut ledgerera, L.EraGov ledgerera, L.EraCertState ledgerera, L.EraStake ledgerera)
  => ToJSON (L.NewEpochState ledgerera)
  where
  toJSON :: NewEpochState ledgerera -> Value
toJSON (L.NewEpochState EpochNo
nesEL BlocksMade
nesBprev BlocksMade
nesBCur EpochState ledgerera
nesEs StrictMaybe PulsingRewUpdate
nesRu PoolDistr
nesPd StashedAVVMAddresses ledgerera
_stashedAvvm) =
    [Pair] -> Value
object
      [ Key
"currentEpoch" Key -> EpochNo -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= EpochNo
nesEL
      , Key
"priorBlocks" Key -> BlocksMade -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= BlocksMade
nesBprev
      , Key
"currentEpochBlocks" Key -> BlocksMade -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= BlocksMade
nesBCur
      , Key
"currentEpochState" Key -> EpochState ledgerera -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= EpochState ledgerera
nesEs
      , Key
"rewardUpdate" Key -> StrictMaybe PulsingRewUpdate -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= StrictMaybe PulsingRewUpdate
nesRu
      , Key
"currentStakeDistribution" Key -> PoolDistr -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= PoolDistr
nesPd
      ]

instance ToJSON HashableScriptData where
  toJSON :: HashableScriptData -> Value
toJSON HashableScriptData
hsd =
    [Pair] -> Value
object
      [ Key
"hash" Key -> Hash ScriptData -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HashableScriptData -> Hash ScriptData
hashScriptDataBytes HashableScriptData
hsd
      , Key
"json" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HashableScriptData -> Value
scriptDataToJsonDetailedSchema HashableScriptData
hsd
      ]

instance Error Byron.GenesisDataError where
  prettyError :: forall ann. GenesisDataError -> Doc ann
prettyError = GenesisDataError -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow

-- TODO: Convert readVerificationKeySource to use CIO. We can then
-- remove this instance
instance
  Error
    ( Either
        ( FileError
            ScriptDecodeError
        )
        (FileError InputDecodeError)
    )
  where
  prettyError :: forall ann.
Either (FileError ScriptDecodeError) (FileError InputDecodeError)
-> Doc ann
prettyError = \case
    Left FileError ScriptDecodeError
e -> FileError ScriptDecodeError -> Doc ann
forall e ann. Error e => e -> Doc ann
forall ann. FileError ScriptDecodeError -> Doc ann
prettyError FileError ScriptDecodeError
e
    Right FileError InputDecodeError
e -> FileError InputDecodeError -> Doc ann
forall e ann. Error e => e -> Doc ann
forall ann. FileError InputDecodeError -> Doc ann
prettyError FileError InputDecodeError
e

instance Error String where
  prettyError :: forall ann. String -> Doc ann
prettyError = String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty

instance Error Text where
  prettyError :: forall ann. Text -> Doc ann
prettyError = Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Text -> Doc ann
pretty

instance (Typeable e, Show e, Error e) => Exception (FileError e) where
  displayException :: FileError e -> String
displayException = FileError e -> String
forall a. Error a => a -> String
displayError

instance Error [(Word64, TxMetadataRangeError)] where
  prettyError :: forall ann. [(Word64, TxMetadataRangeError)] -> Doc ann
prettyError [(Word64, TxMetadataRangeError)]
errs =
    [Doc ann] -> Doc ann
forall a. Monoid a => [a] -> a
mconcat
      [ Doc ann
"Error validating transaction metadata at: " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"\n"
      , [Doc ann] -> Doc ann
forall a. Monoid a => [a] -> a
mconcat ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$
          Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
List.intersperse
            Doc ann
"\n"
            [ Doc ann
"key " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Word64 -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow Word64
k 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
<> TxMetadataRangeError -> Doc ann
forall e ann. Error e => e -> Doc ann
forall ann. TxMetadataRangeError -> Doc ann
prettyError TxMetadataRangeError
valErr
            | (Word64
k, TxMetadataRangeError
valErr) <- [(Word64, TxMetadataRangeError)]
errs
            ]
      ]

-- Move to cardano-api
instance Convert Era AllegraEraOnwards where
  convert :: forall era. Era era -> AllegraEraOnwards era
convert Era era
Exp.ConwayEra = AllegraEraOnwards era
AllegraEraOnwards ConwayEra
AllegraEraOnwardsConway
  convert Era era
Exp.DijkstraEra = AllegraEraOnwards era
AllegraEraOnwards DijkstraEra
AllegraEraOnwardsDijkstra