Parser.hs

module Test.Parser
  ( unit_Parse_contracts
  , unit_Parse_bad_contracts
  , unit_Value
  , unit_string_literal
  , unit_annotation
  , unit_IF
  , unit_MAP
  , unit_PAIR
  , unit_pair_type
  , unit_tuple_type
  , unit_or_type
  , unit_lambda_type
  , unit_list_type
  , unit_set_type
  , unit_Pair_constructor
  , unit_PrintComment
  , unit_ParserException
  , unit_letType
  ) where

import qualified Data.List.NonEmpty as NE
import Test.Hspec.Expectations (Expectation, expectationFailure, shouldBe, shouldSatisfy)
import Text.Megaparsec (parse)
import Text.Megaparsec.Error
  (ErrorFancy(ErrorCustom), ParseError(FancyError), bundleErrors, errorBundlePretty)

import Michelson.ErrorPos (srcPos)
import Michelson.Macro as Mo
import Michelson.Parser as P
import Michelson.Parser.Annotations as PA
import Michelson.Untyped as Mo
import Util.IO
import Util.Positive

import Test.Util.Contracts (getIllTypedContracts, getUnparsableContracts, getWellTypedContracts)

unit_Parse_contracts :: Expectation
unit_Parse_contracts = do
  files <- mappend <$> getWellTypedContracts <*> getIllTypedContracts
  mapM_ (checkFile True) files

unit_Parse_bad_contracts :: Expectation
unit_Parse_bad_contracts = do
  files <- getUnparsableContracts
  mapM_ (checkFile False) files

checkFile :: Bool -> FilePath -> Expectation
checkFile shouldParse file = do
  code <- readFileUtf8 file
  case parse P.program file code of
    Left err
      | shouldParse -> expectationFailure $ errorBundlePretty err
    Right _
      | not shouldParse -> expectationFailure $ "Managed to parse " <> file
    _ -> pass

unit_Value :: Expectation
unit_Value = do
  P.parseNoEnv P.value "" "{}" `shouldBe`
    Right Mo.ValueNil
  P.parseNoEnv P.value "" "{PUSH int 5;}" `shouldBe`
    (Right . ValueLambda $ NE.fromList
      [Mo.Prim (Mo.PUSH noAnn (Mo.Type (Mo.Tc Mo.CInt) noAnn) (Mo.ValueInt 5)) (srcPos 0 1)]
    )
  P.parseNoEnv P.value "" "{1; 2}" `shouldBe`
    (Right . Mo.ValueSeq $ NE.fromList
      [Mo.ValueInt 1, Mo.ValueInt 2]
    )
  P.parseNoEnv P.value "" "{Elt 1 2; Elt 3 4}" `shouldBe`
    (Right . Mo.ValueMap $ NE.fromList
      [Mo.Elt (Mo.ValueInt 1) (Mo.ValueInt 2), Mo.Elt (Mo.ValueInt 3) (Mo.ValueInt 4)]
    )
  P.parseNoEnv P.value "" "{DIP DROP;}" `shouldBe`
    Right (Mo.ValueLambda (Mo.Prim (Mo.DIP [Mo.Prim Mo.DROP (srcPos 0 5)]) (srcPos 0 1) :| []))
  P.parseNoEnv P.value "" "{DIP DROP;somecontent}" `shouldSatisfy` isLeft
  P.parseNoEnv P.value "" "{{ }; {}; {PUSH int 5; DROP}}" `shouldBe`
    Right (Mo.ValueLambda (Mo.Seq [] (srcPos 0 1)
            :| [ Mo.Seq [] (srcPos 0 6)
               , Mo.Seq [Mo.Prim (Mo.PUSH noAnn (Mo.Type (Mo.Tc Mo.CInt) noAnn) (Mo.ValueInt 5)) (srcPos 0 11)
                        , Mo.Prim Mo.DROP (srcPos 0 23)] (srcPos 0 10)
               ]
           ))
  P.parseNoEnv P.value "" "{{}; {}; {5}}" `shouldBe`
    Right (Mo.ValueSeq (Mo.ValueNil :| [Mo.ValueNil, Mo.ValueSeq (Mo.ValueInt 5 :| [])]))
  P.parseNoEnv P.value "" "{{}; {5}; {Push int 5}}" `shouldSatisfy` isLeft

unit_string_literal :: Expectation
unit_string_literal = do
  P.parseNoEnv P.stringLiteral "" "\"\"" `shouldSatisfy` isRight
  P.parseNoEnv P.stringLiteral "" "\" \\n  \"" `shouldSatisfy` isRight
  P.parseNoEnv P.stringLiteral "" "\"abacaba \\t \n\n\r a\"" `shouldSatisfy` isLeft
  P.parseNoEnv P.stringLiteral "" "\"abacaba \\t \\n\\n\\r" `shouldSatisfy` isLeft

