digital-asset/daml
1
1
Fork 0
mirror of https://github.com/digital-asset/daml.git synced 2024-09-20 01:07:18 +03:00
Code Issues Projects Releases Wiki Activity

New template desugaring (#2178)

Browse Source 
* Update ghc-libs to use new template desugaring
* Replace old template typeclasses with generic-friendly ones
* New template desugaring doc
* Fix tests
* Fix damldoc tests regarding Archive choice
* Update visualisation code to not traverse master dictionary
* Additional class method stubs to template instance declaration for upgrades
* Increase stack limit for bond trading compilation test
* Update hlint version
This commit is contained in:
Rohan Jacob-Rao 2019-07-30 19:49:33 -04:00 committed by GitHub
parent b3dac78e66
commit e6a4d8b251
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
28 changed files with 581 additions and 566 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
3rdparty/haskell/BUILD.ghc-lib-parser vendored
View File

@ -52,7 +52,7 @@ haskell_library(
"-I/compiler", "-I/compiler/utils"
],
package_name = "ghc-lib-parser",
version = "8.8.0.20190723",
version = "8.8.0.20190730.1",
)
cc_library(

11
WORKSPACE
View File

@ -464,12 +464,12 @@ HASKELL_LSP_COMMIT = "d73e2ccb518724e6766833ee3d7e73289cbe0018"
HASKELL_LSP_HASH = "36b92431039e6289eb709b8872f5010a57d4a45e637e1c1c945bdb3128586081"
GHC_LIB_VERSION = "8.8.0.20190723"
GHC_LIB_VERSION = "8.8.0.20190730.1"
http_archive(
name = "haskell_ghc__lib__parser",
build_file = "//3rdparty/haskell:BUILD.ghc-lib-parser",
sha256 = "139c5b58d179a806640f8b56bc3fe8c70a893191dbfd111a593544e7ac71086b",
sha256 = "dcd211cac831609cec546050b342ca94a546cb4e672cf2819189332f49361baf",
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)],
)
@ -517,10 +517,9 @@ hazel_repositories(
packages = add_extra_packages(
extra =
# Read [Working on ghc-lib] for ghc-lib update
# instructions at
# 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, "139c5b58d179a806640f8b56bc3fe8c70a893191dbfd111a593544e7ac71086b", "7cfbe3bd12fb38685b86096ad666790326020308138eaf49198631b8792f5b2a") +
hazel_ghclibs(GHC_LIB_VERSION, "dcd211cac831609cec546050b342ca94a546cb4e672cf2819189332f49361baf", "6e144d99bc43e861a2895e0c34d73964305db2ad634f14d3e3a41cf0c4523495") +
# Support for Hlint:
# - Requires haskell-src-exts 1.21.0 so override hazel/packages.bzl.
@ -528,7 +527,7 @@ hazel_repositories(
# - To build the library : `bazel build @haskell_hlint//:lib`
# We'll be using it via the library, not the binary.
hazel_hackage("haskell-src-exts", "1.21.0", "95dac187824edfa23b6a2363880b5e113df8ce4a641e8a0f76e6d45aaa699ff3") +
hazel_github_external("digital-asset", "hlint", "b007fb1f9acfb1342af57d07c96149235e105b50", "61fdbd214a101653ac21cfdfd7da34e4ad4dacfe74dc841dbd782622213bff57") +
hazel_github_external("digital-asset", "hlint", "f3d3acad10c9a4418a6fcad002087fc527f15d3d", "dbd091a6d59bf2d3cc387ab4a0ffc50ffad3242b808e7205ccceef49aed682f8") +
hazel_github_external("awakesecurity", "proto3-wire", "43d8220dbc64ef7cc7681887741833a47b61070f", "1c3a7fbf4ab3308776675c6202583f9750de496757f3ad4815e81edd122d75e1") +
hazel_github_external("awakesecurity", "proto3-suite", "dd01df7a3f6d0f1ea36125a67ac3c16936b53da0", "59ea7b876b14991347918eefefe24e7f0e064b5c2cc14574ac4ab5d6af6413ca") +
hazel_hackage("happy", "1.19.10", "22eb606c97105b396e1c7dc27e120ca02025a87f3e44d2ea52be6a653a52caed") +

132
compiler/damlc/daml-compiler/src/DA/Daml/Compiler/Upgrade.hs
View File

@ -231,7 +231,6 @@ generateSrcFromLf (Qualify qualify) thisPkgId pkgMap m = noLoc mod
noLoc $
mkRdrQual (mkModuleName "DA.Internal.Template") $
mkOccName varName "Template" :: LHsType GhcPs
sigRdrName = noLoc $ mkRdrUnqual $ mkOccName varName "signatory"
errTooManyNameComponents cs =
error $
"Internal error: Dalf contains type constructors with more than two name components: " <>
@ -244,6 +243,71 @@ generateSrcFromLf (Qualify qualify) thisPkgId pkgMap m = noLoc mod
, length dataTyCon == 2
, LF.DataRecord fs <- [dataCons]
]
templateMethodNames =
map mkRdrName
[ "signatory"
, "observer"
, "agreement"
, "fetch"
, "ensure"
, "create"
, "archive"
]
classMethodStub :: Located RdrName -> LHsBindLR GhcPs GhcPs
classMethodStub funName =
noLoc $
FunBind
{ fun_ext = noExt
, fun_id = funName
, fun_matches =
MG
{ mg_ext = noExt
, mg_alts =
noLoc
[ noLoc $
Match
{ m_ext = noExt
, m_ctxt =
FunRhs
{ mc_fun = funName
, mc_fixity = Prefix
, mc_strictness = NoSrcStrict
}
, m_pats = []
, m_rhs_sig = Nothing
, m_grhss =
GRHSs
{ grhssExt = noExt
, grhssGRHSs =
[ noLoc $
GRHS
noExt
[]
(noLoc $
HsApp
noExt
(noLoc $
HsVar
noExt
(noLoc
error_RDR))
(noLoc $
HsLit noExt $
HsString
NoSourceText $
mkFastString
"undefined template class method in generated code"))
]
, grhssLocalBinds =
noLoc emptyLocalBinds
}
}
]
, mg_origin = Generated
}
, fun_co_fn = WpHole
, fun_tick = []
}
decls =
concat $ do
LF.DefDataType {..} <- NM.toList $ LF.moduleDataTypes m
@ -303,71 +367,7 @@ generateSrcFromLf (Qualify qualify) thisPkgId pkgMap m = noLoc mod
HsAppTy noExt templateTy $
noLoc $ convType templType
}
, cid_binds =
listToBag
[ noLoc $
FunBind
{ fun_ext = noExt
, fun_id = sigRdrName
, fun_matches =
MG
{ mg_ext = noExt
, mg_alts =
noLoc
[ noLoc $
Match
{ m_ext =
noExt
, m_ctxt =
FunRhs
{ mc_fun =
sigRdrName
, mc_fixity =
Prefix
, mc_strictness =
NoSrcStrict
}
, m_pats = []
, m_rhs_sig =
Nothing
, m_grhss =
GRHSs
{ grhssExt =
noExt
, grhssGRHSs =
[ noLoc $
GRHS
noExt
[
]
(noLoc $
HsApp
noExt
(noLoc $
HsVar
noExt
(noLoc
error_RDR))
(noLoc $
HsLit
noExt $
HsString
NoSourceText $
mkFastString
"undefined template class method in generated code"))
]
, grhssLocalBinds =
noLoc
emptyLocalBinds
}
}
]
, mg_origin = Generated
}
, fun_co_fn = WpHole
, fun_tick = []
}
]
, cid_binds = listToBag $ map classMethodStub templateMethodNames
, cid_sigs = []
, cid_tyfam_insts = []
, cid_datafam_insts = []

7
compiler/damlc/daml-doc/test/DA/Daml/GHC/Damldoc/Tests.hs
View File

@ -153,7 +153,7 @@ unitTests =
check $ isNothing $ td_descr t
f1 <- getSingle $ td_payload t
check $ isNothing $ fd_descr f1
ch <- getSingle $ td_choices t
ch <- getSingle $ td_choicesWithoutArchive t
f2 <- getSingle $ cd_fields ch
check $ Just "field" == fd_descr f2))
@ -177,7 +177,7 @@ unitTests =
("Expected two choices in doc, got " <> show md)
(isJust $ do t <- getSingle $ md_templates md
check $ isNothing $ td_descr t
cs <- Just $ td_choices t
cs <- Just $ td_choicesWithoutArchive t
check $ length cs == 2
check $ ["DoMore", "DoSomething"] == sort (map cd_name cs)))
@ -208,6 +208,9 @@ unitTests =
check True = Just ()
check False = Nothing
td_choicesWithoutArchive :: TemplateDoc -> [ChoiceDoc]
td_choicesWithoutArchive = filter (\ch -> cd_name ch /= "External:Archive") . td_choices
testModule :: String
testModule = "Testfile"

