morley-1.19.0: src/Morley/Michelson/Parser/Value.hs

-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

-- | Parsing of untyped Michelson values.

module Morley.Michelson.Parser.Value
  ( value'

  -- * For tests
  , stringLiteral
  , bytesLiteral
  , intLiteral
  ) where

import Prelude hiding (many, note, try)

import Data.Char qualified as Char
import Text.Hex qualified as Hex

import Text.Megaparsec (anySingle, choice, customFailure, label, manyTill, satisfy, takeWhileP, try)
import Text.Megaparsec.Char (char, string)
import Text.Megaparsec.Char.Lexer qualified as L

import Morley.Michelson.Macro (ParsedOp, ParsedValue)
import Morley.Michelson.Parser.Error
import Morley.Michelson.Parser.Helpers
import Morley.Michelson.Parser.Lexer
import Morley.Michelson.Parser.Types (Parser)
import Morley.Michelson.Text (isMChar, mkMText)
import Morley.Michelson.Untyped qualified as U

-- | Parse untyped 'ParsedValue'. Take instruction parser as argument
-- to avoid cyclic dependencies between modules, hence ' in its name.
value' :: Parser ParsedOp -> Parser ParsedValue
value' opParser = parensOrTuple opParser <|> valueInnerWithoutParens opParser

parensOrTuple :: Parser ParsedOp -> Parser ParsedValue
parensOrTuple opParser = parens $ value' opParser

valueInnerWithoutParens :: Parser ParsedOp -> Parser ParsedValue
valueInnerWithoutParens opParser = label "value" $ choice $
  [ stringLiteral, bytesLiteral, intLiteral, unitValue
  , trueValue, falseValue, pairValueCore opParser, leftValue opParser
  , rightValue opParser, someValue opParser, noneValue, nilValue
  , seqOrLambda opParser, mapValue opParser, lambdaRecValue opParser
  ]

seqOrLambda :: Parser ParsedOp -> Parser ParsedValue
seqOrLambda opParser = try (lambdaValue opParser) <|> seqValue opParser

stringLiteral :: Parser ParsedValue
stringLiteral = lexeme $ U.ValueString . unsafe . mkMText . toText <$> do
  _ <- try $ string "\""
  manyTill validChar (string "\"")
  where
      validChar :: Parser Char
      validChar = choice
        [ strEscape
        , satisfy (\x -> x /= '"' && isMChar x)
        , anySingle >>= stringLiteralFailure . InvalidChar
        ]

      strEscape :: Parser Char
      strEscape = try (char '\\') >> esc
        where
          esc = choice
            [ char '\\'
            , char '"'
            , char 'n' $> '\n'
            , anySingle >>= stringLiteralFailure . InvalidEscapeSequence
            ]
      stringLiteralFailure = customFailure . StringLiteralException

-- It is safe not to use `try` here because bytesLiteral is the only
-- thing that starts from 0x (at least for now)
bytesLiteral :: Parser (U.Value' op)
bytesLiteral = lexeme $ do
  string "0x"
  hexdigits <- takeWhileP Nothing Char.isHexDigit
  let mBytes = Hex.decodeHex hexdigits
  maybe
    (customFailure OddNumberBytesException)
    (return . U.ValueBytes . U.InternalByteString)
    mBytes

intLiteral :: Parser (U.Value' op)
intLiteral = lexeme $ try $ U.ValueInt <$> L.signed pass L.decimal

unitValue :: Parser ParsedValue
unitValue = word "Unit" U.ValueUnit

trueValue :: Parser ParsedValue
trueValue = word "True" U.ValueTrue

falseValue :: Parser ParsedValue
falseValue = word "False" U.ValueFalse

pairValueCore :: Parser ParsedOp -> Parser ParsedValue
pairValueCore opParser = symbol1 "Pair" *> pairInner
  where
    pairInner = U.ValuePair
      <$> value' opParser
      <*> (foldr1 U.ValuePair <$> some' (value' opParser))

leftValue :: Parser ParsedOp -> Parser ParsedValue
leftValue opParser = word "Left" U.ValueLeft <*> value' opParser

rightValue :: Parser ParsedOp -> Parser ParsedValue
rightValue opParser = word "Right" U.ValueRight <*> value' opParser

someValue :: Parser ParsedOp -> Parser ParsedValue
someValue opParser = word "Some" U.ValueSome <*> value' opParser

noneValue :: Parser ParsedValue
noneValue = word "None" U.ValueNone

nilValue :: Parser ParsedValue
nilValue = U.ValueNil <$ (try $ braces pass)

lambdaValue :: Parser ParsedOp -> Parser ParsedValue
lambdaValue opParser = U.ValueLambda <$> ops1
  where
    ops1 :: Parser (NonEmpty ParsedOp)
    ops1 = braces $ sepEndBy1 opParser semicolon

lambdaRecValue :: Parser ParsedOp -> Parser ParsedValue
lambdaRecValue opParser = word "Lambda_rec" U.ValueLamRec <*> ops1
  where
    ops1 :: Parser (NonEmpty ParsedOp)
    ops1 = braces $ sepEndBy1 opParser semicolon

seqValue :: Parser ParsedOp -> Parser ParsedValue
seqValue opParser =
  U.ValueSeq <$> (try $ braces $ sepEndBy1 (value' opParser) semicolon)

eltValue :: Parser ParsedOp -> Parser (U.Elt ParsedOp)
eltValue opParser = word "Elt" U.Elt <*> value' opParser <*> value' opParser

mapValue :: Parser ParsedOp -> Parser ParsedValue
mapValue opParser =
  U.ValueMap <$> (try $ braces $ sepEndBy1 (eltValue opParser) semicolon)