StoreClass.hs

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

module Test.Lorentz.StoreClass
  ( test_Storage_entrypoints
  ) where

import Prelude hiding (swap)

import Test.Tasty (TestTree)
import Test.Tasty.HUnit (testCase)

import Lorentz.Address
import Lorentz.ADT
import Lorentz.Base
import Lorentz.EntryPoints
import Lorentz.EntryPoints.Doc
import Lorentz.Instr
import Lorentz.Macro
import Lorentz.Run
import Lorentz.StoreClass
import Lorentz.Test
import Lorentz.TypeAnns (HasTypeAnn)
import Michelson.Text (mt)
import Michelson.Typed (IsoValue)
import Tezos.Core (toMutez)

----------------------------------------------------------------------------
-- Storage Entrypoints - Types
----------------------------------------------------------------------------

data ParameterEpTest
  = AddNat Natural
  | SubNat Natural
  | GetValue (View () Natural)
  | SetSubNat (EntrypointLambda Natural Natural)
  deriving stock Generic
  deriving anyclass (IsoValue, HasTypeAnn)

instance ParameterHasEntryPoints ParameterEpTest where
  type ParameterEntryPointsDerivation ParameterEpTest = EpdPlain

data StorageEpTest = StorageEpTest
  { epNats :: EntrypointsField Natural Natural
  , storeNat :: Natural
  } deriving stock Generic
    deriving anyclass IsoValue

instance StoreHasEntrypoint StorageEpTest "addNat" Natural Natural where
  storeEpOps = storeEntrypointOpsADT #epNats #storeNat

instance StoreHasEntrypoint StorageEpTest "subNat" Natural Natural where
  storeEpOps = storeEntrypointOpsADT #epNats #storeNat

instance StoreHasField StorageEpTest "storeNat" Natural where
  storeFieldOps = storeFieldOpsADT

type StorageIsEpTest store = StorageContains store
  [ "addNat" := Natural ::-> Natural
  , "subNat" := Natural ::-> Natural
  , "storeNat" := Natural
  ]

----------------------------------------------------------------------------
-- Storage Entrypoints - Impl
----------------------------------------------------------------------------

addNat :: EntrypointLambda Natural Natural
addNat = unpair # add # nil # pair

subNat :: EntrypointLambda Natural Natural
subNat = unpair # swap # sub # isNat # ifSome nop (push 0) # nil # pair

mkStorageEpTestFull :: Natural -> StorageEpTest
mkStorageEpTestFull n = StorageEpTest
  { epNats = mkStoreEp #addNat addNat <> mkStoreEp #subNat subNat
  , storeNat = n
  }

mkStorageEpTestPart :: Natural -> StorageEpTest
mkStorageEpTestPart n = StorageEpTest
  { epNats = mkStoreEp #addNat addNat
  , storeNat = n
  }

contractEpTest :: StorageIsEpTest store => ContractCode ParameterEpTest store
contractEpTest = unpair # entryCaseSimple @ParameterEpTest
  ( #cAddNat /-> stEntrypoint #addNat
  , #cSubNat /-> stEntrypoint #subNat
  , #cGetValue /-> view_ (cdr # stToField #storeNat)
  , #cSetSubNat /-> stSetEpLambda #subNat # nil # pair
  )

----------------------------------------------------------------------------
-- Storage Entrypoints - Tests
----------------------------------------------------------------------------

lOriginateEpContract :: StorageEpTest -> IntegrationalScenarioM (TAddress ParameterEpTest)
lOriginateEpContract st = lOriginate (defaultContract contractEpTest) "StEps" st (toMutez 0)

test_Storage_entrypoints :: [TestTree]
test_Storage_entrypoints =
  [ testCase "Executes both entrypoints correctly when set at origination" $
      integrationalTestExpectation $ do
        testCon <- lOriginateEpContract $ mkStorageEpTestFull 10
        consumer <- lOriginateEmpty @Natural contractConsumer "consumer"

        lCallDef testCon $ GetValue (mkView () consumer)
        lCallDef testCon $ AddNat 10
        lCallDef testCon $ GetValue (mkView () consumer)
        lCallDef testCon $ SubNat 5
        lCallDef testCon $ GetValue (mkView () consumer)

        lExpectViewConsumerStorage consumer [10, 20, 15]
  , testCase "Cannot set entrypoint that was set at origination" $
      integrationalTestExpectation $ do
        testCon <- lOriginateEpContract $ mkStorageEpTestFull 10

        lCallDef testCon (SetSubNat subNat) `catchExpectedError`
          lExpectFailWith (== [mt|Storage entrypoint already set: subNat|])
  , testCase "Cannot set entrypoint twice" $
      integrationalTestExpectation $ do
        testCon <- lOriginateEpContract $ mkStorageEpTestPart 10

        lCallDef testCon $ SetSubNat subNat
        lCallDef testCon (SetSubNat subNat) `catchExpectedError`
          lExpectFailWith (== [mt|Storage entrypoint already set: subNat|])
  , testCase "Executes correctly entrypoint set after origination" $
      integrationalTestExpectation $ do
        testCon <- lOriginateEpContract $ mkStorageEpTestPart 10
        consumer <- lOriginateEmpty @Natural contractConsumer "consumer"

        lCallDef testCon $ GetValue (mkView () consumer)
        lCallDef testCon $ AddNat 5
        lCallDef testCon $ GetValue (mkView () consumer)

        lCallDef testCon $ SetSubNat subNat
        lCallDef testCon $ SubNat 20
        lCallDef testCon $ GetValue (mkView () consumer)

        lExpectViewConsumerStorage consumer [10, 15, 0]
  ]