4
compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs
View File

@ -345,8 +345,8 @@ convertGenericTemplate env x
let applyThis e = ETmApp e $ unwrapTpl $ EVar this
tplSignatories <- applyThis <$> convertExpr env (Var signatories)
tplObservers <- applyThis <$> convertExpr env (Var observers)
let tplPrecondition = ETrue
let tplAgreement = mkEmptyText
tplPrecondition <- applyThis <$> convertExpr env (Var ensure)
tplAgreement <- applyThis <$> convertExpr env (Var agreement)
archive <- convertExpr env (Var archive)
(tplKey, key, choices) <- case keyAndChoices of
hasKey : key : maintainers : _fetchByKey : _lookupByKey : choices

13
compiler/damlc/daml-stdlib-src/DA/Internal/Desugar.daml
View File

@ -7,14 +7,13 @@ daml 1.2
-- | Automatically imported qualified in every module.
module DA.Internal.Desugar (
concat,
Template(ensure, signatory, observer, agreement),
TemplateKey(key, maintainer),
Choice(consuming, choiceController, choice), preconsuming, nonconsuming, postconsuming, NoEvent(..),
IsParties(toParties),
Eq(..),
Show(..)
module DA.Internal.Template,
Eq(..), Show(..),
Bool(..), Text, Optional,
concat, magic,
Party, ContractId, Update
) where
import DA.Internal.Prelude
import DA.Internal.Template
import DA.Internal.LF

2
compiler/damlc/daml-stdlib-src/DA/Internal/LF.daml
View File

@ -38,7 +38,7 @@ module DA.Internal.LF
, unpackPair
) where
import GHC.Types (Opaque, Symbol, magic)
import GHC.Types (Opaque, Symbol)
import DA.Internal.Prelude
-- | The `Party` type represents a party to a contract.

2
compiler/damlc/daml-stdlib-src/DA/Internal/Prelude.daml
View File

@ -23,7 +23,7 @@ import GHC.Real as GHC (fromRational)
import GHC.Show as GHC
import DA.Types as GHC (Either(..))
import GHC.Tuple()
import GHC.Types as GHC (Bool (..), Int, Ordering (..), Text, Decimal, ifThenElse, primitive)
import GHC.Types as GHC (Bool (..), Int, Ordering (..), Text, Decimal, ifThenElse, primitive, magic)
infixr 0 $
-- | Take a function from `a` to `b` and a value of type `a`, and apply the

217
compiler/damlc/daml-stdlib-src/DA/Internal/Template.daml
View File

