Interface desugaring cont. (digital-asset#11964)

* Move toInterfaceContractId and fromInterfaceContractId out of Implements class * Split Implements class into single-method classes * Define toInterface outside its class to swap type arguments This allows users to call 'toInterface @interface', since the type of the template can usually be inferred * Move interface classes and functions to DA.Internal.Interface changelog_begin changelog_end
kgeonw · Dec 7, 2021 · 8df9a42 · 8df9a42
1 parent ef4ae93
commit 8df9a42
Show file tree

Hide file tree

Showing 19 changed files with 180 additions and 127 deletions.
diff --git a/bazel-haskell-deps.bzl b/bazel-haskell-deps.bzl
@@ -17,11 +17,11 @@ load("@os_info//:os_info.bzl", "is_linux", "is_windows")
 load("@dadew//:dadew.bzl", "dadew_tool_home")
 load("@rules_haskell//haskell:cabal.bzl", "stack_snapshot")
 
-GHC_LIB_REV = "342ccbe3c582820fe9e305e1c3954bba"
-GHC_LIB_SHA256 = "96ed0322efc367774cebb00c61945ad5fe276bf1a801734ececc232d55a04591"
+GHC_LIB_REV = "7b12411cd3ebc707c16eb308e1535ad6"
+GHC_LIB_SHA256 = "05c30d529df636e85181af75c7fefeee4888b6146c2e62745eb2e5086d00ce06"
 GHC_LIB_VERSION = "8.8.1"
-GHC_LIB_PARSER_REV = "342ccbe3c582820fe9e305e1c3954bba"
-GHC_LIB_PARSER_SHA256 = "287468de32f45bc75c52842817784d16b5a4dd6e7d311d661dfbe57cce7a719e"
+GHC_LIB_PARSER_REV = "7b12411cd3ebc707c16eb308e1535ad6"
+GHC_LIB_PARSER_SHA256 = "c60f010769fe7d0b7cc425d35c541c4511ef3c58ccaa6559d453c86f3bd6cb83"
 GHC_LIB_PARSER_VERSION = "8.8.1"
 GHCIDE_REV = "e04b5386b3741b839eb5c3d2a2586fd2aa97229c"
 GHCIDE_SHA256 = "1d27926e0ad3c2a9536f23b454875a385ecc766ae68ce48a0ec88d0867884b46"

diff --git a/ci/da-ghc-lib/compile.yml b/ci/da-ghc-lib/compile.yml
@@ -12,7 +12,7 @@ jobs:
   variables:
     ghc-lib-sha: '362d4f38a7ac10521393de9b7ad942a77a2605be'
     base-sha: '9c787d4d24f2b515934c8503ee2bbd7cfac4da20'
-    patches: '6af5f6d01846cf175609f7a79fc27cf3a62016d1 833ca63be2ab14871874ccb6974921e8952802e9'
+    patches: '13e692597b82ada422bce419c47a3dfcb0614c00 833ca63be2ab14871874ccb6974921e8952802e9'
     flavor: 'da-ghc-8.8.1'
   steps:
   - checkout: self

diff --git a/compiler/damlc/daml-doc/src/DA/Daml/Doc/Extract.hs b/compiler/damlc/daml-doc/src/DA/Daml/Doc/Extract.hs
@@ -87,11 +87,12 @@ extractDocs extractOpts diagsLogger ideOpts fp = do
                         Nothing -> Left classDoc
                         Just templateName -> Right (templateName, classDoc)
             templateInstanceClassMap = MS.fromList templateInstanceClasses
+            templateImplementsMap = getTemplateImplementsMap ctx dc_decls
 
             md_name = dc_modname
             md_anchor = Just (moduleAnchor md_name)
             md_descr = modDoc tcmod
-            md_templates = getTemplateDocs ctx typeMap templateInstanceClassMap
+            md_templates = getTemplateDocs ctx typeMap templateInstanceClassMap templateImplementsMap
             md_interfaces = getInterfaceDocs ctx typeMap
             md_functions = mapMaybe (getFctDocs ctx) dc_decls
             md_instances = map (getInstanceDocs ctx) dc_insts
@@ -204,6 +205,20 @@ haddockParse diagsLogger opts f = MaybeT $ do
 
 ------------------------------------------------------------
 
+-- | Extracts the set of interface types implemented by each template type.
+getTemplateImplementsMap :: DocCtx -> [DeclData] -> MS.Map Typename (Set.Set DDoc.Type)
+getTemplateImplementsMap ctx@DocCtx{..} decls =
+    MS.fromListWith Set.union
+        [ (t, Set.singleton iface)
+        | DeclData decl _ <- decls
+        , name <- case unLoc decl of
+            SigD _ (TypeSig _ (L _ n :_) _) -> [packRdrName n]
+            _ -> []
+        , Just _ <- [T.stripPrefix "_implements_" name]
+        , Just id <- [MS.lookup (Fieldname name) dc_ids]
+        , TypeApp _ (Typename "ImplementsT") [TypeApp _ t [], iface] <- [typeToType ctx $ idType id]
+        ]
+
 -- | Extracts the documentation of a function. Comments are either
 --   adjacent to a type signature, or to the actual function definition. If
 --   neither a comment nor a function type is in the source, we omit the
@@ -230,6 +245,7 @@ getFctDocs ctx@DocCtx{..} (DeclData decl docs) = do
 
     guard (exportsFunction dc_exports fct_name)
     guard (not $ "_choice_" `T.isPrefixOf` packRdrName name)
+    guard (not $ "_implements_" `T.isPrefixOf` packRdrName name)
     Just FunctionDoc {..}
 
 getClsDocs :: DocCtx -> DeclData -> Maybe ClassDoc

diff --git a/compiler/damlc/daml-doc/src/DA/Daml/Doc/Extract/Templates.hs b/compiler/damlc/daml-doc/src/DA/Daml/Doc/Extract/Templates.hs
@@ -10,6 +10,7 @@ module DA.Daml.Doc.Extract.Templates
     ) where
 
 import DA.Daml.Doc.Types
