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

Add AnyChoice type to DAML (#3152)

Browse Source 
* Add AnyChoice type to DAML

fixes #3131

* Fix ProposalDesugared

* Fix trigger tests

* Use the proper ghc-lib urls
This commit is contained in:
Moritz Kiefer 2019-10-10 18:46:55 +02:00 committed by mergify[bot]
parent 172996e4db
commit 48eb360a4f
9 changed files with 171 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
WORKSPACE
View File

@ -484,12 +484,12 @@ GRPC_HASKELL_COMMIT = "11681ec6b99add18a8d1315f202634aea343d146"
GRPC_HASKELL_HASH = "c6201f4e2fd39f25ca1d47b1dac4efdf151de88a2eb58254d61abc2760e58fda"
GHC_LIB_VERSION = "8.8.1.20190925"
GHC_LIB_VERSION = "8.8.1.20191010"
http_archive(
name = "haskell_ghc__lib__parser",
build_file = "//3rdparty/haskell:BUILD.ghc-lib-parser",
sha256 = "02c71094a0bb06d6f6c4bbd444f9a26804c8eca423cc77fd3824ccd498ddaefe",
sha256 = "5f1226f407ddc728a17bbafbf97c5b908ce88f19856ae32819a8a0a589558a2b",
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)],
)
@ -571,7 +571,7 @@ hazel_repositories(
# Read [Working on ghc-lib] for ghc-lib update instructions at
# https://github.com/digital-asset/daml/blob/master/ghc-lib/working-on-ghc-lib.md.
hazel_ghclibs(GHC_LIB_VERSION, "02c71094a0bb06d6f6c4bbd444f9a26804c8eca423cc77fd3824ccd498ddaefe", "4aa88ed404dcf8a67f712ad37d8ad9f4ed51fe6180c15978a97034acf7dee834") +
hazel_ghclibs(GHC_LIB_VERSION, "5f1226f407ddc728a17bbafbf97c5b908ce88f19856ae32819a8a0a589558a2b", "fbc246d396db5dd3d1608f992b4efed86151d0e66f9fd13c83286e4f7273e8ea") +
hazel_github_external("digital-asset", "hlint", "193b3eb89d186ae901ff6d95a70653258ed5eed9", "4f99badd7058b10f89207622bc719bd22b65ad401bf21cf8b33a7d79bbc000f6") +
hazel_github_external("awakesecurity", "proto3-wire", "4f355bbac895d577d8a28f567ab4380f042ccc24", "031e05d523a887fbc546096618bc11dceabae224462a6cdd6aab11c1658e17a3") +
hazel_github_external(

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

@ -338,6 +338,7 @@ convertGenericTemplate env x
, ETmApp $ mkETyApps (EBuiltin BECoerceContractId) [monoType, polyType]
, ETmApp $ mkETyApps (EBuiltin BECoerceContractId) [polyType, monoType]
)
stdlibRef <- packageNameToPkgRef env damlStdlib
let tplTypeCon = qualObject monoTyCon
let tplParam = this
let applyThis e = ETmApp e $ unwrapTpl $ EVar this
@ -374,7 +375,7 @@ convertGenericTemplate env x
pure (Just $ TemplateKey keyType (applyThis key) (ETmApp maintainers hasKey), [hasKey, key, maintainers, fetchByKey, lookupByKey], choices)
choices -> pure (Nothing, [], choices)
let convertGenericChoice :: [Var] -> ConvertM (TemplateChoice, [LF.Expr])
convertGenericChoice [consumption, controllers, action, _exercise] = do
convertGenericChoice [consumption, controllers, action, _exercise, _toAnyChoice, _fromAnyChoice] = do
(argType, argTCon, resType) <- convertType env (varType action) >>= \case
TContractId _ :-> _ :-> argType@(TConApp argTCon _) :-> TUpdate resType -> pure (argType, argTCon, resType)
t -> unhandled "Choice action type" (varType action)
@ -405,9 +406,31 @@ convertGenericTemplate env x
let exercise =
mkETmLams [(self, TContractId polyType), (arg, argType)] $
EUpdate $ UExercise monoTyCon chcName (wrapCid $ EVar self) Nothing (EVar arg)
pure (TemplateChoice{..}, [consumption, controllers, action, exercise])
let anyChoiceTy = TypeConApp (Qualified stdlibRef (mkModName ["DA", "Internal", "LF"]) (mkTypeCon ["AnyChoice"])) []
let anyChoiceField = mkField "getAnyChoice"
let toAnyChoice =
if envLfVersion env `supports` featureAnyType
then ETyLam
(mkTypeVar "proxy", KArrow KStar KStar)
(ETmLam
(mkVar "_", TApp (TVar $ mkTypeVar "proxy") polyType)
(ETmLam chcArgBinder $ ERecCon anyChoiceTy [(anyChoiceField, EToAny argType $ EVar arg)]))
else EBuiltin BEError `ETyApp`
(TForall (mkTypeVar "proxy", KArrow KStar KStar) (TApp (TVar $ mkTypeVar "proxy") polyType :-> argType :-> typeConAppToType anyChoiceTy)) `ETmApp`
EBuiltin (BEText "toAnyChoice is not supported in this DAML-LF version")
let fromAnyChoice =
if envLfVersion env `supports` featureAnyType
then ETyLam
(mkTypeVar "proxy", KArrow KStar KStar)
(ETmLam
(mkVar "_", TApp (TVar $ mkTypeVar "proxy") polyType)
(ETmLam (mkVar "any", typeConAppToType anyChoiceTy) $ EFromAny argType $ ERecProj anyChoiceTy anyChoiceField $ EVar $ mkVar "any"))
else EBuiltin BEError `ETyApp`
(TForall (mkTypeVar "proxy", KArrow KStar KStar) (TApp (TVar $ mkTypeVar "proxy") polyType :-> typeConAppToType anyChoiceTy :-> TOptional argType)) `ETmApp`
EBuiltin (BEText "toAnyChoice is not supported in this DAML-LF version")
pure (TemplateChoice{..}, [consumption, controllers, action, exercise, toAnyChoice, fromAnyChoice])
convertGenericChoice es = unhandled "generic choice" es
(tplChoices, choices) <- first NM.fromList . unzip <$> mapM convertGenericChoice (chunksOf 4 choices)
(tplChoices, choices) <- first NM.fromList . unzip <$> mapM convertGenericChoice (chunksOf 6 choices)
superClassDicts <- mapM (convertExpr env . Var) superClassDicts
signatories <- convertExpr env (Var signatories)
observers <- convertExpr env (Var observers)
@ -415,18 +438,20 @@ convertGenericTemplate env x
agreement <- convertExpr env (Var agreement)
let create = ETmLam (this, polyType) $ EUpdate $ UBind (Binding (self, TContractId monoType) $ EUpdate $ UCreate monoTyCon $ wrapTpl $ EVar this) $ EUpdate $ UPure (TContractId polyType) $ unwrapCid $ EVar self
let fetch = ETmLam (self, TContractId polyType) $ EUpdate $ UBind (Binding (this, monoType) $ EUpdate $ UFetch monoTyCon $ wrapCid $ EVar self) $ EUpdate $ UPure polyType $ unwrapTpl $ EVar this
let anyTemplateTy = TypeConApp (Qualified stdlibRef (mkModName ["DA", "Internal", "LF"]) (mkTypeCon ["AnyTemplate"])) []
let anyTemplateField = mkField "getAnyTemplate"
let toAnyTemplate =
if envLfVersion env `supports` featureAnyType
then ETmLam (this, polyType) $ EToAny (TCon monoTyCon) (wrapTpl $ EVar this)
else EBuiltin BEError `ETyApp` (polyType :-> TUnit) `ETmApp` EBuiltin (BEText "toAnyTemplate is not supported in this DAML-LF version")
then ETmLam (this, polyType) $ ERecCon anyTemplateTy [(anyTemplateField, EToAny (TCon monoTyCon) (wrapTpl $ EVar this))]
else EBuiltin BEError `ETyApp` (polyType :-> typeConAppToType anyTemplateTy) `ETmApp` EBuiltin (BEText "toAnyTemplate is not supported in this DAML-LF version")
let fromAnyTemplate =
if envLfVersion env `supports` featureAnyType
then ETmLam (anyTpl, TAny) $
ECase (EFromAny (TCon monoTyCon) (EVar anyTpl))
then ETmLam (anyTpl, typeConAppToType anyTemplateTy) $
ECase (EFromAny (TCon monoTyCon) (ERecProj anyTemplateTy anyTemplateField (EVar anyTpl)))
[ CaseAlternative CPNone $ ENone polyType
, CaseAlternative (CPSome self) $ ESome polyType $ unwrapTpl $ EVar self
]
else EBuiltin BEError `ETyApp` (TUnit :-> TOptional polyType) `ETmApp` EBuiltin (BEText "fromAnyTemplate is not supported in this DAML-LF version")
else EBuiltin BEError `ETyApp` (typeConAppToType anyTemplateTy :-> TOptional polyType) `ETmApp` EBuiltin (BEText "fromAnyTemplate is not supported in this DAML-LF version")
tyArgs <- mapM (convertType env) tyArgs
-- NOTE(MH): The additional lambda is DICTIONARY SANITIZATION step (3).
let tmArgs = map (ETmLam (mkVar "_", TUnit)) $ superClassDicts ++ [signatories, observers, ensure, agreement, create, fetch, archive, toAnyTemplate, fromAnyTemplate] ++ key ++ concat choices
@ -549,7 +574,7 @@ convertBind env (name, x)
--
-- TODO(MH): The check is an approximation which will fail when users
-- start the name of their own methods with, say, `_exercise`.
| any (`T.isPrefixOf` getOccText name) [ "$" <> prefix <> "_" <> method | prefix <- ["dm", "c"], method <- ["create", "fetch", "exercise", "toAnyTemplate", "fromAnyTemplate", "fetchByKey", "lookupByKey"] ]
| any (`T.isPrefixOf` getOccText name) [ "$" <> prefix <> "_" <> method | prefix <- ["dm", "c"], method <- ["create", "fetch", "exercise", "toAnyTemplate", "fromAnyTemplate", "fetchByKey", "lookupByKey", "toAnyChoice", "fromAnyChoice"] ]
= pure []
-- NOTE(MH): Our inline return type syntax produces a local letrec for
-- recursive functions. We currently don't support local letrecs.
@ -584,7 +609,7 @@ convertBind env (name, x)
-- during conversion to DAML-LF together with their constructors since we
-- deliberately remove 'GHC.Types.Opaque' as well.
internalTypes :: UniqSet FastString
internalTypes = mkUniqSet ["Scenario","Update","ContractId","Time","Date","Party","Pair", "TextMap", "AnyTemplate"]
internalTypes = mkUniqSet ["Scenario","Update","ContractId","Time","Date","Party","Pair", "TextMap", "Any"]
internalFunctions :: UniqFM (UniqSet FastString)
internalFunctions = listToUFM $ map (bimap mkModuleNameFS mkUniqSet)
@ -1205,7 +1230,7 @@ convertTyCon env t
"Date" -> pure TDate
"Time" -> pure TTimestamp
"TextMap" -> pure (TBuiltin BTMap)
"AnyTemplate" ->
"Any" ->
-- We just translate this to TUnit when it is not supported.
-- We can’t get rid of it completely since the template desugaring uses
-- this and we do not want to make that dependent on the DAML-LF version.

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

@ -11,7 +11,7 @@ module DA.Internal.Desugar (
Eq(..), Show(..),
Bool(..), Text, Optional,
concat, magic,
Party, ContractId, Update, AnyTemplate
Party, ContractId, Update, AnyTemplate, AnyChoice
) where
import DA.Internal.Prelude

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

@ -38,6 +38,7 @@ module DA.Internal.LF
, unpackPair
, AnyTemplate
, AnyChoice
) where
import GHC.Types (Opaque, Symbol)
@ -206,7 +207,12 @@ data Pair (f1 : Symbol) (f2 : Symbol) a1 a2 = Pair Opaque
unpackPair : forall f1 f2 a1 a2. Pair f1 f2 a1 a2 -> (a1, a2)
unpackPair = magic @"unpackPair"
-- | Existential type that can wrap an arbitrary type.
-- We do not expose this directly and instead only expose AnyTemplate and AnyChoice.
data Any = Any Opaque
-- | Existential template type that can wrap an arbitrary template.
data AnyTemplate =
AnyTemplate Opaque
-- We need the constructor to avoid GHC warning about impossible pattern matches.
newtype AnyTemplate = AnyTemplate { getAnyTemplate : Any }
-- | Existential choice type that can wrap an arbitrary chice.
newtype AnyChoice = AnyChoice { getAnyChoice : Any }

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

