cleveland-0.1.1: morley-test/Test/Parser.hs
-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA
-- TODO [#712]: Remove this next major release
{-# OPTIONS_GHC -Wno-deprecations #-}
module Test.Parser
( test_parse_contracts
, test_value
, test_string_literal
, test_annotation
, test_IF
, test_MAP
, test_PAIR
, test_UNPAIR
, test_pair_type
, test_tuple_type
, test_or_type
, test_lambda_type
, test_list_type
, test_set_type
, test_Pair_constructor
, test_printComment
, test_parser_exception
, test_letType
, test_block_comment
, test_UNPAPAIR
, test_mandatory_spaces
) where
import Data.List.NonEmpty qualified as NE
import Data.Text.IO.Utf8 qualified as Utf8 (readFile)
import Test.Hspec (shouldBe, shouldSatisfy)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (assertFailure, testCase)
import Text.Megaparsec (parse)
import Text.Megaparsec.Error
(ErrorFancy(ErrorCustom), ErrorItem(Tokens), ParseError(FancyError, TrivialError), bundleErrors)
import Morley.Michelson.ErrorPos (srcPos)
import Morley.Michelson.Macro as Mo
import Morley.Michelson.Parser as P
import Morley.Michelson.Parser.Annotations as PA
import Morley.Michelson.Parser.Lexer as PL
import Morley.Michelson.Parser.Types (LetEnv, Parser')
import Morley.Michelson.Untyped as Mo
import Morley.Util.Positive
import Test.Cleveland.Instances ()
import Test.Util.Contracts (getIllTypedContracts, getUnparsableContracts, getWellTypedContracts)
----------------------------------------------------------------------------
-- Contracts
----------------------------------------------------------------------------
test_parse_contracts :: [TestTree]
test_parse_contracts =
[ testCase "well-typed and ill-typed contracts are parsable" $ do
files <- mappend <$> getWellTypedContracts <*> getIllTypedContracts
mapM_ (checkFile True) files
, testCase "bad contracts are unparsable" $ do
files <- getUnparsableContracts
mapM_ (checkFile False) files
]
----------------------------------------------------------------------------
-- Values
----------------------------------------------------------------------------
test_value :: [TestTree]
test_value = testSatisfyingCases P.value
[ ( "{}"
, Right Mo.ValueNil
)
, ( "{PUSH int 5;}"
, Right . ValueLambda $ NE.fromList
[Mo.Prim (Mo.PUSH noAnn (Mo.Ty Mo.TInt noAnn) (Mo.ValueInt 5)) (srcPos 0 1)]
)
, ( "{1; 2}"
, Right . Mo.ValueSeq $ NE.fromList
[Mo.ValueInt 1, Mo.ValueInt 2]
)
, ( "{Elt 1 2; Elt 3 4}"
, Right . Mo.ValueMap $ NE.fromList
[Mo.Elt (Mo.ValueInt 1) (Mo.ValueInt 2), Mo.Elt (Mo.ValueInt 3) (Mo.ValueInt 4)]
)
, ( "{DIP DROP;}"
, Right (Mo.ValueLambda (Mo.Prim (Mo.DIP [Mo.Prim Mo.DROP (srcPos 0 5)]) (srcPos 0 1) :| []))
)
, ( "{{ }; {}; {PUSH int 5; DROP}}"
, Right (Mo.ValueLambda (Mo.Seq [] (srcPos 0 1) :|
[ Mo.Seq [] (srcPos 0 6)
, Mo.Seq [ Mo.Prim (Mo.PUSH noAnn (Mo.Ty Mo.TInt noAnn) (Mo.ValueInt 5)) (srcPos 0 11)
, Mo.Prim Mo.DROP (srcPos 0 23)] (srcPos 0 10)
]))
)
, ( "{{}; {}; {5}}"
, Right (Mo.ValueSeq (Mo.ValueNil :| [Mo.ValueNil, Mo.ValueSeq (Mo.ValueInt 5 :| [])]))
)
] ++
testSatisfyingCasesPredicate P.value
[ ("{DIP DROP;somecontent}", isLeft)
, ("{{}; {5}; {Push int 5}}", isLeft)
]
test_string_literal :: [TestTree]
test_string_literal = testSatisfyingCasesPredicate P.stringLiteral
[ ("\"\"", isRight)
, ("\" \\n \"", isRight)
, ("\"abacaba \\t \n\n\r a\"", isLeft)
, ("\"abacaba \\t \\n\\n\\r", isLeft)
]
----------------------------------------------------------------------------
-- Annotations
----------------------------------------------------------------------------
test_annotation :: [TestTree]
test_annotation = testSatisfyingCasesPredicate PA.noteV
[ ("@", isRight)
, ("@_", isRight)
, ("@a.", isRight)
, ("@7a", isRight)
, ("@.a", isLeft)
, ("@@@", isLeft)
, ("@a b", isLeft)
, ("@a\\", isLeft)
-- TODO [#48] these are special annotations and should not always be accepted
, ("@%", isRight)
, ("@%%", isRight)
]
----------------------------------------------------------------------------
-- Instructions
----------------------------------------------------------------------------
test_IF :: [TestTree]
test_IF = testSatisfyingCases P.codeEntry
[ ( "{IF {} {};}"
, Right [Mo.Prim (Mo.IF [] []) (srcPos 0 1)]
)
, ( "{IFEQ {} {};}"
, Right [Mo.Mac (Mo.IFX (Mo.EQ noAnn) [] []) (srcPos 0 1)]
)
, ( "{IFCMPEQ {} {};}"
, Right [Mo.Mac (Mo.IFCMP (Mo.EQ noAnn) noAnn [] []) (srcPos 0 1)]
)
]
test_MAP :: [TestTree]
test_MAP = testSatisfyingCases P.codeEntry
[ ( "{MAP {};}"
, Right [Mo.Prim (Mo.MAP noAnn []) (srcPos 0 1)]
)
, ( "{MAP_CAR {};}"
, Right [Mo.Mac (Mo.MAP_CADR [Mo.A] noAnn noAnn []) (srcPos 0 1)]
)
]
test_PAIR :: [TestTree]
test_PAIR = testSatisfyingCases P.codeEntry
[ ( "{PAIR;}"
, Right [Mo.Prim (PAIR noAnn noAnn noAnn noAnn) (srcPos 0 1)]
)
, ( "{PAIR %a;}"
, Right [Mo.Prim (PAIR noAnn noAnn "a" noAnn) (srcPos 0 1)]
)
, ( "{PAIR %0;}"
, Right [Mo.Prim (PAIR noAnn noAnn "0" noAnn) (srcPos 0 1)]
)
, ( "{PAPAIR;}"
, Right
[flip Mac (srcPos 0 1) $
PAPAIR (P (F noAnn) (P (F noAnn) (F noAnn)))
noAnn noAnn
]
)
]
test_UNPAPAIR :: [TestTree]
test_UNPAPAIR = testSatisfyingCases P.codeEntry
[ ( "{UNPAPAIR @v1 @v2 @v3 @v4 @v5 %f1 %f2 %f3 %f4 %f5;}"
, Right [unpapair]
)
, ( "{UNPAPAIR @a %b @c %d %e @f;}"
, Right [unpapair]
)
, ( "{UNPAPAIR;}"
, Right [unpapair]
)
]
where
unpapair = Mo.Mac (UNPAPAIR (UP UF (UP UF UF))) (srcPos 0 1)
test_UNPAIR :: [TestTree]
test_UNPAIR = testSatisfyingCases P.codeEntry
[ ( "{UNPAIR;}"
, Right [Mo.Prim (UNPAIR "" "" "" "") (srcPos 0 1)]
)
, ( "{UNPAIR %a;}"
, Right [Mo.Prim (UNPAIR "" "" "a" "") (srcPos 0 1)]
)
, ( "{UNPAIR @a;}"
, Right [Mo.Prim (UNPAIR "a" "" "" "") (srcPos 0 1)]
)
, ( "{UNPAIR @a %b;}"
, Right [Mo.Prim (UNPAIR "a" "" "b" "") (srcPos 0 1)]
)
, ( "{UNPAIR %b @a;}"
, Right [Mo.Prim (UNPAIR "a" "" "b" "") (srcPos 0 1)]
)
, ( "{UNPAIR @a @b;}"
, Right [Mo.Prim (UNPAIR "a" "b" "" "") (srcPos 0 1)]
)
, ( "{UNPAIR %c %d;}"
, Right [Mo.Prim (UNPAIR "" "" "c" "d") (srcPos 0 1)]
)
, ( "{UNPAIR @a @b %c;}"
, Right [Mo.Prim (UNPAIR "a" "b" "c" "") (srcPos 0 1)]
)
, ( "{UNPAIR @a @b %c %d;}"
, Right [Mo.Prim (UNPAIR "a" "b" "c" "d") (srcPos 0 1)]
)
, ( "{UNPAIR %c %d @a;}"
, Right [Mo.Prim (UNPAIR "a" "" "c" "d") (srcPos 0 1)]
)
, ( "{UNPAIR %c %d @a @b;}"
, Right [Mo.Prim (UNPAIR "a" "b" "c" "d") (srcPos 0 1)]
)
] ++
[ -- should fail because the two field anns are not "grouped" together.
handleTrivialError
"{UNPAIR %c @a @b %d;}"
P.codeEntry
(Tokens ('%' :| ""))
, -- should fail because the two var anns are not "grouped" together.
handleTrivialError
"{UNPAIR @a %c %d @b;}"
P.codeEntry
(Tokens ('@' :| ""))
]
----------------------------------------------------------------------------
-- Types
----------------------------------------------------------------------------
test_pair_type :: [TestTree]
test_pair_type =
[ testGroup "simple pair type" $
testSatisfyingCases P.type_
[ ("pair unit unit", Right unitPair)
, ("(unit, unit)", Right unitPair)
]
++
testSatisfyingCasesPredicate P.type_
[ ("(key, (int, (string, bool)))", isRight)
, ("(signature, chain_id, string, bool)", isRight)
]
, testGroup "right-combed pair type" $
testSatisfyingCases P.type_
[ ("pair unit int string", Right rightCombPair)
, ("(unit, int, string)", Right rightCombPair)
]
, testGroup "right-combed pair type with annotations" $
testSatisfyingCases P.type_
[ ( "pair :t (unit :t1 %x) (int :t2 %y) (string %z :t3)"
, Right rightCombPairWithAnns
)
, ( "(unit :t1 %x, int :t2 %y, string %z :t3) :t"
, Right rightCombPairWithAnns
)
]
]
where
unitPair :: Mo.Ty
unitPair =
Mo.Ty (Mo.TPair noAnn noAnn noAnn noAnn (Mo.Ty Mo.TUnit noAnn) (Mo.Ty Mo.TUnit noAnn)) noAnn
rightCombPair :: Mo.Ty
rightCombPair =
Mo.Ty
(Mo.TPair noAnn noAnn noAnn noAnn
(Mo.Ty Mo.TUnit noAnn)
(Mo.Ty
(Mo.TPair noAnn noAnn noAnn noAnn
(Mo.Ty Mo.TInt noAnn)
(Mo.Ty Mo.TString noAnn)
)
noAnn
)
)
noAnn
rightCombPairWithAnns :: Mo.Ty
rightCombPairWithAnns =
Mo.Ty
(Mo.TPair "x" noAnn noAnn noAnn
(Mo.Ty Mo.TUnit "t1")
(Mo.Ty
(Mo.TPair "y" "z" noAnn noAnn
(Mo.Ty Mo.TInt "t2")
(Mo.Ty Mo.TString "t3")
)
noAnn
)
)
"t"
test_tuple_type :: [TestTree]
test_tuple_type = testSatisfyingCases P.type_
[ ( "(int, int, bool, unit, nat)"
, Right (typair (typair tyint tyint) (typair tybool (typair tyunit tynat)))
)
, ( "(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))))))))))))))))"
, Right (bigPair 16)
)
]
where
bigPair :: Integer -> Ty
bigPair n | n == 0 = tynat
bigPair n = typair tynat (bigPair (n - 1))
test_or_type :: [TestTree]
test_or_type =
testSatisfyingCases P.type_
[ ("or unit unit", Right unitOr)
, ("(unit | unit)", Right unitOr)
]
++ testSatisfyingCasesPredicate P.type_
[ ("(chain_id | (int | (string | bool)))", isRight)
, ("or unit unit kek", isLeft)
]
where
unitOr :: Mo.Ty
unitOr =
Mo.Ty (Mo.TOr noAnn noAnn (Mo.Ty Mo.TUnit noAnn) (Mo.Ty Mo.TUnit noAnn)) noAnn
test_lambda_type :: [TestTree]
test_lambda_type =
satisfyingCasePredicate P.type_ "lambda int (signature, int)" isRight :
testSatisfyingCases P.type_
[ ("lambda unit unit", Right lambdaUnitUnit)
, ("\\unit -> unit", Right lambdaUnitUnit)
]
where
lambdaUnitUnit :: Mo.Ty
lambdaUnitUnit =
Mo.Ty (Mo.TLambda (Mo.Ty Mo.TUnit noAnn) (Mo.Ty Mo.TUnit noAnn)) noAnn
test_list_type :: [TestTree]
test_list_type =
satisfyingCasePredicate P.type_ "[(key, key)]" isRight :
testSatisfyingCases P.type_
[ ("list unit", Right unitList)
, ("[unit]", Right unitList)
]
where
unitList :: Mo.Ty
unitList =
Mo.Ty (Mo.TList (Mo.Ty Mo.TUnit noAnn)) noAnn
test_set_type :: [TestTree]
test_set_type = testSatisfyingCases P.type_
[ ("set int", Right intSet)
, ("set (pair int int)", Right intPairSet)
, ("{int}", Right intSet)
, ("{(pair int int)}", Right intPairSet)
]
where
intSet :: Mo.Ty
intSet =
Mo.Ty (Mo.TSet (Mo.Ty Mo.TInt noAnn)) noAnn
intPairSet :: Mo.Ty
intPairSet =
Mo.Ty (Mo.TSet (Mo.Ty (Mo.TPair noAnn noAnn noAnn noAnn (Mo.Ty Mo.TInt noAnn) (Mo.Ty Mo.TInt Mo.noAnn)) noAnn)) noAnn
----------------------------------------------------------------------------
-- Constructors
----------------------------------------------------------------------------
test_Pair_constructor :: [TestTree]
test_Pair_constructor =
[ testGroup "simple pair constructor" $ testSatisfyingCases P.value
[ ("Pair Unit Unit", Right unitPair)
, ("(Unit, Unit)", Right unitPair)
]
, testGroup "right-combed pair consrtuctor" $ testSatisfyingCases P.value
[ ("Pair Unit 3 \"Hi\"", Right unitPairRightCombed)
, ("(Unit, 3, \"Hi\")", Right unitPairRightCombed)
]
]
where
unitPair :: Mo.Value' Mo.ParsedOp
unitPair = Mo.ValuePair Mo.ValueUnit Mo.ValueUnit
unitPairRightCombed :: Mo.Value' Mo.ParsedOp
unitPairRightCombed = Mo.ValuePair Mo.ValueUnit (Mo.ValuePair (Mo.ValueInt 3) (Mo.ValueString "Hi"))
----------------------------------------------------------------------------
-- Comments
----------------------------------------------------------------------------
test_block_comment :: [TestTree]
test_block_comment =
testSatisfyingCases PL.mSpace $
[ "/* */"
, " /* */"
, "/* */ "
, "/* */;"
, "/* */ ;"
, "/* */\n;"
]
`zip` repeat (Right ())
----------------------------------------------------------------------------
-- Delimiters
----------------------------------------------------------------------------
test_mandatory_spaces :: [TestTree]
test_mandatory_spaces =
[ testGroup "delimiters inside single value" $ testSatisfyingCasesPredicate P.value
[ ("Pair 1Unit", isLeft)
, ("Pair 1/*a*/2", isRight)
-- TODO [#744]: The next two cases should be both
-- either valid expressions or invalid, depending on
-- the fact what is an intended behaviour
, ("Pair\"1\"Unit", isLeft)
, ("Pair 1\"2\"", isLeft)
]
, testGroup "delimiters inside single instruction" $ testSatisfyingCasesPredicate P.parsedOp
-- there have to be at least one delimiter
-- between instruction items, either space or block comment
[ ("PUSHint 1", isLeft)
, ("PUSH int1", isLeft)
, ("PUSH int#a\n1", isLeft)
, ("PUSH int/*a*/1", isRight)
, ("PUSH int 1", isRight)
-- TODO [#744]: The next two cases should be both
-- either valid expressions or invalid, depending on
-- the fact what is an intended behaviour
, ("PUSH string\"1\"", isLeft)
, ("PUSH (pair string int) (Pair\"1\"2)", isLeft)
]
, testGroup "delimiters between instructions" $ testSatisfyingCasesPredicate P.ops
-- instructions might not be separated by @;@
-- iff the first one is a sequence @{a; b;...} z@
[ ("{{ } NIL operation {}}", isLeft)
, ("{ DROP SWAP }", isLeft)
, ("{DROP ; SWAP;}", isRight)
, ("{{DROP}SWAP}", isRight)
, ("{DROP; DIP{SWAP}}", isRight)
]
, testGroup "delimiters inside type" $ (:)
-- delimiters inside type: there might be no space after
-- type if it's followed by one of @, | : ] .@
( satisfyingCasePredicate (P.letInner P.parsedOp)
"f :: forall a. '[int] -> '[a,int,...] = {PUSH int 1};" isRight)
( testSatisfyingCasesPredicate P.type_
[ ("(int,int)", isRight)
, ("(string|nat)", isRight)
, ("unit:u", isRight)
, ("[int]", isRight)
]
)
]
----------------------------------------------------------------------------
-- Others
----------------------------------------------------------------------------
test_printComment :: [TestTree]
test_printComment = testSatisfyingCases P.printComment
[ ( "\"Sides are %[0] x %[1]\""
, Right (PrintComment [Left "Sides are ", Right (StackRef 0), Left " x ", Right (StackRef 1)])
)
, ( "\"%[0] x\""
, Right (PrintComment [Right (StackRef 0), Left " x"])
)
, ( "\"%[0]x%[1]\""
, Right (PrintComment [Right (StackRef 0), Left "x", Right (StackRef 1)])
)
, ( "\"%[0]%[1]\""
, Right (PrintComment [Right (StackRef 0), Right (StackRef 1)])
)
, ( "\"xxx\""
, Right (PrintComment [Left "xxx"])
)
, ( "\"\""
, Right (PrintComment [])
)
]
test_parser_exception :: [TestTree]
test_parser_exception =
[ handleCustomError "0x000" P.value OddNumberBytesException
, handleCustomError "Right 0x000" P.value OddNumberBytesException
, 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 (UnsafePositive 2))
, handleCustomError "{ ACCESS 2 2 }" P.codeEntry
(WrongAccessArgs 2 (UnsafePositive 2))
, handleCustomError "{ SET 2 2 }" P.codeEntry
(WrongSetArgs 2 (UnsafePositive 2))
, handleTrivialError "type Store = (BigMap Address Nat, Nat); \ntest :: '[option int] -> '[int]\n= { IF_SOME { nop; } { PUSH int 3 }; };"
(P.letInner P.parsedOp)
(Tokens ('n' :| ""))
]
test_letType :: [TestTree]
test_letType = testSatisfyingCasesPredicate P.letType
[ ("type kek = int", isRight)
-- They used to be prohibited, but now we permit them.
, ("type Parameter = int", isRight)
, ("type Storage = int", isRight)
]
----------------------------------------------------------------------------
-- Helpers
----------------------------------------------------------------------------
checkFile :: Bool -> FilePath -> IO ()
checkFile shouldParse file = do
code <- Utf8.readFile file
case parse P.programExt file code of
Left err
| shouldParse -> assertFailure $ errorBundlePretty err
Right _
| not shouldParse -> assertFailure $ "Managed to parse " <> file
_ -> pass
handleCustomError
:: HasCallStack => Text -> Parser' LetEnv a -> CustomParserException -> TestTree
handleCustomError text parser customException = testCase (toString text) $
case P.parseNoEnv parser codeSrc text of
Right _ -> assertFailure "expecting parser to fail"
Left bundle -> case toList $ bundleErrors bundle of
[FancyError _ (toList -> [ErrorCustom e])] ->
e `shouldBe` customException
_ ->
assertFailure $
"expecting single ErrorCustom, but got " <>
errorBundlePretty bundle
handleTrivialError
:: HasCallStack => Text -> Parser' LetEnv a -> ErrorItem Char -> TestTree
handleTrivialError text parser errorItem = testCase (toString text) $
case P.parseNoEnv parser codeSrc text of
Right _ -> assertFailure "expecting parser to fail"
Left bundle -> case toList $ bundleErrors bundle of
[TrivialError _ e _] ->
e `shouldBe` (Just errorItem)
_ ->
assertFailure $
"expecting single TrivialError, but got " <>
errorBundlePretty bundle
satisfyingCasePredicate
:: Show a
=> Parser' LetEnv a
-> Text
-> (Either (ParseErrorBundle Text CustomParserException) a -> Bool)
-> TestTree
satisfyingCasePredicate parser parsedExpression predicate =
testCase (toString parsedExpression) $
P.parseNoEnv parser codeSrc parsedExpression `shouldSatisfy` predicate
satisfyingCase
:: (Eq a, Show a)
=> Parser' LetEnv a
-> Text
-> Either (ParseErrorBundle Text CustomParserException) a
-> TestTree
satisfyingCase parser parsedExpression expected =
satisfyingCasePredicate parser parsedExpression (== expected)
testSatisfyingCases
:: (Eq a, Show a)
=> Parser' LetEnv a
-> [(Text, Either (ParseErrorBundle Text CustomParserException) a)]
-> [TestTree]
testSatisfyingCases parser = map (uncurry $ satisfyingCase parser)
testSatisfyingCasesPredicate
:: Show a
=> Parser' LetEnv a
-> [(Text, Either (ParseErrorBundle Text CustomParserException) a -> Bool)]
-> [TestTree]
testSatisfyingCasesPredicate parser = map (uncurry $ satisfyingCasePredicate parser)