-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

module Lorentz.Contracts.Upgradeable.EntrypointWise
  ( EntrypointImpl
  , EpwFallback
  , EpwContract (..)
  , EpwCaseClause (..)
  , mkEpwContract
  , mkEpwContractT
  , epwFallbackFail
  , (/==>)
  , removeEndpoint
  , EpwDocumented (..)
  , epwContractDoc
  ) where

import Lorentz
import Prelude (Typeable, fmap)

import Lorentz.Contracts.Upgradeable.Common
import Lorentz.UStore
import Michelson.Text
import Util.TypeLits
import Util.TypeTuple

-- | This data type represents the new contract code and migrations necessary
--   to upgrade the contract endpoints to the new version.
data EpwContract ver = EpwContract
  { EpwContract ver -> UContractRouter ver
epwServe :: UContractRouter ver
  -- ^ `epwServe` does  the dispatching logic and is assumed to be used for
  --   the `code` lambda of the upgradeable contract.

  , EpwContract ver
-> forall oldStore.
   [MigrationScript oldStore (VerUStoreTemplate ver)]
epwCodeMigrations :: forall oldStore. [MigrationScript oldStore (VerUStoreTemplate ver)]
  -- ^ `epwCodeMigrations` is a list of packed migrations the client ought to
  --   pass to the `EpwUpgrade` method in order to upgrade the implementation.
  }


-- | Creates the EpwContract data structure from a Rec of case clauses
mkEpwContract
  :: forall (ver :: VersionKind) (interface :: [EntrypointKind]) store.
  ( interface ~ VerInterface ver, store ~ VerUStoreTemplate ver
  , CodeMigrations interface
  , HasUStore "code" MText (EntrypointImpl store) store
  , HasUField "fallback" (EpwFallback store) store
  , Typeable store
  )
  => Rec (EpwCaseClause store) interface
  -> EpwFallback store
  -> EpwContract ver
mkEpwContract :: Rec (EpwCaseClause store) interface
-> EpwFallback store -> EpwContract ver
mkEpwContract Rec (EpwCaseClause store) interface
entries EpwFallback store
fallback = EpwContract :: forall (ver :: VersionKind).
UContractRouter ver
-> (forall oldStore.
    [MigrationScript oldStore (VerUStoreTemplate ver)])
-> EpwContract ver
EpwContract
  { epwServe :: UContractRouter ver
epwServe = ('[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
$
      (HasUStore "code" MText (EntrypointImpl store) store,
 HasUField "fallback" (EpwFallback store) store) =>
'[UParam interface, UStore store]
:-> '[([Operation], UStore store)]
forall store (entries :: [EntrypointKind]).
(HasUStore "code" MText (EntrypointImpl store) store,
 HasUField "fallback" (EpwFallback store) store) =>
'[UParam entries, UStore store] :-> '[([Operation], UStore store)]
caseUParamUnsafe' @store @interface
  , epwCodeMigrations :: forall oldStore. [MigrationScript oldStore (VerUStoreTemplate ver)]
epwCodeMigrations =
      (('[UStore store] :-> '[UStore store])
 -> MigrationScript oldStore store)
-> ['[UStore store] :-> '[UStore store]]
-> [MigrationScript oldStore store]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Lambda UStore_ UStore_ -> MigrationScript oldStore store
forall oldStore newStore.
Lambda UStore_ UStore_ -> MigrationScript oldStore newStore
MigrationScript (Lambda UStore_ UStore_ -> MigrationScript oldStore store)
-> (('[UStore store] :-> '[UStore store])
    -> Lambda UStore_ UStore_)
-> ('[UStore store] :-> '[UStore store])
-> MigrationScript oldStore store
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: [*]).
Coercible_ UStore_ (UStore store) =>
((UStore store : s) :-> (UStore store : s))
-> (UStore_ : s) :-> (UStore_ : s)
forall a b (s :: [*]).
Coercible_ a b =>
((b : s) :-> (b : s)) -> (a : s) :-> (a : s)
checkedCoercing_ @UStore_ @(UStore store)) (['[UStore store] :-> '[UStore store]]
 -> [MigrationScript oldStore store])
