cleveland-0.1.0: morley-test/Test/Parser.hs
-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ
module Test.Parser
( unit_Parse_contracts
, unit_Parse_bad_contracts
, unit_Value
, unit_string_literal
, unit_annotation
, unit_IF
, unit_MAP
, unit_PAIR
, unit_UNPAIR
, unit_pair_type
, unit_Right_combed_pair_type
, unit_Right_combed_pair_type_with_annotations
, unit_tuple_type
, unit_or_type
, unit_lambda_type
, unit_list_type
, unit_set_type
, unit_Pair_constructor
, unit_Right_combed_Pair_constructor
, unit_PrintComment
, unit_ParserException
, unit_letType
, unit_block_comment
, unit_UNPAPAIR
) where
import qualified Data.List.NonEmpty as NE
import qualified Data.Text.IO.Utf8 as Utf8 (readFile)
import Test.Hspec.Expectations (Expectation, expectationFailure, shouldBe, shouldSatisfy)
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.Untyped as Mo
import Morley.Util.Positive
import Test.Cleveland.Instances ()
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 <- Utf8.readFile 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 codeSrc "{}" `shouldBe`
Right Mo.ValueNil
P.parseNoEnv P.value codeSrc "{PUSH int 5;}" `shouldBe`
(Right . ValueLambda $ NE.fromList
[Mo.Prim (Mo.PUSH noAnn (Mo.Ty Mo.TInt noAnn) (Mo.ValueInt 5)) (srcPos 0 1)]
)
P.parseNoEnv P.value codeSrc "{1; 2}" `shouldBe`
(Right . Mo.ValueSeq $ NE.fromList
[Mo.ValueInt 1, Mo.ValueInt 2]
)
P.parseNoEnv P.value codeSrc "{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 codeSrc "{DIP DROP;}" `shouldBe`
Right (Mo.ValueLambda (Mo.Prim (Mo.DIP [Mo.Prim Mo.DROP (srcPos 0 5)]) (srcPos 0 1) :| []))
P.parseNoEnv P.value codeSrc "{DIP DROP;somecontent}" `shouldSatisfy` isLeft
P.parseNoEnv P.value codeSrc "{{ }; {}; {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.Ty Mo.TInt noAnn) (Mo.ValueInt 5)) (srcPos 0 11)
, Mo.Prim Mo.DROP (srcPos 0 23)] (srcPos 0 10)
]
))
P.parseNoEnv P.value codeSrc "{{}; {}; {5}}" `shouldBe`
Right (Mo.ValueSeq (Mo.ValueNil :| [Mo.ValueNil, Mo.ValueSeq (Mo.ValueInt 5 :| [])]))
P.parseNoEnv P.value codeSrc "{{}; {5}; {Push int 5}}" `shouldSatisfy` isLeft
unit_string_literal :: Expectation
unit_string_literal = do
P.parseNoEnv P.stringLiteral codeSrc "\"\"" `shouldSatisfy` isRight
P.parseNoEnv P.stringLiteral codeSrc "\" \\n \"" `shouldSatisfy` isRight
P.parseNoEnv P.stringLiteral codeSrc "\"abacaba \\t \n\n\r a\"" `shouldSatisfy` isLeft
P.parseNoEnv P.stringLiteral codeSrc "\"abacaba \\t \\n\\n\\r" `shouldSatisfy` isLeft
unit_annotation :: Expectation
unit_annotation = do
P.parseNoEnv PA.noteV codeSrc "@" `shouldSatisfy` isRight
P.parseNoEnv PA.noteV codeSrc "@_" `shouldSatisfy` isRight
P.parseNoEnv PA.noteV codeSrc "@a." `shouldSatisfy` isRight
P.parseNoEnv PA.noteV codeSrc "@7a" `shouldSatisfy` isRight
P.parseNoEnv PA.noteV codeSrc "@.a" `shouldSatisfy` isLeft
P.parseNoEnv PA.noteV codeSrc "@@@" `shouldSatisfy` isLeft
P.parseNoEnv PA.noteV codeSrc "@a b" `shouldSatisfy` isLeft
P.parseNoEnv PA.noteV codeSrc "@a\\" `shouldSatisfy` isLeft
-- TODO [#48] these are special annotations and should not always be accepted
P.parseNoEnv PA.noteV codeSrc "@%" `shouldSatisfy` isRight
P.parseNoEnv PA.noteV codeSrc "@%%" `shouldSatisfy` isRight
unit_IF :: Expectation
unit_IF = do
P.parseNoEnv P.codeEntry codeSrc "{IF {} {};}" `shouldBe`
Prelude.Right [Mo.Prim (Mo.IF [] []) (srcPos 0 1)]
P.parseNoEnv P.codeEntry codeSrc "{IFEQ {} {};}" `shouldBe`
Prelude.Right [Mo.Mac (Mo.IFX (Mo.EQ noAnn) [] []) (srcPos 0 1)]
P.parseNoEnv P.codeEntry codeSrc "{IFCMPEQ {} {};}" `shouldBe`
Prelude.Right [Mo.Mac (Mo.IFCMP (Mo.EQ noAnn) noAnn [] []) (srcPos 0 1)]
unit_MAP :: Expectation
unit_MAP = do
parseNoEnv P.codeEntry codeSrc "{MAP {};}" `shouldBe`
Prelude.Right [Mo.Prim (Mo.MAP noAnn []) (srcPos 0 1)]
parseNoEnv P.codeEntry codeSrc "{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 codeSrc "{PAIR;}" `shouldBe`
Prelude.Right [Mo.Prim (PAIR noAnn noAnn noAnn noAnn) (srcPos 0 1)]
P.parseNoEnv P.codeEntry codeSrc "{PAIR %a;}" `shouldBe`
Prelude.Right [Mo.Prim (PAIR noAnn noAnn "a" noAnn) (srcPos 0 1)]
P.parseNoEnv P.codeEntry codeSrc "{PAIR %0;}" `shouldBe`
Prelude.Right [Mo.Prim (PAIR noAnn noAnn "0" noAnn) (srcPos 0 1)]
P.parseNoEnv P.codeEntry codeSrc "{PAPAIR;}" `shouldBe`
Prelude.Right
[flip Mac (srcPos 0 1) $
PAPAIR (P (F noAnn) (P (F noAnn) (F noAnn)))
noAnn noAnn
]
unit_UNPAPAIR :: Expectation
unit_UNPAPAIR = do
let unpapair = Mo.Mac (UNPAPAIR (UP UF (UP UF UF))) (srcPos 0 1)
P.parseNoEnv P.codeEntry "" "{UNPAPAIR @v1 @v2 @v3 @v4 @v5 %f1 %f2 %f3 %f4 %f5;}" `shouldBe`
Prelude.Right [unpapair]
P.parseNoEnv P.codeEntry "" "{UNPAPAIR @a %b @c %d %e @f;}" `shouldBe`
Prelude.Right [unpapair]
P.parseNoEnv P.codeEntry "" "{UNPAPAIR;}" `shouldBe`
Prelude.Right [unpapair]
unit_UNPAIR :: Expectation
unit_UNPAIR = do
P.parseNoEnv P.codeEntry codeSrc "{UNPAIR;}" `shouldBe`
Prelude.Right [Mo.Prim (UNPAIR "" "" "" "") (srcPos 0 1)]
P.parseNoEnv P.codeEntry codeSrc "{UNPAIR %a;}" `shouldBe`
Prelude.Right [Mo.Prim (UNPAIR "" "" "a" "") (srcPos 0 1)]
P.parseNoEnv P.codeEntry codeSrc "{UNPAIR @a;}" `shouldBe`
Prelude.Right [Mo.Prim (UNPAIR "a" "" "" "") (srcPos 0 1)]
P.parseNoEnv P.codeEntry codeSrc "{UNPAIR @a %b;}" `shouldBe`
Prelude.Right [Mo.Prim (UNPAIR "a" "" "b" "") (srcPos 0 1)]
P.parseNoEnv P.codeEntry codeSrc "{UNPAIR %b @a;}" `shouldBe`
Prelude.Right [Mo.Prim (UNPAIR "a" "" "b" "") (srcPos 0 1)]
P.parseNoEnv P.codeEntry codeSrc "{UNPAIR @a @b;}" `shouldBe`
Prelude.Right [Mo.Prim (UNPAIR "a" "b" "" "") (srcPos 0 1)]
P.parseNoEnv P.codeEntry codeSrc "{UNPAIR %c %d;}" `shouldBe`
Prelude.Right [Mo.Prim (UNPAIR "" "" "c" "d") (srcPos 0 1)]
P.parseNoEnv P.codeEntry codeSrc "{UNPAIR @a @b %c;}" `shouldBe`
Prelude.Right [Mo.Prim (UNPAIR "a" "b" "c" "") (srcPos 0 1)]
P.parseNoEnv P.codeEntry codeSrc "{UNPAIR @a @b %c %d;}" `shouldBe`
Prelude.Right [Mo.Prim (UNPAIR "a" "b" "c" "d") (srcPos 0 1)]
P.parseNoEnv P.codeEntry codeSrc "{UNPAIR %c %d @a;}" `shouldBe`
Prelude.Right [Mo.Prim (UNPAIR "a" "" "c" "d") (srcPos 0 1)]
P.parseNoEnv P.codeEntry codeSrc "{UNPAIR %c %d @a @b;}" `shouldBe`
Prelude.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 ('@' :| ""))
unit_pair_type :: Expectation
unit_pair_type = do
P.parseNoEnv P.type_ codeSrc "pair unit unit" `shouldBe` Right unitPair
P.parseNoEnv P.type_ codeSrc "(unit, unit)" `shouldBe` Right unitPair
P.parseNoEnv P.type_ codeSrc "(key, (int, (string, bool)))"
`shouldSatisfy` isRight
P.parseNoEnv P.type_ codeSrc "(signature, chain_id, string, bool)"
`shouldSatisfy` isRight
where
unitPair :: Mo.Ty
unitPair =
Mo.Ty (Mo.TPair noAnn noAnn noAnn noAnn (Mo.Ty Mo.TUnit noAnn) (Mo.Ty Mo.TUnit noAnn)) noAnn
unit_Right_combed_pair_type :: Expectation
unit_Right_combed_pair_type = do
P.parseNoEnv P.type_ codeSrc "pair unit int string" `shouldBe` Right rightCombPair
P.parseNoEnv P.type_ codeSrc "(unit, int, string)" `shouldBe` Right rightCombPair
where
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
unit_Right_combed_pair_type_with_annotations :: Expectation
unit_Right_combed_pair_type_with_annotations = do
P.parseNoEnv P.type_ codeSrc "pair :t (unit :t1 %x) (int :t2 %y) (string %z :t3)" `shouldBe` Right rightCombPairWithAnns
P.parseNoEnv P.type_ codeSrc "(unit :t1 %x, int :t2 %y, string %z :t3) :t" `shouldBe` Right rightCombPairWithAnns
where
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"
unit_tuple_type :: Expectation
unit_tuple_type = do
P.parseNoEnv P.type_ codeSrc "(int, int, bool, unit, nat)"
`shouldBe` Right (typair (typair tyint tyint) (typair tybool (typair tyunit tynat)))
P.parseNoEnv P.type_ codeSrc
"(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 -> Ty
bigPair n | n == 0 = tynat
bigPair n = typair tynat (bigPair (n - 1))
unit_or_type :: Expectation
unit_or_type = do
P.parseNoEnv P.type_ codeSrc "or unit unit" `shouldBe` Right unitOr
P.parseNoEnv P.type_ codeSrc "(unit | unit)" `shouldBe` Right unitOr
P.parseNoEnv P.type_ codeSrc "(chain_id | (int | (string | bool)))"
`shouldSatisfy` isRight
P.parseNoEnv P.type_ codeSrc "or unit unit kek"
`shouldSatisfy` isLeft
where
unitOr :: Mo.Ty
unitOr =
Mo.Ty (Mo.TOr noAnn noAnn (Mo.Ty Mo.TUnit noAnn) (Mo.Ty Mo.TUnit noAnn)) noAnn
unit_lambda_type :: Expectation
unit_lambda_type = do
P.parseNoEnv P.type_ codeSrc "lambda unit unit" `shouldBe` Right lambdaUnitUnit
P.parseNoEnv P.type_ codeSrc "\\unit -> unit" `shouldBe` Right lambdaUnitUnit
P.parseNoEnv P.type_ codeSrc "lambda int (signature, int)" `shouldSatisfy` isRight
where
lambdaUnitUnit :: Mo.Ty
lambdaUnitUnit =
Mo.Ty (Mo.TLambda (Mo.Ty Mo.TUnit noAnn) (Mo.Ty Mo.TUnit noAnn)) noAnn
unit_list_type :: Expectation
unit_list_type = do
P.parseNoEnv P.type_ codeSrc "list unit" `shouldBe` Right unitList
P.parseNoEnv P.type_ codeSrc "[unit]" `shouldBe` Right unitList
P.parseNoEnv P.type_ codeSrc "[(key, key)]" `shouldSatisfy` isRight
where
unitList :: Mo.Ty
unitList =
Mo.Ty (Mo.TList (Mo.Ty Mo.TUnit noAnn)) noAnn
unit_set_type :: Expectation
unit_set_type = do
P.parseNoEnv P.type_ codeSrc "set int" `shouldBe` Right intSet
P.parseNoEnv P.type_ codeSrc "set (pair int int)" `shouldBe` Right intPairSet
P.parseNoEnv P.type_ codeSrc "{int}" `shouldBe` Right intSet
P.parseNoEnv P.type_ codeSrc "{(pair int int)}" `shouldBe` 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
unit_Pair_constructor :: Expectation
unit_Pair_constructor = do
P.parseNoEnv P.value codeSrc "Pair Unit Unit" `shouldBe` Right unitPair
P.parseNoEnv P.value codeSrc "(Unit, Unit)" `shouldBe` Right unitPair
where
unitPair :: Mo.Value' Mo.ParsedOp
unitPair = Mo.ValuePair Mo.ValueUnit Mo.ValueUnit
unit_Right_combed_Pair_constructor :: Expectation
unit_Right_combed_Pair_constructor = do
P.parseNoEnv P.value codeSrc "Pair Unit 3 \"Hi\"" `shouldBe` Right unitPair
P.parseNoEnv P.value codeSrc "(Unit, 3, \"Hi\")" `shouldBe` Right unitPair
where
unitPair :: Mo.Value' Mo.ParsedOp
unitPair = Mo.ValuePair Mo.ValueUnit (Mo.ValuePair (Mo.ValueInt 3) (Mo.ValueString "Hi"))
unit_PrintComment :: Expectation
unit_PrintComment = do
P.parseNoEnv P.printComment codeSrc "\"Sides are %[0] x %[1]\"" `shouldBe`
Right (PrintComment [Left "Sides are ", Right (StackRef 0), Left " x ", Right (StackRef 1)])
P.parseNoEnv P.printComment codeSrc "\"%[0] x\"" `shouldBe`
Right (PrintComment [Right (StackRef 0), Left " x"])
P.parseNoEnv P.printComment codeSrc "\"%[0]x%[1]\"" `shouldBe`
Right (PrintComment [Right (StackRef 0), Left "x", Right (StackRef 1)])
P.parseNoEnv P.printComment codeSrc "\"%[0]%[1]\"" `shouldBe`
Right (PrintComment [Right (StackRef 0), Right (StackRef 1)])
P.parseNoEnv P.printComment codeSrc "\"xxx\"" `shouldBe`
Right (PrintComment [Left "xxx"])
P.parseNoEnv P.printComment codeSrc "\"\"" `shouldBe`
Right (PrintComment [])
unit_ParserException :: Expectation
unit_ParserException = do
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' :| ""))
handleCustomError
:: HasCallStack => Text -> Parser a -> CustomParserException -> Expectation
handleCustomError text parser customException =
case P.parseNoEnv parser codeSrc 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
handleTrivialError
:: HasCallStack => Text -> Parser a -> ErrorItem Char -> Expectation
handleTrivialError text parser errorItem =
case P.parseNoEnv parser codeSrc text of
Right _ -> expectationFailure "expecting parser to fail"
Left bundle -> case toList $ bundleErrors bundle of
[TrivialError _ e _] ->
e `shouldBe` (Just errorItem)
_ ->
expectationFailure $
"expecting single TrivialError, but got " <>
errorBundlePretty bundle
unit_letType :: Expectation
unit_letType = do
P.parseNoEnv P.letType codeSrc "type kek = int" `shouldSatisfy` isRight
-- They used to be prohibited, but now we permit them.
P.parseNoEnv P.letType codeSrc "type Parameter = int" `shouldSatisfy` isRight
P.parseNoEnv P.letType codeSrc "type Storage = int" `shouldSatisfy` isRight
unit_block_comment :: Expectation
unit_block_comment =
forM_ validBlockComments $ \blockComment ->
P.parseNoEnv PL.mSpace codeSrc blockComment `shouldBe` Right ()
where
validBlockComments =
[ "/* */"
, " /* */"
, "/* */ "
, "/* */;"
, "/* */ ;"
, "/* */\n;"
]