{-# LANGUAGE OverloadedLists #-}

module Cardano.Api.ValueParser
  ( parseValue
  , parseTxOutMultiAssetValue
  , parseMintingMultiAssetValue
  , parseUTxOValue
  , parseAssetName
  , parsePolicyId
  , ParserValueRole (..)
  )
where

import           Cardano.Api.Error (displayError)
import           Cardano.Api.SerialiseRaw
import           Cardano.Api.Utils (failEitherWith)
import           Cardano.Api.Value

import           Control.Applicative (many, some, (<|>))
import           Control.Monad (unless, when)
import qualified Data.ByteString.Char8 as BSC
import qualified Data.Char as Char
import           Data.Functor (void, ($>))
import           Data.List as List (foldl')
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import           Data.Word (Word64)
import           Text.Parsec as Parsec (notFollowedBy, try, (<?>))
import           Text.Parsec.Char (alphaNum, char, digit, hexDigit, space, spaces, string)
import           Text.Parsec.Expr (Assoc (..), Operator (..), buildExpressionParser)
import           Text.Parsec.String (Parser)
import           Text.ParserCombinators.Parsec.Combinator (many1)

-- | The role for which a 'Value' is being parsed.
data ParserValueRole
  = -- | The value is used as a UTxO or transaction output.
    RoleUTxO
  | -- | The value is used as a minting policy.
    RoleMint
  deriving (ParserValueRole -> ParserValueRole -> Bool
(ParserValueRole -> ParserValueRole -> Bool)
-> (ParserValueRole -> ParserValueRole -> Bool)
-> Eq ParserValueRole
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ParserValueRole -> ParserValueRole -> Bool
== :: ParserValueRole -> ParserValueRole -> Bool
$c/= :: ParserValueRole -> ParserValueRole -> Bool
/= :: ParserValueRole -> ParserValueRole -> Bool
Eq, Int -> ParserValueRole -> ShowS
[ParserValueRole] -> ShowS
ParserValueRole -> String
(Int -> ParserValueRole -> ShowS)
-> (ParserValueRole -> String)
-> ([ParserValueRole] -> ShowS)
-> Show ParserValueRole
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ParserValueRole -> ShowS
showsPrec :: Int -> ParserValueRole -> ShowS
$cshow :: ParserValueRole -> String
show :: ParserValueRole -> String
$cshowList :: [ParserValueRole] -> ShowS
showList :: [ParserValueRole] -> ShowS
Show, Int -> ParserValueRole
ParserValueRole -> Int
ParserValueRole -> [ParserValueRole]
ParserValueRole -> ParserValueRole
ParserValueRole -> ParserValueRole -> [ParserValueRole]
ParserValueRole
-> ParserValueRole -> ParserValueRole -> [ParserValueRole]
(ParserValueRole -> ParserValueRole)
-> (ParserValueRole -> ParserValueRole)
-> (Int -> ParserValueRole)
-> (ParserValueRole -> Int)
-> (ParserValueRole -> [ParserValueRole])
-> (ParserValueRole -> ParserValueRole -> [ParserValueRole])
-> (ParserValueRole -> ParserValueRole -> [ParserValueRole])
-> (ParserValueRole
    -> ParserValueRole -> ParserValueRole -> [ParserValueRole])
-> Enum ParserValueRole
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: ParserValueRole -> ParserValueRole
succ :: ParserValueRole -> ParserValueRole
$cpred :: ParserValueRole -> ParserValueRole
pred :: ParserValueRole -> ParserValueRole
$ctoEnum :: Int -> ParserValueRole
toEnum :: Int -> ParserValueRole
$cfromEnum :: ParserValueRole -> Int
fromEnum :: ParserValueRole -> Int
$cenumFrom :: ParserValueRole -> [ParserValueRole]
enumFrom :: ParserValueRole -> [ParserValueRole]
$cenumFromThen :: ParserValueRole -> ParserValueRole -> [ParserValueRole]
enumFromThen :: ParserValueRole -> ParserValueRole -> [ParserValueRole]
$cenumFromTo :: ParserValueRole -> ParserValueRole -> [ParserValueRole]
enumFromTo :: ParserValueRole -> ParserValueRole -> [ParserValueRole]
$cenumFromThenTo :: ParserValueRole
-> ParserValueRole -> ParserValueRole -> [ParserValueRole]
enumFromThenTo :: ParserValueRole
-> ParserValueRole -> ParserValueRole -> [ParserValueRole]
Enum, ParserValueRole
ParserValueRole -> ParserValueRole -> Bounded ParserValueRole
forall a. a -> a -> Bounded a
$cminBound :: ParserValueRole
minBound :: ParserValueRole
$cmaxBound :: ParserValueRole
maxBound :: ParserValueRole
Bounded)

-- | Parse a 'Value' from its string representation. The @role@ argument for which purpose
-- the value is being parsed. This is used to enforce additional constraints on the value.
-- Why do we parse a general value and check for additional constraints you may ask?
-- Because we can't rule out the negation operator
-- for transaction outputs: some users have negative values in additions, with the addition's total
-- summing up to a positive value. So forbidding negations altogether is too restrictive.
parseValue :: ParserValueRole -> Parser Value
parseValue :: ParserValueRole -> Parser Value
parseValue ParserValueRole
role = do
  ValueExpr
valueExpr <- Parser ValueExpr
parseValueExpr
  let value :: Value
value = ValueExpr -> Value
evalValueExpr ValueExpr
valueExpr
  case ParserValueRole
role of
    ParserValueRole
RoleUTxO -> do
      Bool
-> ParsecT String () Identity () -> ParsecT String () Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Value -> Bool
allPositive Value
value) (ParsecT String () Identity () -> ParsecT String () Identity ())
-> ParsecT String () Identity () -> ParsecT String () Identity ()
forall a b. (a -> b) -> a -> b
$
        String -> ParsecT String () Identity ()
forall a. String -> ParsecT String () Identity a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ParsecT String () Identity ())
-> String -> ParsecT String () Identity ()
forall a b. (a -> b) -> a -> b
$
          String
