StorageEntrypoints.hs

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

module Test.Lorentz.StoreClass.StorageEntrypoints
  ( test_Storage_entrypoints
  ) where

import Prelude hiding (drop, swap)

import Data.Constraint (Dict(..), (:-)(Sub))
import Test.Tasty (TestTree)

import Lorentz.ADT
import Lorentz.Annotation (HasAnnotation)
import Lorentz.Base
import Lorentz.Constraints
import Lorentz.Entrypoints
import Lorentz.Entrypoints.Doc
import Lorentz.Instr
import Lorentz.Macro
import Lorentz.Run
import Lorentz.StoreClass
import Lorentz.Value
import Test.Cleveland
import Test.Cleveland.Lorentz

----------------------------------------------------------------------------
-- Types
----------------------------------------------------------------------------

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

instance ParameterHasEntrypoints ParameterEpTest where
  type ParameterEntrypointsDerivation ParameterEpTest = EpdPlain

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

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
    ]
  , Dupable store
  )

----------------------------------------------------------------------------
-- 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_ (drop @() # stToField #storeNat)
  , #cSetSubNat /-> stSetEpLambda #subNat # nil # pair
  )

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

originateEpContract
  :: MonadCleveland caps m
  => StorageEpTest
  -> m (ContractHandle ParameterEpTest StorageEpTest ())
originateEpContract st = originate $ OriginateData "StEps" 0 st (defaultContract contractEpTest)

test_Storage_entrypoints :: [TestTree]
test_Storage_entrypoints =
  [ testScenario "Executes both entrypoints correctly when set at origination" $ scenario do
      testCon <- originateEpContract $ mkStorageEpTestFull 10
      consumer <- originateSimple "consumer" def contractConsumer

      call testCon CallDefault $ GetValue (mkView_ () consumer)
      call testCon CallDefault $ AddNat 10
      call testCon CallDefault $ GetValue (mkView_ () consumer)
      call testCon CallDefault $ SubNat 5
      call testCon CallDefault $ GetValue (mkView_ () consumer)

      getStorage consumer @@== [15, 20, 10]

  , testScenario "Cannot set entrypoint that was set at origination" $ scenario do
      testCon <- originateEpContract $ mkStorageEpTestFull 10

      expectFailedWith [mt|Storage entrypoint already set: subNat|] $
        call testCon CallDefault (SetSubNat subNat)

  , testScenario "Cannot set entrypoint twice" $ scenario do
      testCon <- originateEpContract $ mkStorageEpTestPart 10

      call testCon CallDefault $ SetSubNat subNat
      expectFailedWith [mt|Storage entrypoint already set: subNat|] $
        call testCon CallDefault (SetSubNat subNat)

  , testScenario "Executes correctly entrypoint set after origination" $ scenario do
      testCon <- originateEpContract $ mkStorageEpTestPart 10
      consumer <- originateSimple "consumer" def contractConsumer

      call testCon CallDefault $ GetValue (mkView_ () consumer)
      call testCon CallDefault $ AddNat 5
      call testCon CallDefault $ GetValue (mkView_ () consumer)

      call testCon CallDefault $ SetSubNat subNat
      call testCon CallDefault $ SubNat 20
      call testCon CallDefault $ GetValue (mkView_ () consumer)

      getStorage consumer @@== [0, 15, 10]
  ]

----------------------------------------------------------------------------
-- Tests on conveniences
----------------------------------------------------------------------------

type StorageC store meta = StorageContains store
  '[ "field" := Identity meta
   ]

_storeFieldConstraintInterpretedCorrectly :: StorageC store meta :- StoreHasField store "field" meta
_storeFieldConstraintInterpretedCorrectly = Sub Dict