Separate exercise & fetch for interfaces from templates (#10908)

* Separate exercise & fetch for interfaces from templates

part of #10810

changelog_begin
changelog_end

* Update compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Base.hs

Co-authored-by: Sofia Faro <sofia.faro@digitalasset.com>

* Update compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Base.hs

Co-authored-by: Sofia Faro <sofia.faro@digitalasset.com>

Co-authored-by: Sofia Faro <sofia.faro@digitalasset.com>
This commit is contained in:
Moritz Kiefer 2021-09-16 14:05:11 +02:00 committed by GitHub
parent f4adee91ca
commit 9b0fa29aec
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
20 changed files with 186 additions and 2 deletions

View File

@ -283,6 +283,12 @@ alphaUpdate env = \case
&& alphaExpr' env e1a e2a
&& alphaExpr' env e1b e2b
_ -> False
UExerciseInterface i1 c1 e1a e1b -> \case
UExerciseInterface i2 c2 e2a e2b -> alphaTypeCon i1 i2
&& c1 == c2
&& alphaExpr' env e1a e2a
&& alphaExpr' env e1b e2b
_ -> False
UExerciseByKey t1 c1 e1a e1b -> \case
UExerciseByKey t2 c2 e2a e2b -> alphaTypeCon t1 t2
&& c1 == c2
@ -293,6 +299,10 @@ alphaUpdate env = \case
UFetch t2 e2 -> alphaTypeCon t1 t2
&& alphaExpr' env e1 e2
_ -> False
UFetchInterface i1 e1 -> \case
UFetchInterface i2 e2 -> alphaTypeCon i1 i2
&& alphaExpr' env e1 e2
_ -> False
UGetTime -> \case
UGetTime -> True
_ -> False

View File

@ -639,6 +639,17 @@ data Update
, exeArg :: !Expr
-- ^ Argument for the choice.
}
-- | Exercise choice on a contract of an interface given a contract ID.
| UExerciseInterface
{ exeInterface :: !(Qualified TypeConName)
-- ^ Qualified type constructor corresponding to the interface.
, exeChoice :: !ChoiceName
-- ^ Choice to exercise.
, exeContractId :: !Expr
-- ^ Contract id of the contract template instance to exercise choice on.
, exeArg :: !Expr
-- ^ Argument for the choice.
}
-- | Exercise a choice on a contract by key.
| UExerciseByKey
{ exeTemplate :: !(Qualified TypeConName)
@ -658,6 +669,14 @@ data Update
-- ^ Contract id of the contract template instance whose argument shall be
-- retrieved.
}
-- | Retrieve the argument of an existing contract interface instance.
| UFetchInterface
{ fetInterface :: !(Qualified TypeConName)
-- ^ Qualified type constructor corresponding to the interface.
, fetContractId :: !Expr
-- ^ Contract id of the contract template instance whose argument shall be
-- retrieved.
}
-- | Retrieve effective ledger time.
| UGetTime
-- | See comment for 'SEmbedExpr'

View File

@ -133,8 +133,10 @@ freeVarsStep = \case
UBindF b e -> goBinding b e
UCreateF _ e -> e
UExerciseF _ _ e1 e2 -> e1 <> e2
UExerciseInterfaceF _ _ e1 e2 -> e1 <> e2
UExerciseByKeyF _ _ e1 e2 -> e1 <> e2
UFetchF _ e -> e
UFetchInterfaceF _ e -> e
UGetTimeF -> mempty
UEmbedExprF t e -> freeVarsInType t <> e
UFetchByKeyF r -> retrieveByKeyFKey r

View File

