Throw ContractError in template precondition field (#9760)

* Throw ContractError in template precondition field

changelog_begin
changelog_end

* s/pre-condition/precondition/where relevant

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

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.

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)]
+    }

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'}"

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
 

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

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