"Value must be positive in UTxO (or transaction output): " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. Show a => a -> String
show Value
value
      Value -> Parser Value
forall a. a -> ParsecT String () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
value
    ParserValueRole
RoleMint -> do
      let (Coin Integer
lovelace) = Value -> Coin
selectLovelace Value
value
      Bool
-> ParsecT String () Identity () -> ParsecT String () Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
lovelace Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0) (ParsecT String () Identity () -> ParsecT String () Identity ())
-> ParsecT String () Identity () -> ParsecT String () Identity ()
forall a b. (a -> b) -> a -> b
$
        String -> ParsecT String () Identity ()
forall a. String -> ParsecT String () Identity a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ParsecT String () Identity ())
-> String -> ParsecT String () Identity ()
forall a b. (a -> b) -> a -> b
$
          String
"Lovelace must be zero in minting value: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. Show a => a -> String
show Value
value
      Value -> Parser Value
forall a. a -> ParsecT String () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
value

parseTxOutMultiAssetValue :: Parser Value
parseTxOutMultiAssetValue :: Parser Value
parseTxOutMultiAssetValue = ParserValueRole -> Parser Value
parseValue ParserValueRole
RoleUTxO

parseMintingMultiAssetValue :: Parser Value
parseMintingMultiAssetValue :: Parser Value
parseMintingMultiAssetValue = ParserValueRole -> Parser Value
parseValue ParserValueRole
RoleMint

parseUTxOValue :: Parser Value
parseUTxOValue :: Parser Value
parseUTxOValue = ParserValueRole -> Parser Value
parseValue ParserValueRole
RoleUTxO

-- | Evaluate a 'ValueExpr' and construct a 'Value'.
evalValueExpr :: ValueExpr -> Value
evalValueExpr :: ValueExpr -> Value
evalValueExpr ValueExpr
vExpr =
  case ValueExpr
vExpr of
    ValueExprAdd ValueExpr
x ValueExpr
y -> ValueExpr -> Value
evalValueExpr ValueExpr
x Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> ValueExpr -> Value
evalValueExpr ValueExpr
y
    ValueExprNegate ValueExpr
x -> Value -> Value
negateValue (ValueExpr -> Value
evalValueExpr ValueExpr
x)
    ValueExprLovelace Quantity
quant -> [(AssetId
AdaAssetId, Quantity
quant)]
    ValueExprMultiAsset PolicyId
