Expression.hs

-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

-- | Tests for 'Morley.Micheline.Expression'.

module Test.Morley.Expression
  ( test_Roundtrip_binary
  , test_Roundtrip_expression
  , test_Roundtrip_JSON
  , test_toExpression
  ) where

import Data.Aeson (FromJSON, ToJSON, eitherDecode, encode)
import qualified Data.Sequence as Seq
import Hedgehog (Gen)
import Test.Tasty (TestTree)

import Michelson.Test.Gen
import qualified Michelson.Typed as T
import qualified Michelson.Untyped as U
import qualified Morley.Micheline as M
import Test.Util.Hedgehog (roundtripTree)
import Tezos.Core (Mutez)

import Test.Hspec.Expectations (shouldBe)
import Test.Tasty.HUnit (testCase)

testJSON
  :: forall a. (Eq a, Show a, ToJSON a, FromJSON a, Typeable a)
  => Gen a -> TestTree
testJSON genA = roundtripTree @a genA encode eitherDecode

testValue
  :: forall a. (Eq a, Show a, M.ToExpression a, M.FromExpression a, Typeable a)
  => Gen a -> TestTree
testValue genA = roundtripTree @a genA M.toExpression (maybeToRight () . M.fromExpression)

testValueJSON
  :: forall a. (Eq a, Show a, M.ToExpression a, M.FromExpression a, Typeable a)
  => Gen a -> TestTree
testValueJSON genA = roundtripTree @a genA
  (encode . M.toExpression)
  (maybeToRight "error" . 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
  , testValueJSON @(T.Value $ T.ToT Integer) genValueInt
  , testValueJSON @(T.Value $ T.ToT Mutez) genValueMutez
  , testValueJSON @(T.Value $ T.ToT ()) genValueUnit
  ]

test_Roundtrip_binary :: [TestTree]
test_Roundtrip_binary =
  [ testBinary M.genExpression
  ]

test_Roundtrip_expression :: [TestTree]
test_Roundtrip_expression =
  [ testValue @(T.Value $ T.ToT Integer) genValueInt
  , testValue @(T.Value $ T.ToT Mutez) genValueMutez
  , testValue @(T.Value $ T.ToT ()) genValueUnit
  ]

test_toExpression :: [TestTree]
test_toExpression =
  [ testCase "Converting TInt to Expression" $
      M.toExpression T.TInt `shouldBe`
        M.ExpressionPrim (M.MichelinePrimAp (M.MichelinePrimitive "int") mempty mempty)

  , testCase "Converting (TOption TString) to Expression" $
      M.toExpression (T.TOption T.TString) `shouldBe`
        M.ExpressionPrim
          ( M.MichelinePrimAp
            { mpaPrim = M.MichelinePrimitive "option"
            , mpaArgs = Seq.fromList [M.ExpressionPrim
                ( M.MichelinePrimAp {mpaPrim = M.MichelinePrimitive "string"
                , mpaArgs = Seq.fromList [], mpaAnnots = Seq.fromList [] }
                )]
            , mpaAnnots = Seq.fromList []
            }
          )

  , testCase "Converting Instr (DIP SIZE) to Expression" $
      M.toExpression (T.DIP (T.SIZE @'T.TString)) `shouldBe`
        M.ExpressionSeq (Seq.fromList
          [ M.ExpressionPrim (M.MichelinePrimAp
              { mpaPrim = M.MichelinePrimitive "DIP"
              , mpaArgs = Seq.fromList [M.ExpressionSeq (Seq.fromList [M.ExpressionPrim (M.MichelinePrimAp
                  { mpaPrim = M.MichelinePrimitive "SIZE"
                  , mpaArgs = Seq.fromList []
                  , mpaAnnots = Seq.fromList []
                  })])]
              , mpaAnnots = Seq.fromList []
              })]
          )
  , testCase "Converting VInt to Expression" $
      M.toExpression @(T.Value $ T.ToT Integer) (T.VInt 12) `shouldBe` M.ExpressionInt 12

  , testCase "Converting NTPair to Expression" $
      M.toExpression (T.NTPair (U.ann "pair") (U.ann "a") (U.ann "b") (T.NTString U.noAnn) (T.NTInt $ U.ann "val")) `shouldBe`
        M.ExpressionPrim
          (M.MichelinePrimAp
              { mpaPrim = M.MichelinePrimitive "pair"
              , mpaArgs = Seq.fromList
                [ M.ExpressionPrim (M.MichelinePrimAp
                  { mpaPrim = M.MichelinePrimitive "string"
                  , mpaArgs = Seq.fromList []
                  , mpaAnnots = Seq.fromList [M.AnnotationField (U.ann "a") ]})
                , M.ExpressionPrim (M.MichelinePrimAp
                  { mpaPrim = M.MichelinePrimitive "int"
                  , mpaArgs = Seq.fromList []
                  , mpaAnnots = Seq.fromList [ M.AnnotationType (U.ann "val"), M.AnnotationField (U.ann "b")]})
                ]
              , mpaAnnots = Seq.fromList [ M.AnnotationType (U.ann "pair") ]
              }
          )
  , testCase "Converting sample contract to Expression" $
      M.toExpression sampleContract `shouldBe`
        M.ExpressionSeq (Seq.fromList
          [ M.ExpressionPrim (M.MichelinePrimAp
              { mpaPrim = M.MichelinePrimitive "parameter"
              , mpaArgs = Seq.fromList [M.ExpressionPrim (M.MichelinePrimAp {mpaPrim = M.MichelinePrimitive "unit", mpaArgs = Seq.fromList [], mpaAnnots = Seq.fromList [M.AnnotationField (U.ann "")]})]
              , mpaAnnots = Seq.fromList []
              })
          , M.ExpressionPrim (M.MichelinePrimAp
              { mpaPrim = M.MichelinePrimitive "storage"
              , mpaArgs = Seq.fromList [M.ExpressionPrim (M.MichelinePrimAp {mpaPrim = M.MichelinePrimitive "chain_id", mpaArgs = Seq.fromList [], mpaAnnots = Seq.fromList []})]
              , mpaAnnots = Seq.fromList []
              })
          , M.ExpressionPrim (M.MichelinePrimAp
              { mpaPrim = M.MichelinePrimitive "code"
              , mpaArgs = Seq.fromList [M.ExpressionSeq (Seq.fromList
                [ M.ExpressionPrim (M.MichelinePrimAp {mpaPrim = M.MichelinePrimitive "DROP", mpaArgs = Seq.fromList [], mpaAnnots = Seq.fromList []})
                , M.ExpressionPrim (M.MichelinePrimAp {mpaPrim = M.MichelinePrimitive "CHAIN_ID", mpaArgs = Seq.fromList [], mpaAnnots = Seq.fromList []})
                , M.ExpressionPrim (M.MichelinePrimAp
                    { mpaPrim = M.MichelinePrimitive "NIL"
                    , mpaArgs = Seq.fromList
                      [ M.ExpressionPrim (M.MichelinePrimAp
                        { mpaPrim = M.MichelinePrimitive "operation"
                        , mpaArgs = Seq.fromList []
                        , mpaAnnots = Seq.fromList []
                        })
                      ]
                    , mpaAnnots = Seq.fromList []
                    })
                , M.ExpressionPrim (M.MichelinePrimAp {mpaPrim = M.MichelinePrimitive "PAIR", mpaArgs = Seq.fromList [], mpaAnnots = Seq.fromList []})
                ])]
              , mpaAnnots = Seq.fromList []
              })
          ])
  ]
  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
            }