+import qualified DA.Daml.Doc.Types as DDoc
 import DA.Daml.Doc.Extract.Types
 import DA.Daml.Doc.Extract.Util
 import DA.Daml.Doc.Extract.TypeExpr
@@ -31,8 +32,9 @@ getTemplateDocs ::
     DocCtx
     -> MS.Map Typename ADTDoc -- ^ maps template names to their ADT docs
     -> MS.Map Typename ClassDoc -- ^ maps template names to their template instance class docs
+    -> MS.Map Typename (Set.Set DDoc.Type)-- ^ maps template names to their implemented interfaces' types
     -> [TemplateDoc]
-getTemplateDocs DocCtx{..} typeMap templateInstanceMap =
+getTemplateDocs DocCtx{..} typeMap templateInstanceMap templateImplementsMap =
     map mkTemplateDoc $ Set.toList dc_templates
   where
     -- The following functions use the type map and choice map in scope, so
@@ -47,8 +49,9 @@ getTemplateDocs DocCtx{..} typeMap templateInstanceMap =
       , td_payload = getFields tmplADT
       -- assumes exactly one record constructor (syntactic, template syntax)
       , td_choices = map (mkChoiceDoc typeMap) choices
-      -- is filled via distributeInstanceDocs
-      , td_impls = []
+      , td_impls =
+          ImplDoc <$>
+            Set.toList (MS.findWithDefault mempty name templateImplementsMap)
       }
       where
         tmplADT = asADT typeMap name

diff --git a/compiler/damlc/daml-doc/src/DA/Daml/Doc/Transform/Instances.hs b/compiler/damlc/daml-doc/src/DA/Daml/Doc/Transform/Instances.hs
@@ -10,7 +10,6 @@ import DA.Daml.Doc.Transform.Options
 
 import qualified Data.Map as Map
 import qualified Data.Set as Set
-import Safe
 
 type InstanceMap = Map.Map Anchor (Set.Set InstanceDoc)
 
@@ -54,7 +53,7 @@ distributeInstanceDocs opts docs =
         , md_anchor = md_anchor
         , md_descr = md_descr
         , md_functions = md_functions
-        , md_templates = map (addIfaceImpls imap) md_templates
+        , md_templates = md_templates
         , md_interfaces = md_interfaces
         , md_classes = map (addClassInstances imap) md_classes
         , md_adts = map (addTypeInstances imap) md_adts
@@ -77,19 +76,3 @@ distributeInstanceDocs opts docs =
             anchor <- ad_anchor ad
             Map.lookup anchor imap
         }
-
-    addIfaceImpls :: InstanceMap -> TemplateDoc -> TemplateDoc
-    addIfaceImpls imap td = td
-        { td_impls =
-            [ ImplDoc iface_type
-            | InstanceDoc {id_type, id_module} <-
-                maybe [] Set.toList $ do
-                  anchor <- td_anchor td
-                  Map.lookup anchor imap
-            , Just "Implements" == getTypeAppName id_type
-            , "DA.Internal.Desugar" == id_module
-            , Just args <- [getTypeAppArgs id_type]
-            , Just iface_type <- [lastMay args]
-            ]
-        }
-
diff --git a/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs b/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs
@@ -441,16 +441,9 @@ convertInterfaces env binds = interfaceDefs
   where
     interfaceDefs :: ConvertM [Definition]
     interfaceDefs = sequence
