Generic templates: support ensure and agreement clauses (#1411)

I don't add tests since they will all become useless once we desugar the
surface syntax to the new type class representation. At this point all
existing tests will kick in.

This is part of #1387.

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

@@ -331,7 +331,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 : create : fetch : choices) <- span isSuperClassDict <$> mapM isVar_maybe (dropWhile isTypeArg args)
+    , Just (superClassDicts, signatories : observers : ensure : agreement : create : fetch : choices) <- span isSuperClassDict <$> mapM isVar_maybe (dropWhile isTypeArg args)
     , Just (polyType, _) <- splitFunTy_maybe (varType create)
     , Just (monoTyCon, unwrapCo) <- findMonoTyp polyType
     = do
@@ -373,12 +373,14 @@ convertGenericTemplate env x
         superClassDicts <- mapM (convertExpr env . Var) superClassDicts
         signatories <- convertExpr env (Var signatories)
         observers <- convertExpr env (Var observers)
+        ensure <- convertExpr env (Var ensure)
+        agreement <- convertExpr env (Var agreement)
         let create = ETmLam (this, polyType) $ EUpdate $ UBind (Binding (self, TContractId monoType) $ EUpdate $ UCreate monoTyCon $ wrapTpl $ EVar this) $ EUpdate $ UPure (TContractId polyType) $ unwrapSelf
         let fetch = ETmLam (self, TContractId polyType) $ EUpdate $ UBind (Binding (this, monoType) $ EUpdate $ UFetch monoTyCon wrapSelf) $ EUpdate $ UPure polyType $ unwrapTpl $ EVar this
         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, create, fetch] ++ concat choices
+        let tmArgs = map (TmArg . ETmLam (mkVar "_", TUnit)) $ superClassDicts ++ [signatories, observers, ensure, agreement, create, fetch] ++ concat choices
         let dict = mkEApps dictCon $ tyArgs ++ tmArgs
         pure (Template{..}, dict)
   where

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

@@ -12,6 +12,8 @@ import Prelude hiding (Template (..), Choice (..), create, fetch, exercise)
 class Template t where
   signatory : t -> [Party]
   observer : t -> [Party]
+  ensure : t -> Bool
+  agreement : t -> Text
   create : t -> Update (ContractId t)
   fetch : ContractId t -> Update t
 

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

@@ -20,6 +20,8 @@ data Iou = Iou with
 instance IouInstance => Template Iou where
   signatory = signatoryIou
   observer = observerIou
+  ensure = ensureIou
+  agreement = agreementIou
   create = createIou
   fetch = fetchIou
 
@@ -34,6 +36,11 @@ class IouInstance where
   signatoryIou this@Iou{..} = [issuer, owner]
   observerIou : Iou -> [Party]
   observerIou this@Iou{..} = []
+  ensureIou : Iou -> Bool
+  ensureIou this@Iou{..} = amount > 0.0
+  agreementIou : Iou -> Text
+  agreementIou this@Iou{..} =
+      show issuer <> " owns " <> show owner <> " CHF " <> show amount
   createIou : Iou -> Update (ContractId Iou)
   createIou = error "code will be injected by the compiler"
   fetchIou : ContractId Iou -> Update Iou

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

@@ -13,6 +13,7 @@ module ProposalDSL
 
 import Prelude hiding (Template (..), Choice (..), create, fetch, exercise)
 import DA.List
+import DA.Text
 import GenericTemplates
 
 
@@ -24,11 +25,12 @@ data Proposal t = Proposal with
 instance ProposalInstance t => Template (Proposal t) where
     signatory = signatoryProposal
     observer = observerProposal
+    ensure = ensureProposal
+    agreement = agreementProposal
     create = createProposal
     fetch = fetchProposal
 
 
-
 data Accept = Accept{}
   deriving (Eq, Show)
 
@@ -41,6 +43,15 @@ class Template t => ProposalInstance t where
     signatoryProposal this@Proposal{..} = signatory asset \\ receivers
     observerProposal : Proposal t -> [Party]
     observerProposal this@Proposal{..} = receivers
+    ensureProposal : Proposal t -> Bool
+    ensureProposal this@Proposal{..} = True
+    agreementProposal : Proposal t -> Text
+    agreementProposal this@Proposal{..} = implode
+        [ "Proposal:\n"
+        , "* proposers: " <> show (signatory this) <> "\n"
+        , "* receivers: " <> show receivers <> "\n"
+        , "* agreement: " <> agreement asset
+        ]
     createProposal : Proposal t -> Update (ContractId (Proposal t))
     createProposal = error "code will be injected by the compiler"
     fetchProposal : ContractId (Proposal t) -> Update (Proposal t)