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" "-I/compiler", "-I/compiler/utils"
], ],
package_name = "ghc-lib-parser", package_name = "ghc-lib-parser",
version = "8.8.0.20190723", version = "8.8.0.20190730.1",
) )
cc_library( cc_library(

11
WORKSPACE
View File

@ -464,12 +464,12 @@ HASKELL_LSP_COMMIT = "d73e2ccb518724e6766833ee3d7e73289cbe0018"
HASKELL_LSP_HASH = "36b92431039e6289eb709b8872f5010a57d4a45e637e1c1c945bdb3128586081" HASKELL_LSP_HASH = "36b92431039e6289eb709b8872f5010a57d4a45e637e1c1c945bdb3128586081"
GHC_LIB_VERSION = "8.8.0.20190723" GHC_LIB_VERSION = "8.8.0.20190730.1"
http_archive( http_archive(
name = "haskell_ghc__lib__parser", name = "haskell_ghc__lib__parser",
build_file = "//3rdparty/haskell:BUILD.ghc-lib-parser", build_file = "//3rdparty/haskell:BUILD.ghc-lib-parser",
sha256 = "139c5b58d179a806640f8b56bc3fe8c70a893191dbfd111a593544e7ac71086b", sha256 = "dcd211cac831609cec546050b342ca94a546cb4e672cf2819189332f49361baf",
strip_prefix = "ghc-lib-parser-{}".format(GHC_LIB_VERSION), 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)], 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( packages = add_extra_packages(
extra = extra =
# Read [Working on ghc-lib] for ghc-lib update # Read [Working on ghc-lib] for ghc-lib update instructions at
# instructions at
# https://github.com/DACH-NY/daml/blob/master/ghc-lib/working-on-ghc-lib.md. # 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: # Support for Hlint:
# - Requires haskell-src-exts 1.21.0 so override hazel/packages.bzl. # - 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` # - To build the library : `bazel build @haskell_hlint//:lib`
# We'll be using it via the library, not the binary. # We'll be using it via the library, not the binary.
hazel_hackage("haskell-src-exts", "1.21.0", "95dac187824edfa23b6a2363880b5e113df8ce4a641e8a0f76e6d45aaa699ff3") + 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-wire", "43d8220dbc64ef7cc7681887741833a47b61070f", "1c3a7fbf4ab3308776675c6202583f9750de496757f3ad4815e81edd122d75e1") +
hazel_github_external("awakesecurity", "proto3-suite", "dd01df7a3f6d0f1ea36125a67ac3c16936b53da0", "59ea7b876b14991347918eefefe24e7f0e064b5c2cc14574ac4ab5d6af6413ca") + hazel_github_external("awakesecurity", "proto3-suite", "dd01df7a3f6d0f1ea36125a67ac3c16936b53da0", "59ea7b876b14991347918eefefe24e7f0e064b5c2cc14574ac4ab5d6af6413ca") +
hazel_hackage("happy", "1.19.10", "22eb606c97105b396e1c7dc27e120ca02025a87f3e44d2ea52be6a653a52caed") + 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 $ noLoc $
mkRdrQual (mkModuleName "DA.Internal.Template") $ mkRdrQual (mkModuleName "DA.Internal.Template") $
mkOccName varName "Template" :: LHsType GhcPs mkOccName varName "Template" :: LHsType GhcPs
sigRdrName = noLoc $ mkRdrUnqual $ mkOccName varName "signatory"
errTooManyNameComponents cs = errTooManyNameComponents cs =
error $ error $
"Internal error: Dalf contains type constructors with more than two name components: " <> "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 , length dataTyCon == 2
, LF.DataRecord fs <- [dataCons] , 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 = decls =
concat $ do concat $ do
LF.DefDataType {..} <- NM.toList $ LF.moduleDataTypes m LF.DefDataType {..} <- NM.toList $ LF.moduleDataTypes m
@ -303,71 +367,7 @@ generateSrcFromLf (Qualify qualify) thisPkgId pkgMap m = noLoc mod
HsAppTy noExt templateTy $ HsAppTy noExt templateTy $
noLoc $ convType templType noLoc $ convType templType
} }
, cid_binds = , cid_binds = listToBag $ map classMethodStub templateMethodNames
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_sigs = [] , cid_sigs = []
, cid_tyfam_insts = [] , cid_tyfam_insts = []
, cid_datafam_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 check $ isNothing $ td_descr t
f1 <- getSingle $ td_payload t f1 <- getSingle $ td_payload t
check $ isNothing $ fd_descr f1 check $ isNothing $ fd_descr f1
ch <- getSingle $ td_choices t ch <- getSingle $ td_choicesWithoutArchive t
f2 <- getSingle $ cd_fields ch f2 <- getSingle $ cd_fields ch
check $ Just "field" == fd_descr f2)) check $ Just "field" == fd_descr f2))
@ -177,7 +177,7 @@ unitTests =
("Expected two choices in doc, got " <> show md) ("Expected two choices in doc, got " <> show md)
(isJust $ do t <- getSingle $ md_templates md (isJust $ do t <- getSingle $ md_templates md
check $ isNothing $ td_descr t check $ isNothing $ td_descr t
cs <- Just $ td_choices t cs <- Just $ td_choicesWithoutArchive t
check $ length cs == 2 check $ length cs == 2
check $ ["DoMore", "DoSomething"] == sort (map cd_name cs))) check $ ["DoMore", "DoSomething"] == sort (map cd_name cs)))
@ -208,6 +208,9 @@ unitTests =
check True = Just () check True = Just ()
check False = Nothing check False = Nothing
td_choicesWithoutArchive :: TemplateDoc -> [ChoiceDoc]
td_choicesWithoutArchive = filter (\ch -> cd_name ch /= "External:Archive") . td_choices
testModule :: String testModule :: String
testModule = "Testfile" 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 let applyThis e = ETmApp e $ unwrapTpl $ EVar this
tplSignatories <- applyThis <$> convertExpr env (Var signatories) tplSignatories <- applyThis <$> convertExpr env (Var signatories)
tplObservers <- applyThis <$> convertExpr env (Var observers) tplObservers <- applyThis <$> convertExpr env (Var observers)
let tplPrecondition = ETrue tplPrecondition <- applyThis <$> convertExpr env (Var ensure)
let tplAgreement = mkEmptyText tplAgreement <- applyThis <$> convertExpr env (Var agreement)
archive <- convertExpr env (Var archive) archive <- convertExpr env (Var archive)
(tplKey, key, choices) <- case keyAndChoices of (tplKey, key, choices) <- case keyAndChoices of
hasKey : key : maintainers : _fetchByKey : _lookupByKey : choices 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. -- | Automatically imported qualified in every module.
module DA.Internal.Desugar ( module DA.Internal.Desugar (
concat, module DA.Internal.Template,
Template(ensure, signatory, observer, agreement), Eq(..), Show(..),
TemplateKey(key, maintainer), Bool(..), Text, Optional,
Choice(consuming, choiceController, choice), preconsuming, nonconsuming, postconsuming, NoEvent(..), concat, magic,
IsParties(toParties), Party, ContractId, Update
Eq(..),
Show(..)
) where ) where
import DA.Internal.Prelude import DA.Internal.Prelude
import DA.Internal.Template 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 , unpackPair
) where ) where
import GHC.Types (Opaque, Symbol, magic) import GHC.Types (Opaque, Symbol)
import DA.Internal.Prelude import DA.Internal.Prelude
-- | The `Party` type represents a party to a contract. -- | 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 GHC.Show as GHC
import DA.Types as GHC (Either(..)) import DA.Types as GHC (Either(..))
import GHC.Tuple() 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 $ infixr 0 $
-- | Take a function from `a` to `b` and a value of type `a`, and apply the -- | 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 daml 1.2
-- | MOVE Prelude DAML-LF primitives, just templates/contracts -- | MOVE Prelude DAML-LF primitives, just templates/contracts
module DA.Internal.Template( module DA.Internal.Template where
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
import GHC.Types (magic)
import DA.Internal.LF import DA.Internal.LF
import DA.Internal.Prelude 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`. -- | The signatories of a contract.
create : Template c => c -> Update (ContractId c) signatory : t -> [Party]
create = internalCreate
-- | Exercise a choice on the contract with the given contract ID. -- | The observers of a contract.
exercise : forall c e r . Choice c e r => ContractId c -> e -> Update r observer : t -> [Party]
exercise = internalExercise
-- | Fetch the contract data associated with the given contract ID. -- | A predicate that must be true, otherwise contract creation will fail.
-- ensure : t -> Bool
-- 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
-- | Archive the contract with the given contract ID. -- | The agreement text of a contract.
archive : Template c => ContractId c -> Update () agreement : t -> Text
archive c = exercise c Archive
-- | 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. -- | The stakeholders of a contract: its signatories and observers.
stakeholder : Template c => c -> [Party] stakeholder : Template t => t -> [Party]
stakeholder c = signatory c ++ observer c stakeholder t = signatory t ++ observer t
-- | Look up the contract ID `c` associated with a given contract key `k`. class Template t => Choice t c r | t c -> r where
-- -- | Exercise a choice on the contract with the given contract ID.
-- You must pass the `c` using an explicit type application. For exercise : ContractId t -> c -> Update r
-- instance, if you want to look up a contract of template `Account` by its
-- key `k`, you must call `lookupByKey @Account k`. class Template t => TemplateKey t k | t -> k where
lookupByKey : forall c k. TemplateKey c k => k -> Update (Optional (ContractId c)) -- | The key of a contract.
lookupByKey = internalLookupByKey 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. -- | 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 -- instance, if you want to exercise a choice `Withdraw` on a contract of
-- template `Account` given by its key `k`, you must call -- template `Account` given by its key `k`, you must call
-- `exerciseByKey @Account k Withdraw`. -- `exerciseByKey @Account k Withdraw`.
exerciseByKey : forall c k e r. (TemplateKey c k, Choice c e r) => k -> e -> Update r exerciseByKey : forall t k c r. (TemplateKey t k, Choice t c r) => k -> c -> Update r
exerciseByKey k e = do exerciseByKey k c = do
(cid, _) <- fetchByKey @c k (cid, _) <- fetchByKey @t k
internalExercise cid e exercise cid c
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"
data NonConsuming t = NonConsuming {}
data PreConsuming t = PreConsuming {}
data PostConsuming t = PostConsuming {}
-- | The data type corresponding to the implicit `Archive` -- | The data type corresponding to the implicit `Archive`
-- choice in every template. -- choice in every template.
data Archive = Archive data Archive = Archive {}
deriving (Eq, Show)
instance Template c => Choice c Archive () where data HasKey t = HasKey {}
choiceController c _ = signatory c
choice _ _ _ = return ()
internalExercise c Archive = internalArchive c
-- | HIDE
data NoEvent c e = NoEvent
-- | Accepted ways to specify a list of parties: either a single party, or a list of parties. -- | Accepted ways to specify a list of parties: either a single party, or a list of parties.
class IsParties a where class IsParties a where
@ -176,20 +112,3 @@ instance IsParties [Party] where
instance IsParties (Optional Party) where instance IsParties (Optional Party) where
toParties None = [] toParties None = []
toParties (Some p) = [p] 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. -- | The pieces that make up the DAML language.
module Prelude (module X) where 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.LF as X hiding (Pair(..), TextMap, unpackPair)
import DA.Internal.Template as X import DA.Internal.Template as X
import DA.Internal.Compatible 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 -- NOTE(MH): The cases below are impossible because they only appear
-- in dictionaries for the `Template` and `Choice` classes, which we -- in dictionaries for the `Template` and `Choice` classes, which we
-- ignore below. -- ignore below.
LF.UCreate{}-> error "IMPOSSIBLE" LF.UCreate{} -> error "IMPOSSIBLE"
LF.UExercise{} -> error "IMPOSSIBLE" LF.UExercise{} -> error "IMPOSSIBLE"
LF.UFetch{} -> error "IMPOSSIBLE" LF.UFetch{} -> error "IMPOSSIBLE"
LF.ULookupByKey{} -> error "IMPOSSIBLE" LF.ULookupByKey{} -> error "IMPOSSIBLE"
LF.UFetchByKey{} -> 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 startFromExpr seen world e = case e of
LF.EVar _ -> Set.empty LF.EVar _ -> Set.empty
-- NOTE(MH): We ignore the dictionaries for the `Template` and `Choice` -- NOTE(MH/RJR): Do not explore the `$fXInstance` dictionary because it
-- classes because they contain too many ledger actions. We detect the -- contains all the ledger actions and therefore creates too many edges
-- `create`, `archive` and `exercise` functions which take these -- in the graph. We instead detect calls to the `create`, `archive` and
-- dictionaries as arguments instead. -- `exercise` methods from `Template` and `Choice` instances.
LF.EVal (LF.Qualified _ _ (LF.ExprValName ref)) LF.EVal (LF.Qualified _ _ (LF.ExprValName ref))
| "$fTemplate" `T.isPrefixOf` ref || "$fChoice" `T.isPrefixOf` ref -> Set.empty | "$f" `T.isPrefixOf` ref && "Instance" `T.isSuffixOf` ref -> Set.empty
LF.EVal ref -> case LF.lookupValue ref world of LF.EVal ref -> case LF.lookupValue ref world of
Right LF.DefValue{..} Right LF.DefValue{..}
| ref `Set.member` seen -> Set.empty | ref `Set.member` seen -> Set.empty
| otherwise -> startFromExpr (Set.insert ref seen) world dvalBody | otherwise -> startFromExpr (Set.insert ref seen) world dvalBody
Left _ -> error "This should not happen" Left _ -> error "This should not happen"
LF.EUpdate upd -> startFromUpdate seen world upd 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 EInternalTemplateVal "create" `LF.ETyApp` LF.TCon tpl `LF.ETmApp` _dict
-> Set.singleton (ACreate tpl) -> 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 -> EInternalTemplateVal "archive" `LF.ETyApp` LF.TCon tpl `LF.ETmApp` _dict ->
Set.singleton (AExercise tpl (LF.ChoiceName "Archive")) 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 expr -> Set.unions $ map (startFromExpr seen world) $ children expr
pattern EInternalTemplateVal :: T.Text -> LF.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"], srcs = [":bond-trading"],
heap_limit = "200M" if is_windows else "100M", heap_limit = "200M" if is_windows else "100M",
main = "bond-trading/Test.daml", main = "bond-trading/Test.daml",
stack_limit = "35K", stack_limit = "300K" if is_windows else "35K",
) )
filegroup( filegroup(

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

@ -10,10 +10,8 @@
daml 1.2 daml 1.2
module ComposedKey where module ComposedKey where
import Prelude hiding (Template (..), TemplateKey (..), Choice (..), Archive (..), create, fetch, fetchByKey, archive, exercise)
import DA.Assert import DA.Assert
import DA.Text import DA.Text
import GenericTemplates
import GenTemplCompat import GenTemplCompat
-- For any instantiation, `k` has to be the key type of `t`. -- 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 daml 1.2
module EqContractId where module EqContractId where
data Foo = Foo{p : Party} template Foo with
p: Party
instance Template Foo where where
signatory Foo{p} = [p] signatory p
data Bar = Bar{}
instance Choice Foo Bar () where
choiceController Foo{p} _ = [p]
choice _ _ _ = return ()
main = scenario do main = scenario do
alice <- getParty "Alice" alice <- getParty "Alice"

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

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

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

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

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

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

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

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

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

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

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

@ -4,18 +4,18 @@
daml 1.2 daml 1.2
module Self where module Self where
data Self = Self {p : Party} template Self with
p: Party
where
signatory p
instance Template Self where controller p can
signatory Self {p} = [p] Same : ()
with other: ContractId Self
data Same = Same (ContractId Self) do assert (self == other)
instance Choice Self Same () where
choiceController Self{p} _ = [p]
choice _ self (Same other) = assert (self == other)
main = scenario do main = scenario do
alice <- getParty "Alice" alice <- getParty "Alice"
submit alice do submit alice do
cid1 <- create Self{p = alice} cid1 <- create Self with p = alice
exercise cid1 (Same cid1) 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. -- Copyright (c) 2019, Digital Asset (Switzerland) GmbH and/or its affiliates.
-- All rights reserved. -- 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 -- @ERROR expected serializable type
daml 1.2 daml 1.2
module Unserializable where module Unserializable where
data Unserializable = Unserializable{f : Text -> Text} data Unserializable = Unserializable with
p : Party
f : Text -> Text
instance Template Unserializable where class UnserializableInstance where
signatory Unserializable{} = [] 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 { digraph G {
compound=true; compound=true;
rankdir=LR; rankdir=LR;
subgraph cluster_Group{ subgraph cluster_Message{
n0[label=Create][color=green]; n0[label=Create][color=green];
n1[label=Archive][color=red]; n1[label=Archive][color=red];
label=Group;color=blue label=Message;color=blue
}subgraph cluster_Invitation{ }subgraph cluster_Invitation{
n2[label=Create][color=green]; n2[label=Create][color=green];
n3[label=Archive][color=red]; n3[label=Archive][color=red];
label=Invitation;color=blue label=Invitation;color=blue
}subgraph cluster_Message{ }subgraph cluster_Group{
n4[label=Create][color=green]; n4[label=Create][color=green];
n5[label=Archive][color=red]; n5[label=Archive][color=red];
label=Message;color=blue label=Group;color=blue
}subgraph cluster_Membership{ }subgraph cluster_Membership{
n6[label=Create][color=green]; n6[label=Create][color=green];
n7[label=Archive][color=red]; n7[label=Archive][color=red];
n8[label=Membership_Shutdown_Indirect][color=green]; n8[label=Membership_Join][color=red];
n9[label=Membership_Shutdown][color=red]; n9[label=Membership_Leave][color=red];
n10[label=Membership_SendMessage][color=green]; n10[label=Membership_SendMessage][color=green];
n11[label=Membership_Leave][color=red]; n11[label=Membership_Shutdown_Indirect][color=green];
n12[label=Membership_Join][color=red]; n12[label=Membership_Shutdown][color=red];
label=Membership;color=blue label=Membership;color=blue
}n8->n9 }n8->n6
n9->n1 n9->n6
n10->n4 n10->n0
n11->n6 n11->n12
n12->n6 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) => case Some(module) =>
val actualTypes: Set[String] = val actualTypes: Set[String] =
module.getDataTypesList.asScala.toSet.map((t: DamlLf1.DefDataType) => name(t.getName)) 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 val archive2Modules = archive2.getDamlLf1.getModulesList.asScala

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

@ -9,25 +9,17 @@ module AuthorizedDivulgence where
-- Authorized fetch -- Authorized fetch
---------------------------------------------------------------------------------------------------- ----------------------------------------------------------------------------------------------------
data Secret = Secret template Secret with
{ p : Party p : Party
, mySecret : Text mySecret : Text
} where
signatory p
instance Template Secret where template RevealYourSecret with
signatory this@Secret{..} = [p] p : Party
observer this@Secret{..} = [] secretCid : ContractId Secret
agreement this@Secret{..} = "" where
signatory p
data RevealYourSecret = RevealYourSecret
{ p : Party
, secretCid : ContractId Secret
}
instance Template RevealYourSecret where
signatory this@RevealYourSecret{..} = [p]
observer this@RevealYourSecret{..} = []
agreement this@RevealYourSecret{..} = ""
-- This scenario succeeds only if the flag +DontDivulgeContractIdsInCreateArguments is turned on -- This scenario succeeds only if the flag +DontDivulgeContractIdsInCreateArguments is turned on
test_authorizedFetch = scenario do 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. -- Testing no divulgence of create arguments. We test with the classic swap scenario.
---------------------------------------------------------------------------------------------------- ----------------------------------------------------------------------------------------------------
data Iou = Iou template Iou with
{ owner : Party owner : Party
, obligor : 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 template Swap1 with
signatory Iou{..} = [obligor] p1 : Party
observer Iou{..} = [owner] p2 : Party
agreement _ = "" where
signatory p1
observer p2
data Sell = Sell controller p1 can
{ newOwner : Party GoSwap1 : ContractId Swap2
} with cid1 : ContractId Iou
do create Swap2 with p1; p2; cid1
instance Choice Iou Sell (ContractId Iou) where GoSwap1WithFetch : ContractId Swap2
choiceController Iou{..} _ = [owner] with cid1 : ContractId Iou
choice this@Iou{..} self Sell{..} = create this{owner = newOwner} do
fetch cid1
create Swap2 with p1; p2; cid1
data Swap1 = Swap1 template Swap2 with
{ p1 : Party p1 : Party
, p2 : Party p2 : Party
} cid1 : ContractId Iou
where
signatory p1
observer p2
instance Template Swap1 where controller p2 can
signatory Swap1{..} = [p1] GoSwap2 : ()
observer Swap1{..} = [p2] with cid2 : ContractId Iou
agreement _ = "" do
exercise cid1 Sell with newOwner = p2
data Swap2 = Swap2 exercise cid2 Sell with newOwner = p1
{ p1 : Party pure ()
, 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 ()
-- We're testing the classic swap example. -- We're testing the classic swap example.
-- This scenario should fail now if the DontDivulgeContractIdsInCreateArguments flag is set because -- 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 module DontDiscloseNonConsumingExercisesToObservers where
data NonObservable = NonObservable template NonObservable with
{ p : Party p : Party
, obs : Party obs : Party
} where
signatory p
observer obs
controller p can
nonconsuming CreateEvent : ContractId Event
do create $ Event p
instance Template NonObservable where template Event with
signatory NonObservable{..} = [p] p : Party
observer NonObservable{..} = [obs] where
signatory p
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
-- Bob should not be able to fetch when DontDiscloseNonConsumingExercisesToObservers is set, -- 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 ensure amount > 0
signatory issuer, owner signatory issuer, owner
observer regulators observer regulators
agreement issuer <> " will pay " <> owner <> " " <> (show amount) agreement issuer <> " will pay " <> owner <> " " <> show amount
choice Transfer : ContractId Iou choice Transfer : ContractId Iou
with with
@ -38,145 +38,117 @@ template Iou
The `class Template` (defined by the DAML standard library) represents the set of all contract types: The `class Template` (defined by the DAML standard library) represents the set of all contract types:
```haskell ```haskell
class Template c where class Template t where
-- | Predicate that must hold for the succesful creation of the contract. signatory : t -> [Party]
ensure : c -> Bool ; ensure _ = True observer : t -> [Party]
-- | The signatories of a contract. ensure : t -> Bool
signatory : c -> [Party] agreement : t -> Text
-- | The observers of a contract. create : t -> Update (ContractId t)
observer : c -> [Party] ; observer _ = [] fetch : ContractId t -> Update t
-- | The agreement text of a contract. archive : ContractId t -> Update ()
agreement : c -> Text ; agreement _ = ""
``` ```
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 ```haskell
data Iou = Iou { data Iou = Iou with
issuer : Party issuer : Party
, owner : Party owner : Party
, currency : Party currency : Party
, amount : Float amount : Decimal
, account : Party account : Party
, regulators :[Party] } deriving (Eq, Show) 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 ```haskell
instance Template Iou where class IouInstance where
ensure this@Iou{..} = amount > 0.0 signatoryIou : Iou -> [Party]
signatory this@Iou{..} = concat [toParties issuer, toParties owner] signatoryIou this@Iou{..} = [issuer, owner]
observer this@Iou{..} = concat [toParties owner, toParties regulators] observerIou : Iou -> [Party]
agreement this@Iou{..} = issuer <> " will pay " <> owner <> " " <> (show amount) 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 ```haskell
class Template c => Choice c e r | c e -> r where class Template t => Choice t c r | t c -> r where
consuming : NoEvent c e -> ChoiceType ; consuming _ = Consuming exercise : ContractId t -> c -> Update r
choiceController : c -> e -> [Party]
choice : c -> ContractId c -> e -> 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`: The `instance` declaration establishes the triple `(Iou, Transfer, ContractId Iou)` as satisfying the `Choice` relation:
```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:
```haskell ```haskell
instance Choice Iou Transfer (ContractId Iou) where instance Choice Iou Transfer (ContractId Iou) where
choiceController this@Iou{..} arg@Transfer{..} = [owner] exercise = exerciseIouTransfer
choice this@Iou{..} self arg@Transfer{..} = create this with owner = newOwner
``` ```
### Example (2) ### 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 ```haskell
template Iou class Template t => TemplateKey t k | t -> k where
with key : t -> k
issuer : Party fetchByKey : k -> Update (ContractId t, t)
owner : Party lookupByKey : k -> Update (Optional (ContractId t))
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)
``` ```
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`. In the following `Enrollment` contract, there are no choices but there are declarations of `key` and `maintainer`.
```haskell ```haskell
data Course = data Course =
Course with Course with
@ -199,15 +171,192 @@ template Enrollment
key reg : Registration key reg : Registration
maintainer key.course.institution maintainer key.course.institution
``` ```
What the above desugars to is shown below.
```haskell
data Course = ...
data Registration = ...
instance Template Enrollment where The `Course` and `Registration` data types remain as they are, but the `Enrollment` template results in several pieces after desugaring.
signatory this@Enrollment{..} = concat [toParties reg.student, toParties reg.course.institution]
```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 instance TemplateKey Enrollment Registration where
key this@Enrollment{..} = reg key = keyEnrollment
maintainer key = concat [toParties key.course.institution] 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.