{-# OPTIONS_HADDOCK not-home #-}
module Test.Cleveland.Internal.Actions.Transfer
( module Test.Cleveland.Internal.Actions.Transfer
) where
import Data.Constraint (Bottom(..))
import Data.Singletons.TH (SingI(..), genSingletons)
import GHC.TypeLits (ErrorMessage(..), TypeError)
import Lorentz
import Morley.Client.Types
import Morley.Michelson.Typed (Dict(..))
import Morley.Michelson.Untyped qualified as U
import Morley.Tezos.Address
import Test.Cleveland.Internal.Abstract
import Test.Cleveland.Internal.Actions.MonadOpsInternal
import Test.Cleveland.Lorentz.Types
data TransferResult = TransferIgnoreResult | TransferWithEmits
type family FTransferResult emit :: Type where
FTransferResult 'TransferWithEmits = [ContractEvent]
FTransferResult 'TransferIgnoreResult = ()
genSingletons [''TransferResult]
transfer :: forall addr r.
( HasCallStack
, TransferFunc ('Incomplete (InitialTransferMode addr))
'TransferIgnoreResult 'HasNoAmount r
, ToL1Address addr )
=> addr -> r
transfer :: forall addr r.
(HasCallStack,
TransferFunc
('Incomplete (InitialTransferMode addr))
'TransferIgnoreResult
'HasNoAmount
r,
ToL1Address addr) =>
addr -> r
transfer = forall (mode :: TransferMode) (emit :: TransferResult)
(hasAmount :: HasAmount) r.
(TransferFunc mode emit hasAmount r, HasCallStack) =>
GenericTransferData mode -> r
transfer'r @_ @'TransferIgnoreResult @'HasNoAmount (GenericTransferData ('Incomplete (InitialTransferMode addr)) -> r)
-> (addr
-> GenericTransferData ('Incomplete (InitialTransferMode addr)))
-> addr
-> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall addr.
ToL1Address addr =>
addr
-> GenericTransferData ('Incomplete (InitialTransferMode addr))
initialData @addr
data TransferMode = Checked Type | Unchecked | Incomplete TransferMode
data GenericCall mode where
CheckedCall
:: (NiceParameter epArg, HasEntrypointArg param epRef epArg)
=> epRef -> epArg -> GenericCall ('Checked param)
UncheckedCall :: NiceParameter epArg => U.EpName -> epArg -> GenericCall 'Unchecked
UnspecifiedCall :: GenericCall ('Incomplete param)
data GenericTransferData mode =
GenericTransferData
{ forall (mode :: TransferMode).
GenericTransferData mode -> L1Address
gtdAddr :: L1Address
, forall (mode :: TransferMode).
GenericTransferData mode -> GenericCall mode
gtdCall :: GenericCall mode
, forall (mode :: TransferMode). GenericTransferData mode -> Mutez
gtdAmount :: Mutez
}
type family InitialTransferMode addr :: TransferMode where
InitialTransferMode ContractAddress = 'Unchecked
InitialTransferMode ImplicitAddress = 'Unchecked
InitialTransferMode ContractAddressWithAlias = 'Unchecked
InitialTransferMode ImplicitAddressWithAlias = 'Unchecked
InitialTransferMode L1Address = 'Unchecked
InitialTransferMode (L1TAddress param _) = 'Checked param
InitialTransferMode (ContractHandle param _ _) = 'Checked param
InitialTransferMode Address = TypeError (
'Text "'Address' can not be used as the first argument of 'transfer'." ':$$:
'Text "Perhaps you meant to use 'L1Address'?")
InitialTransferMode (TAddress _ _) = TypeError (
'Text "'TAddress' can not be used as the first argument of 'transfer'." ':$$:
'Text "Perhaps you meant to use 'L1TAddress'?")
InitialTransferMode x = TypeError (
'Text "Address type '" ':<>: 'ShowType x ':<>: 'Text "' is unsupported or ambiguous." ':$$:
'Text "The supported address types are" ':$$:
'Text "'ContractAddress', 'ImplicitAddress', 'L1Address', 'L1TAddress', and 'ContractHandle'")
initialData
:: ToL1Address addr
=> addr -> GenericTransferData ('Incomplete (InitialTransferMode addr))
initialData :: forall addr.
ToL1Address addr =>
addr
-> GenericTransferData ('Incomplete (InitialTransferMode addr))
initialData addr
addr = GenericTransferData :: forall (mode :: TransferMode).
L1Address -> GenericCall mode -> Mutez -> GenericTransferData mode
GenericTransferData
{ gtdAddr :: L1Address
gtdAddr = addr -> L1Address
forall addr. ToL1Address addr => addr -> L1Address
toL1Address addr
addr
, gtdAmount :: Mutez
gtdAmount = Mutez
zeroMutez
, gtdCall :: GenericCall ('Incomplete (InitialTransferMode addr))
gtdCall = GenericCall ('Incomplete (InitialTransferMode addr))
forall (epArg :: TransferMode). GenericCall ('Incomplete epArg)
UnspecifiedCall
}
data HasAmount = HasAmount | HasNoAmount
class TransferFunc (mode :: TransferMode) (emit :: TransferResult) (hasAmount :: HasAmount) r where
transfer'r :: HasCallStack => GenericTransferData mode -> r
type family NoDuplicateAmount am :: Constraint where
NoDuplicateAmount 'HasAmount = TypeError ('Text "Amount is specified more than once.")
NoDuplicateAmount 'HasNoAmount = ()
instance (TransferFunc mode emit 'HasAmount r, NoDuplicateAmount am, am ~ 'HasNoAmount)
=> TransferFunc mode emit am (Mutez -> r) where
transfer'r :: HasCallStack => GenericTransferData mode -> Mutez -> r
transfer'r GenericTransferData mode
initData Mutez
x = forall (mode :: TransferMode) (emit :: TransferResult)
(hasAmount :: HasAmount) r.
(TransferFunc mode emit hasAmount r, HasCallStack) =>
GenericTransferData mode -> r
transfer'r @_ @emit @'HasAmount GenericTransferData mode
initData{gtdAmount :: Mutez
gtdAmount = Mutez
x}
type family NoDuplicateEmit am :: Constraint where
NoDuplicateEmit 'TransferWithEmits =
TypeError ('Text "WithContractEvents is specified more than once.")
NoDuplicateEmit 'TransferIgnoreResult = ()
instance (TransferFunc mode 'TransferWithEmits am r
, NoDuplicateEmit emit, emit ~ 'TransferIgnoreResult)
=> TransferFunc mode emit am (WithContractEvents -> r) where
transfer'r :: HasCallStack => GenericTransferData mode -> WithContractEvents -> r
transfer'r GenericTransferData mode
initData WithContractEvents
_ = forall (mode :: TransferMode) (emit :: TransferResult)
(hasAmount :: HasAmount) r.
(TransferFunc mode emit hasAmount r, HasCallStack) =>
GenericTransferData mode -> r
transfer'r @_ @'TransferWithEmits @am GenericTransferData mode
initData
type family MatchModes from to :: Constraint where
MatchModes ('Incomplete _) 'Unchecked = ()
MatchModes ('Incomplete ('Checked param1)) ('Checked param2) = param1 ~ param2
MatchModes ('Incomplete 'Unchecked) _ = TypeError (
'Text "Can not use this type of call with an untyped address."
':$$: 'Text "Try using 'unsafeCalling' instead."
)
MatchModes _ _ = TypeError ('Text "Call is specified more than once.")
instance (TransferFunc modeTo emit am r, MatchModes modeFrom modeTo)
=> TransferFunc modeFrom emit am (GenericCall modeTo -> r) where
transfer'r :: HasCallStack =>
GenericTransferData modeFrom -> GenericCall modeTo -> r
transfer'r GenericTransferData{L1Address
Mutez
GenericCall modeFrom
gtdAmount :: Mutez
gtdCall :: GenericCall modeFrom
gtdAddr :: L1Address
gtdAmount :: forall (mode :: TransferMode). GenericTransferData mode -> Mutez
gtdCall :: forall (mode :: TransferMode).
GenericTransferData mode -> GenericCall mode
gtdAddr :: forall (mode :: TransferMode).
GenericTransferData mode -> L1Address
..} GenericCall modeTo
x =
forall (mode :: TransferMode) (emit :: TransferResult)
(hasAmount :: HasAmount) r.
(TransferFunc mode emit hasAmount r, HasCallStack) =>
GenericTransferData mode -> r
transfer'r @_ @emit @am (GenericTransferData modeTo -> r)
-> GenericTransferData modeTo -> r
forall a b. (a -> b) -> a -> b
$ GenericTransferData :: forall (mode :: TransferMode).
L1Address -> GenericCall mode -> Mutez -> GenericTransferData mode
GenericTransferData{gtdCall :: GenericCall modeTo
gtdCall = GenericCall modeTo
x, L1Address
Mutez
gtdAmount :: Mutez
gtdAddr :: L1Address
gtdAmount :: Mutez
gtdAddr :: L1Address
..}
instance ( SingI emit, DoTransfer mode, a ~ FTransferResult emit)
=> TransferFunc mode emit am (ClevelandOpsBatch a) where
transfer'r :: HasCallStack => GenericTransferData mode -> ClevelandOpsBatch a
transfer'r = case forall {k} (a :: k). SingI a => Sing a
forall (a :: TransferResult). SingI a => Sing a
sing @emit of
Sing emit
STransferResult emit
STransferWithEmits -> GenericTransferData mode -> ClevelandOpsBatch a
forall (mode :: TransferMode) (m :: * -> *).
(DoTransfer mode, HasCallStack, MonadOpsInternal m) =>
GenericTransferData mode -> m [ContractEvent]
doTransfer
Sing emit
STransferResult emit
STransferIgnoreResult -> ClevelandOpsBatch [ContractEvent] -> ClevelandOpsBatch ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ClevelandOpsBatch [ContractEvent] -> ClevelandOpsBatch ())
-> (GenericTransferData mode -> ClevelandOpsBatch [ContractEvent])
-> GenericTransferData mode
-> ClevelandOpsBatch ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericTransferData mode -> ClevelandOpsBatch [ContractEvent]
forall (mode :: TransferMode) (m :: * -> *).
(DoTransfer mode, HasCallStack, MonadOpsInternal m) =>
GenericTransferData mode -> m [ContractEvent]
doTransfer
instance ( SingI emit, DoTransfer mode, HasClevelandCaps cap
, base ~ ClevelandBaseMonad cap, a ~ FTransferResult emit )
=> TransferFunc mode emit am (ReaderT cap base a) where
transfer'r :: HasCallStack => GenericTransferData mode -> ReaderT cap base a
transfer'r = case forall {k} (a :: k). SingI a => Sing a
forall (a :: TransferResult). SingI a => Sing a
sing @emit of
Sing emit
STransferResult emit
STransferWithEmits -> GenericTransferData mode -> ReaderT cap base a
forall (mode :: TransferMode) (m :: * -> *).
(DoTransfer mode, HasCallStack, MonadOpsInternal m) =>
GenericTransferData mode -> m [ContractEvent]
doTransfer
Sing emit
STransferResult emit
STransferIgnoreResult -> ReaderT cap base [ContractEvent] -> ReaderT cap base ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT cap base [ContractEvent] -> ReaderT cap base ())
-> (GenericTransferData mode -> ReaderT cap base [ContractEvent])
-> GenericTransferData mode
-> ReaderT cap base ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericTransferData mode -> ReaderT cap base [ContractEvent]
forall (mode :: TransferMode) (m :: * -> *).
(DoTransfer mode, HasCallStack, MonadOpsInternal m) =>
GenericTransferData mode -> m [ContractEvent]
doTransfer
class (
forall mod am emit a. (SingI emit, DoTransfer mod, a ~ FTransferResult emit)
=> TransferFunc mod emit am (m a)
) => MonadTransfer m
instance (
forall mod am emit a. (SingI emit, DoTransfer mod, a ~ FTransferResult emit)
=> TransferFunc mod emit am (m a)
) => MonadTransfer m
instance {-# INCOHERENT #-}
( Bottom
, TypeError ('Text "Incorrect argument for the 'transfer' function: " ':<>: 'ShowType x ':$$:
'Text "If in doubt, try adding a type annotation."))
=> TransferFunc mode emit am (x -> r) where
transfer'r :: HasCallStack => GenericTransferData mode -> x -> r
transfer'r = forall a. Bottom => a
GenericTransferData mode -> x -> r
no
class DoTransfer mode where
doTransfer :: (HasCallStack, MonadOpsInternal m) => GenericTransferData mode -> m [ContractEvent]
runTransfer :: (HasCallStack, MonadOpsInternal m) => TransferData -> m [ContractEvent]
runTransfer :: forall (m :: * -> *).
(HasCallStack, MonadOpsInternal m) =>
TransferData -> m [ContractEvent]
runTransfer TransferData
td = (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" (TransferInfo ClevelandInput -> OperationInfo ClevelandInput
forall i. TransferInfo i -> OperationInfo i
OpTransfer TransferInfo ClevelandInput
TransferData
td) \case
OpTransfer TransferInfo ClevelandResult
ops -> [ContractEvent] -> Maybe [ContractEvent]
forall a. a -> Maybe a
Just [ContractEvent]
TransferInfo ClevelandResult
ops
OperationInfo ClevelandResult
_ -> Maybe [ContractEvent]
forall a. Maybe a
Nothing
instance DoTransfer 'Unchecked where
doTransfer :: forall (m :: * -> *).
(HasCallStack, MonadOpsInternal m) =>
GenericTransferData 'Unchecked -> m [ContractEvent]
doTransfer GenericTransferData
{ gtdAddr :: forall (mode :: TransferMode).
GenericTransferData mode -> L1Address
gtdAddr = L1Address
tdTo
, gtdAmount :: forall (mode :: TransferMode). GenericTransferData mode -> Mutez
gtdAmount = Mutez
tdAmount
, gtdCall :: forall (mode :: TransferMode).
GenericTransferData mode -> GenericCall mode
gtdCall = UncheckedCall EpName
tdEntrypoint epArg
tdParameter
} = TransferData -> m [ContractEvent]
forall (m :: * -> *).
(HasCallStack, MonadOpsInternal m) =>
TransferData -> m [ContractEvent]
runTransfer TransferData :: forall v addr.
(NiceParameter v, ToL1Address addr) =>
addr -> Mutez -> EpName -> v -> TransferData
TransferData{epArg
L1Address
Mutez
EpName
tdParameter :: epArg
tdEntrypoint :: EpName
tdAmount :: Mutez
tdTo :: L1Address
tdParameter :: epArg
tdEntrypoint :: EpName
tdAmount :: Mutez
tdTo :: L1Address
..}
instance DoTransfer ('Checked param) where
doTransfer :: forall (m :: * -> *).
(HasCallStack, MonadOpsInternal m) =>
GenericTransferData ('Checked param) -> m [ContractEvent]
doTransfer GenericTransferData
{ gtdAddr :: forall (mode :: TransferMode).
GenericTransferData mode -> L1Address
gtdAddr = L1Address
tdTo
, gtdAmount :: forall (mode :: TransferMode). GenericTransferData mode -> Mutez
gtdAmount = Mutez
tdAmount
, gtdCall :: forall (mode :: TransferMode).
GenericTransferData mode -> GenericCall mode
gtdCall = CheckedCall (epRef
epRef :: epRef) (epArg
tdParameter :: epArg)
} | (Dict (ParameterScope (ToT epArg))
Dict, EpName
tdEntrypoint) <- 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 @param @epRef @epArg epRef
epRef
= TransferData -> m [ContractEvent]
forall (m :: * -> *).
(HasCallStack, MonadOpsInternal m) =>
TransferData -> m [ContractEvent]
runTransfer TransferData :: forall v addr.
(NiceParameter v, ToL1Address addr) =>
addr -> Mutez -> EpName -> v -> TransferData
TransferData{epArg
L1Address
Mutez
EpName
tdEntrypoint :: EpName
tdParameter :: epArg
tdAmount :: Mutez
tdTo :: L1Address
tdParameter :: epArg
tdEntrypoint :: EpName
tdAmount :: Mutez
tdTo :: L1Address
..}
instance HasEntrypointArg param (EntrypointRef 'Nothing) ()
=> DoTransfer ('Incomplete ('Checked param)) where
doTransfer :: forall (m :: * -> *).
(HasCallStack, MonadOpsInternal m) =>
GenericTransferData ('Incomplete ('Checked param))
-> m [ContractEvent]
doTransfer GenericTransferData{L1Address
Mutez
GenericCall ('Incomplete ('Checked param))
gtdAmount :: Mutez
gtdCall :: GenericCall ('Incomplete ('Checked param))
gtdAddr :: L1Address
gtdAmount :: forall (mode :: TransferMode). GenericTransferData mode -> Mutez
gtdCall :: forall (mode :: TransferMode).
GenericTransferData mode -> GenericCall mode
gtdAddr :: forall (mode :: TransferMode).
GenericTransferData mode -> L1Address
..} =
GenericTransferData ('Checked param) -> m [ContractEvent]
forall (mode :: TransferMode) (m :: * -> *).
(DoTransfer mode, HasCallStack, MonadOpsInternal m) =>
GenericTransferData mode -> m [ContractEvent]
doTransfer GenericTransferData :: forall (mode :: TransferMode).
L1Address -> GenericCall mode -> Mutez -> GenericTransferData mode
GenericTransferData {gtdCall :: GenericCall ('Checked param)
gtdCall = EntrypointRef 'Nothing
-> forall epArg param.
(NiceParameter epArg,
HasEntrypointArg param (EntrypointRef 'Nothing) epArg) =>
epArg -> GenericCall ('Checked param)
forall (mname :: Maybe Symbol).
EntrypointRef mname
-> forall epArg param.
(NiceParameter epArg,
HasEntrypointArg param (EntrypointRef mname) epArg) =>
epArg -> GenericCall ('Checked param)
calling EntrypointRef 'Nothing
CallDefault @_ @param (), L1Address
Mutez
gtdAmount :: Mutez
gtdAddr :: L1Address
gtdAmount :: Mutez
gtdAddr :: L1Address
..}
instance DoTransfer ('Incomplete 'Unchecked) where
doTransfer :: forall (m :: * -> *).
(HasCallStack, MonadOpsInternal m) =>
GenericTransferData ('Incomplete 'Unchecked) -> m [ContractEvent]
doTransfer GenericTransferData{L1Address
Mutez
GenericCall ('Incomplete 'Unchecked)
gtdAmount :: Mutez
gtdCall :: GenericCall ('Incomplete 'Unchecked)
gtdAddr :: L1Address
gtdAmount :: forall (mode :: TransferMode). GenericTransferData mode -> Mutez
gtdCall :: forall (mode :: TransferMode).
GenericTransferData mode -> GenericCall mode
gtdAddr :: forall (mode :: TransferMode).
GenericTransferData mode -> L1Address
..} =
GenericTransferData 'Unchecked -> m [ContractEvent]
forall (mode :: TransferMode) (m :: * -> *).
(DoTransfer mode, HasCallStack, MonadOpsInternal m) =>
GenericTransferData mode -> m [ContractEvent]
doTransfer GenericTransferData :: forall (mode :: TransferMode).
L1Address -> GenericCall mode -> Mutez -> GenericTransferData mode
GenericTransferData {gtdCall :: GenericCall 'Unchecked
gtdCall = EpName
-> forall epArg.
NiceParameter epArg =>
epArg -> GenericCall 'Unchecked
unsafeCalling EpName
U.DefEpName (), L1Address
Mutez
gtdAmount :: Mutez
gtdAddr :: L1Address
gtdAmount :: Mutez
gtdAddr :: L1Address
..}
calling
:: forall mname.
EntrypointRef mname
-> forall epArg param. (NiceParameter epArg, HasEntrypointArg param (EntrypointRef mname) epArg)
=> epArg -> GenericCall ('Checked param)
calling :: forall (mname :: Maybe Symbol).
EntrypointRef mname
-> forall epArg param.
(NiceParameter epArg,
HasEntrypointArg param (EntrypointRef mname) epArg) =>
epArg -> GenericCall ('Checked param)
calling EntrypointRef mname
arg = EntrypointRef mname -> epArg -> GenericCall ('Checked param)
forall epArg param epRef.
(NiceParameter epArg, HasEntrypointArg param epRef epArg) =>
epRef -> epArg -> GenericCall ('Checked param)
CheckedCall EntrypointRef mname
arg
unsafeCalling :: U.EpName -> forall epArg. NiceParameter epArg => epArg -> GenericCall 'Unchecked
unsafeCalling :: EpName
-> forall epArg.
NiceParameter epArg =>
epArg -> GenericCall 'Unchecked
unsafeCalling EpName
arg = EpName -> epArg -> GenericCall 'Unchecked
forall epArg.
NiceParameter epArg =>
EpName -> epArg -> GenericCall 'Unchecked
UncheckedCall EpName
arg
data WithContractEvents = WithContractEvents