module Lorentz.Contracts.Upgradeable.StorageDriven
( UStoreEntrypoint
, UMarkerEntrypoint
, SduEntrypoint
, pattern UStoreEntrypoint
, mkSduEntrypoint
, mkUStoreEntrypoint
, SduFallback
, UStoreEpInterface
, mkSduContract
, callUStoreEntrypoint
, sduFallbackFail
, sduDocument
, SduDocumentTW
, sduAddEntrypointDoc
, SduAddEntrypointDocTW
, sduContractDoc
) where
import Lorentz
import Prelude (Const(..), Identity(..), Typeable, id)
import qualified Data.Kind as Kind
import Lorentz.Contracts.Upgradeable.Common
import qualified Lorentz.Instr as L
import Lorentz.UStore
import Lorentz.UStore.Doc
import Lorentz.UStore.Traversal
import Util.TypeLits
type SduEntrypointUntyped store =
Lambda (ByteString, UStore store) ([Operation], UStore store)
newtype SduEntrypoint (store :: Kind.Type) (arg :: Kind.Type) = SduEntrypoint
{ SduEntrypoint store arg -> SduEntrypointUntyped store
unSduEntrypoint :: SduEntrypointUntyped store
} deriving stock (SduEntrypoint store arg -> SduEntrypoint store arg -> Bool
(SduEntrypoint store arg -> SduEntrypoint store arg -> Bool)
-> (SduEntrypoint store arg -> SduEntrypoint store arg -> Bool)
-> Eq (SduEntrypoint store arg)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall store arg.
SduEntrypoint store arg -> SduEntrypoint store arg -> Bool
/= :: SduEntrypoint store arg -> SduEntrypoint store arg -> Bool
$c/= :: forall store arg.
SduEntrypoint store arg -> SduEntrypoint store arg -> Bool
== :: SduEntrypoint store arg -> SduEntrypoint store arg -> Bool
$c== :: forall store arg.
SduEntrypoint store arg -> SduEntrypoint store arg -> Bool
Eq, (forall x.
SduEntrypoint store arg -> Rep (SduEntrypoint store arg) x)
-> (forall x.
Rep (SduEntrypoint store arg) x -> SduEntrypoint store arg)
-> Generic (SduEntrypoint store arg)
forall x.
Rep (SduEntrypoint store arg) x -> SduEntrypoint store arg
forall x.
SduEntrypoint store arg -> Rep (SduEntrypoint store arg) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall store arg x.
Rep (SduEntrypoint store arg) x -> SduEntrypoint store arg
forall store arg x.
SduEntrypoint store arg -> Rep (SduEntrypoint store arg) x
$cto :: forall store arg x.
Rep (SduEntrypoint store arg) x -> SduEntrypoint store arg
$cfrom :: forall store arg x.
SduEntrypoint store arg -> Rep (SduEntrypoint store arg) x
Generic)
deriving anyclass (WellTypedToT (SduEntrypoint store arg)
WellTypedToT (SduEntrypoint store arg)
-> (SduEntrypoint store arg
-> Value (ToT (SduEntrypoint store arg)))
-> (Value (ToT (SduEntrypoint store arg))
-> SduEntrypoint store arg)
-> IsoValue (SduEntrypoint store arg)
Value (ToT (SduEntrypoint store arg)) -> SduEntrypoint store arg
SduEntrypoint store arg -> Value (ToT (SduEntrypoint store arg))
forall a.
WellTypedToT a
-> (a -> Value (ToT a)) -> (Value (ToT a) -> a) -> IsoValue a
forall store arg. WellTypedToT (SduEntrypoint store arg)
forall store arg.
Value (ToT (SduEntrypoint store arg)) -> SduEntrypoint store arg
forall store arg.
SduEntrypoint store arg -> Value (ToT (SduEntrypoint store arg))
fromVal :: Value (ToT (SduEntrypoint store arg)) -> SduEntrypoint store arg
$cfromVal :: forall store arg.
Value (ToT (SduEntrypoint store arg)) -> SduEntrypoint store arg
toVal :: SduEntrypoint store arg -> Value (ToT (SduEntrypoint store arg))
$ctoVal :: forall store arg.
SduEntrypoint store arg -> Value (ToT (SduEntrypoint store arg))
$cp1IsoValue :: forall store arg. WellTypedToT (SduEntrypoint store arg)
IsoValue, ToT (SduEntrypoint store arg)
~ ToT (Unwrappable (SduEntrypoint store arg))
(ToT (SduEntrypoint store arg)
~ ToT (Unwrappable (SduEntrypoint store arg)))
-> Wrappable (SduEntrypoint store arg)
forall s. (ToT s ~ ToT (Unwrappable s)) -> Wrappable s
forall store arg.
ToT (SduEntrypoint store arg)
~ ToT (Unwrappable (SduEntrypoint store arg))
Wrappable)
instance ( Typeable store, Typeable arg
, TypeHasDoc (UStore store), TypeHasDoc arg
) =>
TypeHasDoc (SduEntrypoint store arg) where
typeDocMdDescription :: Markdown
typeDocMdDescription =
Markdown
"Public upgradeable entrypoint of a contract."
typeDocMdReference :: Proxy (SduEntrypoint store arg) -> WithinParens -> Markdown
typeDocMdReference Proxy (SduEntrypoint store arg)
tp =
(Text, DType) -> [DType] -> WithinParens -> Markdown
customTypeDocMdReference (Text
"SduEntrypoint", Proxy (SduEntrypoint store arg) -> DType
forall a. TypeHasDoc a => Proxy a -> DType
DType Proxy (SduEntrypoint store arg)
tp) [Proxy arg -> DType
forall a. TypeHasDoc a => Proxy a -> DType
DType (Proxy arg
forall k (t :: k). Proxy t
Proxy @arg)]
typeDocHaskellRep :: TypeDocHaskellRep (SduEntrypoint store arg)
typeDocHaskellRep =
forall b.
(Typeable (SduEntrypoint () Integer),
GenericIsoValue (SduEntrypoint () Integer),
GTypeHasDoc (Rep (SduEntrypoint () Integer)),
HaveCommonTypeCtor b (SduEntrypoint () Integer)) =>
TypeDocHaskellRep b
forall a b.
(Typeable a, GenericIsoValue a, GTypeHasDoc (Rep a),
HaveCommonTypeCtor b a) =>
TypeDocHaskellRep b
concreteTypeDocHaskellRep @(SduEntrypoint () Integer)
typeDocMichelsonRep :: TypeDocMichelsonRep (SduEntrypoint store arg)
typeDocMichelsonRep =
forall b.
(Typeable (SduEntrypoint () Integer),
SingI (ToT (SduEntrypoint () Integer)),
HaveCommonTypeCtor b (SduEntrypoint () Integer)) =>
TypeDocMichelsonRep b
forall k a (b :: k).
(Typeable a, SingI (ToT a), HaveCommonTypeCtor b a) =>
TypeDocMichelsonRep b
concreteTypeDocMichelsonRep @(SduEntrypoint () Integer)
typeDocDependencies :: Proxy (SduEntrypoint store arg) -> [SomeDocDefinitionItem]
typeDocDependencies Proxy (SduEntrypoint store arg)
p = [[SomeDocDefinitionItem]] -> [SomeDocDefinitionItem]
forall a. Monoid a => [a] -> a
mconcat
[ [DUStoreTemplate -> SomeDocDefinitionItem
forall d.
(DocItem d, DocItemPlacement d ~ 'DocItemInDefinitions) =>
d -> SomeDocDefinitionItem
SomeDocDefinitionItem (DUStoreTemplate -> SomeDocDefinitionItem)
-> DUStoreTemplate -> SomeDocDefinitionItem
forall a b. (a -> b) -> a -> b
$ Proxy () -> DUStoreTemplate
forall template.
UStoreTemplateHasDoc template =>
Proxy template -> DUStoreTemplate
DUStoreTemplate (Proxy () -> DUStoreTemplate) -> Proxy () -> DUStoreTemplate
forall a b. (a -> b) -> a -> b
$ Proxy ()
forall k (t :: k). Proxy t
Proxy @()]
, Proxy (SduEntrypoint store arg) -> [SomeDocDefinitionItem]
forall a.
(Generic a, GTypeHasDoc (Rep a)) =>
Proxy a -> [SomeDocDefinitionItem]
genericTypeDocDependencies Proxy (SduEntrypoint store arg)
p
]
type SduFallback store =
Lambda ((MText, ByteString), UStore store) ([Operation], UStore store)
type UStoreEntrypoint store arg =
UStoreFieldExt UMarkerEntrypoint (SduEntrypoint store arg)
data UMarkerEntrypoint :: UStoreMarkerType
pattern UStoreEntrypoint :: SduEntrypointUntyped store -> UStoreEntrypoint store arg
pattern $bUStoreEntrypoint :: SduEntrypointUntyped store -> UStoreEntrypoint store arg
$mUStoreEntrypoint :: forall r store arg.
UStoreEntrypoint store arg
-> (SduEntrypointUntyped store -> r) -> (Void# -> r) -> r
UStoreEntrypoint code = UStoreField (SduEntrypoint code)
type UStoreEpKey = (Lambda () (), MText)
instance KnownUStoreMarker UMarkerEntrypoint where
mkFieldMarkerUKey :: MText -> ByteString
mkFieldMarkerUKey MText
field =
UStoreEpKey -> ByteString
forall a. NicePackedValue a => a -> ByteString
lPackValueRaw @UStoreEpKey ('[()] :-> '[()]
forall (s :: [*]). s :-> s
L.nop, MText
field)
type ShowUStoreField UMarkerEntrypoint (SduEntrypoint store arg) =
'Text "entrypoint with argument " ':<>: 'ShowType arg ':<>:
'Text " over storage " ':<>: 'ShowType store
instance UStoreMarkerHasDoc UMarkerEntrypoint where
ustoreMarkerKeyEncoding :: Text -> Text
ustoreMarkerKeyEncoding Text
k = Text
"pack ({} :: lambda, " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
type UStoreEpInterface utemplate =
ExtractInterface utemplate (PickMarkedFields UMarkerEntrypoint utemplate)
type family (utemplate :: Kind.Type) (ufields :: [(Symbol, Kind.Type)])
:: [EntrypointKind] where
_ '[] = '[]
utemplate (entry ': entries) =
ExtractEntrypoint utemplate entry ': ExtractInterface utemplate entries
type family (utemplate :: Kind.Type) (ufields :: (Symbol, Kind.Type))
:: EntrypointKind where
utemplate '(name, SduEntrypoint utemplate arg) =
name ?: arg
_ '(name, SduEntrypoint (UStore _) _) =
TypeError ('Text "UStore passed to entrypoint, expected UStore template" ':$$:
'Text "In UStore field " ':<>: 'ShowType name
)
utemplate' '(name, SduEntrypoint utemplate _) =
TypeError ('Text "Entrypoint polymorphic over foreign storage: UStore " ':<>:
'ShowType utemplate ':$$:
'Text "In storage UStore " ':<>: 'ShowType utemplate' ':$$:
'Text "In field " ':<>: 'ShowType name
)
_ v =
TypeError ('Text "Field with entrypoint of unknown type " ':<>: 'ShowType v)
mkSduContract
:: (Typeable (VerUStoreTemplate ver))
=> SduFallback (VerUStoreTemplate ver) -> UContractRouter ver
mkSduContract :: SduFallback (VerUStoreTemplate ver) -> UContractRouter ver
mkSduContract SduFallback (VerUStoreTemplate ver)
fallback = ('[VerParam ver, VerUStore ver]
:-> '[([Operation], VerUStore ver)])
-> UContractRouter ver
forall (ver :: VersionKind).
('[VerParam ver, VerUStore ver]
:-> '[([Operation], VerUStore ver)])
-> UContractRouter ver
mkUContractRouter (('[VerParam ver, VerUStore ver]
:-> '[([Operation], VerUStore ver)])
-> UContractRouter ver)
-> ('[VerParam ver, VerUStore ver]
:-> '[([Operation], VerUStore ver)])
-> UContractRouter ver
forall a b. (a -> b) -> a -> b
$ do
forall (s :: [*]).
(VerParam ver : s) :-> (VerParam ver : VerParam ver : s)
forall a (s :: [*]). (a : s) :-> (a : a : s)
dup @(UParam _)
'[VerParam ver, VerParam ver, VerUStore ver]
:-> '[(MText, ByteString), VerParam ver, VerUStore ver]
forall (entries :: [EntrypointKind]) (s :: [*]).
(UParam entries : s) :-> ((MText, ByteString) : s)
unwrapUParam; '[(MText, ByteString), VerParam ver, VerUStore ver]
:-> '[MText, VerParam ver, VerUStore ver]
forall a b (s :: [*]). ((a, b) : s) :-> (a : s)
car
('[VerParam ver, VerUStore ver]
:-> '[VerUStore ver, VerParam ver, VerUStore ver])
-> '[MText, VerParam ver, VerUStore ver]
:-> '[MText, VerUStore ver, VerParam ver, VerUStore ver]
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
dip (forall (s :: [*]) (s' :: [*]) a.
ConstraintDUPNLorentz (ToPeano 2) s s' a =>
s :-> (a : s)
forall (n :: Nat) (s :: [*]) (s' :: [*]) a.
ConstraintDUPNLorentz (ToPeano n) s s' a =>
s :-> (a : s)
duupX @2)
('[()] :-> '[()])
-> '[MText, VerUStore ver, VerParam ver, VerUStore ver]
:-> '['[()] :-> '[()], MText, VerUStore ver, VerParam ver,
VerUStore ver]
forall t (s :: [*]). NiceConstant t => t -> s :-> (t : s)
push '[()] :-> '[()]
forall (s :: [*]). s :-> s
nop; '['[()] :-> '[()], MText, VerUStore ver, VerParam ver,
VerUStore ver]
:-> '[UStoreEpKey, VerUStore ver, VerParam ver, VerUStore ver]
forall a b (s :: [*]). (a : b : s) :-> ((a, b) : s)
pair; forall (s :: [*]).
NicePackedValue UStoreEpKey =>
(UStoreEpKey : s) :-> (ByteString : s)
forall a (s :: [*]).
NicePackedValue a =>
(a : s) :-> (ByteString : s)
packRaw @UStoreEpKey
'[ByteString, VerUStore ver, VerParam ver, VerUStore ver]
:-> '[Maybe ByteString, VerParam ver, VerUStore ver]
forall c (s :: [*]).
(GetOpHs c, KnownValue (GetOpValHs c)) =>
(GetOpKeyHs c : c : s) :-> (Maybe (GetOpValHs c) : s)
get
if Condition
'[Maybe ByteString, VerParam ver, VerUStore ver]
'[ByteString, VerParam ver, VerUStore ver]
'[VerParam ver, VerUStore ver]
'[([Operation], VerUStore ver)]
'[([Operation], VerUStore ver)]
forall a (argr :: [*]) (outb :: [*]).
Condition (Maybe a : argr) (a : argr) argr outb outb
IsSome
then do
forall (s :: [*]).
NiceUnpackedValue (SduEntrypointUntyped (VerUStoreTemplate ver)) =>
(ByteString : s)
:-> (Maybe (SduEntrypointUntyped (VerUStoreTemplate ver)) : s)
forall a (s :: [*]).
NiceUnpackedValue a =>
(ByteString : s) :-> (Maybe a : s)
unpackRaw @(SduEntrypointUntyped _)
MText
-> '[Maybe (SduEntrypointUntyped (VerUStoreTemplate ver)),
VerParam ver, VerUStore ver]
:-> '[SduEntrypointUntyped (VerUStoreTemplate ver), VerParam ver,
VerUStore ver]
forall err a (s :: [*]).
IsError err =>
err -> (Maybe a : s) :-> (a : s)
assertSome [mt|Wrong sdu entrypoint type|]
('[VerParam ver, VerUStore ver] :-> '[(ByteString, VerUStore ver)])
-> '[SduEntrypointUntyped (VerUStoreTemplate ver), VerParam ver,
VerUStore ver]
:-> '[SduEntrypointUntyped (VerUStoreTemplate ver),
(ByteString, VerUStore ver)]
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
dip (('[VerParam ver, VerUStore ver]
:-> '[(ByteString, VerUStore ver)])
-> '[SduEntrypointUntyped (VerUStoreTemplate ver), VerParam ver,
VerUStore ver]
:-> '[SduEntrypointUntyped (VerUStoreTemplate ver),
(ByteString, VerUStore ver)])
-> ('[VerParam ver, VerUStore ver]
:-> '[(ByteString, VerUStore ver)])
-> '[SduEntrypointUntyped (VerUStoreTemplate ver), VerParam ver,
VerUStore ver]
:-> '[SduEntrypointUntyped (VerUStoreTemplate ver),
(ByteString, VerUStore ver)]
forall a b. (a -> b) -> a -> b
$ do
'[VerParam ver, VerUStore ver]
:-> '[(MText, ByteString), VerUStore ver]
forall (entries :: [EntrypointKind]) (s :: [*]).
(UParam entries : s) :-> ((MText, ByteString) : s)
unwrapUParam; '[(MText, ByteString), VerUStore ver]
:-> '[ByteString, VerUStore ver]
forall a b (s :: [*]). ((a, b) : s) :-> (b : s)
cdr
'[ByteString, VerUStore ver] :-> '[(ByteString, VerUStore ver)]
forall a b (s :: [*]). (a : b : s) :-> ((a, b) : s)
pair
'[SduEntrypointUntyped (VerUStoreTemplate ver),
(ByteString, VerUStore ver)]
:-> '[(ByteString, VerUStore ver),
SduEntrypointUntyped (VerUStoreTemplate ver)]
forall a b (s :: [*]). (a : b : s) :-> (b : a : s)
swap
'[(ByteString, VerUStore ver),
SduEntrypointUntyped (VerUStoreTemplate ver)]
:-> '[([Operation], VerUStore ver)]
forall a b (s :: [*]). (a : Lambda a b : s) :-> (b : s)
exec
else do
'[VerParam ver, VerUStore ver]
:-> '[(MText, ByteString), VerUStore ver]
forall (entries :: [EntrypointKind]) (s :: [*]).
(UParam entries : s) :-> ((MText, ByteString) : s)
unwrapUParam
'[(MText, ByteString), VerUStore ver]
:-> '[((MText, ByteString), VerUStore ver)]
forall a b (s :: [*]). (a : b : s) :-> ((a, b) : s)
pair
SduFallback (VerUStoreTemplate ver)
fallback
mkSduEntrypoint
:: NiceUnpackedValue arg
=> Entrypoint arg (UStore store)
-> SduEntrypoint store arg
mkSduEntrypoint :: Entrypoint arg (UStore store) -> SduEntrypoint store arg
mkSduEntrypoint Entrypoint arg (UStore store)
code = SduEntrypointUntyped store -> SduEntrypoint store arg
forall store arg.
SduEntrypointUntyped store -> SduEntrypoint store arg
SduEntrypoint (SduEntrypointUntyped store -> SduEntrypoint store arg)
-> SduEntrypointUntyped store -> SduEntrypoint store arg
forall a b. (a -> b) -> a -> b
$ do
'[(ByteString, UStore store)] :-> '[ByteString, UStore store]
forall a b (s :: [*]). ((a, b) : s) :-> (a : b : s)
unpair
'[ByteString, UStore store] :-> '[Maybe arg, UStore store]
forall a (s :: [*]).
NiceUnpackedValue a =>
(ByteString : s) :-> (Maybe a : s)
unpackRaw
('[arg, UStore store] :-> '[arg, UStore store])
-> ('[UStore store] :-> '[arg, UStore store])
-> '[Maybe arg, UStore store] :-> '[arg, UStore store]
forall a (s :: [*]) (s' :: [*]).
((a : s) :-> s') -> (s :-> s') -> (Maybe a : s) :-> s'
ifSome '[arg, UStore store] :-> '[arg, UStore store]
forall (s :: [*]). s :-> s
nop (('[UStore store] :-> '[arg, UStore store])
-> '[Maybe arg, UStore store] :-> '[arg, UStore store])
-> ('[UStore store] :-> '[arg, UStore store])
-> '[Maybe arg, UStore store] :-> '[arg, UStore store]
forall a b. (a -> b) -> a -> b
$ Label "uparamArgumentUnpackFailed"
-> '[UStore store] :-> '[arg, UStore store]
forall (tag :: Symbol) (s :: [*]) (any :: [*]).
(MustHaveErrorArg tag (MText, ()), CustomErrorHasDoc tag) =>
Label tag -> s :-> any
failCustom_ Label "uparamArgumentUnpackFailed"
forall a. IsLabel "uparamArgumentUnpackFailed" a => a
forall (x :: Symbol) a. IsLabel x a => a
#uparamArgumentUnpackFailed
Entrypoint arg (UStore store)
code
mkUStoreEntrypoint
:: NiceUnpackedValue arg
=> Entrypoint arg (UStore store)
-> UStoreEntrypoint store arg
mkUStoreEntrypoint :: Entrypoint arg (UStore store) -> UStoreEntrypoint store arg
mkUStoreEntrypoint = SduEntrypoint store arg -> UStoreEntrypoint store arg
forall (m :: UStoreMarkerType) v. v -> UStoreFieldExt m v
UStoreField (SduEntrypoint store arg -> UStoreEntrypoint store arg)
-> (Entrypoint arg (UStore store) -> SduEntrypoint store arg)
-> Entrypoint arg (UStore store)
-> UStoreEntrypoint store arg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entrypoint arg (UStore store) -> SduEntrypoint store arg
forall arg store.
NiceUnpackedValue arg =>
Entrypoint arg (UStore store) -> SduEntrypoint store arg
mkSduEntrypoint
callSduEntrypoint
:: NicePackedValue arg
=> arg : SduEntrypoint store arg : UStore store : s
:-> ([Operation], UStore store) : s
callSduEntrypoint :: (arg : SduEntrypoint store arg : UStore store : s)
:-> (([Operation], UStore store) : s)
callSduEntrypoint = do
((SduEntrypoint store arg : UStore store : s)
:-> (UStore store
: Lambda (ByteString, UStore store) ([Operation], UStore store)
: s))
-> (arg : SduEntrypoint store arg : UStore store : s)
:-> (arg
: UStore store
: Lambda (ByteString, UStore store) ([Operation], UStore store)
: s)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
dip (((SduEntrypoint store arg : UStore store : s)
:-> (UStore store
: Lambda (ByteString, UStore store) ([Operation], UStore store)
: s))
-> (arg : SduEntrypoint store arg : UStore store : s)
:-> (arg
: UStore store
: Lambda (ByteString, UStore store) ([Operation], UStore store)
: s))
-> ((SduEntrypoint store arg : UStore store : s)
:-> (UStore store
: Lambda (ByteString, UStore store) ([Operation], UStore store)
: s))
-> (arg : SduEntrypoint store arg : UStore store : s)
:-> (arg
: UStore store
: Lambda (ByteString, UStore store) ([Operation], UStore store)
: s)
forall a b. (a -> b) -> a -> b
$ (SduEntrypoint store arg : UStore store : s)
:-> (Lambda (ByteString, UStore store) ([Operation], UStore store)
: UStore store : s)
forall a (s :: [*]). Wrappable a => (a : s) :-> (Unwrappable a : s)
coerceUnwrap ((SduEntrypoint store arg : UStore store : s)
:-> (Lambda (ByteString, UStore store) ([Operation], UStore store)
: UStore store : s))
-> ((Lambda (ByteString, UStore store) ([Operation], UStore store)
: UStore store : s)
:-> (UStore store
: Lambda (ByteString, UStore store) ([Operation], UStore store)
: s))
-> (SduEntrypoint store arg : UStore store : s)
:-> (UStore store
: Lambda (ByteString, UStore store) ([Operation], UStore store)
: s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
>> (Lambda (ByteString, UStore store) ([Operation], UStore store)
: UStore store : s)
:-> (UStore store
: Lambda (ByteString, UStore store) ([Operation], UStore store)
: s)
forall a b (s :: [*]). (a : b : s) :-> (b : a : s)
swap
(arg
: UStore store
: Lambda (ByteString, UStore store) ([Operation], UStore store)
: s)
:-> (ByteString
: UStore store
: Lambda (ByteString, UStore store) ([Operation], UStore store)
: s)
forall a (s :: [*]).
NicePackedValue a =>
(a : s) :-> (ByteString : s)
packRaw
(ByteString
: UStore store
: Lambda (ByteString, UStore store) ([Operation], UStore store)
: s)
:-> ((ByteString, UStore store)
: Lambda (ByteString, UStore store) ([Operation], UStore store)
: s)
forall a b (s :: [*]). (a : b : s) :-> ((a, b) : s)
pair
((ByteString, UStore store)
: Lambda (ByteString, UStore store) ([Operation], UStore store)
: s)
:-> (([Operation], UStore store) : s)
forall a b (s :: [*]). (a : Lambda a b : s) :-> (b : s)
exec
callUStoreEntrypoint
:: (NicePackedValue arg, HasUField field (SduEntrypoint store arg) store)
=> Label field
-> arg : UStore store : s :-> ([Operation], UStore store) : s
callUStoreEntrypoint :: Label field
-> (arg : UStore store : s) :-> (([Operation], UStore store) : s)
callUStoreEntrypoint Label field
label = do
((UStore store : s)
:-> (SduEntrypoint store arg : UStore store : s))
-> (arg : UStore store : s)
:-> (arg : SduEntrypoint store arg : UStore store : s)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
dip (((UStore store : s)
:-> (SduEntrypoint store arg : UStore store : s))
-> (arg : UStore store : s)
:-> (arg : SduEntrypoint store arg : UStore store : s))
-> ((UStore store : s)
:-> (SduEntrypoint store arg : UStore store : s))
-> (arg : UStore store : s)
:-> (arg : SduEntrypoint store arg : UStore store : s)
forall a b. (a -> b) -> a -> b
$ Label field
-> (UStore store : s)
:-> (GetUStoreField store field : UStore store : s)
forall store (name :: Symbol) (s :: [*]).
FieldAccessC store name =>
Label name
-> (UStore store : s)
:-> (GetUStoreField store name : UStore store : s)
ustoreGetField Label field
label
(arg : SduEntrypoint store arg : UStore store : s)
:-> (([Operation], UStore store) : s)
forall arg store (s :: [*]).
NicePackedValue arg =>
(arg : SduEntrypoint store arg : UStore store : s)
:-> (([Operation], UStore store) : s)
callSduEntrypoint
sduFallbackFail :: SduFallback store
sduFallbackFail :: SduFallback store
sduFallbackFail =
'[((MText, ByteString), UStore store)] :-> '[(MText, ByteString)]
forall a b (s :: [*]). ((a, b) : s) :-> (a : s)
car ('[((MText, ByteString), UStore store)] :-> '[(MText, ByteString)])
-> ('[(MText, ByteString)] :-> '[MText])
-> '[((MText, ByteString), UStore store)] :-> '[MText]
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# '[(MText, ByteString)] :-> '[MText]
forall a b (s :: [*]). ((a, b) : s) :-> (a : s)
car ('[((MText, ByteString), UStore store)] :-> '[MText])
-> ('[MText] :-> '[([Operation], UStore store)])
-> SduFallback store
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# Label "uparamNoSuchEntrypoint"
-> '[MText] :-> '[([Operation], UStore store)]
forall (tag :: Symbol) err (s :: [*]) (any :: [*]).
(MustHaveErrorArg tag (MText, err), CustomErrorHasDoc tag,
KnownError err) =>
Label tag -> (err : s) :-> any
failCustom Label "uparamNoSuchEntrypoint"
forall a. IsLabel "uparamNoSuchEntrypoint" a => a
forall (x :: Symbol) a. IsLabel x a => a
#uparamNoSuchEntrypoint
sduDocument
:: UStoreTraversable SduDocumentTW template
=> template -> Lambda () ()
sduDocument :: template -> '[()] :-> '[()]
sduDocument = SduDocumentTW -> template -> '[()] :-> '[()]
forall way template res.
(UStoreTraversable way template,
UStoreTraversalArgumentWrapper way ~ Identity,
UStoreTraversalMonad way ~ Const res) =>
way -> template -> res
foldUStore SduDocumentTW
SduDocumentTW
data SduDocumentTW = SduDocumentTW
instance UStoreTraversalWay SduDocumentTW where
type UStoreTraversalArgumentWrapper SduDocumentTW = Identity
type UStoreTraversalMonad SduDocumentTW = Const (Lambda () ())
instance {-# OVERLAPPING #-}
UStoreTraversalFieldHandler SduDocumentTW
UMarkerEntrypoint (SduEntrypoint store arg) where
ustoreTraversalFieldHandler :: SduDocumentTW
-> Label name
-> UStoreTraversalArgumentWrapper
SduDocumentTW (SduEntrypoint store arg)
-> UStoreTraversalMonad SduDocumentTW (SduEntrypoint store arg)
ustoreTraversalFieldHandler
SduDocumentTW
SduDocumentTW (Label name
Label :: Label fieldName) (Identity (SduEntrypoint ep)) =
('[()] :-> '[()])
-> Const ('[()] :-> '[()]) (SduEntrypoint store arg)
forall k a (b :: k). a -> Const a b
Const (('[()] :-> '[()])
-> Const ('[()] :-> '[()]) (SduEntrypoint store arg))
-> ('[()] :-> '[()])
-> Const ('[()] :-> '[()]) (SduEntrypoint store arg)
forall a b. (a -> b) -> a -> b
$
('[(ByteString, UStore store)] :-> '[([Operation], UStore store)])
-> '[()] :-> '[()]
forall (inp :: [*]) (out :: [*]) (s :: [*]).
(inp :-> out) -> s :-> s
cutLorentzNonDoc (('[(ByteString, UStore store)] :-> '[([Operation], UStore store)])
-> '[()] :-> '[()])
-> ('[(ByteString, UStore store)]
:-> '[([Operation], UStore store)])
-> '[()] :-> '[()]
forall a b. (a -> b) -> a -> b
$ ParamBuildingStep
-> ('[(ByteString, UStore store)]
:-> '[([Operation], UStore store)])
-> '[(ByteString, UStore store)] :-> '[([Operation], UStore store)]
forall (inp :: [*]) (out :: [*]).
ParamBuildingStep -> (inp :-> out) -> inp :-> out
clarifyParamBuildingSteps (KnownSymbol name => ParamBuildingStep
forall (ctorName :: Symbol).
KnownSymbol ctorName =>
ParamBuildingStep
pbsUParam @fieldName) '[(ByteString, UStore store)] :-> '[([Operation], UStore store)]
ep
instance UStoreTraversalFieldHandler SduDocumentTW marker v where
ustoreTraversalFieldHandler :: SduDocumentTW
-> Label name
-> UStoreTraversalArgumentWrapper SduDocumentTW v
-> UStoreTraversalMonad SduDocumentTW v
ustoreTraversalFieldHandler SduDocumentTW
SduDocumentTW Label name
_ UStoreTraversalArgumentWrapper SduDocumentTW v
_ = ('[()] :-> '[()]) -> Const ('[()] :-> '[()]) v
forall k a (b :: k). a -> Const a b
Const '[()] :-> '[()]
forall a. Monoid a => a
mempty
instance UStoreTraversalSubmapHandler SduDocumentTW k v where
ustoreTraversalSubmapHandler :: SduDocumentTW
-> Label name
-> UStoreTraversalArgumentWrapper SduDocumentTW (Map k v)
-> UStoreTraversalMonad SduDocumentTW (Map k v)
ustoreTraversalSubmapHandler SduDocumentTW
SduDocumentTW Label name
_ UStoreTraversalArgumentWrapper SduDocumentTW (Map k v)
_ = ('[()] :-> '[()]) -> Const ('[()] :-> '[()]) (Map k v)
forall k a (b :: k). a -> Const a b
Const '[()] :-> '[()]
forall a. Monoid a => a
mempty
sduAddEntrypointDoc
:: ( UStoreTraversable SduAddEntrypointDocTW template
, DocItem (DEntrypoint epKind)
)
=> Proxy epKind -> template -> template
sduAddEntrypointDoc :: Proxy epKind -> template -> template
sduAddEntrypointDoc Proxy epKind
epKindP = SduAddEntrypointDocTW -> template -> template
forall way template.
(UStoreTraversable way template,
UStoreTraversalArgumentWrapper way ~ Identity,
UStoreTraversalMonad way ~ Identity) =>
way -> template -> template
modifyUStore (Proxy epKind -> SduAddEntrypointDocTW
forall epKind.
DocItem (DEntrypoint epKind) =>
Proxy epKind -> SduAddEntrypointDocTW
SduAddEntrypointDocTW Proxy epKind
epKindP)
data SduAddEntrypointDocTW =
forall epKind. (DocItem (DEntrypoint epKind)) =>
SduAddEntrypointDocTW (Proxy epKind)
instance UStoreTraversalWay SduAddEntrypointDocTW where
type UStoreTraversalArgumentWrapper SduAddEntrypointDocTW = Identity
type UStoreTraversalMonad SduAddEntrypointDocTW = Identity
instance {-# OVERLAPPING #-}
( TypeHasDoc arg, NiceParameterFull arg
) =>
UStoreTraversalFieldHandler SduAddEntrypointDocTW
UMarkerEntrypoint (SduEntrypoint store arg) where
ustoreTraversalFieldHandler :: SduAddEntrypointDocTW
-> Label name
-> UStoreTraversalArgumentWrapper
SduAddEntrypointDocTW (SduEntrypoint store arg)
-> UStoreTraversalMonad
SduAddEntrypointDocTW (SduEntrypoint store arg)
ustoreTraversalFieldHandler
(SduAddEntrypointDocTW (Proxy epKind
_ :: Proxy epKind))
(Label name
Label :: Label fieldName) (Identity (SduEntrypoint ep)) =
SduEntrypoint store arg -> Identity (SduEntrypoint store arg)
forall a. a -> Identity a
Identity (SduEntrypoint store arg -> Identity (SduEntrypoint store arg))
-> (SduEntrypointUntyped store -> SduEntrypoint store arg)
-> SduEntrypointUntyped store
-> Identity (SduEntrypoint store arg)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SduEntrypointUntyped store -> SduEntrypoint store arg
forall store arg.
SduEntrypointUntyped store -> SduEntrypoint store arg
SduEntrypoint (SduEntrypointUntyped store -> Identity (SduEntrypoint store arg))
-> SduEntrypointUntyped store -> Identity (SduEntrypoint store arg)
forall a b. (a -> b) -> a -> b
$
(SubDoc -> DEntrypoint epKind)
-> SduEntrypointUntyped store -> SduEntrypointUntyped store
forall di (inp :: [*]) (out :: [*]).
DocItem di =>
(SubDoc -> di) -> (inp :-> out) -> inp :-> out
docGroup (Text -> SubDoc -> DEntrypoint epKind
forall kind. Text -> SubDoc -> DEntrypoint kind
DEntrypoint @epKind (KnownSymbol name => Text
forall (s :: Symbol). KnownSymbol s => Text
symbolValT' @fieldName))
(DEntrypointArg
-> '[(ByteString, UStore store)] :-> '[(ByteString, UStore store)]
forall di (s :: [*]). DocItem di => di -> s :-> s
doc ((NiceParameter arg, TypeHasDoc arg) => DEntrypointArg
forall arg. (NiceParameter arg, TypeHasDoc arg) => DEntrypointArg
constructDEpArg @arg) ('[(ByteString, UStore store)] :-> '[(ByteString, UStore store)])
-> SduEntrypointUntyped store -> SduEntrypointUntyped store
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# SduEntrypointUntyped store
ep)
instance UStoreTraversalFieldHandler SduAddEntrypointDocTW marker v where
ustoreTraversalFieldHandler :: SduAddEntrypointDocTW
-> Label name
-> UStoreTraversalArgumentWrapper SduAddEntrypointDocTW v
-> UStoreTraversalMonad SduAddEntrypointDocTW v
ustoreTraversalFieldHandler SduAddEntrypointDocTW
_ Label name
_ = UStoreTraversalArgumentWrapper SduAddEntrypointDocTW v
-> UStoreTraversalMonad SduAddEntrypointDocTW v
forall a. a -> a
id
instance UStoreTraversalSubmapHandler SduAddEntrypointDocTW k v where
ustoreTraversalSubmapHandler :: SduAddEntrypointDocTW
-> Label name
-> UStoreTraversalArgumentWrapper SduAddEntrypointDocTW (Map k v)
-> UStoreTraversalMonad SduAddEntrypointDocTW (Map k v)
ustoreTraversalSubmapHandler SduAddEntrypointDocTW
_ Label name
_ = UStoreTraversalArgumentWrapper SduAddEntrypointDocTW (Map k v)
-> UStoreTraversalMonad SduAddEntrypointDocTW (Map k v)
forall a. a -> a
id
sduContractDoc
:: forall utemplate ver.
( NiceVersion ver
, KnownContractVersion ver
, UStoreTraversable SduDocumentTW utemplate
, PermConstraint ver
)
=> utemplate
-> PermanentImpl ver
-> Lambda () ()
sduContractDoc :: utemplate -> PermanentImpl ver -> '[()] :-> '[()]
sduContractDoc utemplate
store PermanentImpl ver
permImpl = do
DVersion -> '[()] :-> '[()]
forall di (s :: [*]). DocItem di => di -> s :-> s
doc (DVersion -> '[()] :-> '[()]) -> DVersion -> '[()] :-> '[()]
forall a b. (a -> b) -> a -> b
$ Version -> DVersion
DVersion (Proxy ver -> Version
forall (v :: VersionKind).
KnownContractVersion v =>
Proxy v -> Version
contractVersion (Proxy ver
forall k (t :: k). Proxy t
Proxy @ver))
('[(Parameter ver, Storage ver)] :-> ContractOut (Storage ver))
-> '[()] :-> (Parameter ver : Any)
forall (s1 :: [*]) (s2 :: [*]) (s1' :: [*]) (s2' :: [*]).
(s1 :-> s2) -> s1' :-> s2'
fakeCoercing (('[(Parameter ver, Storage ver)] :-> ContractOut (Storage ver))
-> '[()] :-> (Parameter ver : Any))
-> ('[(Parameter ver, Storage ver)] :-> ContractOut (Storage ver))
-> '[()] :-> (Parameter ver : Any)
forall a b. (a -> b) -> a -> b
$
Contract (Parameter ver) (Storage ver)
-> '[(Parameter ver, Storage ver)] :-> ContractOut (Storage ver)
forall cp st. Contract cp st -> ContractCode cp st
cCode (Contract (Parameter ver) (Storage ver)
-> '[(Parameter ver, Storage ver)] :-> ContractOut (Storage ver))
-> Contract (Parameter ver) (Storage ver)
-> '[(Parameter ver, Storage ver)] :-> ContractOut (Storage ver)
forall a b. (a -> b) -> a -> b
$ (NiceVersion ver, NiceParameterFull (Parameter ver)) =>
Contract (Parameter ver) (Storage ver)
forall (ver :: VersionKind).
(NiceVersion ver, NiceParameterFull (Parameter ver)) =>
UpgradeableContract ver
upgradeableContract @ver
forall (inp :: [*]) (out :: [*]).
(NiceParameterFull (Parameter ver), RequireSumType (Parameter ver),
HasCallStack) =>
((Parameter ver : inp) :-> out) -> (Parameter ver : inp) :-> out
forall cp (inp :: [*]) (out :: [*]).
(NiceParameterFull cp, RequireSumType cp, HasCallStack) =>
((cp : inp) :-> out) -> (cp : inp) :-> out
finalizeParamCallingDoc @(Parameter ver) (((Parameter ver : Any) :-> (Parameter ver : Any))
-> (Parameter ver : Any) :-> (Parameter ver : Any))
-> (('[()] :-> '[()])
-> (Parameter ver : Any) :-> (Parameter ver : Any))
-> ('[()] :-> '[()])
-> (Parameter ver : Any) :-> (Parameter ver : Any)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ('[()] :-> '[()])
-> (Parameter ver : Any) :-> (Parameter ver : Any)
forall (s1 :: [*]) (s2 :: [*]) (s1' :: [*]) (s2' :: [*]).
(s1 :-> s2) -> s1' :-> s2'
fakeCoercing (('[()] :-> '[()])
-> (Parameter ver : Any) :-> (Parameter ver : Any))
-> ('[()] :-> '[()])
-> (Parameter ver : Any) :-> (Parameter ver : Any)
forall a b. (a -> b) -> a -> b
$
ParamBuildingStep -> ('[()] :-> '[()]) -> '[()] :-> '[()]
forall (inp :: [*]) (out :: [*]).
ParamBuildingStep -> (inp :-> out) -> inp :-> out
clarifyParamBuildingSteps ParamBuildingStep
pbsContainedInRun (('[()] :-> '[()]) -> '[()] :-> '[()])
-> ('[()] :-> '[()]) -> '[()] :-> '[()]
forall a b. (a -> b) -> a -> b
$
utemplate -> '[()] :-> '[()]
forall template.
UStoreTraversable SduDocumentTW template =>
template -> '[()] :-> '[()]
sduDocument utemplate
store
forall (inp :: [*]) (out :: [*]).
(NiceParameterFull (Parameter ver), RequireSumType (Parameter ver),
HasCallStack) =>
((Parameter ver : inp) :-> out) -> (Parameter ver : inp) :-> out
forall cp (inp :: [*]) (out :: [*]).
(NiceParameterFull cp, RequireSumType cp, HasCallStack) =>
((cp : inp) :-> out) -> (cp : inp) :-> out
finalizeParamCallingDoc @(Parameter ver) (((Parameter ver : Any) :-> '[()])
-> (Parameter ver : Any) :-> '[()])
-> (('[VerPermanent ver, UStore (VerUStoreTemplate ver)]
:-> ContractOut (UStore (VerUStoreTemplate ver)))
-> (Parameter ver : Any) :-> '[()])
-> ('[VerPermanent ver, UStore (VerUStoreTemplate ver)]
:-> ContractOut (UStore (VerUStoreTemplate ver)))
-> (Parameter ver : Any) :-> '[()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ('[VerPermanent ver, UStore (VerUStoreTemplate ver)]
:-> ContractOut (UStore (VerUStoreTemplate ver)))
-> (Parameter ver : Any) :-> '[()]
forall (s1 :: [*]) (s2 :: [*]) (s1' :: [*]) (s2' :: [*]).
(s1 :-> s2) -> s1' :-> s2'
fakeCoercing (('[VerPermanent ver, UStore (VerUStoreTemplate ver)]
:-> ContractOut (UStore (VerUStoreTemplate ver)))
-> (Parameter ver : Any) :-> '[()])
-> ('[VerPermanent ver, UStore (VerUStoreTemplate ver)]
:-> ContractOut (UStore (VerUStoreTemplate ver)))
-> (Parameter ver : Any) :-> '[()]
forall a b. (a -> b) -> a -> b
$
ParamBuildingStep
-> ('[VerPermanent ver, UStore (VerUStoreTemplate ver)]
:-> ContractOut (UStore (VerUStoreTemplate ver)))
-> '[VerPermanent ver, UStore (VerUStoreTemplate ver)]
:-> ContractOut (UStore (VerUStoreTemplate ver))
forall (inp :: [*]) (out :: [*]).
ParamBuildingStep -> (inp :-> out) -> inp :-> out
clarifyParamBuildingSteps ParamBuildingStep
pbsContainedInRunPerm (('[VerPermanent ver, UStore (VerUStoreTemplate ver)]
:-> ContractOut (UStore (VerUStoreTemplate ver)))
-> '[VerPermanent ver, UStore (VerUStoreTemplate ver)]
:-> ContractOut (UStore (VerUStoreTemplate ver)))
-> ('[VerPermanent ver, UStore (VerUStoreTemplate ver)]
:-> ContractOut (UStore (VerUStoreTemplate ver)))
-> '[VerPermanent ver, UStore (VerUStoreTemplate ver)]
:-> ContractOut (UStore (VerUStoreTemplate ver))
forall a b. (a -> b) -> a -> b
$
PermanentImpl ver
-> '[VerPermanent ver, UStore (VerUStoreTemplate ver)]
:-> ContractOut (UStore (VerUStoreTemplate ver))
forall (ver :: VersionKind).
PermanentImpl ver -> Entrypoint (VerPermanent ver) (VerUStore ver)
unPermanentImpl PermanentImpl ver
permImpl