@ -377,6 +377,9 @@ pPrintTmArg lvl = pPrintPrec lvl (succ precEApp)
tplArg :: Qualified TypeConName -> Arg
tplArg tpl = TyArg (TCon tpl)
interfaceArg :: Qualified TypeConName -> Arg
interfaceArg tpl = TyArg (TCon tpl)
instance Pretty Arg where
pPrintPrec lvl _prec = \case
TmArg e -> pPrintTmArg lvl e
@ -406,11 +409,17 @@ instance Pretty Update where
-- NOTE(MH): Converting the choice name into a variable is a bit of a hack.
pPrintAppKeyword lvl prec "exercise"
[tplArg tpl, TmArg (EVar (ExprVarName (unChoiceName choice))), TmArg cid, TmArg arg]
UExerciseInterface interface choice cid arg ->
-- NOTE(MH): Converting the choice name into a variable is a bit of a hack.
pPrintAppKeyword lvl prec "exercise_interface"
[interfaceArg interface, TmArg (EVar (ExprVarName (unChoiceName choice))), TmArg cid, TmArg arg]
UExerciseByKey tpl choice key arg ->
pPrintAppKeyword lvl prec "exercise_by_key"
[tplArg tpl, TmArg (EVar (ExprVarName (unChoiceName choice))), TmArg key, TmArg arg]
UFetch tpl cid ->
pPrintAppKeyword lvl prec "fetch" [tplArg tpl, TmArg cid]
UFetchInterface interface cid ->
pPrintAppKeyword lvl prec "fetch_interface" [interfaceArg interface, TmArg cid]
UGetTime ->
keyword_ "get_time"
UEmbedExpr typ e ->

View File

@ -61,8 +61,10 @@ data UpdateF expr
| UBindF !(BindingF expr) !expr
| UCreateF !(Qualified TypeConName) !expr
| UExerciseF !(Qualified TypeConName) !ChoiceName !expr !expr
| UExerciseInterfaceF !(Qualified TypeConName) !ChoiceName !expr !expr
| UExerciseByKeyF !(Qualified TypeConName) !ChoiceName !expr !expr
| UFetchF !(Qualified TypeConName) !expr
| UFetchInterfaceF !(Qualified TypeConName) !expr
| UGetTimeF
| UEmbedExprF !Type !expr
| UFetchByKeyF !(RetrieveByKeyF expr)
@ -107,8 +109,10 @@ projectUpdate = \case
UBind a b -> UBindF (projectBinding a) b
UCreate a b -> UCreateF a b
UExercise a b c d -> UExerciseF a b c d
UExerciseInterface a b c d -> UExerciseInterfaceF a b c d
UExerciseByKey a b c d -> UExerciseByKeyF a b c d
UFetch a b -> UFetchF a b
UFetchInterface a b -> UFetchInterfaceF a b
UGetTime -> UGetTimeF
UEmbedExpr a b -> UEmbedExprF a b
ULookupByKey a -> ULookupByKeyF (projectRetrieveByKey a)
@ -124,8 +128,10 @@ embedUpdate = \case
UBindF a b -> UBind (embedBinding a) b
UCreateF a b -> UCreate a b
UExerciseF a b c d -> UExercise a b c d
UExerciseInterfaceF a b c d -> UExerciseInterface a b c d
UExerciseByKeyF a b c d -> UExerciseByKey a b c d
UFetchF a b -> UFetch a b
UFetchInterfaceF a b -> UFetchInterface a b
UGetTimeF -> UGetTime
UEmbedExprF a b -> UEmbedExpr a b
UFetchByKeyF a -> UFetchByKey (embedRetrieveByKey a)

View File

@ -243,6 +243,11 @@ applySubstInUpdate subst = \case
choiceName
(applySubstInExpr subst e1)
(applySubstInExpr subst e2)
UExerciseInterface interface choiceName e1 e2 -> UExerciseInterface
interface
choiceName
(applySubstInExpr subst e1)
(applySubstInExpr subst e2)
UExerciseByKey templateName choiceName e1 e2 -> UExerciseByKey
templateName
choiceName
@ -251,6 +256,9 @@ applySubstInUpdate subst = \case
UFetch templateName e -> UFetch
templateName
(applySubstInExpr subst e)
UFetchInterface interface e -> UFetchInterface
interface
(applySubstInExpr subst e)
e@UGetTime -> e
UEmbedExpr t e -> UEmbedExpr
(applySubstInType subst t)

