interfaces: consuming/non-consuming iface choices (#11009)

* interfaces: consuming/non-consuming iface choices We add the consumption behaviour to the interface choice definition and typecheck accordingly. CHANGELOG_BEGIN CHANGELOG_END update to new ghc-lib, conversion implementation * update ghc-lib * pinning stackage on unix * pin stackage on windows
digital-asset · Sep 30, 2021 · 9fd6326 · 9fd6326
1 parent 229ce47
commit 9fd6326
Show file tree

Hide file tree

Showing 8 changed files with 122 additions and 39 deletions.
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: '42e5c306dcfbc84b83336fdd531023e93bfcc5b2'
     base-sha: '9c787d4d24f2b515934c8503ee2bbd7cfac4da20'
-    patches: 'f369e0f5c6933e895f90ae4efcb3d4294aba532b 833ca63be2ab14871874ccb6974921e8952802e9'
+    patches: '6d6f3d903428fed3e4ad2261bbe79f762f29bd3e 833ca63be2ab14871874ccb6974921e8952802e9'
     flavor: 'ghc-8.8.1'
   steps:
   - checkout: self

diff --git a/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs b/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs
@@ -176,6 +176,7 @@ data Env = Env
     ,envChoiceData :: MS.Map TypeConName [ChoiceData]
     ,envImplements :: MS.Map TypeConName [GHC.TyCon]
     ,envInterfaceInstances :: MS.Map (GHC.Module, TypeConName, TypeConName) (GHC.Expr GHC.CoreBndr)
+    ,envInterfaceChoiceData :: MS.Map TypeConName [ChoiceData]
     ,envInterfaces :: S.Set TypeConName
     ,envIsGenerated :: Bool
     ,envTypeVars :: !(MS.Map Var TypeVarName)
@@ -420,34 +421,32 @@ convertInterfaces :: Env -> [TyThing] -> ConvertM [Definition]
 convertInterfaces env tyThings = interfaceClasses
   where
     interfaceClasses = sequence
-        [ DInterface <$> convertInterface interface cls
+        [ DInterface <$> convertInterface interface cls choiceData
         | ATyCon t <- tyThings
         , Just cls <- [tyConClass_maybe t]
         , Just interface <- [T.stripPrefix "Is" (getOccText t)]
         , TypeConName [interface] `S.member` (envInterfaces env)
+        , choiceData <- [MS.findWithDefault [] (TypeConName [interface]) $ envInterfaceChoiceData env]
         ]
-    convertInterface :: T.Text -> Class -> ConvertM DefInterface
-    convertInterface name cls = do
-      choices <- sequence
-        [ convertChoice arg res
-        |
-          TypeCon (NameIn DA_Internal_Template_Functions "HasExercise") [_, arg, res] <- classSCTheta cls]
-      -- Drop toIface/fromIface/toIfaceContractId/fromIfaceContractId to get only user-defined methods.
+    convertInterface :: T.Text -> Class -> [ChoiceData] -> ConvertM DefInterface
+    convertInterface name cls choiceData = do
       methods <- mapM convertMethod (drop 4 $ classMethods cls)
+      choices <- mapM convertChoice choiceData
       pure DefInterface
         { intLocation = Nothing
         , intName = mkTypeCon [name]
         , intChoices = NM.fromList choices
         , intMethods = NM.fromList methods
         }
-    convertChoice :: TyCoRep.Type -> TyCoRep.Type -> ConvertM InterfaceChoice
-    convertChoice arg res = do
-        arg@(TCon (Qualified { qualObject = TypeConName[choice]})) <- convertType env arg
-        res <- convertType env res
+    convertChoice :: ChoiceData -> ConvertM InterfaceChoice
+    convertChoice (ChoiceData ty _expr) = do
+        TConApp _ [_ :-> _ :-> arg@(TConApp choiceTyCon _) :-> TUpdate res, consumingTy] <- convertType env ty
+        let choiceName = ChoiceName (T.intercalate "." $ unTypeConName $ qualObject choiceTyCon)
+        consuming <- convertConsuming consumingTy
         pure InterfaceChoice
           { ifcLocation = Nothing
-          , ifcName = ChoiceName choice
-          , ifcConsuming = True
+          , ifcName = choiceName
+          , ifcConsuming = consuming == Consuming
           , ifcArgType = arg
           , ifcRetType = res
           }
@@ -463,6 +462,15 @@ convertInterfaces env tyThings = interfaceClasses
           , ifmType = retTy
           }
 
+convertConsuming :: LF.Type -> ConvertM Consuming
+convertConsuming consumingTy = case consumingTy of
+      TConApp Qualified { qualObject = TypeConName con } _
+          | con == ["NonConsuming"] -> pure NonConsuming
+          | con == ["PreConsuming"] -> pure PreConsuming
+          | con == ["Consuming"] -> pure Consuming
+          | con == ["PostConsuming"] -> pure PostConsuming
+      _ -> unhandled "choice consumption type" (show consumingTy)
+
 convertModule
     :: LF.Version
     -> MS.Map UnitId DalfPackage
@@ -518,6 +526,12 @@ convertModule lfVersion pkgMap stablePackages isGenerated file x depOrphanModule
             , "_choice_" `T.isPrefixOf` getOccText name
             , ty@(TypeCon _ [_, _, TypeCon _ [TypeCon tplTy _], _]) <- [varType name]
             ]