@ -6,161 +6,97 @@
daml 1.2
-- | MOVE Prelude DAML-LF primitives, just templates/contracts
module DA.Internal.Template(
Template(ensure, signatory, observer, agreement),
Choice(consuming, choiceController, choice), preconsuming, nonconsuming, postconsuming, NoEvent(..),
stakeholder,
create, exercise, fetch,
archive, Archive(..),
lookupByKey, fetchByKey, exerciseByKey,
IsParties(toParties),
TemplateKey(key, maintainer)
) where
module DA.Internal.Template where
import GHC.Types (magic)
import DA.Internal.LF
import DA.Internal.Prelude
-- NOTE: use internalCreate vs create so that people implementing Template can't override create/fetch/exercise
class Template t where
-- | Create a contract based on a template `c`.
create : Template c => c -> Update (ContractId c)
create = internalCreate
-- | The signatories of a contract.
signatory : t -> [Party]
-- | Exercise a choice on the contract with the given contract ID.
exercise : forall c e r . Choice c e r => ContractId c -> e -> Update r
exercise = internalExercise
-- | The observers of a contract.
observer : t -> [Party]
-- | Fetch the contract data associated with the given contract ID.
--
-- If the `ContractId c` supplied is not the contract ID of an active
-- contract, this fails and aborts the entire transaction.
fetch : Template c => ContractId c -> Update c
fetch = internalFetch
-- | A predicate that must be true, otherwise contract creation will fail.
ensure : t -> Bool
-- | Archive the contract with the given contract ID.
archive : Template c => ContractId c -> Update ()
archive c = exercise c Archive
-- | The agreement text of a contract.
agreement : t -> Text
-- | Create a contract based on a template `t`.
create : t -> Update (ContractId t)
-- | Fetch the contract data associated with the given contract ID.
-- If the `ContractId t` supplied is not the contract ID of an active
-- contract, this fails and aborts the entire transaction.
fetch : ContractId t -> Update t
-- | Archive the contract with the given contract ID.
archive : ContractId t -> Update ()
-- | The stakeholders of a contract: its signatories and observers.
stakeholder : Template c => c -> [Party]
stakeholder c = signatory c ++ observer c
stakeholder : Template t => t -> [Party]
stakeholder t = signatory t ++ observer t
-- | Look up the contract ID `c` associated with a given contract key `k`.
--
-- You must pass the `c` using an explicit type application. For
-- instance, if you want to look up a contract of template `Account` by its
-- key `k`, you must call `lookupByKey @Account k`.
lookupByKey : forall c k. TemplateKey c k => k -> Update (Optional (ContractId c))
lookupByKey = internalLookupByKey
class Template t => Choice t c r | t c -> r where
-- | Exercise a choice on the contract with the given contract ID.
exercise : ContractId t -> c -> Update r
class Template t => TemplateKey t k | t -> k where
-- | The key of a contract.
key : t -> k
-- | Look up the contract ID `t` associated with a given contract key `k`.
--
-- You must pass the `t` using an explicit type application. For
-- instance, if you want to look up a contract of template `Account` by its
-- key `k`, you must call `lookupByKey @Account k`.
lookupByKey : k -> Update (Optional (ContractId t))
-- | Fetch the contract ID and contract data associated with a given
-- contract key.
--
-- You must pass the `t` using an explicit type application. For
-- instance, if you want to fetch a contract of template `Account` by its
-- key `k`, you must call `fetchByKey @Account k`.
fetchByKey : k -> Update (ContractId t, t)
-- NOTE(FM): the motivation for this function to return both the
-- contract ID and the contract instance is that `fetchByKey` results in
-- a fetch node in the transaction structure, and the fetch node
-- contains the contract data, so we might as well include it here.
--
-- The reason why turning it into a fetch node is necessary is that:
-- 1. We want to have it a more relaxed authorization rule than
-- `lookupByKey`, which gets turned into a LookupByKey node;
-- 2. We want it to have the same authorization rules of a normal
-- fetch, and to implement _that_, we need to know what the
-- stakeholders of the fetched contract are, which requires
-- getting the contract instance.
-- | Fetch the contract ID and contract data associated with a given
-- contract key.
--
-- You must pass the `c` using an explicit type application. For
-- instance, if you want to fetch a contract of template `Account` by its
-- key `k`, you must call `fetchByKey @Account k`.
fetchByKey : forall c k. TemplateKey c k => k -> Update (ContractId c, c)
-- NOTE(FM): the motivation for this function to return both the
-- contract ID and the contract instance is that `fetchByKey` results in
-- a fetch node in the transaction structure, and the fetch node
-- contains the contract data, so we might as well include it here.
--
-- The reason why turning it into a fetch node is necessary is that:
-- 1. We want to have it a more relaxed authorization rule than
-- `lookupByKey`, which gets turned into a LookupByKey node;
-- 2. We want it to have the same authorization rules of a normal
-- fetch, and to implement _that_, we need to know what the
-- stakeholders of the fetched contract are, which requires
-- getting the contract instance.
fetchByKey k = fmap unpackPair (internalFetchByKey k)
-- | Exercise a choice on the contract associated with the given key.
--
-- You must pass the `c` using an explicit type application. For
-- 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 c k e r. (TemplateKey c k, Choice c e r) => k -> e -> Update r
exerciseByKey k e = do
(cid, _) <- fetchByKey @c k
internalExercise cid e
class Template c where
-- | A predicate that must be true, otherwise contract creation will fail.
ensure : c -> Bool
ensure _ = True
-- | The signatories of a contract.
signatory : c -> [Party]
-- | The observers of a contract.
observer : c -> [Party]
observer _ = []
-- | The agreement text of a contract.
agreement : c -> Text
agreement _ = ""
-- | HIDE
internalCreate : c -> Update (ContractId c)
internalCreate = magic @"create"
-- | HIDE
internalFetch : ContractId c -> Update c
internalFetch = magic @"fetch"
-- | HIDE
internalArchive : ContractId c -> Update ()
internalArchive = magic @"archive"
-- Deliberately not exported.
-- | HIDE
data Consuming = PreConsuming -- Archive before executing exercise body.
| PostConsuming -- Execute exercise body then archive.
| NonConsuming -- Don't archive.
-- | HIDE
nonconsuming : NoEvent c e -> Consuming
nonconsuming _ = NonConsuming
-- | HIDE
preconsuming : NoEvent c e -> Consuming
preconsuming _ = PreConsuming
-- | HIDE
postconsuming : NoEvent c e -> Consuming
postconsuming _ = PostConsuming
class Template c => Choice c e r | c e -> r where
-- | HIDE
consuming : NoEvent c e -> Consuming
consuming = preconsuming
-- | The controller of a choice on a contract.
choiceController : c -> e -> [Party]
-- | The follow-up update of a choice on a contract.
choice : c -> ContractId c -> e -> Update r
-- | HIDE
internalExercise : ContractId c -> e -> Update r
internalExercise = magic @"exercise"
exerciseByKey : forall t k c r. (TemplateKey t k, Choice t c r) => k -> c -> Update r
exerciseByKey k c = do
(cid, _) <- fetchByKey @t k
exercise cid c
data NonConsuming t = NonConsuming {}
data PreConsuming t = PreConsuming {}
data PostConsuming t = PostConsuming {}
-- | The data type corresponding to the implicit `Archive`
-- choice in every template.
data Archive = Archive
data Archive = Archive {}
deriving (Eq, Show)
instance Template c => Choice c Archive () where
choiceController c _ = signatory c
choice _ _ _ = return ()
internalExercise c Archive = internalArchive c
-- | HIDE
data NoEvent c e = NoEvent
data HasKey t = HasKey {}
-- | Accepted ways to specify a list of parties: either a single party, or a list of parties.
class IsParties a where
@ -176,20 +112,3 @@ instance IsParties [Party] where
instance IsParties (Optional Party) where
toParties None = []
toParties (Some p) = [p]
class Template c => TemplateKey c k | c -> k where
-- | The key of a contract.
key : c -> k
-- | The maintainers of the contract key. The maintainers guarantee
-- that contract keys are unique: this means that keys are only unique
-- to the specified maintainers.
maintainer : k -> [Party]
-- | HIDE
internalFetchByKey : k -> Update (Pair "contractId" "contract" (ContractId c) c)
internalFetchByKey = magic @"fetchByKey"
-- | HIDE
internalLookupByKey : k -> Update (Optional (ContractId c))
internalLookupByKey = magic @"lookupByKey"

2
compiler/damlc/daml-stdlib-src/Prelude.daml
View File

@ -6,7 +6,7 @@ daml 1.2
-- | The pieces that make up the DAML language.
module Prelude (module X) where
import DA.Internal.Prelude as X
import DA.Internal.Prelude as X hiding (magic)
import DA.Internal.LF as X hiding (Pair(..), TextMap, unpackPair)
import DA.Internal.Template as X
import DA.Internal.Compatible as X

31
compiler/damlc/lib/DA/Cli/Visual.hs
View File

