interface fixed choices: LFConversion support (#11206)

* interface fixed choices: LFConversion support Part of #11137 changelog_begin changelog_end * Update experimental primitives name, invoke UExerciseInterface
2024-09-19 16:57:40 +03:00 · 2021-10-12 18:06:52 +01:00 · 2021-10-12 18:06:52 +01:00 · 7a02e7c440
commit 7a02e7c440
parent 73d9ebfe0d
3 changed files with 138 additions and 37 deletions
--- a/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs
+++ b/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs
@ -177,7 +177,7 @@ data Env = Env
    ,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
+    ,envInterfaces :: MS.Map TypeConName GHC.TyCon
    ,envIsGenerated :: Bool
    ,envTypeVars :: !(MS.Map Var TypeVarName)
        -- ^ Maps GHC type variables in scope to their LF type variable names
@ -411,37 +411,41 @@ modInstanceInfoFromDetails :: ModDetails -> ModInstanceInfo
 modInstanceInfoFromDetails ModDetails{..} = MS.fromList
    [ (is_dfun, overlapMode is_flag) | ClsInst{..} <- md_insts ]

-interfaceNames :: LF.Version -> [TyThing] -> S.Set TypeConName
+interfaceNames :: LF.Version -> [TyThing] -> MS.Map TypeConName TyCon
 interfaceNames lfVersion tyThings
-    | lfVersion `supports` featureInterfaces =
-      S.fromList [ mkTypeCon [getOccText t] | ATyCon t <- tyThings, hasDamlInterfaceCtx t ]
-    | otherwise = S.empty
+    | lfVersion `supports` featureInterfaces = MS.fromList
+        [ (mkTypeCon [getOccText t], t)
+        | ATyCon t <- tyThings
+        , hasDamlInterfaceCtx t
+        ]
+    | otherwise = MS.empty

 convertInterfaces :: Env -> [TyThing] -> ConvertM [Definition]
 convertInterfaces env tyThings = interfaceClasses
  where
+    interfaceClasses :: ConvertM [Definition]
    interfaceClasses = sequence
-        [ DInterface <$> convertInterface interface cls choiceData
+        [ DInterface <$> convertInterface name tycon cls
        | 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]
+        , let name = TypeConName [interface]
+        , Just tycon <- [MS.lookup name (envInterfaces env)]
        ]
-    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]
-        , intParam = ExprVarName "this"
-        , intVirtualChoices = NM.fromList choices
-        , intFixedChoices = NM.empty -- TODO https://github.com/digital-asset/daml/issues/11137
-        , intMethods = NM.fromList methods
-        }
-    convertChoice :: ChoiceData -> ConvertM InterfaceChoice
-    convertChoice (ChoiceData ty _expr) = do
+
+    convertInterface :: LF.TypeConName -> GHC.TyCon -> Class -> ConvertM DefInterface
+    convertInterface intName tyCon cls = do
+        let intLocation = convNameLoc (GHC.tyConName tyCon)
+        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
+            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
@ -452,6 +456,7 @@ convertInterfaces env tyThings = interfaceClasses
          , ifcArgType = arg
          , ifcRetType = res
          }
+
    convertMethod :: Var -> ConvertM InterfaceMethod
    convertMethod method = do
        retTy <- convertType env (varType method) >>= \case
@ -812,7 +817,7 @@ convertTemplate env tplTypeCon tbinds@TemplateBinds{..}
        pure Template {..}

    | otherwise =
-        unhandled "Missing required instances in template definition." (show tplTypeCon)
+        unhandled ("Missing required instances in template definition for " <> show tplTypeCon) ()

  where
    wrapPrecondition b
@ -910,8 +915,7 @@ convertChoices env tplTypeCon tbinds =
        (MS.findWithDefault [] tplTypeCon (envChoiceData env))

 convertChoice :: Env -> TemplateBinds -> ChoiceData -> ConvertM TemplateChoice