-      [ DInterface <$> convertInterface name tycon
-      | (name, val) <- binds
-      -- We're looking for `instance DA.Internal.Desugar.Implements I I`
-      , DFunId _ <- [idDetails name]
-      , TypeCon implementsCls [TypeCon tpl [], TypeCon ifc []] <- [varType name]
-      , NameIn DA_Internal_Desugar "Implements" <- [implementsCls]
-      , tpl == ifc
-      , let name = TypeConName [getOccText ifc]
-            tycon = ifc
-      ]
+        [ DInterface <$> convertInterface name tycon
+        | (name, tycon) <- MS.toList (envInterfaces env)
+        ]
 
     convertInterface :: LF.TypeConName -> GHC.TyCon -> ConvertM DefInterface
     convertInterface intName tyCon = do
@@ -537,9 +530,9 @@ convertModule lfVersion pkgMap stablePackages isGenerated file x depOrphanModule
         tplImplements = MS.fromListWith (++)
           [ (mkTypeCon [getOccText tpl], [iface])
           | (name, _val) <- binds
-          , DFunId _ <- [idDetails name]
-          , TypeCon implementsCls [TypeCon tpl [], TypeCon iface []] <- [varType name]
-          , NameIn DA_Internal_Desugar "Implements" <- [implementsCls]
+          , "_implements_" `T.isPrefixOf` getOccText name
+          , TypeCon implementsT [TypeCon tpl [], TypeCon iface []] <- [varType name]
+          , NameIn DA_Internal_Desugar "ImplementsT" <- [implementsT]
           ]
         tplInterfaceMethodInstances :: MS.Map (GHC.Module, TypeConName, TypeConName) [(T.Text, GHC.Expr GHC.CoreBndr)]
         tplInterfaceMethodInstances = MS.fromListWith (++)
@@ -569,24 +562,22 @@ convertModule lfVersion pkgMap stablePackages isGenerated file x depOrphanModule
         emptyInterfaces :: S.Set (GHC.Module, TypeConName)
         emptyInterfaces = S.fromList
           [ (mod, mkTypeCon [getOccText ifc])
-          | (name, val) <- binds
-          -- We're looking for `instance DA.Internal.Desugar.Implements I I`
-          , DFunId _ <- [idDetails name]
-          , TypeCon implementsCls [TypeCon tpl [], TypeCon ifc []] <- [varType name]
-          , NameIn DA_Internal_Desugar "Implements" <- [implementsCls]
-          , Just mod <- [nameModule_maybe (getName ifc)]
-          , tpl == ifc
+          |
+          -- We're looking for `data DamlInterface => I = ...`
+            (_, ifc) <- MS.toList interfaceCons
           -- such that there are no `instance HasMethod I _ _`
           , null
             [ ()
-            | (name, val) <- binds
+            | (name, _) <- binds
             , DFunId _ <- [idDetails name]
             , TypeCon hasMethodCls
               [ TypeCon ((== ifc) -> True) []
               , _
               , _
               ] <- [varType name]
+            , NameIn DA_Internal_Desugar "HasMethod" <- [hasMethodCls]
             ]
+          , Just mod <- [nameModule_maybe (getName ifc)]
           ]
         choiceData = MS.fromListWith (++)
             [ (mkTypeCon [getOccText tplTy], [ChoiceData ty v])
@@ -1201,6 +1192,7 @@ desugarTypes = mkUniqSet
     , "NonConsuming"
     , "Method"
     , "HasMethod"
+    , "ImplementsT"
     ]
 
 internalFunctions :: UniqFM (UniqSet FastString)

diff --git a/compiler/damlc/daml-stdlib-src/DA/Internal/Desugar.daml b/compiler/damlc/daml-stdlib-src/DA/Internal/Desugar.daml
@@ -3,28 +3,30 @@
 
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 
 -- | HIDE Automatically imported qualified in every module.
 module DA.Internal.Desugar (
     module DA.Internal.Template,
     module DA.Internal.Template.Functions,
     module DA.Internal.Exception,
+    module DA.Internal.Interface,
     Eq(..), Show(..),
     Bool(..), Text, Optional(..),
     concat, magic,
     Party, ContractId, Update, Any,
     NonConsuming(..), PreConsuming(..), PostConsuming(..), Consuming(..),
-    HasInterfaceTypeRep(..),
-    Implements(..),
     TypeRep,
+    ImplementsT(..),
     HasMethod,
     mkMethod,
 ) where
 
 import DA.Internal.Prelude
 import DA.Internal.Template
 import DA.Internal.Template.Functions