-> ['[UStore store] :-> '[UStore store]]
-> [MigrationScript oldStore store]
forall a b. (a -> b) -> a -> b
$
        (EpwFallback store
-> '[UStore store] :-> '[EpwFallback store, UStore store]
forall t (s :: [*]). NiceConstant t => t -> s :-> (t : s)
push EpwFallback store
fallback ('[UStore store] :-> '[EpwFallback store, UStore store])
-> ('[EpwFallback store, UStore store] :-> '[UStore store])
-> '[UStore store] :-> '[UStore store]
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# Label "fallback"
-> '[GetUStoreField store "fallback", UStore store]
   :-> '[UStore store]
forall store (name :: Symbol) (s :: [*]).
FieldAccessC store name =>
Label name
-> (GetUStoreField store name : UStore store : s)
   :-> (UStore store : s)
ustoreSetField Label "fallback"
forall a. IsLabel "fallback" a => a
forall (x :: Symbol) a. IsLabel x a => a
#fallback) ('[UStore store] :-> '[UStore store])
-> ['[UStore store] :-> '[UStore store]]
-> ['[UStore store] :-> '[UStore store]]
forall a. a -> [a] -> [a]
: Rec (EpwCaseClause store) interface
-> ['[UStore store] :-> '[UStore store]]
forall (entries :: [EntrypointKind]) store.
(CodeMigrations entries, Typeable store,
 GetUStoreKey store "code" ~ MText,
 GetUStoreValue store "code" ~ EntrypointImpl store) =>
Rec (EpwCaseClause store) entries
-> ['[UStore store] :-> '[UStore store]]
mkMigrations Rec (EpwCaseClause store) interface
entries
  }

-- | Like 'mkEpwContract', but accepts a tuple of clauses, not a 'Rec'.
mkEpwContractT
  :: forall clauses ver (interface :: [EntrypointKind]) store.
  ( interface ~ VerInterface ver, store ~ VerUStoreTemplate ver
  , clauses ~ Rec (EpwCaseClause store) interface
  , RecFromTuple clauses
  , CodeMigrations interface
  , HasUStore "code" MText (EntrypointImpl store) store
  , HasUField "fallback" (EpwFallback store) store
  , Typeable store
  )
  => IsoRecTuple clauses
  -> EpwFallback store
  -> EpwContract ver
mkEpwContractT :: IsoRecTuple clauses -> EpwFallback store -> EpwContract ver
mkEpwContractT IsoRecTuple clauses
clauses EpwFallback store
fallback = Rec (EpwCaseClause store) interface
-> EpwFallback store -> EpwContract ver
forall (ver :: VersionKind) (interface :: [EntrypointKind]) store.
(interface ~ VerInterface ver, store ~ VerUStoreTemplate ver,
 CodeMigrations interface,
 HasUStore "code" MText (EntrypointImpl store) store,
 HasUField "fallback" (EpwFallback store) store, Typeable store) =>
Rec (EpwCaseClause store) interface
-> EpwFallback store -> EpwContract ver
mkEpwContract (IsoRecTuple (Rec (EpwCaseClause store) interface)
-> Rec (EpwCaseClause store) interface
forall r. RecFromTuple r => IsoRecTuple r -> r
recFromTuple IsoRecTuple clauses
IsoRecTuple (Rec (EpwCaseClause store) interface)
clauses) EpwFallback store
fallback

-- | A helper type that defines an entrypoint that receives
--   an unpacked argument
type TypedEntrypointImpl arg store =
  Lambda (arg, UStore store) ([Operation], UStore store)

-- | A helper type that defines an entrypoint that receives
--   a packed argument, i.e. it's basically an unpack instruction
--   followed by a TypedEntrypoint code
type EntrypointImpl store =
  Lambda (ByteString, UStore store) ([Operation], UStore store)

-- | A helper type that defines a function being called in case
--   no implementation matches the requested entrypoint
type EpwFallback store =
  Lambda ((MText, ByteString), UStore store) ([Operation], UStore store)

-- | A data type representing a full case clause with the name
--   and implementation of an entrypoint.
data EpwCaseClause store (entry :: EntrypointKind) where
  EpwCaseClause
    :: TypedEntrypointImpl arg store
    -> EpwCaseClause store '(name, arg)

(/==>)
  :: Label name
  -> Lambda (arg, UStore store) ([Operation], UStore store)
  -> EpwCaseClause store '(name, arg)
