Throw ContractError in template precondition field (#9760)

* Throw ContractError in template precondition field changelog_begin changelog_end * s/pre-condition/precondition/where relevant
2024-09-20 09:17:43 +03:00 · 2021-05-20 20:10:25 +01:00 · 2021-05-20 20:10:25 +01:00 · 765d7e3f53
commit 765d7e3f53
parent f5a03b3af6
7 changed files with 82 additions and 8 deletions
--- a/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs
+++ b/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs
@ -356,15 +356,16 @@ data TemplateBinds = TemplateBinds
    , tbKeyType :: Maybe GHC.Type
    , tbKey :: Maybe (GHC.Expr Var)
    , tbMaintainer :: Maybe (GHC.Expr Var)
+    , tbShow :: Maybe GHC.Var
    }

 emptyTemplateBinds :: TemplateBinds
 emptyTemplateBinds = TemplateBinds
    Nothing Nothing Nothing Nothing Nothing Nothing
-    Nothing Nothing Nothing
+    Nothing Nothing Nothing Nothing

 scrapeTemplateBinds :: [(Var, GHC.Expr Var)] -> MS.Map TypeConName TemplateBinds
-scrapeTemplateBinds binds = MS.map ($ emptyTemplateBinds) $ MS.fromListWith (.)
+scrapeTemplateBinds binds = MS.filter (isJust . tbTyCon) $ MS.map ($ emptyTemplateBinds) $ MS.fromListWith (.)
    [ (mkTypeCon [getOccText (GHC.tyConName tpl)], fn)
    | (name, expr) <- binds
    , Just (tpl, fn) <- pure $ case name of
@ -382,6 +383,8 @@ scrapeTemplateBinds binds = MS.map ($ emptyTemplateBinds) $ MS.fromListWith (.)
            Just (tpl, \tb -> tb { tbKeyType = Just key, tbKey = Just expr })
        HasMaintainerDFunId tpl _key ->
            Just (tpl, \tb -> tb { tbMaintainer = Just expr })
+        ShowDFunId tpl ->
+            Just (tpl, \tb -> tb { tbShow = Just name })
        _ -> Nothing
    ]

@ -685,7 +688,7 @@ convertTemplate env tplTypeCon tbinds@TemplateBinds{..}
        let tplParam = this
        tplSignatories <- useSingleMethodDict env fSignatory (`ETmApp` EVar this)
        tplObservers <- useSingleMethodDict env fObserver (`ETmApp` EVar this)
-        tplPrecondition <- useSingleMethodDict env fEnsure (`ETmApp` EVar this)
+        tplPrecondition <- useSingleMethodDict env fEnsure (wrapPrecondition . (`ETmApp` EVar this))
        tplAgreement <- useSingleMethodDict env fAgreement (`ETmApp` EVar this)
        tplChoices <- convertChoices env tplTypeCon tbinds
        tplKey <- convertTemplateKey env tplTypeCon tbinds
@ -694,6 +697,31 @@ convertTemplate env tplTypeCon tbinds@TemplateBinds{..}
    | otherwise =
        unhandled "Missing required instances in template definition." (show tplTypeCon)

+  where
+    wrapPrecondition b
+        | envLfVersion env`supports` featureExceptions
+        = case tbShow of
+            Nothing ->
+                error ("Missing Show instance for template: " <> show tplTypeCon)
+            Just showDict ->
+                ECase b
+                    [ CaseAlternative (CPBool True) ETrue
+                    , CaseAlternative (CPBool False)
+                        $ EThrow TBool (TCon contractErrorTypeCon)
+                        $ mkContractError
+                        $ EBuiltin BEAppendText
+                            `ETmApp` EBuiltin (BEText "Template precondition violated: " )
+                            `ETmApp`
+                                (EStructProj (FieldName "m_show")
+                                    (EVal (Qualified PRSelf (envLFModuleName env) (convVal showDict)))
+                                `ETmApp` EUnit
+                                `ETmApp` EVar this)
+                    ]
+
+        | otherwise
+        = b
+
+
 convertTemplateKey :: Env -> LF.TypeConName -> TemplateBinds -> ConvertM (Maybe TemplateKey)
 convertTemplateKey env tname TemplateBinds{..}
    | Just keyTy <- tbKeyType
--- a/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion/UtilGHC.hs
+++ b/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion/UtilGHC.hs
@ -78,7 +78,7 @@ pattern IgnoreWorkerPrefixFS :: T.Text -> FastString
 pattern IgnoreWorkerPrefixFS n <- (fsToText -> IgnoreWorkerPrefix n)

 -- daml-prim module patterns
-pattern Control_Exception_Base, Data_String, GHC_Base, GHC_Classes, GHC_CString, GHC_Integer_Type, GHC_Num, GHC_Prim, GHC_Real, GHC_Tuple, GHC_Types :: GHC.Module
+pattern Control_Exception_Base, Data_String, GHC_Base, GHC_Classes, GHC_CString, GHC_Integer_Type, GHC_Num, GHC_Prim, GHC_Real, GHC_Tuple, GHC_Types, GHC_Show :: GHC.Module
 pattern Control_Exception_Base <- ModuleIn DamlPrim "Control.Exception.Base"
 pattern Data_String <- ModuleIn DamlPrim "Data.String"
 pattern GHC_Base <- ModuleIn DamlPrim "GHC.Base"
@ -90,6 +90,7 @@ pattern GHC_Prim <- ModuleIn DamlPrim "GHC.Prim" -- wired-in by GHC
 pattern GHC_Real <- ModuleIn DamlPrim "GHC.Real"
 pattern GHC_Tuple <- ModuleIn DamlPrim "GHC.Tuple"
 pattern GHC_Types <- ModuleIn DamlPrim "GHC.Types"
