Views.hs

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

-- | Tests for Lorentz on-chain views.

module Test.Lorentz.Views
  ( test_Views
  ) where

import Lorentz
import Prelude hiding (drop, some, swap, take, view)

import Data.Coerce (coerce)
import Test.Tasty (TestTree, testGroup)

import Morley.Util.Type
import Test.Cleveland
import Test.Cleveland.Lorentz.Requester

data Views1
type instance RevealViews Views1 =
  [ "plusSt" ?:: Natural >-> Natural
  , "fail" ?:: MText >-> Never
  , "stPow" ?:: Natural >-> Natural
  ] ++
  RevealViews PlusView

data PlusView deriving stock (Generic)
type instance RevealViews PlusView =
 '[ "plus" ?:: (Integer, Integer) >-> Integer
  ]
instance ViewsDescriptorHasDoc PlusView

viewedContract1 :: Contract Never Natural Views1
viewedContract1 = compileLorentzContract $
  defaultContractData
    (car # never)
  & setViews
    ( mkView @"plusSt" (unpair # add)
    , mkView @"fail" (car # failWith)
    , mkView @"stPow"
        ( car #
          push @Integer 1 # rsub # isNat # ifSome
            ( -- call the same view recursively
              viewE @"plusSt"
                ! #address do selfAddress # asAddressOf_ viewedContract1
                ! #arg do push 0
              |*|
              -- call another view
              viewE @"stPow"
                ! #address do selfAddress # asAddressOf_ viewedContract1
                ! #arg take
            )
            ( push 1 )
        )
    , mkView @"plus" (car # unpair # add)
    )

data Views2
type instance RevealViews Views2 =
 '[ "plus10"
      -- TODO [#716]: here we should use not TAddress but something else that
      -- 1. does not carry the parameter type
      -- 2. can narrow the list of views when converted from e.g. ContractHandle
      --    (because we are fine with any contract that contains more views, not only
      --     'PlusView')
      --
      -- For now, we have to cast 'TAddress'.
      ?:: (Integer, TAddress () PlusView)
      >-> Integer
  ]

viewedContract2 :: Contract Never () Views2
viewedContract2 = compileLorentzContract $
  defaultContractData
    (car # never)
  & setViews
    ( mkView @"plus10" (car # unpair # push 10 # pair # view @"plus")
    )

data AccessAddrView
type instance RevealViews AccessAddrView =
 '[ "originatedContract" ?:: () >-> TAddress Never PlusView
  ]

-- | On call originates a contract with 'PlusView' view and save its address in storage.
-- The view in the originated contract will sum up two numbers and add extra 100.
view3OriginatorContract :: Contract () (Maybe (TAddress Never PlusView)) AccessAddrView
view3OriginatorContract = compileLorentzContract $
  defaultContractData
    ( drop #
      pairE
        ( createContractE
          ! #storage (push 100)
          ! #delegate none
          ! #balance (push zeroMutez)
          ! #contract newContract
          |:| nil
        , some
        )
    )
  & setViews
    ( mkView @"originatedContract" (cdr # assertSome [mt|Nothing originated|])
    )
  where
    newContract = compileLorentzContract @Never @Natural @PlusView $
      defaultContractData (car # never)
      & setViews
        ( mkView @"plus" (unpair # unpair # add # add)
        )

-- | On call, calls the view in the contract originated by 'view3OriginatorContract'.
view3Caller :: Contract () (TAddress () AccessAddrView, Maybe Integer) ()
view3Caller = mkContract $
  cdr #
  car #
  stackType @'[TAddress () AccessAddrView] #
  viewE @"plus"
    ! #arg do push (10, 1)
    ! #address do
        viewE @"originatedContract"
            ! #arg unit
            ! #address dup
    #
  stackType @[Integer, TAddress () AccessAddrView] #
  swap #
  pairE (take, some) #
  nil # pair

-- | Calls 'view3OriginatorContract' and 'view3Caller' sequentially.
view3CreatorAndCaller :: Contract (ContractRef (), ContractRef ()) () ()
view3CreatorAndCaller = mkContract $
  car #
  unpair #
  transferTokensE
    ! #arg unit
    ! #amount (push zeroMutez)
    ! #contract take
  |:|
  transferTokensE
    ! #arg unit
    ! #amount (push zeroMutez)
    ! #contract take
  |:| nil
  |@| unit

test_Views :: TestTree
test_Views = testGroup "Views"
  [ testScenario "Simple case with requester contract" $ scenario do
      viewed <- originateSimple "viewed" 1 viewedContract1
      requester <- originateSimple "requester" [] (contractRequester @"plusSt" viewed)
      forM_ [5, 10] $ call requester CallDefault
      getStorage requester @@== [11, 6]

  -- TODO [#708]: Call views directly, without requester contract

  , testScenario "Failing view" $ scenario do
      viewed <- originateSimple "viewed" 0 viewedContract1
      requester <- originateSimple "requester" [] (contractRequester @"fail" viewed)
      call requester CallDefault [mt|nyan|]
        & expectFailedWith [mt|nyan|]

  , testScenario "Recursive view" $ scenario do
      viewed <- originateSimple "viewed" 2 viewedContract1
      requester <- originateSimple "requester" [] (contractRequester @"stPow" viewed)
      forM_ [5, 0] $ call requester CallDefault
      getStorage requester @@== [1, 32]

  , testScenario "Calling view in another contract" $ scenario do
      viewedHelper <- originateSimple "viewed" 0 viewedContract1
      viewed <- originateSimple "viewed" () viewedContract2
      requester <- originateSimple "requester" [] (contractRequester @"plus10" viewed)
      -- TODO [#716]: coerce shouldn't be necessary
      call requester CallDefault (20, coerce $ toTAddress viewedHelper)
      getStorage requester @@== [30]

  , testScenario "Calling a just originated view" $ scenario do
      -- It might be that a view is originated and called within the same
      -- global operation, we want to be sure this works
      originator <- originateSimple "originator" Nothing view3OriginatorContract
      caller <- originateSimple "caller" (toTAddress originator, Nothing) view3Caller
      allCaller <- originateSimple "allCaller" () view3CreatorAndCaller

      call allCaller CallDefault (toContractRef originator, toContractRef caller)
      snd <$> getStorage caller @@== Just 111

  ]