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"

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

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 ->

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