View File

@ -659,6 +659,12 @@ decodeUpdate LF1.Update{..} = mayDecode "updateSum" updateSum $ \case
<*> decodeName ChoiceName update_ExerciseChoice
<*> mayDecode "update_ExerciseCid" update_ExerciseCid decodeExpr
<*> mayDecode "update_ExerciseArg" update_ExerciseArg decodeExpr
LF1.UpdateSumExerciseInterface LF1.Update_ExerciseInterface{..} ->
fmap EUpdate $ UExerciseInterface
<$> mayDecode "update_ExerciseInterfaceInterface" update_ExerciseInterfaceInterface decodeTypeConName
<*> decodeNameId ChoiceName update_ExerciseInterfaceChoiceInternedStr
<*> mayDecode "update_ExerciseInterfaceCid" update_ExerciseInterfaceCid decodeExpr
<*> mayDecode "update_ExerciseInterfaceArg" update_ExerciseInterfaceArg decodeExpr
LF1.UpdateSumExerciseByKey LF1.Update_ExerciseByKey{..} ->
fmap EUpdate $ UExerciseByKey
<$> mayDecode "update_ExerciseByKeyTemplate" update_ExerciseByKeyTemplate decodeTypeConName
@ -669,6 +675,10 @@ decodeUpdate LF1.Update{..} = mayDecode "updateSum" updateSum $ \case
fmap EUpdate $ UFetch
<$> mayDecode "update_FetchTemplate" update_FetchTemplate decodeTypeConName
<*> mayDecode "update_FetchCid" update_FetchCid decodeExpr
LF1.UpdateSumFetchInterface LF1.Update_FetchInterface{..} ->
fmap EUpdate $ UFetchInterface
<$> mayDecode "update_FetchInterfaceInterface" update_FetchInterfaceInterface decodeTypeConName
<*> mayDecode "update_FetchInterfaceCid" update_FetchInterfaceCid decodeExpr
LF1.UpdateSumGetTime LF1.Unit ->
pure (EUpdate UGetTime)
LF1.UpdateSumEmbedExpr LF1.Update_EmbedExpr{..} ->

View File

@ -729,6 +729,12 @@ encodeUpdate = fmap (P.Update . Just) . \case
update_ExerciseCid <- encodeExpr exeContractId
update_ExerciseArg <- encodeExpr exeArg
pure $ P.UpdateSumExercise P.Update_Exercise{..}
UExerciseInterface{..} -> do
update_ExerciseInterfaceInterface <- encodeQualTypeConName exeInterface
update_ExerciseInterfaceChoiceInternedStr <- encodeNameId unChoiceName exeChoice
update_ExerciseInterfaceCid <- encodeExpr exeContractId
update_ExerciseInterfaceArg <- encodeExpr exeArg
pure $ P.UpdateSumExerciseInterface P.Update_ExerciseInterface{..}
UExerciseByKey{..} -> do
update_ExerciseByKeyTemplate <- encodeQualTypeConName exeTemplate
update_ExerciseByKeyChoiceInternedStr <-
@ -741,6 +747,10 @@ encodeUpdate = fmap (P.Update . Just) . \case
update_FetchTemplate <- encodeQualTypeConName fetTemplate
update_FetchCid <- encodeExpr fetContractId
pure $ P.UpdateSumFetch P.Update_Fetch{..}
UFetchInterface{..} -> do
update_FetchInterfaceInterface <- encodeQualTypeConName fetInterface
update_FetchInterfaceCid <- encodeExpr fetContractId
pure $ P.UpdateSumFetchInterface P.Update_FetchInterface{..}
UGetTime -> pure $ P.UpdateSumGetTime P.Unit
UEmbedExpr typ e -> do
update_EmbedExprType <- encodeType typ

View File