@ -3,6 +3,7 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ScopedTypeVariables #-}
daml 1.2
-- | MOVE Prelude DAML-LF primitives, just templates/contracts
@ -50,6 +51,14 @@ stakeholder t = signatory t ++ observer t
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
_toAnyChoice : proxy t -> c -> AnyChoice
_fromAnyChoice : proxy t -> AnyChoice -> Optional c
toAnyChoice : forall t c r. Choice t c r => c -> AnyChoice
toAnyChoice = _toAnyChoice ([] : [t])
fromAnyChoice : forall t c r. Choice t c r => AnyChoice -> Optional c
fromAnyChoice = _fromAnyChoice ([] : [t])
class Template t => TemplateKey t k | t -> k where
-- | The key of a contract.

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

@ -14,7 +14,7 @@ import DA.Internal.LF as X hiding (Pair(..), TextMap, unpackPair)
#ifdef DAML_ANY_TYPE
import DA.Internal.Template as X
#else
import DA.Internal.Template as X hiding (fromAnyTemplate, toAnyTemplate)
import DA.Internal.Template as X hiding (fromAnyTemplate, toAnyTemplate, fromAnyChoice, toAnyChoice, _fromAnyChoice, _toAnyChoice)
#endif
import DA.Internal.Compatible as X
import DA.Internal.Assert as X

