allow upgrading key types in the participant

sdk/daml-lf/validation/BUILD.bazel

@@ -196,6 +196,8 @@ da_scala_test_suite(
             "//test-common:upgrades-FailsWhenTemplateAddsKeyType-v2.dar",
             "//test-common:upgrades-FailsWhenTemplateChangesKeyType-v1.dar",
             "//test-common:upgrades-FailsWhenTemplateChangesKeyType-v2.dar",
+            "//test-common:upgrades-SucceedsWhenTemplateUpgradesKeyType-v1.dar",
+            "//test-common:upgrades-SucceedsWhenTemplateUpgradesKeyType-v2.dar",
             "//test-common:upgrades-FailsWhenTemplateChoiceChangesItsReturnType-v1.dar",
             "//test-common:upgrades-FailsWhenTemplateChoiceChangesItsReturnType-v2.dar",
             "//test-common:upgrades-FailsWhenTemplateRemovesKeyType-v1.dar",

sdk/daml-lf/validation/src/main/scala/com/digitalasset/daml/lf/validation/Upgrading.scala

@@ -4,10 +4,9 @@
 package com.daml.lf
 package validation
 
-import com.daml.lf.data.Ref.TypeConName
 import com.daml.lf.data.{ImmArray, Ref}
 import com.daml.lf.language.Ast._
-import com.daml.lf.language.{Ast, LanguageVersion, PackageInterface}
+import com.daml.lf.language.{Ast, LanguageVersion}
 
 import scala.annotation.tailrec
 import scala.util.{Failure, Success, Try}
@@ -383,169 +382,8 @@ case class TypecheckUpgrades(
 ) {
   import TypecheckUpgrades._
 
-  private lazy val packageId: Upgrading[Ref.PackageId] = packages.map(_._1)
   private lazy val _package: Upgrading[Ast.Package] = packages.map(_._2)
 
-  private val packageInterface: Upgrading[PackageInterface] =
-    packages.map { case (pkgId, pkgAst) => PackageInterface(Map(pkgId -> pkgAst)) }
-
-  /** The set of type constructors whose definitions are structurally equal between the
-    * past and present packages. It is built by building the largest fixed point of
-    * [[genStructurallyEqualTyConsStep]], which removes type constructors whose definitions
-    * are not structurally equal from a set. The set is seeded with the qualified names of
-    *  all type constructors present in both packages and whose definitions are serializable.
-    */
-  private lazy val structurallyEqualTyCons: Set[Ref.QualifiedName] = {
-    def tyCons(pkg: Ast.Package): Set[Ref.QualifiedName] = {
-      pkg.modules.flatMap { case (moduleName, module) =>
-        module.definitions.collect {
-          case (name, dt: DDataType) if dt.serializable =>
-            Ref.QualifiedName(moduleName, name)
-        }
-      }.toSet
-    }
-    val commonTyCons = tyCons(_package.past).intersect(tyCons(_package.present))
-    genStructurallyEqualTyCons(commonTyCons)
-  }
-
-  /** Computes the fixed point of genStructurallyEqualTyConsStep.
-    */
-  @tailrec
-  private def genStructurallyEqualTyCons(tyCons: Set[Ref.QualifiedName]): Set[Ref.QualifiedName] = {
-    val newTyCOns = genStructurallyEqualTyConsStep(tyCons)
-    if (newTyCOns == tyCons) tyCons
-    else genStructurallyEqualTyCons(newTyCOns)
-  }
-
-  /** For each type constructor name in [[tyCons]], checks that the definition of [[tyCons]] in
-    * the past and present packages are structurally equal, assuming that the type constructors
-    * in [[tyCons]] are structurally equal. Removes those that aren't.
-    */
-  def genStructurallyEqualTyConsStep(tyCons: Set[Ref.QualifiedName]): Set[Ref.QualifiedName] = {
-    tyCons.filter { name =>
-      val pastTypeConName = TypeConName(packageId.past, name)
-      val presentTypeConName = TypeConName(packageId.present, name)
-      structurallyEqualDataTypes(
-        tyCons,
-        Util.handleLookup(
-          Context.DefDataType(pastTypeConName),
-          packageInterface.past
-            .lookupDataType(pastTypeConName),
-        ),
-        Util.handleLookup(
-          Context.DefDataType(presentTypeConName),
-          packageInterface.present
-            .lookupDataType(presentTypeConName),
-        ),
-      )
-    }
-  }
-
-  /** Checks that [[pastDataType]] and [[presentDataType]] are structurally equal, assuming that
-    * the type constructors in [[tyCons]] are structurally equal.
-    */
-  def structurallyEqualDataTypes(
-      tyCons: Set[Ref.QualifiedName],
-      pastDataType: DDataType,
-      presentDataType: DDataType,
-  ): Boolean =
-    structurallyEqualDataCons(
-      tyCons,
-      Closure(Env().extend(pastDataType.params.map(_._1)), pastDataType.cons),
-      Closure(Env().extend(presentDataType.params.map(_._1)), presentDataType.cons),
-    )
-
-  /** Checks that [[pastCons]] and [[presentCons]] are structurally equal, assuming that
-    * the type constructors in [[tyCons]] are structurally equal.
-    */
-  private def structurallyEqualDataCons(
-      tyCons: Set[Ref.QualifiedName],
-      pastCons: Closure[DataCons],
-      presentCons: Closure[DataCons],
-  ): Boolean =
-    (pastCons.value, presentCons.value) match {
-      case (DataRecord(pastFields), DataRecord(presentFields)) =>
-        pastFields.length == presentFields.length &&
-        pastFields.iterator.zip(presentFields.iterator).forall {
-          case ((pastFieldName, pastType), (presentFieldName, presentType)) =>
-            pastFieldName == presentFieldName &&
-            structurallyEqualTypes(
-              tyCons,
-              Closure(pastCons.env, pastType),
-              Closure(presentCons.env, presentType),
-            )
-        }
-      case (DataVariant(pastVariants), DataVariant(presentVariants)) =>
-        pastVariants.length == presentVariants.length &&
-        pastVariants.iterator.zip(presentVariants.iterator).forall {
-          case ((pastVariantName, pastType), (presentVariantName, presentType)) =>
-            pastVariantName == presentVariantName &&
-            structurallyEqualTypes(
-              tyCons,
-              Closure(pastCons.env, pastType),
-              Closure(presentCons.env, presentType),
-            )
-        }
-      case (DataEnum(pastConstructors), DataEnum(presentConstructors)) =>
-        pastConstructors.length == presentConstructors.length &&
-        pastConstructors.iterator.zip(presentConstructors.iterator).forall {
-          case (pastCtor, presentCtor) => pastCtor == presentCtor
-        }
-      case _ =>
-        false
-    }
-
-  /** Checks that [[pastType]] and [[presentType]] are structurally equal, assuming that
-    * the type constructors in [[tyCons]] are structurally equal.
-    */
-  private def structurallyEqualTypes(
-      tyCons: Set[Ref.QualifiedName],
-      pastType: Closure[Ast.Type],
-      presentType: Closure[Ast.Type],
-  ): Boolean =
-    structurallyEqualTypes(
-      tyCons,
-      pastType.env,
-      presentType.env,
-      List((pastType.value, presentType.value)),
-    )
-
-  /** A stack-safe version of [[structurallyEqualTypes]] that uses a work list.
-    */
-  @tailrec
-  private def structurallyEqualTypes(
-      tyCons: Set[Ref.QualifiedName],
-      envPast: Env,
-      envPresent: Env,
-      trips: List[(Type, Type)],
-  ): Boolean = {
-    trips match {
-      case Nil => true
-      case (t1, t2) :: trips =>
-        (t1, t2) match {
-          case (TVar(x1), TVar(x2)) =>
-            envPast.binderDepth(x1) == envPresent.binderDepth(x2) &&
-            structurallyEqualTypes(tyCons, envPast, envPresent, trips)
-          case (TNat(n1), TNat(n2)) =>
-            n1 == n2 && structurallyEqualTypes(tyCons, envPast, envPresent, trips)
-          case (TTyCon(c1), TTyCon(c2)) =>
-            // Either c1 and c2 are the same type constructor from the exact same package (e.g. Tuple2),
-            // or they must have the same qualified name and be structurally equal by co-induction
-            // hypothesis.
-            (c1 == c2 ||
-              (c1.qualifiedName == c2.qualifiedName &&
-                tyCons.contains(c1.qualifiedName))) &&
-            structurallyEqualTypes(tyCons, envPast, envPresent, trips)
-          case (TApp(f1, a1), TApp(f2, a2)) =>
-            structurallyEqualTypes(tyCons, envPast, envPresent, (f1, f2) :: (a1, a2) :: trips)
-          case (TBuiltin(b1), TBuiltin(b2)) =>
-            b1 == b2 && structurallyEqualTypes(tyCons, envPast, envPresent, trips)
-          case _ =>
-            false
-        }
-    }
-  }
-
   private def check(): Try[Unit] = {
     for {
       _ <- checkLfVersions(_package.map(_.languageVersion))
@@ -724,13 +562,7 @@ case class TypecheckUpgrades(
       case Upgrading(None, None) => Success(());
       case Upgrading(Some(pastKey), Some(presentKey)) => {
         val keyPastPresent = Upgrading(pastKey.typ, presentKey.typ)
-        if (
-          !structurallyEqualTypes(
-            structurallyEqualTyCons,
-            Closure(Env(), pastKey.typ),
-            Closure(Env(), presentKey.typ),
-          )
-        )
+        if (!checkType(Upgrading(Closure(Env(), pastKey.typ), Closure(Env(), presentKey.typ))))
           fail(UpgradeError.TemplateChangedKeyType(templateName, keyPastPresent))
         else
           Success(())

sdk/daml-lf/validation/src/test/scala/com/digitalasset/daml/lf/validation/upgrade/UpgradesSpecBase.scala

@@ -208,6 +208,13 @@ trait LongTests { this: UpgradesSpec =>
         assertPackageUpgradeCheck(Some("The upgraded template A cannot change its key type.")),
       )
     }
+    s"Succeeds when template upgrades its key type ($suffix)" in {
+      testPackagePair(
+        "test-common/upgrades-SucceedsWhenTemplateUpgradesKeyType-v1.dar",
+        "test-common/upgrades-SucceedsWhenTemplateUpgradesKeyType-v2.dar",
+        assertPackageUpgradeCheck(None),
+      )
+    }
     s"Fails when template removes key type ($suffix)" in {
       testPackagePair(
         "test-common/upgrades-FailsWhenTemplateRemovesKeyType-v1.dar",

sdk/daml-script/runner/src/main/scala/com/digitalasset/daml/lf/engine/script/v2/ScriptF.scala

@@ -400,7 +400,7 @@ class ScriptF(majorLanguageVersion: LanguageMajorVersion) {
       for {
         keyTy <- env.lookupKeyTy(id)
         translatorConfig =
-          if (enableContractUpgrading) preprocessing.ValueTranslator.Config.Coerceable
+          if (enableContractUpgrading) preprocessing.ValueTranslator.Config.Upgradeable
           else preprocessing.ValueTranslator.Config.Strict
         translated <- env.valueTranslator
           .translateValue(keyTy, v, translatorConfig)

sdk/daml-script/test/daml/upgrades/ContractKeys.daml

@@ -6,12 +6,27 @@ module ContractKeys (main) where
 import UpgradeTestLib
 import qualified V1.ContractKeys as V1
 import qualified V2.ContractKeys as V2
+import qualified V1.UpgradedContractKeys as V1
+import qualified V2.UpgradedContractKeys as V2
 
 {- PACKAGE
 name: contract-key-upgrades
 versions: 2
 -}
 
+main : TestTree
+main = tests
+  [ ("Query an unchanged old key for a new contract", queryKeyUnchanged)
+  , ("ExerciseByKey command an unchanged old key for a new contract", exerciseCmdKeyUnchanged)
+  , ("Fetching an unchanged old key for a new contract", fetchKeyUnchanged)
+  , ("ExerciseByKey in Update an unchanged old key for a new contract", exerciseUpdateKeyUnchanged)
+  , ("Query an Upgraded old key for a new contract", queryKeyUpgraded)
+  -- TODO(https://github.com/digital-asset/daml/issues/19782): re-enable this test once the issue is fixed
+  -- , ("ExerciseByKey command an Upgraded old key for a new contract", exerciseCmdKeyUpgraded)
+  , ("Fetching an Upgraded old key for a new contract", fetchKeyUpgraded)
+  , ("ExerciseByKey in Update an Upgraded old key for a new contract", exerciseUpdateKeyUpgraded)
+  ]
+
 {- MODULE
 package: contract-key-upgrades
 contents: |
@@ -53,14 +68,6 @@ contents: |
         do exerciseByKey @UnchangedKey k UnchangedKeyCall
 -}
 
-main : TestTree
-main = tests
-  [ ("Query an unchanged old key for a new contract", queryKeyUnchanged)
-  , ("ExerciseByKey command an unchanged old key for a new contract", exerciseCmdKeyUnchanged)
-  , ("Fetching an unchanged old key for a new contract", fetchKeyUnchanged)
-  , ("ExerciseByKey in Update an unchanged old key for a new contract", exerciseUpdateKeyUnchanged)
-  ]
-
 queryKeyUnchanged : Test
 queryKeyUnchanged = test $ do
   a <- allocateParty "alice"
@@ -92,3 +99,76 @@ exerciseUpdateKeyUnchanged = test $ do
   res <- a `submit` createAndExerciseCmd (V2.UnchangedKeyHelper a) (V2.UnchangedKeyExercise $ V2.UnchangedKeyKey a 1)
   res === "V2"
 
+{- MODULE
+package: contract-key-upgrades
+contents: |
+  module UpgradedContractKeys where
+
+  data UpgradedKeyKey = UpgradedKeyKey with
+      p : Party
+      n : Int
+      m : Optional Int                                -- @V 2
+    deriving (Eq, Show)
+
+  template UpgradedKey
+    with
+      party : Party
+      n : Int
+      m : Optional Int                                -- @V 2
+    where
+      signatory party
+      key (UpgradedKeyKey party n) : UpgradedKeyKey   -- @V 1
+      key (UpgradedKeyKey party n m) : UpgradedKeyKey -- @V 2
+      maintainer key.p
+
+      choice UpgradedKeyCall : Text
+        controller party
+        do pure "V1"                                  -- @V 1
+        do pure "V2"                                  -- @V 2
+
+  template UpgradedKeyHelper
+    with
+      party : Party
+    where
+      signatory party
+      choice UpgradedKeyFetch : (ContractId UpgradedKey, UpgradedKey) with
+          k : UpgradedKeyKey
+        controller party
+        do fetchByKey k
+
+      choice UpgradedKeyExercise : Text with
+          k : UpgradedKeyKey
+        controller party
+        do exerciseByKey @UpgradedKey k UpgradedKeyCall
+-}
+
+queryKeyUpgraded : Test
+queryKeyUpgraded = test $ do
+  a <- allocateParty "alice"
+  cid <- a `submit` createExactCmd (V1.UpgradedKey a 1)
+  keyRes <- queryContractKey a $ V2.UpgradedKeyKey a 1 None
+  case keyRes of
+    Some (foundCid, foundContract) | show foundCid == show cid && foundContract == V2.UpgradedKey a 1 None -> pure ()
+    _ -> assertFail $ "Didn't find correct contract, expected " <> show (cid, V2.UpgradedKey a 1 None) <> ", got " <> show keyRes
+
+exerciseCmdKeyUpgraded : Test
+exerciseCmdKeyUpgraded = test $ do
+  a <- allocateParty "alice"
+  cid <- a `submit` createExactCmd (V1.UpgradedKey a 1)
+  res <- a `submit` exerciseByKeyExactCmd @V2.UpgradedKey (V2.UpgradedKeyKey a 1 None) V2.UpgradedKeyCall
+  res === "V2"
+
+fetchKeyUpgraded : Test
+fetchKeyUpgraded = test $ do
+  a <- allocateParty "alice"
+  cid <- a `submit` createCmd (V1.UpgradedKey a 1)
+  (foundCid, foundContract) <- a `submit` createAndExerciseCmd (V2.UpgradedKeyHelper a) (V2.UpgradedKeyFetch $ V2.UpgradedKeyKey a 1 None)
+  foundContract === V2.UpgradedKey a 1 None
+  show foundCid === show cid
+
+exerciseUpdateKeyUpgraded : Test
+exerciseUpdateKeyUpgraded = test $ do
+  a <- allocateParty "alice"
+  _ <- a `submit` createCmd (V1.UpgradedKey a 1)
+  res <- a `submit` createAndExerciseCmd (V2.UpgradedKeyHelper a) (V2.UpgradedKeyExercise $ V2.UpgradedKeyKey a 1 None)
+  res === "V2"

sdk/test-common/BUILD.bazel

@@ -336,6 +336,7 @@ da_scala_dar_resources_library(
         ("FailsWhenOldFieldIsDeletedFromTemplateChoice", {}, {}),
         ("FailsWhenTemplateAddsKeyType", {}, {}),
         ("FailsWhenTemplateChangesKeyType", {}, {}),
+        ("SucceedsWhenTemplateUpgradesKeyType", {}, {}),
         ("FailsWhenTemplateChangesKeyTypeSuperficially", {}, {}),
         ("FailsWhenTemplateChoiceChangesItsReturnType", {}, {}),
         ("FailsWhenTemplateRemovesKeyType", {}, {}),

sdk/test-common/src/main/daml/upgrades/FailsWhenTemplateChangesKeyType/v1/Main.daml

@@ -3,13 +3,12 @@
 
 module Main where
 
-data T = T with
-  i : Int
+data T = T {}
 
 template A with
     p : Party
     q : Party
   where
     signatory p
-    key (p, T 0) : (Party, T)
+    key (p, T) : (Party, T)
     maintainer (fst key)

sdk/test-common/src/main/daml/upgrades/FailsWhenTemplateChangesKeyType/v2/Main.daml

@@ -3,15 +3,14 @@
 
 module Main where
 
-data T = T with
-  i : Int
-  j : Optional Int
+data T = T {}
+data U = U {}
 
 template A with
     p : Party
     q : Party
   where
     signatory p
-    key (p, T 0 None) : (Party, T)
+    key (p, U) : (Party, U)
     maintainer (fst key)