interface methods: Haskell AST (#11018)

* interface methods: Haskell AST for methods

Part of #11006. This leaves typechecker and LF conversion for later, on
the haskell side.

changelog_begin
changelog_end

* Forgot ECallInterface in DecodeV1

* fix a test

compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Alpha.hs

@@ -67,6 +67,10 @@ alphaExprVar AlphaEnv{..} x1 x2 =
 alphaTypeCon :: Qualified TypeConName -> Qualified TypeConName -> Bool
 alphaTypeCon = (==)
 
+-- | Strongly typed version of (==) for method names.
+alphaMethod :: MethodName -> MethodName -> Bool
+alphaMethod = (==)
+
 alphaType' :: AlphaEnv -> Type -> Type -> Bool
 alphaType' env = \case
     TVar x1 -> \case
@@ -224,6 +228,12 @@ alphaExpr' env = \case
             && alphaTypeCon t1b t2b
             && alphaExpr' env e1 e2
         _ -> False
+    ECallInterface t1 m1 e1 -> \case
+        ECallInterface t2 m2 e2
+            -> alphaTypeCon t1 t2
+            && alphaMethod m1 m2
+            && alphaExpr' env e1 e2
+        _ -> False
     EUpdate u1 -> \case
         EUpdate u2 -> alphaUpdate env u1 u2
         _ -> False

compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Base.hs

@@ -80,6 +80,13 @@ newtype ChoiceName = ChoiceName{unChoiceName :: T.Text}
     deriving stock (Eq, Data, Generic, Ord, Show)
     deriving newtype (Hashable, NFData)
 
+-- | Name for an interface method.  Must match the regex
+--
+-- > [a-z_][a-zA-Z0-9_]*
+newtype MethodName = MethodName{unMethodName :: T.Text}
+    deriving stock (Eq, Data, Generic, Ord, Show)
+    deriving newtype (Hashable, NFData)
+
 -- | Name for a type variable. Must match the regex
 --
 -- > [a-z_][a-zA-Z0-9_]*
@@ -558,6 +565,12 @@ data Expr
     , fromInterfaceTemplate :: !(Qualified TypeConName)
     , fromInterfaceExpr :: !Expr
     }
+  -- | Invoke an interface method
+  | ECallInterface
+    { callInterfaceType :: !(Qualified TypeConName)
+    , callInterfaceMethod :: !MethodName
+    , callInterfaceExpr :: !Expr
+    }
   -- | Update expression.
   | EUpdate !Update
   -- | Scenario expression.
@@ -879,7 +892,26 @@ data Template = Template
     -- ^ Choices of the template.
   , tplKey             :: !(Maybe TemplateKey)
     -- ^ Template key definition, if any.
-  , tplImplements      :: ![Qualified TypeConName]
+  , tplImplements      :: !(NM.NameMap TemplateImplements)
+    -- ^ The interfaces that this template implements.
+  }
+  deriving (Eq, Data, Generic, NFData, Show)
+
+-- | Template implementation of an interface.
+data TemplateImplements = TemplateImplements
+  { tpiInterface :: !(Qualified TypeConName)
+    -- ^ Interface name for implementation.
+  , tpiMethods :: !(NM.NameMap TemplateImplementsMethod)
+  }
+  deriving (Eq, Data, Generic, NFData, Show)
+
+-- | Template implementation of an interface's method.
+data TemplateImplementsMethod = TemplateImplementsMethod
+  { tpiMethodName :: !MethodName
+    -- ^ Name of method.
+  , tpiMethodExpr :: !Expr
+    -- ^ Method expression, has type @tpl -> mty@ where @tpl@ is the template type,
+    -- and @mty@ is the method's type as defined in the interface.
   }
   deriving (Eq, Data, Generic, NFData, Show)
 
