interfaces: Add list of fixed choices in TemplateImplements structure. (#11364)

* interfaces: Add fixed choices in TemplateImplements To make template choice collision checks local. changelog_begin changelog_end * LF completer * lint * scary non-shadowing * improve comment * change field name
2024-11-10 00:35:25 +03:00 · 2021-11-01 11:51:51 +00:00 · 2021-11-01 11:51:51 +00:00 · 741a6e75a7
commit 741a6e75a7
parent 79505b5474
10 changed files with 83 additions and 12 deletions
--- a/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Base.hs
+++ b/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Base.hs
@ -16,10 +16,11 @@ import Data.Hashable
 import Data.Data
 import GHC.Generics(Generic)
 import Data.Int
-import           Control.DeepSeq
-import           Control.Lens
+import Control.DeepSeq
+import Control.Lens
 import qualified Data.NameMap as NM
-import qualified Data.Text          as T
+import qualified Data.Text as T
+import qualified Data.Set as S
 import Data.Fixed
 import qualified "template-haskell" Language.Haskell.TH as TH
 import qualified Control.Lens.TH as Lens.TH
@ -902,6 +903,8 @@ data TemplateImplements = TemplateImplements
  { tpiInterface :: !(Qualified TypeConName)
    -- ^ Interface name for implementation.
  , tpiMethods :: !(NM.NameMap TemplateImplementsMethod)
+  , tpiInheritedChoiceNames :: !(S.Set ChoiceName)
+    -- ^ Set of inherited fixed choice names.
  }
  deriving (Eq, Data, Generic, NFData, Show)

--- a/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Optics.hs
+++ b/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Optics.hs
@ -26,6 +26,7 @@ import Control.Lens.MonoTraversal
 import Data.Functor.Foldable (cata, embed)
 import qualified Data.NameMap as NM
 import qualified Data.Text as T
+import qualified Data.Set as S

 import DA.Daml.LF.Ast.Base
 import DA.Daml.LF.Ast.TypeLevelNat
@ -79,8 +80,10 @@ templateExpr f (Template loc tpl param precond signatories observers agreement c
  <*> (NM.traverse . templateImplementsExpr) f implements

 templateImplementsExpr :: Traversal' TemplateImplements Expr
-templateImplementsExpr f (TemplateImplements iface methods) =
-  TemplateImplements iface <$> (NM.traverse . templateImplementsMethodExpr) f methods
+templateImplementsExpr f (TemplateImplements iface methods inheritedChoiceNames) =
+  TemplateImplements iface
+    <$> (NM.traverse . templateImplementsMethodExpr) f methods
+    <*> pure inheritedChoiceNames

 templateImplementsMethodExpr :: Traversal' TemplateImplementsMethod Expr
 templateImplementsMethodExpr f (TemplateImplementsMethod name body) =
@ -145,6 +148,7 @@ instance MonoTraversable ModuleRef VariantConName where monoTraverse _ = pure
 instance MonoTraversable ModuleRef Version where monoTraverse _ = pure
 instance MonoTraversable ModuleRef PackageName where monoTraverse _ = pure
 instance MonoTraversable ModuleRef PackageVersion where monoTraverse _ = pure
+instance MonoTraversable ModuleRef (S.Set ChoiceName) where monoTraverse _ = pure

 -- NOTE(MH): This is an optimization to avoid running into a dead end.
 instance {-# OVERLAPPING #-} MonoTraversable ModuleRef FilePath where monoTraverse _ = pure
--- a/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Pretty.hs
+++ b/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Pretty.hs
@ -11,7 +11,8 @@ import qualified Data.Ratio                 as Ratio
 import           Control.Lens
 import           Control.Lens.Ast   (rightSpine)
 import qualified Data.NameMap as NM
-import qualified Data.Text          as T
+import qualified Data.Text as T
+import qualified Data.Set as S
 import qualified Data.Time.Clock.POSIX      as Clock.Posix
 import qualified Data.Time.Format           as Time.Format
 import           Data.Foldable (toList)
@ -632,10 +633,11 @@ pPrintTemplate lvl modName (Template mbLoc tpl param precond signatories observe
      implementsDoc = map (pPrintTemplateImplements lvl) (NM.toList implements)

 pPrintTemplateImplements :: PrettyLevel -> TemplateImplements -> Doc ann
-pPrintTemplateImplements lvl (TemplateImplements name methods)
+pPrintTemplateImplements lvl (TemplateImplements name methods inheritedChoices)
  | NM.null methods = keyword_ "implements" <-> pPrintPrec lvl 0 name
  | otherwise = vcat
      $ (keyword_ "implements" <-> pPrintPrec lvl 0 name <-> keyword_ "where")
+      : nest 2 (keyword_ "inherits" <-> pPrintPrec lvl 0 (S.toList inheritedChoices))
      : map (nest 2 . pPrintTemplateImplementsMethod lvl) (NM.toList methods)

 pPrintTemplateImplementsMethod :: PrettyLevel -> TemplateImplementsMethod -> Doc ann
--- a/compiler/daml-lf-proto/src/DA/Daml/LF/Proto3/DecodeV1.hs
+++ b/compiler/daml-lf-proto/src/DA/Daml/LF/Proto3/DecodeV1.hs
@ -26,6 +26,7 @@ import qualified Com.Daml.DamlLfDev.DamlLf1 as LF1
 import qualified Data.NameMap as NM
 import qualified Data.HashSet as HS
 import qualified Data.Text as T
+import qualified Data.Set as S
 import qualified Data.Text.Lazy as TL
 import qualified Data.Vector.Extended as V
 import qualified Proto3.Suite as Proto
@ -342,6 +343,7 @@ decodeDefTemplateImplements :: LF1.DefTemplate_Implements -> Decode TemplateImpl
 decodeDefTemplateImplements LF1.DefTemplate_Implements{..} = TemplateImplements
  <$> mayDecode "defTemplate_ImplementsInterface" defTemplate_ImplementsInterface decodeTypeConName
  <*> decodeNM DuplicateMethod decodeDefTemplateImplementsMethod defTemplate_ImplementsMethods
+  <*> decodeSet DuplicateChoice (decodeNameId ChoiceName) defTemplate_ImplementsInheritedChoiceInternedNames

 decodeDefTemplateImplementsMethod :: LF1.DefTemplate_ImplementsMethod -> Decode TemplateImplementsMethod
 decodeDefTemplateImplementsMethod LF1.DefTemplate_ImplementsMethod{..} = TemplateImplementsMethod
@ -970,3 +972,13 @@ decodeNM
 decodeNM mkDuplicateError decode1 xs = do
  ys <- traverse decode1 (V.toList xs)
  either (throwError . mkDuplicateError) pure $ NM.fromListEither ys
+
+decodeSet :: Ord b => (b -> Error) -> (a -> Decode b) -> V.Vector a -> Decode (S.Set b)
+decodeSet mkDuplicateError decode1 xs = do
+    ys <- traverse decode1 (V.toList xs)
+    foldM insertAndCheck S.empty ys
+  where
+      insertAndCheck !accum item =
+        if S.member item accum
+          then throwError (mkDuplicateError item)
+          else pure (S.insert item accum)
--- a/compiler/daml-lf-proto/src/DA/Daml/LF/Proto3/EncodeV1.hs
+++ b/compiler/daml-lf-proto/src/DA/Daml/LF/Proto3/EncodeV1.hs
@ -19,6 +19,7 @@ import           Data.Either
 import           Data.Functor.Identity
 import qualified Data.HashMap.Strict as HMS
 import qualified Data.List as L
+import qualified Data.Set as S
 import qualified Data.Map.Strict as Map
 import           Data.Maybe (fromMaybe)
 import qualified Data.NameMap as NM
@ -218,6 +219,9 @@ encodeList encodeElem = fmap V.fromList . mapM encodeElem
 encodeNameMap :: NM.Named a => (a -> Encode b) -> NM.NameMap a -> Encode (V.Vector b)
 encodeNameMap encodeElem = fmap V.fromList . mapM encodeElem . NM.toList

+encodeSet :: (a -> Encode b) -> S.Set a -> Encode (V.Vector b)
+encodeSet encodeElem = fmap V.fromList . mapM encodeElem . S.toList
+
 encodeQualTypeSynName' :: Qualified TypeSynName -> Encode P.TypeSynName
 encodeQualTypeSynName' (Qualified pref mname syn) = do
    typeSynNameModule <- encodeModuleRef pref mname
@ -929,6 +933,7 @@ encodeTemplateImplements :: TemplateImplements -> Encode P.DefTemplate_Implement
 encodeTemplateImplements TemplateImplements{..} = do
    defTemplate_ImplementsInterface <- encodeQualTypeConName tpiInterface
    defTemplate_ImplementsMethods <- encodeNameMap encodeTemplateImplementsMethod tpiMethods
+    defTemplate_ImplementsInheritedChoiceInternedNames <- encodeSet (encodeNameId unChoiceName) tpiInheritedChoiceNames
    pure P.DefTemplate_Implements {..}

 encodeTemplateImplementsMethod :: TemplateImplementsMethod -> Encode P.DefTemplate_ImplementsMethod
--- a/compiler/daml-lf-tools/src/DA/Daml/LF/Completer.hs
+++ b/compiler/daml-lf-tools/src/DA/Daml/LF/Completer.hs
@ -0,0 +1,36 @@
+-- Copyright (c) 2021 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
+-- SPDX-License-Identifier: Apache-2.0
+
+-- | Completion is an LF postprocessing step. It happens after LF conversion,
+-- but before simplification and typechecking. Its purpose is to propagate
+-- any type-level information that can only be obtained with access to the
+-- LF world.
+module DA.Daml.LF.Completer
+    ( completeModule
+    ) where
+
+import qualified Data.NameMap as NM
+import qualified Data.Set as S
+import qualified Data.Text as T
+import DA.Daml.LF.Ast as LF
+
+completeModule :: LF.World -> LF.Version -> LF.Module -> LF.Module
+completeModule world lfVersion mod@Module{..}
+    | LF.supports lfVersion featureInterfaces
+    = mod { moduleTemplates = NM.map (completeTemplate world') moduleTemplates }
+
+    | otherwise
+    = mod
+  where
+    world' = extendWorldSelf mod world
+
+completeTemplate :: LF.World -> LF.Template -> LF.Template
+completeTemplate world tpl@Template{..} =
+    tpl { tplImplements = NM.map (completeTemplateImplements world) tplImplements }
+
+completeTemplateImplements :: LF.World -> LF.TemplateImplements -> LF.TemplateImplements
+completeTemplateImplements world tpi@TemplateImplements{..} =
+    case lookupInterface tpiInterface world of
+        Left _ -> error ("Could not find interface " <> T.unpack (T.intercalate "." (unTypeConName (qualObject tpiInterface))))
+        Right DefInterface { intFixedChoices } ->
+            tpi { tpiInheritedChoiceNames = S.fromList (NM.names intFixedChoices) }
--- a/compiler/damlc/daml-compiler/src/DA/Daml/Compiler/Repl.hs
+++ b/compiler/damlc/daml-compiler/src/DA/Daml/Compiler/Repl.hs
@ -28,6 +28,7 @@ import Control.Monad.Trans.Maybe
 import DA.Daml.Compiler.Output (printDiagnostics)
 import qualified DA.Daml.LF.Ast as LF
 import qualified DA.Daml.LF.InferSerializability as Serializability
+import qualified DA.Daml.LF.Completer as LF
 import qualified DA.Daml.LF.Simplifier as LF
 import qualified DA.Daml.LF.TypeChecker as LF
 import DA.Daml.LF.Ast.Optics (packageRefs)
@ -503,7 +504,8 @@ runRepl importPkgs opts replClient logger ideState = do
                Right v -> do
                   pkgs <- lift $ getExternalPackages file
                   let world = LF.initWorldSelf pkgs (buildPackage (optMbPackageName opts) (optMbPackageVersion opts) lfVersion [])
-                   let simplified = LF.simplifyModule world lfVersion v
+                   let completed = LF.completeModule world lfVersion v
+                   let simplified = LF.simplifyModule world lfVersion completed
                   case Serializability.inferModule world lfVersion simplified of
                       Left err -> handleIdeResult ([ideErrorPretty file err], Nothing)
                       Right dalf -> do
--- a/compiler/damlc/daml-ide-core/src/Development/IDE/Core/Rules/Daml.hs
+++ b/compiler/damlc/daml-ide-core/src/Development/IDE/Core/Rules/Daml.hs
@ -96,6 +96,7 @@ import qualified DA.Daml.LF.InferSerializability as Serializability
 import qualified DA.Daml.LF.PrettyScenario as LF
 import qualified DA.Daml.LF.Proto3.Archive as Archive
 import qualified DA.Daml.LF.ScenarioServiceClient as SS
+import qualified DA.Daml.LF.Completer as LF
 import qualified DA.Daml.LF.Simplifier as LF
 import qualified DA.Daml.LF.TypeChecker as LF
 import DA.Daml.UtilLF
@ -271,7 +272,9 @@ generateRawDalfRule =
                            WhnfPackage pkg <- use_ GeneratePackageDeps file
                            pkgs <- getExternalPackages file
                            let world = LF.initWorldSelf pkgs pkg
-                            return ([], Just $ LF.simplifyModule world lfVersion v)
+                                completed = LF.completeModule world lfVersion v
+                                simplified = LF.simplifyModule world lfVersion completed
+                            return ([], Just simplified)

 getExternalPackages :: NormalizedFilePath -> Action [LF.ExternalPackage]
 getExternalPackages file = do
@ -423,13 +426,14 @@ generateSerializedDalfRule options =
                                    pkgs <- getExternalPackages file
                                    let selfPkg = buildPackage (optMbPackageName options) (optMbPackageVersion options) lfVersion dalfDeps
                                        world = LF.initWorldSelf pkgs selfPkg
-                                    rawDalf <- pure $ LF.simplifyModule (LF.initWorld [] lfVersion) lfVersion rawDalf
+                                        completed = LF.completeModule world lfVersion rawDalf
+                                        simplified = LF.simplifyModule (LF.initWorld [] lfVersion) lfVersion completed
                                        -- NOTE (SF): We pass a dummy LF.World to the simplifier because we don't want inlining
                                        -- across modules when doing incremental builds. The reason is that our Shake rules
                                        -- use ABI changes to determine whether to rebuild the module, so if an implementaion
                                        -- changes without a corresponding ABI change, we would end up with an outdated
                                        -- implementation.
-                                    case Serializability.inferModule world lfVersion rawDalf of
+                                    case Serializability.inferModule world lfVersion simplified of
                                        Left err -> pure ([ideErrorPretty file err], Nothing)
                                        Right dalf -> do
                                            let (diags, checkResult) = diagsToIdeResult file $ LF.checkModule world lfVersion dalf
--- a/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs
+++ b/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs
@ -972,7 +972,8 @@ convertImplements env tplTypeCon = NM.fromList <$>
                | (FieldName fieldName, e) <- methodFields
                , Just methodName <- [T.stripPrefix "m_" fieldName]
                ]
-        pure (TemplateImplements con methods)
+        let inheritedChoiceNames = S.empty -- This is filled during LF post-processing (in the LF completer).
+        pure (TemplateImplements con methods inheritedChoiceNames)

 convertChoices :: Env -> LF.TypeConName -> TemplateBinds -> ConvertM (NM.NameMap TemplateChoice)
 convertChoices env tplTypeCon tbinds =
--- a/daml-lf/archive/src/main/protobuf/com/daml/daml_lf_dev/daml_lf_1.proto
+++ b/daml-lf/archive/src/main/protobuf/com/daml/daml_lf_dev/daml_lf_1.proto
@ -1457,6 +1457,8 @@ message DefTemplate {
  message Implements {
    TypeConName interface = 1;
    repeated ImplementsMethod methods = 2;
+    repeated int32 inherited_choice_interned_names = 3;
+      // ^ inherited fixed choice names as interned strings
  }

  // The type constructor for the template, acting as both