View.hs

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

{-# OPTIONS_HADDOCK not-home #-}

-- | On-chain view utilities.
module Test.Cleveland.Internal.Actions.View
  ( module Test.Cleveland.Internal.Actions.View
  ) where

import Data.Constraint (pattern Dict)
import Fmt ((+|), (|+))

import Lorentz (Contract(..), HasView, Label, NiceViewable, toVal)
import Lorentz qualified as L
import Morley.AsRPC
import Morley.Client.Types (awaAddress)
import Morley.Michelson.Typed (pattern (:#))
import Morley.Michelson.Typed qualified as T
import Morley.Tezos.Address
import Morley.Util.TypeLits (KnownSymbol, symbolValT')
import Test.Cleveland.Internal.Abstract
import Test.Cleveland.Internal.Actions.Assertions (failure)
import Test.Cleveland.Internal.Actions.Misc
import Test.Cleveland.Lorentz.Types

-- | Call an on-chain view by name. The existence of the view is checked at
-- compile time. If you don't have compile-time information about views, see
-- 'unsafeCallView'.
--
-- Example:
--
-- > callView contract #sum (123, -321)
callView
  :: forall name arg ret cp st vd m caps.
    ( MonadCleveland caps m, HasView vd name arg ret
    , NiceParameter arg, NiceViewable ret, NiceStorage ret
    , KnownSymbol name, HasRPCRepr ret
    , T.IsoValue (AsRPC ret))
  => ContractHandle cp st vd -- ^ Contract to call.
  -> Label name -- ^ View name. Use @OverloadedLabels@ syntax.
  -> arg -- ^ Parameter to pass to the view.
  -> m (AsRPC ret)
callView = unsafeCallView @ret
  where _ = Dict @(HasView vd name arg ret) -- silence redundant constraint warning

-- | Version of 'callView' that doesn't check if the view exists in the type.
-- You'll have to specify the return type. You can use @TypeApplications@ syntax
-- for that.
--
-- If the view doesn't exist or has incorrect type, a test failure will be
-- thrown.
--
-- Note that first type argument is return type, the second is parameter type.
-- The reason for this inversion is you often only need to specify the return
-- type, while the parameter type can be either inferred or explicitly specified
-- with a type annotation on the parameter argument value.
--
-- Examples:
--
-- > unsafeCallView @() contract #id ()
-- Calls view @id@ with argument @unit@ and return type @unit@.
--
-- > unsafeCallView @(Integer, MText) contract #query [mt|hello|]
-- Calls view @query@ with argument @string@ and return type @pair int string@.
--
-- > unsafeCallView @Integer contract #sum (123 :: Natural, -321 :: Integer)
-- Calls view @sum@ with argument @pair nat int@ and return type @int@. Type
-- annotations are required due to polymorphic numeric literals.
--
-- This last example could also be written as
--
-- > unsafeCallView @Integer @(Natural, Integer) contract #sum (123, -321)
unsafeCallView
  :: forall ret arg name addr m caps.
    ( MonadCleveland caps m, NiceParameter arg, NiceViewable ret
    , NiceStorage ret, KnownSymbol name
    , HasRPCRepr ret, T.IsoValue (AsRPC ret)
    , ToContractAddress addr)
  => addr -- ^ Contract to call.
  -> Label name -- ^ View name. Use @OverloadedLabels@ syntax.
  -> arg -- ^ Parameter to pass to the view.
  -> m (AsRPC ret)
unsafeCallView (toContractAddress -> ch) _ arg = do
  Sender sender' <- Prelude.view senderL
  contractBalance <- getBalance ch
  let ct = runnerContract @name @arg @ret ch
      callFail = failure $ "Failed to call view " +| symbolValT' @name |+
        ": either it doesn't exist or types don't match."
  res <- runCode RunCode
    { rcAmount = 0
    , rcBalance = contractBalance
    , rcSource = Just $ awaAddress sender'
    , rcContract = ct
    , rcParameter = T.untypeValue $ T.toVal arg
    , rcStorage = T.untypeValue $ T.toVal (Nothing :: Maybe ret)
    , rcLevel = Nothing
    , rcNow = Nothing
    }
  maybe callFail pure res

-- | Contract that calls a view and saves the result to storage.
runnerContract
  :: forall name arg ret. (NiceParameter arg, NiceViewable ret, NiceStorage ret, KnownSymbol name)
  => ContractAddress -> Contract arg (Maybe ret) ()
runnerContract ch = flip Contract fakeDoc $ T.defaultContract $
  -- NB: It's not a Lorentz contract to avoid requiring NiceParameterFull and
  -- NiceStorageFull on arg and ret respectively.
  T.CAR :# T.DIP (T.PUSH $ toVal $ toAddress ch)
    :# T.VIEW (T.UnsafeViewName $ symbolValT' @name)
    :# T.NIL :# T.PAIR
  where
    fakeDoc = L.ContractCode $ L.fakeCoercing L.nop