{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE DerivingVia       #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Ledger.Value.Orphans where

import Cardano.Api qualified as C
import Codec.Serialise (Serialise (decode))
import Codec.Serialise.Class (Serialise (encode))
import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), (.:))
import Data.Aeson qualified as JSON
import Data.Aeson.Extras qualified as JSON
import Data.ByteString qualified as BS
import Data.Hashable (Hashable)
import Data.String (IsString (fromString))
import Data.Text qualified as Text
import Data.Text.Encoding qualified as E
import GHC.Generics (Generic)
import Plutus.V1.Ledger.Bytes qualified as Bytes
import Plutus.V1.Ledger.Value
import PlutusTx.AssocMap qualified as Map
import PlutusTx.Prelude qualified as PlutusTx
import Prettyprinter (Pretty (pretty), (<+>))
import Prettyprinter.Extras (PrettyShow (PrettyShow))
import Prettyprinter.Util (reflow)


instance ToJSON CurrencySymbol where
  toJSON :: CurrencySymbol -> Value
toJSON CurrencySymbol
c =
    [Pair] -> Value
JSON.object
      [ ( Key
"unCurrencySymbol"
        , Text -> Value
JSON.String (Text -> Value)
-> (CurrencySymbol -> Text) -> CurrencySymbol -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          ByteString -> Text
JSON.encodeByteString (ByteString -> Text)
-> (CurrencySymbol -> ByteString) -> CurrencySymbol -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          BuiltinByteString -> ByteString
forall arep a. FromBuiltin arep a => arep -> a
PlutusTx.fromBuiltin (BuiltinByteString -> ByteString)
-> (CurrencySymbol -> BuiltinByteString)
-> CurrencySymbol
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          CurrencySymbol -> BuiltinByteString
unCurrencySymbol (CurrencySymbol -> Value) -> CurrencySymbol -> Value
forall a b. (a -> b) -> a -> b
$
          CurrencySymbol
c)
      ]

instance FromJSON CurrencySymbol where
  parseJSON :: Value -> Parser CurrencySymbol
parseJSON =
    String
-> (Object -> Parser CurrencySymbol)
-> Value
-> Parser CurrencySymbol
forall a. String -> (Object -> Parser a) -> Value -> Parser a
JSON.withObject String
"CurrencySymbol" ((Object -> Parser CurrencySymbol)
 -> Value -> Parser CurrencySymbol)
-> (Object -> Parser CurrencySymbol)
-> Value
-> Parser CurrencySymbol
forall a b. (a -> b) -> a -> b
$ \Object
object -> do
      Value
raw <- Object
object Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"unCurrencySymbol"
      ByteString
bytes <- Value -> Parser ByteString
JSON.decodeByteString Value
raw
      CurrencySymbol -> Parser CurrencySymbol
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CurrencySymbol -> Parser CurrencySymbol)
-> CurrencySymbol -> Parser CurrencySymbol
forall a b. (a -> b) -> a -> b
$ BuiltinByteString -> CurrencySymbol
CurrencySymbol (BuiltinByteString -> CurrencySymbol)
-> BuiltinByteString -> CurrencySymbol
forall a b. (a -> b) -> a -> b
$ ByteString -> BuiltinByteString
forall a arep. ToBuiltin a arep => a -> arep
PlutusTx.toBuiltin ByteString
bytes

deriving anyclass instance Hashable CurrencySymbol
deriving newtype instance Serialise CurrencySymbol

deriving anyclass instance Hashable TokenName
deriving newtype instance Serialise TokenName

{- note [Roundtripping token names]
How to properly roundtrip a token name that is not valid UTF-8 through PureScript
without a big rewrite of the API?
We prefix it with a zero byte so we can recognize it when we get a bytestring value back,
and we serialize it base16 encoded, with 0x in front so it will look as a hex string.
(Browsers don't render the zero byte.)
-}

instance ToJSON TokenName where
    toJSON :: TokenName -> Value
toJSON = [Pair] -> Value
JSON.object ([Pair] -> Value) -> (TokenName -> [Pair]) -> TokenName -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pair -> [Pair]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pair -> [Pair]) -> (TokenName -> Pair) -> TokenName -> [Pair]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) Key
"unTokenName" (Value -> Pair) -> (TokenName -> Value) -> TokenName -> Pair
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON (Text -> Value) -> (TokenName -> Text) -> TokenName -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        (ByteString -> Text) -> (Text -> Text) -> TokenName -> Text
forall r. (ByteString -> r) -> (Text -> r) -> TokenName -> r
fromTokenName
            (\ByteString
bs -> Char -> Text -> Text
Text.cons Char
'\NUL' (ByteString -> Text
asBase16 ByteString
bs))
            (\Text
t -> case Int -> Text -> Text
Text.take Int
1 Text
t of Text
"\NUL" -> [Text] -> Text
Text.concat [Text
"\NUL\NUL", Text
t]; Text
_ -> Text
t)
      where
        -- copied from 'Plutus.V1.Ledger.Value' because not exported
        asBase16 :: BS.ByteString -> Text.Text
        asBase16 :: ByteString -> Text