/==> :: Label name
-> Lambda (arg, UStore store) ([Operation], UStore store)
-> EpwCaseClause store '(name, arg)
(/==>) Label name
_ = Lambda (arg, UStore store) ([Operation], UStore store)
-> EpwCaseClause store '(name, arg)
forall arg store (name :: Symbol).
TypedEntrypointImpl arg store -> EpwCaseClause store '(name, arg)
EpwCaseClause
infixr 0 /==>

-- | A greatly simplified version of UParam lookup code.
--
--   While it does not provide the same safety guarantees as UParam's lookup,
--   it does a map search instead of a linear search, and thus it may consume
--   less gas in practice.
caseUParamUnsafe'
  :: forall store (entries :: [EntrypointKind]).
  ( HasUStore "code" MText (EntrypointImpl store) store
  , HasUField "fallback" (EpwFallback store) store
  )
  => '[UParam entries, UStore store] :-> '[([Operation], UStore store)]
caseUParamUnsafe' :: '[UParam entries, UStore store] :-> '[([Operation], UStore store)]
caseUParamUnsafe' = do
  '[UParam entries, UStore store]
:-> '[UParam entries, UParam entries, UStore store]
forall a (s :: [*]). (a : s) :-> (a : a : s)
dup
  '[UParam entries, UParam entries, UStore store]
:-> '[(MText, ByteString), UParam entries, UStore store]
forall (entries :: [EntrypointKind]) (s :: [*]).
(UParam entries : s) :-> ((MText, ByteString) : s)
unwrapUParam
  '[(MText, ByteString), UParam entries, UStore store]
:-> '[MText, ByteString, UParam entries, UStore store]
forall a b (s :: [*]). ((a, b) : s) :-> (a : b : s)
unpair
  ('[ByteString, UParam entries, UStore store]
 :-> '[UStore store, ByteString, UParam entries, UStore store])
-> '[MText, ByteString, UParam entries, UStore store]
   :-> '[MText, UStore store, ByteString, UParam entries,
         UStore store]
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
dip (forall (s :: [*]) (s' :: [*]) a.
ConstraintDUPNLorentz (ToPeano 3) s s' a =>
s :-> (a : s)
forall (n :: Nat) (s :: [*]) (s' :: [*]) a.
ConstraintDUPNLorentz (ToPeano n) s s' a =>
s :-> (a : s)
duupX @3)
  Label "code"
-> '[GetUStoreKey store "code", UStore store, ByteString,
     UParam entries, UStore store]
   :-> '[Maybe (GetUStoreValue store "code"), ByteString,
         UParam entries, UStore store]
forall store (name :: Symbol) (s :: [*]).
(KeyAccessC store name, ValueAccessC store name) =>
Label name
-> (GetUStoreKey store name : UStore store : s)
   :-> (Maybe (GetUStoreValue store name) : s)
ustoreGet Label "code"
forall a. IsLabel "code" a => a
forall (x :: Symbol) a. IsLabel x a => a
#code
  if Condition
  '[Maybe (EntrypointImpl store), ByteString, UParam entries,
    UStore store]
  '[EntrypointImpl store, ByteString, UParam entries, UStore store]
  '[ByteString, UParam entries, UStore store]
  '[([Operation], UStore store)]
  '[([Operation], UStore store)]
