-- 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 :: forall cp vd arg (m :: * -> *) addr ticketerAddr
       (mname :: Maybe Symbol).
(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 addr
to' EntrypointRef mname
epRef
  | (Dict (ParameterScope (ToT (Ticket arg)))
Dict, EpName
epName) <- forall {k} (cp :: k) name arg.
HasEntrypointArg cp name arg =>
name -> (Dict (ParameterScope (ToT arg)), EpName)
forall cp name arg.
HasEntrypointArg cp name arg =>
name -> (Dict (ParameterScope (ToT arg)), EpName)
useHasEntrypointArg @cp @_ @(Ticket arg) EntrypointRef mname
epRef
  = addr
-> EpName -> ticketerAddr -> arg -> Natural -> m [ContractEvent]
forall arg (m :: * -> *) addr ticketerAddr.
(MonadOpsInternal m, NiceParameter arg, NiceComparable arg,
 ToL1Address addr, ToAddress ticketerAddr, HasCallStack) =>
addr
-> EpName -> ticketerAddr -> arg -> Natural -> m [ContractEvent]
unsafeTransferTicket addr
to' EpName
epName
  where Dict (ImplicitAddressParameterHelper addr cp (Ticket arg))
_ = forall (a :: Constraint). a => Dict a
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 :: forall arg (m :: * -> *) addr ticketerAddr.
(MonadOpsInternal m, NiceParameter arg, NiceComparable arg,
 ToL1Address addr, ToAddress ticketerAddr, HasCallStack) =>
addr
-> EpName -> ticketerAddr -> arg -> Natural -> m [ContractEvent]
unsafeTransferTicket (addr -> L1Address
forall addr. ToL1Address addr => addr -> L1Address
toL1Address -> L1Address
ttdTo) EpName
ttdEntrypoint (ticketerAddr -> Address
forall a. ToAddress a => a -> Address
toAddress -> Address
tTicketer) arg
tData Natural
tAmount =
  (ClevelandOpsImpl m -> m [ContractEvent]) -> m [ContractEvent]
forall (m :: * -> *) a.
MonadOpsInternal m =>
(ClevelandOpsImpl m -> m a) -> m a
withOpsCap \ClevelandOpsImpl m
opsCap -> ClevelandOpsImpl m
-> Text
-> OperationInfo ClevelandInput
-> (OperationInfo ClevelandResult -> Maybe [ContractEvent])
-> m [ContractEvent]
forall (m :: * -> *) a.
(HasCallStack, Functor m) =>
ClevelandOpsImpl m
-> Text
-> OperationInfo ClevelandInput
-> (OperationInfo ClevelandResult -> Maybe a)
-> m a
runSingleOperation ClevelandOpsImpl m
opsCap Text
"transfer_ticket" (TransferTicketInfo ClevelandInput -> OperationInfo ClevelandInput
forall i. TransferTicketInfo i -> OperationInfo i
OpTransferTicket TransferTicketInfo ClevelandInput
TransferTicketData
ttData) \case
    OpTransferTicket TransferTicketInfo ClevelandResult
ops -> [ContractEvent] -> Maybe [ContractEvent]
forall a. a -> Maybe a
Just [ContractEvent]
TransferTicketInfo ClevelandResult
ops
    OperationInfo ClevelandResult
_ -> Maybe [ContractEvent]
forall a. Maybe a
Nothing
  where
    ttdParameter :: Value' Instr ('TTicket (ToT arg))
ttdParameter = Address
-> Value' Instr (ToT arg)
-> Natural
-> Value' Instr ('TTicket (ToT arg))
forall (arg :: T) (instr :: [T] -> [T] -> *).
Comparable arg =>
Address
-> Value' instr arg -> Natural -> Value' instr ('TTicket arg)
VTicket Address
tTicketer (arg -> Value' Instr (ToT arg)
forall a. IsoValue a => a -> Value (ToT a)
toVal arg
tData) Natural
tAmount
    ttData :: TransferTicketData
ttData = TransferTicketData :: forall (t :: T) addr.
(WellTyped t, ToL1Address addr) =>
addr -> EpName -> Value ('TTicket t) -> TransferTicketData
TransferTicketData{L1Address
EpName
Value' Instr ('TTicket (ToT arg))
ttdParameter :: Value' Instr ('TTicket (ToT arg))
ttdEntrypoint :: EpName
ttdTo :: L1Address
ttdParameter :: Value' Instr ('TTicket (ToT arg))
ttdEntrypoint :: EpName
ttdTo :: L1Address
..}

-- | 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 _ _ _ = ()