polId AssetName
aName Quantity
quant -> [(PolicyId -> AssetName -> AssetId
AssetId PolicyId
polId AssetName
aName, Quantity
quant)]

------------------------------------------------------------------------------
-- Expression parser
------------------------------------------------------------------------------

-- | Intermediate representation of a parsed multi-asset value.
data ValueExpr
  = ValueExprAdd !ValueExpr !ValueExpr
  | ValueExprNegate !ValueExpr
  | ValueExprLovelace !Quantity
  | ValueExprMultiAsset !PolicyId !AssetName !Quantity
  deriving (ValueExpr -> ValueExpr -> Bool
(ValueExpr -> ValueExpr -> Bool)
-> (ValueExpr -> ValueExpr -> Bool) -> Eq ValueExpr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ValueExpr -> ValueExpr -> Bool
== :: ValueExpr -> ValueExpr -> Bool
$c/= :: ValueExpr -> ValueExpr -> Bool
/= :: ValueExpr -> ValueExpr -> Bool
Eq, Eq ValueExpr
Eq ValueExpr =>
(ValueExpr -> ValueExpr -> Ordering)
-> (ValueExpr -> ValueExpr -> Bool)
-> (ValueExpr -> ValueExpr -> Bool)
-> (ValueExpr -> ValueExpr -> Bool)
-> (ValueExpr -> ValueExpr -> Bool)
-> (ValueExpr -> ValueExpr -> ValueExpr)
-> (ValueExpr -> ValueExpr -> ValueExpr)
-> Ord ValueExpr
ValueExpr -> ValueExpr -> Bool
ValueExpr -> ValueExpr -> Ordering
ValueExpr -> ValueExpr -> ValueExpr
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ValueExpr -> ValueExpr -> Ordering
compare :: ValueExpr -> ValueExpr -> Ordering
$c< :: ValueExpr -> ValueExpr -> Bool
< :: ValueExpr -> ValueExpr -> Bool
$c<= :: ValueExpr -> ValueExpr -> Bool
<= :: ValueExpr -> ValueExpr -> Bool
$c> :: ValueExpr -> ValueExpr -> Bool
> :: ValueExpr -> ValueExpr -> Bool
$c>= :: ValueExpr -> ValueExpr -> Bool
>= :: ValueExpr -> ValueExpr -> Bool
$cmax :: ValueExpr -> ValueExpr -> ValueExpr
max :: ValueExpr -> ValueExpr -> ValueExpr
$cmin :: ValueExpr -> ValueExpr -> ValueExpr
min :: ValueExpr -> ValueExpr -> ValueExpr
Ord, Int -> ValueExpr -> ShowS
[ValueExpr] -> ShowS
ValueExpr -> String
(Int -> ValueExpr -> ShowS)
-> (ValueExpr -> String)
-> ([ValueExpr] -> ShowS)
-> Show ValueExpr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ValueExpr -> ShowS
showsPrec :: Int -> ValueExpr -> ShowS
$cshow :: ValueExpr -> String
show :: ValueExpr -> String
$cshowList :: [ValueExpr] -> ShowS
showList :: [ValueExpr] -> ShowS
Show)

parseValueExpr :: Parser ValueExpr
parseValueExpr :: Parser ValueExpr
parseValueExpr =
  OperatorTable String () Identity ValueExpr
-> Parser ValueExpr -> Parser ValueExpr
forall s (m :: * -> *) t u a.
Stream s m t =>
OperatorTable s u m a -> ParsecT s u m a -> ParsecT s u m a
buildExpressionParser OperatorTable String () Identity ValueExpr
operatorTable Parser ValueExpr
parseValueExprTerm
    Parser ValueExpr -> String -> Parser ValueExpr
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"multi-asset value expression"
 where
  operatorTable :: OperatorTable String () Identity ValueExpr
operatorTable =
    [ [ParsecT String () Identity (ValueExpr -> ValueExpr)
-> Operator String () Identity ValueExpr
forall s u (m :: * -> *) a.
ParsecT s u m (a -> a) -> Operator s u m a
Prefix ParsecT String () Identity (ValueExpr -> ValueExpr)
parseNegateOp]
    , [ParsecT String () Identity (ValueExpr -> ValueExpr -> ValueExpr)
-> Assoc -> Operator String () Identity ValueExpr
forall s u (m :: * -> *) a.
ParsecT s u m (a -> a -> a) -> Assoc -> Operator s u m a
Infix ParsecT String () Identity (ValueExpr -> ValueExpr -> ValueExpr)
parsePlusOp Assoc
AssocLeft]
    ]