@ -624,8 +624,14 @@ typeOfUpdate = \case
UBind binding body -> typeOfBind binding body
UCreate tpl arg -> checkCreate tpl arg $> TUpdate (TContractId (TCon tpl))
UExercise tpl choice cid arg -> typeOfExercise tpl choice cid arg
UExerciseInterface{} ->
-- TODO https://github.com/digital-asset/daml/issues/10810
error "Interfaces not supported"
UExerciseByKey tpl choice key arg -> typeOfExerciseByKey tpl choice key arg
UFetch tpl cid -> checkFetch tpl cid $> TUpdate (TCon tpl)
UFetchInterface{} ->
-- TODO https://github.com/digital-asset/daml/issues/10810
error "Interfaces not supported"
UGetTime -> pure (TUpdate TTimestamp)
UEmbedExpr typ e -> do
checkExpr e (TUpdate typ)

View File

@ -137,8 +137,14 @@ startFromUpdate seen world update = case update of
LF.UEmbedExpr _ upEx -> startFromExpr seen world upEx
LF.UCreate tpl _ -> Set.singleton (ACreate tpl)
LF.UExercise tpl choice _ _ -> Set.singleton (AExercise tpl choice)
LF.UExerciseInterface{} ->
-- TODO https://github.com/digital-asset/daml/issues/10810
error "Interfaces are not supported"
LF.UExerciseByKey tpl choice _ _ -> Set.singleton (AExercise tpl choice)
LF.UFetch{} -> Set.empty
LF.UFetchInterface{} ->
-- TODO https://github.com/digital-asset/daml/issues/10810
error "Interfaces are not supported"
LF.ULookupByKey{} -> Set.empty
LF.UFetchByKey{} -> Set.empty
LF.UTryCatch _ e1 _ e2 -> startFromExpr seen world e1 `Set.union` startFromExpr seen world e2

View File

@ -26,13 +26,13 @@ instance HasExercise Token Split (ContractId Token, ContractId Token) where
exercise = error "unimplemented"
-- TODO https://github.com/digital-asset/daml/issues/10810
-- Switch to this once the Haskell typechecker is fixed
-- GHC.Types.primitive @"UExercise"
-- GHC.Types.primitive @"UExerciseInterface"
instance HasExercise Token Transfer (ContractId Token) where
exercise = error "unimplemented"
-- TODO https://github.com/digital-asset/daml/issues/10810
-- Switch to this once the Haskell typechecker is fixed
-- GHC.Types.primitive @"UExercise"
-- GHC.Types.primitive @"UExerciseInterface"
instance IsToken Token where
-- TODO https://github.com/digital-asset/daml/issues/10810

View File

