mirror of
https://github.com/digital-asset/daml.git
synced 2024-09-20 09:17:43 +03:00
Generic templates: support contract keys and fetchByKey (#1444)
* Generic templates: support contract keys and fetchByKey `lookupByKey` will be done in a separate PR. This is part of #1387. * Run generic templates compatability test only for DAML-LF >= 1.4
This commit is contained in:
parent
70f748379a
commit
8202df8201
@ -327,7 +327,7 @@ convertGenericTemplate :: Env -> GHC.Expr Var -> ConvertM (Template, LF.Expr)
|
||||
convertGenericTemplate env x
|
||||
| (dictCon, args) <- collectArgs x
|
||||
, (tyArgs, args) <- span isTypeArg args
|
||||
, Just (superClassDicts, signatories : observers : ensure : agreement : create : fetch : archive : choices) <- span isSuperClassDict <$> mapM isVar_maybe (dropWhile isTypeArg args)
|
||||
, Just (superClassDicts, signatories : observers : ensure : agreement : create : _fetch : archive : keyAndChoices) <- span isSuperClassDict <$> mapM isVar_maybe (dropWhile isTypeArg args)
|
||||
, Just (polyType, _) <- splitFunTy_maybe (varType create)
|
||||
, Just (monoTyCon, unwrapCo) <- findMonoTyp polyType
|
||||
= do
|
||||
@ -348,10 +348,29 @@ convertGenericTemplate env x
|
||||
tplObservers <- applyThis <$> convertExpr env (Var observers)
|
||||
let tplPrecondition = ETrue
|
||||
let tplAgreement = mkEmptyText
|
||||
let tplKey = Nothing
|
||||
archive <- convertExpr env (Var archive)
|
||||
(tplKey, key, choices) <- case keyAndChoices of
|
||||
hasKey : key : maintainers : _fetchByKey : choices
|
||||
| TypeCon (Is "HasKey") _ <- varType hasKey -> do
|
||||
_ :-> keyType <- convertType env (varType key)
|
||||
hasKey <- convertExpr env (Var hasKey)
|
||||
key <- convertExpr env (Var key)
|
||||
maintainers <- convertExpr env (Var maintainers)
|
||||
let selfField = FieldName "contractId"
|
||||
let thisField = FieldName "contract"
|
||||
tupleTyCon <- qDA_Types env $ mkTypeCon ["Tuple2"]
|
||||
let tupleType = TypeConApp tupleTyCon [TContractId polyType, polyType]
|
||||
let fetchByKey =
|
||||
ETmLam (mkVar "key", keyType) $
|
||||
EUpdate $ UBind (Binding (res, TTuple [(selfField, TContractId monoType), (thisField, monoType)]) $ EUpdate $ UFetchByKey $ RetrieveByKey monoTyCon $ EVar $ mkVar "key") $
|
||||
EUpdate $ UPure (typeConAppToType tupleType) $ ERecCon tupleType
|
||||
[ (FieldName "_1", unwrapCid $ ETupleProj selfField $ EVar res)
|
||||
, (FieldName "_2", unwrapTpl $ ETupleProj thisField $ EVar res)
|
||||
]
|
||||
pure (Just $ TemplateKey keyType (applyThis key) (ETmApp maintainers hasKey), [hasKey, key, maintainers, fetchByKey], choices)
|
||||
choices -> pure (Nothing, [], choices)
|
||||
let convertGenericChoice :: [Var] -> ConvertM (TemplateChoice, [LF.Expr])
|
||||
convertGenericChoice [consumption, controllers, action, exercise] = do
|
||||
convertGenericChoice [consumption, controllers, action, _exercise] = do
|
||||
TContractId _ :-> _ :-> argType@(TConApp argTCon _) :-> TUpdate resType <- convertType env (varType action)
|
||||
let chcLocation = Nothing
|
||||
let chcName = ChoiceName $ T.intercalate "." $ unTypeConName $ qualObject argTCon
|
||||
@ -398,7 +417,7 @@ convertGenericTemplate env x
|
||||
dictCon <- convertExpr env dictCon
|
||||
tyArgs <- mapM (convertArg env) tyArgs
|
||||
-- NOTE(MH): The additional lambda is DICTIONARY SANITIZATION step (3).
|
||||
let tmArgs = map (TmArg . ETmLam (mkVar "_", TUnit)) $ superClassDicts ++ [signatories, observers, ensure, agreement, create, fetch, archive] ++ concat choices
|
||||
let tmArgs = map (TmArg . ETmLam (mkVar "_", TUnit)) $ superClassDicts ++ [signatories, observers, ensure, agreement, create, fetch, archive] ++ key ++ concat choices
|
||||
let dict = mkEApps dictCon $ tyArgs ++ tmArgs
|
||||
pure (Template{..}, dict)
|
||||
where
|
||||
@ -587,6 +606,26 @@ convertBind env (NonRec name x)
|
||||
| DFunId _ <- idDetails name
|
||||
, TypeCon (QIsTpl "Template") [t] <- varType name
|
||||
= withRange (convNameLoc name) $ liftA2 (++) (convertTemplate env x) (convertBind2 env (NonRec name x))
|
||||
-- NOTE(MH, #1387): If we decide to do the rewriting of maintainers from
|
||||
-- `this` to `key` for generic templates as well, this code will do
|
||||
-- some part of the job. Currently, it would only work for non-generic
|
||||
-- templates though. I'd like to leave it here until we've made a
|
||||
-- decision so I don't have to figure it out again.
|
||||
-- | Just tplName <- stripPrefix "$dmmaintainerFromKey" (is name)
|
||||
-- = do
|
||||
-- name'@(_, splitTForalls -> (tvs, _dictType :-> hasKeyType :-> keyType :-> _)) <- convValWithType env name
|
||||
-- key <- envFindBindString env ("$dmkey" ++ tplName)
|
||||
-- maintainer <- envFindBindString env ("$dmmaintainer" ++ tplName)
|
||||
-- case (key, maintainer) of
|
||||
-- (Lam keyDict (Lam keyThis keyExpr), Lam maintainerDict (Lam maintainerThis maintainerExpr)) -> do
|
||||
-- unless (keyDict == maintainerDict) $
|
||||
-- unhandled "generic template key with different dict binders" (keyDict, maintainerDict)
|
||||
-- keyExpr <- convertKeyExpr env keyThis keyExpr
|
||||
-- maintainerExpr <- convertKeyExpr env maintainerThis maintainerExpr
|
||||
-- maintainerExpr <- rewriteMaintainer env keyExpr maintainerExpr
|
||||
-- maintainerDict <- convVarWithType env maintainerDict
|
||||
-- pure [defValue name name' $ mkETyLams tvs $ mkETmLams [maintainerDict, (mkVar "_", hasKeyType), (mkVar "$key", keyType)] maintainerExpr]
|
||||
-- _ -> unhandled "generic template key definition" name
|
||||
| DFunId _ <- idDetails name
|
||||
, TypeCon (Is tplInst) _ <- varType name
|
||||
, "Instance" `isSuffixOf` tplInst
|
||||
|
@ -4,10 +4,13 @@
|
||||
-- Check that non-generic templates work with the new de/re-sugaring of
|
||||
-- templates for DAML-LF < 1.5 as well. This test can be deleted when
|
||||
-- generic templates (#1387) land in master.
|
||||
-- Since we need complex contract keys for this, it only works for
|
||||
-- DAML-LF >= 1.4.
|
||||
-- @SINCE-LF 1.4
|
||||
daml 1.2
|
||||
module GenTemplCompat where
|
||||
|
||||
import Prelude hiding (Template (..), Choice (..), Archive (..), create, fetch, archive, exercise)
|
||||
import Prelude hiding (Template (..), TemplateKey (..), Choice (..), Archive (..), create, fetch, fetchByKey, archive, exercise)
|
||||
import DA.Assert
|
||||
import GenericTemplates
|
||||
|
||||
@ -26,6 +29,10 @@ instance FactInstance => Template Fact where
|
||||
fetch = fetchFact
|
||||
archive = archiveFact
|
||||
|
||||
instance FactInstance => TemplateKey Fact (Party, Text) where
|
||||
key = keyFact
|
||||
fetchByKey = fetchByKeyFact
|
||||
|
||||
instance FactInstance => Choice Fact Archive () where
|
||||
exercise = exerciseFactArchive
|
||||
|
||||
@ -58,6 +65,15 @@ class FactInstance where
|
||||
archiveFact : ContractId Fact -> Update ()
|
||||
archiveFact cid = exerciseFactArchive cid Archive
|
||||
|
||||
hasKeyFact : HasKey Fact
|
||||
hasKeyFact = HasKey
|
||||
keyFact : Fact -> (Party, Text)
|
||||
keyFact this@Fact{..} = (owner, name)
|
||||
maintainerFact : HasKey Fact -> (Party, Text) -> [Party]
|
||||
maintainerFact HasKey key = [fst key]
|
||||
fetchByKeyFact : (Party, Text) -> Update (ContractId Fact, Fact)
|
||||
fetchByKeyFact = error "code will be injected by the compiler"
|
||||
|
||||
consumptionFactArchive : PreConsuming Fact
|
||||
consumptionFactArchive = PreConsuming
|
||||
controllerFactArchive : Fact -> Archive -> [Party]
|
||||
@ -95,11 +111,14 @@ test = scenario do
|
||||
alice <- getParty "Alice"
|
||||
let fact = Fact with owner = alice; name = "Answer"; value = 42
|
||||
|
||||
-- Check that create, fetch and exercising non- and pre-consuming choices work.
|
||||
-- Check that create, fetch, fetchByKey and exercising non- and pre-consuming choices work.
|
||||
factId <- submit alice do create fact
|
||||
submit alice do exercise factId Touch
|
||||
fact' <- submit alice do fetch factId
|
||||
fact' === fact
|
||||
(factId', fact') <- submit alice do fetchByKey @Fact (alice, "Answer")
|
||||
factId' === factId
|
||||
fact' === fact
|
||||
submit alice do archive factId
|
||||
submitMustFail alice do fetch factId
|
||||
|
||||
|
@ -7,7 +7,7 @@
|
||||
daml 1.2
|
||||
module GenericTemplates where
|
||||
|
||||
import Prelude hiding (Template (..), Choice (..), Archive (..), create, fetch, archive, exercise)
|
||||
import Prelude hiding (Template (..), TemplateKey (..), Choice (..), Archive (..), create, fetch, fetchByKey, archive, exercise)
|
||||
|
||||
class Template t where
|
||||
signatory : t -> [Party]
|
||||
@ -18,6 +18,11 @@ class Template t where
|
||||
fetch : ContractId t -> Update t
|
||||
archive : ContractId t -> Update ()
|
||||
|
||||
class Template t => TemplateKey t k | t -> k where
|
||||
key : t -> k
|
||||
fetchByKey : k -> Update (ContractId t, t)
|
||||
|
||||
|
||||
class Template t => Choice t c r | t c -> r where
|
||||
exercise : ContractId t -> c -> Update r
|
||||
|
||||
@ -29,3 +34,5 @@ data NonConsuming t = NonConsuming {}
|
||||
data PreConsuming t = PreConsuming {}
|
||||
|
||||
data PostConsuming t = PostConsuming {}
|
||||
|
||||
data HasKey t = HasKey {}
|
||||
|
@ -6,7 +6,8 @@
|
||||
daml 1.2
|
||||
module IouDSL where
|
||||
|
||||
import Prelude hiding (Template (..), Choice (..), Archive (..), create, fetch, archive, exercise)
|
||||
import Prelude hiding (Template (..), TemplateKey (..), Choice (..), Archive (..), create, fetch, fetchByKey, archive, exercise)
|
||||
import DA.Assert
|
||||
import GenericTemplates
|
||||
import ProposalDSL
|
||||
|
||||
@ -86,12 +87,17 @@ test = scenario do
|
||||
alice <- getParty "alice"
|
||||
bank <- getParty "bank"
|
||||
let iou = Iou with issuer = bank; owner = alice; amount = 10.0
|
||||
let prop = Proposal with asset = iou; receivers = [alice]; name = "present"
|
||||
propId <- submit bank do
|
||||
create Proposal with asset = iou; receivers = [alice]
|
||||
create prop
|
||||
(propId', prop') <- submit bank do
|
||||
fetchByKey @(Proposal Iou) ([bank], "present")
|
||||
propId' === propId
|
||||
prop' === prop
|
||||
iouId <- submit alice do
|
||||
exercise propId Accept
|
||||
iou' <- submit alice do
|
||||
fetch iouId
|
||||
assert $ iou' == iou
|
||||
iou' === iou
|
||||
submit alice do
|
||||
exercise iouId Burn
|
||||
|
@ -11,7 +11,7 @@ module ProposalDSL
|
||||
, ProposalInstance
|
||||
) where
|
||||
|
||||
import Prelude hiding (Template (..), Choice (..), Archive (..), create, fetch, archive, exercise)
|
||||
import Prelude hiding (Template (..), TemplateKey (..), Choice (..), Archive (..), create, fetch, fetchByKey, archive, exercise)
|
||||
import DA.List
|
||||
import DA.Text
|
||||
import GenericTemplates
|
||||
@ -20,6 +20,7 @@ import GenericTemplates
|
||||
data Proposal t = Proposal with
|
||||
asset : t
|
||||
receivers : [Party]
|
||||
name : Text
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance ProposalInstance t => Template (Proposal t) where
|
||||
@ -31,6 +32,10 @@ instance ProposalInstance t => Template (Proposal t) where
|
||||
fetch = fetchProposal
|
||||
archive = archiveProposal
|
||||
|
||||
instance ProposalInstance t => TemplateKey (Proposal t) ([Party], Text) where
|
||||
key = keyProposal
|
||||
fetchByKey = fetchByKeyProposal
|
||||
|
||||
|
||||
data Accept = Accept{}
|
||||
deriving (Eq, Show)
|
||||
@ -62,6 +67,15 @@ class Template t => ProposalInstance t where
|
||||
archiveProposal : ContractId (Proposal t) -> Update ()
|
||||
archiveProposal cid = exerciseProposalArchive cid Archive
|
||||
|
||||
hasKeyProposal : HasKey (Proposal t)
|
||||
hasKeyProposal = HasKey
|
||||
keyProposal : Proposal t -> ([Party], Text)
|
||||
keyProposal this@Proposal{..} = (signatory this, name)
|
||||
maintainerProposal : HasKey (Proposal t) -> ([Party], Text) -> [Party]
|
||||
maintainerProposal HasKey key = fst key
|
||||
fetchByKeyProposal : ([Party], Text) -> Update (ContractId (Proposal t), Proposal t)
|
||||
fetchByKeyProposal = error "code will be injected by the compiler"
|
||||
|
||||
consumptionProposalArchive : PreConsuming (Proposal t)
|
||||
consumptionProposalArchive = PreConsuming
|
||||
controllerProposalArchive : Proposal t -> Archive -> [Party]
|
||||
|
Loading…
Reference in New Issue
Block a user