morley-1.19.2: 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, ParsedSeq(..), 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 (ParsedSeq ParsedOp) -> Parser ParsedValue
value' opsParser = parensOrTuple opsParser <|> valueInnerWithoutParens opsParser

parensOrTuple :: Parser (ParsedSeq ParsedOp) -> Parser ParsedValue
parensOrTuple opsParser = parens $ value' opsParser

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

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

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' f 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' f 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 (ParsedSeq ParsedOp) -> Parser ParsedValue
pairValueCore opsParser = symbol1 "Pair" *> pairInner
  where
    pairInner = U.ValuePair
      <$> value' opsParser
      <*> (foldr1 U.ValuePair <$> some' (value' opsParser))

leftValue :: Parser (ParsedSeq ParsedOp) -> Parser ParsedValue
leftValue opsParser = word "Left" U.ValueLeft <*> value' opsParser

rightValue :: Parser (ParsedSeq ParsedOp) -> Parser ParsedValue
rightValue opsParser = word "Right" U.ValueRight <*> value' opsParser

someValue :: Parser (ParsedSeq ParsedOp) -> Parser ParsedValue
someValue opsParser = word "Some" U.ValueSome <*> value' opsParser

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

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

lambdaValue :: Parser (ParsedSeq ParsedOp) -> Parser ParsedValue
lambdaValue opsParser = opsParser <&> \case
  PSSequence [] -> U.ValueNil
  ops -> U.ValueLambda ops

lambdaRecValue :: Parser (ParsedSeq ParsedOp) -> Parser ParsedValue
lambdaRecValue opsParser = word "Lambda_rec" U.ValueLamRec <*> opsParser

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

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

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