@ -58,36 +58,37 @@ startFromUpdate seen world update = case update of
-- NOTE(MH): The cases below are impossible because they only appear
-- in dictionaries for the `Template` and `Choice` classes, which we
-- ignore below.
LF.UCreate{}-> error "IMPOSSIBLE"
LF.UCreate{} -> error "IMPOSSIBLE"
LF.UExercise{} -> error "IMPOSSIBLE"
LF.UFetch{} -> error "IMPOSSIBLE"
LF.ULookupByKey{} -> error "IMPOSSIBLE"
LF.UFetchByKey{} -> error "IMPOSSIBLE"
startFromExpr :: Set.Set (LF.Qualified LF.ExprValName) -> LF.World -> LF.Expr -> Set.Set Action
startFromExpr :: Set.Set (LF.Qualified LF.ExprValName) -> LF.World -> LF.Expr -> Set.Set Action
startFromExpr seen world e = case e of
LF.EVar _ -> Set.empty
-- NOTE(MH): We ignore the dictionaries for the `Template` and `Choice`
-- classes because they contain too many ledger actions. We detect the
-- `create`, `archive` and `exercise` functions which take these
-- dictionaries as arguments instead.
-- NOTE(MH/RJR): Do not explore the `$fXInstance` dictionary because it
-- contains all the ledger actions and therefore creates too many edges
-- in the graph. We instead detect calls to the `create`, `archive` and
-- `exercise` methods from `Template` and `Choice` instances.
LF.EVal (LF.Qualified _ _ (LF.ExprValName ref))
| "$fTemplate" `T.isPrefixOf` ref || "$fChoice" `T.isPrefixOf` ref -> Set.empty
LF.EVal ref -> case LF.lookupValue ref world of
| "$f" `T.isPrefixOf` ref && "Instance" `T.isSuffixOf` ref -> Set.empty
LF.EVal ref -> case LF.lookupValue ref world of
Right LF.DefValue{..}
| ref `Set.member` seen -> Set.empty
| otherwise -> startFromExpr (Set.insert ref seen) world dvalBody
| ref `Set.member` seen -> Set.empty
| otherwise -> startFromExpr (Set.insert ref seen) world dvalBody
Left _ -> error "This should not happen"
LF.EUpdate upd -> startFromUpdate seen world upd
-- NOTE(RJR): Look for calls to `create` and `archive` methods from a
-- `Template` instance and produce the corresponding edges in the graph.
EInternalTemplateVal "create" `LF.ETyApp` LF.TCon tpl `LF.ETmApp` _dict
-> Set.singleton (ACreate tpl)
EInternalTemplateVal "exercise" `LF.ETyApp` LF.TCon tpl `LF.ETyApp` LF.TCon (LF.Qualified _ _ (LF.TypeConName [chc])) `LF.ETyApp` _ret `LF.ETmApp` _dict ->
Set.singleton (AExercise tpl (LF.ChoiceName chc))
-- TODO(MH): We need to add a special case for `archive` because it
-- currently defined as `archive c = exercise c Archive` and we can't
-- handle polymorphic calls to `exercise` like this one.
EInternalTemplateVal "archive" `LF.ETyApp` LF.TCon tpl `LF.ETmApp` _dict ->
Set.singleton (AExercise tpl (LF.ChoiceName "Archive"))
-- NOTE(RJR): Look for calls to the `exercise` method from a `Choice`
-- instance and produce the corresponding edge in the graph.
EInternalTemplateVal "exercise" `LF.ETyApp` LF.TCon tpl `LF.ETyApp` LF.TCon (LF.Qualified _ _ (LF.TypeConName [chc])) `LF.ETyApp` _ret `LF.ETmApp` _dict ->
Set.singleton (AExercise tpl (LF.ChoiceName chc))
expr -> Set.unions $ map (startFromExpr seen world) $ children expr
pattern EInternalTemplateVal :: T.Text -> LF.Expr

2
compiler/damlc/tests/BUILD.bazel
View File

@ -227,7 +227,7 @@ damlc_compile_test(
srcs = [":bond-trading"],
heap_limit = "200M" if is_windows else "100M",
main = "bond-trading/Test.daml",
stack_limit = "35K",
stack_limit = "300K" if is_windows else "35K",
)
filegroup(

2
compiler/damlc/tests/daml-test-files/ComposedKey.daml
View File

@ -10,10 +10,8 @@
daml 1.2
module ComposedKey where
import Prelude hiding (Template (..), TemplateKey (..), Choice (..), Archive (..), create, fetch, fetchByKey, archive, exercise)
import DA.Assert
import DA.Text
import GenericTemplates
import GenTemplCompat
-- For any instantiation, `k` has to be the key type of `t`.

13
compiler/damlc/tests/daml-test-files/EqContractId.daml
View File

@ -4,15 +4,10 @@
daml 1.2
module EqContractId where
data Foo = Foo{p : Party}
instance Template Foo where
signatory Foo{p} = [p]
data Bar = Bar{}
instance Choice Foo Bar () where
choiceController Foo{p} _ = [p]
choice _ _ _ = return ()
template Foo with
p: Party
where
signatory p
main = scenario do
alice <- getParty "Alice"

3
compiler/damlc/tests/daml-test-files/ExerciseWithoutActors.daml
View File

@ -6,8 +6,7 @@
-- uses actors as a sanity check.
-- @SINCE-LF 1.5
-- @QUERY-LF .modules[] | .values[] | select(.name_with_type.name == ["$$cinternalExercise"]) | .expr | .. | objects | select(has("exercise")) | .exercise | has("actor") | not
-- @QUERY-LF .modules[] | .values[] | select(.name_with_type.name == ["$$cinternalArchive"]) | .expr | .. | objects | select(has("exercise")) | .exercise | has("actor") | not
-- @QUERY-LF [.modules[] | .values[] | select(.name_with_type.name == ["$$fFooInstance"]) | .expr | .. | objects | select(has("exercise")) | .exercise | has("actor") | not] | all
daml 1.2
module ExerciseWithoutActors where

2
compiler/damlc/tests/daml-test-files/GenTemplCompat.daml
View File

@ -10,9 +10,7 @@
daml 1.2
module GenTemplCompat where
import Prelude hiding (Template (..), TemplateKey (..), Choice (..), Archive (..), create, fetch, archive, fetchByKey, lookupByKey, exercise)
import DA.Assert
import GenericTemplates
data Fact = Fact with
owner : Party

46
compiler/damlc/tests/daml-test-files/Hack.daml
View File

@ -1,46 +0,0 @@
-- Copyright (c) 2019, Digital Asset (Switzerland) GmbH and/or its affiliates.
-- All rights reserved.
daml 1.2
module Hack where
data Iou = Iou with
issuer : Party
owner : Party
currency : Text
amount : Decimal
deriving Eq
instance Template Iou where
ensure this = this.amount > 0.0
signatory this = [this.issuer]
{-data Fungible a = Split with splitAmount : Decimal
| Merge with otherCid : ContractId a
data FungibleRv a = SplitRv (ContractId a)
| MergeRv (ContractId a, ContractId a)
-}
{-instance Choice Iou (Fungible Iou) (FungibleRv Iou) where
choiceController Iou {..} _ = [owner]
choice this@Iou {..} self arg@Split{..} = do
f <- create this with amount = splitAmount
s <- create this with amount = amount - splitAmount
return (f, s)
-}
--data Split = ...
--data Merge = ...
--class (Choice tpl Split _, Choice tpl Merge _) => Fungible tpl where
--type Fungible tpl = (Choice tpl Split _, Choice tpl Merge _)
-- data Merge =
{-instance Choice Iou Fungible (ContractId Iou) where
choiceController Iou {..} _ = [owner]
choice this@Iou {..} self arg@Merge {..} = do
otherBond <- fetch otherCid
assert $ this == otherBond with amount
archive otherCid
create this with amount = amount + otherBond.amount
-}

2
compiler/damlc/tests/daml-test-files/IouDSL.daml
View File

@ -6,9 +6,7 @@
daml 1.2
module IouDSL where
import Prelude hiding (Template (..), TemplateKey (..), Choice (..), Archive (..), create, fetch, archive, fetchByKey, lookupByKey, exercise)
import DA.Assert
import GenericTemplates
import ProposalDSL

3
compiler/damlc/tests/daml-test-files/Iou_template.EXPECTED.md
View File

@ -18,6 +18,9 @@
Choices:
* External:Archive
(no fields)
* Merge
merges two "compatible" `Iou`s

1
compiler/damlc/tests/daml-test-files/Iou_template.EXPECTED.rst
View File

@ -35,6 +35,7 @@ Templates
- [Party]
- ``regulators`` may observe any use of the ``Iou``
+ **Choice External:Archive**
+ **Choice Merge**
merges two "compatible" ``Iou``s

2
compiler/damlc/tests/daml-test-files/ProposalDSL.daml
View File

@ -11,10 +11,8 @@ module ProposalDSL
, ProposalInstance
) where
import Prelude hiding (Template (..), TemplateKey (..), Choice (..), Archive (..), create, fetch, archive, fetchByKey, lookupByKey, exercise)
import DA.List
import DA.Text
import GenericTemplates
data Proposal t = Proposal with

