{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- |
-- Copyright: © 2018-2020 IOHK
-- License: Apache-2.0
--
-- Module for orphans which would be too inconvenient to avoid.

module Cardano.Wallet.Orphans where

import Prelude

import Cardano.Api
    ( TxMetadata (..), TxMetadataValue (..) )
import Cardano.Slotting.Slot
    ( SlotNo (..) )
import Control.DeepSeq
    ( NFData (..) )
import Data.Ord
    ( comparing )
import Fmt
    ( Buildable (..), blockListF, hexF, nameF, unlinesF )
import Ouroboros.Consensus.HardFork.History.Qry
    ( PastHorizonException )
import UnliftIO.Exception
    ( displayException )

import qualified Data.Map as Map

instance Buildable SlotNo where
    build :: SlotNo -> Builder
build (SlotNo Word64
n) = String -> Builder
forall p. Buildable p => p -> Builder
build (Word64 -> String
forall a. Show a => a -> String
show Word64
n)

-- Compare metadatas by their string representation.
-- Defined here so other types which use TxMetadata can have Ord.
instance Ord TxMetadata where
    compare :: TxMetadata -> TxMetadata -> Ordering
compare = (TxMetadata -> String) -> TxMetadata -> TxMetadata -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing TxMetadata -> String
forall a. Show a => a -> String
show

instance Buildable TxMetadata where
    build :: TxMetadata -> Builder
build (TxMetadata Map Word64 TxMetadataValue
m) =
        [Builder] -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
unlinesF (((Word64, TxMetadataValue) -> Builder)
-> [(Word64, TxMetadataValue)] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (Word64, TxMetadataValue) -> Builder
forall p. Buildable p => (p, TxMetadataValue) -> Builder
buildElem (Map Word64 TxMetadataValue -> [(Word64, TxMetadataValue)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Word64 TxMetadataValue
m))
      where
        buildElem :: (p, TxMetadataValue) -> Builder
buildElem (p
n, TxMetadataValue
d) = Builder -> Builder -> Builder
nameF (Builder
"element " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> p -> Builder
forall p. Buildable p => p -> Builder
build p
n) (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ TxMetadataValue -> Builder
buildDatum TxMetadataValue
d
        buildDatum :: TxMetadataValue -> Builder
buildDatum = \case
            TxMetaMap [(TxMetadataValue, TxMetadataValue)]
as -> [Builder] -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
blockListF ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ [[Builder]] -> [Builder]
forall a. Monoid a => [a] -> a
mconcat
                [ [ Builder -> Builder -> Builder
nameF Builder
"key" (TxMetadataValue -> Builder
buildDatum TxMetadataValue
k), Builder -> Builder -> Builder
nameF Builder
"val" (TxMetadataValue -> Builder
buildDatum TxMetadataValue
v) ]
                | (TxMetadataValue
k, TxMetadataValue
v) <- [(TxMetadataValue, TxMetadataValue)]
as ]
            TxMetaList [TxMetadataValue]
xs -> Builder -> Builder -> Builder
nameF Builder
"list" (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ [Builder] -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
blockListF ((TxMetadataValue -> Builder) -> [TxMetadataValue] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map TxMetadataValue -> Builder
buildDatum [TxMetadataValue]
xs)
            TxMetaNumber Integer
i -> Integer -> Builder
forall p. Buildable p => p -> Builder
build Integer
i
            TxMetaBytes ByteString
bs -> ByteString -> Builder
forall a. FormatAsHex a => a -> Builder
hexF ByteString
bs
            TxMetaText Text
s -> String -> Builder
forall p. Buildable p => p -> Builder
build (Text -> String
forall a. Show a => a -> String
show Text
s)

instance NFData TxMetadata where
    rnf :: TxMetadata -> ()
rnf (TxMetadata Map Word64 TxMetadataValue
md) = Map Word64 TxMetadataValue -> ()
forall a. NFData a => a -> ()
rnf Map Word64 TxMetadataValue
md

instance NFData TxMetadataValue where
    rnf :: TxMetadataValue -> ()
rnf (TxMetaMap [(TxMetadataValue, TxMetadataValue)]
x) = [(TxMetadataValue, TxMetadataValue)] -> ()
forall a. NFData a => a -> ()
rnf [(TxMetadataValue, TxMetadataValue)]
x
    rnf (TxMetaList [TxMetadataValue]
x) = [TxMetadataValue] -> ()
forall a. NFData a => a -> ()
rnf [TxMetadataValue]
x
    rnf (TxMetaNumber Integer
x) = Integer -> ()
forall a. NFData a => a -> ()
rnf Integer
x
    rnf (TxMetaBytes ByteString
x) = ByteString -> ()
forall a. NFData a => a -> ()
rnf ByteString
x
    rnf (TxMetaText Text
x) = Text -> ()
forall a. NFData a => a -> ()
rnf Text
x

-- Compare PastHorizonException based on their error messages being the same.
-- Defined here so that other types with use PastHorizonException can have Eq.
instance Eq PastHorizonException where
    PastHorizonException
a == :: PastHorizonException -> PastHorizonException -> Bool
== PastHorizonException
b = PastHorizonException -> String
forall e. Exception e => e -> String
displayException PastHorizonException
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== PastHorizonException -> String
forall e. Exception e => e -> String
displayException PastHorizonException
b