Generic templates: support contract keys and fetchByKey (#1444)

* Generic templates: support contract keys and fetchByKey

`lookupByKey` will be done in a separate PR.

This is part of #1387.

* Run generic templates compatability test only for DAML-LF >= 1.4

daml-foundations/daml-ghc/ghc-compiler/src/DA/Daml/GHC/Compiler/Convert.hs

@@ -327,7 +327,7 @@ convertGenericTemplate :: Env -> GHC.Expr Var -> ConvertM (Template, LF.Expr)
 convertGenericTemplate env x
     | (dictCon, args) <- collectArgs x
     , (tyArgs, args) <- span isTypeArg args
-    , Just (superClassDicts, signatories : observers : ensure : agreement : create : fetch : archive : choices) <- span isSuperClassDict <$> mapM isVar_maybe (dropWhile isTypeArg args)
+    , Just (superClassDicts, signatories : observers : ensure : agreement : create : _fetch : archive : keyAndChoices) <- span isSuperClassDict <$> mapM isVar_maybe (dropWhile isTypeArg args)
     , Just (polyType, _) <- splitFunTy_maybe (varType create)
     , Just (monoTyCon, unwrapCo) <- findMonoTyp polyType
     = do
@@ -348,10 +348,29 @@ convertGenericTemplate env x
         tplObservers <- applyThis <$> convertExpr env (Var observers)
         let tplPrecondition = ETrue
         let tplAgreement = mkEmptyText
-        let tplKey = Nothing
         archive <- convertExpr env (Var archive)
+        (tplKey, key, choices) <- case keyAndChoices of
+                hasKey : key : maintainers : _fetchByKey : choices
+                    | TypeCon (Is "HasKey") _ <- varType hasKey -> do
+                        _ :-> keyType <- convertType env (varType key)
+                        hasKey <- convertExpr env (Var hasKey)
+                        key <- convertExpr env (Var key)
+                        maintainers <- convertExpr env (Var maintainers)
+                        let selfField = FieldName "contractId"
+                        let thisField = FieldName "contract"
+                        tupleTyCon <- qDA_Types env $ mkTypeCon ["Tuple2"]
+                        let tupleType = TypeConApp tupleTyCon [TContractId polyType, polyType]
+                        let fetchByKey =
+                                ETmLam (mkVar "key", keyType) $
+                                EUpdate $ UBind (Binding (res, TTuple [(selfField, TContractId monoType), (thisField, monoType)]) $ EUpdate $ UFetchByKey $ RetrieveByKey monoTyCon $ EVar $ mkVar "key") $
+                                EUpdate $ UPure (typeConAppToType tupleType) $ ERecCon tupleType
+                                    [ (FieldName "_1", unwrapCid $ ETupleProj selfField $ EVar res)
+                                    , (FieldName "_2", unwrapTpl $ ETupleProj thisField $ EVar res)
+                                    ]
+                        pure (Just $ TemplateKey keyType (applyThis key) (ETmApp maintainers hasKey), [hasKey, key, maintainers, fetchByKey], choices)
+                choices -> pure (Nothing, [], choices)
         let convertGenericChoice :: [Var] -> ConvertM (TemplateChoice, [LF.Expr])
-            convertGenericChoice [consumption, controllers, action, exercise] = do
+            convertGenericChoice [consumption, controllers, action, _exercise] = do
                 TContractId _ :-> _ :-> argType@(TConApp argTCon _) :-> TUpdate resType <- convertType env (varType action)
                 let chcLocation = Nothing
                 let chcName = ChoiceName $ T.intercalate "." $ unTypeConName $ qualObject argTCon
@@ -398,7 +417,7 @@ convertGenericTemplate env x
         dictCon <- convertExpr env dictCon
         tyArgs <- mapM (convertArg env) tyArgs
         -- NOTE(MH): The additional lambda is DICTIONARY SANITIZATION step (3).
-        let tmArgs = map (TmArg . ETmLam (mkVar "_", TUnit)) $ superClassDicts ++ [signatories, observers, ensure, agreement, create, fetch, archive] ++ concat choices
+        let tmArgs = map (TmArg . ETmLam (mkVar "_", TUnit)) $ superClassDicts ++ [signatories, observers, ensure, agreement, create, fetch, archive] ++ key ++ concat choices
         let dict = mkEApps dictCon $ tyArgs ++ tmArgs
         pure (Template{..}, dict)
   where
@@ -587,6 +606,26 @@ convertBind env (NonRec name x)
     | DFunId _ <- idDetails name
     , TypeCon (QIsTpl "Template") [t] <- varType name
     = withRange (convNameLoc name) $ liftA2 (++) (convertTemplate env x) (convertBind2 env (NonRec name x))
+    -- NOTE(MH, #1387): If we decide to do the rewriting of maintainers from
+    -- `this` to `key` for generic templates as well, this code will do
+    -- some part of the job. Currently, it would only work for non-generic
+    -- templates though.  I'd like to leave it here until we've made a
+    -- decision so I don't have to figure it out again.
+    -- | Just tplName <- stripPrefix "$dmmaintainerFromKey" (is name)
+    -- = do
+    --     name'@(_, splitTForalls -> (tvs, _dictType :-> hasKeyType :-> keyType :-> _)) <- convValWithType env name
+    --     key <- envFindBindString env ("$dmkey" ++ tplName)
+    --     maintainer <- envFindBindString env ("$dmmaintainer" ++ tplName)
+    --     case (key, maintainer) of
+    --       (Lam keyDict (Lam keyThis keyExpr), Lam maintainerDict (Lam maintainerThis maintainerExpr)) -> do
+    --         unless (keyDict == maintainerDict) $
+    --           unhandled "generic template key with different dict binders" (keyDict, maintainerDict)
+    --         keyExpr <- convertKeyExpr env keyThis keyExpr
+    --         maintainerExpr <- convertKeyExpr env maintainerThis maintainerExpr
+    --         maintainerExpr <- rewriteMaintainer env keyExpr maintainerExpr
+    --         maintainerDict <- convVarWithType env maintainerDict
+    --         pure [defValue name name' $ mkETyLams tvs $ mkETmLams [maintainerDict, (mkVar "_", hasKeyType), (mkVar "$key", keyType)] maintainerExpr]
+    --       _ -> unhandled "generic template key definition" name
     | DFunId _ <- idDetails name
     , TypeCon (Is tplInst) _ <- varType name
     , "Instance" `isSuffixOf` tplInst

daml-foundations/daml-ghc/tests/GenTemplCompat.daml

@@ -4,10 +4,13 @@
 -- Check that non-generic templates work with the new de/re-sugaring of
 -- templates for DAML-LF < 1.5 as well. This test can be deleted when
 -- generic templates (#1387) land in master.
+-- Since we need complex contract keys for this, it only works for
+-- DAML-LF >= 1.4.
+-- @SINCE-LF 1.4
 daml 1.2
 module GenTemplCompat where
 
-import Prelude hiding (Template (..), Choice (..), Archive (..), create, fetch, archive, exercise)
+import Prelude hiding (Template (..), TemplateKey (..), Choice (..), Archive (..), create, fetch, fetchByKey, archive, exercise)
 import DA.Assert
 import GenericTemplates
 
@@ -26,6 +29,10 @@ instance FactInstance => Template Fact where
     fetch = fetchFact
     archive = archiveFact
 
+instance FactInstance => TemplateKey Fact (Party, Text) where
+    key = keyFact
+    fetchByKey = fetchByKeyFact
+
 instance FactInstance => Choice Fact Archive () where
     exercise = exerciseFactArchive
 
@@ -58,6 +65,15 @@ class FactInstance where
     archiveFact : ContractId Fact -> Update ()
     archiveFact cid = exerciseFactArchive cid Archive
 
+    hasKeyFact : HasKey Fact
+    hasKeyFact = HasKey
+    keyFact : Fact -> (Party, Text)
+    keyFact this@Fact{..} = (owner, name)
+    maintainerFact : HasKey Fact -> (Party, Text) -> [Party]
+    maintainerFact HasKey key = [fst key]
+    fetchByKeyFact : (Party, Text) -> Update (ContractId Fact, Fact)
+    fetchByKeyFact = error "code will be injected by the compiler"
+
     consumptionFactArchive : PreConsuming Fact
     consumptionFactArchive = PreConsuming
     controllerFactArchive : Fact -> Archive -> [Party]
@@ -95,11 +111,14 @@ test = scenario do
     alice <- getParty "Alice"
     let fact = Fact with owner = alice; name = "Answer"; value = 42
 
-    -- Check that create, fetch and exercising non- and pre-consuming choices work.
+    -- Check that create, fetch, fetchByKey and exercising non- and pre-consuming choices work.
     factId <- submit alice do create fact
     submit alice do exercise factId Touch
     fact' <- submit alice do fetch factId
     fact' === fact
+    (factId', fact') <- submit alice do fetchByKey @Fact (alice, "Answer")
+    factId' === factId
+    fact' === fact
     submit alice do archive factId
     submitMustFail alice do fetch factId
 

daml-foundations/daml-ghc/tests/GenericTemplates.daml

@@ -7,7 +7,7 @@
 daml 1.2
 module GenericTemplates where
 
-import Prelude hiding (Template (..), Choice (..), Archive (..), create, fetch, archive, exercise)
+import Prelude hiding (Template (..), TemplateKey (..), Choice (..), Archive (..), create, fetch, fetchByKey, archive, exercise)
 
 class Template t where
   signatory : t -> [Party]
@@ -18,6 +18,11 @@ class Template t where
   fetch : ContractId t -> Update t
   archive : ContractId t -> Update ()
 
+class Template t => TemplateKey t k | t -> k where
+  key : t -> k
+  fetchByKey : k -> Update (ContractId t, t)
+
+
 class Template t => Choice t c r | t c -> r where
   exercise : ContractId t -> c -> Update r
 
@@ -29,3 +34,5 @@ data NonConsuming t = NonConsuming {}
 data PreConsuming t = PreConsuming {}
 
 data PostConsuming t = PostConsuming {}
+
+data HasKey t = HasKey {}

daml-foundations/daml-ghc/tests/IouDSL.daml

@@ -6,7 +6,8 @@
 daml 1.2
 module IouDSL where
 
-import Prelude hiding (Template (..), Choice (..), Archive (..), create, fetch, archive, exercise)
+import Prelude hiding (Template (..), TemplateKey (..), Choice (..), Archive (..), create, fetch, fetchByKey, archive, exercise)
+import DA.Assert
 import GenericTemplates
 import ProposalDSL
 
@@ -86,12 +87,17 @@ test = scenario do
   alice <- getParty "alice"
   bank <- getParty "bank"
   let iou = Iou with issuer = bank; owner = alice; amount = 10.0
+  let prop = Proposal with asset = iou; receivers = [alice]; name = "present"
   propId <- submit bank do
-    create Proposal with asset = iou; receivers = [alice]
+    create prop
+  (propId', prop') <- submit bank do
+    fetchByKey @(Proposal Iou) ([bank], "present")
+  propId' === propId
+  prop' === prop
   iouId <- submit alice do
     exercise propId Accept
   iou' <- submit alice do
     fetch iouId
-  assert $ iou' == iou
+  iou' === iou
   submit alice do
     exercise iouId Burn

daml-foundations/daml-ghc/tests/ProposalDSL.daml

@@ -11,7 +11,7 @@ module ProposalDSL
   , ProposalInstance
   ) where
 
-import Prelude hiding (Template (..), Choice (..), Archive (..), create, fetch, archive, exercise)
+import Prelude hiding (Template (..), TemplateKey (..), Choice (..), Archive (..), create, fetch, fetchByKey, archive, exercise)
 import DA.List
 import DA.Text
 import GenericTemplates
@@ -20,6 +20,7 @@ import GenericTemplates
 data Proposal t = Proposal with
     asset : t
     receivers : [Party]
+    name : Text
   deriving (Eq, Show)
 
 instance ProposalInstance t => Template (Proposal t) where
@@ -31,6 +32,10 @@ instance ProposalInstance t => Template (Proposal t) where
     fetch = fetchProposal
     archive = archiveProposal
 
+instance ProposalInstance t => TemplateKey (Proposal t) ([Party], Text) where
+    key = keyProposal
+    fetchByKey = fetchByKeyProposal
+
 
 data Accept = Accept{}
   deriving (Eq, Show)
@@ -62,6 +67,15 @@ class Template t => ProposalInstance t where
     archiveProposal : ContractId (Proposal t) -> Update ()
     archiveProposal cid = exerciseProposalArchive cid Archive
 
+    hasKeyProposal : HasKey (Proposal t)
+    hasKeyProposal = HasKey
+    keyProposal : Proposal t -> ([Party], Text)
+    keyProposal this@Proposal{..} = (signatory this, name)
+    maintainerProposal : HasKey (Proposal t) -> ([Party], Text) -> [Party]
+    maintainerProposal HasKey key = fst key
+    fetchByKeyProposal : ([Party], Text) -> Update (ContractId (Proposal t), Proposal t)
+    fetchByKeyProposal = error "code will be injected by the compiler"
+
     consumptionProposalArchive : PreConsuming (Proposal t)
     consumptionProposalArchive = PreConsuming
     controllerProposalArchive : Proposal t -> Archive -> [Party]