Remove virtual choices (#11482)

* Remove virtual choices

* Remove choices without a body in 'interface' definition
* Remove choices in 'template ... implements' section

part of #11372

changelog_begin
changelog_end

* Remove virtual choices cont.

Switch uses of virtual choices to fixed choice with method implementation

* update snapshot after pin on windows

* Disable failing interface tests with TODO #10810

ci/da-ghc-lib/compile.yml

@@ -12,7 +12,7 @@ jobs:
   variables:
     ghc-lib-sha: '42e5c306dcfbc84b83336fdd531023e93bfcc5b2'
     base-sha: '9c787d4d24f2b515934c8503ee2bbd7cfac4da20'
-    patches: '1acb39102edff7f9f81e50769b159aad458d40e9 833ca63be2ab14871874ccb6974921e8952802e9'
+    patches: 'e9abc24560f623c9c575d96a7a1a234927e042b2 833ca63be2ab14871874ccb6974921e8952802e9'
     flavor: 'ghc-8.8.1'
   steps:
   - checkout: self

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

@@ -931,7 +931,6 @@ data DefInterface = DefInterface
   { intLocation :: !(Maybe SourceLoc)
   , intName :: !TypeConName
   , intParam :: !ExprVarName
-  , intVirtualChoices :: !(NM.NameMap InterfaceChoice)
   , intFixedChoices :: !(NM.NameMap TemplateChoice)
   , intMethods :: !(NM.NameMap InterfaceMethod)
   , intPrecondition :: !Expr

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

@@ -35,7 +35,6 @@ import Data.List
 import qualified Data.NameMap as NM
 import GHC.Generics
 import Data.Either.Extra (maybeToEither)
-import Control.Applicative
 
 import DA.Daml.LF.Ast.Base
 import DA.Daml.LF.Ast.Pretty ()
@@ -157,12 +156,11 @@ lookupChoice (tplRef, chName) world = do
     Just choice -> Right choice
 
 lookupInterfaceChoice :: (Qualified TypeConName, ChoiceName) -> World ->
-  Either LookupError (Either InterfaceChoice TemplateChoice)
+  Either LookupError TemplateChoice
 lookupInterfaceChoice (ifaceRef, chName) world = do
   DefInterface{..} <- lookupInterface ifaceRef world
   maybeToEither (LEChoice ifaceRef chName) $
-        Left  <$> NM.lookup chName intVirtualChoices
-    <|> Right <$> NM.lookup chName intFixedChoices
+    NM.lookup chName intFixedChoices
 
 lookupInterfaceMethod :: (Qualified TypeConName, MethodName) -> World -> Either LookupError InterfaceMethod
 lookupInterfaceMethod (ifaceRef, methodName) world = do

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

@@ -24,7 +24,6 @@ import           Data.List
 import           DA.Daml.LF.Mangling
 import qualified Com.Daml.DamlLfDev.DamlLf1 as LF1
 import qualified Data.NameMap as NM
-import qualified Data.HashSet as HS
 import qualified Data.Text as T
 import qualified Data.Set as S
 import qualified Data.Text.Lazy as TL
@@ -235,25 +234,11 @@ decodeDefInterface LF1.DefInterface {..} = do
   intLocation <- traverse decodeLocation defInterfaceLocation
   intName <- decodeDottedNameId TypeConName defInterfaceTyconInternedDname
   intParam <- decodeNameId ExprVarName defInterfaceParamInternedStr
-  intVirtualChoices <- decodeNM DuplicateChoice decodeInterfaceChoice defInterfaceChoices
   intFixedChoices <- decodeNM DuplicateChoice decodeChoice defInterfaceFixedChoices
   intMethods <- decodeNM DuplicateMethod decodeInterfaceMethod defInterfaceMethods
-  unless (HS.null (NM.namesSet intFixedChoices `HS.intersection` NM.namesSet intVirtualChoices)) $
-    throwError $ ParseError $ unwords
-      [ "Interface", T.unpack (T.intercalate "." (unTypeConName intName))
-      , "has collision between fixed choice and virtual choice." ]
   intPrecondition <- mayDecode "defInterfacePrecond" defInterfacePrecond decodeExpr
   pure DefInterface {..}
 
-decodeInterfaceChoice :: LF1.InterfaceChoice -> Decode InterfaceChoice
-decodeInterfaceChoice LF1.InterfaceChoice {..} =
-  InterfaceChoice
-    <$> traverse decodeLocation interfaceChoiceLocation
-    <*> decodeNameId ChoiceName interfaceChoiceNameInternedString
-    <*> pure interfaceChoiceConsuming
-    <*> mayDecode "interfaceChoiceArgType" interfaceChoiceArgType decodeType
-    <*> mayDecode "interfaceChoiceRetType" interfaceChoiceRetType decodeType
-
 decodeInterfaceMethod :: LF1.InterfaceMethod -> Decode InterfaceMethod
 decodeInterfaceMethod LF1.InterfaceMethod {..} = InterfaceMethod
   <$> traverse decodeLocation interfaceMethodLocation

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

@@ -1005,21 +1005,11 @@ encodeDefInterface DefInterface{..} = do
     defInterfaceLocation <- traverse encodeSourceLoc intLocation
     defInterfaceTyconInternedDname <- encodeDottedNameId unTypeConName intName
     defInterfaceParamInternedStr <- encodeNameId unExprVarName intParam
-    defInterfaceChoices <- encodeNameMap encodeInterfaceChoice intVirtualChoices
     defInterfaceFixedChoices <- encodeNameMap encodeTemplateChoice intFixedChoices
     defInterfaceMethods <- encodeNameMap encodeInterfaceMethod intMethods
     defInterfacePrecond <- encodeExpr intPrecondition
     pure $ P.DefInterface{..}
 
-encodeInterfaceChoice :: InterfaceChoice -> Encode P.InterfaceChoice
-encodeInterfaceChoice InterfaceChoice {..} = do
-    interfaceChoiceLocation <- traverse encodeSourceLoc ifcLocation
-    interfaceChoiceNameInternedString <- encodeNameId unChoiceName ifcName
-    let interfaceChoiceConsuming = ifcConsuming
-    interfaceChoiceArgType <- encodeType ifcArgType
-    interfaceChoiceRetType <- encodeType ifcRetType
-    pure $ P.InterfaceChoice{..}
-
 encodeInterfaceMethod :: InterfaceMethod -> Encode P.InterfaceMethod
 encodeInterfaceMethod InterfaceMethod {..} = do
     interfaceMethodLocation <- traverse encodeSourceLoc ifmLocation

compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Check.hs

@@ -597,8 +597,8 @@ typeOfExerciseInterface :: MonadGamma m =>
 typeOfExerciseInterface tpl chName cid arg = do
   choice <- inWorld (lookupInterfaceChoice (tpl, chName))
   checkExpr cid (TContractId (TCon tpl))
-  checkExpr arg (either ifcArgType chcArgType choice)
-  pure (TUpdate (either ifcRetType chcReturnType choice))
+  checkExpr arg (chcArgType choice)
+  pure (TUpdate (chcReturnType choice))
 
 typeOfExerciseByKey :: MonadGamma m =>
   Qualified TypeConName -> ChoiceName -> Expr -> Expr -> m Type
@@ -810,22 +810,16 @@ checkDefTypeSyn DefTypeSyn{synParams,synType} = do
 
 -- | Check that an interface definition is well defined.
 checkIface :: MonadGamma m => Module -> DefInterface -> m ()
-checkIface m DefInterface{intName, intParam, intVirtualChoices, intFixedChoices, intMethods, intPrecondition} = do
-  checkUnique (EDuplicateInterfaceChoiceName intName) $ NM.names intVirtualChoices `union` NM.names intFixedChoices
+checkIface m DefInterface{intName, intParam, intFixedChoices, intMethods, intPrecondition} = do
+  checkUnique (EDuplicateInterfaceChoiceName intName) $ NM.names intFixedChoices
   checkUnique (EDuplicateInterfaceMethodName intName) $ NM.names intMethods
-  forM_ intVirtualChoices checkIfaceChoice
   forM_ intMethods checkIfaceMethod
 
   let tcon = Qualified PRSelf (moduleName m) intName
   introExprVar intParam (TCon tcon) $ do
     forM_ intFixedChoices (checkTemplateChoice tcon)
     checkExpr intPrecondition TBool
 
-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
@@ -891,24 +885,13 @@ checkTemplate m t@(Template _loc tpl param precond signatories observers text ch
 checkIfaceImplementation :: MonadGamma m => Qualified TypeConName -> TemplateImplements -> m ()
 checkIfaceImplementation tplTcon TemplateImplements{..} = do
   let tplName = qualObject tplTcon
-  DefInterface {intFixedChoices, intVirtualChoices, intMethods} <- inWorld $ lookupInterface tpiInterface
+  DefInterface {intFixedChoices, intMethods} <- inWorld $ lookupInterface tpiInterface
 
   -- check fixed choices
   let inheritedChoices = S.fromList (NM.names intFixedChoices)
   unless (inheritedChoices == tpiInheritedChoiceNames) $
     throwWithContext $ EBadInheritedChoices tpiInterface (S.toList inheritedChoices) (S.toList tpiInheritedChoiceNames)
 
-  -- check virtual choices
-  forM_ intVirtualChoices $ \InterfaceChoice {ifcName, ifcConsuming, ifcArgType, ifcRetType} -> do
-    TemplateChoice {chcConsuming, chcArgBinder, chcReturnType} <-
-      inWorld $ lookupChoice (tplTcon, ifcName)
-    unless (chcConsuming == ifcConsuming) $
-      throwWithContext $ EBadInterfaceChoiceImplConsuming ifcName ifcConsuming chcConsuming
-    unless (alphaType (snd chcArgBinder) ifcArgType) $
-      throwWithContext $ EBadInterfaceChoiceImplArgType ifcName ifcArgType (snd chcArgBinder)
-    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

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

@@ -441,25 +441,10 @@ convertInterfaces env tyThings = interfaceClasses
         let intParam = this
         withRange intLocation $ do
             intMethods <- NM.fromList <$> mapM convertMethod (drop 4 $ classMethods cls)
-            intVirtualChoices <- NM.fromList <$> mapM convertVirtualChoice
-                (MS.findWithDefault [] intName (envInterfaceChoiceData env))
             intFixedChoices <- convertChoices env intName emptyTemplateBinds
             let intPrecondition = ETrue -- TODO (drsk) #11397 Implement interface preconditions
             pure DefInterface {..}
 
-    convertVirtualChoice :: ChoiceData -> ConvertM InterfaceChoice
-    convertVirtualChoice (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
-          , ifcConsuming = consuming == Consuming
-          , ifcArgType = arg
-          , ifcRetType = res
-          }
-
     convertMethod :: Var -> ConvertM InterfaceMethod
     convertMethod method = do
         retTy <- convertType env (varType method) >>= \case

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

@@ -12,17 +12,30 @@ interface Token where
   getAmount : Int
   setAmount : Int -> Token
 
+  splitImpl : Int -> Update (ContractId Token, ContractId Token)
+  transferImpl : Party -> Update (ContractId Token)
+  noopImpl : () -> Update ()
+
   choice Split : (ContractId Token, ContractId Token)
     with
       splitAmount : Int
+    controller getOwner this
+    do
+      splitImpl this splitAmount
 
   choice Transfer : ContractId Token
     with
       newOwner : Party
+    controller getOwner this, newOwner
+    do
+      transferImpl this newOwner
 
   nonconsuming choice Noop : ()
     with
       nothing : ()
+    controller getOwner this
+    do
+      noopImpl this nothing
 
   choice GetRich : ContractId Token
     with
@@ -46,30 +59,18 @@ template Asset
         -- TODO https://github.com/digital-asset/daml/issues/10810
         --  (maybe) support `let setAmount x = ...` syntax.
 
-      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)
-
-      nonconsuming choice Noop : ()
-        with
-          nothing : ()
-        controller owner
-        do
-          pure ()
+      let splitImpl = \splitAmount -> do
+            assert (splitAmount < amount)
+            cid1 <- create this with amount = splitAmount
+            cid2 <- create this with amount = amount - splitAmount
+            pure (toTokenContractId cid1, toTokenContractId cid2)
+
+      let transferImpl = \newOwner -> do
+            cid <- create this with owner = newOwner
+            pure (toTokenContractId cid)
+
+      let noopImpl = \nothing -> do
+            pure ()
 
 main = scenario do
   p <- getParty "Alice"