From ed9dbed100b12b481bf10d3e67c5778659fa0937 Mon Sep 17 00:00:00 2001 From: Sofia Faro Date: Thu, 21 Oct 2021 12:29:05 +0100 Subject: [PATCH] interfaces: Add fixed choice collision check in typechecker (Haskell) (#11337) * interfaces: Add fixed choice name collision check Add a check that a template cannot have two choices with the same name, even taking into account all of its "inherited" interface fixed choices. Part of #11137 changelog_begin changelog_end * "Me want" -> "We want" --- .../src/DA/Daml/LF/TypeChecker/Check.hs | 18 +++++++- .../src/DA/Daml/LF/TypeChecker/Error.hs | 3 ++ .../InterfaceChoiceCollision.daml | 42 +++++++++++++++++++ 3 files changed, 62 insertions(+), 1 deletion(-) create mode 100644 compiler/damlc/tests/daml-test-files/InterfaceChoiceCollision.daml diff --git a/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Check.hs b/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Check.hs index 3e4fd2541fb5..1372bcf7beeb 100644 --- a/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Check.hs +++ b/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Check.hs @@ -41,6 +41,7 @@ import Data.Foldable import Data.Functor import Data.List.Extended import Data.Generics.Uniplate.Data (para) +import qualified Data.Set as S import qualified Data.HashSet as HS import qualified Data.Map.Strict as Map import qualified Data.NameMap as NM @@ -868,7 +869,7 @@ checkTemplateChoice tpl (TemplateChoice _loc _ _ controllers mbObservers selfBin introExprVar selfBinder (TContractId (TCon tpl)) $ introExprVar param paramType $ checkExpr upd (TUpdate retType) -checkTemplate :: MonadGamma m => Module -> Template -> m () +checkTemplate :: forall m. MonadGamma m => Module -> Template -> m () checkTemplate m t@(Template _loc tpl param precond signatories observers text choices mbKey implements) = do let tcon = Qualified PRSelf (moduleName m) tpl DefDataType _loc _naem _serializable tparams dataCons <- inWorld (lookupDataType tcon) @@ -882,9 +883,24 @@ checkTemplate m t@(Template _loc tpl param precond signatories observers text ch for_ choices $ \c -> withPart (TPChoice c) $ checkTemplateChoice tcon c whenJust mbKey $ checkTemplateKey param tcon forM_ implements $ checkIfaceImplementation tcon + + -- Check template choice and interface fixed choice name collisions. + foldM_ checkFixedChoiceCollision (S.fromList (NM.names choices)) implements + -- ^ We don't use NM.namesSet here because Data.HashSet is assymptotically + -- slower than Data.Set when it comes to unions and checking for disjointness. + where withPart p = withContext (ContextTemplate m t p) + checkFixedChoiceCollision :: S.Set ChoiceName -> TemplateImplements -> m (S.Set ChoiceName) + checkFixedChoiceCollision !accum ifaceImpl = do + iface <- inWorld $ lookupInterface (tpiInterface ifaceImpl) + let newNames = S.fromList (NM.names (intFixedChoices iface)) + unless (S.disjoint accum newNames) $ do + let choiceName = head (S.toList (S.intersection accum newNames)) + throwWithContext (EDuplicateTemplateChoiceViaInterfaces tpl choiceName) + pure (S.union accum newNames) + checkIfaceImplementation :: MonadGamma m => Qualified TypeConName -> TemplateImplements -> m () checkIfaceImplementation tplTcon TemplateImplements{..} = do let tplName = qualObject tplTcon diff --git a/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs b/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs index c97414b12b17..c28cafd9513e 100644 --- a/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs +++ b/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs @@ -131,6 +131,7 @@ data Error | ENatKindRightOfArrow !Kind | EInterfaceTypeWithParams | EMissingInterfaceDefinition !TypeConName + | EDuplicateTemplateChoiceViaInterfaces !TypeConName !ChoiceName | EDuplicateInterfaceChoiceName !TypeConName !ChoiceName | EDuplicateInterfaceMethodName !TypeConName !MethodName | EUnknownInterface !TypeConName @@ -381,6 +382,8 @@ instance Pretty Error where ] EMissingInterfaceDefinition iface -> "Missing interface definition for interface type: " <> pretty iface + EDuplicateTemplateChoiceViaInterfaces tpl choice -> + "Duplicate choice name '" <> pretty choice <> "' in template " <> pretty tpl <> " via interfaces." EDuplicateInterfaceChoiceName iface choice -> "Duplicate choice name '" <> pretty choice <> "' in interface definition for " <> pretty iface EDuplicateInterfaceMethodName iface method -> diff --git a/compiler/damlc/tests/daml-test-files/InterfaceChoiceCollision.daml b/compiler/damlc/tests/daml-test-files/InterfaceChoiceCollision.daml new file mode 100644 index 000000000000..d63aec8f058c --- /dev/null +++ b/compiler/damlc/tests/daml-test-files/InterfaceChoiceCollision.daml @@ -0,0 +1,42 @@ +-- Copyright (c) 2021 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +-- @SINCE-LF-FEATURE DAML_INTERFACE +-- @ERROR Duplicate choice name 'MyArchive' in template T via interfaces. +module InterfaceChoiceCollision where + +interface InterfaceA where + getOwnerA : Party + + choice MyArchive : () + controller getOwnerA this + do pure () + +interface InterfaceB where + getOwnerB : Party + +-- We want InterfaceB to have a fixed choice with the same name as InterfaceA, +-- but we can't add it via the fixed choice syntax in the same file because that +-- would result in a duplicate `data` declaration for MyArchive. So instead we +-- add the fixed choice manually (see InterfaceDesugared for comparison). +_choice_InterfaceBMyArchive : + ( InterfaceB -> MyArchive -> [DA.Internal.Desugar.Party] + , DA.Internal.Desugar.ContractId InterfaceB -> InterfaceB -> MyArchive -> DA.Internal.Desugar.Update () + , DA.Internal.Desugar.Consuming InterfaceB + , DA.Internal.Desugar.Optional (InterfaceB -> MyArchive -> [DA.Internal.Desugar.Party]) + ) +_choice_InterfaceBMyArchive = + ( \this _ -> [getOwnerB this] + , \_ _ _ -> pure () + , DA.Internal.Desugar.Consuming + , DA.Internal.Desugar.None + ) + +template T with + owner : Party + where + signatory owner + implements InterfaceA where + let getOwnerA = owner + implements InterfaceB where + let getOwnerB = owner