forall a (argr :: [*]) (outb :: [*]).
Condition (Maybe a : argr) (a : argr) argr outb outb
IsSome
  then ('[ByteString, UParam entries, UStore store]
 :-> '[(ByteString, UStore store)])
-> '[EntrypointImpl store, ByteString, UParam entries,
     UStore store]
   :-> '[EntrypointImpl store, (ByteString, UStore store)]
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
dip (('[UParam entries, UStore store] :-> '[UStore store])
-> '[ByteString, UParam entries, UStore store]
   :-> '[ByteString, UStore store]
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
dip ('[UParam entries, UStore store] :-> '[UStore store]
forall a (s :: [*]). (a : s) :-> s
drop) ('[ByteString, UParam entries, UStore store]
 :-> '[ByteString, UStore store])
-> ('[ByteString, UStore store] :-> '[(ByteString, UStore store)])
-> '[ByteString, UParam entries, UStore store]
   :-> '[(ByteString, UStore store)]
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# '[ByteString, UStore store] :-> '[(ByteString, UStore store)]
forall a b (s :: [*]). (a : b : s) :-> ((a, b) : s)
pair) ('[EntrypointImpl store, ByteString, UParam entries, UStore store]
 :-> '[EntrypointImpl store, (ByteString, UStore store)])
-> ('[EntrypointImpl store, (ByteString, UStore store)]
    :-> '[(ByteString, UStore store), EntrypointImpl store])
-> '[EntrypointImpl store, ByteString, UParam entries,
     UStore store]
   :-> '[(ByteString, UStore store), EntrypointImpl store]
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# '[EntrypointImpl store, (ByteString, UStore store)]
:-> '[(ByteString, UStore store), EntrypointImpl store]
forall a b (s :: [*]). (a : b : s) :-> (b : a : s)
swap ('[EntrypointImpl store, ByteString, UParam entries, UStore store]
 :-> '[(ByteString, UStore store), EntrypointImpl store])
-> ('[(ByteString, UStore store), EntrypointImpl store]
    :-> '[([Operation], UStore store)])
-> '[EntrypointImpl store, ByteString, UParam entries,
     UStore store]
   :-> '[([Operation], UStore store)]
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# '[(ByteString, UStore store), EntrypointImpl store]
:-> '[([Operation], UStore store)]
forall a b (s :: [*]). (a : Lambda a b : s) :-> (b : s)
exec
  else do
    '[ByteString, UParam entries, UStore store]
:-> '[UParam entries, UStore store]
forall a (s :: [*]). (a : s) :-> s
drop
    ('[UStore store]
 :-> '[UStore store,
       Lambda
         ((MText, ByteString), UStore store) ([Operation], UStore store)])
-> '[UParam entries, UStore store]
   :-> '[UParam entries, UStore store,
         Lambda
           ((MText, ByteString), UStore store) ([Operation], UStore store)]
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
dip (Label "fallback"
-> '[UStore store]
   :-> '[GetUStoreField store "fallback", UStore store]
forall store (name :: Symbol) (s :: [*]).
FieldAccessC store name =>
Label name
-> (UStore store : s)
   :-> (GetUStoreField store name : UStore store : s)
ustoreGetField Label "fallback"
forall a. IsLabel "fallback" a => a
forall (x :: Symbol) a. IsLabel x a => a
#fallback ('[UStore store]
 :-> '[Lambda
         ((MText, ByteString), UStore store) ([Operation], UStore store),
       UStore store])
-> ('[Lambda
        ((MText, ByteString), UStore store) ([Operation], UStore store),
      UStore store]
    :-> '[UStore store,
          Lambda
            ((MText, ByteString), UStore store) ([Operation], UStore store)])
-> '[UStore store]
   :-> '[UStore store,
         Lambda
           ((MText, ByteString), UStore store) ([Operation], UStore store)]
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# '[Lambda
    ((MText, ByteString), UStore store) ([Operation], UStore store),
  UStore store]
:-> '[UStore store,
      Lambda
        ((MText, ByteString), UStore store) ([Operation], UStore store)]
forall a b (s :: [*]). (a : b : s) :-> (b : a : s)
swap)
    '[UParam entries, UStore store,
  Lambda
    ((MText, ByteString), UStore store) ([Operation], UStore store)]
:-> '[(MText, ByteString), UStore store,
      Lambda
        ((MText, ByteString), UStore store) ([Operation], UStore store)]
forall (entries :: [EntrypointKind]) (s :: [*]).
(UParam entries : s) :-> ((MText, ByteString) : s)
unwrapUParam
    '[(MText, ByteString), UStore store,
  Lambda
    ((MText, ByteString), UStore store) ([Operation], UStore store)]
:-> '[((MText, ByteString), UStore store),
      Lambda
        ((MText, ByteString), UStore store) ([Operation], UStore store)]
forall a b (s :: [*]). (a : b : s) :-> ((a, b) : s)
pair
    '[((MText, ByteString), UStore store),
  Lambda
    ((MText, ByteString), UStore store) ([Operation], UStore store)]
:-> '[([Operation], UStore store)]
forall a b (s :: [*]). (a : Lambda a b : s) :-> (b : s)
exec

-- | Default implementation for 'EpwFallback' reports an error just like its
--   UParam counterpart
epwFallbackFail :: EpwFallback store
epwFallbackFail :: EpwFallback store
epwFallbackFail =
  '[((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)])