20
compiler/damlc/tests/daml-test-files/Self.daml
View File

@ -4,18 +4,18 @@
daml 1.2
module Self where
data Self = Self {p : Party}
template Self with
p: Party
where
signatory p
instance Template Self where
signatory Self {p} = [p]
data Same = Same (ContractId Self)
instance Choice Self Same () where
choiceController Self{p} _ = [p]
choice _ self (Same other) = assert (self == other)
controller p can
Same : ()
with other: ContractId Self
do assert (self == other)
main = scenario do
alice <- getParty "Alice"
submit alice do
cid1 <- create Self{p = alice}
exercise cid1 (Same cid1)
cid1 <- create Self with p = alice
exercise cid1 Same with other = cid1

48
compiler/damlc/tests/daml-test-files/Unserializable.daml
View File

@ -1,11 +1,53 @@
-- Copyright (c) 2019, Digital Asset (Switzerland) GmbH and/or its affiliates.
-- All rights reserved.
-- Test the serializability checker for DAML LF.
-- We use the template typeclass and instances directly as otherwise the error
-- is caught prior due to missing Eq and Show instances.
-- @ERROR expected serializable type
daml 1.2
module Unserializable where
data Unserializable = Unserializable{f : Text -> Text}
data Unserializable = Unserializable with
p : Party
f : Text -> Text
instance Template Unserializable where
signatory Unserializable{} = []
class UnserializableInstance where
signatoryUnserializable : Unserializable -> [Party]
signatoryUnserializable this@Unserializable{..} = [p]
observerUnserializable : Unserializable -> [Party]
observerUnserializable this@Unserializable{..} = []
ensureUnserializable : Unserializable -> Bool
ensureUnserializable this@Unserializable{..} = True
agreementUnserializable : Unserializable -> Text
agreementUnserializable this@Unserializable{..} = ""
createUnserializable : Unserializable -> Update (ContractId Unserializable)
createUnserializable = error "code will be injected by the compiler"
fetchUnserializable : ContractId Unserializable -> Update Unserializable
fetchUnserializable = error "code will be injected by the compiler"
archiveUnserializable : ContractId Unserializable -> Update ()
archiveUnserializable cid = exerciseUnserializableArchive cid Archive
consumptionUnserializableArchive : PreConsuming Unserializable
consumptionUnserializableArchive = PreConsuming
controllerUnserializableArchive : Unserializable -> Archive -> [Party]
controllerUnserializableArchive this@Unserializable{..} arg@Archive = signatoryUnserializable this
actionUnserializableArchive : ContractId Unserializable -> Unserializable -> Archive -> Update ()
actionUnserializableArchive self this@Unserializable{..} arg@Archive = pure ()
exerciseUnserializableArchive : ContractId Unserializable -> Archive -> Update ()
exerciseUnserializableArchive = error "code will be injected by the compiler"
instance UnserializableInstance
instance UnserializableInstance => Template Unserializable where
signatory = signatoryUnserializable
observer = observerUnserializable
ensure = ensureUnserializable
agreement = agreementUnserializable
create = createUnserializable
fetch = fetchUnserializable
archive = archiveUnserializable
instance Choice Unserializable Archive () where
exercise = exerciseUnserializableArchive

26
compiler/damlc/tests/visual/Basic.dot
View File

@ -1,31 +1,31 @@
digraph G {
compound=true;
rankdir=LR;
subgraph cluster_Group{
subgraph cluster_Message{
n0[label=Create][color=green];
n1[label=Archive][color=red];
label=Group;color=blue
label=Message;color=blue
}subgraph cluster_Invitation{
n2[label=Create][color=green];
n3[label=Archive][color=red];
label=Invitation;color=blue
}subgraph cluster_Message{
}subgraph cluster_Group{
n4[label=Create][color=green];
n5[label=Archive][color=red];
label=Message;color=blue
label=Group;color=blue
}subgraph cluster_Membership{
n6[label=Create][color=green];
n7[label=Archive][color=red];
n8[label=Membership_Shutdown_Indirect][color=green];
n9[label=Membership_Shutdown][color=red];
n8[label=Membership_Join][color=red];
n9[label=Membership_Leave][color=red];
n10[label=Membership_SendMessage][color=green];
n11[label=Membership_Leave][color=red];
n12[label=Membership_Join][color=red];
n11[label=Membership_Shutdown_Indirect][color=green];
n12[label=Membership_Shutdown][color=red];
label=Membership;color=blue
}n8->n9
n9->n1
n10->n4
n11->n6
n12->n6
}n8->n6
n9->n6
n10->n0
n11->n12
n12->n5
}

2
daml-lf/archive/src/test/scala/com/digitalasset/daml/lf/archive/DarReaderTest.scala
View File

