diff --git a/bazel-haskell-deps.bzl b/bazel-haskell-deps.bzl index d74ff09f3b11..a60c9c1d9267 100644 --- a/bazel-haskell-deps.bzl +++ b/bazel-haskell-deps.bzl @@ -17,11 +17,11 @@ load("@os_info//:os_info.bzl", "is_linux", "is_windows") load("@dadew//:dadew.bzl", "dadew_tool_home") load("@rules_haskell//haskell:cabal.bzl", "stack_snapshot") -GHC_LIB_REV = "a0b9249a488a13d561a6731a74f72505" -GHC_LIB_SHA256 = "cfc8f68aa8f457370ad0164468398eba362a2bd73ebbb84f05dee96f93df7e02" +GHC_LIB_REV = "7efdbb093dad0ad7a5dfd47785bf1eba" +GHC_LIB_SHA256 = "6a53c9808da2232bc9f331cb26686637f7bf6888072288d98176c9da299b9bb1" GHC_LIB_VERSION = "8.8.1" -GHC_LIB_PARSER_REV = "a0b9249a488a13d561a6731a74f72505" -GHC_LIB_PARSER_SHA256 = "69a3b783f53b3bff7cc92bb51a4e520f7bb1097d2182745a408a41f5711734b0" +GHC_LIB_PARSER_REV = "7efdbb093dad0ad7a5dfd47785bf1eba" +GHC_LIB_PARSER_SHA256 = "b08884e7d3b9fec2baa667aefdb75f93fb253c5d66572085ab3dc2c1595a1d35" GHC_LIB_PARSER_VERSION = "8.8.1" GHCIDE_REV = "4146f08b729e1f4e4a3ac789570e9c0b9010944e" GHCIDE_SHA256 = "bd16242397b67ac0d803c7e0452b03396133d9b7aaf2ba3bddd834260a78bd80" diff --git a/ci/da-ghc-lib/compile.yml b/ci/da-ghc-lib/compile.yml index e0dbdd4edc34..8961e1585a60 100644 --- a/ci/da-ghc-lib/compile.yml +++ b/ci/da-ghc-lib/compile.yml @@ -12,7 +12,7 @@ jobs: variables: ghc-lib-sha: '362d4f38a7ac10521393de9b7ad942a77a2605be' base-sha: '9c787d4d24f2b515934c8503ee2bbd7cfac4da20' - patches: 'aa004d2294f756cd990092d2071ef368aa58d9af 833ca63be2ab14871874ccb6974921e8952802e9' + patches: 'e33ed14601b071ad15745f4455b1f50765ae26eb 833ca63be2ab14871874ccb6974921e8952802e9' flavor: 'da-ghc-8.8.1' steps: - checkout: self diff --git a/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion/Primitives.hs b/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion/Primitives.hs index b54ace9dcd9f..c7e38d55ffd3 100644 --- a/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion/Primitives.hs +++ b/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion/Primitives.hs @@ -292,6 +292,15 @@ convertPrim _ "UExerciseInterface" where choiceName = ChoiceName (T.intercalate "." $ unTypeConName $ qualObject choice) +convertPrim _ "UExerciseByKey" + (TApp proxy (TCon template) :-> key :-> TCon choice :-> TUpdate _returnTy) = + ETmLam (mkVar "_", TApp proxy (TCon template)) $ + ETmLam (mkVar "key", key) $ + ETmLam (mkVar "arg", TCon choice) $ + EUpdate $ UExerciseByKey template choiceName (EVar (mkVar "key")) (EVar (mkVar "arg")) + where + choiceName = ChoiceName (T.intercalate "." $ unTypeConName $ qualObject choice) + convertPrim _ "ULookupByKey" (key :-> TUpdate (TOptional (TContractId (TCon template)))) = ETmLam (mkVar "key", key) $ EUpdate $ ULookupByKey $ RetrieveByKey template (EVar $ mkVar "key") diff --git a/compiler/damlc/daml-stdlib-src/DA/Internal/Template/Functions.daml b/compiler/damlc/daml-stdlib-src/DA/Internal/Template/Functions.daml index 283f155996cf..0cb268f9eb39 100644 --- a/compiler/damlc/daml-stdlib-src/DA/Internal/Template/Functions.daml +++ b/compiler/damlc/daml-stdlib-src/DA/Internal/Template/Functions.daml @@ -196,16 +196,19 @@ class HasFromAnyContractKey t k | t -> k where -- | HIDE _fromAnyContractKey : proxy t -> Any -> Optional k +-- | Exposes `exerciseByKey` function. +class HasExerciseByKey t k c r | t -> k, t c -> r where + -- | HIDE + _exerciseByKey : proxy t -> k -> c -> Update r + -- | Exercise a choice on the contract associated with the given key. -- -- You must pass the `t` using an explicit type application. For -- instance, if you want to exercise a choice `Withdraw` on a contract of -- template `Account` given by its key `k`, you must call -- `exerciseByKey @Account k Withdraw`. -exerciseByKey : forall t k c r. (HasFetchByKey t k, HasExercise t c r) => k -> c -> Update r -exerciseByKey k c = do - (cid, _) <- fetchByKey @t k - exercise cid c +exerciseByKey : forall t k c r. HasExerciseByKey t k c r => k -> c -> Update r +exerciseByKey = _exerciseByKey ([] : [t]) -- | Create a contract and exercise the choice on the newly created contract. createAndExercise : forall t c r. (HasCreate t, HasExercise t c r) => t -> c -> Update r diff --git a/daml-lf/engine/src/test/scala/com/digitalasset/daml/lf/engine/EngineTest.scala b/daml-lf/engine/src/test/scala/com/digitalasset/daml/lf/engine/EngineTest.scala index a65969055b68..65fd592c2d88 100644 --- a/daml-lf/engine/src/test/scala/com/digitalasset/daml/lf/engine/EngineTest.scala +++ b/daml-lf/engine/src/test/scala/com/digitalasset/daml/lf/engine/EngineTest.scala @@ -611,6 +611,50 @@ class EngineTest } } + "DAML exercise-by-key" should { + val seed = hash("exercise-by-key") + val now = Time.Timestamp.now() + + "create a Exercise node with flag byKey without Fetch REMY" in { + + val tmplId = Identifier(basicTestsPkgId, "BasicTests:ExerciseByKey") + val cmds = ImmArray( + speedy.Command.CreateAndExercise( + templateId = tmplId, + createArgument = + SRecord(null, ImmArray(Ref.Name.assertFromString("name")), ArrayList(SParty(alice))), + choiceId = ChoiceName.assertFromString("Exercise"), + choiceArgument = SUnit, + ) + ) + val submitters = Set(alice) + + val result = suffixLenientEngine + .interpretCommands( + validating = false, + submitters = submitters, + readAs = Set.empty, + commands = cmds, + ledgerTime = now, + submissionTime = now, + seeding = InitialSeeding.TransactionSeed(seed), + ) + .consume(lookupContract, lookupPackage, lookupKey) + + inside(result) { case Right((tx, _)) => + inside(tx.roots.map(tx.nodes)) { case ImmArray(create: Node.Create, exe: Node.Exercise) => + create.templateId shouldBe tmplId + exe.templateId shouldBe tmplId + inside(exe.children.map(tx.nodes)) { case ImmArray(exeByKey: Node.Exercise) => + exeByKey.templateId shouldBe Identifier(basicTestsPkgId, "BasicTests:WithKey") + exeByKey.children shouldBe ImmArray.empty + exeByKey.byKey shouldBe true + } + } + } + } + } + "fecth-by-key" should { val seed = hash("fetch-by-key") diff --git a/daml-lf/tests/BasicTests.daml b/daml-lf/tests/BasicTests.daml index f3b9edd1fb69..5f3a3b9b09a1 100644 --- a/daml-lf/tests/BasicTests.daml +++ b/daml-lf/tests/BasicTests.daml @@ -379,6 +379,15 @@ template FailedFetchByKey None <- lookupByKey @WithKey key fetchByKey @WithKey key +template ExerciseByKey + with + p : Party + where + signatory p + choice Exercise : Int + controller p + do + exerciseByKey @WithKey (p, 42) SumToK with n = 0 test_failedAuths = scenario do alice <- getParty "alice"