-> EpwFallback 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

-- | These functions create the code blocks one has to supply in order
--   upgrade a contract. These code blocks write the code of the contract
--   to a submap of UStore. Code migrations _do not delete_ the old code
--   blocks from UStore, so would still be possible to call the old entry
--   points manually after applying migrations.
class CodeMigrations (entries :: [EntrypointKind]) where
  mkMigrations
    :: forall store.
    ( Typeable store
    , GetUStoreKey store "code" ~ MText
    , GetUStoreValue store "code" ~ EntrypointImpl store
    )
    =>  Rec (EpwCaseClause store) entries
    -> ['[UStore store] :-> '[UStore store]]

instance
  ( CodeMigrations entries
  , KnownSymbol name
  , NiceUnpackedValue arg
  )
  => CodeMigrations ((name ?: arg) ': entries) where
    mkMigrations :: Rec (EpwCaseClause store) ((name ?: arg) : entries)
-> ['[UStore store] :-> '[UStore store]]
mkMigrations (EpwCaseClause TypedEntrypointImpl arg store
impl :& Rec (EpwCaseClause store) rs
clauses) =
      (('[(ByteString, UStore store)] :-> '[([Operation], UStore store)])
-> '[UStore store]
   :-> '['[(ByteString, UStore store)]
         :-> '[([Operation], UStore store)],
         UStore store]
forall t (s :: [*]). NiceConstant t => t -> s :-> (t : s)
push '[(ByteString, UStore store)] :-> '[([Operation], UStore store)]
untypedLambda ('[UStore store]
 :-> '['[(ByteString, UStore store)]
       :-> '[([Operation], UStore store)],
       UStore store])
-> ('['[(ByteString, UStore store)]
      :-> '[([Operation], UStore store)],
      UStore store]
    :-> '[MText,
          '[(ByteString, UStore store)] :-> '[([Operation], UStore store)],
          UStore store])
-> '[UStore store]
   :-> '[MText,
         '[(ByteString, UStore store)] :-> '[([Operation], UStore store)],
         UStore store]
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# MText
-> '['[(ByteString, UStore store)]
     :-> '[([Operation], UStore store)],
     UStore store]
   :-> '[MText,
         '[(ByteString, UStore store)] :-> '[([Operation], UStore store)],
         UStore store]
forall t (s :: [*]). NiceConstant t => t -> s :-> (t : s)
push (KnownSymbol name => MText
forall (name :: Symbol). KnownSymbol name => MText
symbolToMText @name) ('[UStore store]
 :-> '[MText,
       '[(ByteString, UStore store)] :-> '[([Operation], UStore store)],
       UStore store])
-> ('[MText,
      '[(ByteString, UStore store)] :-> '[([Operation], UStore store)],
      UStore store]
    :-> '[UStore store])
-> '[UStore store] :-> '[UStore store]
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# Label "code"
-> '[GetUStoreKey store "code", GetUStoreValue store "code",
     UStore store]
   :-> '[UStore store]
forall store (name :: Symbol) (s :: [*]).
(KeyAccessC store name, ValueAccessC store name) =>
Label name
-> (GetUStoreKey store name
      : GetUStoreValue store name : UStore store : s)
   :-> (UStore store : s)
ustoreInsert Label "code"
forall a. IsLabel "code" a => a
forall (x :: Symbol) a. IsLabel x a => a
#code)
      ('[UStore store] :-> '[UStore store])
-> ['[UStore store] :-> '[UStore store]]
-> ['[UStore store] :-> '[UStore store]]
forall a. a -> [a] -> [a]
: Rec (EpwCaseClause store) rs
-> ['[UStore store] :-> '[UStore store]]
forall (entries :: [EntrypointKind]) store.
(CodeMigrations entries, Typeable store,
 GetUStoreKey store "code" ~ MText,
 GetUStoreValue store "code" ~ EntrypointImpl store) =>
Rec (EpwCaseClause store) entries
-> ['[UStore store] :-> '[UStore store]]
mkMigrations Rec (EpwCaseClause store) rs
clauses
      where
        untypedLambda :: '[(ByteString, UStore store)] :-> '[([Operation], UStore store)]
untypedLambda = do
          '[(ByteString, UStore store)] :-> '[ByteString, UStore store]