60
compiler/damlc/tests/daml-test-files/AnyChoice.daml Normal file
View File

@ -0,0 +1,60 @@
-- Copyright (c) 2019, Digital Asset (Switzerland) GmbH and/or its affiliates.
-- All rights reserved.
-- @SINCE-LF 1.7
daml 1.2 module AnyTemplate where
import DA.Assert
template T1
with
x : Int
p : Party
where
signatory p
choice C1 : ()
controller p
do pure ()
choice C1' : ()
controller p
do pure ()
template T2
with
y : Text
p : Party
where
signatory p
choice C2 : ()
controller p
do pure ()
template Template t => GenericT t
with
wrapped : t
p : Party
where
signatory p
choice CT : ()
with v : t
controller p
do pure ()
template instance GT1 = GenericT T1
template instance GT2 = GenericT T2
main = scenario do
p <- getParty "alice"
let c1 = C1
let c1' = C1'
let c2 = C2
let ct1 = CT (T1 0 p)
let ct2 = CT (T2 "" p)
x <- pure $ toAnyChoice @T1 @C1 c1
fromAnyChoice @T1 @C1 (toAnyChoice @T1 c1) === Some c1
fromAnyChoice @T1 @C1' (toAnyChoice @T1 c1) === None
fromAnyChoice @T2 @C2 (toAnyChoice @T2 c2) === Some c2
fromAnyChoice @GT1 @(CT T1) (toAnyChoice @GT1 ct1) === Some ct1
fromAnyChoice @GT2 @(CT T2) (toAnyChoice @GT1 ct1) === None
fromAnyChoice @GT2 @(CT T2) (toAnyChoice @GT2 ct2) === Some ct2
fromAnyChoice @GT1 @(CT T1) (toAnyChoice @GT2 ct2) === None

