Support generic templates (digital-asset#2465)

* Upgrade ghc-libs supporting generic templates * Update Proposal and ComposedKey tests to generic template syntax * Temporarily patch daml-doc test output (will need to fix for template instances)
iggy-da · Aug 9, 2019 · c2f315d · c2f315d
1 parent a156880
commit c2f315d
Show file tree

Hide file tree

Showing 11 changed files with 72 additions and 199 deletions.
diff --git a/3rdparty/haskell/BUILD.ghc-lib-parser b/3rdparty/haskell/BUILD.ghc-lib-parser
@@ -52,7 +52,7 @@ haskell_library(
     "-I/compiler", "-I/compiler/utils"
   ],
   package_name = "ghc-lib-parser",
-  version = "8.8.0.20190730.1",
+  version = "8.8.0.20190809",
 )
 
 cc_library(

diff --git a/WORKSPACE b/WORKSPACE
@@ -464,12 +464,12 @@ HASKELL_LSP_COMMIT = "bfbd8630504ebc57b70948689c37b85cfbe589da"
 
 HASKELL_LSP_HASH = "a301d9409c3a19a042bdf5763611c6a60af5cbc1ff0f281acbc19b3ee70dde5f"
 
-GHC_LIB_VERSION = "8.8.0.20190730.1"
+GHC_LIB_VERSION = "8.8.0.20190809"
 
 http_archive(
     name = "haskell_ghc__lib__parser",
     build_file = "//3rdparty/haskell:BUILD.ghc-lib-parser",
-    sha256 = "dcd211cac831609cec546050b342ca94a546cb4e672cf2819189332f49361baf",
+    sha256 = "8d7774dc830d8e27d20ce0a4f039fcfdf440a3332f2dfce3716743ea30e3589e",
     strip_prefix = "ghc-lib-parser-{}".format(GHC_LIB_VERSION),
     urls = ["https://digitalassetsdk.bintray.com/ghc-lib/ghc-lib-parser-{}.tar.gz".format(GHC_LIB_VERSION)],
 )
@@ -519,7 +519,7 @@ hazel_repositories(
 
             # Read [Working on ghc-lib] for ghc-lib update instructions at
             # https://github.com/DACH-NY/daml/blob/master/ghc-lib/working-on-ghc-lib.md.
-            hazel_ghclibs(GHC_LIB_VERSION, "dcd211cac831609cec546050b342ca94a546cb4e672cf2819189332f49361baf", "6e144d99bc43e861a2895e0c34d73964305db2ad634f14d3e3a41cf0c4523495") +
+            hazel_ghclibs(GHC_LIB_VERSION, "8d7774dc830d8e27d20ce0a4f039fcfdf440a3332f2dfce3716743ea30e3589e", "0a0231b5d98ea60d9987b8b46fd911d7d183b9c4b7e0513640c54515a5de7362") +
 
             # Support for Hlint:
             #   - Requires haskell-src-exts 1.21.0 so override hazel/packages.bzl.

diff --git a/compiler/damlc/tests/daml-test-files/ComposedKey.daml b/compiler/damlc/tests/daml-test-files/ComposedKey.daml
@@ -24,94 +24,32 @@ template Fact with
 
 
 -- For any instantiation, `k` has to be the key type of `t`.
-data Proposal t k = Proposal with
+template (Template t, TemplateKey t k) => Proposal t k with
     asset : t
     proposers : [Party]
     receivers : [Party]
-  deriving (Eq, Show)
-
-instance ProposalInstance t k => Template (Proposal t k) where
-    signatory = _signatoryProposal
-    observer = _observerProposal
-    ensure = _ensureProposal
-    agreement = _agreementProposal
-    create = _createProposal
-    fetch = _fetchProposal
-    archive = _archiveProposal
-
-instance ProposalInstance t k => TemplateKey (Proposal t k) ([Party], k) where
-    key = _keyProposal
-    fetchByKey = _fetchByKeyProposal
-    lookupByKey = _lookupByKeyProposal
-
-data Accept = Accept{}
-  deriving (Eq, Show)
-
-instance ProposalInstance t k => Choice (Proposal t k) Accept (ContractId t) where
-    exercise = _exerciseProposalAccept
-
-instance ProposalInstance t k => Choice (Proposal t k) Archive () where
-    exercise = _exerciseProposalArchive
-
-class (Template t, TemplateKey t k) => ProposalInstance t k where
-    _signatoryProposal : Proposal t k -> [Party]
-    _signatoryProposal this@Proposal{..} = proposers
-    _observerProposal : Proposal t k -> [Party]
-    _observerProposal this@Proposal{..} = receivers
-    _ensureProposal : Proposal t k -> Bool
-    _ensureProposal this@Proposal{..} =
+  where
+    signatory proposers
+    observer receivers
+    ensure
         let authorizers = proposers ++ receivers
         in all (`elem` authorizers) (signatory asset)
-    _agreementProposal : Proposal t k -> Text
-    _agreementProposal this@Proposal{..} = unlines
+    agreement unlines
         [ "Proposal:"
         , "* proposers: " <> show proposers
         , "* receivers: " <> show receivers
         , "* agreement: " <> agreement asset
         ]
-    _createProposal : Proposal t k -> Update (ContractId (Proposal t k))
-    _createProposal = error "code will be injected by the compiler"
-    _fetchProposal : ContractId (Proposal t k) -> Update (Proposal t k)
-    _fetchProposal = error "code will be injected by the compiler"
-    _archiveProposal : ContractId (Proposal t k) -> Update ()
-    _archiveProposal cid = _exerciseProposalArchive cid Archive
-
-    _hasKeyProposal : HasKey (Proposal t k)
-    _hasKeyProposal = HasKey
-    _keyProposal : Proposal t k -> ([Party], k)
-    _keyProposal this@Proposal{..} = (proposers, key asset)
-    _maintainerProposal : HasKey (Proposal t k) -> ([Party], k) -> [Party]
-    _maintainerProposal HasKey key = fst key
-    _fetchByKeyProposal : ([Party], k) -> Update (ContractId (Proposal t k), Proposal t k)
-    _fetchByKeyProposal = error "code will be injected by the compiler"
-    _lookupByKeyProposal : ([Party], k) -> Update (Optional (ContractId (Proposal t k)))
-    _lookupByKeyProposal = error "code will be injected by the compiler"
 
-    _consumptionProposalArchive : PreConsuming (Proposal t k)
-    _consumptionProposalArchive = PreConsuming
-    _controllerProposalArchive : Proposal t k -> Archive -> [Party]
-    _controllerProposalArchive this@Proposal{..} arg@Archive = _signatoryProposal this
-    _actionProposalArchive : ContractId (Proposal t k) -> Proposal t k -> Archive -> Update ()
-    _actionProposalArchive self this@Proposal{..} arg@Archive = do
-        pure ()
-    _exerciseProposalArchive : ContractId (Proposal t k) -> Archive -> Update ()
-    _exerciseProposalArchive = error "code will be injected by the compiler"
-
-    _consumptionProposalAccept : PreConsuming (Proposal t k)
-    _consumptionProposalAccept = PreConsuming
-    _controllerProposalAccept : Proposal t k -> Accept -> [Party]
-    _controllerProposalAccept this@Proposal{..} arg@Accept = receivers
-    _actionProposalAccept : ContractId (Proposal t k) -> Proposal t k -> Accept -> Update (ContractId t)
-    _actionProposalAccept self this@Proposal{..} arg@Accept = do
-        create asset
-    _exerciseProposalAccept : ContractId (Proposal t k) -> Accept -> Update (ContractId t)
-    _exerciseProposalAccept = error "code will be injected by the compiler"
+    key (proposers, key asset) : ([Party], k)
+    maintainer (fst key)
 
+    controller receivers can
+      Accept : ContractId t
+        do create asset
 
 -- The instantiation of the generic proposal workflow for `Iou`.
-newtype ProposalFact = MkProposalFact with unProposalFact : Proposal Fact (Party, Text)
-
-instance ProposalInstance Fact (Party, Text) where
+template instance ProposalFact = Proposal Fact (Party, Text)
 
 test = scenario do
     alice <- getParty "Alice"

diff --git a/...s/daml-test-files/ProposalDSL.EXPECTED.md → ...ests/daml-test-files/Proposal.EXPECTED.md b/...s/daml-test-files/ProposalDSL.EXPECTED.md → ...ests/daml-test-files/Proposal.EXPECTED.md
@@ -1,8 +1,8 @@
-# <a name="module-proposaldsl-55246"></a>Module ProposalDSL
+# <a name="module-proposal-60338"></a>Module Proposal
 
 ## Templates
 
-<a name="type-proposaldsl-proposal-65892"></a>**template** Template t =\> [Proposal](#type-proposaldsl-proposal-65892) t
+<a name="type-proposal-proposal-1384"></a>**template** Template t =\> [Proposal](#type-proposal-proposal-1384) t
 
 > | Field     | Type      | Description |
 > | :-------- | :-------- | :---------- |

diff --git a/.../daml-test-files/ProposalDSL.EXPECTED.rst → ...sts/daml-test-files/Proposal.EXPECTED.rst b/.../daml-test-files/ProposalDSL.EXPECTED.rst → ...sts/daml-test-files/Proposal.EXPECTED.rst
@@ -1,14 +1,14 @@
-.. _module-proposaldsl-55246:
+.. _module-proposal-60338:
 
-Module ProposalDSL
-------------------
+Module Proposal
+---------------
 
 Templates
 ^^^^^^^^^
 
-.. _type-proposaldsl-proposal-65892:
+.. _type-proposal-proposal-1384:
 
-**template** Template t => `Proposal <type-proposaldsl-proposal-65892_>`_ t
+**template** Template t => `Proposal <type-proposal-proposal-1384_>`_ t
 
   .. list-table::
      :widths: 15 10 30

diff --git a/compiler/damlc/tests/daml-test-files/Proposal.daml b/compiler/damlc/tests/daml-test-files/Proposal.daml
@@ -0,0 +1,33 @@
+-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
+-- SPDX-License-Identifier: Apache-2.0
+
+-- A generic proposal workflow using generic templates. This is not tested
+-- itself but imported in the `ProposalIou` test.
+-- @SINCE-LF 1.5
+daml 1.2
+module Proposal where
+
+import DA.List
+import DA.Text
+
+template Template t => Proposal t
+  with
+    asset : t
+    receivers : [Party]
+    name : Text
+  where
+    signatory (signatory asset \\ receivers)
+    observer receivers
+    agreement implode
+        [ "Proposal:\n"
+        , "* proposers: " <> show (signatory this) <> "\n"
+        , "* receivers: " <> show receivers <> "\n"
+        , "* agreement: " <> agreement asset
+        ]
+
+    key (signatory this, name) : ([Party], Text)
+    maintainer (fst key)
+
+    controller receivers can
+      Accept : ContractId t
+        do create asset
diff --git a/compiler/damlc/tests/daml-test-files/ProposalDSL.daml b/compiler/damlc/tests/daml-test-files/ProposalDSL.daml
diff --git a/compiler/damlc/tests/daml-test-files/ProposalIou.EXPECTED.md b/compiler/damlc/tests/daml-test-files/ProposalIou.EXPECTED.md
@@ -18,8 +18,9 @@
 >   
 >   (no fields)
 
-## Template Instances
+## Data Types
 
-<a name="type-proposaliou-proposaliou-81988"></a>**template instance** [ProposalIou](#type-proposaliou-proposaliou-81988)
+<a name="type-proposaliou-proposaliou-81988"></a>**data** [ProposalIou](#type-proposaliou-proposaliou-81988)
 
-> = Proposal [Iou](#type-proposaliou-iou-51326)
+> <a name="constr-proposaliou-proposaliou-48383"></a>[ProposalIou](#constr-proposaliou-proposaliou-48383) (Proposal [Iou](#type-proposaliou-iou-51326))
+> 
diff --git a/compiler/damlc/tests/daml-test-files/ProposalIou.EXPECTED.rst b/compiler/damlc/tests/daml-test-files/ProposalIou.EXPECTED.rst
@@ -33,10 +33,14 @@ Templates
   + **Choice Burn**
 
 
-Template Instances
-^^^^^^^^^^^^^^^^^^
+Data Types
+^^^^^^^^^^
 
 .. _type-proposaliou-proposaliou-81988:
 
-**template instance** `ProposalIou <type-proposaliou-proposaliou-81988_>`_
-  = Proposal `Iou <type-proposaliou-iou-51326_>`_
+**data** `ProposalIou <type-proposaliou-proposaliou-81988_>`_
+
+  .. _constr-proposaliou-proposaliou-48383:
+
+  `ProposalIou <constr-proposaliou-proposaliou-48383_>`_ (Proposal `Iou <type-proposaliou-iou-51326_>`_)
+
diff --git a/compiler/damlc/tests/daml-test-files/ProposalIou.daml b/compiler/damlc/tests/daml-test-files/ProposalIou.daml
@@ -7,8 +7,7 @@ daml 1.2
 module ProposalIou where
 
 import DA.Assert
-import ProposalDSL
-
+import Proposal
 
 template Iou with
     issuer : Party
@@ -24,12 +23,8 @@ template Iou with
       do
         pure ()
 
-
 -- The instantiation of the generic proposal workflow for `Iou`.
-newtype ProposalIou = MkProposalIou with unProposalIou : Proposal Iou -- ^ TEMPLATE_INSTANCE
-
-instance ProposalInstance Iou where
-
+template instance ProposalIou = Proposal Iou
 
 -- A scenario.
 test = scenario do
@@ -47,7 +42,7 @@ test = scenario do
     lookupByKey @(Proposal Iou) ([bank], "present")
   mbPropId === Some propId
   iouId <- submit alice do
-    exercise propId Accept
+    exercise propId (Accept @Iou)
   iou' <- submit alice do
     fetch iouId
   iou' === iou

diff --git a/unreleased.rst b/unreleased.rst
@@ -14,3 +14,4 @@ HEAD — ongoing
   with relative paths in ``daml build``.
 + [Ledger] Fixed internal shutdown order to avoid dead letter warnings when stopping Sandbox/Ledger API Server.
   See issue `#1886 <https://github.com/digital-asset/daml/issues/1886>`__.
++ [DAML Compiler] Support generic template declarations and instances.