unit_annotation :: Expectation
unit_annotation = do
  P.parseNoEnv PA.noteV "" "@" `shouldSatisfy` isRight
  P.parseNoEnv PA.noteV "" "@_" `shouldSatisfy` isRight
  P.parseNoEnv PA.noteV "" "@a." `shouldSatisfy` isRight
  P.parseNoEnv PA.noteV "" "@.a" `shouldSatisfy` isLeft
  P.parseNoEnv PA.noteV "" "@7a" `shouldSatisfy` isLeft
  P.parseNoEnv PA.noteV "" "@@@" `shouldSatisfy` isLeft
  P.parseNoEnv PA.noteV "" "@a b" `shouldSatisfy` isLeft
  P.parseNoEnv PA.noteV "" "@a\\" `shouldSatisfy` isLeft
  -- TODO [#48] these are special annotations and should not always be accepted
  P.parseNoEnv PA.noteV "" "@%" `shouldSatisfy` isRight
  P.parseNoEnv PA.noteV "" "@%%" `shouldSatisfy` isRight

unit_IF :: Expectation
unit_IF = do
  P.parseNoEnv P.codeEntry "" "{IF {} {};}" `shouldBe`
    Prelude.Right [Mo.Prim (Mo.IF [] []) (srcPos 0 1)]
  P.parseNoEnv P.codeEntry "" "{IFEQ {} {};}" `shouldBe`
    Prelude.Right [Mo.Mac (Mo.IFX (Mo.EQ noAnn) [] []) (srcPos 0 1)]
  P.parseNoEnv P.codeEntry "" "{IFCMPEQ {} {};}" `shouldBe`
    Prelude.Right [Mo.Mac (Mo.IFCMP (Mo.EQ noAnn) noAnn [] []) (srcPos 0 1)]

unit_MAP :: Expectation
unit_MAP = do
  parseNoEnv P.codeEntry "" "{MAP {};}" `shouldBe`
    Prelude.Right [Mo.Prim (Mo.MAP noAnn []) (srcPos 0 1)]
  parseNoEnv P.codeEntry "" "{MAP_CAR {};}" `shouldBe`
    Prelude.Right [Mo.Mac (Mo.MAP_CADR [Mo.A] noAnn noAnn []) (srcPos 0 1)]

unit_PAIR :: Expectation
unit_PAIR = do
  P.parseNoEnv P.codeEntry "" "{PAIR;}" `shouldBe`
    Prelude.Right [Mo.Prim (PAIR noAnn noAnn noAnn noAnn) (srcPos 0 1)]
  P.parseNoEnv P.codeEntry "" "{PAIR %a;}" `shouldBe`
    Prelude.Right [Mac (PAPAIR (P (F (noAnn, Mo.ann "a")) (F (noAnn,noAnn))) noAnn noAnn) (srcPos 0 1)]
  P.parseNoEnv P.codeEntry "" "{PAPAIR;}" `shouldBe`
    Prelude.Right
      [flip Mac (srcPos 0 1) $
        PAPAIR (P (F (noAnn,noAnn)) (P (F (noAnn,noAnn)) (F (noAnn,noAnn))))
          noAnn noAnn
      ]

unit_pair_type :: Expectation
unit_pair_type = do
  P.parseNoEnv P.type_ "" "pair unit unit" `shouldBe` Right unitPair
  P.parseNoEnv P.type_ "" "(unit, unit)" `shouldBe` Right unitPair
  P.parseNoEnv P.type_ "" "(key, (int, (string, bool)))"
    `shouldSatisfy` isRight
  P.parseNoEnv P.type_ "" "(signature, chain_id, string, bool)"
    `shouldSatisfy` isRight
  where
    unitPair :: Mo.Type
    unitPair =
      Mo.Type (Mo.TPair noAnn noAnn (Mo.Type Mo.TUnit noAnn) (Mo.Type Mo.TUnit noAnn)) noAnn

unit_tuple_type :: Expectation
unit_tuple_type = do
  P.parseNoEnv P.type_ "" "(int, int, bool, unit, nat)"
    `shouldBe` Right (typair (typair tyint tyint) (typair tybool (typair tyunit tynat)))
  P.parseNoEnv P.type_ ""
    "(pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat nat))))))))))))))))"
      `shouldBe` Right (bigPair 16)
  where
    bigPair :: Integer -> Type
    bigPair n | n == 0 = tynat
    bigPair n          = typair tynat (bigPair (n - 1))

unit_or_type :: Expectation
unit_or_type = do
  P.parseNoEnv P.type_ "" "or unit unit" `shouldBe` Right unitOr
  P.parseNoEnv P.type_ "" "(unit | unit)" `shouldBe` Right unitOr
  P.parseNoEnv P.type_ "" "(chain_id | (int | (string | bool)))"
    `shouldSatisfy` isRight
  P.parseNoEnv P.type_ "" "or unit unit kek"
    `shouldSatisfy` isLeft
  where
    unitOr :: Mo.Type
    unitOr =
      Mo.Type (Mo.TOr noAnn noAnn (Mo.Type Mo.TUnit noAnn) (Mo.Type Mo.TUnit noAnn)) noAnn

unit_lambda_type :: Expectation
unit_lambda_type = do
  P.parseNoEnv P.type_ "" "lambda unit unit" `shouldBe` Right lambdaUnitUnit
  P.parseNoEnv P.type_ "" "\\unit -> unit" `shouldBe` Right lambdaUnitUnit
  P.parseNoEnv P.type_ "" "lambda int (signature, int)" `shouldSatisfy` isRight
  where
    lambdaUnitUnit :: Mo.Type
    lambdaUnitUnit =
      Mo.Type (Mo.TLambda (Mo.Type Mo.TUnit noAnn) (Mo.Type Mo.TUnit noAnn)) noAnn

unit_list_type :: Expectation
unit_list_type = do
  P.parseNoEnv P.type_ "" "list unit" `shouldBe` Right unitList
  P.parseNoEnv P.type_ "" "[unit]" `shouldBe` Right unitList
  P.parseNoEnv P.type_ "" "[(key, key)]" `shouldSatisfy` isRight
  where
    unitList :: Mo.Type
    unitList =
      Mo.Type (Mo.TList (Mo.Type Mo.TUnit noAnn)) noAnn

unit_set_type :: Expectation
unit_set_type = do
  P.parseNoEnv P.type_ "" "set int" `shouldBe` Right intSet
  P.parseNoEnv P.type_ "" "{int}" `shouldBe` Right intSet
  where
    intSet :: Mo.Type
    intSet =
      Mo.Type (Mo.TSet (Mo.Comparable Mo.CInt noAnn)) noAnn

unit_Pair_constructor :: Expectation
unit_Pair_constructor = do
  P.parseNoEnv P.value "" "Pair Unit Unit" `shouldBe` Right unitPair
  P.parseNoEnv P.value "" "(Unit, Unit)" `shouldBe` Right unitPair
  where
    unitPair :: Mo.Value' Mo.ParsedOp
    unitPair = Mo.ValuePair Mo.ValueUnit Mo.ValueUnit

unit_PrintComment :: Expectation
unit_PrintComment = do
  P.parseNoEnv P.printComment "" "\"Sides are %[0] x %[1]\"" `shouldBe`
    Right (PrintComment [Left "Sides are ", Right (StackRef 0), Left " x ", Right (StackRef 1)])
  P.parseNoEnv P.printComment "" "\"%[0] x\"" `shouldBe`
    Right (PrintComment [Right (StackRef 0), Left " x"])
  P.parseNoEnv P.printComment "" "\"%[0]x%[1]\"" `shouldBe`
    Right (PrintComment [Right (StackRef 0), Left "x", Right (StackRef 1)])
  P.parseNoEnv P.printComment "" "\"%[0]%[1]\"" `shouldBe`
    Right (PrintComment [Right (StackRef 0), Right (StackRef 1)])
  P.parseNoEnv P.printComment "" "\"xxx\"" `shouldBe`
    Right (PrintComment [Left "xxx"])
  P.parseNoEnv P.printComment "" "\"\"" `shouldBe`
    Right (PrintComment [])

unit_ParserException :: Expectation
unit_ParserException = do
  handleCustomError "0x000" P.value OddNumberBytesException
  handleCustomError "Right 0x000" P.value OddNumberBytesException
  handleCustomError "kek" P.type_ UnknownTypeException
  handleCustomError "\"aaa\\r\"" P.stringLiteral
    (StringLiteralException (InvalidEscapeSequence 'r'))
  handleCustomError "\"aaa\\b\"" P.stringLiteral
    (StringLiteralException (InvalidEscapeSequence 'b'))
  handleCustomError "\"aaa\\t\"" P.stringLiteral
    (StringLiteralException (InvalidEscapeSequence 't'))
  handleCustomError "\"aaa\n\"" P.stringLiteral
    (StringLiteralException (InvalidChar '\n'))
  handleCustomError "\"aaa\r\"" P.stringLiteral
    (StringLiteralException (InvalidChar '\r'))
  handleCustomError "{ TAG 2 (int | string) }" P.codeEntry
    (WrongTagArgs 2 (PositiveUnsafe 2))
  handleCustomError "{ ACCESS 2 2 }" P.codeEntry
    (WrongAccessArgs 2 (PositiveUnsafe 2))
  handleCustomError "{ SET 2 2 }" P.codeEntry
    (WrongSetArgs 2 (PositiveUnsafe 2))
  where
    handleCustomError
      :: HasCallStack => Text -> Parser a -> CustomParserException -> Expectation
    handleCustomError text parser customException =
      case P.parseNoEnv parser "" text of
        Right _ -> expectationFailure "expecting parser to fail"
        Left bundle -> case toList $ bundleErrors bundle of
          [FancyError _ (toList -> [ErrorCustom e])] ->
            e `shouldBe` customException
          _ ->
            expectationFailure $
              "expecting single ErrorCustom, but got " <>
              errorBundlePretty bundle

unit_letType :: Expectation
unit_letType = do
  P.parseNoEnv P.letType "" "type kek = int" `shouldSatisfy` isRight
  -- They used to be prohibited, but now we permit them.
  P.parseNoEnv P.letType "" "type Parameter = int" `shouldSatisfy` isRight
  P.parseNoEnv P.letType "" "type Storage = int" `shouldSatisfy` isRight