-convertChoice env tbinds (ChoiceData ty expr)
-    | Just fArchive <- tbArchive tbinds = do
+convertChoice env tbinds (ChoiceData ty expr) = do
    TConApp _ [_, _ :-> _ :-> choiceTy@(TConApp choiceTyCon _) :-> TUpdate choiceRetTy, consumingTy, _] <- convertType env ty
    let choiceName = ChoiceName (T.intercalate "." $ unTypeConName $ qualObject choiceTyCon)
    ERecCon _ [ (_, controllers)
@ -928,17 +932,22 @@ convertChoice env tbinds (ChoiceData ty expr)

    consuming <- convertConsuming consumingTy
    let update = action `ETmApp` EVar self `ETmApp` EVar this `ETmApp` EVar arg
-    archiveSelf <- useSingleMethodDict env fArchive (`ETmApp` EVar self)
-    update <- pure $
-      case consuming of
-        Consuming -> update
-        NonConsuming -> update
-        PreConsuming ->
-          EUpdate $ UBind (Binding (mkVar "_", TUnit) archiveSelf) update
-        PostConsuming ->
-          EUpdate $ UBind (Binding (res, choiceRetTy) update) $
-          EUpdate $ UBind (Binding (mkVar "_", TUnit) archiveSelf) $
-          EUpdate $ UPure choiceRetTy $ EVar res
+    update <- case consuming of
+        Consuming -> pure update
+        NonConsuming -> pure update
+        PreConsuming | Just fArchive <- tbArchive tbinds -> do
+          archiveSelf <- useSingleMethodDict env fArchive (`ETmApp` EVar self)
+          pure $ EUpdate $ UBind (Binding (mkVar "_", TUnit) archiveSelf) update
+        PreConsuming | otherwise ->
+          unsupported "preconsuming choice for interface" ()
+        PostConsuming | Just fArchive <- tbArchive tbinds -> do
+          archiveSelf <- useSingleMethodDict env fArchive (`ETmApp` EVar self)
+          pure $
+            EUpdate $ UBind (Binding (res, choiceRetTy) update) $
+            EUpdate $ UBind (Binding (mkVar "_", TUnit) archiveSelf) $
+            EUpdate $ UPure choiceRetTy $ EVar res
+        PostConsuming | otherwise ->
+          unsupported "postconsuming choice for interface" ()
    pure TemplateChoice
        { chcLocation = Nothing
        , chcName = choiceName
@ -975,7 +984,7 @@ convertBind env (name, x)
    -- 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 []
+    , mkTypeCon [iface] `MS.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.
--- a/compiler/damlc/tests/daml-test-files/Interface.daml
+++ b/compiler/damlc/tests/daml-test-files/Interface.daml
@ -8,7 +8,9 @@ module Interface where
 import DA.Assert ((===))

 interface Token where
+  getOwner : Party
  getAmount : Int
+  setAmount : Int -> Token

  choice Split : (ContractId Token, ContractId Token)
    with
@ -22,6 +24,37 @@ interface Token where
    with
      nothing : ()

+-- TODO https://github.com/digital-asset/daml/issues/10810
+--   Add HasCreate, HasSignatory, HasObserver instances in GHC parser
+instance HasCreate Token where
+  create x = GHC.Types.primitive @"$RESOLVE_VIRTUAL_CREATE" x x
+instance HasObserver Token where
+  observer x = GHC.Types.primitive @"$RESOLVE_VIRTUAL_OBSERVERS" x x
+-- TODO https://github.com/digital-asset/daml/issues/11198
+--   Instance disabled until issue is resolved.
+-- instance HasSignatory Token where
+--   signatory x = GHC.Types.primitive @"$RESOLVE_VIRTUAL_SIGNATORIES" x x
+
+-- TODO https://github.com/digital-asset/daml/issues/11137
+--   Implement fixed choices in GHC parser.
+data GetRich = GetRich { byHowMuch : Int }
+_choice_TokenGetRich :
+  ( Token -> GetRich -> [DA.Internal.Desugar.Party]
+  , DA.Internal.Desugar.ContractId Token -> Token -> GetRich -> DA.Internal.Desugar.Update (ContractId Token)
+  , DA.Internal.Desugar.Consuming Token
+  , DA.Internal.Desugar.Optional (Token -> GetRich -> [DA.Internal.Desugar.Party])
+  )
+_choice_TokenGetRich =
+  ( \this _ -> [getOwner this]
+  , \self this GetRich{byHowMuch} -> do
+      assert (byHowMuch > 0)
+      create $ setAmount this (getAmount this + byHowMuch)
+  , DA.Internal.Desugar.Consuming
+  , DA.Internal.Desugar.None
+  )
+instance IsToken t => HasExercise t GetRich (ContractId Token) where
+  exercise cid = GHC.Types.primitive @"UExerciseInterface" (toTokenContractId cid)
+
 template Asset
  with
    issuer : Party
@ -30,7 +63,11 @@ template Asset
  where
    signatory issuer, owner
    implements Token where
+      let getOwner = owner
      let getAmount = amount
+      let setAmount = \x -> toToken (this with amount = x)
+        -- TODO https://github.com/digital-asset/daml/issues/10810
+        --  (maybe) support `let setAmount x = ...` syntax.

      choice Split : (ContractId Token, ContractId Token)
        with
@ -79,4 +116,15 @@ main = scenario do
      None -> abort "expected Asset"
      Some Asset {amount} ->
        amount === 5
+
+    -- TODO https://github.com/digital-asset/daml/issues/11137
+    --   uncomment once speedy supports fixed choices
+    -- cidToken4 <- exercise cidToken3 (GetRich 20)
+    -- token4 <- fetch cidToken4
+    -- getAmount token4 === 25
+    -- case fromToken token4 of
+    --   None -> abort "expected Asset"
+    --   Some Asset {amount} ->
+    --     amount === 25
+
    pure ()
--- a/compiler/damlc/tests/daml-test-files/InterfaceDesugared.daml
+++ b/compiler/damlc/tests/daml-test-files/InterfaceDesugared.daml
@ -28,7 +28,18 @@ class
  fromToken : Token -> Optional t
  toTokenContractId : ContractId t -> ContractId Token
  fromTokenContractId : ContractId Token -> Update (Optional (ContractId t))
+  getOwner : t -> Party
  getAmount : t -> Int
+  setAmount : t -> Int -> Token
+
+instance HasCreate Token where
+  create x = GHC.Types.primitive @"$RESOLVE_VIRTUAL_CREATE" x x
+instance HasObserver Token where
+  observer x = GHC.Types.primitive @"$RESOLVE_VIRTUAL_OBSERVERS" x x
+-- TODO https://github.com/digital-asset/daml/issues/11198
+--   Instance disabled until issue is resolved.
+-- instance HasSignatory Token where
+--   signatory x = GHC.Types.primitive @"$RESOLVE_VIRTUAL_SIGNATORIES" x x

 instance HasFetch Token where
  fetch = GHC.Types.primitive @"UFetchInterface"
@ -47,7 +58,9 @@ instance IsToken Token where
  fromToken = GHC.Types.primitive @"EFromInterface"
  toTokenContractId = GHC.Types.primitive @"EToInterfaceContractId"
  fromTokenContractId = GHC.Types.primitive @"UFromInterfaceContractId"
+  getOwner = GHC.Types.primitiveInterface @"getOwner"
  getAmount = GHC.Types.primitiveInterface @"getAmount"
+  setAmount = GHC.Types.primitiveInterface @"setAmount"

 _interface_choice_TokenTransfer :
  (DA.Internal.Desugar.ContractId Token
@ -73,6 +86,24 @@ _interface_choice_TokenNoop :
 _interface_choice_TokenNoop
  = (error "", DA.Internal.Desugar.NonConsuming)

+data GetRich = GetRich { byHowMuch : Int }
+_choice_TokenGetRich :
+  ( Token -> GetRich -> [DA.Internal.Desugar.Party]
+  , DA.Internal.Desugar.ContractId Token -> Token -> GetRich -> DA.Internal.Desugar.Update (ContractId Token)
+  , DA.Internal.Desugar.Consuming Token
+  , DA.Internal.Desugar.Optional (Token -> GetRich -> [DA.Internal.Desugar.Party])
+  )
+_choice_TokenGetRich =
+  ( \this _ -> [getOwner this]
+  , \self this GetRich{byHowMuch} -> do
+      assert (byHowMuch > 0)
+      create $ setAmount this (getAmount this + byHowMuch)
+  , DA.Internal.Desugar.Consuming
+  , DA.Internal.Desugar.None
+  )
+instance IsToken t => HasExercise t GetRich (ContractId Token) where
+  exercise cid = GHC.Types.primitive @"UExerciseInterface" (toTokenContractId cid)
+
 data Asset = Asset { amount : Int, issuer : Party, owner : Party }
  deriving (Eq, Show)

@ -81,7 +112,9 @@ instance IsToken Asset where
  fromToken = GHC.Types.primitive @"EFromInterface"
  toTokenContractId = GHC.Types.primitive @"EToInterfaceContractId"
  fromTokenContractId = GHC.Types.primitive @"UFromInterfaceContractId"
+  getOwner Asset{..} = owner
  getAmount Asset{..} = amount
+  setAmount this x = toToken (this with amount = x)

 _implements_AssetToken : DA.Internal.Desugar.Implements Asset Token
 _implements_AssetToken = DA.Internal.Desugar.Implements
@ -199,4 +232,15 @@ main = scenario do
      None -> abort "expected Asset"
      Some Asset {amount} ->
        amount === 5
+
+    -- TODO https://github.com/digital-asset/daml/issues/11137
+    --   uncomment once speedy supports fixed choices
+    -- cidToken4 <- exercise cidToken3 (GetRich 20)
+    -- token4 <- fetch cidToken4
+    -- getAmount token4 === 25
+    -- case fromToken token4 of
+    --   None -> abort "expected Asset"
+    --   Some Asset {amount} ->
+    --     amount === 25
+
    pure ()