-- | Parse either a 'ValueExprLovelace' or 'ValueExprMultiAsset'.
parseValueExprTerm :: Parser ValueExpr
parseValueExprTerm :: Parser ValueExpr
parseValueExprTerm = do
  Quantity
q <- ParsecT String () Identity Quantity
-> ParsecT String () Identity Quantity
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try ParsecT String () Identity Quantity
parseQuantity ParsecT String () Identity Quantity
-> String -> ParsecT String () Identity Quantity
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"quantity (word64)"
  AssetId
aId <- ParsecT String () Identity AssetId
-> ParsecT String () Identity AssetId
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try ParsecT String () Identity AssetId
parseAssetIdUnspecified ParsecT String () Identity AssetId
-> ParsecT String () Identity AssetId
-> ParsecT String () Identity AssetId
forall a.
ParsecT String () Identity a
-> ParsecT String () Identity a -> ParsecT String () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT String () Identity AssetId
parseAssetIdSpecified ParsecT String () Identity AssetId
-> String -> ParsecT String () Identity AssetId
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"asset id"
  ()
_ <- ParsecT String () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
  ValueExpr -> Parser ValueExpr
forall a. a -> ParsecT String () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ValueExpr -> Parser ValueExpr) -> ValueExpr -> Parser ValueExpr
forall a b. (a -> b) -> a -> b
$ case AssetId
aId of
    AssetId
AdaAssetId -> Quantity -> ValueExpr
ValueExprLovelace Quantity
q
    AssetId PolicyId
polId AssetName
aName -> PolicyId -> AssetName -> Quantity -> ValueExpr
ValueExprMultiAsset PolicyId
polId AssetName
aName Quantity
q
 where
  -- Parse an asset ID which must be lead by one or more whitespace
  -- characters and may be trailed by whitespace characters.
  parseAssetIdSpecified :: Parser AssetId
  parseAssetIdSpecified :: ParsecT String () Identity AssetId
parseAssetIdSpecified = ParsecT String () Identity Char
-> ParsecT String () Identity String
forall a.
ParsecT String () Identity a -> ParsecT String () Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
space ParsecT String () Identity String
-> ParsecT String () Identity AssetId
-> ParsecT String () Identity AssetId
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT String () Identity AssetId
parseAssetId

  -- Default for if an asset ID is not specified.
  parseAssetIdUnspecified :: Parser AssetId
  parseAssetIdUnspecified :: ParsecT String () Identity AssetId
parseAssetIdUnspecified =
    ParsecT String () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
      ParsecT String () Identity ()
-> ParsecT String () Identity () -> ParsecT String () Identity ()
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT String () Identity Char -> ParsecT String () Identity ()
forall s (m :: * -> *) t a u.
(Stream s m t, Show a) =>
ParsecT s u m a -> ParsecT s u m ()
notFollowedBy ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
alphaNum
      ParsecT String () Identity ()
-> AssetId -> ParsecT String () Identity AssetId
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> AssetId
AdaAssetId

------------------------------------------------------------------------------
-- Primitive parsers
------------------------------------------------------------------------------

parsePlusOp :: Parser (ValueExpr -> ValueExpr -> ValueExpr)
parsePlusOp :: ParsecT String () Identity (ValueExpr -> ValueExpr -> ValueExpr)
parsePlusOp = (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'+' ParsecT String () Identity Char
-> ParsecT String () Identity () -> ParsecT String () Identity ()
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT String () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces) ParsecT String () Identity ()
-> (ValueExpr -> ValueExpr -> ValueExpr)
-> ParsecT String () Identity (ValueExpr -> ValueExpr -> ValueExpr)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ValueExpr -> ValueExpr -> ValueExpr
ValueExprAdd

