mirror of
https://github.com/digital-asset/daml.git
synced 2024-09-20 01:07:18 +03:00
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"
This commit is contained in:
parent
c37ecd1a42
commit
ed9dbed100
@ -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
|
||||
|
@ -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 ->
|
||||
|
@ -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
|
Loading…
Reference in New Issue
Block a user