{-# LANGUAGE OverloadedLists #-}

module Cardano.Api.Value.Internal.Parser
  ( parseTxOutMultiAssetValue
  , parseMintingMultiAssetValue
  , parseUTxOValue
  , parseAssetName
  , parsePolicyId
  )
where

import Cardano.Api.Era.Internal.Eon.MaryEraOnwards
import Cardano.Api.Parser.Text
import Cardano.Api.Value.Internal

import Cardano.Ledger.Mary.Value qualified as L

import Control.Monad (unless, when)

-- | Parse a 'Value' from its string representation. The resulting amounts must be positive for the parser
-- to succeed.
parseTxOutMultiAssetValue :: Parser Value
parseTxOutMultiAssetValue :: Parser Value
parseTxOutMultiAssetValue = ParserValueRole -> Parser Value
parseValue ParserValueRole
RoleUTxO

-- | Parse a 'MintValue' from its string representation. The string representation cannot contain ADA.
parseMintingMultiAssetValue :: MaryEraOnwards era -> Parser L.MultiAsset
parseMintingMultiAssetValue :: forall era. MaryEraOnwards era -> Parser MultiAsset
parseMintingMultiAssetValue MaryEraOnwards era
w = MaryEraOnwards era
-> (MaryEraOnwardsConstraints era => Parser MultiAsset)
-> Parser MultiAsset
forall era a.
MaryEraOnwards era -> (MaryEraOnwardsConstraints era => a) -> a
maryEraOnwardsConstraints MaryEraOnwards era
w ((MaryEraOnwardsConstraints era => Parser MultiAsset)
 -> Parser MultiAsset)
-> (MaryEraOnwardsConstraints era => Parser MultiAsset)
-> Parser MultiAsset
forall a b. (a -> b) -> a -> b
$ do
  L.MaryValue Coin
0 MultiAsset
result <- MaryEraOnwards era -> Value -> Value (ShelleyLedgerEra era)
forall era.
MaryEraOnwards era -> Value -> Value (ShelleyLedgerEra era)
toLedgerValue MaryEraOnwards era
w (Value -> MaryValue)
-> Parser Value -> ParsecT Text () Identity MaryValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserValueRole -> Parser Value
parseValue ParserValueRole
RoleMint
  MultiAsset -> Parser MultiAsset
forall a. a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MultiAsset
result

-- | Parse a 'Value' from its string representation. The resulting amounts must be positive for the parser
-- to succeed.
parseUTxOValue :: Parser Value
parseUTxOValue :: Parser Value
parseUTxOValue = ParserValueRole -> Parser Value
parseValue ParserValueRole
RoleUTxO

-- | 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 Text () Identity () -> ParsecT Text () Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Value -> Bool
allPositive Value
value) (ParsecT Text () Identity () -> ParsecT Text () Identity ())
-> ParsecT Text () Identity () -> ParsecT Text () Identity ()
forall a b. (a -> b) -> a -> b
$
        String -> ParsecT Text () Identity ()
forall a. String -> ParsecT Text () Identity a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ParsecT Text () Identity ())
-> String -> ParsecT Text () 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 Text () 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 Text () Identity () -> ParsecT Text () Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
lovelace Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0) (ParsecT Text () Identity () -> ParsecT Text () Identity ())
-> ParsecT Text () Identity () -> ParsecT Text () Identity ()
forall a b. (a -> b) -> a -> b
$
        String -> ParsecT Text () Identity ()
forall a. String -> ParsecT Text () Identity a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ParsecT Text () Identity ())
-> String -> ParsecT Text () 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 Text () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
value

-- | 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 Text () 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 Text () 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 Text () Identity ValueExpr
operatorTable =
    [ [ParsecT Text () Identity (ValueExpr -> ValueExpr)
-> Operator Text () Identity ValueExpr
forall s u (m :: * -> *) a.
ParsecT s u m (a -> a) -> Operator s u m a
Prefix ParsecT Text () Identity (ValueExpr -> ValueExpr)
parseNegateOp]
    , [ParsecT Text () Identity (ValueExpr -> ValueExpr -> ValueExpr)
-> Assoc -> Operator Text () Identity ValueExpr
forall s u (m :: * -> *) a.
ParsecT s u m (a -> a -> a) -> Assoc -> Operator s u m a
Infix ParsecT Text () Identity (ValueExpr -> ValueExpr -> ValueExpr)
parsePlusOp Assoc
AssocLeft]
    ]

-- | Parse either a 'ValueExprLovelace' or 'ValueExprMultiAsset'.
parseValueExprTerm :: Parser ValueExpr
parseValueExprTerm :: Parser ValueExpr
parseValueExprTerm = do
  Quantity
q <- ParsecT Text () Identity Quantity
-> ParsecT Text () Identity Quantity
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try ParsecT Text () Identity Quantity
parseQuantity ParsecT Text () Identity Quantity
-> String -> ParsecT Text () Identity Quantity
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"quantity (word64)"
  AssetId
aId <- ParsecT Text () Identity AssetId
-> ParsecT Text () Identity AssetId
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try ParsecT Text () Identity AssetId
parseAssetIdUnspecified ParsecT Text () Identity AssetId
-> ParsecT Text () Identity AssetId
-> ParsecT Text () Identity AssetId
forall a.
ParsecT Text () Identity a
-> ParsecT Text () Identity a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Text () Identity AssetId
parseAssetIdSpecified ParsecT Text () Identity AssetId
-> String -> ParsecT Text () Identity AssetId
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"asset id"
  ()
_ <- ParsecT Text () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
  ValueExpr -> Parser ValueExpr
forall a. a -> ParsecT Text () 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 Text () Identity AssetId
parseAssetIdSpecified = ParsecT Text () Identity Char -> ParsecT Text () Identity String
forall a.
ParsecT Text () Identity a -> ParsecT Text () Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
space ParsecT Text () Identity String
-> ParsecT Text () Identity AssetId
-> ParsecT Text () Identity AssetId
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Text () Identity AssetId
parseAssetId

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

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

parsePlusOp :: Parser (ValueExpr -> ValueExpr -> ValueExpr)
parsePlusOp :: ParsecT Text () Identity (ValueExpr -> ValueExpr -> ValueExpr)
parsePlusOp = (Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'+' ParsecT Text () Identity Char
-> ParsecT Text () Identity () -> ParsecT Text () Identity ()
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Text () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces) ParsecT Text () Identity ()
-> (ValueExpr -> ValueExpr -> ValueExpr)
-> ParsecT Text () 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 Text () Identity (ValueExpr -> ValueExpr)
parseNegateOp = (Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'-' ParsecT Text () Identity Char
-> ParsecT Text () Identity () -> ParsecT Text () Identity ()
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Text () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces) ParsecT Text () Identity ()
-> (ValueExpr -> ValueExpr)
-> ParsecT Text () Identity (ValueExpr -> ValueExpr)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ValueExpr -> ValueExpr
ValueExprNegate