Desugar interface implements declarations (#10895)

* Desugar interface implements declarations

This PR adds desugaring for tplImplements. This consists of the
corresponding typeclass instance (which we just ignore in LF for now,
we probably need it once we have pure functions) and a _implements_
top-level value.

changelog_begin
changelog_end

* Address review feedback

changelog_begin
changelog_end

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

@@ -590,11 +590,11 @@ pPrintTemplateChoice lvl modName tpl (TemplateChoice mbLoc name isConsuming cont
 
 pPrintTemplate ::
   PrettyLevel -> ModuleName -> Template -> Doc ann
-pPrintTemplate lvl modName (Template mbLoc tpl param precond signatories observers agreement choices mbKey _implements) = -- TODO interfaces
+pPrintTemplate lvl modName (Template mbLoc tpl param precond signatories observers agreement choices mbKey implements) =
   withSourceLoc lvl mbLoc $
     keyword_ "template" <-> pPrint tpl <-> pPrint param
     <-> keyword_ "where"
-    $$ nest 2 (vcat ([signatoriesDoc, observersDoc, precondDoc, agreementDoc] ++ mbKeyDoc ++ choiceDocs))
+    $$ nest 2 (vcat ([signatoriesDoc, observersDoc, precondDoc, agreementDoc] ++ mbImplementsDoc ++ mbKeyDoc ++ choiceDocs))
     where
       signatoriesDoc = keyword_ "signatory" <-> pPrintPrec lvl 0 signatories
       observersDoc = keyword_ "observer" <-> pPrintPrec lvl 0 observers
@@ -608,6 +608,10 @@ 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)]
+
 
 pPrintFeatureFlags :: FeatureFlags -> Doc ann
 pPrintFeatureFlags flags

compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs

@@ -175,6 +175,8 @@ data Env = Env
     ,envTemplateBinds :: MS.Map TypeConName TemplateBinds
     ,envExceptionBinds :: MS.Map TypeConName ExceptionBinds
     ,envChoiceData :: MS.Map TypeConName [ChoiceData]
+    ,envImplements :: MS.Map TypeConName [GHC.Type]
+    ,envInterfaces :: S.Set TypeConName
     ,envIsGenerated :: Bool
     ,envTypeVars :: !(MS.Map Var TypeVarName)
         -- ^ Maps GHC type variables in scope to their LF type variable names
@@ -408,18 +410,21 @@ modInstanceInfoFromDetails :: ModDetails -> ModInstanceInfo
 modInstanceInfoFromDetails ModDetails{..} = MS.fromList
     [ (is_dfun, overlapMode is_flag) | ClsInst{..} <- md_insts ]
 
+interfaceNames :: LF.Version -> [TyThing] -> S.Set TypeConName
+interfaceNames lfVersion tyThings
+    | lfVersion `supports` featureInterfaces =
+      S.fromList [ mkTypeCon [getOccText t] | ATyCon t <- tyThings, hasDamlInterfaceCtx t ]
+    | otherwise = S.empty
+
 convertInterfaces :: Env -> [TyThing] -> ConvertM [Definition]
-convertInterfaces env tyThings
-  | envLfVersion env `supports` featureInterfaces = interfaceClasses
-  | otherwise = pure []
+convertInterfaces env tyThings = interfaceClasses
   where
-    interfaceCons = S.fromList [ getOccText t | ATyCon t <- tyThings, hasDamlInterfaceCtx t ]
     interfaceClasses = sequence
         [ DInterface <$> convertInterface interface cls
         | ATyCon t <- tyThings
         , Just cls <- [tyConClass_maybe t]
         , Just interface <- [T.stripPrefix "Is" (getOccText t)]
-        , interface `S.member` interfaceCons
+        , TypeConName [interface] `S.member` (envInterfaces env)
         ]
     convertInterface :: T.Text -> Class -> ConvertM DefInterface
     convertInterface name cls = do
@@ -475,6 +480,13 @@ convertModule lfVersion pkgMap stablePackages isGenerated file x details = runCo
                 | otherwise -> [(name, body)]
               Rec binds -> binds
           ]