+        ifChoiceData = MS.fromListWith (++)
+            [ (mkTypeCon [getOccText tplTy], [ChoiceData ty v])
+            | (name, v) <- binds
+            , "_interface_choice_" `T.isPrefixOf` getOccText name
+            , ty@(TypeCon _ [_, TypeCon _ [TypeCon tplTy _]]) <- [varType name]
+            ]
         templateBinds = scrapeTemplateBinds binds
         exceptionBinds
             | lfVersion `supports` featureExceptions =
@@ -534,6 +548,7 @@ convertModule lfVersion pkgMap stablePackages isGenerated file x depOrphanModule
           , envStablePackages = stablePackages
           , envLfVersion = lfVersion
           , envInterfaces = interfaceCons
+          , envInterfaceChoiceData = ifChoiceData
           , envTemplateBinds = templateBinds
           , envExceptionBinds = exceptionBinds
           , envImplements = tplImplements
@@ -909,13 +924,7 @@ convertChoice env tbinds (ChoiceData ty expr)
         ESome{someBody} -> pure $ Just someBody
         _ -> unhandled "choice observers function" optObservers
 
-    consuming <- case consumingTy of
-        TConApp Qualified { qualObject = TypeConName con } _
-            | con == ["NonConsuming"] -> pure NonConsuming
-            | con == ["PreConsuming"] -> pure PreConsuming
-            | con == ["Consuming"] -> pure Consuming
-            | con == ["PostConsuming"] -> pure PostConsuming
-        _ -> unhandled "choice consumption type" (show consumingTy)
+    consuming <- convertConsuming consumingTy
     let update = action `ETmApp` EVar self `ETmApp` EVar this `ETmApp` EVar arg
     archiveSelf <- useSingleMethodDict env fArchive (`ETmApp` EVar self)
     update <- pure $
@@ -948,7 +957,9 @@ convertBind env (name, x)
     -- This is inlined in the choice in the template so we can just drop this.
     | "_choice_" `T.isPrefixOf` getOccText name
     = pure []
-
+    -- We only need this to get additional info for interface choices.
+    | "_interface_choice_" `T.isPrefixOf` getOccText name
+    = pure []
     -- These are only used as markers for the LF conversion.
     | "_implements_" `T.isPrefixOf` getOccText name
     = pure []

diff --git a/compiler/damlc/tests/daml-test-files/Interface.daml b/compiler/damlc/tests/daml-test-files/Interface.daml
@@ -18,6 +18,10 @@ interface Token where
     with
       newOwner : Party
 
+  nonconsuming choice Noop : ()
+    with
+      nothing : ()
+
 template Asset
   with
     issuer : Party
@@ -46,6 +50,13 @@ template Asset
           cid <- create this with owner = newOwner
           pure (toTokenContractId cid)
 
+      nonconsuming choice Noop : ()
+        with
+          nothing : ()
+        controller owner
+        do
+          pure ()
+
 main = scenario do
   p <- getParty "Alice"
   p `submit` do
@@ -54,6 +65,7 @@ main = scenario do
       owner = p
       amount = 15
     let cidToken1 = toTokenContractId cidAsset1