asBase16 ByteString
bs = [Text] -> Text
Text.concat [Text
"0x", ByteString -> Text
Bytes.encodeByteString ByteString
bs]

        fromTokenName :: (BS.ByteString -> r) -> (Text.Text -> r) -> TokenName -> r
        fromTokenName :: (ByteString -> r) -> (Text -> r) -> TokenName -> r
fromTokenName ByteString -> r
handleBytestring Text -> r
handleText (TokenName BuiltinByteString
bs) = (UnicodeException -> r)
-> (Text -> r) -> Either UnicodeException Text -> r
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\UnicodeException
_ -> ByteString -> r
handleBytestring (ByteString -> r) -> ByteString -> r
forall a b. (a -> b) -> a -> b
$ BuiltinByteString -> ByteString
forall arep a. FromBuiltin arep a => arep -> a
PlutusTx.fromBuiltin BuiltinByteString
bs) Text -> r
handleText (Either UnicodeException Text -> r)
-> Either UnicodeException Text -> r
forall a b. (a -> b) -> a -> b
$ ByteString -> Either UnicodeException Text
E.decodeUtf8' (BuiltinByteString -> ByteString
forall arep a. FromBuiltin arep a => arep -> a
PlutusTx.fromBuiltin BuiltinByteString
bs)

instance FromJSON TokenName where
    parseJSON :: Value -> Parser TokenName
parseJSON =
        String -> (Object -> Parser TokenName) -> Value -> Parser TokenName
forall a. String -> (Object -> Parser a) -> Value -> Parser a
JSON.withObject String
"TokenName" ((Object -> Parser TokenName) -> Value -> Parser TokenName)
-> (Object -> Parser TokenName) -> Value -> Parser TokenName
forall a b. (a -> b) -> a -> b
$ \Object
object -> do
        Text
raw <- Object
object Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"unTokenName"
        Text -> Parser TokenName
forall (m :: * -> *). MonadFail m => Text -> m TokenName
fromJSONText Text
raw
        where
            fromText :: Text -> TokenName
fromText = ByteString -> TokenName
tokenName (ByteString -> TokenName)
-> (Text -> ByteString) -> Text -> TokenName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
E.encodeUtf8 (Text -> ByteString) -> (Text -> Text) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Text) -> (Text -> String) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. IsString a => String -> a
fromString (String -> String) -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack
            fromJSONText :: Text -> m TokenName
fromJSONText Text
t = case Int -> Text -> Text
Text.take Int
3 Text
t of
                Text
"\NUL0x"       -> (String -> m TokenName)
-> (ByteString -> m TokenName)
-> Either String ByteString
-> m TokenName
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> m TokenName
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (TokenName -> m TokenName
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TokenName -> m TokenName)
-> (ByteString -> TokenName) -> ByteString -> m TokenName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> TokenName
tokenName) (Either String ByteString -> m TokenName)
-> (Text -> Either String ByteString) -> Text -> m TokenName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either String ByteString
JSON.tryDecode (Text -> Either String ByteString)
-> (Text -> Text) -> Text -> Either String ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
Text.drop Int
3 (Text -> m TokenName) -> Text -> m TokenName
forall a b. (a -> b) -> a -> b
$ Text
t
                Text
"\NUL\NUL\NUL" -> TokenName -> m TokenName
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TokenName -> m TokenName)
-> (Text -> TokenName) -> Text -> m TokenName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> TokenName
fromText (Text -> TokenName) -> (Text -> Text) -> Text -> TokenName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
Text.drop Int
2 (Text -> m TokenName) -> Text -> m TokenName
forall a b. (a -> b) -> a -> b
$ Text
t
                Text
_              -> TokenName -> m TokenName
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TokenName -> m TokenName)
-> (Text -> TokenName) -> Text -> m TokenName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> TokenName
fromText (Text -> m TokenName) -> Text -> m TokenName
forall a b. (a -> b) -> a -> b
$ Text
t

deriving anyclass instance ToJSON AssetClass
deriving anyclass instance FromJSON AssetClass
deriving anyclass instance Hashable AssetClass
deriving newtype instance Serialise AssetClass

deriving anyclass instance ToJSON Value
deriving anyclass instance FromJSON Value
deriving anyclass instance Hashable Value
deriving newtype instance Serialise Value

