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
  , contractIfRightLorentz
  , contractIfConsLorentz
  , contractCaseLorentz
  , contractOpsLorentz
  , contractAssertLorentz
  , contractUserCommentLorentz
  , pathWhile
  , pathWhileLeft
  , pathForEach
  , pathVar
  , pathIf
  , pathIfValue
  , pathIfRight
  , pathIfCons
  , pathCase
  , pathOps
  , pathAssert
  , pathComment
  ) where

import Lorentz
import Prelude hiding (drop, swap)

import Hedgehog (Gen)
import qualified Hedgehog.Gen as Gen
import Hedgehog.Gen.Tezos.Address (genAddress)
import Hedgehog.Gen.Tezos.Crypto (genKeyHash)
import qualified Hedgehog.Range as Range
import Test.Tasty (TestTree)

import Cleveland.Util (genTuple2)
import Michelson.Interpret (MichelsonFailed(..))
import Michelson.Runtime.GState
import qualified Michelson.Typed as T
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
      (validateContractSt 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 "IF_RET_VALUE"
      genInteger
      genInteger
      validateContractConst
      contractIfValueLorentz
      pathIfValue
  , testIndigoContract "CASE"
      genDummyOp
      genInteger
      (validateContractSt caseCheck)
      contractCaseLorentz
      pathCase
  , testIndigoDoc "DOC"
      contractDocLorentz expectedDocContract
  , testIndigoContract "OPS"
      (Gen.maybe genKeyHash)
      genAddress
      (validateContractOps opsCheck)
      contractOpsLorentz
      pathOps
  , testIndigoContract "ASSERT"
      genInteger
      genInteger
      (validateContractSt 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"

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

pathIfCons :: FilePath
pathIfCons = "test/contracts/golden/if_cons_value.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 -> Either MichelsonFailed Integer
ifRightCheck param _st
  | param >= 10 = Right 10
  | otherwise = Right 0

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

whileCheck :: Integer -> Integer -> Either MichelsonFailed Integer
whileCheck param st
  | st <= 0 = Right 0
  | param == 0 = Left zeroDivFail
  | otherwise = Right . sum $ filter ((== 0) . (`T.modMich` param)) [0..(st - 1)]

whileLeftCheck :: Integer -> Integer -> Either MichelsonFailed Integer
whileLeftCheck param _st
  | param < 10 && (param `mod` 2) == 0 = Right 10
  | otherwise = Right param

forEachCheck :: [Integer] -> Integer -> Either MichelsonFailed Integer
forEachCheck param _st = Right $ sum param

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

opsCheck :: Maybe KeyHash -> Address -> Either MichelsonFailed [Operation]
opsCheck param _st = Right [crConOp, setDelOp]
  where
    setDelOp = T.OpSetDelegate $ T.SetDelegate param
    crConOp = T.OpCreateContract $
      T.CreateContract genesisAddress param (toMutez 0) (T.VInt 0)
      (T.cCode $ compileLorentzContract ifTest)

assertCheck :: Integer -> Integer -> Either MichelsonFailed Integer
assertCheck param st
  | sm <= 0 = Left negativeResFail
  | otherwise = Right sm
  where sm = st + param

--------------------------------------------------------------------------------
-- 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 =
  -- 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