cleveland-0.1.1: morley-test/Test/Morley/Expression.hs
-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA
-- | Tests for 'Morley.Micheline.Expression'.
module Test.Morley.Expression
( test_Roundtrip_binary
, test_Roundtrip_expression
, test_Roundtrip_JSON
, test_ToJSON_omits_empty_lists
, test_fromExpression
, test_toExpression
) where
import Unsafe qualified (fromJust)
import Data.Aeson
(FromJSON, Result(Error, Success), ToJSON(toJSON), Value(String), eitherDecode, encode, fromJSON,
object, (.=))
import Data.Aeson.QQ (aesonQQ)
import Data.Default (def)
import Data.Map qualified as Map
import Data.Set qualified as Set
import Data.Singletons (demote)
import Data.Text qualified as T
import Hedgehog (Gen)
import Test.Hspec.Expectations (shouldBe)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (Assertion, assertFailure, testCase, (@?=))
import Hedgehog.Gen.Michelson.Typed (genSimpleInstr, genValueInt, genValueMutez, genValueUnit)
import Hedgehog.Gen.Michelson.Untyped (genValidType)
import Hedgehog.Gen.Morley.Micheline qualified as M
import Morley.Micheline qualified as M
import Morley.Michelson.Parser (notes)
import Morley.Michelson.Text (MText)
import Morley.Michelson.Typed qualified as T
import Morley.Michelson.Untyped qualified as U
import Morley.Tezos.Core (Mutez)
import Test.Cleveland.Instances ()
import Test.Cleveland.Util (fromHex)
import Test.Util.Hedgehog (roundtripTree)
testJSON
:: forall a. (Eq a, Show a, ToJSON a, FromJSON a, Typeable a)
=> Gen a -> TestTree
testJSON genA = roundtripTree @a genA encode eitherDecode
-- | Test that 'M.fromExpression' is inverse of 'M.toExpression'
roundtripExpression
:: forall a. (Eq a, Show a, M.ToExpression a, M.FromExpression a, Typeable a)
=> Gen a -> TestTree
roundtripExpression genA = roundtripTree @a genA M.toExpression (M.fromExpression)
-- | Test that converting something to 'M.Expression', then to JSON,
-- then decoding this JSON and converting back to the original type
-- returns the original value.
roundtripExpressionJSON
:: forall a. (Eq a, Show a, M.ToExpression a, M.FromExpression a, Typeable a)
=> Gen a -> TestTree
roundtripExpressionJSON genA = roundtripTree @a genA
(encode . M.toExpression)
(first displayException . M.fromExpression <=< eitherDecode)
testBinary :: Gen M.Expression -> TestTree
testBinary genA = roundtripTree genA M.encodeExpression' M.eitherDecodeExpression
test_Roundtrip_JSON :: [TestTree]
test_Roundtrip_JSON =
[ testJSON M.genExprAnnotation
, testJSON M.genExpression
, testJSON M.genMichelinePrimAp
, roundtripExpressionJSON @(T.Value $ T.ToT Integer) genValueInt
, roundtripExpressionJSON @(T.Value $ T.ToT Mutez) genValueMutez
, roundtripExpressionJSON @(T.Value $ T.ToT ()) genValueUnit
, roundtripExpressionJSON @(T.Instr '[T.ToT Mutez] '[T.ToT Mutez]) genSimpleInstr
, roundtripExpressionJSON (T.fromUType <$> genValidType)
, roundtripExpressionJSON genValidType
]
test_ToJSON_omits_empty_lists :: TestTree
test_ToJSON_omits_empty_lists =
testCase "ToJSON omits empty lists" $ do
let actual = toJSON . M.toExpression $ T.toVal (Nothing :: Maybe Integer)
let expected = object ["prim" .= String "None"]
actual @?= expected
test_Roundtrip_binary :: [TestTree]
test_Roundtrip_binary =
[ testBinary M.genExpression
]
test_Roundtrip_expression :: [TestTree]
test_Roundtrip_expression =
[ roundtripExpression @(T.Value $ T.ToT Integer) genValueInt
, roundtripExpression @(T.Value $ T.ToT Mutez) genValueMutez
, roundtripExpression @(T.Value $ T.ToT ()) genValueUnit
, roundtripExpression @(T.Instr '[T.ToT Mutez] '[T.ToT Mutez]) genSimpleInstr
, roundtripExpression @T.T (T.fromUType <$> genValidType)
, roundtripExpression genValidType
]
test_fromExpression :: [TestTree]
test_fromExpression =
-- These michelson expressions are generated using commands like the following:
--
-- > tezos-client convert data 'Pair 1 2 "Hi"' from michelson to json
-- > tezos-client convert data 'pair int nat string' from michelson to json
[ testGroup "Value t"
[ testCase "Converting 'Pair' expression with >2 args into right-combed pair" $ do
fromExpressionTest
(T.toVal @(Integer, (Natural, MText)) (1, (2, "Hi")))
[aesonQQ|
{ "prim": "Pair", "args": [ { "int": "1" }, { "int": "2" }, { "string": "Hi" } ] }
|]
, testCase "Converting nested 'Pair' expression into right-combed pair" $ do
fromExpressionTest
(T.toVal @(Integer, (Natural, MText)) (1, (2, "Hi")))
[aesonQQ|
{ "prim": "Pair",
"args":
[ { "int": "1" },
{ "prim": "Pair", "args": [ { "int": "2" }, { "string": "Hi" } ] } ]
}
|]
, testCase "Converting list expression into right-combed pair" $ do
fromExpressionTest
(T.toVal @(Integer, (Natural, MText)) (1, (2, "Hi")))
[aesonQQ|
[ { "int": "1" }, { "int": "2" }, { "string": "Hi" } ]
|]
]
, testGroup "Type"
[ testCase "Converting 'pair' type expression with >2 args into right-combed pair type" $ do
fromExpressionTest
(T.toUType $ demote @(T.ToT (Integer, (Natural, MText))))
[aesonQQ|
{ "prim": "pair",
"args": [ { "prim": "int" }, { "prim": "nat" }, { "prim": "string" } ] }
|]
, testCase "Converting nested 'pair' type expression into right-combed pair type" $ do
fromExpressionTest
(T.toUType $ demote @(T.ToT (Integer, (Natural, MText))))
[aesonQQ|
{ "prim": "pair",
"args":
[ { "prim": "int" },
{ "prim": "pair", "args": [ { "prim": "nat" }, { "prim": "string" } ] } ] }
|]
]
, testGroup "Contract"
[ testCase "Conversion of contract with duplicated 'storage' block fails" $ do
fromExpressionFailWithPredicateTest @U.Contract
(T.isInfixOf "Something's wrong with top-level contract blocks")
[aesonQQ|
[ { "prim": "storage", "args": [ { "prim": "unit" } ] },
{ "prim": "parameter", "args": [ { "prim": "unit" } ] },
{ "prim": "storage", "args": [ { "prim": "unit" } ] } ]
|]
, testCase "Conversion of contract with absence one of blocks fails" $ do
fromExpressionFailWithPredicateTest @U.Contract
(T.isInfixOf "Something's wrong with top-level contract blocks")
[aesonQQ|
[ { "prim": "storage", "args": [ { "prim": "unit" } ] },
{ "prim": "storage", "args": [ { "prim": "unit" } ] },
{ "prim": "code",
"args":
[ [ { "prim": "DROP" }, { "prim": "UNIT" },
{ "prim": "NIL", "args": [ { "prim": "operation" } ] },
{ "prim": "PAIR" } ] ] } ]
|]
, testCase "Conversion of contract with invalid block arguments count fails" $ do
fromExpressionFailWithPredicateTest @U.Contract
(T.isInfixOf "Expected 'storage' block without annotations and exactly 1 argument")
[aesonQQ|
[ { "prim": "storage",
"args": [ { "prim": "unit"}, {"prim": "int"} ] },
{ "prim": "parameter", "args": [ { "prim": "unit" } ] },
{ "prim": "code",
"args":
[ [ { "prim": "DROP" }, { "prim": "UNIT" },
{ "prim": "NIL", "args": [ { "prim": "operation" } ] },
{ "prim": "PAIR" } ] ] } ]
|]
, testCase "Conversion of contract with error inside block fails" $ do
fromExpressionFailWithPredicateTest @U.Contract
(T.isInfixOf "Expected a type")
[aesonQQ|
[ { "prim": "storage",
"args": [ { "prim": "unit", "args": [ { "prim": "int" } ] } ] },
{ "prim": "parameter", "args": [ { "prim": "unit" } ] },
{ "prim": "code",
"args":
[ [ { "prim": "DROP" }, { "prim": "UNIT" },
{ "prim": "NIL", "args": [ { "prim": "operation" } ] },
{ "prim": "PAIR" } ] ] } ]
|]
, testCase "Conversion of contract with parameter which contains more than 1 root ann" $ do
fromExpressionFailWithPredicateTest @U.Contract
(T.isInfixOf "Expected parameter with at most 1 root annotation")
[aesonQQ|
[ { "prim": "storage", "args": [ { "prim": "unit" } ] },
{ "prim": "parameter",
"args": [ { "prim": "unit", "annots": [ "%root1", "%root2" ] } ]},
{ "prim": "code",
"args":
[ [ { "prim": "DROP" }, { "prim": "UNIT" },
{ "prim": "NIL", "args": [ { "prim": "operation" } ] },
{ "prim": "PAIR" } ] ] } ]
|]
]
, testGroup "Annotations"
[ testGroup "Instructions"
[ testCase "Conversion of instruction with extra annotations fails" $ do
fromExpressionFailTest @U.ExpandedInstr
[aesonQQ|
{ "prim": "PAIR",
"annots": [ ":ta", "@va1", "@va2", "%fa1", "%fa2", "%fa3" ] }
|]
, testCase "Conversion of instruction with annotation of unexpected type fails" $ do
fromExpressionFailTest @U.ExpandedInstr
[aesonQQ|
{ "prim": "DUP",
"annots": [ "@va", "%fa" ] }
|]
]
, testGroup "Types"
[ testCase "Conversion of type with extra annotations fails" $ do
fromExpressionFailTest @U.Ty
[aesonQQ| { "prim": "int", "annots": [ ":ta", "%fa" ] } |]
]
]
]
where
fromExpressionTest :: forall t. (Eq t, Show t, M.FromExpression t) => t -> Value -> Assertion
fromExpressionTest expected exprJSON =
case fromJSON @M.Expression exprJSON of
Error err -> assertFailure err
Success expr -> do
actual <- either (assertFailure . displayException) pure $ M.fromExpression @t expr
actual @?= expected
fromExpressionFailTest :: forall t. (M.FromExpression t) => Value -> Assertion
fromExpressionFailTest = fromExpressionFailWithPredicateTest @t (const True)
fromExpressionFailWithPredicateTest
:: forall t.
(HasCallStack, M.FromExpression t)
=> (Text -> Bool)
-> Value
-> Assertion
fromExpressionFailWithPredicateTest p exprJSON =
case fromJSON @M.Expression exprJSON of
Error err -> assertFailure err
Success expr -> case M.fromExpression @t expr of
Right _ -> assertFailure "Test was expected to fail, but it passed"
Left (M.FromExpressionError _ msg) ->
unless (p msg) $
assertFailure $ "Test failed with an unexpected error type:\n " <> toString msg
test_toExpression :: [TestTree]
test_toExpression =
[ testCase "Converting TInt to Expression" $
M.toExpression T.TInt `shouldBe`
M.ExpressionPrim (M.MichelinePrimAp (M.MichelinePrimitive "int") [] [])
, testCase "Converting (TOption TString) to Expression" $
M.toExpression (T.TOption T.TString) `shouldBe`
M.ExpressionPrim
( M.MichelinePrimAp
{ mpaPrim = M.MichelinePrimitive "option"
, mpaArgs = [M.ExpressionPrim
( M.MichelinePrimAp {mpaPrim = M.MichelinePrimitive "string"
, mpaArgs = [], mpaAnnots = [] }
)]
, mpaAnnots = []
}
)
, testCase "Converting Instr (DIP SIZE) to Expression" $
M.toExpression (T.DIP (T.SIZE @'T.TString)) `shouldBe`
M.ExpressionSeq
[ M.ExpressionPrim (M.MichelinePrimAp
{ mpaPrim = M.MichelinePrimitive "DIP"
, mpaArgs = [M.ExpressionSeq [M.ExpressionPrim (M.MichelinePrimAp
{ mpaPrim = M.MichelinePrimitive "SIZE"
, mpaArgs = []
, mpaAnnots = []
})]]
, mpaAnnots = []
})]
, testCase "Converting VInt to Expression" $
M.toExpression @(T.Value $ T.ToT Integer) (T.VInt 12) `shouldBe` M.ExpressionInt 12
, testCase "Converting VPair to Expression" $
M.toExpression @(T.Value $ T.ToT (Integer, Integer))
(T.VPair (T.VInt 12, T.VInt 12)) `shouldBe`
M.ExpressionSeq [M.ExpressionInt 12, M.ExpressionInt 12]
, testCase "Converting VOption (Some) to Expression" $
M.toExpression @(T.Value $ T.ToT (Maybe Integer)) (T.VOption $ Just $ T.VInt 42) `shouldBe`
M.ExpressionPrim
(M.MichelinePrimAp
{ mpaPrim = M.MichelinePrimitive "Some"
, mpaArgs = [M.ExpressionInt 42]
, mpaAnnots = []
})
, testCase "Converting VOption (None) to Expression" $
M.toExpression @(T.Value $ T.ToT (Maybe Integer)) (T.VOption Nothing) `shouldBe`
M.ExpressionPrim
(M.MichelinePrimAp
{ mpaPrim = M.MichelinePrimitive "None"
, mpaArgs = []
, mpaAnnots = []
})
, testCase "Converting VList to Expression" $
M.toExpression @(T.Value $ T.ToT [Integer]) (T.VList [T.VInt 12, T.VInt 12]) `shouldBe`
M.ExpressionSeq [M.ExpressionInt 12, M.ExpressionInt 12]
, testCase "Converting VMap to Expression" $
M.toExpression @(T.Value $ T.ToT (Map Integer Integer))
(T.VMap (Map.fromList [(T.VInt 12, T.VInt 12), (T.VInt 13, T.VInt 13)])) `shouldBe`
M.ExpressionSeq
[ (M.ExpressionPrim
M.MichelinePrimAp
{ mpaPrim = M.MichelinePrimitive "Elt"
, mpaArgs = [M.ExpressionInt 12, M.ExpressionInt 12]
, mpaAnnots = []
}
)
, (M.ExpressionPrim
M.MichelinePrimAp
{ mpaPrim = M.MichelinePrimitive "Elt"
, mpaArgs = [M.ExpressionInt 13, M.ExpressionInt 13]
, mpaAnnots = []
}
)
]
, testCase "Converting VOr (Right) to Expression" $
M.toExpression @(T.Value $ T.ToT (Either Integer Integer)) (T.VOr $ Right $ T.VInt 12) `shouldBe`
M.ExpressionPrim
M.MichelinePrimAp
{ mpaPrim = M.MichelinePrimitive "Right"
, mpaArgs = [M.ExpressionInt 12]
, mpaAnnots = []
}
, testCase "Converting VOr (Left) to Expression" $
M.toExpression @(T.Value $ T.ToT (Either Integer Integer)) (T.VOr $ Left $ T.VInt 12) `shouldBe`
M.ExpressionPrim
M.MichelinePrimAp
{ mpaPrim = M.MichelinePrimitive "Left"
, mpaArgs = [M.ExpressionInt 12]
, mpaAnnots = []
}
, testCase "Converting VSet to Expression" $
M.toExpression @(T.Value $ T.ToT (Set Integer)) (T.VSet $ Set.fromList [T.VInt 1, T.VInt 2]) `shouldBe`
M.ExpressionSeq [M.ExpressionInt 1, M.ExpressionInt 2]
, testCase "Converting VMutez to Expression" $
M.toExpression @(T.Value $ T.ToT Mutez) (T.VMutez $ 12) `shouldBe`
M.ExpressionInt 12
, testCase "Converting VBool to Expression" $
M.toExpression @(T.Value $ T.ToT Bool) (T.VBool True) `shouldBe`
M.ExpressionPrim
(M.MichelinePrimAp
{ mpaPrim = M.MichelinePrimitive "True"
, mpaArgs = []
, mpaAnnots = []
})
, testCase "Converting VContract to Expression" $
M.toExpression @(T.Value $ 'T.TContract 'T.TAddress)
(getSampleValue @('T.TContract 'T.TAddress)) `shouldBe`
M.ExpressionBytes (unsafe $ fromHex "01122d038abd69be91b4b6803f2f098a088e259e7200")
, testCase "Converting VBigMap to Expression" $
M.toExpression @(T.Value $ 'T.TBigMap (T.ToT Integer) (T.ToT Integer))
(T.VBigMap Nothing $ Map.fromList [(T.VInt 1, T.VInt 2), (T.VInt 3, T.VInt 4)]) `shouldBe`
M.ExpressionSeq
[ (M.ExpressionPrim
M.MichelinePrimAp
{ mpaPrim = M.MichelinePrimitive "Elt"
, mpaArgs = [M.ExpressionInt 1, M.ExpressionInt 2]
, mpaAnnots = []
}
)
, (M.ExpressionPrim
M.MichelinePrimAp
{ mpaPrim = M.MichelinePrimitive "Elt"
, mpaArgs = [M.ExpressionInt 3, M.ExpressionInt 4]
, mpaAnnots = []
}
)
]
, testCase "Converting VUnit to Expression" $
M.toExpression @(T.Value 'T.TUnit) T.VUnit `shouldBe`
M.ExpressionPrim (M.MichelinePrimAp
{ mpaPrim = M.MichelinePrimitive "Unit"
, mpaArgs = []
, mpaAnnots = []
})
, testCase "Converting VKey to Expression" $
M.toExpression @(T.Value 'T.TKey) (getSampleValue @('T.TKey)) `shouldBe`
M.ExpressionBytes (unsafe $ fromHex "00aad3f16293766169f7db278c5e0e9db4fb82ffe1cbcc35258059617dc0fec082")
, testCase "Converting VTimestamp to Expression" $
M.toExpression @(T.Value 'T.TTimestamp) (getSampleValue @('T.TTimestamp)) `shouldBe`
M.ExpressionInt 1564142952
, testCase "Converting VAddress to Expression" $
M.toExpression @(T.Value 'T.TAddress) (getSampleValue @('T.TAddress)) `shouldBe`
M.ExpressionBytes (unsafe $ fromHex "01122d038abd69be91b4b6803f2f098a088e259e7200")
, testCase "Converting VChainId to Expression" $
M.toExpression @(T.Value 'T.TChainId) (getSampleValue @('T.TChainId)) `shouldBe`
M.ExpressionBytes (unsafe $ fromHex "458aa837")
, testCase "Converting VSignature to Expression" $
M.toExpression @(T.Value 'T.TSignature) (getSampleValue @('T.TSignature)) `shouldBe`
(M.ExpressionBytes $ unsafe $ fromHex
"91ac1e7fd668854fc7a40feec4034e42c06c068cce10622c607fda232db34c8cf5d8da83098dd89\
\1cd4cb4299b3fa0352ae323ad99b24541e54b91888fdc8201")
, testCase "Converting VKeyHash to Expression" $
M.toExpression @(T.Value 'T.TKeyHash) (getSampleValue @('T.TKeyHash)) `shouldBe`
M.ExpressionBytes (unsafe $ fromHex "0092629ed0afa9cd42835ce09ee2623c1efa0b590d")
, testCase "Converting VBls12381Fr to Expression" $
M.toExpression @(T.Value 'T.TBls12381Fr) (getSampleValue @('T.TBls12381Fr)) `shouldBe`
M.ExpressionBytes (unsafe $ fromHex "0100000000000000000000000000000000000000000000000000000000000000")
, testCase "Converting VLam to Expression" $
M.toExpression @(T.Value $ 'T.TLambda 'T.TUnit 'T.TUnit)
(getSampleValue @('T.TLambda 'T.TUnit 'T.TUnit)) `shouldBe`
M.ExpressionSeq
[ M.ExpressionPrim
(M.MichelinePrimAp
{ mpaPrim = M.MichelinePrimitive "DROP"
, mpaArgs = []
, mpaAnnots = []
}
)
, M.ExpressionPrim
(M.MichelinePrimAp
{ mpaPrim = M.MichelinePrimitive "PUSH"
, mpaArgs =
[ M.ExpressionPrim
(M.MichelinePrimAp
{ mpaPrim = M.MichelinePrimitive "unit"
, mpaArgs = []
, mpaAnnots = []
})
, M.ExpressionPrim
(M.MichelinePrimAp
{ mpaPrim = M.MichelinePrimitive "Unit"
, mpaArgs = []
, mpaAnnots = []
})
]
, mpaAnnots = []
})
]
, testCase "Converting NTPair to Expression" $
M.toExpression [notes|pair :pair (string %a) (int %b :val)|] `shouldBe`
M.ExpressionPrim
(M.MichelinePrimAp
{ mpaPrim = M.MichelinePrimitive "pair"
, mpaArgs =
[ M.ExpressionPrim (M.MichelinePrimAp
{ mpaPrim = M.MichelinePrimitive "string"
, mpaArgs = []
, mpaAnnots = [M.AnnotationField "a"]
})
, M.ExpressionPrim (M.MichelinePrimAp
{ mpaPrim = M.MichelinePrimitive "int"
, mpaArgs = []
, mpaAnnots = [ M.AnnotationType "val", M.AnnotationField "b"]
})
]
, mpaAnnots = [ M.AnnotationType "pair" ]
}
)
, testCase "Converting \"CAR @bar %foo\" to Expression" $
M.toExpression (T.AnnCAR "bar" "foo") `shouldBe`
M.ExpressionSeq
[ M.ExpressionPrim $ M.MichelinePrimAp
{ mpaPrim = M.MichelinePrimitive "CAR"
, mpaArgs = []
, mpaAnnots =
[ M.AnnotationField "foo"
, M.AnnotationVariable "bar"
]
}
]
, testCase "Converting sample contract to Expression" $
M.toExpression sampleContract `shouldBe`
M.ExpressionSeq
[ M.ExpressionPrim (M.MichelinePrimAp
{ mpaPrim = M.MichelinePrimitive "storage"
, mpaArgs = [M.ExpressionPrim (M.MichelinePrimAp {mpaPrim = M.MichelinePrimitive "chain_id", mpaArgs = [], mpaAnnots = []})]
, mpaAnnots = []
})
, M.ExpressionPrim (M.MichelinePrimAp
{ mpaPrim = M.MichelinePrimitive "parameter"
, mpaArgs = [M.ExpressionPrim (M.MichelinePrimAp {mpaPrim = M.MichelinePrimitive "unit", mpaArgs = [], mpaAnnots = []})]
, mpaAnnots = []
})
, M.ExpressionPrim (M.MichelinePrimAp
{ mpaPrim = M.MichelinePrimitive "code"
, mpaArgs = [M.ExpressionSeq
[ M.ExpressionPrim (M.MichelinePrimAp {mpaPrim = M.MichelinePrimitive "DROP", mpaArgs = [], mpaAnnots = []})
, M.ExpressionPrim (M.MichelinePrimAp {mpaPrim = M.MichelinePrimitive "CHAIN_ID", mpaArgs = [], mpaAnnots = []})
, M.ExpressionPrim (M.MichelinePrimAp
{ mpaPrim = M.MichelinePrimitive "NIL"
, mpaArgs =
[ M.ExpressionPrim (M.MichelinePrimAp
{ mpaPrim = M.MichelinePrimitive "operation"
, mpaArgs = []
, mpaAnnots = []
})
]
, mpaAnnots = []
})
, M.ExpressionPrim (M.MichelinePrimAp {mpaPrim = M.MichelinePrimitive "PAIR", mpaArgs = [], mpaAnnots = []})
]]
, mpaAnnots = []
})
]
]
where
sampleContract :: T.Contract 'T.TUnit 'T.TChainId
sampleContract =
let code = T.DROP `T.Seq` T.CHAIN_ID `T.Seq` T.NIL `T.Seq` T.PAIR
in T.Contract
{ cCode = code
, cParamNotes = T.starParamNotes @'T.TUnit
, cStoreNotes = T.starNotes
, cEntriesOrder = U.SPC
, cViews = def
}
getSampleValue :: forall t. (T.SingI t) => T.Value t
getSampleValue = Unsafe.fromJust $ T.sampleTypedValue $ T.sing @t