@@ -895,6 +927,7 @@ data DefInterface = DefInterface
   { intLocation :: !(Maybe SourceLoc)
   , intName :: !TypeConName
   , intChoices :: !(NM.NameMap InterfaceChoice)
+  , intMethods :: !(NM.NameMap InterfaceMethod)
   }
   deriving (Eq, Data, Generic, NFData, Show)
 
@@ -907,6 +940,13 @@ data InterfaceChoice = InterfaceChoice
   }
   deriving (Eq, Data, Generic, NFData, Show)
 
+data InterfaceMethod = InterfaceMethod
+  { ifmLocation :: !(Maybe SourceLoc)
+  , ifmName :: !MethodName
+  , ifmType :: !Type
+  }
+  deriving (Eq, Data, Generic, NFData, Show)
+
 -- | Single choice of a contract template.
 data TemplateChoice = TemplateChoice
   { chcLocation :: !(Maybe SourceLoc)
@@ -1016,6 +1056,10 @@ instance NM.Named InterfaceChoice where
   type Name InterfaceChoice = ChoiceName
   name = ifcName
 
+instance NM.Named InterfaceMethod where
+  type Name InterfaceMethod = MethodName
+  name = ifmName
+
 instance NM.Named DefTypeSyn where
   type Name DefTypeSyn = TypeSynName
   name = synName
@@ -1040,6 +1084,14 @@ instance NM.Named Template where
   type Name Template = TypeConName
   name = tplTypeCon
 
+instance NM.Named TemplateImplements where
+  type Name TemplateImplements = Qualified TypeConName
+  name = tpiInterface
+
+instance NM.Named TemplateImplementsMethod where
+  type Name TemplateImplementsMethod = MethodName
+  name = tpiMethodName
+
 instance NM.Named Module where
   type Name Module = ModuleName
   name = moduleName

compiler/daml-lf-ast/src/DA/Daml/LF/Ast/FreeVars.hs

@@ -106,6 +106,7 @@ freeVarsStep = \case
     EThrowF t1 t2 e -> freeVarsInType t1 <> freeVarsInType t2 <> e
     EToInterfaceF _ _ e -> e
     EFromInterfaceF _ _ e -> e
+    ECallInterfaceF _ _ e -> e
     EExperimentalF _ t -> freeVarsInType t
 
   where

compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Optics.hs

@@ -76,7 +76,15 @@ templateExpr f (Template loc tpl param precond signatories observers agreement c
   <*> f agreement
   <*> (NM.traverse . templateChoiceExpr) f choices
   <*> (traverse . templateKeyExpr) f key
-  <*> pure implements
+  <*> (NM.traverse . templateImplementsExpr) f implements
+
+templateImplementsExpr :: Traversal' TemplateImplements Expr
+templateImplementsExpr f (TemplateImplements iface methods) =
+  TemplateImplements iface <$> (NM.traverse . templateImplementsMethodExpr) f methods
+
+templateImplementsMethodExpr :: Traversal' TemplateImplementsMethod Expr
+templateImplementsMethodExpr f (TemplateImplementsMethod name body) =
+  TemplateImplementsMethod name <$> f body
 
 templateKeyExpr :: Traversal' TemplateKey Expr
 templateKeyExpr f (TemplateKey typ body maintainers) =
@@ -125,6 +133,7 @@ instance MonoTraversable ModuleRef (Qualified a) where
     (\(pkg1, mod1) -> Qualified pkg1 mod1 x) <$> f (pkg0, mod0)
 
 instance MonoTraversable ModuleRef ChoiceName where monoTraverse _ = pure
+instance MonoTraversable ModuleRef MethodName where monoTraverse _ = pure
 instance MonoTraversable ModuleRef ExprValName where monoTraverse _ = pure
 instance MonoTraversable ModuleRef ExprVarName where monoTraverse _ = pure
 instance MonoTraversable ModuleRef FieldName where monoTraverse _ = pure
@@ -175,6 +184,7 @@ instance MonoTraversable ModuleRef DefTypeSyn
 instance MonoTraversable ModuleRef DefException
 
 instance MonoTraversable ModuleRef InterfaceChoice
+instance MonoTraversable ModuleRef InterfaceMethod
 instance MonoTraversable ModuleRef DefInterface
 
 instance MonoTraversable ModuleRef HasNoPartyLiterals
@@ -187,6 +197,8 @@ instance MonoTraversable ModuleRef Bool where monoTraverse _ = pure
 instance MonoTraversable ModuleRef TemplateChoice
 instance MonoTraversable ModuleRef TemplateKey
 instance MonoTraversable ModuleRef Template
+instance MonoTraversable ModuleRef TemplateImplements
+instance MonoTraversable ModuleRef TemplateImplementsMethod
 
 instance MonoTraversable ModuleRef FeatureFlags
 instance MonoTraversable ModuleRef Module

compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Pretty.hs

@@ -64,6 +64,9 @@ instance Pretty TypeConName where
 instance Pretty ChoiceName where
     pPrint = text . unChoiceName
 
+instance Pretty MethodName where
+    pPrint = text . unMethodName
+
 instance Pretty FieldName where
     pPrint = text . unFieldName
 
@@ -380,6 +383,9 @@ tplArg tpl = TyArg (TCon tpl)
 interfaceArg :: Qualified TypeConName -> Arg
 interfaceArg tpl = TyArg (TCon tpl)
 
+methodArg :: MethodName -> Arg
+methodArg = TmArg . EVar . ExprVarName . unMethodName
+
 instance Pretty Arg where
   pPrintPrec lvl _prec = \case
     TmArg e -> pPrintTmArg lvl e
@@ -541,6 +547,8 @@ instance Pretty Expr where
         [interfaceArg ty1, tplArg ty2, TmArg expr]
     EFromInterface ty1 ty2 expr -> pPrintAppKeyword lvl prec "from_interface"
         [interfaceArg ty1, tplArg ty2, TmArg expr]
+    ECallInterface ty mth expr -> pPrintAppKeyword lvl prec "call_interface"
+        [interfaceArg ty, methodArg mth, TmArg expr]
     EExperimental name _ ->  pPrint $ "$" <> name
 
 instance Pretty DefTypeSyn where
@@ -607,7 +615,7 @@ pPrintTemplate lvl modName (Template mbLoc tpl param precond signatories observe
   withSourceLoc lvl mbLoc $
     keyword_ "template" <-> pPrint tpl <-> pPrint param
     <-> keyword_ "where"
-    $$ nest 2 (vcat ([signatoriesDoc, observersDoc, precondDoc, agreementDoc] ++ mbImplementsDoc ++ mbKeyDoc ++ choiceDocs))
+    $$ nest 2 (vcat ([signatoriesDoc, observersDoc, precondDoc, agreementDoc] ++ implementsDoc ++ mbKeyDoc ++ choiceDocs))
     where
       signatoriesDoc = keyword_ "signatory" <-> pPrintPrec lvl 0 signatories
       observersDoc = keyword_ "observer" <-> pPrintPrec lvl 0 observers
@@ -621,10 +629,18 @@ pPrintTemplate lvl modName (Template mbLoc tpl param precond signatories observe
           , nest 2 (keyword_ "body" <-> pPrintPrec lvl 0 (tplKeyBody key))
           , nest 2 (keyword_ "maintainers" <-> pPrintPrec lvl 0 (tplKeyMaintainers key))
           ]
-      mbImplementsDoc
-        | null implements = []
-        | otherwise = [keyword_ "implements" <-> hsep (map (pPrintPrec lvl 0) implements)]
-
+      implementsDoc = map (pPrintTemplateImplements lvl) (NM.toList implements)
+
+pPrintTemplateImplements :: PrettyLevel -> TemplateImplements -> Doc ann
+pPrintTemplateImplements lvl (TemplateImplements name methods)
+  | NM.null methods = keyword_ "implements" <-> pPrintPrec lvl 0 name
+  | otherwise = vcat
+      $ (keyword_ "implements" <-> pPrintPrec lvl 0 name <-> keyword_ "where")
+      : map (nest 2 . pPrintTemplateImplementsMethod lvl) (NM.toList methods)
+
+pPrintTemplateImplementsMethod :: PrettyLevel -> TemplateImplementsMethod -> Doc ann
+pPrintTemplateImplementsMethod lvl (TemplateImplementsMethod name expr) =
+    pPrintPrec lvl 0 name <-> keyword_ "=" <-> pPrintPrec lvl 0 expr
 
 pPrintFeatureFlags :: FeatureFlags -> Doc ann
 pPrintFeatureFlags flags

compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Recursive.hs

@@ -52,6 +52,7 @@ data ExprF expr
   | EThrowF !Type !Type !expr
   | EToInterfaceF !(Qualified TypeConName) !(Qualified TypeConName) !expr
   | EFromInterfaceF !(Qualified TypeConName) !(Qualified TypeConName) !expr
+  | ECallInterfaceF !(Qualified TypeConName) !MethodName !expr
   | EExperimentalF !T.Text !Type
   deriving (Foldable, Functor, Traversable)
 
@@ -202,6 +203,7 @@ instance Recursive Expr where
     EThrow a b c -> EThrowF a b c
     EToInterface a b c -> EToInterfaceF a b c
     EFromInterface a b c -> EFromInterfaceF a b c
+    ECallInterface a b c -> ECallInterfaceF a b c
     EExperimental a b -> EExperimentalF a b
 
 instance Corecursive Expr where
@@ -238,4 +240,5 @@ instance Corecursive Expr where
     EThrowF a b c -> EThrow a b c
     EToInterfaceF a b c -> EToInterface a b c
     EFromInterfaceF a b c -> EFromInterface a b c
+    ECallInterfaceF a b c -> ECallInterface a b c
     EExperimentalF a b -> EExperimental a b

compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Subst.hs

@@ -196,6 +196,8 @@ applySubstInExpr subst@Subst{..} = \case
         (applySubstInExpr subst e)
     EFromInterface t1 t2 e -> EFromInterface t1 t2
         (applySubstInExpr subst e)
+    ECallInterface t m e -> ECallInterface t m
+        (applySubstInExpr subst e)
     EUpdate u -> EUpdate
         (applySubstInUpdate subst u)
     EScenario s -> EScenario

compiler/daml-lf-proto/src/DA/Daml/LF/Proto3/DecodeV1.hs

@@ -234,6 +234,7 @@ decodeDefInterface LF1.DefInterface {..} =
     <$> traverse decodeLocation defInterfaceLocation
     <*> decodeDottedNameId TypeConName defInterfaceTyconInternedDname
     <*> decodeNM DuplicateChoice decodeInterfaceChoice defInterfaceChoices
+    <*> decodeNM DuplicateMethod decodeInterfaceMethod defInterfaceMethods
 
 decodeInterfaceChoice :: LF1.InterfaceChoice -> Decode InterfaceChoice
 decodeInterfaceChoice LF1.InterfaceChoice {..} =
@@ -244,6 +245,15 @@ decodeInterfaceChoice LF1.InterfaceChoice {..} =
     <*> mayDecode "interfaceChoiceArgType" interfaceChoiceArgType decodeType
     <*> mayDecode "interfaceChoiceRetType" interfaceChoiceRetType decodeType
 
+decodeInterfaceMethod :: LF1.InterfaceMethod -> Decode InterfaceMethod
+decodeInterfaceMethod LF1.InterfaceMethod {..} = InterfaceMethod
+  <$> traverse decodeLocation interfaceMethodLocation
+  <*> decodeMethodName interfaceMethodMethodInternedName
+  <*> mayDecode "interfaceMethodType" interfaceMethodType decodeType
+
+decodeMethodName :: Int32 -> Decode MethodName
+decodeMethodName = decodeNameId MethodName
+
 decodeFeatureFlags :: LF1.FeatureFlags -> Decode FeatureFlags
 decodeFeatureFlags LF1.FeatureFlags{..} =
   if not featureFlagsDontDivulgeContractIdsInCreateArguments || not featureFlagsDontDiscloseNonConsumingChoicesToObservers
@@ -318,13 +328,17 @@ decodeDefTemplate LF1.DefTemplate{..} = do
     <*> mayDecode "defTemplateAgreement" defTemplateAgreement decodeExpr
     <*> decodeNM DuplicateChoice decodeChoice defTemplateChoices
     <*> mapM (decodeDefTemplateKey tplParam) defTemplateKey
-    <*> traverse decodeDefTemplateImplements (V.toList defTemplateImplements)
+    <*> decodeNM DuplicateImplements decodeDefTemplateImplements defTemplateImplements
+
+decodeDefTemplateImplements :: LF1.DefTemplate_Implements -> Decode TemplateImplements
+decodeDefTemplateImplements LF1.DefTemplate_Implements{..} = TemplateImplements
+  <$> mayDecode "defTemplate_ImplementsInterface" defTemplate_ImplementsInterface decodeTypeConName
+  <*> decodeNM DuplicateMethod decodeDefTemplateImplementsMethod defTemplate_ImplementsMethods
 
--- TODO https://github.com/digital-asset/daml/issues/11006
---   decode rest and store in AST
-decodeDefTemplateImplements :: LF1.DefTemplate_Implements -> Decode (Qualified TypeConName)
-decodeDefTemplateImplements LF1.DefTemplate_Implements{..} =
-  mayDecode "defTemplate_ImplementsInterface" defTemplate_ImplementsInterface decodeTypeConName
+decodeDefTemplateImplementsMethod :: LF1.DefTemplate_ImplementsMethod -> Decode TemplateImplementsMethod
+decodeDefTemplateImplementsMethod LF1.DefTemplate_ImplementsMethod{..} = TemplateImplementsMethod
+  <$> decodeMethodName defTemplate_ImplementsMethodMethodInternedName
+  <*> mayDecode "defTemplate_ImplementsMethodValue" defTemplate_ImplementsMethodValue decodeExpr
 
 decodeDefTemplateKey :: ExprVarName -> LF1.DefTemplate_DefKey -> Decode TemplateKey
 decodeDefTemplateKey templateParam LF1.DefTemplate_DefKey{..} = do
@@ -650,8 +664,10 @@ decodeExprSum exprSum = mayDecode "exprSum" exprSum $ \case
     <$> mayDecode "expr_FromInterfaceInterfaceType" expr_FromInterfaceInterfaceType decodeTypeConName
     <*> mayDecode "expr_FromInterfaceTemplateType" expr_FromInterfaceTemplateType decodeTypeConName
     <*> mayDecode "expr_FromInterfaceInterfaceExpr" expr_FromInterfaceInterfaceExpr decodeExpr
-  LF1.ExprSumCallInterface LF1.Expr_CallInterface {} ->
-    error "ECallInterface not implemented" -- TODO https://github.com/digital-asset/daml/issues/11006
+  LF1.ExprSumCallInterface LF1.Expr_CallInterface {..} -> ECallInterface
+    <$> mayDecode "expr_CallInterfaceInterfaceType" expr_CallInterfaceInterfaceType decodeTypeConName
+    <*> decodeMethodName expr_CallInterfaceMethodInternedName
+    <*> mayDecode "expr_CallInterfaceInterfaceExpr" expr_CallInterfaceInterfaceExpr decodeExpr
   LF1.ExprSumExperimental (LF1.Expr_Experimental name mbType) -> do
     ty <- mayDecode "expr_Experimental" mbType decodeType
     pure $ EExperimental (decodeString name) ty