From e362c92b1a4a0a83fd884587ff7cbb964c72a47f Mon Sep 17 00:00:00 2001 From: Sofia Faro Date: Mon, 27 Sep 2021 11:00:47 +0100 Subject: [PATCH] interface methods: Haskell Typechecker part of #11006 changelog_begin changelog_end --- .../daml-lf-ast/src/DA/Daml/LF/Ast/World.hs | 18 +++++++-- .../src/DA/Daml/LF/TypeChecker/Check.hs | 37 +++++++++++++++---- .../src/DA/Daml/LF/TypeChecker/Error.hs | 9 +++++ 3 files changed, 52 insertions(+), 12 deletions(-) diff --git a/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/World.hs b/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/World.hs index affea3b5c891..96ddc2dbb938 100644 --- a/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/World.hs +++ b/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/World.hs @@ -19,6 +19,7 @@ module DA.Daml.LF.Ast.World( lookupDataType, lookupChoice, lookupInterfaceChoice, + lookupInterfaceMethod, lookupValue, lookupModule, lookupInterface, @@ -100,6 +101,7 @@ data LookupError | LEException !(Qualified TypeConName) | LEChoice !(Qualified TypeConName) !ChoiceName | LEInterface !(Qualified TypeConName) + | LEInterfaceMethod !(Qualified TypeConName) !MethodName deriving (Eq, Ord, Show) lookupModule :: Qualified a -> World -> Either LookupError Module @@ -154,12 +156,19 @@ lookupChoice (tplRef, chName) world = do lookupInterfaceChoice :: (Qualified TypeConName, ChoiceName) -> World -> Either LookupError InterfaceChoice -lookupInterfaceChoice (tplRef, chName) world = do - iface <- lookupInterface tplRef world +lookupInterfaceChoice (ifaceRef, chName) world = do + iface <- lookupInterface ifaceRef world case NM.lookup chName (intChoices iface) of - Nothing -> Left (LEChoice tplRef chName) + Nothing -> Left (LEChoice ifaceRef chName) Just choice -> Right choice +lookupInterfaceMethod :: (Qualified TypeConName, MethodName) -> World -> Either LookupError InterfaceMethod +lookupInterfaceMethod (ifaceRef, methodName) world = do + iface <- lookupInterface ifaceRef world + case NM.lookup methodName (intMethods iface) of + Nothing -> Left (LEInterfaceMethod ifaceRef methodName) + Just method -> Right method + instance Pretty LookupError where pPrint = \case LEPackage pkgId -> "unknown package:" <-> pretty pkgId @@ -171,4 +180,5 @@ instance Pretty LookupError where LETemplate tplRef -> "unknown template:" <-> pretty tplRef LEException exnRef -> "unknown exception:" <-> pretty exnRef LEChoice tplRef chName -> "unknown choice:" <-> pretty tplRef <> ":" <> pretty chName - LEInterface ifaceRef -> "unknown interface" <-> pretty ifaceRef + LEInterface ifaceRef -> "unknown interface:" <-> pretty ifaceRef + LEInterfaceMethod ifaceRef methodName -> "unknown interface method:" <-> pretty ifaceRef <> "." <> pretty methodName 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 78f9c6bdfef9..6c4255e3ba3b 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 @@ -748,9 +748,10 @@ typeOf' = \case checkImplements tpl iface checkExpr val (TCon iface) pure (TOptional (TCon tpl)) - ECallInterface _ _ _ -> - -- TODO https://github.com/digital-asset/daml/issues/11006 - error "ECallInterface not yet implemented" + ECallInterface iface method val -> do + method <- inWorld (lookupInterfaceMethod (iface, method)) + checkExpr val (TCon iface) + pure (ifmType method) EUpdate upd -> typeOfUpdate upd EScenario scen -> typeOfScenario scen ELocation _ expr -> typeOf' expr @@ -808,15 +809,21 @@ checkDefTypeSyn DefTypeSyn{synParams,synType} = do checkIface :: MonadGamma m => DefInterface -> m () -checkIface DefInterface{intName, intChoices} = do +checkIface DefInterface{intName, intChoices, intMethods} = do checkUnique (EDuplicateInterfaceChoiceName intName) $ NM.names intChoices + checkUnique (EDuplicateInterfaceMethodName intName) $ NM.names intMethods forM_ intChoices checkIfaceChoice + forM_ intMethods checkIfaceMethod checkIfaceChoice :: MonadGamma m => InterfaceChoice -> m () checkIfaceChoice InterfaceChoice{ifcArgType,ifcRetType} = do checkType ifcArgType KStar checkType ifcRetType KStar +checkIfaceMethod :: MonadGamma m => InterfaceMethod -> m () +checkIfaceMethod InterfaceMethod{ifmType} = do + checkType ifmType KStar + -- | Check that a type constructor definition is well-formed. checkDefDataType :: MonadGamma m => Module -> DefDataType -> m () checkDefDataType m (DefDataType _loc name _serializable params dataCons) = do @@ -876,9 +883,10 @@ checkTemplate m t@(Template _loc tpl param precond signatories observers text ch checkIfaceImplementation :: MonadGamma m => Qualified TypeConName -> TemplateImplements -> m () checkIfaceImplementation tplTcon TemplateImplements{..} = do - -- TODO https://github.com/digital-asset/daml/issues/11006 - -- check methods, not just choices - DefInterface {intChoices} <- inWorld $ lookupInterface tpiInterface + let tplName = qualObject tplTcon + DefInterface {intChoices, intMethods} <- inWorld $ lookupInterface tpiInterface + + -- check choices forM_ intChoices $ \InterfaceChoice {ifcName, ifcConsuming, ifcArgType, ifcRetType} -> do TemplateChoice {chcConsuming, chcArgBinder, chcReturnType} <- inWorld $ lookupChoice (tplTcon, ifcName) @@ -889,6 +897,17 @@ checkIfaceImplementation tplTcon TemplateImplements{..} = do unless (alphaType chcReturnType ifcRetType) $ throwWithContext $ EBadInterfaceChoiceImplRetType ifcName ifcRetType chcReturnType + -- check methods + let missingMethods = HS.difference (NM.namesSet intMethods) (NM.namesSet tpiMethods) + case HS.toList missingMethods of + [] -> pure () + (methodName:_) -> throwWithContext (EMissingInterfaceMethod tplName tpiInterface methodName) + forM_ tpiMethods $ \TemplateImplementsMethod{tpiMethodName, tpiMethodExpr} -> do + case NM.lookup tpiMethodName intMethods of + Nothing -> throwWithContext (EUnknownInterfaceMethod tplName tpiInterface tpiMethodName) + Just InterfaceMethod{ifmType} -> + checkExpr tpiMethodExpr (TCon tplTcon :-> ifmType) + _checkFeature :: MonadGamma m => Feature -> m () _checkFeature feature = do version <- getLfVersion @@ -922,7 +941,9 @@ checkModule m@(Module _modName _path _flags synonyms dataTypes values templates let with ctx f x = withContext (ctx x) (f x) traverse_ (with (ContextDefTypeSyn m) checkDefTypeSyn) synonyms traverse_ (with (ContextDefDataType m) $ checkDefDataType m) dataTypes + -- NOTE(SF): Interfaces should be checked before templates, because the typechecking + -- for templates relies on well-typed interface definitions. + traverse_ (with (ContextDefInterface m) checkIface) interfaces traverse_ (with (\t -> ContextTemplate m t TPWhole) $ checkTemplate m) templates traverse_ (with (ContextDefException m) (checkDefException m)) exceptions traverse_ (with (ContextDefValue m) checkDefValue) values - traverse_ (with (ContextDefInterface m) checkIface) interfaces 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 129ab4492739..c97414b12b17 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 @@ -132,11 +132,14 @@ data Error | EInterfaceTypeWithParams | EMissingInterfaceDefinition !TypeConName | EDuplicateInterfaceChoiceName !TypeConName !ChoiceName + | EDuplicateInterfaceMethodName !TypeConName !MethodName | EUnknownInterface !TypeConName | EMissingInterfaceChoice !ChoiceName | EBadInterfaceChoiceImplConsuming !ChoiceName !Bool !Bool | EBadInterfaceChoiceImplArgType !ChoiceName !Type !Type | EBadInterfaceChoiceImplRetType !ChoiceName !Type !Type + | EMissingInterfaceMethod !TypeConName !(Qualified TypeConName) !MethodName + | EUnknownInterfaceMethod !TypeConName !(Qualified TypeConName) !MethodName | ETemplateDoesNotImplementInterface !(Qualified TypeConName) !(Qualified TypeConName) contextLocation :: Context -> Maybe SourceLoc @@ -380,6 +383,8 @@ instance Pretty Error where "Missing interface definition for interface type: " <> pretty iface EDuplicateInterfaceChoiceName iface choice -> "Duplicate choice name '" <> pretty choice <> "' in interface definition for " <> pretty iface + EDuplicateInterfaceMethodName iface method -> + "Duplicate method name '" <> pretty method <> "' in interface definition for " <> pretty iface EUnknownInterface tcon -> "Unknown interface: " <> pretty tcon EMissingInterfaceChoice ch -> "Missing interface choice implementation for " <> pretty ch EBadInterfaceChoiceImplConsuming ch ifaceConsuming tplConsuming -> @@ -400,6 +405,10 @@ instance Pretty Error where , "Expected: " <> pretty ifaceRetType , "But got: " <> pretty tplRetType ] + EMissingInterfaceMethod tpl iface method -> + "Template " <> pretty tpl <> " is missing method " <> pretty method <> " for interface " <> pretty iface + EUnknownInterfaceMethod tpl iface method -> + "Template " <> pretty tpl <> " implements " <> pretty method <> " but interface " <> pretty iface <> " has no such method." ETemplateDoesNotImplementInterface tpl iface -> "Template " <> pretty tpl <> " does not implement interface " <> pretty iface