interfaces: Add "requires" field in Haskell AST. (#12016)

* interfaces: Add "requires" field in Haskell AST. Part of #11978. Adds typechecking for this on the interface and implementation side. changelog_begin changelog_end * Fix all the errors
digital-asset · Dec 7, 2021 · 1dd8131 · 1dd8131
1 parent ef23593
commit 1dd8131
Show file tree

Hide file tree

Showing 8 changed files with 26 additions and 7 deletions.
diff --git a/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Base.hs b/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Base.hs
@@ -929,6 +929,7 @@ data DefException = DefException
 data DefInterface = DefInterface
   { intLocation :: !(Maybe SourceLoc)
   , intName :: !TypeConName
+  , intRequires :: !(S.Set (Qualified TypeConName))
   , intParam :: !ExprVarName
   , intFixedChoices :: !(NM.NameMap TemplateChoice)
   , intMethods :: !(NM.NameMap InterfaceMethod)

diff --git a/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Optics.hs b/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Optics.hs
@@ -134,6 +134,9 @@ instance MonoTraversable ModuleRef (Qualified a) where
   monoTraverse f (Qualified pkg0 mod0 x) =
     (\(pkg1, mod1) -> Qualified pkg1 mod1 x) <$> f (pkg0, mod0)
 
+instance (Ord a, MonoTraversable ModuleRef a) => MonoTraversable ModuleRef (S.Set a) where
+  monoTraverse f = fmap S.fromList . traverse (monoTraverse f) . S.toList
+
 instance MonoTraversable ModuleRef ChoiceName where monoTraverse _ = pure
 instance MonoTraversable ModuleRef MethodName where monoTraverse _ = pure
 instance MonoTraversable ModuleRef ExprValName where monoTraverse _ = pure
@@ -147,7 +150,6 @@ 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

diff --git a/compiler/daml-lf-proto/src/DA/Daml/LF/Proto3/DecodeV1.hs b/compiler/daml-lf-proto/src/DA/Daml/LF/Proto3/DecodeV1.hs
@@ -237,6 +237,7 @@ decodeDefInterface :: LF1.DefInterface -> Decode DefInterface
 decodeDefInterface LF1.DefInterface {..} = do
   intLocation <- traverse decodeLocation defInterfaceLocation
   intName <- decodeDottedNameId TypeConName defInterfaceTyconInternedDname
+  intRequires <- decodeSet DuplicateRequires decodeTypeConName defInterfaceRequires
   intParam <- decodeNameId ExprVarName defInterfaceParamInternedStr
   intFixedChoices <- decodeNM DuplicateChoice decodeChoice defInterfaceFixedChoices
   intMethods <- decodeNM DuplicateMethod decodeInterfaceMethod defInterfaceMethods

diff --git a/compiler/daml-lf-proto/src/DA/Daml/LF/Proto3/EncodeV1.hs b/compiler/daml-lf-proto/src/DA/Daml/LF/Proto3/EncodeV1.hs
@@ -1005,7 +1005,7 @@ encodeDefInterface :: DefInterface -> Encode P.DefInterface
 encodeDefInterface DefInterface{..} = do
     defInterfaceLocation <- traverse encodeSourceLoc intLocation
     defInterfaceTyconInternedDname <- encodeDottedNameId unTypeConName intName
-    let defInterfaceRequires = V.empty -- TODO https://github.com/digital-asset/daml/issues/11978
+    defInterfaceRequires <- encodeSet encodeQualTypeConName' intRequires
     defInterfaceMethods <- encodeNameMap encodeInterfaceMethod intMethods
     defInterfaceParamInternedStr <- encodeNameId unExprVarName intParam
     defInterfacePrecond <- encodeExpr intPrecondition

diff --git a/compiler/daml-lf-proto/src/DA/Daml/LF/Proto3/Error.hs b/compiler/daml-lf-proto/src/DA/Daml/LF/Proto3/Error.hs
@@ -23,6 +23,7 @@ data Error
   | DuplicateMethod MethodName
   | DuplicateException TypeConName
   | DuplicateInterface TypeConName
+  | DuplicateRequires (Qualified TypeConName)
   | DuplicateImplements (Qualified TypeConName)
   | UnsupportedMinorVersion T.Text
   | BadStringId Int32

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
@@ -818,9 +818,10 @@ checkDefTypeSyn DefTypeSyn{synParams,synType} = do
 
 -- | Check that an interface definition is well defined.
 checkIface :: MonadGamma m => Module -> DefInterface -> m ()
-checkIface m DefInterface{intName, intParam, intFixedChoices, intMethods, intPrecondition} = do
+checkIface m DefInterface{..} = do
   checkUnique (EDuplicateInterfaceChoiceName intName) $ NM.names intFixedChoices
   checkUnique (EDuplicateInterfaceMethodName intName) $ NM.names intMethods
+  forM_ intRequires (inWorld . lookupInterface) -- verify that required interface exists
   forM_ intMethods checkIfaceMethod
 
   let tcon = Qualified PRSelf (moduleName m) intName
@@ -885,15 +886,22 @@ checkTemplate m t@(Template _loc tpl param precond signatories observers text ch
     withPart TPAgreement $ checkExpr text TText
     for_ choices $ \c -> withPart (TPChoice c) $ checkTemplateChoice tcon c
   whenJust mbKey $ checkTemplateKey param tcon
-  forM_ implements $ checkIfaceImplementation tcon
+  forM_ implements $ checkIfaceImplementation t tcon
 
   where
     withPart p = withContext (ContextTemplate m t p)
 
-checkIfaceImplementation :: MonadGamma m => Qualified TypeConName -> TemplateImplements -> m ()
-checkIfaceImplementation tplTcon TemplateImplements{..} = do
+checkIfaceImplementation :: MonadGamma m => Template -> Qualified TypeConName -> TemplateImplements -> m ()
+checkIfaceImplementation Template{tplImplements} tplTcon TemplateImplements{..} = do
   let tplName = qualObject tplTcon
-  DefInterface {intFixedChoices, intMethods} <- inWorld $ lookupInterface tpiInterface
+  DefInterface {intFixedChoices, intRequires, intMethods} <- inWorld $ lookupInterface tpiInterface
+
+  -- check requires
+  let missingRequires = S.difference intRequires (S.fromList (NM.names tplImplements))
+  case S.toList missingRequires of
+    [] -> pure ()
+    (missingInterface:_) ->
+      throwWithContext (EMissingRequiredInterface tplName tpiInterface missingInterface)
 
   -- check fixed choices
   let inheritedChoices = S.fromList (NM.names intFixedChoices)

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
@@ -134,6 +134,7 @@ data Error
   | EDuplicateInterfaceChoiceName !TypeConName !ChoiceName
   | EDuplicateInterfaceMethodName !TypeConName !MethodName
   | EUnknownInterface !TypeConName
+  | EMissingRequiredInterface { emriTemplate :: !TypeConName, emriRequiringInterface :: !(Qualified TypeConName), emriRequiredInterface :: !(Qualified TypeConName) }
   | EBadInheritedChoices { ebicInterface :: !(Qualified TypeConName), ebicExpected :: ![ChoiceName], ebicGot :: ![ChoiceName] }
   | EMissingInterfaceChoice !ChoiceName
   | EBadInterfaceChoiceImplConsuming !ChoiceName !Bool !Bool
@@ -378,6 +379,10 @@ instance Pretty Error where
     EDuplicateInterfaceMethodName iface method ->
       "Duplicate method name '" <> pretty method <> "' in interface definition for " <> pretty iface
     EUnknownInterface tcon -> "Unknown interface: " <> pretty tcon
+    EMissingRequiredInterface {..} ->
+      "Template " <> pretty emriTemplate <>
+      " is missing an implementation of interface " <> pretty emriRequiredInterface <>
+      " required by interface " <> pretty emriRequiringInterface
     EBadInheritedChoices {ebicInterface, ebicExpected, ebicGot} ->
       vcat
       [ "List of inherited choices does not match interface definition for " <> pretty ebicInterface

diff --git a/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs b/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs
@@ -449,6 +449,7 @@ convertInterfaces env binds = interfaceDefs
     convertInterface intName tyCon = do
         let intLocation = convNameLoc (GHC.tyConName tyCon)
         let intParam = this
+        let intRequires = S.empty -- TODO https://github.com/digital-asset/daml/issues/11978
         let precond = fromMaybe (error $ "Missing precondition for interface " <> show intName)
                         $ (MS.lookup intName $ envInterfaceBinds env) >>= ibEnsure
         withRange intLocation $ do