Examples.hs

{-# OPTIONS_GHC -Wno-name-shadowing #-}

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

-- | Examples of Indigo Contracts and Tests for them

module Test.Examples
  ( test_Examples
  , contractWhileLorentz
  , contractWhileLeftLorentz
  , contractForEachLorentz
  , contractVarLorentz
  , contractIfLorentz
  , contractIfValueLorentz
  , contractWhenLorentz
  , contractIfRightLorentz
  , contractIfConsLorentz
  , contractCaseLorentz
  , contractOpsLorentz
  , contractAssertLorentz
  , contractUserCommentLorentz
  , contractSimpleEmitLorentz
  , pathWhile
  , pathWhileLeft
  , pathForEach
  , pathVar
  , pathIf
  , pathIfValue
  , pathWhen
  , pathIfRight
  , pathIfCons
  , pathSimpleEmit
  , pathCase
  , pathOps
  , pathAssert
  , pathComment
  ) where

import Lorentz hiding ((>>))
import Prelude hiding (drop, swap)

import Fmt (pretty)
import Hedgehog (Gen)
import Hedgehog.Gen qualified as Gen
import Hedgehog.Range qualified as Range
import Test.Tasty (TestTree)

import Hedgehog.Gen.Michelson (genMText)
import Hedgehog.Gen.Tezos.Address (genAddress)
import Hedgehog.Gen.Tezos.Crypto (genKeyHash', genKeyType)
import Morley.Michelson.Typed qualified as T
import Morley.Tezos.Address
import Morley.Tezos.Crypto (KeyType(..))
import Test.Cleveland
import Test.Cleveland.Util (genTuple2)
import Test.Code.Examples
import Test.Util

--------------------------------------------------------------------------------
-- Tests
--------------------------------------------------------------------------------

{-# ANN module ("HLint: ignore Reduce duplication" :: Text) #-}

-- | Tests on the Indigo examples. Indigo generated contracts need to match their
-- respective Michelson expected contract (by being made of the same instructions)
-- and need to pass validation for randomly generated param and storage.
-- These contracts can be regenerate via @Test.Util.Golden@ module.
test_Examples :: [TestTree]
test_Examples =
  [ testIndigoContract "WHILE"
      genInteger
      genInteger
      whileCheck
      contractWhileLorentz
      pathWhile
  , testIndigoContract "WHILE_LEFT"
      genInteger
      genInteger
      (validateContractSt whileLeftCheck)
      contractWhileLeftLorentz
      pathWhileLeft
  , testIndigoContract "FOR_IN"
      (Gen.list (Range.linear 0 100) genInteger)
      genInteger
      (validateContractSt forEachCheck)
      contractForEachLorentz
      pathForEach
  , testIndigoContract "VAR"
      genInteger
      genInteger
      validateContractConst
      contractVarLorentz
      pathVar
  , testIndigoContract "IF"
      genInteger
      genInteger
      validateContractConst
      contractIfLorentz
      pathIf
  , testIndigoContract "IF_RIGHT"
      genInteger
      genInteger
      (validateContractSt ifRightCheck)
      contractIfRightLorentz
      pathIfRight
  , testIndigoContract "IF_CONS"
      genInteger
      genInteger
      (validateContractSt ifConsCheck)
      contractIfConsLorentz
      pathIfCons
  , testIndigoContract "SIMPLE_EMIT"
      (pure ())
      (Gen.either genInteger (genMText def))
      emitCheck
      contractSimpleEmitLorentz
      pathSimpleEmit
  , testIndigoContract "IF_RET_VALUE"
      genInteger
      genInteger
      validateContractConst
      contractIfValueLorentz
      pathIfValue
  , testIndigoContract "WHEN"
      genInteger
      genInteger
      validateContractConst
      contractWhenLorentz
      pathWhen
  , testIndigoContract "CASE"
      genDummyOp
      genInteger
      (validateContractSt caseCheck)
      contractCaseLorentz
      pathCase
  , testIndigoDoc "DOC"
      contractDocLorentz expectedDocContract
  , testIndigoContract "OPS"
      (Gen.maybe $ genKeyHash' $ Gen.filter (/= KeyTypeBLS) genKeyType)
      genAddress
      opsCheck
      contractOpsLorentz
      pathOps
  , testIndigoContract "ASSERT"
      genInteger
      genInteger
      assertCheck
      contractAssertLorentz
      pathAssert
  , testIndigoContract "COMMENTS"
      genInteger
      genInteger
      (\_ _ _ _ -> pure ())
      contractUserCommentLorentz
      pathComment
  ]
  where
    genInteger :: Gen Integer
    genInteger = Gen.integral (Range.linearFrom 0 -1000 1000)

    genDummyOp :: Gen DummyOp
    genDummyOp = Gen.choice
      [ DSub <$> genTuple2 genInteger genInteger
      , DAdd <$> genTuple2 genInteger genInteger
      ]

--------------------------------------------------------------------------------
-- Golden tests path
--------------------------------------------------------------------------------

pathWhile :: FilePath
pathWhile = "test/contracts/golden/while.tz"

pathWhileLeft :: FilePath
pathWhileLeft = "test/contracts/golden/while_left.tz"

pathForEach :: FilePath
pathForEach = "test/contracts/golden/foreach.tz"

pathVar :: FilePath
pathVar = "test/contracts/golden/var.tz"

pathIf :: FilePath
pathIf = "test/contracts/golden/if.tz"

pathIfValue :: FilePath
pathIfValue = "test/contracts/golden/if_ret_value.tz"

pathWhen :: FilePath
pathWhen = "test/contracts/golden/when.tz"

pathIfRight :: FilePath
pathIfRight = "test/contracts/golden/if_right_value.tz"

pathIfCons :: FilePath
pathIfCons = "test/contracts/golden/if_cons_value.tz"

pathSimpleEmit :: FilePath
pathSimpleEmit = "test/contracts/golden/simple_emit.tz"

pathCase :: FilePath
pathCase = "test/contracts/golden/case.tz"

pathOps :: FilePath
pathOps = "test/contracts/golden/ops.tz"

pathAssert :: FilePath
pathAssert = "test/contracts/golden/assert.tz"

pathComment :: FilePath
pathComment = "test/contracts/golden/comments.tz"

--------------------------------------------------------------------------------
-- Validate Functions
--------------------------------------------------------------------------------

ifRightCheck :: Integer -> Integer -> Integer
ifRightCheck param _st
  | param >= 10 = 10
  | otherwise = 0

ifConsCheck :: Integer -> Integer -> Integer
ifConsCheck param _st
  | param >= 10 = 3
  | otherwise = 0

whileCheck :: MonadCleveland caps m
           => Integer -> Integer -> ContractHandle Integer Integer () -> m a -> m ()
whileCheck param st h act
  | st <= 0 = act >> (getStorage h @@== 0)
  | param == 0 = expectFailedWith [mt|division by zero|] act
  | otherwise = act >> (getStorage h @@== sum (filter ((== 0) . (`T.modMich` param)) [0..(st - 1)]))

whileLeftCheck :: Integer -> Integer -> Integer
whileLeftCheck param _st
  | param < 10 && even param = 10
  | otherwise = param

forEachCheck :: [Integer] -> Integer -> Integer
forEachCheck param _st = sum param

caseCheck :: DummyOp -> Integer -> Integer
caseCheck param _st = case param of
  DSub (a, b) -> a - b
  DAdd (a, b) -> a + b

opsCheck :: MonadCleveland caps m
         => Maybe KeyHash
         -> Address
         -> ContractHandle (Maybe KeyHash) Address ()
         -> m a
         -> m ()
opsCheck expectedDelegate st contract action = do
  expectedDelegate & maybe pass \hash -> do
    let delegateAddr = AddressWithAlias (ImplicitAddress hash) "delegate"
    transfer delegateAddr [tz|1|]
    registerDelegate delegateAddr
  void action
  getDelegate contract @@== expectedDelegate
  originatedContract <- getStorage contract
  originatedContract @/= st
  case originatedContract of
    Constrained addr@ContractAddress{} -> do
      getDelegate addr @@== expectedDelegate
      getStorage @Integer addr @@== 0
    _ -> failure $ "Expected contract address, got " <> pretty originatedContract

assertCheck :: MonadCleveland caps m
            => Integer -> Integer -> ContractHandle Integer Integer () -> m a -> m ()
assertCheck param st h act
  | sm <= 0 = expectFailedWith [mt|unacceptable negative result|] act
  | otherwise = act >> (getStorage h @@== sm)
  where sm = st + param

emitCheck
  :: forall caps m st. (MonadCleveland caps m, NiceStorage st, HasAnnotation st)
  => () -> st -> ContractHandle () st () -> m [ContractEvent] -> m ()
emitCheck _ st _ act = act >>= \case
  [ContractEvent{..}] -> do
    ceTag @== "test"
    cePayload @== Just (T.SomeAnnotatedValue (getAnnotation @st NotFollowEntrypoint) (toVal st))
  x -> failure $ "Expected one event, but got " <> pretty (length x)

--------------------------------------------------------------------------------
-- Expected Contracts
--------------------------------------------------------------------------------

-- Note that these contracts may diverge from the Indigo examples, but only for
-- differences that get eliminated by using `optimizeLorentz` on both

expectedDocContract :: ContractCode Integer Integer
expectedDocContract = mkContractCode $
  -- add an empty operation list at the bottom of the stack
  nil # swap #
  -- leave `param` followed by `st` on the stack
  unpair #
  dip nop #
  -- doc (DDescription "x")
  doc (DDescription "x") #
  -- docGroup "aaa" (doc $ DDescription "a")
  docGroup "aaa" (doc $ DDescription "a") #
  -- i <- new$ 10 int
  push @Integer 10 #
  -- docGroup "bbb" (doc $ DDescription "b")
  docGroup "bbb" (doc $ DDescription "b") #
  -- duplicate `i`
  duupX @1 #
  -- copy `param` to top of the stack
  duupX @3 #
  -- param +. i
  add #
  -- override `st` with it
  replaceN @3 #
  -- cleanup `i` and `param`
  drop # drop #
  -- return `st`
  swap # pair