haskell side

digital-asset · Nov 29, 2021 · c6d7cdf · c6d7cdf
1 parent ca38610
commit c6d7cdf
Show file tree

Hide file tree

Showing 10 changed files with 34 additions and 14 deletions.
diff --git a/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Alpha.hs b/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Alpha.hs
@@ -309,11 +309,13 @@ alphaUpdate env = \case
             && alphaExpr' env e1a e2a
             && alphaExpr' env e1b e2b
         _ -> False
-    UExerciseInterface i1 c1 e1a e1b -> \case
-        UExerciseInterface i2 c2 e2a e2b -> alphaTypeCon i1 i2
+    UExerciseInterface i1 c1 e1a e1b e1c e1d -> \case
+        UExerciseInterface i2 c2 e2a e2b e2c e2d -> alphaTypeCon i1 i2
             && c1 == c2
             && alphaExpr' env e1a e2a
             && alphaExpr' env e1b e2b
+            && alphaExpr' env e1c e2c
+            && alphaExpr' env e1d e2d
         _ -> False
     UExerciseByKey t1 c1 e1a e1b -> \case
         UExerciseByKey t2 c2 e2a e2b -> alphaTypeCon t1 t2

diff --git a/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Base.hs b/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Base.hs
@@ -683,6 +683,11 @@ data Update
       -- ^ Contract id of the contract template instance to exercise choice on.
     , exeArg        :: !Expr
       -- ^ Argument for the choice.
+    , exeTypeRep    :: !Expr
+      -- ^ Optional TypeRep with the expected template ID.
+    , exeGuard      :: !Expr
+      -- ^ Exercise guard (Interface -> Bool) to abort the transaction eagerly
+      -- if the payload does not satisfy the predicate.
     }
   -- | Exercise a choice on a contract by key.
   | UExerciseByKey

diff --git a/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/FreeVars.hs b/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/FreeVars.hs
@@ -137,7 +137,7 @@ freeVarsStep = \case
         UCreateF _ e -> e
         UCreateInterfaceF _ e -> e
         UExerciseF _ _ e1 e2 -> e1 <> e2
-        UExerciseInterfaceF _ _ e1 e2 -> e1 <> e2
+        UExerciseInterfaceF _ _ e1 e2 e3 e4 -> e1 <> e2 <> e3 <> e4
         UExerciseByKeyF _ _ e1 e2 -> e1 <> e2
         UFetchF _ e -> e
         UFetchInterfaceF _ e -> e

diff --git a/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Pretty.hs b/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Pretty.hs
@@ -418,10 +418,10 @@ instance Pretty Update where
       -- NOTE(MH): Converting the choice name into a variable is a bit of a hack.
       pPrintAppKeyword lvl prec "exercise"
       [tplArg tpl, TmArg (EVar (ExprVarName (unChoiceName choice))), TmArg cid, TmArg arg]
-    UExerciseInterface interface choice cid arg ->
+    UExerciseInterface interface choice cid arg typeRep guard ->
       -- NOTE(MH): Converting the choice name into a variable is a bit of a hack.
       pPrintAppKeyword lvl prec "exercise_interface"
-      [interfaceArg interface, TmArg (EVar (ExprVarName (unChoiceName choice))), TmArg cid, TmArg arg]
+      [interfaceArg interface, TmArg (EVar (ExprVarName (unChoiceName choice))), TmArg cid, TmArg arg, TmArg typeRep, TmArg guard]
     UExerciseByKey tpl choice key arg ->
       pPrintAppKeyword lvl prec "exercise_by_key"
       [tplArg tpl, TmArg (EVar (ExprVarName (unChoiceName choice))), TmArg key, TmArg arg]

diff --git a/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Recursive.hs b/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Recursive.hs
@@ -65,7 +65,7 @@ data UpdateF expr
   | UCreateF   !(Qualified TypeConName) !expr
   | UCreateInterfaceF !(Qualified TypeConName) !expr
   | UExerciseF !(Qualified TypeConName) !ChoiceName !expr !expr
-  | UExerciseInterfaceF !(Qualified TypeConName) !ChoiceName !expr !expr
+  | UExerciseInterfaceF !(Qualified TypeConName) !ChoiceName !expr !expr !expr !expr
   | UExerciseByKeyF !(Qualified TypeConName) !ChoiceName !expr !expr
   | UFetchF    !(Qualified TypeConName) !expr
   | UFetchInterfaceF    !(Qualified TypeConName) !expr
@@ -114,7 +114,7 @@ projectUpdate = \case
   UCreate a b -> UCreateF a b
   UCreateInterface a b -> UCreateInterfaceF a b
   UExercise a b c d -> UExerciseF a b c d
-  UExerciseInterface a b c d -> UExerciseInterfaceF a b c d
+  UExerciseInterface a b c d e f -> UExerciseInterfaceF a b c d e f
   UExerciseByKey a b c d -> UExerciseByKeyF a b c d
   UFetch a b -> UFetchF a b
   UFetchInterface a b -> UFetchInterfaceF a b
@@ -134,7 +134,7 @@ embedUpdate = \case
   UCreateF a b -> UCreate a b
   UCreateInterfaceF a b -> UCreateInterface a b
   UExerciseF a b c d -> UExercise a b c d
-  UExerciseInterfaceF a b c d -> UExerciseInterface a b c d
+  UExerciseInterfaceF a b c d e f -> UExerciseInterface a b c d e f
   UExerciseByKeyF a b c d -> UExerciseByKey a b c d
   UFetchF a b -> UFetch a b
   UFetchInterfaceF a b -> UFetchInterface a b