forall a b (s :: [*]). ((a, b) : s) :-> (a : b : s)
unpair
          forall (s :: [*]).
NiceUnpackedValue arg =>
(ByteString : s) :-> (Maybe arg : s)
forall a (s :: [*]).
NiceUnpackedValue a =>
(ByteString : s) :-> (Maybe a : s)
unpackRaw @arg
          ('[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
          '[arg, UStore store] :-> '[(arg, UStore store)]
forall a b (s :: [*]). (a : b : s) :-> ((a, b) : s)
pair
          '[(arg, UStore store)] :-> '[([Operation], UStore store)]
TypedEntrypointImpl arg store
impl

instance CodeMigrations '[] where
  mkMigrations :: Rec (EpwCaseClause store) '[]
-> ['[UStore store] :-> '[UStore store]]
mkMigrations Rec (EpwCaseClause store) '[]
_ = []

-- | Removes an endpoint from the #code submap
removeEndpoint
  :: forall store name s.
     GetUStoreKey store "code" ~ MText
  => Label name
  -> UStore store ': s :-> UStore store ': s
removeEndpoint :: Label name -> (UStore store : s) :-> (UStore store : s)
removeEndpoint Label name
Label = do
  MText -> (UStore store : s) :-> (MText : UStore store : s)
forall t (s :: [*]). NiceConstant t => t -> s :-> (t : s)
push (MText -> (UStore store : s) :-> (MText : UStore store : s))
-> MText -> (UStore store : s) :-> (MText : UStore store : s)
forall a b. (a -> b) -> a -> b
$ KnownSymbol name => MText
forall (name :: Symbol). KnownSymbol name => MText
symbolToMText @name
  Label "code"
-> (GetUStoreKey store "code" : UStore store : s)
   :-> (UStore store : s)
forall store (name :: Symbol) (s :: [*]).
KeyAccessC store name =>
Label name
-> (GetUStoreKey store name : UStore store : s)
   :-> (UStore store : s)
ustoreDelete Label "code"
forall a. IsLabel "code" a => a
forall (x :: Symbol) a. IsLabel x a => a
#code

-- | Helper for documenting entrypoints with EPW interface.
class EpwDocumented (entries :: [EntrypointKind]) where
  -- | Make up documentation for given entry points.
  --
  -- As result you get a fake contract from which you can later build desired
  -- documentation. Although, you may want to add contract name and
  -- description first.
  epwDocument
    :: Rec (EpwCaseClause store) entries
    -> Lambda () ()

instance EpwDocumented '[] where
  epwDocument :: Rec (EpwCaseClause store) '[] -> Lambda () ()
epwDocument Rec (EpwCaseClause store) '[]
RNil = Lambda () ()
forall (s :: [*]). s :-> s
nop

instance (KnownSymbol name, EpwDocumented es) =>
         EpwDocumented ('(name, a) ': es) where
  epwDocument :: Rec (EpwCaseClause store) ('(name, a) : es) -> Lambda () ()
epwDocument (EpwCaseClause TypedEntrypointImpl arg store
code :& Rec (EpwCaseClause store) rs
es) =
    let documentedCode :: TypedEntrypointImpl arg store
documentedCode = ParamBuildingStep
-> TypedEntrypointImpl arg store -> TypedEntrypointImpl arg store
forall (inp :: [*]) (out :: [*]).
ParamBuildingStep -> (inp :-> out) -> inp :-> out
clarifyParamBuildingSteps (KnownSymbol name => ParamBuildingStep
forall (ctorName :: Symbol).
KnownSymbol ctorName =>
ParamBuildingStep
pbsUParam @name) TypedEntrypointImpl arg store
code
    in TypedEntrypointImpl arg store -> Lambda () ()
forall (inp :: [*]) (out :: [*]) (s :: [*]).
(inp :-> out) -> s :-> s
cutLorentzNonDoc TypedEntrypointImpl arg store
documentedCode Lambda () () -> Lambda () () -> Lambda () ()
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# Rec (EpwCaseClause store) rs -> Lambda () ()
forall (entries :: [EntrypointKind]) store.
EpwDocumented entries =>
Rec (EpwCaseClause store) entries -> Lambda () ()
epwDocument Rec (EpwCaseClause store) rs
es

-- | By given list of entrypoints make up a fake contract which contains
-- documentation for the body of given upgradeable contract.
epwContractDoc
  :: forall ver.
     ( NiceVersion ver
     , KnownContractVersion ver
     , EpwDocumented (VerInterface ver)
     , PermConstraint ver
     )
  => Rec (EpwCaseClause (VerUStoreTemplate ver)) (VerInterface ver)
  -> PermanentImpl ver
  -> Lambda () ()
epwContractDoc :: Rec (EpwCaseClause (VerUStoreTemplate ver)) (VerInterface ver)
-> PermanentImpl ver -> Lambda () ()
epwContractDoc Rec (EpwCaseClause (VerUStoreTemplate ver)) (VerInterface ver)
upgImpl PermanentImpl ver
permImpl =
  ((Parameter ver : Any) :-> Any) -> Lambda () ()
forall (s1 :: [*]) (s2 :: [*]) (s1' :: [*]) (s2' :: [*]).
(s1 :-> s2) -> s1' :-> s2'
fakeCoercing (((Parameter ver : Any) :-> Any) -> Lambda () ())
-> (((Parameter ver : Any) :-> Any)
    -> (Parameter ver : Any) :-> Any)
-> ((Parameter ver : Any) :-> Any)
-> Lambda () ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) :-> Any) -> Lambda () ())
-> ((Parameter ver : Any) :-> Any) -> Lambda () ()
forall a b. (a -> b) -> a -> b
$ do
    DVersion -> (Parameter ver : Any) :-> (Parameter ver : Any)