+        interfaceCons = interfaceNames lfVersion (eltsUFM (cm_types x))
+        tplImplements = MS.fromListWith (++)
+           [ (mkTypeCon [getOccText tplTy], [ifaceTy])
+           | (name, _) <- binds
+           , "_implements_" `T.isPrefixOf` getOccText name
+           , TypeCon _ [TypeCon tplTy [], ifaceTy] <- [varType name]
+           ]
         choiceData = MS.fromListWith (++)
             [ (mkTypeCon [getOccText tplTy], [ChoiceData ty v])
             | (name, v) <- binds
@@ -496,8 +508,10 @@ convertModule lfVersion pkgMap stablePackages isGenerated file x details = runCo
           , envPkgMap = pkgMap
           , envStablePackages = stablePackages
           , envLfVersion = lfVersion
+          , envInterfaces = interfaceCons
           , envTemplateBinds = templateBinds
           , envExceptionBinds = exceptionBinds
+          , envImplements = tplImplements
           , envChoiceData = choiceData
           , envIsGenerated = isGenerated
           , envTypeVars = MS.empty
@@ -518,9 +532,9 @@ convertTypeDef env o@(ATyCon t) = withRange (convNameLoc t) $ if
     , n `elementOfUniqSet` internalTypes
     -> pure []
     | NameIn DA_Internal_Prelude "Optional" <- t -> pure []
-    -- Consumption marker types used to transfer information from template desugaring to LF conversion.
+    -- Types used only for desugaring are dropped during the LF conversion.
     | NameIn DA_Internal_Desugar n <- t
-    , n `elementOfUniqSet` consumingTypes
+    , n `elementOfUniqSet` desugarTypes
     -> pure []
 
     | hasDamlInterfaceCtx t && envLfVersion env `supports` featureInterfaces
@@ -743,8 +757,7 @@ convertTemplate env tplTypeCon tbinds@TemplateBinds{..}
         tplAgreement <- useSingleMethodDict env fAgreement (`ETmApp` EVar this)
         tplChoices <- convertChoices env tplTypeCon tbinds
         tplKey <- convertTemplateKey env tplTypeCon tbinds
-        -- TODO https://github.com/digital-asset/daml/issues/10810
-        let tplImplements = []
+        tplImplements <- convertImplements env tplTypeCon
         pure Template {..}
 
     | otherwise =
@@ -814,6 +827,16 @@ useSingleMethodDict env (Cast ghcExpr _) f = do
 useSingleMethodDict env x _ =
     unhandled "useSingleMethodDict: not a single method type class dictionary" x
 
+convertImplements :: Env -> LF.TypeConName -> ConvertM [Qualified TypeConName]
+convertImplements env tplTypeCon =
+    mapM convertInterfaceCon (MS.findWithDefault [] tplTypeCon (envImplements env))
+  where
+    convertInterfaceCon ty = do
+        ty' <- convertType env ty
+        case ty' of
+            TCon con -> pure con
+            _ -> unhandled "interface type" ty
+
 convertChoices :: Env -> LF.TypeConName -> TemplateBinds -> ConvertM (NM.NameMap TemplateChoice)
 convertChoices env tplTypeCon tbinds =
     NM.fromList <$> traverse (convertChoice env tbinds)
@@ -828,7 +851,7 @@ convertChoice env tbinds (ChoiceData ty expr)
               , (_, action)
               , _
               , (_, optObservers)
-              ] <- convertExpr env expr
+              ] <- removeLocations <$> convertExpr env expr
 
     mbObservers <-
       case optObservers of
@@ -876,11 +899,21 @@ convertBind env (name, x)
     | "_choice_" `T.isPrefixOf` getOccText name
     = pure []
 
+    -- These are only used as markers for the LF conversion.
+    | "_implements_" `T.isPrefixOf` getOccText name
+    = pure []
+
     -- Remove internal functions.
     | Just internals <- lookupUFM internalFunctions (envGHCModuleName env)
     , getOccFS name `elementOfUniqSet` internals
     = pure []
 
+    -- TODO https://github.com/digital-asset/daml/issues/10810
+    -- Reconsider once we have a constructor for existential interfaces
+    -- in LF.
+    | Just iface <- T.stripPrefix "$W" (getOccText name)
+    , mkTypeCon [iface] `S.member` (envInterfaces env) = pure []
+
     -- NOTE(MH): Our inline return type syntax produces a local letrec for
     -- recursive functions. We currently don't support local letrecs.
     -- However, we can work around this issue by rewriting
@@ -963,8 +996,8 @@ internalTypes = mkUniqSet
     , "Experimental"
     ]
 
-consumingTypes :: UniqSet FastString
-consumingTypes = mkUniqSet ["Consuming", "PreConsuming", "PostConsuming", "NonConsuming"]
+desugarTypes :: UniqSet FastString
+desugarTypes = mkUniqSet ["Consuming", "PreConsuming", "PostConsuming", "NonConsuming", "Implements"]
 
 internalFunctions :: UniqFM (UniqSet FastString)
 internalFunctions = listToUFM $ map (bimap mkModuleNameFS mkUniqSet)

compiler/damlc/daml-stdlib-src/DA/Internal/Desugar.daml

