Interpreter.hs

-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

-- TODO [#712]: Remove this next major release
{-# OPTIONS_GHC -Wno-deprecations #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Interpreter
  ( test_basic5
  , test_increment
  , test_fail
  , test_mutez_add_overflow
  , test_mutez_sub_underflow
  , test_basic1
  , test_lsl
  , test_lsr
  , test_FAILWITH
  , test_gas_exhaustion
  , test_add1_list
  , test_Sum_types
  , test_Product_types
  , test_split_bytes
  , test_split_string_simple
  , test_complex_strings
  , test_contract_instr_on_implicit
  , test_map_preserve_stack
  , test_AND_binary
  , test_EDIV
  , test_SELF_address_packing
  , test_fail_callstack
  ) where

import Fmt ((+|), (|+))
import Hedgehog (forAll, property)
import Hedgehog.Gen qualified as Gen
import Hedgehog.Range qualified as Range
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.Hedgehog (testProperty)

import Lorentz (HasEntrypointArg, NiceParameter, NiceParameterFull, NiceStorage)
import Morley.Michelson.ErrorPos (InstrCallStack(..), LetName(..), srcPos)
import Morley.Michelson.Text
import Morley.Michelson.Typed (IsoValue(..), divMich, modMich)
import Morley.Michelson.Typed qualified as T
import Morley.Michelson.Untyped qualified as U
import Morley.Tezos.Address
import Morley.Tezos.Crypto
import Test.Cleveland
import Test.Cleveland.Internal.Abstract (TransferFailure(..), TransferFailureReason(..))
import Test.Cleveland.Michelson (concatTestTrees, testTreesWithTypedContract)
import Test.Cleveland.Michelson.Import
  (testTreesWithTypedContractExt, testTreesWithUntypedContractExt)

import Test.Util.Contracts

catchTransferFailureReason :: (HasCallStack, MonadCleveland caps m) => m a -> m TransferFailureReason
catchTransferFailureReason = fmap tfReason . catchTransferFailure

callSimple
  :: forall cp st caps m.
    ( HasCallStack
    , MonadCleveland caps m
    , HasEntrypointArg cp (EntrypointRef 'Nothing) cp
    , AsRPC st ~ st
    , NiceParameterFull cp, NiceStorage st
    )
  => AliasHint -> T.Contract (ToT cp) (ToT st) -> cp -> st -> m st
callSimple nm contract cp st = do
  handle <- originateTypedSimple @cp @st @() nm st contract
  call handle CallDefault cp
  getStorage handle

callUntyped
  :: forall cp st caps m.
    ( MonadCleveland caps m
    , T.ConstantScope (ToT st)
    , AsRPC st ~ st
    , NiceStorage st, NiceParameter cp
    )
  => AliasHint -> U.Contract -> cp -> st -> m st
callUntyped nm contract cp st = do
  handle <- originateUntypedSimple nm (T.untypeValue $ T.toVal st) contract
  transfer TransferData
    { tdTo = handle
    , tdAmount = 0
    , tdEntrypoint = T.DefEpName
    , tdParameter = cp
    }
  getStorage @st handle

test_basic5 :: IO [TestTree]
test_basic5 =
  testTreesWithTypedContract (contractsDir </> "basic5.tz") $ \contract -> pure
  [ testScenarioOnEmulator "Basic test" $ scenario $
      callSimple "basic5" contract () [1] @@== [13, 100 :: Integer]
  ]

test_increment :: IO [TestTree]
test_increment =
  testTreesWithTypedContract (contractsDir </> "increment.tz") $ \contract -> pure
  [ testScenarioOnEmulator "Basic test" $ scenario $
      callSimple "increment" contract () 23 @@== (24 :: Integer)
  ]

test_fail :: IO [TestTree]
test_fail =
  testTreesWithTypedContract (contractsDir </> "tezos_examples/macros/fail.tz") $ \contract -> pure
  [ testScenarioOnEmulator "Fail test" $ scenario $
      callSimple "fail" contract () () & expectFailedWith ()
  ]

test_mutez_add_overflow :: IO [TestTree]
test_mutez_add_overflow =
  testTreesWithTypedContract (contractsDir </> "mutez_add_overflow.tz") $ \contract -> pure
  [ testScenarioOnEmulator "Mutez add overflow test" $ scenario $
      callSimple "mutez_add_overflow" contract () ()
        & catchTransferFailureReason >>= \case
          MutezArithError T.AddOverflow -> pass
          _ -> failure "expecting another failure reason"
  ]

test_mutez_sub_underflow :: IO [TestTree]
test_mutez_sub_underflow =
  testTreesWithTypedContract (contractsDir </> "mutez_sub_underflow.tz") $ \contract -> pure
  [ testScenarioOnEmulator "Mutez sub underflow test" $ scenario $
      callSimple "mutez_sub_underflow" contract () ()
  ]

test_basic1 :: IO [TestTree]
test_basic1 =
  testTreesWithTypedContract (contractsDir </> "basic1.tz") $ \contract -> pure
  [ testProperty "Random check" $ property $ do
      input <- forAll $ Gen.list (Range.linear 0 100) (Gen.integral (Range.linearFrom 0 -1000 1000))
      testScenarioProps $ scenario $
        callSimple "basic1" contract () input @@== [sum input + 12, 100 :: Integer]
  ]

test_lsl :: IO [TestTree]
test_lsl =
  testTreesWithTypedContract (contractsDir </> "lsl.tz") $ \contract -> pure
  [ testScenarioOnEmulator "LSL shouldn't overflow test" $ scenario $
      callSimple @Natural @Natural "lsl" contract 5 2 @@== 20
  , testScenarioOnEmulator "LSL should overflow test" $ scenario $
      callSimple "lsl" contract (5 :: Natural) (257 :: Natural)
        & expectTransferFailure shiftOverflow
  ]

test_lsr :: IO [TestTree]
test_lsr =
  testTreesWithTypedContract (contractsDir </> "lsr.tz") $ \contract -> pure
  [ testScenarioOnEmulator "LSR shouldn't underflow test" $ scenario $
      callSimple @Natural @Natural "lsr" contract 30 3 @@== 3
  , testScenarioOnEmulator "LSR should underflow test" $ scenario $
      callSimple "lsr" contract (1000 :: Natural) (257 :: Natural)
        & catchTransferFailureReason >>= \case
            ShiftOverflow -> pass
            x -> failure $ "expecting another failure reason, got " +| x |+ ""
  ]

test_FAILWITH :: IO [TestTree]
test_FAILWITH = concatTestTrees
  [ testTreesWithTypedContract (contractsDir </> "failwith_message.tz") $ \contract ->
    pure
    [ testScenarioOnEmulator "Failwith message test" $ scenario $
        let msg = "An error occurred." :: MText
        in callSimple "failwith_message" contract msg ()
          & expectFailedWith msg
    ]
  , testTreesWithTypedContract (contractsDir </> "failwith_message2.tz") $ \contract ->
    pure
    [ testScenarioOnEmulator "Conditional failwith message test" $ scenario do
        let msg = "An error occurred." :: MText
        callSimple "failwith_message2" contract (True, msg) ()
          & expectFailedWith msg

    , testScenarioOnEmulator "Conditional success test" $ scenario do
        let param = (False, "Err" :: MText)
        callSimple "failwith_message2" contract param ()
    ]
  ]

test_gas_exhaustion :: IO [TestTree]
test_gas_exhaustion =
  testTreesWithTypedContract (contractsDir </> "gas_exhaustion.tz") $ \contract -> pure
  [ testScenarioOnEmulator "Contract should fail due to gas exhaustion" $ scenario $
      let dummyStr = "x" :: MText
      in callSimple "gas_exhaustion" contract dummyStr dummyStr
          & catchTransferFailureReason >>= \case
              GasExhaustion -> pass
              e -> failure $ "Expected gas_exhaustion, but got " +| e |+ ""
  ]

test_fail_callstack :: IO [TestTree]
test_fail_callstack =
  testTreesWithUntypedContractExt (contractsDir </> "fail_in_let.mtz") $ \contract -> pure
  [ testScenarioOnEmulator "Should correctly report FAIL instruction position" $ scenario do
      callUntyped "fail_in_let" contract True () & catchTransferFailureReason >>= \case
          FailedWith _ (Just ics) ->
            ics @== InstrCallStack {
                icsCallStack = map LetName ["letfail1", "letfail2", "letfail3"]
              , icsSrcPos = srcPos 5 29
              }
          err -> failure $
            "Expected interpreter to fail with callstack, but it instead errored with " +|
              err |+ ""
  ]

test_add1_list :: IO [TestTree]
test_add1_list =
  testTreesWithTypedContract (contractsDir </> "tezos_examples/attic/add1_list.tz") $ \contract ->
  pure
  [ testProperty "Random check" $ property $ do
      param <- forAll $ Gen.list (Range.linear 0 100) (Gen.integral (Range.linearFrom 0 -1000 1000))
      testScenarioProps $ scenario $
        callSimple @[Integer] @[Integer] "add1_list" contract param param @@== map succ param
  ]

test_Sum_types :: IO [TestTree]
test_Sum_types = concatTestTrees
  [ testTreesWithUntypedContractExt (contractsDir </> "union.mtz") $ \contract -> pure
    [ testGroup "union.mtz: union corresponds to Haskell types properly" $
        let caseTest param = scenario $ callUntyped "union" contract param ()
        in
        [ testScenarioOnEmulator "Case 1" $ caseTest (Case1 3)
        , testScenarioOnEmulator "Case 2" $ caseTest (Case2 "a")
        , testScenarioOnEmulator "Case 3" $ caseTest (Case3 $ Just "b")
        , testScenarioOnEmulator "Case 4" $ caseTest (Case4 $ Left "b")
        , testScenarioOnEmulator "Case 5" $ caseTest (Case5 ["q"])
        ]
    ]
  , testTreesWithUntypedContractExt (contractsDir </> "case.mtz") $ \contract -> pure
    [ testGroup "CASE instruction" $
        let caseTest param expectedStorage = scenario $
              callUntyped "case" contract param ("" :: MText)
                @@== expectedStorage
        in
        [ testScenarioOnEmulator "Case 1" $ caseTest (Case1 5) "int"
        , testScenarioOnEmulator "Case 2" $ caseTest (Case2 "a") "string"
        , testScenarioOnEmulator "Case 3" $ caseTest (Case3 $ Just "aa") "aa"
        , testScenarioOnEmulator "Case 4" $ caseTest (Case4 $ Right "b") "or string string"
        , testScenarioOnEmulator "Case 5" $ caseTest (Case5 $ ["a", "b"]) "ab"
        ]
    ]
  , testTreesWithTypedContractExt (contractsDir </> "tag.mtz") $ \contract -> pure
    [ testScenarioOnEmulator "TAG instruction" $ scenario $
        let expected = mconcat ["unit" :: MText, "o" :: MText, "ab" :: MText, "nat" :: MText, "int" :: MText]
        in callSimple "tag" contract () ("" :: MText) @@== expected
    ]
  ]

test_Product_types :: IO [TestTree]
test_Product_types = concatTestTrees
  [ testTreesWithTypedContractExt (contractsDir </> "access.mtz") $ \contract -> pure
    [ testScenarioOnEmulator "ACCESS instruction" $ scenario $
        callSimple @Tuple1 "access" contract (1, "a", Just "a", Right "a", ["a"]) ()
    ]
  , testTreesWithTypedContractExt (contractsDir </> "set.mtz") $ \contract -> pure
    [ testScenarioOnEmulator "SET instruction" $ scenario $
      let expected = (2, "za", Just "wa", Right "ya", ["ab"]) :: Tuple1
      in callSimple @_ @Tuple1 "set" contract () (1, "a", Just "a", Right "a", ["a", "b"])
          @@== expected
    ]
  , testTreesWithTypedContractExt (contractsDir </> "construct.mtz") $ \contract -> pure
    [ testScenarioOnEmulator "CONSTRUCT instruction" $ scenario $
      let expected = (1, "a", Just "b", Left "q", []) :: Tuple1
      in callSimple @_ @Tuple1 "construct" contract () (0, "", Nothing, Right "", []) @@== expected
    ]
  ]

test_split_bytes :: IO [TestTree]
test_split_bytes =
  testTreesWithTypedContract (contractsDir </> "tezos_examples/opcodes/split_bytes.tz") $
    \contract -> pure
  [ testScenarioOnEmulator "splits given byte sequence into parts" $ scenario $
      let expected = ["\11", "\12", "\13"] :: [ByteString]
      in callSimple "split_bytes" contract ("\11\12\13" :: ByteString) ([] :: [ByteString])
          @@== expected
  ]

test_split_string_simple :: IO [TestTree]
test_split_string_simple =
  testTreesWithTypedContract (contractsDir </> "split_string_simple.tz") $ \contract ->
  pure
  [ testScenarioOnEmulator "applies SLICE instruction" $ scenario do
      let
        oneTest o l str expected =
          callSimple @(Natural, Natural) @(Maybe MText) "split_string_simple"
            contract (o, l) (Just str) @@== expected

      -- These values have been tested using tezos-client
      oneTest 0 0 "aaa" (Just "")
      oneTest 2 0 "aaa" (Just "")
      oneTest 3 0 "aaa" Nothing
      oneTest 0 5 "aaa" Nothing
      oneTest 1 2 "abc" (Just "bc")
      oneTest 1 1 "abc" (Just "b")
      oneTest 2 1 "abc" (Just "c")
      oneTest 2 2 "abc" Nothing
      oneTest 1 1 "\"\"" (Just "\"")
      oneTest 1 2 "a\n" Nothing
  ]

test_complex_strings :: IO [TestTree]
test_complex_strings =
  testTreesWithTypedContract (contractsDir </> "complex_strings.tz") $ \contract ->
  pure
  [ testScenarioOnEmulator "ComplexString" $ scenario $
      callSimple "complex_strings" contract ("text: " :: MText) ("" :: MText)
        @@== ("text: \"aa\" \\\n" :: MText)
  ]

data Union1
  = Case1 Integer
  | Case2 MText
  | Case3 (Maybe MText)
  | Case4 (Either MText MText)
  | Case5 [MText]
  deriving stock (Generic)
  deriving anyclass (IsoValue)

type Tuple1 = (Integer, MText, Maybe MText, Either MText MText, [MText])

test_contract_instr_on_implicit :: IO [TestTree]
test_contract_instr_on_implicit =
  testTreesWithTypedContract (contractsDir </> "contract_instr_unit.tz") $ \contractGood ->
  testTreesWithTypedContract (contractsDir </> "contract_instr_nonunit.tz") $ \contractBad ->
  pure
  [ testScenarioOnEmulator "CONTRACT instruction succeeds on implicit accounts" $ scenario $
      callSimple "contract_instr_unit" contractGood addr ()

  , testScenarioOnEmulator "CONTRACT instruction considers implicit accounts as unit-parametrized" $
      scenario $ callSimple "contract_instr_nounit" contractBad addr ()
        & expectFailedWith ("No such contract" :: MText)
  ]
  where
    addr = mkKeyAddress . toPublic $ detSecretKey "sfsdfsdf"

-- | This test creates a map of two items and then converts them into a list
-- with @MAP@ primitive, counting the number of items along the way.
--
-- See https://gitlab.com/morley-framework/morley/-/issues/123
test_map_preserve_stack :: IO [TestTree]
test_map_preserve_stack =
  testTreesWithTypedContract (contractsDir </> "map_preserve_stack.tz") $ \contract ->
  pure
  [ testScenarioOnEmulator "MAP preserves deep stack modifications (#123)" $ scenario $
      callSimple @() @([Integer], Integer) "map_preserve_stack" contract () ([], 0)
        @@== ([257, 43], 2)
  ]

test_AND_binary :: IO [TestTree]
test_AND_binary =
  testTreesWithTypedContract (contractsDir </> "tezos_examples/opcodes/and_binary.tz") $ \contract ->
    pure
    [ testScenarioOnEmulator "Binary AND test" $ scenario $
        callSimple "and_binary" contract () ()
    ]

type TestEdivStorage =
  ( Maybe (Integer, Natural)
  , ( Maybe (Integer, Natural)
    , ( Maybe (Integer, Natural)
      , Maybe (Natural, Natural)
      )
    )
  )

test_EDIV :: IO [TestTree]
test_EDIV =
  testTreesWithTypedContract (contractsDir </> "tezos_examples/opcodes/ediv.tz") $ \contract ->
  pure
  [ testScenarioOnEmulator "EDIV of int and nat test (non-zero modulo)" $ scenario $
    let intNatNeg = (278 `divMich` -167, fromInteger $ (278 `modMich` -167))
        intNatPos = (278 `divMich` 167, 278 `modMich` 167)
        natNat    = (278 `divMich` 167, 278 `modMich` 167)
    in callSimple @(Integer, Integer) @TestEdivStorage "ediv" contract
        (278, -167) (Nothing, (Nothing, (Nothing, Nothing)))
          @@== (Just intNatNeg, (Just intNatPos, (Just intNatNeg, Just natNat)))
  , testScenarioOnEmulator "EDIV of int and nat test (zero modulo)" $ scenario $
      callSimple @(Integer, Integer) @TestEdivStorage "ediv" contract
        (109, -1) (Nothing, (Nothing, (Nothing, Nothing)))
          @@== (Just (-109, 0), (Just (109, 0), (Just (-109, 0), Just (109, 0))))
  ]

test_SELF_address_packing :: IO [TestTree]
test_SELF_address_packing =
  testTreesWithTypedContract (contractsDir </> "entrypoints/self_pack1.tz") $ \contract ->
    pure
    [ testScenarioOnEmulator "SELF address packing (#333)" $ scenario $
        callSimple "self_pack1" contract () ()
    ]