+import DA.Internal.Interface
 import DA.Internal.LF
 #ifndef DAML_EXCEPTIONS
 import DA.Internal.Exception ()
@@ -39,14 +41,9 @@ data PreConsuming t = PreConsuming {}
 data Consuming t = Consuming {}
 data PostConsuming t = PostConsuming {}
 
-class HasInterfaceTypeRep i where
-  interfaceTypeRep : i -> TypeRep
-
-class HasInterfaceTypeRep i => Implements t i where
-  toInterface : t -> i
-  fromInterface : i -> Optional t
-  toInterfaceContractId : ContractId t -> ContractId i
-  fromInterfaceContractId : ContractId i -> Update (Optional (ContractId t))
+-- Used to construct markers representing the fact that
+-- a template `t` implements an interface `i`.
+data ImplementsT t i = ImplementsT
 
 {-
 Together, `HasMethod`, `Method` and `mkMethod` allow us to desugar the methods of

diff --git a/compiler/damlc/daml-stdlib-src/DA/Internal/Interface.daml b/compiler/damlc/daml-stdlib-src/DA/Internal/Interface.daml
@@ -0,0 +1,65 @@
+-- Copyright (c) 2021 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
+-- SPDX-License-Identifier: Apache-2.0
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- | MOVE Prelude interface functionality
+module DA.Internal.Interface (
+  HasInterfaceTypeRep(..),
+  HasToInterface(..),
+  HasFromInterface(..),
+  Implements,
+  toInterface,
+  toInterfaceContractId,
+  fromInterfaceContractId,
+) where
+
+import DA.Internal.Prelude
+import DA.Internal.Template.Functions
+import DA.Internal.LF
+
+class HasInterfaceTypeRep i where
+  interfaceTypeRep : i -> TypeRep
+
+class HasToInterface t i where
+  _toInterface : t -> i
+
+-- Note that this seems identical to the method '_toInterface'. The only difference
+-- is the order of the type arguments. This allows `toInterface` to be type-applied to
+-- the interface type first, which is usually more convenient.
+-- i.e., for a value `asset` of template Asset which implements an interface Token,
+--
+-- @
+--   token = toInterface @Token asset
+-- @
+--
+-- This way, it's clear to readers what interface is being used, without needing
+-- to provide/skip the template type argument, cf.
+--
+-- @
+--   token = _toInterface @Asset @Token asset
+--   token = _toInterface @_ @Token asset
+-- @
+--
+toInterface : forall i t. HasToInterface t i => t -> i
+toInterface = _toInterface
+
+class HasFromInterface t i where
+  fromInterface : i -> Optional t
+
+type Implements t i =
+  ( HasInterfaceTypeRep i
+  , HasToInterface t i
+  , HasFromInterface t i
+  )
+
+toInterfaceContractId : forall i t. HasToInterface t i => ContractId t -> ContractId i
+toInterfaceContractId = coerceContractId
+
+fromInterfaceContractId : forall t i. (HasFromInterface t i, HasFetch i) => ContractId i -> Update (Optional (ContractId t))
+fromInterfaceContractId cid = do
+  iface <- fetch cid
+  pure $
+    const (coerceContractId cid) <$> fromInterface @t iface
diff --git a/compiler/damlc/daml-stdlib-src/Prelude.daml b/compiler/damlc/daml-stdlib-src/Prelude.daml
@@ -25,7 +25,4 @@ import DA.Internal.Template.Functions as X
 #endif
 import DA.Internal.Compatible as X
 import DA.Internal.Assert as X
-import DA.Internal.Desugar as X
-  ( HasInterfaceTypeRep(..)
-  , Implements (..)
-  )
+import DA.Internal.Interface as X
diff --git a/compiler/damlc/tests/daml-test-files/Interface.EXPECTED.md b/compiler/damlc/tests/daml-test-files/Interface.EXPECTED.md
@@ -48,24 +48,24 @@
 
 <a name="function-interface-noopimpl-83220"></a>[noopImpl](#function-interface-noopimpl-83220)
 
-> : Implements t [Token](#type-interface-token-72202) =\> t -\> () -\> [Update](https://docs.daml.com/daml/stdlib/Prelude.html#type-da-internal-lf-update-36457) ()
+> : [Implements](https://docs.daml.com/daml/stdlib/Prelude.html#type-da-internal-interface-implements-77034) t [Token](#type-interface-token-72202) =\> t -\> () -\> [Update](https://docs.daml.com/daml/stdlib/Prelude.html#type-da-internal-lf-update-36457) ()
 
 <a name="function-interface-transferimpl-81005"></a>[transferImpl](#function-interface-transferimpl-81005)
 
-> : Implements t [Token](#type-interface-token-72202) =\> t -\> [Party](https://docs.daml.com/daml/stdlib/Prelude.html#type-da-internal-lf-party-50311) -\> [Update](https://docs.daml.com/daml/stdlib/Prelude.html#type-da-internal-lf-update-36457) ([ContractId](https://docs.daml.com/daml/stdlib/Prelude.html#type-da-internal-lf-contractid-47171) [Token](#type-interface-token-72202))
+> : [Implements](https://docs.daml.com/daml/stdlib/Prelude.html#type-da-internal-interface-implements-77034) t [Token](#type-interface-token-72202) =\> t -\> [Party](https://docs.daml.com/daml/stdlib/Prelude.html#type-da-internal-lf-party-50311) -\> [Update](https://docs.daml.com/daml/stdlib/Prelude.html#type-da-internal-lf-update-36457) ([ContractId](https://docs.daml.com/daml/stdlib/Prelude.html#type-da-internal-lf-contractid-47171) [Token](#type-interface-token-72202))
 
 <a name="function-interface-splitimpl-48531"></a>[splitImpl](#function-interface-splitimpl-48531)
 
-> : Implements t [Token](#type-interface-token-72202) =\> t -\> [Int](https://docs.daml.com/daml/stdlib/Prelude.html#type-ghc-types-int-68728) -\> [Update](https://docs.daml.com/daml/stdlib/Prelude.html#type-da-internal-lf-update-36457) ([ContractId](https://docs.daml.com/daml/stdlib/Prelude.html#type-da-internal-lf-contractid-47171) [Token](#type-interface-token-72202), [ContractId](https://docs.daml.com/daml/stdlib/Prelude.html#type-da-internal-lf-contractid-47171) [Token](#type-interface-token-72202))
+> : [Implements](https://docs.daml.com/daml/stdlib/Prelude.html#type-da-internal-interface-implements-77034) t [Token](#type-interface-token-72202) =\> t -\> [Int](https://docs.daml.com/daml/stdlib/Prelude.html#type-ghc-types-int-68728) -\> [Update](https://docs.daml.com/daml/stdlib/Prelude.html#type-da-internal-lf-update-36457) ([ContractId](https://docs.daml.com/daml/stdlib/Prelude.html#type-da-internal-lf-contractid-47171) [Token](#type-interface-token-72202), [ContractId](https://docs.daml.com/daml/stdlib/Prelude.html#type-da-internal-lf-contractid-47171) [Token](#type-interface-token-72202))
 
 <a name="function-interface-setamount-71357"></a>[setAmount](#function-interface-setamount-71357)
 
-> : Implements t [Token](#type-interface-token-72202) =\> t -\> [Int](https://docs.daml.com/daml/stdlib/Prelude.html#type-ghc-types-int-68728) -\> [Token](#type-interface-token-72202)
+> : [Implements](https://docs.daml.com/daml/stdlib/Prelude.html#type-da-internal-interface-implements-77034) t [Token](#type-interface-token-72202) =\> t -\> [Int](https://docs.daml.com/daml/stdlib/Prelude.html#type-ghc-types-int-68728) -\> [Token](#type-interface-token-72202)
 
 <a name="function-interface-getamount-93321"></a>[getAmount](#function-interface-getamount-93321)
 
-> : Implements t [Token](#type-interface-token-72202) =\> t -\> [Int](https://docs.daml.com/daml/stdlib/Prelude.html#type-ghc-types-int-68728)
+> : [Implements](https://docs.daml.com/daml/stdlib/Prelude.html#type-da-internal-interface-implements-77034) t [Token](#type-interface-token-72202) =\> t -\> [Int](https://docs.daml.com/daml/stdlib/Prelude.html#type-ghc-types-int-68728)
 
 <a name="function-interface-getowner-9315"></a>[getOwner](#function-interface-getowner-9315)
 
-> : Implements t [Token](#type-interface-token-72202) =\> t -\> [Party](https://docs.daml.com/daml/stdlib/Prelude.html#type-da-internal-lf-party-50311)
+> : [Implements](https://docs.daml.com/daml/stdlib/Prelude.html#type-da-internal-interface-implements-77034) t [Token](#type-interface-token-72202) =\> t -\> [Party](https://docs.daml.com/daml/stdlib/Prelude.html#type-da-internal-lf-party-50311)