parseNegateOp :: Parser (ValueExpr -> ValueExpr)
parseNegateOp :: ParsecT String () Identity (ValueExpr -> ValueExpr)
parseNegateOp = (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'-' ParsecT String () Identity Char
-> ParsecT String () Identity () -> ParsecT String () Identity ()
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT String () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces) ParsecT String () Identity ()
-> (ValueExpr -> ValueExpr)
-> ParsecT String () Identity (ValueExpr -> ValueExpr)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ValueExpr -> ValueExpr
ValueExprNegate

-- | Period (\".\") parser.
parsePeriod :: Parser ()
parsePeriod :: ParsecT String () Identity ()
parsePeriod = ParsecT String () Identity Char -> ParsecT String () Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT String () Identity Char -> ParsecT String () Identity ())
-> ParsecT String () Identity Char -> ParsecT String () Identity ()
forall a b. (a -> b) -> a -> b
$ Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'.'

-- | Word64 parser.
parseWord64 :: Parser Integer
parseWord64 :: Parser Integer
parseWord64 = do
  Integer
i <- Parser Integer
parseDecimal
  if Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
forall a. Bounded a => a
maxBound :: Word64)
    then
      String -> Parser Integer
forall a. String -> ParsecT String () Identity a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Integer) -> String -> Parser Integer
forall a b. (a -> b) -> a -> b
$
        String
"expecting word64, but the number exceeds the max bound: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
i
    else Integer -> Parser Integer
forall a. a -> ParsecT String () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
i

parseDecimal :: Parser Integer
parseDecimal :: Parser Integer
parseDecimal = do
  String
digits <- ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit
  Integer -> Parser Integer
forall a. a -> ParsecT String () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Parser Integer) -> Integer -> Parser Integer
forall a b. (a -> b) -> a -> b
$! (Integer -> Char -> Integer) -> Integer -> String -> Integer
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (\Integer
x Char
d -> Integer
10 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Char -> Int
Char.digitToInt Char
d)) Integer
0 String
digits

-- | Asset name parser.
parseAssetName :: Parser AssetName
parseAssetName :: Parser AssetName
parseAssetName = do
  String
hexText <- ParsecT String () Identity Char
-> ParsecT String () Identity String
forall a.
ParsecT String () Identity a -> ParsecT String () Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
hexDigit
  (RawBytesHexError -> String)
-> Either RawBytesHexError AssetName -> Parser AssetName
forall (m :: * -> *) e a.
MonadFail m =>
(e -> String) -> Either e a -> m a
failEitherWith
    (\RawBytesHexError
e -> String
"AssetName deserisalisation failed: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ RawBytesHexError -> String
forall a. Error a => a -> String
displayError RawBytesHexError
e)
    (Either RawBytesHexError AssetName -> Parser AssetName)
-> Either RawBytesHexError AssetName -> Parser AssetName
forall a b. (a -> b) -> a -> b
$ AsType AssetName -> ByteString -> Either RawBytesHexError AssetName
forall a.
SerialiseAsRawBytes a =>
AsType a -> ByteString -> Either RawBytesHexError a
deserialiseFromRawBytesHex AsType AssetName
AsAssetName
    (ByteString -> Either RawBytesHexError AssetName)
-> ByteString -> Either RawBytesHexError AssetName
forall a b. (a -> b) -> a -> b
$ String -> ByteString
BSC.pack String
hexText

-- | Policy ID parser.
parsePolicyId :: Parser PolicyId
parsePolicyId :: Parser PolicyId
parsePolicyId = do
  String
hexText <- ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
hexDigit
  (RawBytesHexError -> String)
-> Either RawBytesHexError PolicyId -> Parser PolicyId
forall (m :: * -> *) e a.
MonadFail m =>
(e -> String) -> Either e a -> m a
failEitherWith
    ( \RawBytesHexError
e ->
        ShowS
forall a. String -> [a]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
          String
"expecting a 56-hex-digit policy ID, but found "
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
hexText)
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" hex digits; "
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ RawBytesHexError -> String
forall a. Error a => a -> String
displayError RawBytesHexError
e
    )
    (String -> Either RawBytesHexError PolicyId
textToPolicyId String
hexText)
 where
  textToPolicyId :: String -> Either RawBytesHexError PolicyId
textToPolicyId =
    (ScriptHash -> PolicyId)
