module Cardano.Api.ValueParser
  ( parseValue
  , assetName
  , policyId
  ) where

import           Prelude

import           Control.Applicative (many, some, (<|>))
import qualified Data.ByteString.Char8 as BSC
import qualified Data.Char as Char
import           Data.Functor (void, ($>))
import           Data.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)

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

-- | Parse a 'Value' from its string representation.
parseValue :: Parser Value
parseValue :: Parser Value
parseValue = ValueExpr -> Value
evalValueExpr (ValueExpr -> Value)
-> ParsecT String () Identity ValueExpr -> Parser Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity ValueExpr
parseValueExpr

-- | 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, Quantity)] -> Value
valueFromList [(AssetId
AdaAssetId, Quantity
quant)]
    ValueExprMultiAsset PolicyId
polId AssetName
aName Quantity
quant ->
      [(AssetId, Quantity)] -> Value
valueFromList [(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
/= :: ValueExpr -> ValueExpr -> Bool
$c/= :: ValueExpr -> ValueExpr -> Bool
== :: ValueExpr -> ValueExpr -> Bool
$c== :: 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
min :: ValueExpr -> ValueExpr -> ValueExpr
$cmin :: ValueExpr -> ValueExpr -> ValueExpr
max :: ValueExpr -> ValueExpr -> ValueExpr
$cmax :: ValueExpr -> ValueExpr -> ValueExpr
>= :: ValueExpr -> ValueExpr -> Bool
$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
compare :: ValueExpr -> ValueExpr -> Ordering
$ccompare :: ValueExpr -> ValueExpr -> Ordering
$cp1Ord :: Eq 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
showList :: [ValueExpr] -> ShowS
$cshowList :: [ValueExpr] -> ShowS
show :: ValueExpr -> String
$cshow :: ValueExpr -> String
showsPrec :: Int -> ValueExpr -> ShowS
$cshowsPrec :: Int -> ValueExpr -> ShowS
Show)

parseValueExpr :: Parser ValueExpr
parseValueExpr :: ParsecT String () Identity ValueExpr
parseValueExpr =
    OperatorTable String () Identity ValueExpr
-> ParsecT String () Identity ValueExpr
-> ParsecT String () Identity 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 ParsecT String () Identity ValueExpr
valueExprTerm
      ParsecT String () Identity ValueExpr
-> String -> ParsecT String () Identity 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)
negateOp]
      , [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)
plusOp Assoc
AssocLeft]
      ]

-- | Parse either a 'ValueExprLovelace' or 'ValueExprMultiAsset'.
valueExprTerm :: Parser ValueExpr
valueExprTerm :: ParsecT String () Identity ValueExpr
valueExprTerm = 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
quantity 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
assetIdUnspecified ParsecT String () Identity AssetId
-> ParsecT String () Identity AssetId
-> ParsecT String () Identity AssetId
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT String () Identity AssetId
assetIdSpecified 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 -> ParsecT String () Identity ValueExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ValueExpr -> ParsecT String () Identity ValueExpr)
-> ValueExpr -> ParsecT String () Identity 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.
    assetIdSpecified :: Parser AssetId
    assetIdSpecified :: ParsecT String () Identity AssetId
assetIdSpecified = ParsecT String () Identity Char
-> ParsecT String () Identity String
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 (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT String () Identity AssetId
assetId

    -- Default for if an asset ID is not specified.
    assetIdUnspecified :: Parser AssetId
    assetIdUnspecified :: ParsecT String () Identity AssetId
assetIdUnspecified =
      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 (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
------------------------------------------------------------------------------

plusOp :: Parser (ValueExpr -> ValueExpr -> ValueExpr)
plusOp :: ParsecT String () Identity (ValueExpr -> ValueExpr -> ValueExpr)
plusOp = (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 (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

negateOp :: Parser (ValueExpr -> ValueExpr)
negateOp :: ParsecT String () Identity (ValueExpr -> ValueExpr)
negateOp = (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 (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.
period :: Parser ()
period :: ParsecT String () Identity ()
period = 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.
word64 :: Parser Integer
word64 :: Parser Integer
word64 = do
  Integer
i <- Parser Integer
decimal
  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 (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 (m :: * -> *) a. Monad m => a -> m a
return Integer
i

decimal :: Parser Integer
decimal :: Parser Integer
decimal = do
    String
digits <- ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
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 (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 (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Integer
x Char
d -> Integer
10Integer -> 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.
assetName :: Parser AssetName
assetName :: Parser AssetName
assetName = do
  String
hexText <- ParsecT String () Identity Char
-> ParsecT String () Identity String
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 e. Error e => e -> 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.
policyId :: Parser PolicyId
policyId :: Parser PolicyId
policyId = do
  String
hexText <- ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
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 (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 (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 e. Error e => e -> 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 (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.
assetId :: Parser AssetId
assetId :: ParsecT String () Identity AssetId
assetId =
    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
adaAssetId
      ParsecT String () Identity AssetId
-> ParsecT String () Identity AssetId
-> ParsecT String () Identity AssetId
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT String () Identity AssetId
nonAdaAssetId
      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.
    adaAssetId :: Parser AssetId
    adaAssetId :: ParsecT String () Identity AssetId
adaAssetId = 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.
    nonAdaAssetId :: Parser AssetId
    nonAdaAssetId :: ParsecT String () Identity AssetId
nonAdaAssetId = do
      PolicyId
polId <- Parser PolicyId
policyId
      PolicyId -> ParsecT String () Identity AssetId
fullAssetId PolicyId
polId ParsecT String () Identity AssetId
-> ParsecT String () Identity AssetId
-> ParsecT String () Identity AssetId
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> PolicyId -> ParsecT String () Identity AssetId
assetIdNoAssetName PolicyId
polId

    -- Parse a fully specified multi-asset ID with both a policy ID and asset
    -- name.
    fullAssetId :: PolicyId -> Parser AssetId
    fullAssetId :: PolicyId -> ParsecT String () Identity AssetId
fullAssetId PolicyId
polId = do
      ()
_ <- ParsecT String () Identity ()
period
      AssetName
aName <- Parser AssetName
assetName 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 (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.
    assetIdNoAssetName :: PolicyId -> Parser AssetId
    assetIdNoAssetName :: PolicyId -> ParsecT String () Identity AssetId
assetIdNoAssetName PolicyId
polId = AssetId -> ParsecT String () Identity AssetId
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PolicyId -> AssetName -> AssetId
AssetId PolicyId
polId AssetName
"")

-- | Quantity (word64) parser.
quantity :: Parser Quantity
quantity :: ParsecT String () Identity Quantity
quantity = (Integer -> Quantity)
-> Parser Integer -> ParsecT String () Identity Quantity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> Quantity
Quantity Parser Integer
word64