Disallow keys in LF 2.1 in the compiler (#18886)

* Disable keys in LfConversion. * fix UnusedMatchTests.daml in integration-v21 * fix //compiler/damlc/tests:upgrades * stop compiling daml tests that use keys with 2.1 * migrate the upgrade examples to 2.dev as they use keys * only compile daml-script/tests dar using keys to 2.dev * do not compile daml-script/test daml files that use keys to 2.1 * fix //docs:bindings-java-daml-test * add TODOs everywhere tests need to be split * add a tests that checks that contract keys are rejected for LF<2.dev * remove keys from compatibility tests * Add the qualified template name to the keys not supported error message
digital-asset · Apr 3, 2024 · cf2b387 · cf2b387
1 parent 62fe3c4
commit cf2b387
Show file tree

Hide file tree

Showing 21 changed files with 358 additions and 86 deletions.
diff --git a/sdk/compatibility/bazel_tools/data_dependencies/example/UpgradeFromCoinV1.daml b/sdk/compatibility/bazel_tools/data_dependencies/example/UpgradeFromCoinV1.daml
@@ -15,8 +15,6 @@ template UpgradeCoinProposal
   where
     signatory issuer
     observer owner
-    key (issuer, owner) : (Party, Party)
-    maintainer key._1
     choice Accept : ContractId UpgradeCoinAgreement
       controller owner
       do create UpgradeCoinAgreement with ..
@@ -29,8 +27,6 @@ template UpgradeCoinAgreement
     owner : Party
   where
     signatory issuer, owner
-    key (issuer, owner) : (Party, Party)
-    maintainer key._1
     nonconsuming choice Upgrade : ContractId CoinWithAmount
       with
         coinId : ContractId Coin

diff --git a/sdk/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs b/sdk/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs
@@ -1116,6 +1116,9 @@ convertTemplate env mc tplTypeCon tbinds@TemplateBinds{..}
 
 convertTemplateKey :: SdkVersioned => Env -> LF.TypeConName -> TemplateBinds -> ConvertM (Maybe TemplateKey)
 convertTemplateKey env tname TemplateBinds{..}
+    | Just fKey <- tbKey
+    , not (envLfVersion env `supports` featureContractKeys) =
+        unsupported "Contract keys." (T.unpack $ T.intercalate "." $ unTypeConName tname)
     | Just keyTy <- tbKeyType
     , Just fKey <- tbKey
     , Just fMaintainer <- tbMaintainer

diff --git a/sdk/compiler/damlc/tests/BUILD.bazel b/sdk/compiler/damlc/tests/BUILD.bazel
@@ -459,6 +459,7 @@ da_haskell_test(
         "filepath",
         "process",
         "regex-tdfa",
+        "safe",
         "tasty",
         "tasty-hunit",
         "text",

diff --git a/sdk/compiler/damlc/tests/daml-test-files/ContractKeysNotSupported.daml b/sdk/compiler/damlc/tests/daml-test-files/ContractKeysNotSupported.daml
@@ -0,0 +1,12 @@
+-- @DOES-NOT-SUPPORT-LF-FEATURE DAML_CONTRACT_KEYS
+-- @ERROR Contract keys
+
+module ContractKeysNotSupported where
+
+template TemplateWithKey
+  with
+    p: Party
+  where
+    signatory p
+    key p: Party
+    maintainer key
diff --git a/sdk/compiler/damlc/tests/daml-test-files/UnusedMatchTests.EXPECTED.desugared-daml b/sdk/compiler/damlc/tests/daml-test-files/UnusedMatchTests.EXPECTED.desugared-daml
@@ -103,33 +103,6 @@ _choice$_T$Revoke
      \ self this@T {..} arg@Revoke
        -> let _ = self in
           let _ = this in let _ = arg in do pure (revokeRetVal this))
-instance DA.Internal.Desugar.HasExerciseByKey T (Party,
-                                                 Text) DA.Internal.Desugar.Archive (()) where
-  _exerciseByKey = GHC.Types.primitive @"UExerciseByKey"
-instance DA.Internal.Desugar.HasExerciseByKey T (Party,
-                                                 Text) Revoke (()) where
-  _exerciseByKey = GHC.Types.primitive @"UExerciseByKey"
-instance DA.Internal.Desugar.HasKey T (Party, Text) where
-  key this@T {..}
-    = userWrittenTuple (sig this, ident this)
-    where
-        _ = this
-instance DA.Internal.Desugar.HasMaintainer T (Party, Text) where
-  _maintainer _ key
-    = DA.Internal.Desugar.toParties
-        ((DA.Internal.Record.getField @"_1" key))
-    where
-        _ = key
-instance DA.Internal.Desugar.HasFetchByKey T (Party, Text) where
-  fetchByKey = GHC.Types.primitive @"UFetchByKey"
-instance DA.Internal.Desugar.HasLookupByKey T (Party, Text) where
-  lookupByKey = GHC.Types.primitive @"ULookupByKey"
-instance DA.Internal.Desugar.HasToAnyContractKey T (Party,
-                                                    Text) where
-  _toAnyContractKey = GHC.Types.primitive @"EToAnyContractKey"
-instance DA.Internal.Desugar.HasFromAnyContractKey T (Party,
-                                                      Text) where
-  _fromAnyContractKey = GHC.Types.primitive @"EFromAnyContractKey"
 revokeRetVal : T -> ()
 revokeRetVal _ = ()
 assertion : T -> Bool

diff --git a/sdk/compiler/damlc/tests/daml-test-files/UnusedMatchTests.daml b/sdk/compiler/damlc/tests/daml-test-files/UnusedMatchTests.daml
@@ -28,8 +28,6 @@ template T
     signatory sig this
     observer obs this
     ensure assertion this
-    key (sig this, ident this): (Party, Text)
-    maintainer key._1
     choice Revoke: () with
       controller p
       do

diff --git a/sdk/compiler/damlc/tests/daml-test-files/UnusedMatchTestsWithKeys.EXPECTED.desugared-daml b/sdk/compiler/damlc/tests/daml-test-files/UnusedMatchTestsWithKeys.EXPECTED.desugared-daml
@@ -0,0 +1,144 @@
+module UnusedMatchTestsWithKeys where
+import (implicit) qualified DA.Internal.Record
+import (implicit) qualified GHC.Types
+import (implicit) qualified DA.Internal.Desugar
+import (implicit) DA.Internal.RebindableSyntax
+f x = 12
+data GHC.Types.DamlTemplate => T
+  = T {p : Party, q : Party}
+  deriving (DA.Internal.Desugar.Eq, DA.Internal.Desugar.Show)
+instance DA.Internal.Record.GetField "p" T Party where
+  getField = DA.Internal.Record.getFieldPrim @"p" @T @Party
+instance DA.Internal.Record.SetField "p" T Party where
+  setField = DA.Internal.Record.setFieldPrim @"p" @T @Party
+instance DA.Internal.Record.GetField "q" T Party where
+  getField = DA.Internal.Record.getFieldPrim @"q" @T @Party
+instance DA.Internal.Record.SetField "q" T Party where
+  setField = DA.Internal.Record.setFieldPrim @"q" @T @Party
+data Revoke
+  = Revoke {}
+  deriving (DA.Internal.Desugar.Eq, DA.Internal.Desugar.Show)
+instance DA.Internal.Desugar.HasSignatory T where
+  signatory this@T {..}
+    = DA.Internal.Desugar.toParties (sig this)
+    where
+        _ = this
+instance DA.Internal.Desugar.HasObserver T where
+  observer this@T {..}
+    = DA.Internal.Desugar.toParties (obs this)
+    where
+        _ = this
+instance DA.Internal.Desugar.HasEnsure T where
+  ensure this@T {..}
+    = assertion this
+    where
+        _ = this
+instance DA.Internal.Desugar.HasArchive T where
+  archive cid
+    = DA.Internal.Desugar.exercise cid DA.Internal.Desugar.Archive
+    where
+        _ = cid
+instance DA.Internal.Desugar.HasCreate T where
+  create = GHC.Types.primitive @"UCreate"
+instance DA.Internal.Desugar.HasFetch T where
+  fetch = GHC.Types.primitive @"UFetch"
+instance DA.Internal.Desugar.HasToAnyTemplate T where
+  _toAnyTemplate = GHC.Types.primitive @"EToAnyTemplate"
+instance DA.Internal.Desugar.HasFromAnyTemplate T where
+  _fromAnyTemplate = GHC.Types.primitive @"EFromAnyTemplate"
+instance DA.Internal.Desugar.HasTemplateTypeRep T where
+  _templateTypeRep = GHC.Types.primitive @"ETemplateTypeRep"
+instance DA.Internal.Desugar.HasIsInterfaceType T where
+  _isInterfaceType _ = DA.Internal.Desugar.False
+instance DA.Internal.Desugar.HasExercise T DA.Internal.Desugar.Archive (()) where
+  exercise = GHC.Types.primitive @"UExercise"
+instance DA.Internal.Desugar.HasToAnyChoice T DA.Internal.Desugar.Archive (()) where
+  _toAnyChoice = GHC.Types.primitive @"EToAnyChoice"
+instance DA.Internal.Desugar.HasFromAnyChoice T DA.Internal.Desugar.Archive (()) where
+  _fromAnyChoice = GHC.Types.primitive @"EFromAnyChoice"
+instance DA.Internal.Desugar.HasChoiceController T DA.Internal.Desugar.Archive where
+  _choiceController = GHC.Types.primitive @"EChoiceController"
+instance DA.Internal.Desugar.HasChoiceObserver T DA.Internal.Desugar.Archive where
+  _choiceObserver = GHC.Types.primitive @"EChoiceObserver"
+instance DA.Internal.Desugar.HasExercise T Revoke (()) where
+  exercise = GHC.Types.primitive @"UExercise"
+instance DA.Internal.Desugar.HasToAnyChoice T Revoke (()) where
+  _toAnyChoice = GHC.Types.primitive @"EToAnyChoice"
+instance DA.Internal.Desugar.HasFromAnyChoice T Revoke (()) where
+  _fromAnyChoice = GHC.Types.primitive @"EFromAnyChoice"
+instance DA.Internal.Desugar.HasChoiceController T Revoke where
+  _choiceController = GHC.Types.primitive @"EChoiceController"
+instance DA.Internal.Desugar.HasChoiceObserver T Revoke where
+  _choiceObserver = GHC.Types.primitive @"EChoiceObserver"
+_choice$_T$Archive :
+  (DA.Internal.Desugar.Consuming T,
+   T -> DA.Internal.Desugar.Archive -> [DA.Internal.Desugar.Party],
+   DA.Internal.Desugar.Optional (T
+                                 -> DA.Internal.Desugar.Archive -> [DA.Internal.Desugar.Party]),
+   DA.Internal.Desugar.Optional (T
+                                 -> DA.Internal.Desugar.Archive -> [DA.Internal.Desugar.Party]),
+   DA.Internal.Desugar.ContractId T
+   -> T
+      -> DA.Internal.Desugar.Archive -> DA.Internal.Desugar.Update (()))
+_choice$_T$Archive
+  = (DA.Internal.Desugar.Consuming, 
+     \ this _ -> DA.Internal.Desugar.signatory this, 
+     DA.Internal.Desugar.None, DA.Internal.Desugar.None, 
+     \ _ _ _ -> pure ())
+_choice$_T$Revoke :
+  (DA.Internal.Desugar.Consuming T,
+   T -> Revoke -> [DA.Internal.Desugar.Party],
+   DA.Internal.Desugar.Optional (T
+                                 -> Revoke -> [DA.Internal.Desugar.Party]),
+   DA.Internal.Desugar.Optional (T
+                                 -> Revoke -> [DA.Internal.Desugar.Party]),
+   DA.Internal.Desugar.ContractId T
+   -> T -> Revoke -> DA.Internal.Desugar.Update (()))
+_choice$_T$Revoke
+  = (DA.Internal.Desugar.Consuming, 
+     \ this@T {..} arg@Revoke
+       -> let _ = this in
+          let _ = arg in DA.Internal.Desugar.toParties (p), 
+     DA.Internal.Desugar.None, DA.Internal.Desugar.None, 
+     \ self this@T {..} arg@Revoke
+       -> let _ = self in
+          let _ = this in let _ = arg in do pure (revokeRetVal this))
+instance DA.Internal.Desugar.HasExerciseByKey T (Party,
+                                                 Text) DA.Internal.Desugar.Archive (()) where
+  _exerciseByKey = GHC.Types.primitive @"UExerciseByKey"
+instance DA.Internal.Desugar.HasExerciseByKey T (Party,
+                                                 Text) Revoke (()) where
+  _exerciseByKey = GHC.Types.primitive @"UExerciseByKey"
+instance DA.Internal.Desugar.HasKey T (Party, Text) where
+  key this@T {..}
+    = userWrittenTuple (sig this, ident this)
+    where
+        _ = this
+instance DA.Internal.Desugar.HasMaintainer T (Party, Text) where
+  _maintainer _ key
+    = DA.Internal.Desugar.toParties
+        ((DA.Internal.Record.getField @"_1" key))
+    where
+        _ = key
+instance DA.Internal.Desugar.HasFetchByKey T (Party, Text) where
+  fetchByKey = GHC.Types.primitive @"UFetchByKey"
+instance DA.Internal.Desugar.HasLookupByKey T (Party, Text) where
+  lookupByKey = GHC.Types.primitive @"ULookupByKey"
+instance DA.Internal.Desugar.HasToAnyContractKey T (Party,
+                                                    Text) where
+  _toAnyContractKey = GHC.Types.primitive @"EToAnyContractKey"
+instance DA.Internal.Desugar.HasFromAnyContractKey T (Party,
+                                                      Text) where
+  _fromAnyContractKey = GHC.Types.primitive @"EFromAnyContractKey"
+revokeRetVal : T -> ()
+revokeRetVal _ = ()
+assertion : T -> Bool
+assertion _ = True
+sig : T -> Party
+sig T {p} = p
+obs : T -> Party
+obs T {q} = q
+plainEnglish : T -> Text
+plainEnglish _ = "Chop wood, carry water."
+ident : T -> Text
+ident _ = "123"
diff --git a/sdk/compiler/damlc/tests/daml-test-files/UnusedMatchTestsWithKeys.daml b/sdk/compiler/damlc/tests/daml-test-files/UnusedMatchTestsWithKeys.daml
@@ -0,0 +1,55 @@
+-- Copyright (c) 2020, Digital Asset (Switzerland) GmbH and/or its
+-- affiliates. All rights reserved.
+
+-- @SUPPORTS-LF-FEATURE DAML_CONTRACT_KEYS
+-- @WARN range=20:3-20:4; Defined but not used
+
+{-# OPTIONS_GHC -Wunused-matches #-}
+{-# OPTIONS_GHC -Wunused-foralls #-}
+{-# OPTIONS_GHC -Wunused-imports #-}
+{-# OPTIONS_GHC -Wunused-pattern-binds #-}
+{-# OPTIONS_GHC -Wunused-top-binds #-}
+{-# OPTIONS_GHC -Wunused-type-patterns #-}
+-- We know this will fail and why.
+--   {-# OPTIONS_GHC -Wunused-local-binds #-}
+module UnusedMatchTestsWithKeys where
+
+-- It should be OK to enable -Wunused-* and not get warnings from
+-- template desugared code.
+
+f x = 12 -- Defined but not used 'x'; prove unused match detection.
+
+template T
+  with
+    p : Party
+    q : Party
+  where
+    -- None of the below should generate defined but not used
+    -- warnings.
+    signatory sig this
+    observer obs this
+    ensure assertion this
+    key (sig this, ident this): (Party, Text)
+    maintainer key._1
+    choice Revoke: () with
+      controller p
+      do
+        pure (revokeRetVal this)
+
+revokeRetVal : T -> ()
+revokeRetVal _ = ()
+
+assertion : T -> Bool
+assertion _ = True
+
+sig : T -> Party
+sig T {p} = p
+
+obs : T -> Party
+obs T {q} = q
+
+plainEnglish : T -> Text
+plainEnglish _ = "Chop wood, carry water."
+
+ident : T -> Text
+ident _ = "123"