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>
digital-asset · Sep 16, 2021 · 9b0fa29 · 9b0fa29
1 parent f4adee9
commit 9b0fa29
Show file tree

Hide file tree

Showing 20 changed files with 186 additions and 2 deletions.
diff --git a/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Alpha.hs b/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Alpha.hs
@@ -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

diff --git a/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Base.hs b/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Base.hs
@@ -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'

diff --git a/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/FreeVars.hs b/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/FreeVars.hs
@@ -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

diff --git a/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Pretty.hs b/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Pretty.hs
@@ -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 ->

diff --git a/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Recursive.hs b/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Recursive.hs
@@ -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)

diff --git a/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Subst.hs b/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Subst.hs
@@ -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)

diff --git a/compiler/daml-lf-proto/src/DA/Daml/LF/Proto3/DecodeV1.hs b/compiler/daml-lf-proto/src/DA/Daml/LF/Proto3/DecodeV1.hs
@@ -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{..} ->

diff --git a/compiler/daml-lf-proto/src/DA/Daml/LF/Proto3/EncodeV1.hs b/compiler/daml-lf-proto/src/DA/Daml/LF/Proto3/EncodeV1.hs
@@ -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

diff --git a/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Check.hs b/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Check.hs
@@ -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)

diff --git a/compiler/damlc/daml-visual/src/DA/Daml/Visual.hs b/compiler/damlc/daml-visual/src/DA/Daml/Visual.hs
@@ -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

diff --git a/compiler/damlc/tests/daml-test-files/InterfaceDesugared.daml b/compiler/damlc/tests/daml-test-files/InterfaceDesugared.daml
@@ -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

diff --git a/daml-lf/archive/src/main/protobuf/com/daml/daml_lf_dev/daml_lf_1.proto b/daml-lf/archive/src/main/protobuf/com/daml/daml_lf_dev/daml_lf_1.proto
@@ -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*
   }
 }
 

diff --git a/daml-lf/archive/src/main/scala/com/digitalasset/daml/lf/archive/DecodeV1.scala b/daml-lf/archive/src/main/scala/com/digitalasset/daml/lf/archive/DecodeV1.scala
@@ -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))
 

diff --git a/daml-lf/encoder/src/main/scala/com/digitalasset/daml/lf/archive/testing/EncodeV1.scala b/daml-lf/encoder/src/main/scala/com/digitalasset/daml/lf/archive/testing/EncodeV1.scala
@@ -365,13 +365,24 @@ 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)
           setString(choice, b.setChoiceStr, b.setChoiceInternedStr)
           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,

diff --git a/daml-lf/interpreter/src/main/scala/com/digitalasset/daml/lf/speedy/Compiler.scala b/daml-lf/interpreter/src/main/scala/com/digitalasset/daml/lf/speedy/Compiler.scala
@@ -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 =>