@@ -14,7 +14,8 @@ module DA.Internal.Desugar (
     Bool(..), Text, Optional(..),
     concat, magic,
     Party, ContractId, Update, Any,
-    NonConsuming(..), PreConsuming(..), PostConsuming(..), Consuming(..)
+    NonConsuming(..), PreConsuming(..), PostConsuming(..), Consuming(..),
+    Implements(..),
 ) where
 
 import DA.Internal.Prelude
@@ -33,3 +34,4 @@ data NonConsuming t = NonConsuming {}
 data PreConsuming t = PreConsuming {}
 data Consuming t = Consuming {}
 data PostConsuming t = PostConsuming {}
+data Implements t i = Implements

compiler/damlc/tests/daml-test-files/InterfaceDesugared.daml

@@ -23,12 +23,83 @@ class
 data GHC.Types.DamlInterface => Token = Token GHC.Types.Opaque
 
 instance HasExercise Token Split (ContractId Token, ContractId Token) where
-  exercise = GHC.Types.primitive @"UExercise"
+  exercise = error "unimplemented"
+  -- TODO https://github.com/digital-asset/daml/issues/10810
+  -- Switch to this once the Haskell typechecker is fixed
+  -- GHC.Types.primitive @"UExercise"
 
 instance HasExercise Token Transfer (ContractId Token) where
-  exercise = GHC.Types.primitive @"UExercise"
+  exercise = error "unimplemented"
+  -- TODO https://github.com/digital-asset/daml/issues/10810
+  -- Switch to this once the Haskell typechecker is fixed
+  -- GHC.Types.primitive @"UExercise"
 
 instance IsToken Token where
 -- TODO https://github.com/digital-asset/daml/issues/10810
 -- enable once we support pure functions
 --  getAmount = primitivInterface @"getAmount"
+
+data Asset = Asset { amount : Decimal, issuer : Party, owner : Party }
+  deriving (Eq, Show)
+
+instance IsToken Asset where
+-- TODO https://github.com/digital-asset/daml/issues/10810
+-- enable once we support pure functions
+--  getAmount Asset{..} = amount
+
+_implements_AssetToken : DA.Internal.Desugar.Implements Asset Token
+_implements_AssetToken = DA.Internal.Desugar.Implements
+
+instance HasCreate Asset where
+  create = GHC.Types.primitive @"UCreate"
+
+instance HasSignatory Asset where
+  signatory = error "unimplemented"
+
+instance HasEnsure Asset where
+  ensure = error "unimplemented"
+
+instance HasAgreement Asset where
+  agreement = error "agreement"
+
+instance HasObserver Asset where
+  observer = error "unimplemented"
+
+instance HasExercise Asset Transfer (ContractId Token) where
+  exercise = GHC.Types.primitive @"UExercise"
+
+instance HasExercise Asset Archive () where
+  exercise = GHC.Types.primitive @"UExercise"
+
+instance HasExercise Asset Split (ContractId Token, ContractId Token) where
+  exercise = GHC.Types.primitive @"UExercise"
+
+instance HasArchive Asset where
+  archive cid = exercise cid Archive
+
+_choice_AssetTransfer :
+  ( Asset -> Transfer -> [DA.Internal.Desugar.Party]
+  , DA.Internal.Desugar.ContractId Asset -> Asset -> Transfer -> DA.Internal.Desugar.Update (ContractId Token)
+  , DA.Internal.Desugar.Consuming Asset
+  , DA.Internal.Desugar.Optional (Asset -> Transfer -> [DA.Internal.Desugar.Party])
+  )
+_choice_AssetTransfer =
+  (error "abc", error "abc", error "abc", DA.Internal.Desugar.None)
+
+_choice_AssetArchive :
+  ( Asset -> Archive -> [DA.Internal.Desugar.Party]
+  , DA.Internal.Desugar.ContractId Asset -> Asset -> Archive -> DA.Internal.Desugar.Update ()
+  , DA.Internal.Desugar.Consuming Asset
+  , DA.Internal.Desugar.Optional (Asset -> Archive -> [DA.Internal.Desugar.Party])
+  )
+_choice_AssetArchive =
+  (error "abc", error "abc", error "abc", DA.Internal.Desugar.None)
+
+_choice_AssetSplit :
+  ( Asset -> Split -> [DA.Internal.Desugar.Party]
+  , DA.Internal.Desugar.ContractId Asset -> Asset -> Split -> DA.Internal.Desugar.Update (ContractId Token, ContractId Token)
+  , DA.Internal.Desugar.Consuming Asset
+  , DA.Internal.Desugar.Optional (Asset -> Split -> [DA.Internal.Desugar.Party])
+  )
+_choice_AssetSplit =
+  (error "abc", error "abc", error "abc", DA.Internal.Desugar.None)