+pattern GHC_Show <- ModuleIn DamlPrim "GHC.Show"

 -- daml-stdlib module patterns
 pattern DA_Action, DA_Generics, DA_Internal_LF, DA_Internal_Prelude, DA_Internal_Record, DA_Internal_Desugar, DA_Internal_Template_Functions, DA_Internal_Exception :: GHC.Module
@ -132,7 +133,7 @@ pattern DesugarDFunId tyCoVars dfunArgs name classArgs <-
    )

 pattern HasSignatoryDFunId, HasEnsureDFunId, HasAgreementDFunId, HasObserverDFunId,
-    HasArchiveDFunId :: TyCon -> GHC.Var
+    HasArchiveDFunId, ShowDFunId :: TyCon -> GHC.Var

 pattern HasSignatoryDFunId templateTyCon <-
    DesugarDFunId [] [] (NameIn DA_Internal_Template_Functions "HasSignatory")
@ -149,6 +150,9 @@ pattern HasObserverDFunId templateTyCon <-
 pattern HasArchiveDFunId templateTyCon <-
    DesugarDFunId [] [] (NameIn DA_Internal_Template_Functions "HasArchive")
        [splitTyConApp_maybe -> Just (templateTyCon, [])]
+pattern ShowDFunId tyCon <-
+    DesugarDFunId [] [] (NameIn GHC_Show "Show")
+        [splitTyConApp_maybe -> Just (tyCon, [])]

 pattern HasKeyDFunId, HasMaintainerDFunId :: TyCon -> Type -> GHC.Var

@ -166,6 +170,7 @@ pattern HasMessageDFunId tyCon <-
    DesugarDFunId [] [] (NameIn DA_Internal_Exception "HasMessage")
        [splitTyConApp_maybe -> Just (tyCon, [])]

+
 -- | Break down a constraint tuple projection function name
 -- into an (index, arity) pair. These names have the form
 -- "$p1(%,%)" "$p2(%,%)" "$p1(%,,%)" etc.
--- a/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion/UtilLF.hs
+++ b/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion/UtilLF.hs
@ -124,3 +124,16 @@ mkBuiltinGreater v ty =
    if v `supports` featureGenericComparison
        then EBuiltin BEGreaterGeneric `ETyApp` TBuiltin ty
        else EBuiltin (BEGreater ty)
+
+contractErrorTypeCon :: Qualified TypeConName
+contractErrorTypeCon = Qualified
+    { qualPackage = PRImport (PackageId "a4d351c1a14963402c98d9c4ad92ce7e7cea74d81138f4de012df8d65229b78f")
+    , qualModule = ModuleName ["DA", "Exception", "ContractError"]
+    , qualObject = TypeConName ["ContractError"]
+    }
+
+mkContractError :: Expr -> Expr
+mkContractError msg = ERecCon
+    { recTypeCon = TypeConApp contractErrorTypeCon []
+    , recFields = [(FieldName "message", msg)]
+    }
--- a/compiler/damlc/tests/daml-test-files/ExceptionCreate.daml
+++ b/compiler/damlc/tests/daml-test-files/ExceptionCreate.daml
@ -0,0 +1,28 @@
+-- Copyright (c) 2021 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
+-- SPDX-License-Identifier: Apache-2.0
+
+-- @SINCE-LF 1.dev
+
+-- | Test that create throws a ContractError when the precondition is violated.
+module ExceptionCreate where
+
+import DA.Assert
+import DA.Exception
+
+template MyTemplate
+    with
+        p : Party
+    where
+        signatory p
+        ensure False
+
+test = scenario do
+    p <- getParty "Alice"
+    m <- submit p do
+        try do
+            create (MyTemplate p)
+            pure ""
+        catch
+            ContractError msg ->
+                pure msg
+    m === "Template precondition violated: MyTemplate {p = 'Alice'}"
--- a/compiler/damlc/tests/daml-test-files/Precondition.daml
+++ b/compiler/damlc/tests/daml-test-files/Precondition.daml
@ -1,7 +1,7 @@
 -- Copyright (c) 2020, Digital Asset (Switzerland) GmbH and/or its affiliates.
 -- All rights reserved.

-- @ERROR range=22:1-22:5; Template pre-condition violated
+-- @ERROR range=22:1-22:5; Template precondition violated

 module Precondition where

--- a/compiler/damlc/tests/daml-test-files/SemanticsEvalOrder.daml
+++ b/compiler/damlc/tests/daml-test-files/SemanticsEvalOrder.daml
@ -294,7 +294,7 @@ evUpdCreateErr1 = scenario do
    create (T_EvUpdCreateErr1 p)
    error "EvUpdCreateErr1 failed (4)"

-- @ERROR Template pre-condition violated in: create SemanticsEvalOrder:T_EvUpdCreateFail
+-- @ERROR range=307:1-307:16; Template precondition violated
 template T_EvUpdCreateFail
  with
    p : Party
--- a/compiler/scenario-service/client/src/DA/Daml/LF/PrettyScenario.hs
+++ b/compiler/scenario-service/client/src/DA/Daml/LF/PrettyScenario.hs
@ -221,7 +221,7 @@ prettyScenarioErrorError (Just err) =  do
    ScenarioErrorErrorUnhandledException exc -> pure $ text "Unhandled exception: " <-> prettyValue' True 0 world exc
    ScenarioErrorErrorTemplatePrecondViolated ScenarioError_TemplatePreconditionViolated{..} -> do
      pure $
-        "Template pre-condition violated in:"
+        "Template precondition violated in:"
          $$ nest 2
          (   "create"
          <-> prettyMay "<missing template id>" (prettyDefName world) scenarioError_TemplatePreconditionViolatedTemplateId