{-# LANGUAGE OverloadedLists #-}
module Cardano.Api.ValueParser
( parseValue
, assetName
, policyId
)
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 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)
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
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)]
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 :: 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]
]
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 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
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 a. a -> ParsecT String () Identity a
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
assetIdSpecified :: Parser AssetId
assetIdSpecified :: ParsecT String () Identity AssetId
assetIdSpecified = 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
assetId
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 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
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 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
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 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 ()
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 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 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
decimal :: Parser Integer
decimal :: Parser Integer
decimal = 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
assetName :: Parser AssetName
assetName :: Parser AssetName
assetName = 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
policyId :: Parser PolicyId
policyId :: Parser PolicyId
policyId = 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
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 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
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
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
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 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
assetIdNoAssetName PolicyId
polId
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 a. a -> ParsecT String () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PolicyId -> AssetName -> AssetId
AssetId PolicyId
polId AssetName
aName)
assetIdNoAssetName :: PolicyId -> Parser AssetId
assetIdNoAssetName :: PolicyId -> ParsecT String () Identity AssetId
assetIdNoAssetName 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 :: Parser Quantity
quantity :: ParsecT String () Identity Quantity
quantity = (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
word64