ViewCall.hs

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

-- | Views are tested mainly in lorentz-test, but here we check everything at
-- least works in simple scenarios.
module TestSuite.Cleveland.ViewCall
  ( test_RequesterContract
  , test_ViewCall
  , test_UnsafeViewCall
  ) where

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

import Test.Tasty (TestTree)

import Morley.Michelson.Untyped (pattern ValueUnit)
import Test.Cleveland
import Test.Cleveland.Lorentz
import Test.Cleveland.Lorentz.Requester
import Test.Cleveland.Michelson.Import (testTreesWithUntypedContract)
import TestSuite.Util
import TestSuite.Util.Contracts (inContractsDir)

type Views = ViewsList
  [ "add" ?:: Natural >-> Natural
  , "id" ?:: Natural >-> (Natural, ())
  , "fail" ?:: MText >-> Never
  ]

viewedContract :: Contract Never () Views
viewedContract = $$(embedContract $ inContractsDir "view_example.tz")

test_RequesterContract :: TestTree
test_RequesterContract = testScenario "Views can be called via requester contract" $ scenario do
  viewed <- originate "viewed" () viewedContract

  clarifyErrors "Calling view 'add'" do
    requester <- originate "requester" [] (contractRequester @"add" viewed)
    forM_ [5, 10] $ transfer requester . calling def
    getStorage requester @@== [11, 6]

  clarifyErrors "Calling view 'fail'" do
    requester <- originate "requester" [] (contractRequester @"fail" viewed)
    transfer requester (calling def [mt|nyan|])
      & expectFailedWith [mt|nyan|]

  clarifyErrors "Calling view 'id'" do
    requester <- originate "requester" [] (contractRequester @"id" viewed)
    forM_ [5, 0] $ transfer requester . calling def
    getStorage requester @@== [(0, ()), (5, ())]

test_ViewCall :: TestTree
test_ViewCall = testScenario "Views can be called directly" $ scenario do
  viewed <- originate "viewed" () viewedContract

  clarifyErrors "Calling view 'add'" do
    forM [5, 10] (callView viewed #add) @@== [6, 11]

  clarifyErrors "Calling view 'fail'" do
    callView viewed #fail [mt|nyan|]
      & expectFailedWith [mt|nyan|]

  clarifyErrors "Calling view 'id'" do
    forM [5, 0] (callView viewed #id) @@== [(5, ()), (0, ())]

test_UnsafeViewCall :: IO [TestTree]
test_UnsafeViewCall = testTreesWithUntypedContract (inContractsDir "view_example.tz") \ct ->
  pure $ pure $ testScenario "Views can be called directly" $ scenario do
    viewed <- originate "viewed" ValueUnit ct

    clarifyErrors "Calling view 'add'" do
      forM [5 :: Natural, 10] (unsafeCallView @Natural viewed #add) @@== [6, 11]

    clarifyErrors "Calling view 'fail'" do
      unsafeCallView @Never viewed #fail [mt|nyan|]
        & expectFailedWith [mt|nyan|]

    clarifyErrors "Calling view 'id'" do
      forM [5 :: Natural, 0] (unsafeCallView @(Natural, ()) viewed #id) @@== [(5, ()), (0, ())]

    clarifyErrors "Calling view 'nonexistent' which doesn't exist" do
      unsafeCallView @Never viewed #nonexistent ()
        & shouldFailWithMessage "Failed to call view nonexistent"

    clarifyErrors "Calling view 'id' with incorrect types" do
      unsafeCallView @Never viewed #id ()
        & shouldFailWithMessage "Failed to call view id"