@ -48,7 +48,7 @@ class DarReaderTest extends WordSpec with Matchers with Inside with BazelRunfile
case Some(module) =>
val actualTypes: Set[String] =
module.getDataTypesList.asScala.toSet.map((t: DamlLf1.DefDataType) => name(t.getName))
actualTypes shouldBe Set("Transfer", "Call2", "CallablePayout", "PayOut")
actualTypes should contain allOf ("Transfer", "Call2", "CallablePayout", "PayOut")
}
val archive2Modules = archive2.getDamlLf1.getModulesList.asScala

130
daml-lf/tests/AuthorizedDivulgence.daml
View File

@ -9,25 +9,17 @@ module AuthorizedDivulgence where
-- Authorized fetch
----------------------------------------------------------------------------------------------------
data Secret = Secret
{ p : Party
, mySecret : Text
}
template Secret with
p : Party
mySecret : Text
where
signatory p
instance Template Secret where
signatory this@Secret{..} = [p]
observer this@Secret{..} = []
agreement this@Secret{..} = ""
data RevealYourSecret = RevealYourSecret
{ p : Party
, secretCid : ContractId Secret
}
instance Template RevealYourSecret where
signatory this@RevealYourSecret{..} = [p]
observer this@RevealYourSecret{..} = []
agreement this@RevealYourSecret{..} = ""
template RevealYourSecret with
p : Party
secretCid : ContractId Secret
where
signatory p
-- This scenario succeeds only if the flag +DontDivulgeContractIdsInCreateArguments is turned on
test_authorizedFetch = scenario do
@ -44,75 +36,51 @@ test_authorizedFetch = scenario do
-- Testing no divulgence of create arguments. We test with the classic swap scenario.
----------------------------------------------------------------------------------------------------
data Iou = Iou
{ owner : Party
, obligor : Party
}
template Iou with
owner : Party
obligor : Party
where
signatory obligor
observer owner
controller owner can
Sell : ContractId Iou
with newOwner : Party
do create this with owner = newOwner
instance Template Iou where
signatory Iou{..} = [obligor]
observer Iou{..} = [owner]
agreement _ = ""
template Swap1 with
p1 : Party
p2 : Party
where
signatory p1
observer p2
data Sell = Sell
{ newOwner : Party
}
controller p1 can
GoSwap1 : ContractId Swap2
with cid1 : ContractId Iou
do create Swap2 with p1; p2; cid1
instance Choice Iou Sell (ContractId Iou) where
choiceController Iou{..} _ = [owner]
choice this@Iou{..} self Sell{..} = create this{owner = newOwner}
GoSwap1WithFetch : ContractId Swap2
with cid1 : ContractId Iou
do
fetch cid1
create Swap2 with p1; p2; cid1
data Swap1 = Swap1
{ p1 : Party
, p2 : Party
}
template Swap2 with
p1 : Party
p2 : Party
cid1 : ContractId Iou
where
signatory p1
observer p2
instance Template Swap1 where
signatory Swap1{..} = [p1]
observer Swap1{..} = [p2]
agreement _ = ""
data Swap2 = Swap2
{ p1 : Party
, p2 : Party
, cid1 : ContractId Iou
}
instance Template Swap2 where
signatory Swap2{..} = [p1]
observer Swap2{..} = [p2]
agreement _ = ""
data GoSwap1 = GoSwap1
{ cid1 : ContractId Iou
}
instance Choice Swap1 GoSwap1 (ContractId Swap2) where
choiceController Swap1{..} _ = [p1]
choice Swap1{..} _self GoSwap1{..} = do
create Swap2{p1 = p1, p2 = p2, cid1 = cid1}
data GoSwap1WithFetch = GoSwap1WithFetch
{ cid1 : ContractId Iou
}
instance Choice Swap1 GoSwap1WithFetch (ContractId Swap2) where
choiceController Swap1{..} _ = [p1]
choice Swap1{..} _self GoSwap1WithFetch{..} = do
fetch cid1
create Swap2{p1 = p1, p2 = p2, cid1 = cid1}
data GoSwap2 = GoSwap2
{ cid2 : ContractId Iou
}
instance Choice Swap2 GoSwap2 () where
choiceController Swap2{..} _ = [p2]
choice Swap2{..} _self GoSwap2{..} = do
exercise cid1 Sell {newOwner = p2}
exercise cid2 Sell {newOwner = p1}
pure ()
controller p2 can
GoSwap2 : ()
with cid2 : ContractId Iou
do
exercise cid1 Sell with newOwner = p2
exercise cid2 Sell with newOwner = p1
pure ()
-- We're testing the classic swap example.
-- This scenario should fail now if the DontDivulgeContractIdsInCreateArguments flag is set because

35
daml-lf/tests/DontDiscloseNonConsumingChoicesToObservers.daml
View File

@ -5,30 +5,21 @@ daml 1.2
module DontDiscloseNonConsumingExercisesToObservers where
data NonObservable = NonObservable
{ p : Party
, obs : Party
}
template NonObservable with
p : Party
obs : Party
where
signatory p
observer obs
controller p can
nonconsuming CreateEvent : ContractId Event
do create $ Event p
instance Template NonObservable where
signatory NonObservable{..} = [p]
observer NonObservable{..} = [obs]
data Event = Event
{ p : Party
}
instance Template Event where
signatory Event{..} = [p]
data CreateEvent = CreateEvent {}
instance Choice NonObservable CreateEvent (ContractId Event) where
choiceController NonObservable{..} _ = [p]
consuming = nonconsuming
choice NonObservable{..} _self CreateEvent =
create $ Event p
template Event with
p : Party
where
signatory p
-- Bob should not be able to fetch when DontDiscloseNonConsumingExercisesToObservers is set,

387
ghc-lib/template-desugaring.md
View File