24
compiler/damlc/tests/daml-test-files/ProposalDesugared.daml
View File

@ -43,9 +43,13 @@ data Accept = Accept{}
instance ProposalInstance t => Choice (Proposal t) Accept (ContractId t) where
exercise = _exerciseProposalAccept
_toAnyChoice = _toAnyChoiceProposalAccept
_fromAnyChoice = _fromAnyChoiceProposalAccept
instance ProposalInstance t => Choice (Proposal t) Archive () where
exercise = _exerciseProposalArchive
_toAnyChoice = _toAnyChoiceProposalArchive
_fromAnyChoice = _fromAnyChoiceProposalArchive
class Template t => ProposalInstance t where
_signatoryProposal : Proposal t -> [Party]
@ -92,6 +96,10 @@ class Template t => ProposalInstance t where
pure ()
_exerciseProposalArchive : ContractId (Proposal t) -> Archive -> Update ()
_exerciseProposalArchive = error "code will be injected by the compiler"
_toAnyChoiceProposalArchive : proxy (Proposal t) -> Archive -> AnyChoice
_toAnyChoiceProposalArchive = error "code will be injected by the compiler"
_fromAnyChoiceProposalArchive : proxy (Proposal t) -> AnyChoice -> Optional Archive
_fromAnyChoiceProposalArchive = error "code will be injected by the compiler"
_consumptionProposalAccept : PreConsuming (Proposal t)
_consumptionProposalAccept = PreConsuming
@ -102,6 +110,10 @@ class Template t => ProposalInstance t where
create asset
_exerciseProposalAccept : ContractId (Proposal t) -> Accept -> Update (ContractId t)
_exerciseProposalAccept = error "code will be injected by the compiler"
_toAnyChoiceProposalAccept : proxy (Proposal t) -> Accept -> AnyChoice
_toAnyChoiceProposalAccept = error "code will be injected by the compiler"
_fromAnyChoiceProposalAccept : proxy (Proposal t) -> AnyChoice -> Optional Accept
_fromAnyChoiceProposalAccept = error "code will be injected by the compiler"
-- The `Iou` template in its desugared form.
@ -127,9 +139,13 @@ data Burn = Burn{}
instance IouInstance => Choice Iou Burn () where
exercise = _exerciseIouBurn
_toAnyChoice = _toAnyChoiceIouBurn
_fromAnyChoice = _fromAnyChoiceIouBurn
instance IouInstance => Choice Iou Archive () where
exercise = _exerciseIouArchive
_toAnyChoice = _toAnyChoiceIouArchive
_fromAnyChoice = _fromAnyChoiceIouArchive
class IouInstance where
_signatoryIou : Iou -> [Party]
@ -161,6 +177,10 @@ class IouInstance where
pure ()
_exerciseIouArchive : ContractId Iou -> Archive -> Update ()
_exerciseIouArchive = error "code will be injected by the compiler"
_toAnyChoiceIouArchive : proxy Iou -> Archive -> AnyChoice
_toAnyChoiceIouArchive = error "code will be injected by the compiler"
_fromAnyChoiceIouArchive : proxy Iou -> AnyChoice -> Optional Archive
_fromAnyChoiceIouArchive = error "code will be injected by the compiler"
_consumptionIouBurn : PreConsuming Iou
_consumptionIouBurn = PreConsuming
@ -171,6 +191,10 @@ class IouInstance where
pure ()
_exerciseIouBurn : ContractId Iou -> Burn -> Update ()
_exerciseIouBurn = error "code will be injected by the compiler"
_toAnyChoiceIouBurn : proxy Iou -> Burn -> AnyChoice
_toAnyChoiceIouBurn = error "code will be injected by the compiler"
_fromAnyChoiceIouBurn : proxy Iou -> AnyChoice -> Optional Burn
_fromAnyChoiceIouBurn = error "code will be injected by the compiler"
instance IouInstance where

