morley-0.3.0: test/Test/Parser.hs
module Test.Parser
( unit_Parse_contracts
, unit_Value
, unit_string_literal
, unit_IF
, unit_MAP
, unit_PAIR
, unit_pair_type
, unit_or_type
, unit_lambda_type
, unit_list_type
, unit_set_type
, unit_explicitType
, 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)
import Michelson.ErrorPos (srcPos)
import Michelson.Macro as Mo
import Michelson.Parser as P
import Michelson.Untyped as Mo
import Util.IO
import Test.Util.Contracts (getIllTypedContracts, getWellTypedContracts)
unit_Parse_contracts :: Expectation
unit_Parse_contracts = do
files <- mappend <$> getWellTypedContracts <*> getIllTypedContracts
mapM_ checkFile files
where
checkFile :: FilePath -> Expectation
checkFile file = do
code <- readFileUtf8 file
parse P.program file code `shouldSatisfy` isRight
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)]
)
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_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_ "" "(Parameter, (int, (Storage, bool)))"
`shouldSatisfy` isRight
P.parseNoEnv P.type_ "" "(Parameter, Parameter, Storage, 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_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_ "" "Parameter | (int | (Storage | bool)))"
`shouldSatisfy` isRight
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 (Storage, 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_ "" "[(Parameter, Storage)]" `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_explicitType :: Expectation
unit_explicitType = do
P.parseNoEnv P.explicitType "" "Parameter" `shouldSatisfy` isLeft
P.parseNoEnv P.explicitType "" "Storage" `shouldSatisfy` isLeft
P.parseNoEnv P.explicitType "" "List Parameter" `shouldSatisfy` isLeft
P.parseNoEnv P.explicitType "" "Void int Parameter" `shouldSatisfy` isLeft
P.parseNoEnv P.explicitType "" "(Parameter, (int, (bool, Storage)))"
`shouldSatisfy` isLeft
P.parseNoEnv P.explicitType "" "int"
`shouldBe` (Right $ Mo.Type (Mo.Tc Mo.CInt) 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'))
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 _ errorSet] -> case toList errorSet of
[(ErrorCustom e)] -> e `shouldBe` customException
_ -> expectationFailure "expecting single ErrorCustom"
_ -> expectationFailure "expecting single ErrorCustom"
unit_letType :: Expectation
unit_letType = do
P.parseNoEnv P.letType "" "type kek = int" `shouldSatisfy` isRight
P.parseNoEnv P.letType "" "type Parameter = int" `shouldSatisfy` isLeft
P.parseNoEnv P.letType "" "type Storage = int" `shouldSatisfy` isLeft