forall di (s :: [*]). DocItem di => di -> s :-> s
doc (DVersion -> (Parameter ver : Any) :-> (Parameter ver : Any))
-> DVersion -> (Parameter ver : Any) :-> (Parameter ver : Any)
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) :-> Any
forall (s1 :: [*]) (s2 :: [*]) (s1' :: [*]) (s2' :: [*]).
(s1 :-> s2) -> s1' :-> s2'
fakeCoercing (('[(Parameter ver, Storage ver)] :-> ContractOut (Storage ver))
 -> (Parameter ver : Any) :-> Any)
-> ('[(Parameter ver, Storage ver)] :-> ContractOut (Storage ver))
-> (Parameter ver : Any) :-> 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
    Lambda () () -> Any :-> Any
forall (s1 :: [*]) (s2 :: [*]) (s1' :: [*]) (s2' :: [*]).
(s1 :-> s2) -> s1' :-> s2'
fakeCoercing (Lambda () () -> Any :-> Any) -> Lambda () () -> Any :-> Any
forall a b. (a -> b) -> a -> b
$
      -- We have to put this part (which describes actual logic of our contract)
      -- separately, because this is not directly part of @Run@ entrypoint of
      -- 'upgradeableContract', and also because Markdown editors usually do not
      -- render deeply nested headers well.
      ParamBuildingStep -> Lambda () () -> Lambda () ()
forall (inp :: [*]) (out :: [*]).
ParamBuildingStep -> (inp :-> out) -> inp :-> out
clarifyParamBuildingSteps ParamBuildingStep
pbsContainedInRun (Lambda () () -> Lambda () ()) -> Lambda () () -> Lambda () ()
forall a b. (a -> b) -> a -> b
$
        Rec (EpwCaseClause (VerUStoreTemplate ver)) (VerInterface ver)
-> Lambda () ()
forall (entries :: [EntrypointKind]) store.
EpwDocumented entries =>
Rec (EpwCaseClause store) entries -> Lambda () ()
epwDocument Rec (EpwCaseClause (VerUStoreTemplate ver)) (VerInterface ver)
upgImpl
    ('[VerPermanent ver, UStore (VerUStoreTemplate ver)]
 :-> ContractOut (UStore (VerUStoreTemplate ver)))
-> Any :-> Any
forall (s1 :: [*]) (s2 :: [*]) (s1' :: [*]) (s2' :: [*]).
(s1 :-> s2) -> s1' :-> s2'
fakeCoercing (('[VerPermanent ver, UStore (VerUStoreTemplate ver)]
  :-> ContractOut (UStore (VerUStoreTemplate ver)))
 -> Any :-> Any)
-> ('[VerPermanent ver, UStore (VerUStoreTemplate ver)]
    :-> ContractOut (UStore (VerUStoreTemplate ver)))
-> Any :-> 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