{-# OPTIONS_HADDOCK not-home #-}
module Test.Cleveland.Internal.Actions.Originate
( module Test.Cleveland.Internal.Actions.Originate
) where
import Lorentz (Contract(..), NiceViewsDescriptor)
import Data.Coerce (coerce)
import Data.Constraint (Bottom(..))
import GHC.TypeLits (ErrorMessage(..), Symbol, TypeError)
import Morley.Client.Types
import Morley.Michelson.Typed qualified as T
import Morley.Michelson.Untyped qualified as U
import Morley.Tezos.Address
import Morley.Tezos.Address.Alias
import Morley.Tezos.Core
import Morley.Tezos.Crypto (KeyHash)
import Test.Cleveland.Internal.Abstract
import Test.Cleveland.Internal.Actions.Helpers
import Test.Cleveland.Internal.Actions.MonadOpsInternal
import Test.Cleveland.Lorentz.Types
originate
:: forall contract r.
( HasCallStack, ContractClass contract, OriginateFunc contract '[] r)
=> ContractAlias -> ContractStorage contract -> contract -> r
originate :: forall contract r.
(HasCallStack, ContractClass contract,
OriginateFunc contract '[] r) =>
ContractAlias -> ContractStorage contract -> contract -> r
originate = forall contract (props :: [Prop]) r.
(OriginateFunc contract props r, HasCallStack) =>
OriginateData (ContractOriginateType contract) (GetLarge props)
-> r
originate'r @contract @'[] (OriginateData (ContractOriginateType contract) 'NotLarge -> r)
-> (ContractAlias
-> ContractStorage' (ContractOriginateType contract)
-> contract
-> OriginateData (ContractOriginateType contract) 'NotLarge)
-> ContractAlias
-> ContractStorage' (ContractOriginateType contract)
-> contract
-> r
forall a b c. SuperComposition a b c => a -> b -> c
... forall contract.
ContractClass contract =>
ContractAlias
-> ContractStorage contract
-> contract
-> OriginateData (ContractOriginateType contract) 'NotLarge
initialData @contract
type OriginationResult :: OriginationType -> Type
type family OriginationResult a where
OriginationResult 'OTUntyped = ContractAddress
OriginationResult ('OTTypedMorley cp st vd) = ContractHandle cp st vd
OriginationResult ('OTTypedLorentz cp st vd) = ContractHandle cp st vd
originateFn
:: (HasCallStack, Originator large m)
=> OriginateData ot large -> m (OriginationResult ot)
originateFn :: forall (large :: LargeOrigination) (m :: * -> *)
(ot :: OriginationType).
(HasCallStack, Originator large m) =>
OriginateData ot large -> m (OriginationResult ot)
originateFn od :: OriginateData ot large
od@OriginateData{Maybe KeyHash
Mutez
ContractAlias
ODContractAndStorage ot
odContractAndStorage :: forall (oty :: OriginationType) (large :: LargeOrigination).
OriginateData oty large -> ODContractAndStorage oty
odDelegate :: forall (oty :: OriginationType) (large :: LargeOrigination).
OriginateData oty large -> Maybe KeyHash
odBalance :: forall (oty :: OriginationType) (large :: LargeOrigination).
OriginateData oty large -> Mutez
odName :: forall (oty :: OriginationType) (large :: LargeOrigination).
OriginateData oty large -> ContractAlias
odContractAndStorage :: ODContractAndStorage ot
odDelegate :: Maybe KeyHash
odBalance :: Mutez
odName :: ContractAlias
..} = case ODContractAndStorage ot
odContractAndStorage of
ODContractAndStorageUntyped{} -> OriginateData ot large -> m ContractAddress
forall (large :: LargeOrigination) (m :: * -> *)
(oty :: OriginationType).
(Originator large m, HasCallStack) =>
OriginateData oty large -> m ContractAddress
doOriginate OriginateData ot large
od
ODContractAndStorageTyped st
_ T.Contract{} -> ContractAlias -> ContractAddress -> ContractHandle cp st vd
forall cp st vd.
(NiceParameter cp, NiceStorage st, NiceViewsDescriptor vd) =>
ContractAlias -> ContractAddress -> ContractHandle cp st vd
ContractHandle ContractAlias
odName (ContractAddress -> ContractHandle cp st vd)
-> m ContractAddress -> m (ContractHandle cp st vd)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OriginateData ot large -> m ContractAddress
forall (large :: LargeOrigination) (m :: * -> *)
(oty :: OriginationType).
(Originator large m, HasCallStack) =>
OriginateData oty large -> m ContractAddress
doOriginate OriginateData ot large
od
ODContractAndStorageLorentz st
_ Contract{} -> ContractAlias -> ContractAddress -> ContractHandle param st vd
forall cp st vd.
(NiceParameter cp, NiceStorage st, NiceViewsDescriptor vd) =>
ContractAlias -> ContractAddress -> ContractHandle cp st vd
ContractHandle ContractAlias
odName (ContractAddress -> ContractHandle param st vd)
-> m ContractAddress -> m (ContractHandle param st vd)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OriginateData ot large -> m ContractAddress
forall (large :: LargeOrigination) (m :: * -> *)
(oty :: OriginationType).
(Originator large m, HasCallStack) =>
OriginateData oty large -> m ContractAddress
doOriginate OriginateData ot large
od
class MonadOpsInternal m => Originator large m where
doOriginate :: HasCallStack => OriginateData oty large -> m ContractAddress
instance MonadOpsInternal m => Originator 'NotLarge m where
doOriginate :: forall (oty :: OriginationType).
HasCallStack =>
OriginateData oty 'NotLarge -> m ContractAddress
doOriginate OriginateData oty 'NotLarge
od = (ClevelandOpsImpl m -> m ContractAddress) -> m ContractAddress
forall (m :: * -> *) a.
MonadOpsInternal m =>
(ClevelandOpsImpl m -> m a) -> m a
withOpsCap \ClevelandOpsImpl m
opsCap ->
ClevelandOpsImpl m
-> Text
-> OperationInfo ClevelandInput
-> (OperationInfo ClevelandResult -> Maybe ContractAddress)
-> m ContractAddress
forall (m :: * -> *) a.
(HasCallStack, Functor m) =>
ClevelandOpsImpl m
-> Text
-> OperationInfo ClevelandInput
-> (OperationInfo ClevelandResult -> Maybe a)
-> m a
runSingleOperation ClevelandOpsImpl m
opsCap Text
"origination" (OriginationInfo ClevelandInput -> OperationInfo ClevelandInput
forall i. OriginationInfo i -> OperationInfo i
OpOriginate (OriginationInfo ClevelandInput -> OperationInfo ClevelandInput)
-> OriginationInfo ClevelandInput -> OperationInfo ClevelandInput
forall a b. (a -> b) -> a -> b
$ OriginateData oty 'NotLarge -> SomeOriginateData 'NotLarge
forall (oty :: OriginationType) (large :: LargeOrigination).
OriginateData oty large -> SomeOriginateData large
SomeOriginateData OriginateData oty 'NotLarge
od) \case
OpOriginate OriginationInfo ClevelandResult
addr -> ContractAddress -> Maybe ContractAddress
forall a. a -> Maybe a
Just ContractAddress
OriginationInfo ClevelandResult
addr
OperationInfo ClevelandResult
_ -> Maybe ContractAddress
forall a. Maybe a
Nothing
instance MonadCleveland caps m => Originator 'IsLarge m where
doOriginate :: forall (oty :: OriginationType).
HasCallStack =>
OriginateData oty 'IsLarge -> m ContractAddress
doOriginate OriginateData oty 'IsLarge
od = do
Sender
sender <- Getting Sender caps Sender -> m Sender
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Sender caps Sender
forall caps. HasClevelandCaps caps => Lens' caps Sender
senderL
(caps -> ClevelandMiscImpl (ClevelandBaseMonad caps))
-> (ClevelandMiscImpl (ClevelandBaseMonad caps)
-> ClevelandBaseMonad caps ContractAddress)
-> ReaderT caps (ClevelandBaseMonad caps) ContractAddress
forall (m :: * -> *) caps cap a.
Monad m =>
(caps -> cap) -> (cap -> m a) -> ReaderT caps m a
withCap caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
forall caps.
HasClevelandCaps caps =>
caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
getMiscCap \ClevelandMiscImpl (ClevelandBaseMonad caps)
cap -> ClevelandMiscImpl (ClevelandBaseMonad caps)
-> forall (oty :: OriginationType).
HasCallStack =>
Sender
-> OriginateData oty 'IsLarge
-> ClevelandBaseMonad caps ContractAddress
forall (m :: * -> *).
ClevelandMiscImpl m
-> forall (oty :: OriginationType).
HasCallStack =>
Sender -> OriginateData oty 'IsLarge -> m ContractAddress
cmiOriginateLargeUntyped ClevelandMiscImpl (ClevelandBaseMonad caps)
cap Sender
sender OriginateData oty 'IsLarge
od
type ContractStorage contract = ContractStorage' (ContractOriginateType contract)
type ContractStorage' :: OriginationType -> Type
type family ContractStorage' contract where
ContractStorage' 'OTUntyped = U.Value
ContractStorage' ('OTTypedMorley _ st _) = st
ContractStorage' ('OTTypedLorentz _ st _) = st
initialData
:: ContractClass contract
=> ContractAlias
-> ContractStorage contract
-> contract
-> OriginateData (ContractOriginateType contract) 'NotLarge
initialData :: forall contract.
ContractClass contract =>
ContractAlias
-> ContractStorage contract
-> contract
-> OriginateData (ContractOriginateType contract) 'NotLarge
initialData ContractAlias
name = ContractAlias
-> Mutez
-> Maybe KeyHash
-> ODContractAndStorage (ContractOriginateType contract)
-> OriginateData (ContractOriginateType contract) 'NotLarge
forall (oty :: OriginationType) (large :: LargeOrigination).
ContractAlias
-> Mutez
-> Maybe KeyHash
-> ODContractAndStorage oty
-> OriginateData oty large
OriginateData ContractAlias
name Mutez
zeroMutez Maybe KeyHash
forall a. Maybe a
Nothing (ODContractAndStorage (ContractOriginateType contract)
-> OriginateData (ContractOriginateType contract) 'NotLarge)
-> (ContractStorage' (ContractOriginateType contract)
-> contract
-> ODContractAndStorage (ContractOriginateType contract))
-> ContractStorage' (ContractOriginateType contract)
-> contract
-> OriginateData (ContractOriginateType contract) 'NotLarge
forall a b c. SuperComposition a b c => a -> b -> c
... ContractStorage' (ContractOriginateType contract)
-> contract
-> ODContractAndStorage (ContractOriginateType contract)
forall contract.
ContractClass contract =>
ContractStorage contract
-> contract
-> ODContractAndStorage (ContractOriginateType contract)
initialStorageAndContract
class ContractClass contract where
type ContractOriginateType contract :: OriginationType
initialStorageAndContract
:: ContractStorage contract -> contract -> ODContractAndStorage (ContractOriginateType contract)
instance ContractClass (Contract cp st vd) where
type ContractOriginateType (Contract cp st vd) = 'OTTypedLorentz cp st vd
initialStorageAndContract :: ContractStorage (Contract cp st vd)
-> Contract cp st vd
-> ODContractAndStorage (ContractOriginateType (Contract cp st vd))
initialStorageAndContract = ContractStorage (Contract cp st vd)
-> Contract cp st vd
-> ODContractAndStorage (ContractOriginateType (Contract cp st vd))
forall st param vd.
st
-> Contract param st vd
-> ODContractAndStorage ('OTTypedLorentz param st vd)
ODContractAndStorageLorentz
instance ContractClass U.Contract where
type ContractOriginateType U.Contract = 'OTUntyped
initialStorageAndContract :: ContractStorage Contract
-> Contract
-> ODContractAndStorage (ContractOriginateType Contract)
initialStorageAndContract = Value -> Contract -> ODContractAndStorage 'OTUntyped
ContractStorage Contract
-> Contract
-> ODContractAndStorage (ContractOriginateType Contract)
ODContractAndStorageUntyped
instance (NiceStorage st, NiceViewsDescriptor vd, NiceParameter cp)
=> ContractClass (TypedContract cp st vd) where
type ContractOriginateType (TypedContract cp st vd) = 'OTTypedMorley cp st vd
initialStorageAndContract :: ContractStorage (TypedContract cp st vd)
-> TypedContract cp st vd
-> ODContractAndStorage
(ContractOriginateType (TypedContract cp st vd))
initialStorageAndContract ContractStorage (TypedContract cp st vd)
store (TypedContract Contract (ToT cp) (ToT st)
contract) =
st
-> Contract (ToT cp) (ToT st)
-> ODContractAndStorage ('OTTypedMorley cp st vd)
forall st vd cp.
(NiceStorage st, NiceViewsDescriptor vd, NiceParameter cp) =>
st
-> Contract (ToT cp) (ToT st)
-> ODContractAndStorage ('OTTypedMorley cp st vd)
ODContractAndStorageTyped st
ContractStorage (TypedContract cp st vd)
store Contract (ToT cp) (ToT st)
contract
class OriginateFunc contract (props :: [Prop]) r where
originate'r
:: HasCallStack
=> OriginateData (ContractOriginateType contract) (GetLarge props) -> r
data Prop = PropBalance | PropDelegate | PropLarge
type PropName :: Prop -> Symbol
type family PropName a where
PropName 'PropBalance = "Balance"
PropName 'PropDelegate = "Delegate"
PropName 'PropLarge = "Large"
type GetLarge :: [Prop] -> LargeOrigination
type family GetLarge a where
GetLarge ('PropLarge ': _) = 'IsLarge
GetLarge (_ ': xs) = GetLarge xs
GetLarge '[] = 'NotLarge
type CheckDupProp :: Prop -> [Prop] -> Constraint
type family CheckDupProp name props where
CheckDupProp name (name ': _) =
TypeError ('Text (PropName name) ':<>: 'Text " is specified more than once.")
CheckDupProp name (_ ': xs) = CheckDupProp name xs
CheckDupProp _ '[] = ()
type OFConstraints ct prop props r =
( OriginateFunc ct (prop ': props) r
, CheckDupProp prop props)
instance OFConstraints ct 'PropBalance props r => OriginateFunc ct props (Mutez -> r) where
originate'r :: HasCallStack =>
OriginateData (ContractOriginateType ct) (GetLarge props)
-> Mutez -> r
originate'r OriginateData (ContractOriginateType ct) (GetLarge props)
initData Mutez
x = forall contract (props :: [Prop]) r.
(OriginateFunc contract props r, HasCallStack) =>
OriginateData (ContractOriginateType contract) (GetLarge props)
-> r
originate'r @ct @('PropBalance : props) (OriginateData
(ContractOriginateType ct) (GetLarge ('PropBalance : props))
-> r)
-> OriginateData
(ContractOriginateType ct) (GetLarge ('PropBalance : props))
-> r
forall a b. (a -> b) -> a -> b
$ OriginateData (ContractOriginateType ct) (GetLarge props)
initData{odBalance :: Mutez
odBalance = Mutez
x}
instance OFConstraints ct 'PropDelegate props r => OriginateFunc ct props (KeyHash -> r) where
originate'r :: HasCallStack =>
OriginateData (ContractOriginateType ct) (GetLarge props)
-> KeyHash -> r
originate'r OriginateData (ContractOriginateType ct) (GetLarge props)
initData KeyHash
x = forall contract (props :: [Prop]) r.
(OriginateFunc contract props r, HasCallStack) =>
OriginateData (ContractOriginateType contract) (GetLarge props)
-> r
originate'r @ct @('PropDelegate : props) (OriginateData
(ContractOriginateType ct) (GetLarge ('PropDelegate : props))
-> r)
-> OriginateData
(ContractOriginateType ct) (GetLarge ('PropDelegate : props))
-> r
forall a b. (a -> b) -> a -> b
$ OriginateData (ContractOriginateType ct) (GetLarge props)
initData{odDelegate :: Maybe KeyHash
odDelegate = KeyHash -> Maybe KeyHash
forall a. a -> Maybe a
Just KeyHash
x}
instance (OFConstraints ct 'PropLarge props r, GetLarge props ~ 'NotLarge)
=> OriginateFunc ct props (Large -> r) where
originate'r :: HasCallStack =>
OriginateData (ContractOriginateType ct) (GetLarge props)
-> Large -> r
originate'r OriginateData (ContractOriginateType ct) (GetLarge props)
initData Large
Large = forall contract (props :: [Prop]) r.
(OriginateFunc contract props r, HasCallStack) =>
OriginateData (ContractOriginateType contract) (GetLarge props)
-> r
originate'r @ct @('PropLarge ': props) (OriginateData
(ContractOriginateType ct) (GetLarge ('PropLarge : props))
-> r)
-> OriginateData
(ContractOriginateType ct) (GetLarge ('PropLarge : props))
-> r
forall a b. (a -> b) -> a -> b
$ OriginateData (ContractOriginateType ct) 'NotLarge
-> OriginateData (ContractOriginateType ct) 'IsLarge
coerce OriginateData (ContractOriginateType ct) 'NotLarge
OriginateData (ContractOriginateType ct) (GetLarge props)
initData
type TerminatingOFConstraints ct props m a =
(Originator (GetLarge props) m, a ~ OriginationResult (ContractOriginateType ct))
instance TerminatingOFConstraints ct props ClevelandOpsBatch a
=> OriginateFunc ct props (ClevelandOpsBatch a) where
originate'r :: HasCallStack =>
OriginateData (ContractOriginateType ct) (GetLarge props)
-> ClevelandOpsBatch a
originate'r = OriginateData (ContractOriginateType ct) (GetLarge props)
-> ClevelandOpsBatch a
forall (large :: LargeOrigination) (m :: * -> *)
(ot :: OriginationType).
(HasCallStack, Originator large m) =>
OriginateData ot large -> m (OriginationResult ot)
originateFn
instance TerminatingOFConstraints ct props (ReaderT cap base) a
=> OriginateFunc ct props (ReaderT cap base a) where
originate'r :: HasCallStack =>
OriginateData (ContractOriginateType ct) (GetLarge props)
-> ReaderT cap base a
originate'r = OriginateData (ContractOriginateType ct) (GetLarge props)
-> ReaderT cap base a
forall (large :: LargeOrigination) (m :: * -> *)
(ot :: OriginationType).
(HasCallStack, Originator large m) =>
OriginateData ot large -> m (OriginationResult ot)
originateFn
class (MonadOpsInternal m
, forall ct props a. TerminatingOFConstraints ct props m a => OriginateFunc ct props (m a)
) => MonadOriginate m
instance (MonadOpsInternal m
, forall ct props a. TerminatingOFConstraints ct props m a => OriginateFunc ct props (m a)
) => MonadOriginate m
instance {-# INCOHERENT #-}
( TypeError ('Text "Incorrect argument for the 'originate' function: " ':<>: 'ShowType x ':$$:
'Text "If in doubt, try adding a type annotation.")
, Bottom)
=> OriginateFunc ct props (x -> r) where
originate'r :: HasCallStack =>
OriginateData (ContractOriginateType ct) (GetLarge props) -> x -> r
originate'r = forall a. Bottom => a
OriginateData (ContractOriginateType ct) (GetLarge props) -> x -> r
no
data Large = Large