TransferTicket.hs

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

{-# OPTIONS_HADDOCK not-home #-}

-- | Machinery for transferring tickets from implicit accounts.
module Test.Cleveland.Internal.Actions.TransferTicket
  ( module Test.Cleveland.Internal.Actions.TransferTicket
  ) where

import Lorentz
import Morley.Client.Types
import Morley.Michelson.Typed (Dict(..), pattern VTicket)
import Morley.Tezos.Address
import Test.Cleveland.Internal.Abstract
import Test.Cleveland.Internal.Actions.MonadOpsInternal
import Test.Cleveland.Lorentz.Types

-- | Transfer tickets.
transferTicket
  :: forall cp vd arg m addr ticketerAddr mname.
     ( MonadOpsInternal m, NiceParameter arg, NiceComparable arg
     , ImplicitAddressParameterHelper addr cp (Ticket arg)
     , ToL1TAddress cp vd addr, ToAddress ticketerAddr
     , HasEntrypointArg cp (EntrypointRef mname) (Ticket arg)
     , HasCallStack
     )
  => addr -> EntrypointRef mname -> ticketerAddr -> arg -> Natural -> m [ContractEvent]
transferTicket to' epRef
  | (Dict, epName) <- useHasEntrypointArg @cp @_ @(Ticket arg) epRef
  = unsafeTransferTicket to' epName
  where _ = Dict @(ImplicitAddressParameterHelper addr cp (Ticket arg))

-- | Transfer tickets without checking the recipient can accept them.
unsafeTransferTicket
  :: forall arg m addr ticketerAddr.
     ( MonadOpsInternal m, NiceParameter arg, NiceComparable arg
     , ToL1Address addr, ToAddress ticketerAddr
     , HasCallStack
     )
  => addr -> EpName -> ticketerAddr -> arg -> Natural -> m [ContractEvent]
unsafeTransferTicket (toL1Address -> ttdTo) ttdEntrypoint (toAddress -> tTicketer) tData tAmount =
  withOpsCap \opsCap -> runSingleOperation opsCap "transfer_ticket" (OpTransferTicket ttData) \case
    OpTransferTicket ops -> Just ops
    _ -> Nothing
  where
    ttdParameter = VTicket tTicketer (toVal tData) tAmount
    ttData = TransferTicketData{..}

-- | Implicit address may only have the root entrypoint, so full parameter type
-- is exactly the argument parameter type. This is used to improve type
-- inference when using 'transferTicket' with implicit addresses.
type family ImplicitAddressParameterHelper addr cp arg :: Constraint where
  ImplicitAddressParameterHelper ImplicitAddress cp arg = cp ~ arg
  ImplicitAddressParameterHelper ImplicitAddressWithAlias cp arg = cp ~ arg
  ImplicitAddressParameterHelper _ _ _ = ()