@ -1176,6 +1176,21 @@ message Update {
Expr arg = 5;
}
// Interface Exercise Update
message ExerciseInterface {
// Interface type
TypeConName interface = 1;
// name of the exercised template choice
// *Must be a valid interned identifier*
int32 choice_interned_str = 2;
// contract id
Expr cid = 3;
// argument
Expr arg = 4;
}
// ExerciseByKey Update
message ExerciseByKey {
// Template type
@ -1197,6 +1212,14 @@ message Update {
reserved 3; // was actor, we thought we'd need this, but we don't
}
// Interface Fetch Update
message FetchInterface {
// Interface type
TypeConName interface = 1;
// contract id
Expr cid = 2;
}
// Embedded Expression Update
message EmbedExpr {
// Expression type
@ -1235,6 +1258,8 @@ message Update {
// see similar constructor in `Scenario` on why this is useful.
EmbedExpr embed_expr = 7;
TryCatch try_catch = 11; // *Available in versions >= 1.14*
ExerciseInterface exercise_interface = 12; // *Available in versions >= 1.dev*
FetchInterface fetch_interface = 13; // *Available in versions >= 1.dev*
}
}

View File

@ -394,6 +394,11 @@ private[archive] class DecodeV1(minor: LV.Minor) {
)
}
private[this] def handleInternedName(
internedString: => Int
) =
toName(internedStrings(internedString))
private[this] def handleInternedName[Case](
actualCase: Case,
stringCase: Case,
@ -1240,6 +1245,16 @@ private[archive] class DecodeV1(minor: LV.Minor) {
argE = decodeExpr(exercise.getArg, definition),
)
case PLF.Update.SumCase.EXERCISE_INTERFACE =>
assertSince(LV.Features.interfaces, "exerciseInterface")
val exercise = lfUpdate.getExerciseInterface
UpdateExerciseInterface(
interface = decodeTypeConName(exercise.getInterface),
choice = handleInternedName(exercise.getChoiceInternedStr),
cidE = decodeExpr(exercise.getCid, definition),
argE = decodeExpr(exercise.getArg, definition),
)
case PLF.Update.SumCase.EXERCISE_BY_KEY =>
assertSince(LV.Features.exerciseByKey, "exerciseByKey")
val exerciseByKey = lfUpdate.getExerciseByKey
@ -1263,6 +1278,14 @@ private[archive] class DecodeV1(minor: LV.Minor) {
contractId = decodeExpr(fetch.getCid, definition),
)
case PLF.Update.SumCase.FETCH_INTERFACE =>
assertSince(LV.Features.interfaces, "fetchInterface")
val fetch = lfUpdate.getFetchInterface
UpdateFetchInterface(
interface = decodeTypeConName(fetch.getInterface),
contractId = decodeExpr(fetch.getCid, definition),
)
case PLF.Update.SumCase.FETCH_BY_KEY =>
UpdateFetchByKey(decodeRetrieveByKey(lfUpdate.getFetchByKey, definition))

View File

@ -365,6 +365,10 @@ private[daml] class EncodeV1(minor: LV.Minor) {
builder.setCreate(PLF.Update.Create.newBuilder().setTemplate(templateId).setExpr(arg))
case UpdateFetch(templateId, contractId) =>
builder.setFetch(PLF.Update.Fetch.newBuilder().setTemplate(templateId).setCid(contractId))
case UpdateFetchInterface(interface, contractId) =>
builder.setFetchInterface(
PLF.Update.FetchInterface.newBuilder().setInterface(interface).setCid(contractId)
)
case UpdateExercise(templateId, choice, cid, arg) =>
val b = PLF.Update.Exercise.newBuilder()
b.setTemplate(templateId)
@ -372,6 +376,13 @@ private[daml] class EncodeV1(minor: LV.Minor) {
b.setCid(cid)
b.setArg(arg)
builder.setExercise(b)
case UpdateExerciseInterface(interface, choice, cid, arg) =>
val b = PLF.Update.ExerciseInterface.newBuilder()
b.setInterface(interface)
setInternedString(choice, b.setChoiceInternedStr)
b.setCid(cid)
b.setArg(arg)
builder.setExerciseInterface(b)
case UpdateExerciseByKey(templateId, choice, key, arg) =>
assertSince(LV.Features.exerciseByKey, "exerciseByKey")
val b = PLF.Update.ExerciseByKey.newBuilder()
@ -797,6 +808,11 @@ private[daml] class EncodeV1(minor: LV.Minor) {
()
}
private def setInternedString[X](s: String, setThroughTable: Int => X) = {
setThroughTable(stringsTable.insert(s))
()
}
private def setDottedName[X](
name: Ref.DottedName,
addDirect: String => X,

View File

@ -773,6 +773,9 @@ private[lf] final class Compiler(
compileBlock(bindings, body)
case UpdateFetch(tmplId, coidE) =>
FetchDefRef(tmplId)(compile(coidE))
case UpdateFetchInterface(_, _) =>
// TODO https://github.com/digital-asset/daml/issues/10810
sys.error("Interfaces not supported")
case UpdateEmbedExpr(_, e) =>
compileEmbedExpr(e)
case UpdateCreate(tmplId, arg) =>
@ -784,6 +787,9 @@ private[lf] final class Compiler(
choiceId = chId,
argument = compile(argE),
)
case UpdateExerciseInterface(_, _, _, _) =>
// TODO https://github.com/digital-asset/daml/issues/10810
sys.error("Interfaces not supported")
case UpdateExerciseByKey(tmplId, chId, keyE, argE) =>
compileExerciseByKey(tmplId, compile(keyE), chId, compile(argE))
case UpdateGetTime =>

View File

@ -481,12 +481,19 @@ object Ast {
final case class UpdateBlock(bindings: ImmArray[Binding], body: Expr) extends Update
final case class UpdateCreate(templateId: TypeConName, arg: Expr) extends Update
final case class UpdateFetch(templateId: TypeConName, contractId: Expr) extends Update
final case class UpdateFetchInterface(interface: TypeConName, contractId: Expr) extends Update
final case class UpdateExercise(
templateId: TypeConName,
choice: ChoiceName,
cidE: Expr,
argE: Expr,
) extends Update
final case class UpdateExerciseInterface(
interface: TypeConName,
choice: ChoiceName,
cidE: Expr,
argE: Expr,
) extends Update
final case class UpdateExerciseByKey(
templateId: TypeConName,
choice: ChoiceName,

View File

@ -154,8 +154,12 @@ private[daml] class AstRewriter(
UpdateCreate(apply(templateId), apply(arg))
case UpdateFetch(templateId, contractId) =>
UpdateFetch(apply(templateId), apply(contractId))
case UpdateFetchInterface(interface, contractId) =>
UpdateFetchInterface(apply(interface), apply(contractId))
case UpdateExercise(templateId, choice, cid, arg) =>
UpdateExercise(apply(templateId), choice, cid, apply(arg))
case UpdateExerciseInterface(interface, choice, cid, arg) =>
UpdateExerciseInterface(apply(interface), choice, cid, apply(arg))
case UpdateExerciseByKey(templateId, choice, key, arg) =>
UpdateExerciseByKey(apply(templateId), choice, apply(key), apply(arg))
case UpdateGetTime => x

View File

@ -867,10 +867,16 @@ private[validation] object Typing {
typeOfCreate(tpl, arg)
case UpdateExercise(tpl, choice, cid, arg) =>
typeOfExercise(tpl, choice, cid, arg)
case UpdateExerciseInterface(_, _, _, _) =>
// TODO https://github.com/digital-asset/daml/issues/10810
sys.error("Interface not supported")
case UpdateExerciseByKey(tpl, choice, key, arg) =>
typeOfExerciseByKey(tpl, choice, key, arg)
case UpdateFetch(tpl, cid) =>
typeOfFetch(tpl, cid)
case UpdateFetchInterface(_, _) =>
// TODO https://github.com/digital-asset/daml/issues/10810
sys.error("Interface not supported")
case UpdateGetTime =>
TUpdate(TTimestamp)
case UpdateEmbedExpr(typ, exp) =>

View File

@ -77,8 +77,12 @@ private[validation] object ExprIterable {
Iterator(arg)
case UpdateFetch(templateId @ _, contractId) =>
Iterator(contractId)
case UpdateFetchInterface(interface @ _, contractId) =>
Iterator(contractId)
case UpdateExercise(templateId @ _, choice @ _, cid, arg) =>
Iterator(cid, arg)
case UpdateExerciseInterface(interface @ _, choice @ _, cid, arg) =>
Iterator(cid, arg)
case UpdateExerciseByKey(templateId @ _, choice @ _, key, arg) =>
Iterator(key, arg)
case UpdateGetTime => Iterator.empty

View File

@ -98,10 +98,17 @@ private[validation] object TypeIterable {
case UpdateFetch(templateId, contractId) =>
Iterator(TTyCon(templateId)) ++
iterator(contractId)
case UpdateFetchInterface(interface, contractId) =>
Iterator(TTyCon(interface)) ++
iterator(contractId)
case UpdateExercise(templateId, choice @ _, cid, arg) =>
Iterator(TTyCon(templateId)) ++
iterator(cid) ++
iterator(arg)
case UpdateExerciseInterface(interface, choice @ _, cid, arg) =>
Iterator(TTyCon(interface)) ++
iterator(cid) ++
iterator(arg)
case UpdateExerciseByKey(templateId, choice @ _, key, arg) =>
Iterator(TTyCon(templateId)) ++
iterator(key) ++