@ -25,7 +25,7 @@ template Iou
ensure amount > 0
signatory issuer, owner
observer regulators
agreement issuer <> " will pay " <> owner <> " " <> (show amount)
agreement issuer <> " will pay " <> owner <> " " <> show amount
choice Transfer : ContractId Iou
with
@ -38,145 +38,117 @@ template Iou
The `class Template` (defined by the DAML standard library) represents the set of all contract types:
```haskell
class Template c where
-- | Predicate that must hold for the succesful creation of the contract.
ensure : c -> Bool ; ensure _ = True
-- | The signatories of a contract.
signatory : c -> [Party]
-- | The observers of a contract.
observer : c -> [Party] ; observer _ = []
-- | The agreement text of a contract.
agreement : c -> Text ; agreement _ = ""
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
archive : ContractId t -> Update ()
```
In this example, `c` is identified with `Iou`. The rest of this section shows you how desugaring proceeds.
In this example, `t` is identified with `Iou`. The rest of this section shows you how desugaring proceeds.
First, the definition of `Iou`:
First we have data type definitions for the `Iou` template and the `Transfer` choice.
```haskell
data Iou = Iou {
data Iou = Iou with
issuer : Party
, owner : Party
, currency : Party
, amount : Float
, account : Party
, regulators :[Party] } deriving (Eq, Show)
owner : Party
currency : Party
amount : Decimal
account : Party
regulators : [Party]
deriving (Eq, Show)
data Transfer = Transfer with
newOwner : Party
deriving (Eq, Show)
```
Next, an `instance` declaration for `Iou` to declare its membership in `Template`:
Next we have a `class IouInstance` with the bulk of the definitions we will need.
```haskell
instance Template Iou where
ensure this@Iou{..} = amount > 0.0
signatory this@Iou{..} = concat [toParties issuer, toParties owner]
observer this@Iou{..} = concat [toParties owner, toParties regulators]
agreement this@Iou{..} = issuer <> " will pay " <> owner <> " " <> (show amount)
class IouInstance where
signatoryIou : Iou -> [Party]
signatoryIou this@Iou{..} = [issuer, owner]
observerIou : Iou -> [Party]
observerIou this@Iou{..} = regulators
ensureIou : Iou -> Bool
ensureIou this@Iou{..} = amount > 0.0
agreementIou : Iou -> Text
agreementIou this@Iou{..} = show issuer <> " will pay " <> show owner <> " " <> show amount
createIou : Iou -> Update (ContractId Iou)
createIou = magic @"create"
fetchIou : ContractId Iou -> Update Iou
fetchIou = magic @"fetch"
archiveIou : ContractId Iou -> Update ()
archiveIou cid = exerciseIouArchive cid Archive
consumptionIouArchive : PreConsuming Iou
consumptionIouArchive = PreConsuming
controllerIouArchive : Iou -> Archive -> [Party]
controllerIouArchive this@Iou{..} arg@Archive = signatoryIou this
actionIouArchive : ContractId Iou -> Iou -> Archive -> Update ()
actionIouArchive self this@Iou{..} arg@Archive = pure ()
exerciseIouArchive : ContractId Iou -> Archive -> Update ()
exerciseIouArchive = magic @"archive"
consumptionIouTransfer : PreConsuming Iou
consumptionIouTransfer = PreConsuming
controllerIouTransfer : Iou -> Transfer -> [Party]
controllerIouTransfer this@Iou{..} arg@Transfer{..} = [owner]
actionIouTransfer : ContractId Iou -> Iou -> Transfer -> Update (ContractId Iou)
actionIouTransfer self this@Iou{..} arg@Transfer{..} = create this with owner = newOwner
exerciseIouTransfer : ContractId Iou -> Transfer -> Update (ContractId Iou)
exerciseIouTransfer = magic @"exercise"
```
When a type `c` is a `Template` instance, `class Choice` (defined by the DAML standard library) defines a (multi-parameter type class) relation on types `c`, `e` and `r` such that `r` is uniquely determined by the pair `(c, e)`:
With that class defined, we can define an `instance` declaration for `Iou` to declare its membership in `Template`:
```haskell
instance IouInstance => Template Iou where
signatory = signatoryIou
observer = observerIou
ensure = ensureIou
agreement = agreementIou
create = createIou
fetch = fetchIou
archive = archiveIou
instance IouInstance where
```
When a type `t` is a `Template` instance, `class Choice` (defined by the DAML standard library) defines a (multi-parameter type class) relation on types `t`, `c` and `r` such that `r` is uniquely determined by the pair `(t, c)`:
```haskell
class Template c => Choice c e r | c e -> r where
consuming : NoEvent c e -> ChoiceType ; consuming _ = Consuming
choiceController : c -> e -> [Party]
choice : c -> ContractId c -> e -> Update r
class Template t => Choice t c r | t c -> r where
exercise : ContractId t -> c -> Update r
```
In this example, `e` is identified with `Transfer` and `r` with `ContractId Iou`.
In this example, `c` is identified with `Transfer` and `r` with `ContractId Iou`.
Desugaring first defines type `Transfer`:
```haskell
data Transfer = Transfer {
newOwner : String } deriving (Eq, Show)
```
Next, an `instance` declaration establishes the triple `(Iou, Transfer, ContractID Iou)` as satisfying the `Choice` relation:
The `instance` declaration establishes the triple `(Iou, Transfer, ContractId Iou)` as satisfying the `Choice` relation:
```haskell
instance Choice Iou Transfer (ContractId Iou) where
choiceController this@Iou{..} arg@Transfer{..} = [owner]
choice this@Iou{..} self arg@Transfer{..} = create this with owner = newOwner
exercise = exerciseIouTransfer
```
### Example (2)
Here is a contract with two choices, this time using an alternative syntax (that predates the `choice` keyword):
The next contract exercises the "contract keys" feature of DAML.
Contract key syntax desugars to `instance` declarations of the following typeclass.
```haskell
template Iou
with
issuer : Party
owner : Party
currency : Party
amount : Float
regulators : [Party]
where
ensure amount > 0
signatory issuer, owner
observer regulators
agreement issuer <> " will pay " <> owner <> " " <> (show amount)
controller [owner] can
Transfer : ContractId Iou
with
newOwner : String
do
create this with owner = newOwner
Split : (ContractId Iou, ContractId Iou)
with
splitAmount : Float
do
let restAmount = amount - splitAmount
splitCid <- create this with amount = splitAmount
restCid <- create this with amount = restAmount
return (splitCid, restCid)
class Template t => TemplateKey t k | t -> k where
key : t -> k
fetchByKey : k -> Update (ContractId t, t)
lookupByKey : k -> Update (Optional (ContractId t))
```
As before, `Iou` is identified with `c` and generates a `data` and `instance` declaration:
```haskell
data Iou = Iou {
issuer : Party
, owner : Party
, amount : Float
, regulators : [Party] } deriving (Eq, Show)
instance Template Iou where
ensure this@Iou{..} = amount > 0.0
signatory this@Iou{..} = concat [toParties issuer, toParties owner]
observer this@Iou{..} = concat [toParties owner, toParties regulators]
agreement this@Iou{..} = issuer <> " will pay " <> owner <> " " <> (show amount)
```
The two choices lead to two `instance Choice Iou e r` declarations, one for each of the triples `(Iou, Split, (ContractID Iou, ContractID Iou))` and `(Iou, Transfer, ContractID Iou)`:
```haskell
data Split = Split { splitAmount : Float } deriving (Eq)
instance Choice Iou Split (ContractId Iou, ContractId Iou) where
choiceController this@Iou{..} arg@Split{..} = [owner]
choice this@Iou{..} self arg@Split{..} = do
let restAmount = amount - splitAmount
splitCid <- create this with amount = splitAmount
restCid <- create this with amount = restAmount
return (splitCid, restCid)
data Transfer = Transfer { newOwner : String } deriving (Eq, Show)
instance Choice Iou Transfer (ContractId Iou) where
choiceController this@Iou{..} arg@Transfer{..} = [owner]
choice this@Iou{..} self arg@Transfer{..} = create this with owner = newOwner
```
### Example (3)
The next contract exercises the so-called "contract keys" feature of DAML. Contract key syntax desugars to `instance` declarations of the following typeclass.
```haskell
class Template c => TemplateKey c k | c -> k where
key : c ->
maintainer : k -> [Party]
```
In the following `Enrollment` contract, there are no choices but there are declarations of `key` and `maintainer`.
```haskell
data Course =
Course with
@ -199,15 +171,192 @@ template Enrollment
key reg : Registration
maintainer key.course.institution
```
What the above desugars to is shown below.
```haskell
data Course = ...
data Registration = ...
instance Template Enrollment where
signatory this@Enrollment{..} = concat [toParties reg.student, toParties reg.course.institution]
The `Course` and `Registration` data types remain as they are, but the `Enrollment` template results in several pieces after desugaring.
```haskell
data Enrollment =
Enrollment with
reg : Registration
deriving (Show, Eq)
class EnrollmentInstance where
signatoryEnrollment : Enrollment -> [Party]
signatoryEnrollment this@Enrollment{..} = [reg.student, reg.course.institution]
observerEnrollment : Enrollment -> [Party]
observerEnrollment this@Enrollment{..} = []
ensureEnrollment : Enrollment -> Bool
ensureEnrollment this@Enrollment{..} = True
agreementEnrollment : Enrollment -> Text
agreementEnrollment this@Enrollment{..} = ""
createEnrollment : Enrollment -> Update (ContractId Enrollment)
createEnrollment = magic @"create"
fetchEnrollment : ContractId Enrollment -> Update Enrollment
fetchEnrollment = magic @"fetch"
archiveEnrollment : ContractId Enrollment -> Update ()
archiveEnrollment cid = exerciseEnrollmentArchive cid Archive
hasKeyEnrollment : HasKey Enrollment
hasKeyEnrollment = HasKey
keyEnrollment : Enrollment -> Registration
keyEnrollment this@Enrollment{..} = reg
maintainerEnrollment : HasKey Enrollment -> Registration -> [Party]
maintainerEnrollment HasKey key = [key.course.institution]
fetchByKeyEnrollment : Registration -> Update (ContractId Enrollment, Enrollment)
fetchByKeyEnrollment = magic @"fetchByKey"
lookupByKeyEnrollment : Registration -> Update (Optional (ContractId Enrollment))
lookupByKeyEnrollment = magic @"lookupByKey"
consumptionEnrollmentArchive : PreConsuming Enrollment
consumptionEnrollmentArchive = PreConsuming
controllerEnrollmentArchive : Enrollment -> Archive -> [Party]
controllerEnrollmentArchive this@Enrollment{..} arg@Archive = signatoryEnrollment this
actionEnrollmentArchive : ContractId Enrollment -> Enrollment -> Archive -> Update ()
actionEnrollmentArchive self this@Enrollment{..} arg@Archive = pure ()
exerciseEnrollmentArchive : ContractId Enrollment -> Archive -> Update ()
exerciseEnrollmentArchive = magic @"archive"
instance EnrollmentInstance where
instance EnrollmentInstance => Template Enrollment where
signatory = signatoryEnrollment
observer = observerEnrollment
ensure = ensureEnrollment
agreement = agreementEnrollment
create = createEnrollment
fetch = fetchEnrollment
archive = archiveEnrollment
instance TemplateKey Enrollment Registration where
key this@Enrollment{..} = reg
maintainer key = concat [toParties key.course.institution]
key = keyEnrollment
fetchByKey = fetchByKeyEnrollment
lookupByKey = lookupByKeyEnrollment
```
### Example (3)
The final example shows a generic proposal template.
```haskell
template Template t => Proposal t with
asset : t
receivers : [Party]
name : Text
where
signatory (signatory t \\ receivers)
observer receivers
key (signatory this, name)
maintainer (fst key)
choice Accept : ContractId t
controller receivers
do
create asset
```
Notice that the `Proposal` template has a type argument `t` with a `Template` constraint preceding it.
We also specify a primary key for the Proposal template by combining data from the underlying template as well as the proposal.
This desugars to the following declarations.
```haskell
data Proposal t = Proposal with
asset : t
receivers : [Party]
name : Party
deriving (Eq, Show)
data Accept = Accept with
deriving (Eq, Show)
class Template t => ProposalInstance t where
signatoryProposal : Proposal t -> [Party]
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 = magic @"create"
fetchProposal : ContractId (Proposal t) -> Update (Proposal t)
fetchProposal = magic @"fetch"
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 = magic @"fetchByKey"
lookupByKeyProposal : ([Party], Text) -> Update (Optional (ContractId (Proposal t)))
lookupByKeyProposal = magic @"lookupByKey"
consumptionProposalArchive : PreConsuming (Proposal t)
consumptionProposalArchive = PreConsuming
controllerProposalArchive : Proposal t -> Archive -> [Party]
controllerProposalArchive this@Proposal{..} arg@Archive = signatoryProposal this
actionProposalArchive : ContractId (Proposal t) -> Proposal t -> Archive -> Update ()
actionProposalArchive self this@Proposal{..} arg@Archive = pure ()
exerciseProposalArchive : ContractId (Proposal t) -> Archive -> Update ()
exerciseProposalArchive = magic @"archive"
consumptionProposalAccept : PreConsuming (Proposal t)
consumptionProposalAccept = PreConsuming
controllerProposalAccept : Proposal t -> Accept -> [Party]
controllerProposalAccept this@Proposal{..} arg@Accept = receivers
actionProposalAccept : ContractId (Proposal t) -> Proposal t -> Accept -> Update (ContractId t)
actionProposalAccept self this@Proposal{..} arg@Accept = do
create asset
exerciseProposalAccept : ContractId (Proposal t) -> Accept -> Update (ContractId t)
exerciseProposalAccept = magic @"exercise"
instance ProposalInstance t => Template (Proposal t) where
signatory = signatoryProposal
observer = observerProposal
ensure = ensureProposal
agreement = agreementProposal
create = createProposal
fetch = fetchProposal
archive = archiveProposal
instance ProposalInstance t => TemplateKey (Proposal t) ([Party], Text) where
key = keyProposal
fetchByKey = fetchByKeyProposal
lookupByKey = lookupByKeyProposal
instance ProposalInstance t => Choice (Proposal t) Accept (ContractId t) where
exercise = exerciseProposalAccept
instance ProposalInstance t => Choice (Proposal t) Archive () where
exercise = exerciseProposalArchive
```
### Example (3)(cont)
We showed the generic proposal template above, but have not showed what an instance looks like.
Let's instantiate the `Proposal` template with the `Iou` (concrete) template from Example 1.
This is done using the syntax below.
```haskell
template instance ProposalIou = Proposal Iou
```
This allows us to create and exercise choices on a proposal contract instantiated to an Iou contract.
The name `ProposalIou` is not needed in DAML code but is required when creating contracts via the Ledger API
(as client languages may not be able to express generic template and type instantiation).
The `template instance` desugars to the following declarations.
```haskell
newtype ProposalIou = ProposalIou (Proposal Iou)
instance ProposalInstance Iou where
```
The `instance` here simply leverages the implementation of the `ProposalInstance` class.