module Test.Cleveland.Internal.Actions.Originate
( module Test.Cleveland.Internal.Actions.Originate
) where
import Lorentz
(Contract(..), NiceParameter, NiceStorage, NiceViewsDescriptor, niceStorageEvi,
toMichelsonContract)
import Data.Constraint ((\\))
import GHC.TypeLits (ErrorMessage(..), TypeError)
import Morley.Client.Types
import Morley.Michelson.Typed (convertContract, toVal, untypeValue)
import Morley.Michelson.Typed qualified as T
import Morley.Michelson.Untyped qualified as U
import Morley.Tezos.Address
import Morley.Tezos.Core
import Test.Cleveland.Internal.Abstract
import Test.Cleveland.Internal.Actions.Helpers
import Test.Cleveland.Internal.Actions.MonadOps
originate :: forall contract r. (HasCallStack, OriginateFunc contract 'NoBalance 'NotLarge r)
=> ContractAlias -> ContractStorage contract -> contract -> r
originate :: forall contract r.
(HasCallStack, OriginateFunc contract 'NoBalance 'NotLarge r) =>
ContractAlias -> ContractStorage contract -> contract -> r
originate = forall contract (bal :: HasBalance) (isLarge :: LargeOrigination)
r.
(OriginateFunc contract bal isLarge r, HasCallStack) =>
ContractOriginateData contract isLarge -> r
originate'r @contract @'NoBalance @'NotLarge (ContractOriginateData contract 'NotLarge -> r)
-> (ContractAlias
-> ContractStorage contract
-> contract
-> ContractOriginateData contract 'NotLarge)
-> ContractAlias
-> ContractStorage contract
-> contract
-> r
forall a b c. SuperComposition a b c => a -> b -> c
... forall contract.
ContractClass contract =>
ContractAlias
-> ContractStorage contract
-> contract
-> ContractOriginateData contract 'NotLarge
initialData @contract
class Originator od res where
originateFn :: HasCallStack => od -> res
instance (a ~ ContractHandle cp st vd, MonadOpsInternal m
, Originator (UntypedOriginateData large) (m ContractAddress))
=> Originator (OriginateData cp st vd large) (m a) where
originateFn :: HasCallStack => OriginateData cp st vd large -> m a
originateFn od :: OriginateData cp st vd large
od@OriginateData{ odContract :: forall param st vd (large :: LargeOrigination).
OriginateData param st vd large -> Contract param st vd
odContract=Contract{}, st
Mutez
ContractAlias
odStorage :: forall param st vd (large :: LargeOrigination).
OriginateData param st vd large -> st
odBalance :: forall param st vd (large :: LargeOrigination).
OriginateData param st vd large -> Mutez
odName :: forall param st vd (large :: LargeOrigination).
OriginateData param st vd large -> ContractAlias
odStorage :: st
odBalance :: Mutez
odName :: ContractAlias
..} = do
let uod :: UntypedOriginateData large
uod = forall (large :: LargeOrigination).
ContractAlias
-> Mutez -> Value -> Contract -> UntypedOriginateData large
UntypedOriginateData @large
ContractAlias
odName
Mutez
odBalance
(Value' Instr (ToT st) -> Value
forall (t :: T). HasNoOp t => Value' Instr t -> Value
untypeValue (st -> Value' Instr (ToT st)
forall a. IsoValue a => a -> Value (ToT a)
toVal st
odStorage) (StorageScope (ToT st) => Value)
-> (NiceStorage st :- StorageScope (ToT st)) -> Value
forall (c :: Constraint) e r. HasDict c e => (c => r) -> e -> r
\\ forall a. NiceStorage a :- StorageScope (ToT a)
niceStorageEvi @st)
(Contract (ToT cp) (ToT st) -> Contract
forall (param :: T) (store :: T). Contract param store -> Contract
convertContract (Contract (ToT cp) (ToT st) -> Contract)
-> Contract (ToT cp) (ToT st) -> Contract
forall a b. (a -> b) -> a -> b
$ Contract cp st vd -> Contract (ToT cp) (ToT st)
forall cp st vd. Contract cp st vd -> Contract (ToT cp) (ToT st)
toMichelsonContract (OriginateData cp st vd large -> Contract cp st vd
forall param st vd (large :: LargeOrigination).
OriginateData param st vd large -> Contract param st vd
odContract OriginateData cp st vd large
od))
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
<$> UntypedOriginateData large -> m ContractAddress
forall od res. (Originator od res, HasCallStack) => od -> res
originateFn UntypedOriginateData large
uod
instance (a ~ ContractHandle cp st vd, MonadOpsInternal m
, Originator (UntypedOriginateData large) (m ContractAddress)
, NiceStorage st, NiceViewsDescriptor vd, NiceParameter cp)
=> Originator (TypedOriginateData cp st vd large) (m a) where
originateFn :: HasCallStack => TypedOriginateData cp st vd large -> m a
originateFn tod :: TypedOriginateData cp st vd large
tod@TypedOriginateData{todContract :: forall {k} cp st (vd :: k) (large :: LargeOrigination).
TypedOriginateData cp st vd large -> Contract (ToT cp) (ToT st)
todContract = T.Contract{}, st
Mutez
ContractAlias
todStorage :: forall {k} cp st (vd :: k) (large :: LargeOrigination).
TypedOriginateData cp st vd large -> st
todBalance :: forall {k} cp st (vd :: k) (large :: LargeOrigination).
TypedOriginateData cp st vd large -> Mutez
todName :: forall {k} cp st (vd :: k) (large :: LargeOrigination).
TypedOriginateData cp st vd large -> ContractAlias
todStorage :: st
todBalance :: Mutez
todName :: ContractAlias
..} = do
let uod :: UntypedOriginateData large
uod = forall (large :: LargeOrigination).
ContractAlias
-> Mutez -> Value -> Contract -> UntypedOriginateData large
UntypedOriginateData @large
ContractAlias
todName
Mutez
todBalance
(Value' Instr (ToT st) -> Value
forall (t :: T). HasNoOp t => Value' Instr t -> Value
untypeValue (st -> Value' Instr (ToT st)
forall a. IsoValue a => a -> Value (ToT a)
toVal st
todStorage))
(Contract' Instr (ToT cp) (ToT st) -> Contract
forall (param :: T) (store :: T). Contract param store -> Contract
convertContract (TypedOriginateData cp st vd large
-> Contract' Instr (ToT cp) (ToT st)
forall {k} cp st (vd :: k) (large :: LargeOrigination).
TypedOriginateData cp st vd large -> Contract (ToT cp) (ToT st)
todContract TypedOriginateData cp st vd large
tod))
ContractAlias -> ContractAddress -> ContractHandle cp st vd
forall cp st vd.
(NiceParameter cp, NiceStorage st, NiceViewsDescriptor vd) =>
ContractAlias -> ContractAddress -> ContractHandle cp st vd
ContractHandle ContractAlias
todName (ContractAddress -> ContractHandle cp st vd)
-> m ContractAddress -> m (ContractHandle cp st vd)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UntypedOriginateData large -> m ContractAddress
forall od res. (Originator od res, HasCallStack) => od -> res
originateFn UntypedOriginateData large
uod
instance (a ~ ContractAddress, MonadOpsInternal m)
=> Originator (UntypedOriginateData 'NotLarge) (m a) where
originateFn :: HasCallStack => UntypedOriginateData 'NotLarge -> m a
originateFn UntypedOriginateData 'NotLarge
uod = (ClevelandOpsImpl m -> m a) -> m a
forall (m :: * -> *) a.
MonadOpsInternal m =>
(ClevelandOpsImpl m -> m a) -> m a
withOpsCap \ClevelandOpsImpl m
opsCap ->
ClevelandOpsImpl m
-> Text
-> OperationInfo ClevelandInput
-> (OperationInfo ClevelandResult -> Maybe a)
-> m a
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
UntypedOriginateData 'NotLarge
uod) \case
OpOriginate OriginationInfo ClevelandResult
addr -> a -> Maybe a
forall a. a -> Maybe a
Just a
OriginationInfo ClevelandResult
addr
OperationInfo ClevelandResult
_ -> Maybe a
forall a. Maybe a
Nothing
instance (HasClevelandCaps caps, base ~ ClevelandBaseMonad caps, a ~ ContractAddress) =>
Originator (UntypedOriginateData 'IsLarge) (ReaderT caps base a) where
originateFn :: HasCallStack =>
UntypedOriginateData 'IsLarge -> ReaderT caps base a
originateFn UntypedOriginateData 'IsLarge
uod = do
Sender
sender <- Getting Sender caps Sender -> ReaderT caps base 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 base)
-> (ClevelandMiscImpl base -> base ContractAddress)
-> ReaderT caps base ContractAddress
forall (m :: * -> *) caps cap a.
Monad m =>
(caps -> cap) -> (cap -> m a) -> ReaderT caps m a
withCap caps -> ClevelandMiscImpl base
forall caps.
HasClevelandCaps caps =>
caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
getMiscCap \ClevelandMiscImpl base
cap -> ClevelandMiscImpl base
-> HasCallStack =>
Sender -> UntypedOriginateData 'IsLarge -> base ContractAddress
forall (m :: * -> *).
ClevelandMiscImpl m
-> HasCallStack =>
Sender -> UntypedOriginateData 'IsLarge -> m ContractAddress
cmiOriginateLargeUntyped ClevelandMiscImpl base
cap Sender
sender UntypedOriginateData 'IsLarge
uod
class ContractClass contract where
type ContractStorage contract
type ContractOriginateData contract :: LargeOrigination -> Type
initialData
:: ContractAlias -> ContractStorage contract -> contract
-> ContractOriginateData contract 'NotLarge
instance ContractClass (Contract cp st vd) where
type ContractStorage (Contract cp st vd) = st
type ContractOriginateData (Contract cp st vd) = OriginateData cp st vd
initialData :: ContractAlias
-> ContractStorage (Contract cp st vd)
-> Contract cp st vd
-> ContractOriginateData (Contract cp st vd) 'NotLarge
initialData = (ContractAlias
-> Mutez
-> st
-> Contract cp st vd
-> OriginateData cp st vd 'NotLarge)
-> Mutez
-> ContractAlias
-> st
-> Contract cp st vd
-> OriginateData cp st vd 'NotLarge
forall a b c. (a -> b -> c) -> b -> a -> c
flip ContractAlias
-> Mutez
-> st
-> Contract cp st vd
-> OriginateData cp st vd 'NotLarge
forall param st vd (large :: LargeOrigination).
ContractAlias
-> Mutez
-> st
-> Contract param st vd
-> OriginateData param st vd large
OriginateData Mutez
zeroMutez
instance ContractClass U.Contract where
type ContractStorage U.Contract = U.Value
type ContractOriginateData U.Contract = UntypedOriginateData
initialData :: ContractAlias
-> ContractStorage Contract
-> Contract
-> ContractOriginateData Contract 'NotLarge
initialData = (ContractAlias
-> Mutez -> Value -> Contract -> UntypedOriginateData 'NotLarge)
-> Mutez
-> ContractAlias
-> Value
-> Contract
-> UntypedOriginateData 'NotLarge
forall a b c. (a -> b -> c) -> b -> a -> c
flip ContractAlias
-> Mutez -> Value -> Contract -> UntypedOriginateData 'NotLarge
forall (large :: LargeOrigination).
ContractAlias
-> Mutez -> Value -> Contract -> UntypedOriginateData large
UntypedOriginateData Mutez
zeroMutez
instance ContractClass (TypedContract cp st vd) where
type ContractStorage (TypedContract cp st vd) = st
type ContractOriginateData (TypedContract cp st vd) = TypedOriginateData cp st vd
initialData :: ContractAlias
-> ContractStorage (TypedContract cp st vd)
-> TypedContract cp st vd
-> ContractOriginateData (TypedContract cp st vd) 'NotLarge
initialData ContractAlias
name ContractStorage (TypedContract cp st vd)
store (TypedContract Contract (ToT cp) (ToT st)
contract) =
TypedOriginateData :: forall {k} cp st (vd :: k) (large :: LargeOrigination).
ContractAlias
-> Mutez
-> st
-> Contract (ToT cp) (ToT st)
-> TypedOriginateData cp st vd large
TypedOriginateData
{ todName :: ContractAlias
todName = ContractAlias
name
, todBalance :: Mutez
todBalance = Mutez
zeroMutez
, todStorage :: st
todStorage = st
ContractStorage (TypedContract cp st vd)
store
, todContract :: Contract (ToT cp) (ToT st)
todContract = Contract (ToT cp) (ToT st)
contract
}
class ContractClass contract => OriginateFunc contract (bal :: HasBalance) isLarge r where
originate'r :: HasCallStack => ContractOriginateData contract isLarge -> r
default originate'r
:: (HasCallStack, Originator (ContractOriginateData contract isLarge) r)
=> ContractOriginateData contract isLarge -> r
originate'r = ContractOriginateData contract isLarge -> r
forall od res. (Originator od res, HasCallStack) => od -> res
originateFn
data HasBalance = NoBalance | HasBalance
type family CheckDupBalance mod :: Constraint where
CheckDupBalance 'HasBalance = TypeError ('Text "Balance is specified more than once.")
CheckDupBalance 'NoBalance = ()
instance
( ModifyOriginationData (ContractOriginateData ct)
, OriginateFunc ct 'HasBalance isLarge r
, CheckDupBalance bal, bal ~ 'NoBalance)
=> OriginateFunc ct bal isLarge (Mutez -> r) where
originate'r :: HasCallStack => ContractOriginateData ct isLarge -> Mutez -> r
originate'r ContractOriginateData ct isLarge
initData Mutez
x = forall contract (bal :: HasBalance) (isLarge :: LargeOrigination)
r.
(OriginateFunc contract bal isLarge r, HasCallStack) =>
ContractOriginateData contract isLarge -> r
originate'r @ct @'HasBalance (ContractOriginateData ct isLarge -> r)
-> ContractOriginateData ct isLarge -> r
forall a b. (a -> b) -> a -> b
$ Mutez
-> ContractOriginateData ct isLarge
-> ContractOriginateData ct isLarge
forall (od :: LargeOrigination -> *) (large :: LargeOrigination).
ModifyOriginationData od =>
Mutez -> od large -> od large
setBalance Mutez
x ContractOriginateData ct isLarge
initData
type family CheckDupLarge mod :: Constraint where
CheckDupLarge 'IsLarge = TypeError ('Text "Large is specified more than once.")
CheckDupLarge 'NotLarge = ()
instance (ModifyOriginationData (ContractOriginateData ct)
, OriginateFunc ct bal 'IsLarge r
, CheckDupLarge isLarge, isLarge ~ 'NotLarge)
=> OriginateFunc ct bal isLarge (Large -> r) where
originate'r :: HasCallStack => ContractOriginateData ct isLarge -> Large -> r
originate'r ContractOriginateData ct isLarge
initData Large
Large = forall contract (bal :: HasBalance) (isLarge :: LargeOrigination)
r.
(OriginateFunc contract bal isLarge r, HasCallStack) =>
ContractOriginateData contract isLarge -> r
originate'r @ct @bal (ContractOriginateData ct 'IsLarge -> r)
-> ContractOriginateData ct 'IsLarge -> r
forall a b. (a -> b) -> a -> b
$ ContractOriginateData ct 'NotLarge
-> ContractOriginateData ct 'IsLarge
forall (od :: LargeOrigination -> *).
ModifyOriginationData od =>
od 'NotLarge -> od 'IsLarge
setLarge ContractOriginateData ct isLarge
ContractOriginateData ct 'NotLarge
initData
type OFConstraint ct large r =
( ContractClass ct, Originator (ContractOriginateData ct large) r)
instance OFConstraint ct large (ClevelandOpsBatch a)
=> OriginateFunc ct bal large (ClevelandOpsBatch a)
instance OFConstraint ct large (ReaderT cap base a)
=> OriginateFunc ct bal large (ReaderT cap base a)
class (forall ct bal large a. OFConstraint ct large (m a) => OriginateFunc ct bal large (m a))
=> MonadOriginate m
instance (forall ct bal large a. OFConstraint ct large (m a) => OriginateFunc ct bal large (m a))
=> MonadOriginate m
instance {-# INCOHERENT #-}
( ContractClass ct
, TypeError ('Text "Incorrect argument for the 'originate' function: " ':<>: 'ShowType x ':$$:
'Text "If in doubt, try adding a type annotation."))
=> OriginateFunc ct bal large (x -> r) where
originate'r :: HasCallStack => ContractOriginateData ct large -> x -> r
originate'r = Text -> ContractOriginateData ct large -> x -> r
forall a. HasCallStack => Text -> a
error Text
"impossible"
data Large = Large
class ModifyOriginationData od where
setBalance :: Mutez -> od large -> od large
setLarge :: od 'NotLarge -> od 'IsLarge
instance ModifyOriginationData (OriginateData cp st vd) where
setBalance :: forall (large :: LargeOrigination).
Mutez
-> OriginateData cp st vd large -> OriginateData cp st vd large
setBalance Mutez
bal OriginateData cp st vd large
od = OriginateData cp st vd large
od {odBalance :: Mutez
odBalance = Mutez
bal}
setLarge :: OriginateData cp st vd 'NotLarge -> OriginateData cp st vd 'IsLarge
setLarge OriginateData{st
Mutez
Contract cp st vd
ContractAlias
odContract :: Contract cp st vd
odStorage :: st
odBalance :: Mutez
odName :: ContractAlias
odStorage :: forall param st vd (large :: LargeOrigination).
OriginateData param st vd large -> st
odBalance :: forall param st vd (large :: LargeOrigination).
OriginateData param st vd large -> Mutez
odName :: forall param st vd (large :: LargeOrigination).
OriginateData param st vd large -> ContractAlias
odContract :: forall param st vd (large :: LargeOrigination).
OriginateData param st vd large -> Contract param st vd
..} = OriginateData :: forall param st vd (large :: LargeOrigination).
ContractAlias
-> Mutez
-> st
-> Contract param st vd
-> OriginateData param st vd large
OriginateData{st
Mutez
Contract cp st vd
ContractAlias
odContract :: Contract cp st vd
odStorage :: st
odBalance :: Mutez
odName :: ContractAlias
odStorage :: st
odBalance :: Mutez
odName :: ContractAlias
odContract :: Contract cp st vd
..}
instance ModifyOriginationData (UntypedOriginateData) where
setBalance :: forall (large :: LargeOrigination).
Mutez -> UntypedOriginateData large -> UntypedOriginateData large
setBalance Mutez
bal UntypedOriginateData large
od = UntypedOriginateData large
od {uodBalance :: Mutez
uodBalance = Mutez
bal}
setLarge :: UntypedOriginateData 'NotLarge -> UntypedOriginateData 'IsLarge
setLarge UntypedOriginateData{Mutez
Contract
Value
ContractAlias
uodContract :: forall (large :: LargeOrigination).
UntypedOriginateData large -> Contract
uodStorage :: forall (large :: LargeOrigination).
UntypedOriginateData large -> Value
uodName :: forall (large :: LargeOrigination).
UntypedOriginateData large -> ContractAlias
uodContract :: Contract
uodStorage :: Value
uodBalance :: Mutez
uodName :: ContractAlias
uodBalance :: forall (large :: LargeOrigination).
UntypedOriginateData large -> Mutez
..} = UntypedOriginateData :: forall (large :: LargeOrigination).
ContractAlias
-> Mutez -> Value -> Contract -> UntypedOriginateData large
UntypedOriginateData{Mutez
Contract
Value
ContractAlias
uodContract :: Contract
uodStorage :: Value
uodName :: ContractAlias
uodContract :: Contract
uodStorage :: Value
uodBalance :: Mutez
uodName :: ContractAlias
uodBalance :: Mutez
..}
instance ModifyOriginationData (TypedOriginateData cp st vd) where
setBalance :: forall (large :: LargeOrigination).
Mutez
-> TypedOriginateData cp st vd large
-> TypedOriginateData cp st vd large
setBalance Mutez
bal TypedOriginateData cp st vd large
od = TypedOriginateData cp st vd large
od {todBalance :: Mutez
todBalance = Mutez
bal}
setLarge :: TypedOriginateData cp st vd 'NotLarge
-> TypedOriginateData cp st vd 'IsLarge
setLarge TypedOriginateData{st
Mutez
Contract (ToT cp) (ToT st)
ContractAlias
todContract :: Contract (ToT cp) (ToT st)
todStorage :: st
todBalance :: Mutez
todName :: ContractAlias
todStorage :: forall {k} cp st (vd :: k) (large :: LargeOrigination).
TypedOriginateData cp st vd large -> st
todBalance :: forall {k} cp st (vd :: k) (large :: LargeOrigination).
TypedOriginateData cp st vd large -> Mutez
todName :: forall {k} cp st (vd :: k) (large :: LargeOrigination).
TypedOriginateData cp st vd large -> ContractAlias
todContract :: forall {k} cp st (vd :: k) (large :: LargeOrigination).
TypedOriginateData cp st vd large -> Contract (ToT cp) (ToT st)
..} = TypedOriginateData :: forall {k} cp st (vd :: k) (large :: LargeOrigination).
ContractAlias
-> Mutez
-> st
-> Contract (ToT cp) (ToT st)
-> TypedOriginateData cp st vd large
TypedOriginateData{st
Mutez
Contract (ToT cp) (ToT st)
ContractAlias
todContract :: Contract (ToT cp) (ToT st)
todStorage :: st
todBalance :: Mutez
todName :: ContractAlias
todStorage :: st
todBalance :: Mutez
todName :: ContractAlias
todContract :: Contract (ToT cp) (ToT st)
..}