Interpreter.hs

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

module Test.Lorentz.Interpreter
  ( test_Entry_points_lookup
  , test_Entry_points_calling
  ) where

import System.FilePath ((</>))
import Test.Tasty (TestTree, testGroup)

import Lorentz (EpdPlain, HasAnnotation, ParameterHasEntrypoints(..), toAddress)
import Morley.Michelson.Text
import Morley.Michelson.Typed (IsoValue(..))
import qualified Morley.Michelson.Typed as T
import qualified Morley.Michelson.Untyped as U
import Morley.Tezos.Address
import Test.Cleveland
import Test.Cleveland.Michelson (testTreesWithTypedContract)

data Contract1Parameter
  = Contract11 Integer
  | Contract12 MText
  deriving stock Generic
  deriving anyclass (IsoValue, HasAnnotation)

data Self1Parameter
  = Self11 Integer
  | Self12 ()
  deriving stock Generic
  deriving anyclass (IsoValue, HasAnnotation)

instance ParameterHasEntrypoints Contract1Parameter where
  type ParameterEntrypointsDerivation Contract1Parameter = EpdPlain

instance ParameterHasEntrypoints Self1Parameter where
  type ParameterEntrypointsDerivation Self1Parameter = EpdPlain

test_Entry_points_lookup :: IO [TestTree]
test_Entry_points_lookup =
  testTreesWithTypedContract (dir </> "call1.mtz") $ \call1 ->
  testTreesWithTypedContract (dir </> "call2.mtz") $ \call2 ->
  testTreesWithTypedContract (dir </> "call3.mtz") $ \call3 ->
  testTreesWithTypedContract (dir </> "call4.mtz") $ \call4 ->
  testTreesWithTypedContract (dir </> "call5.mtz") $ \call5 ->
  testTreesWithTypedContract (dir </> "call6.mtz") $ \call6 ->
  testTreesWithTypedContract (dir </> "call7.mtz") $ \call7 ->
  pure
  [ testGroup "Calling contract without default entrypoint"
    [ testScenarioOnEmulator "Calling default entrypoint refers to the root" $
        myScenario call1 simpleContract id
    , testScenarioOnEmulator "Calling some entrypoint refers this entrypoint" $
        myScenario call7 simpleContract id
    ]
  , testGroup "Calling contract with default entrypoint"
    [ testScenarioOnEmulator "Calling default entrypoint works" $
        myScenario call2 defaultEPContract id
    ]
  , testGroup "Common failures"
    [ testScenarioOnEmulator "Fails on type mismatch" $
        myScenario call1 defaultEPContract $ expectFailedWith ()
    , testScenarioOnEmulator "Fails on entrypoint not found" $
        myScenario call3 simpleContract $ expectFailedWith ()
    ]
  , testGroup "Referring entrypoints groups"
    [ testScenarioOnEmulator "Can refer entrypoint group" $
        myScenario call4 complexContract id
    , testScenarioOnEmulator "Works with annotations" $
        myScenario call5 complexContract id
    , testScenarioOnEmulator "Does not work on annotations mismatch in 'contract' type argument" $
        myScenario call6 complexContract $ expectFailedWith ()
    ]
  ]
  where
    myScenario = scenario ... myScenario'
    myScenario'
      :: MonadCleveland caps m
      => T.Contract 'T.TAddress 'T.TUnit
      -> U.Contract
      -> (m () -> m ())
      -> m ()
    myScenario' caller callee validator = do
      hcallee <- originateUntypedSimple "callee" U.ValueUnit callee
      hcaller <- originateTypedSimple @Address @_ @() "caller" () caller
      validator $ transfer $ TransferData
        { tdTo = hcaller
        , tdEntrypoint = U.DefEpName
        , tdParameter = hcallee
        , tdAmount = 100
        }

    dummyCode = U.PrimEx <$>
      [ U.CDR U.noAnn U.noAnn
      , U.NIL U.noAnn U.noAnn (U.Ty U.TOperation U.noAnn)
      , U.PAIR U.noAnn U.noAnn U.noAnn U.noAnn
      ]

    dummyContract ty = U.Contract (par ty) storageTy dummyCode U.PSC []
    simpleContract = dummyContract contractSimpleTy
    defaultEPContract = dummyContract contractWithDefTy
    complexContract = dummyContract contractComplexTy

    dir = entrypointsDir
    par ty = U.ParameterType ty U.noAnn
    storageTy = U.Ty U.TUnit U.noAnn
    contractSimpleTy =
      U.Ty (U.TOr "a" "b" (U.Ty U.TInt U.noAnn) (U.Ty U.TNat U.noAnn))
             U.noAnn
    contractComplexTy =
      U.Ty (U.TOr "s" "t" (U.Ty U.TString U.noAnn) contractSimpleTy)
             U.noAnn
    contractWithDefTy =
      U.Ty (U.TOr "a" "default" (U.Ty U.TNat U.noAnn) (U.Ty U.TString U.noAnn))
             U.noAnn

test_Entry_points_calling :: IO [TestTree]
test_Entry_points_calling =
  pure
  [ testScenario "Calling some entrypoint in CONTRACT" $ scenario do
      call1 <- importContract @Address @_ @() $ dir </> "call1.mtz"
      callerRef <- originateSimple "caller" () call1

      contract1 <- importContract @Contract1Parameter @_ @() $ dir </> "contract1.mtz"
      targetRef <- originateSimple "target" 0 contract1

      transfer TransferData
        { tdTo = callerRef
        , tdAmount = 1
        , tdEntrypoint = T.DefEpName
        , tdParameter = toAddress targetRef
        }

      getStorage @Integer targetRef @@== 5

  , testScenario "Calling some entrypoint in SELF" $ scenario do
      self1 <- importContract @Self1Parameter @_ @() $ dir </> "self1.mtz"
      contractRef <- originateSimple "self" 0 self1

      transfer TransferData
        { tdTo = contractRef
        , tdAmount = 1
        , tdEntrypoint = T.DefEpName
        , tdParameter = Right @Integer ()
        }

      getStorage @Integer contractRef @@== 5
  ]
  where
    dir = entrypointsDir

entrypointsDir :: FilePath
entrypointsDir = ".." </> ".." </> "contracts" </> "entrypoints"