module Bcc.CLI.Jen.ValueParser
  ( parseValue
  ) where

import           Prelude

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           Control.Applicative (some, (<|>))

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           Bcc.Api

-- | 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)
    ValueExprEntropic Quantity
quant -> [(AssetId, Quantity)] -> Value
valueFromList [(AssetId
BccAssetId, 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
  | ValueExprEntropic !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 'ValueExprEntropic' 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
BccAssetId -> Quantity -> ValueExpr
ValueExprEntropic 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
BccAssetId

------------------------------------------------------------------------------
-- 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 =
    String -> AssetName
toAssetName (String -> AssetName)
-> ParsecT String () Identity String -> Parser AssetName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
alphaNum
  where
    toAssetName :: String -> AssetName
toAssetName = ByteString -> AssetName
AssetName (ByteString -> AssetName)
-> (String -> ByteString) -> String -> AssetName
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

-- | 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
  case String -> Maybe PolicyId
textToPolicyId String
hexText of
    Just PolicyId
p -> PolicyId -> Parser PolicyId
forall (f :: * -> *) a. Applicative f => a -> f a
pure PolicyId
p
    Maybe PolicyId
Nothing ->
      String -> Parser PolicyId
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser PolicyId) -> String -> Parser PolicyId
forall a b. (a -> b) -> a -> b
$ String
"expecting a 56 hex-encoded policy ID, but found only "
          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"
  where
    textToPolicyId :: String -> Maybe PolicyId
textToPolicyId =
        (ScriptHash -> PolicyId) -> Maybe ScriptHash -> Maybe PolicyId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ScriptHash -> PolicyId
PolicyId
      (Maybe ScriptHash -> Maybe PolicyId)
-> (String -> Maybe ScriptHash) -> String -> Maybe PolicyId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AsType ScriptHash -> ByteString -> Maybe ScriptHash
forall a.
SerialiseAsRawBytes a =>
AsType a -> ByteString -> Maybe a
deserialiseFromRawBytesHex AsType ScriptHash
AsScriptHash
      (ByteString -> Maybe ScriptHash)
-> (String -> ByteString) -> String -> Maybe 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
nonBccAssetId
      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 BCC 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
"entropic" ParsecT String () Identity String
-> AssetId -> ParsecT String () Identity AssetId
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> AssetId
BccAssetId

    -- Parse a multi-asset ID.
    nonBccAssetId :: Parser AssetId
    nonBccAssetId :: ParsecT String () Identity AssetId
nonBccAssetId = 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
"alphanumeric 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