-- Orphan instances for 'PlutusTx.Map' to make this work
instance (ToJSON v, ToJSON k) => ToJSON (Map.Map k v) where
    toJSON :: Map k v -> Value
toJSON = [(k, v)] -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON ([(k, v)] -> Value) -> (Map k v -> [(k, v)]) -> Map k v -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map k v -> [(k, v)]
forall k v. Map k v -> [(k, v)]
Map.toList

instance (FromJSON v, FromJSON k) => FromJSON (Map.Map k v) where
    parseJSON :: Value -> Parser (Map k v)
parseJSON Value
v = [(k, v)] -> Map k v
forall k v. [(k, v)] -> Map k v
Map.fromList ([(k, v)] -> Map k v) -> Parser [(k, v)] -> Parser (Map k v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser [(k, v)]
forall a. FromJSON a => Value -> Parser a
JSON.parseJSON Value
v

deriving anyclass instance (Hashable k, Hashable v) => Hashable (Map.Map k v)
deriving anyclass instance (Serialise k, Serialise v) => Serialise (Map.Map k v)


instance Pretty C.Lovelace where
  pretty :: Lovelace -> Doc ann
pretty (C.Lovelace Integer
l) = Integer -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Integer
l Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"lovelace"
deriving newtype instance Serialise C.Lovelace

deriving newtype instance Serialise C.Quantity

instance Pretty C.Value where
  pretty :: Value -> Doc ann
pretty = Text -> Doc ann
forall ann. Text -> Doc ann
reflow (Text -> Doc ann) -> (Value -> Text) -> Value -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Text
C.renderValuePretty
instance Serialise C.Value where
  decode :: Decoder s Value
decode = [(AssetId, Quantity)] -> Value
C.valueFromList ([(AssetId, Quantity)] -> Value)
-> Decoder s [(AssetId, Quantity)] -> Decoder s Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s [(AssetId, Quantity)]
forall a s. Serialise a => Decoder s a
decode
  encode :: Value -> Encoding
encode = [(AssetId, Quantity)] -> Encoding
forall a. Serialise a => a -> Encoding
encode ([(AssetId, Quantity)] -> Encoding)
-> (Value -> [(AssetId, Quantity)]) -> Value -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> [(AssetId, Quantity)]
C.valueToList

deriving stock instance Generic C.AssetId
deriving anyclass instance FromJSON C.AssetId
deriving anyclass instance ToJSON C.AssetId
deriving anyclass instance Serialise C.AssetId
deriving via (PrettyShow C.AssetId) instance Pretty C.AssetId

instance Serialise C.PolicyId where
  encode :: PolicyId -> Encoding
encode = ByteString -> Encoding
forall a. Serialise a => a -> Encoding
encode (ByteString -> Encoding)
-> (PolicyId -> ByteString) -> PolicyId -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PolicyId -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
C.serialiseToRawBytes
  decode :: Decoder s PolicyId
decode = do
    ByteString
bs <- Decoder s ByteString
forall a s. Serialise a => Decoder s a
decode
    Decoder s PolicyId
-> (PolicyId -> Decoder s PolicyId)
-> Maybe PolicyId
-> Decoder s PolicyId
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Decoder s PolicyId
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Can get back policy ID")
      PolicyId -> Decoder s PolicyId
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (Maybe PolicyId -> Decoder s PolicyId)
-> Maybe PolicyId -> Decoder s PolicyId
forall a b. (a -> b) -> a -> b
$ AsType PolicyId -> ByteString -> Maybe PolicyId
forall a.
SerialiseAsRawBytes a =>
AsType a -> ByteString -> Maybe a
C.deserialiseFromRawBytes AsType PolicyId
C.AsPolicyId ByteString
bs

instance Serialise C.AssetName where
  encode :: AssetName -> Encoding
encode = ByteString -> Encoding
forall a. Serialise a => a -> Encoding
encode (ByteString -> Encoding)
-> (AssetName -> ByteString) -> AssetName -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AssetName -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
C.serialiseToRawBytes
  decode :: Decoder s AssetName
decode = do
    ByteString
bs <- Decoder s ByteString
forall a s. Serialise a => Decoder s a
decode
    Decoder s AssetName
-> (AssetName -> Decoder s AssetName)
-> Maybe AssetName
-> Decoder s AssetName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Decoder s AssetName
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Can get back asset name")
      AssetName -> Decoder s AssetName
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (Maybe AssetName -> Decoder s AssetName)
-> Maybe AssetName -> Decoder s AssetName
forall a b. (a -> b) -> a -> b
$ AsType AssetName -> ByteString -> Maybe AssetName
forall a.
SerialiseAsRawBytes a =>
AsType a -> ByteString -> Maybe a
C.deserialiseFromRawBytes AsType AssetName
C.AsAssetName ByteString
bs