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

import PlutusTx.Prelude qualified as PlutusTx

import Data.Aeson.Extras qualified as JSON

import Codec.Serialise (Serialise)
import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), (.:))
import Data.Aeson 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 Plutus.V1.Ledger.Bytes qualified as Bytes
import Plutus.V1.Ledger.Value
import PlutusTx.AssocMap qualified as Map


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)