-> Either RawBytesHexError ScriptHash
-> Either RawBytesHexError PolicyId
forall a b.
(a -> b) -> Either RawBytesHexError a -> Either RawBytesHexError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ScriptHash -> PolicyId
PolicyId
      (Either RawBytesHexError ScriptHash
 -> Either RawBytesHexError PolicyId)
-> (String -> Either RawBytesHexError ScriptHash)
-> String
-> Either RawBytesHexError PolicyId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AsType ScriptHash
-> ByteString -> Either RawBytesHexError ScriptHash
forall a.
SerialiseAsRawBytes a =>
AsType a -> ByteString -> Either RawBytesHexError a
deserialiseFromRawBytesHex AsType ScriptHash
AsScriptHash
      (ByteString -> Either RawBytesHexError ScriptHash)
-> (String -> ByteString)
-> String
-> Either RawBytesHexError ScriptHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Text.encodeUtf8
      (Text -> ByteString) -> (String -> Text) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack

-- | Asset ID parser.
parseAssetId :: Parser AssetId
parseAssetId :: ParsecT String () Identity AssetId
parseAssetId =
  ParsecT String () Identity AssetId
-> ParsecT String () Identity AssetId
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try ParsecT String () Identity AssetId
parseAdaAssetId
    ParsecT String () Identity AssetId
-> ParsecT String () Identity AssetId
-> ParsecT String () Identity AssetId
forall a.
ParsecT String () Identity a
-> ParsecT String () Identity a -> ParsecT String () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT String () Identity AssetId
parseNonAdaAssetId
    ParsecT String () Identity AssetId
-> String -> ParsecT String () Identity AssetId
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"asset ID"
 where
  -- Parse the ADA asset ID.
  parseAdaAssetId :: Parser AssetId
  parseAdaAssetId :: ParsecT String () Identity AssetId
parseAdaAssetId = String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"lovelace" ParsecT String () Identity String
-> AssetId -> ParsecT String () Identity AssetId
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> AssetId
AdaAssetId

  -- Parse a multi-asset ID.
  parseNonAdaAssetId :: Parser AssetId
  parseNonAdaAssetId :: ParsecT String () Identity AssetId
parseNonAdaAssetId = do
    PolicyId
polId <- Parser PolicyId
parsePolicyId
    PolicyId -> ParsecT String () Identity AssetId
parseFullAssetId PolicyId
polId ParsecT String () Identity AssetId
-> ParsecT String () Identity AssetId
-> ParsecT String () Identity AssetId
forall a.
ParsecT String () Identity a
-> ParsecT String () Identity a -> ParsecT String () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> PolicyId -> ParsecT String () Identity AssetId
parseAssetIdNoAssetName PolicyId
polId

  -- Parse a fully specified multi-asset ID with both a policy ID and asset
  -- name.
  parseFullAssetId :: PolicyId -> Parser AssetId
  parseFullAssetId :: PolicyId -> ParsecT String () Identity AssetId
parseFullAssetId PolicyId
polId = do
    ()
_ <- ParsecT String () Identity ()
parsePeriod
    AssetName
aName <- Parser AssetName
parseAssetName Parser AssetName -> String -> Parser AssetName
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"hexadecimal asset name"
    AssetId -> ParsecT String () Identity AssetId
forall a. a -> ParsecT String () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PolicyId -> AssetName -> AssetId
AssetId PolicyId
polId AssetName
aName)

  -- Parse a multi-asset ID that specifies a policy ID, but no asset name.
  parseAssetIdNoAssetName :: PolicyId -> Parser AssetId
  parseAssetIdNoAssetName :: PolicyId -> ParsecT String () Identity AssetId
parseAssetIdNoAssetName PolicyId
polId = AssetId -> ParsecT String () Identity AssetId
forall a. a -> ParsecT String () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PolicyId -> AssetName -> AssetId
AssetId PolicyId
polId AssetName
"")

-- | Quantity (word64) parser. Only accepts positive quantities.
parseQuantity :: Parser Quantity
parseQuantity :: ParsecT String () Identity Quantity
parseQuantity = (Integer -> Quantity)
-> Parser Integer -> ParsecT String () Identity Quantity
forall a b.
(a -> b)
-> ParsecT String () Identity a -> ParsecT String () Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> Quantity
Quantity Parser Integer
parseWord64