+    _ <- exercise cidToken1 (Noop ())
     (cidToken2, cidToken3) <- exercise cidToken1 (Split 10)
     token2 <- fetch cidToken2
     getAmount token2 === 10

diff --git a/compiler/damlc/tests/daml-test-files/InterfaceConsuming.daml b/compiler/damlc/tests/daml-test-files/InterfaceConsuming.daml
@@ -0,0 +1,43 @@
+-- Copyright (c) 2021 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
+-- SPDX-License-Identifier: Apache-2.0
+
+-- @SINCE-LF-FEATURE DAML_INTERFACE
+-- @ERROR Choice implementation and interface definition for Transfer differ in consuming/non-consuming behaviour.
+
+module InterfaceConsuming where
+
+interface Token where
+  choice Split : (ContractId Token, ContractId Token)
+    with
+      splitAmount : Int
+
+  nonconsuming choice Transfer : ContractId Token
+    with
+      newOwner : Party
+
+
+template Asset
+  with
+    issuer : Party
+    owner : Party
+    amount : Int
+  where
+    signatory issuer, owner
+    implements Token where
+      choice Split : (ContractId Token, ContractId Token)
+        with
+          splitAmount : Int
+        controller owner
+        do
+          assert (splitAmount < amount)
+          cid1 <- create this with amount = splitAmount
+          cid2 <- create this with amount = amount - splitAmount
+          pure (toTokenContractId cid1, toTokenContractId cid2)
+
+      choice Transfer : ContractId Token
+        with
+          newOwner : Party
+        controller owner, newOwner
+        do
+          cid <- create this with owner = newOwner
+          pure (toTokenContractId cid)
diff --git a/compiler/damlc/tests/daml-test-files/InterfaceDesugared.daml b/compiler/damlc/tests/daml-test-files/InterfaceDesugared.daml
@@ -108,3 +108,20 @@ _choice_AssetSplit :
   )
 _choice_AssetSplit =
   (error "abc", error "abc", error "abc", DA.Internal.Desugar.None)
+
+_interface_choice_TokenTransfer :
+  (DA.Internal.Desugar.ContractId Token
+   -> Token
+      -> Transfer -> DA.Internal.Desugar.Update (ContractId Token),
+   DA.Internal.Desugar.Consuming Token)
+_interface_choice_TokenTransfer
+  = (error "", DA.Internal.Desugar.Consuming)
+_interface_choice_TokenSplit :
+  (DA.Internal.Desugar.ContractId Token
+   -> Token
+      -> Split
+         -> DA.Internal.Desugar.Update ((ContractId Token,
+                                         ContractId Token)),
+   DA.Internal.Desugar.Consuming Token)
+_interface_choice_TokenSplit
+  = (error "", DA.Internal.Desugar.Consuming)
diff --git a/stack-snapshot.yaml b/stack-snapshot.yaml
@@ -3,10 +3,10 @@
 
 resolver: lts-18.0
 packages:
-  - archive: https://daml-binaries.da-ext.net/da-ghc-lib/ghc-lib-837a79515c4e70f9440d433ed7833e75.tar.gz
-    sha256: "b640032ae942c4edc4a5bc6a314701ed5f030e8a16c492281cf3ee5a5ba97a48"
-  - archive: https://daml-binaries.da-ext.net/da-ghc-lib/ghc-lib-parser-837a79515c4e70f9440d433ed7833e75.tar.gz
-    sha256: "2f70bebd6fa59210258a60ed4450238888dd20e7a06996924b56859cda1ae574"
+  - archive: https://daml-binaries.da-ext.net/da-ghc-lib/ghc-lib-d9cd386e0c79fd53181fc08dd2fb9853.tar.gz
+    sha256: "0e0301c33eeca28c88e3a8fb204363e40ec3a56882c9894c86f654ae39df6632"
+  - archive: https://daml-binaries.da-ext.net/da-ghc-lib/ghc-lib-parser-d9cd386e0c79fd53181fc08dd2fb9853.tar.gz
+    sha256: "2f4d201d4e042ceb1be6e3adc05a87c82a1c55e17d1b9114c20ffd44a6454cfe"
   - github: digital-asset/hlint
     commit: "c8246c1feb932858ff2b5d7e9e900068a974bf57"
     sha256: "3da24baf789c5f00211a92e24153e6b88102befaa946ada1f707935554500fe2"