diff --git a/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Subst.hs b/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Subst.hs
@@ -252,11 +252,13 @@ applySubstInUpdate subst = \case
         choiceName
         (applySubstInExpr subst e1)
         (applySubstInExpr subst e2)
-    UExerciseInterface interface choiceName e1 e2 -> UExerciseInterface
+    UExerciseInterface interface choiceName e1 e2 e3 e4 -> UExerciseInterface
         interface
         choiceName
         (applySubstInExpr subst e1)
         (applySubstInExpr subst e2)
+        (applySubstInExpr subst e3)
+        (applySubstInExpr subst e4)
     UExerciseByKey templateName choiceName e1 e2 -> UExerciseByKey
         templateName
         choiceName

diff --git a/compiler/daml-lf-proto/src/DA/Daml/LF/Proto3/DecodeV1.hs b/compiler/daml-lf-proto/src/DA/Daml/LF/Proto3/DecodeV1.hs
@@ -696,6 +696,8 @@ decodeUpdate LF1.Update{..} = mayDecode "updateSum" updateSum $ \case
       <*> decodeNameId ChoiceName update_ExerciseInterfaceChoiceInternedStr
       <*> mayDecode "update_ExerciseInterfaceCid" update_ExerciseInterfaceCid decodeExpr
       <*> mayDecode "update_ExerciseInterfaceArg" update_ExerciseInterfaceArg decodeExpr
+      <*> mayDecode "update_ExerciseInterfaceTypeRep" update_ExerciseInterfaceTypeRep decodeExpr
+      <*> mayDecode "update_ExerciseInterfaceGuard" update_ExerciseInterfaceGuard decodeExpr
   LF1.UpdateSumExerciseByKey LF1.Update_ExerciseByKey{..} ->
     fmap EUpdate $ UExerciseByKey
       <$> mayDecode "update_ExerciseByKeyTemplate" update_ExerciseByKeyTemplate decodeTypeConName

diff --git a/compiler/daml-lf-proto/src/DA/Daml/LF/Proto3/EncodeV1.hs b/compiler/daml-lf-proto/src/DA/Daml/LF/Proto3/EncodeV1.hs
@@ -761,6 +761,8 @@ encodeUpdate = fmap (P.Update . Just) . \case
         update_ExerciseInterfaceChoiceInternedStr <- encodeNameId unChoiceName exeChoice
         update_ExerciseInterfaceCid <- encodeExpr exeContractId
         update_ExerciseInterfaceArg <- encodeExpr exeArg
+        update_ExerciseInterfaceTypeRep <- encodeExpr exeTypeRep
+        update_ExerciseInterfaceGuard <- encodeExpr exeGuard
         pure $ P.UpdateSumExerciseInterface P.Update_ExerciseInterface{..}
     UExerciseByKey{..} -> do
         update_ExerciseByKeyTemplate <- encodeQualTypeConName exeTemplate

diff --git a/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Check.hs b/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Check.hs
@@ -598,11 +598,13 @@ typeOfExercise tpl chName cid arg = do
   pure (TUpdate (chcReturnType choice))
 
 typeOfExerciseInterface :: MonadGamma m =>
-  Qualified TypeConName -> ChoiceName -> Expr -> Expr -> m Type
-typeOfExerciseInterface tpl chName cid arg = do
-  choice <- inWorld (lookupInterfaceChoice (tpl, chName))
-  checkExpr cid (TContractId (TCon tpl))
+  Qualified TypeConName -> ChoiceName -> Expr -> Expr -> Expr -> Expr -> m Type
+typeOfExerciseInterface iface chName cid arg typeRep guard = do
+  choice <- inWorld (lookupInterfaceChoice (iface, chName))
+  checkExpr cid (TContractId (TCon iface))
   checkExpr arg (chcArgType choice)
+  checkExpr typeRep (TOptional TTypeRep)
+  checkExpr guard (TCon iface :-> TBool)
   pure (TUpdate (chcReturnType choice))
 
 typeOfExerciseByKey :: MonadGamma m =>
@@ -652,7 +654,8 @@ typeOfUpdate = \case
   UCreate tpl arg -> checkCreate tpl arg $> TUpdate (TContractId (TCon tpl))
   UCreateInterface iface arg -> checkCreateInterface iface arg $> TUpdate (TContractId (TCon iface))
   UExercise tpl choice cid arg -> typeOfExercise tpl choice cid arg
-  UExerciseInterface tpl choice cid arg -> typeOfExerciseInterface tpl choice cid arg
+  UExerciseInterface tpl choice cid arg typeRep guard ->
+    typeOfExerciseInterface tpl choice cid arg typeRep guard
   UExerciseByKey tpl choice key arg -> typeOfExerciseByKey tpl choice key arg
   UFetch tpl cid -> checkFetch tpl cid $> TUpdate (TCon tpl)
   UFetchInterface tpl cid -> checkFetchInterface tpl cid $> TUpdate (TCon tpl)

diff --git a/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion/Primitives.hs b/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion/Primitives.hs
@@ -339,6 +339,10 @@ convertPrim _ "UExerciseInterface"
     ETmLam (mkVar "this", TContractId (TCon iface)) $
     ETmLam (mkVar "arg", TCon choice) $
     EUpdate $ UExerciseInterface iface choiceName (EVar (mkVar "this")) (EVar (mkVar "arg"))
+        -- TODO https://github.com/digital-asset/daml/issues/11703
+        --   Pass the typeRep and guard arguments in from daml.
+        (ENone TTypeRep)
+        (ETmLam (mkVar "payload", TCon iface) (EBuiltin (BEBool True)))
   where
     choiceName = ChoiceName (T.intercalate "." $ unTypeConName $ qualObject choice)