36
triggers/runner/src/main/scala/com/daml/trigger/Converter.scala
View File

@ -40,6 +40,7 @@ case class Converter(
case class TriggerIds(
triggerPackageId: PackageId,
triggerModuleName: ModuleName,
stdlibPackageId: PackageId,
mainPackageId: PackageId) {
def getId(n: String): Identifier =
Identifier(triggerPackageId, QualifiedName(triggerModuleName, DottedName.assertFromString(n)))
@ -56,7 +57,15 @@ object TriggerIds {
}
.get
._1
TriggerIds(triggerPackageId, triggerModuleName, dar.main._1)
val stdlibPackageId =
dar.all
.find {
case (pkgId, pkg) =>
pkg.modules.contains(DottedName.assertFromString("DA.Internal.LF"))
}
.get
._1
TriggerIds(triggerPackageId, triggerModuleName, stdlibPackageId, dar.main._1)
}
}
@ -146,6 +155,12 @@ object Converter {
private def fromCreatedEvent(triggerIds: TriggerIds, created: CreatedEvent): SValue = {
val createdTy = triggerIds.getId("Created")
val anyTemplateTyCon =
Identifier(
triggerIds.stdlibPackageId,
QualifiedName(
DottedName.assertFromString("DA.Internal.LF"),
DottedName.assertFromString("AnyTemplate")))
ValueValidator.validateRecord(created.getCreateArguments) match {
case Right(createArguments) =>
SValue.fromValue(createArguments) match {
@ -156,7 +171,7 @@ object Converter {
(
"contractId",
fromAnyContractId(triggerIds, created.getTemplateId, created.contractId)),
("argument", SAny(TTyCon(tyCon), r))
("argument", record(anyTemplateTyCon, ("getAnyTemplate", SAny(TTyCon(tyCon), r))))
)
case v => throw new RuntimeException(s"Expected record but got $v")
}
@ -296,12 +311,17 @@ object Converter {
case SRecord(_, _, vals) => {
assert(vals.size == 1)
vals.get(0) match {
case SAny(_, tpl) =>
for {
templateId <- extractTemplateId(tpl)
templateArg <- toLedgerRecord(tpl)
} yield CreateCommand(Some(toApiIdentifier(templateId)), Some(templateArg))
case v => Left(s"Expected Any but got $v")
case SRecord(_, _, vals) =>
assert(vals.size == 1)
vals.get(0) match {
case SAny(_, tpl) =>
for {
templateId <- extractTemplateId(tpl)
templateArg <- toLedgerRecord(tpl)
} yield CreateCommand(Some(toApiIdentifier(templateId)), Some(templateArg))
case v => Left(s"Expected Any but got $v")
}
case v => Left(s"Expected AnyTemplate but got $v")
}
}
case _ => Left(s"Expected CreateCommand but got $v")