Disallow exceptions repetition for 2.x (#20003)

* Disallow upgrading exceptions in 2.x

* lint

* Replace setUpgradeField with True

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

@@ -221,6 +221,7 @@ data UnwarnableError
   | EForbiddenNewImplementation !TypeConName !TypeConName
   | EUpgradeDependenciesFormACycle ![(PackageId, Maybe PackageMetadata)]
   | EUpgradeMultiplePackagesWithSameNameAndVersion !PackageName !RawPackageVersion ![PackageId]
+  | EUpgradeTriedToUpgradeException !TypeConName
   | EUpgradeDifferentParamsCount !UpgradedRecordOrigin
   | EUpgradeDifferentParamsKinds !UpgradedRecordOrigin
   deriving (Show)
@@ -231,6 +232,7 @@ data WarnableError
   | WEUpgradeShouldDefineTplInSeparatePackage !TypeConName !TypeConName
   | WEDependencyHasUnparseableVersion !PackageName !PackageVersion !PackageUpgradeOrigin
   | WEDependencyHasNoMetadataDespiteUpgradeability !PackageId !PackageUpgradeOrigin
+  | WEUpgradeShouldDefineExceptionsAndTemplatesSeparately
   deriving (Eq, Show)
 
 instance Pretty WarnableError where
@@ -259,6 +261,12 @@ instance Pretty WarnableError where
       "Dependency " <> pPrint pkgName <> " of " <> pPrint packageOrigin <> " has a version which cannot be parsed: '" <> pPrint version <> "'"
     WEDependencyHasNoMetadataDespiteUpgradeability pkgId packageOrigin ->
       "Dependency with package ID " <> pPrint pkgId <> " of " <> pPrint packageOrigin <> " has no metadata, despite being compiled with an SDK version that supports metadata."
+    WEUpgradeShouldDefineExceptionsAndTemplatesSeparately ->
+      vsep
+        [ "This package defines both exceptions and templates. This may make this package and its dependents not upgradeable."
+        , "It is recommended that exceptions are defined in their own package separate from their implementations."
+        , "Ignore this error message with the --warn-bad-exceptions=yes flag."
+        ]
 
 data PackageUpgradeOrigin = UpgradingPackage | UpgradedPackage
   deriving (Eq, Ord, Show)
@@ -696,6 +704,8 @@ instance Pretty UnwarnableError where
       pprintDep (pkgId, Just meta) = pPrint pkgId <> "(" <> pPrint (packageName meta) <> ", " <> pPrint (packageVersion meta) <> ")"
       pprintDep (pkgId, Nothing) = pPrint pkgId
     EUpgradeMultiplePackagesWithSameNameAndVersion name version ids -> "Multiple packages with name " <> pPrint name <> " and version " <> pPrint (show version) <> ": " <> hcat (L.intersperse ", " (map pPrint ids))
+    EUpgradeTriedToUpgradeException exception ->
+      "Tried to upgrade exception " <> pPrint exception <> ", but exceptions cannot be upgraded. They should be removed in any upgrading package."
     EUpgradeDifferentParamsCount origin -> "The upgraded " <> pPrint origin <> " has changed the number of type variables it has."
     EUpgradeDifferentParamsKinds origin -> "The upgraded " <> pPrint origin <> " has changed the kind of one of its type variables."
 

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

@@ -66,7 +66,7 @@ shouldTypecheckM = asks (uncurry shouldTypecheck)
 
 mkGamma :: Version -> UpgradeInfo -> World -> Gamma
 mkGamma version upgradeInfo world =
-    let addBadIfaceSwapIndicator :: Gamma -> Gamma
+    let addBadIfaceSwapIndicator, addBadExceptionSwapIndicator :: Gamma -> Gamma
         addBadIfaceSwapIndicator =
             if uiWarnBadInterfaceInstances upgradeInfo
             then
@@ -76,8 +76,15 @@ mkGamma version upgradeInfo world =
                     Left WEUpgradeShouldDefineIfacesAndTemplatesSeparately {} -> Just True
                     _ -> Nothing)
             else id
+        addBadExceptionSwapIndicator =
+            if uiWarnBadExceptions upgradeInfo
+            then
+                addDiagnosticSwapIndicator (\case
+                    Left WEUpgradeShouldDefineExceptionsAndTemplatesSeparately {} -> Just True
+                    _ -> Nothing)
+            else id
     in
-    addBadIfaceSwapIndicator $ emptyGamma world version
+    addBadExceptionSwapIndicator $ addBadIfaceSwapIndicator $ emptyGamma world version
 
 gammaM :: World -> TcPreUpgradeM Gamma
 gammaM world = asks (flip (uncurry mkGamma) world)
@@ -131,7 +138,7 @@ checkPackageSingle mbContext pkg =
   withReaderT (\(version, upgradeInfo) -> mkGamma version upgradeInfo presentWorld) $
     withMbContext $ do
       checkNewInterfacesAreUnused pkg
-      checkNewInterfacesHaveNoTemplates
+      checkInterfacesAndExceptionsHaveNoTemplates
 
 type UpgradedPkgWithNameAndVersion = (LF.PackageId, LF.Package, LF.PackageName, Maybe LF.PackageVersion)
 
@@ -146,7 +153,7 @@ checkModule world0 module_ deps version upgradeInfo mbUpgradedPkg =
       let world = extendWorldSelf module_ world0
       withReaderT (\(version, upgradeInfo) -> mkGamma version upgradeInfo world) $ do
         checkNewInterfacesAreUnused module_
-        checkNewInterfacesHaveNoTemplates
+        checkInterfacesAndExceptionsHaveNoTemplates
       case mbUpgradedPkg of
         Nothing -> pure ()
         Just (upgradedPkgWithId@(upgradedPkgIdRaw, upgradedPkg, _, _), upgradingDeps) -> do
@@ -411,42 +418,50 @@ checkModuleM upgradedPackageId module_ = do
 
     let ifaceDts :: Upgrading (HMS.HashMap LF.TypeConName (DefDataType, DefInterface))
         unownedDts :: Upgrading (HMS.HashMap LF.TypeConName DefDataType)
-        (ifaceDts, unownedDts) =
+        exceptionDts :: Upgrading (HMS.HashMap LF.TypeConName (DefDataType, DefException))
+        (ifaceDts, exceptionDts, unownedDts) =
             let Upgrading
-                    { _past = (pastIfaceDts, pastUnownedDts)
-                    , _present = (presentIfaceDts, presentUnownedDts)
+                    { _past = (pastIfaceDts, pastExceptionDts, pastUnownedDts)
+                    , _present = (presentIfaceDts, presentExceptionDts, presentUnownedDts)
                     } = fmap splitModuleDts module_
             in
             ( Upgrading pastIfaceDts presentIfaceDts
+            , Upgrading pastExceptionDts presentExceptionDts
             , Upgrading pastUnownedDts presentUnownedDts
             )
 
         splitModuleDts
             :: Module
             -> ( HMS.HashMap LF.TypeConName (DefDataType, DefInterface)
+               , HMS.HashMap LF.TypeConName (DefDataType, DefException)
                , HMS.HashMap LF.TypeConName DefDataType)
         splitModuleDts module_ =
-            let (ifaceDtsList, unownedDtsList) =
-                    partitionEithers
-                        $ map (\(tcon, def) -> lookupInterface module_ tcon def)
+            let (ifaceDtsList, (exceptionDtsList, unownedDtsList)) =
+                    fmap partitionEithers $ partitionEithers
+                        $ map (\(tcon, def) -> lookupInterfaceOrException module_ tcon def)
                         $ HMS.toList $ NM.toHashMap $ moduleDataTypes module_
             in
-            (HMS.fromList ifaceDtsList, HMS.fromList unownedDtsList)
+            (HMS.fromList ifaceDtsList, HMS.fromList exceptionDtsList, HMS.fromList unownedDtsList)
 
-        lookupInterface
+        lookupInterfaceOrException
             :: Module -> LF.TypeConName -> DefDataType
-            -> Either (LF.TypeConName, (DefDataType, DefInterface)) (LF.TypeConName, DefDataType)
-        lookupInterface module_ tcon datatype =
+            -> Either (LF.TypeConName, (DefDataType, DefInterface)) (Either (LF.TypeConName, (DefDataType, DefException)) (LF.TypeConName, DefDataType))
+        lookupInterfaceOrException module_ tcon datatype =
             case NM.name datatype `NM.lookup` moduleInterfaces module_ of
-              Nothing -> Right (tcon, datatype)
+              Nothing -> Right $
+                case NM.name datatype `NM.lookup` moduleExceptions module_ of
+                  Nothing -> Right (tcon, datatype)
+                  Just exception -> Left (tcon, (datatype, exception))
               Just iface -> Left (tcon, (datatype, iface))
 
     -- Check that no interfaces have been deleted, nor propagated
-    -- New interface checks are handled by `checkNewInterfacesHaveNoTemplates`,
+    -- New interface checks are handled by `checkInterfacesAndExceptionsHaveNoTemplates`,
     -- invoked in `singlePkgDiagnostics` above
     -- Interface deletion is the correct behaviour so we ignore that
     let (_ifaceDel, ifaceExisting, _ifaceNew) = extractDelExistNew ifaceDts
     checkContinuedIfaces module_ ifaceExisting
+    let (_exceptionDel, exceptionExisting, _exceptionNew) = extractDelExistNew exceptionDts
+    checkContinuedExceptions module_ exceptionExisting
 
     let flattenInstances
             :: Module
@@ -516,6 +531,17 @@ checkContinuedIfaces module_ ifaces =
         withContextF present' (ContextDefInterface (_present module_) iface IPWhole) $
             throwWithContextF present' $ EUpgradeTriedToUpgradeIface (NM.name iface)
 
+checkContinuedExceptions
+    :: Upgrading Module
+    -> HMS.HashMap LF.TypeConName (Upgrading (DefDataType, DefException))
+    -> TcUpgradeM ()
+checkContinuedExceptions module_ exceptions =
+    forM_ exceptions $ \upgradedDtException ->
+        let (_dt, exception) = _present upgradedDtException
+        in
+        withContextF present' (ContextDefException (_present module_) exception) $
+            throwWithContextF present' $ EUpgradeTriedToUpgradeException (NM.name exception)
+
 class HasModules a where
   getModules :: a -> NM.NameMap LF.Module
 
@@ -531,13 +557,16 @@ instance HasModules [LF.Module] where
 -- Check that a module or package does not define both interfaces and templates.
 -- This warning should trigger even when no previous version DAR is specified in
 -- the `upgrades:` field.
-checkNewInterfacesHaveNoTemplates :: TcM ()
-checkNewInterfacesHaveNoTemplates = do
+checkInterfacesAndExceptionsHaveNoTemplates :: TcM ()
+checkInterfacesAndExceptionsHaveNoTemplates = do
     modules <- NM.toList . packageModules . getWorldSelf <$> getWorld
     let templateDefined = filter (not . NM.null . moduleTemplates) modules
         interfaceDefined = filter (not . NM.null . moduleInterfaces) modules
+        exceptionDefined = filter (not . NM.null . moduleExceptions) modules
     when (not (null templateDefined) && not (null interfaceDefined)) $
         diagnosticWithContext WEUpgradeShouldDefineIfacesAndTemplatesSeparately
+    when (not (null templateDefined) && not (null exceptionDefined)) $
+        diagnosticWithContext WEUpgradeShouldDefineExceptionsAndTemplatesSeparately
 
 -- Check that any interfaces defined in this package or module do not also have
 -- an instance. Interfaces defined in other packages are allowed to have

sdk/compiler/damlc/daml-opts/daml-opts-types/DA/Daml/Options/Types.hs

@@ -37,6 +37,7 @@ module DA.Daml.Options.Types
     , UpgradeInfo (..)
     , defaultUiTypecheckUpgrades
     , defaultUiWarnBadInterfaceInstances
+    , defaultUiWarnBadExceptions
     , defaultUpgradeInfo
     ) where
 
@@ -141,6 +142,7 @@ data UpgradeInfo = UpgradeInfo
     { uiUpgradedPackagePath :: Maybe FilePath
     , uiTypecheckUpgrades :: Bool
     , uiWarnBadInterfaceInstances :: Bool
+    , uiWarnBadExceptions :: Bool
     }
 
 newtype IncrementalBuild = IncrementalBuild { getIncrementalBuild :: Bool }
@@ -291,11 +293,13 @@ defaultUpgradeInfo = UpgradeInfo
     { uiUpgradedPackagePath = Nothing
     , uiTypecheckUpgrades = defaultUiTypecheckUpgrades
     , uiWarnBadInterfaceInstances = defaultUiWarnBadInterfaceInstances
+    , uiWarnBadExceptions = defaultUiWarnBadExceptions
     }
 
-defaultUiTypecheckUpgrades, defaultUiWarnBadInterfaceInstances :: Bool
+defaultUiTypecheckUpgrades, defaultUiWarnBadInterfaceInstances, defaultUiWarnBadExceptions :: Bool
 defaultUiTypecheckUpgrades = True
 defaultUiWarnBadInterfaceInstances = False
+defaultUiWarnBadExceptions = False
 
 pkgNameVersion :: LF.PackageName -> Maybe LF.PackageVersion -> UnitId
 pkgNameVersion (LF.PackageName n) mbV =

sdk/compiler/damlc/lib/DA/Cli/Options.hs

@@ -587,11 +587,20 @@ optionsParser numProcessors enableScenarioService parsePkgName parseDlintUsage =
         "Convert errors about bad, non-upgradeable interface instances into warnings."
         idm
 
+    optWarnBadExceptions :: Parser Bool
+    optWarnBadExceptions =
+      flagYesNoAuto
+        "warn-bad-exceptions"
+        defaultUiWarnBadExceptions
+        "Convert errors about bad, non-upgradeable exceptions into warnings."
+        idm
+
     optUpgradeInfo :: Parser UpgradeInfo
     optUpgradeInfo = do
       uiTypecheckUpgrades <- optTypecheckUpgrades
       uiUpgradedPackagePath <- optUpgradeDar
       uiWarnBadInterfaceInstances <- optWarnBadInterfaceInstances
+      uiWarnBadExceptions <- optWarnBadExceptions
       pure UpgradeInfo {..}
 
 optGhcCustomOptions :: Parser [String]

sdk/compiler/damlc/tests/BUILD.bazel

@@ -457,6 +457,7 @@ da_haskell_test(
         "//test-common:upgrades-FailsWhenATopLevelVariantAddsAFieldToAVariantsType-files",
         "//test-common:upgrades-FailsWhenATopLevelVariantAddsAVariant-files",
         "//test-common:upgrades-FailsWhenATopLevelVariantRemovesAVariant-files",
+        "//test-common:upgrades-FailsWhenAnExceptionIsDefinedInAnUpgradingPackageWhenItWasAlreadyInThePriorPackage-files",
         "//test-common:upgrades-FailsWhenAnInstanceIsAddedSeparateDep-files",
         "//test-common:upgrades-FailsWhenAnInstanceIsAddedUpgradedPackage-files",
         "//test-common:upgrades-FailsWhenAnInstanceIsDropped-files",
@@ -496,6 +497,7 @@ da_haskell_test(
         "//test-common:upgrades-SucceedsWhenATopLevelTypeSynonymChanges-files",
         "//test-common:upgrades-SucceedsWhenATopLevelVariantAddsAVariant-files",
         "//test-common:upgrades-SucceedsWhenATopLevelVariantAddsAnOptionalFieldToAVariantsType-files",
+        "//test-common:upgrades-SucceedsWhenAnExceptionIsOnlyDefinedInTheInitialPackage-files",
         "//test-common:upgrades-SucceedsWhenAnInstanceIsAddedToNewTemplateSeparateDep-files",
         "//test-common:upgrades-SucceedsWhenAnInstanceIsAddedToNewTemplateUpgradedPackage-files",
         "//test-common:upgrades-SucceedsWhenAnInterfaceIsOnlyDefinedInTheInitialPackage-files",

sdk/compiler/damlc/tests/daml-test-files/Daml3ScriptTrySubmitConcurrently.daml

@@ -3,7 +3,8 @@
 
 -- @ SCRIPT-V2
 
--- @ WARN range=19:1-19:52; Import of internal module Daml.Script.Internal of package daml3-script is discouraged, as this module will change without warning.
+-- @ WARN range=20:1-20:52; Import of internal module Daml.Script.Internal of package daml3-script is discouraged, as this module will change without warning.
+-- @ WARN warn-bad-exceptions
 
 {-# LANGUAGE ApplicativeDo #-}
 

sdk/compiler/damlc/tests/daml-test-files/ExceptionSemantics.daml

@@ -2,10 +2,11 @@
 -- SPDX-License-Identifier: Apache-2.0
 
 -- @SUPPORTS-LF-FEATURE DAML_EXCEPTIONS
--- @ERROR range=132:1-132:23; Unhandled exception: ExceptionSemantics:E
--- @ERROR range=147:1-147:25; Unhandled exception: DA.Exception.ArithmeticError:ArithmeticError@XXXXXX with message = "ArithmeticError while evaluating (DIV_INT64 1 0)."
--- @WARN range=181:3-181:12; Use of divulged contracts is deprecated
--- @ERROR range=184:1-184:11; Attempt to exercise a consumed contract
+-- @ERROR range=133:1-133:23; Unhandled exception: ExceptionSemantics:E
+-- @ERROR range=148:1-148:25; Unhandled exception: DA.Exception.ArithmeticError:ArithmeticError@XXXXXX with message = "ArithmeticError while evaluating (DIV_INT64 1 0)."
+-- @WARN range=182:3-182:12; Use of divulged contracts is deprecated
+-- @ERROR range=185:1-185:11; Attempt to exercise a consumed contract
+-- @WARN since-lf=1.17 2.0; warn-bad-exceptions
 module ExceptionSemantics where
 
 import Daml.Script

sdk/compiler/damlc/tests/daml-test-files/ExceptionSyntax.daml

@@ -2,6 +2,7 @@
 -- SPDX-License-Identifier: Apache-2.0
 
 -- @SUPPORTS-LF-FEATURE DAML_EXCEPTIONS
+-- @WARN since-lf=1.17 2.0; warn-bad-exceptions
 -- @QUERY-LF [ $pkg.modules[].exceptions[] ] | length == 1
 
 -- | Test that exception syntax is correctly handled.

sdk/compiler/damlc/tests/daml-test-files/InterfaceGuarded.daml

@@ -6,6 +6,7 @@
 -- @WARN since-lf=1.16 2.0; warn-bad-interface-instances
 -- @WARN since-lf=1.16 2.0; warn-bad-interface-instances
 -- @WARN since-lf=1.16 2.0; warn-bad-interface-instances
+-- @WARN since-lf=1.16 2.0; warn-bad-exceptions
 
 module InterfaceGuarded where
 
@@ -146,17 +147,17 @@ exerciseTest c = script do
 
 trueGuard = exerciseTest TrueGuard
 
--- @ERROR range=150:1-150:11; failing guard
+-- @ERROR range=151:1-151:11; failing guard
 falseGuard = exerciseTest FalseGuard
 
--- @ERROR range=153:1-153:11; failing guard
+-- @ERROR range=154:1-154:11; failing guard
 errorGuard = exerciseTest ErrorGuard
 
--- @ERROR range=156:1-156:17; failing guard
+-- @ERROR range=157:1-157:17; failing guard
 customErrorGuard = exerciseTest CustomErrorGuard
 
--- @ERROR range=159:1-159:14; failing guard
+-- @ERROR range=160:1-160:14; failing guard
 tryErrorGuard = exerciseTest TryErrorGuard
 
--- @ERROR range=162:1-162:20; failing guard
+-- @ERROR range=163:1-163:20; failing guard
 tryCustomErrorGuard = exerciseTest TryCustomErrorGuard

sdk/compiler/damlc/tests/daml-test-files/RestrictedNameWarnings.daml

@@ -1,7 +1,8 @@
--- @WARN range=9:5-9:9; `self' is an unsupported field name, and may break without warning in future versions. Please use something else.
--- @WARN range=14:5-14:8; `arg' is an unsupported field name, and may break without warning in future versions. Please use something else.
--- @WARN range=19:5-19:9; `self' is an unsupported field name, and may break without warning in future versions. Please use something else.
--- @WARN range=24:5-24:8; `arg' is an unsupported field name, and may break without warning in future versions. Please use something else.
+-- @WARN range=10:5-10:9; `self' is an unsupported field name, and may break without warning in future versions. Please use something else.
+-- @WARN range=15:5-15:8; `arg' is an unsupported field name, and may break without warning in future versions. Please use something else.
+-- @WARN range=20:5-20:9; `self' is an unsupported field name, and may break without warning in future versions. Please use something else.
+-- @WARN range=25:5-25:8; `arg' is an unsupported field name, and may break without warning in future versions. Please use something else.
+-- @WARN since-lf=1.17 2.0; warn-bad-exceptions
 
 module RestrictedNameWarnings where
 

sdk/compiler/damlc/tests/src/DA/Test/DamlcIntegration.hs

@@ -329,7 +329,7 @@ getIntegrationTests registerTODO scenarioService (packageDbPath, packageFlags) =
                     , dlintHintFiles = NoDlintHintFiles
                     }
                 , optPackageImports = packageFlags
-                , optUpgradeInfo = (optUpgradeInfo opts0) { uiWarnBadInterfaceInstances = True }
+                , optUpgradeInfo = (optUpgradeInfo opts0) { uiWarnBadInterfaceInstances = True, uiWarnBadExceptions = True }
                 }
 
               mkIde options = do

sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs

@@ -618,6 +618,20 @@ tests damlc =
                   "my-package"
                   "0.0.2"
                   version1_dev
+            , test
+                  "SucceedsWhenAnExceptionIsOnlyDefinedInTheInitialPackage"
+                  Succeed
+                  versionDefault
+                  NoDependencies
+                  False
+                  True
+            , test
+                  "FailsWhenAnExceptionIsDefinedInAnUpgradingPackageWhenItWasAlreadyInThePriorPackage"
+                  (FailWithError "\ESC\\[0;91merror type checking exception Main.E:\n  Tried to upgrade exception E, but exceptions cannot be upgraded. They should be removed in any upgrading package.")
+                  versionDefault
+                  NoDependencies
+                  False
+                  True
             , test
                   "FailWhenParamCountChanges"
                   (FailWithError "\ESC\\[0;91merror type checking data type Main.MyStruct:\n  The upgraded data type MyStruct has changed the number of type variables it has.")

sdk/daml-assistant/integration-tests/src/DA/Daml/Assistant/IntegrationTests.hs

@@ -123,7 +123,7 @@ damlStart tmpDir disableUpgradeValidation = do
             , "    npm-scope: daml.js"
             , "  java:"
             , "    output-directory: ui/java"
-            ] ++ [ "build-options:\n- --warn-bad-interface-instances=yes" | disableUpgradeValidation ]
+            ] ++ [ "build-options:\n- --warn-bad-interface-instances=yes\n- --warn-bad-exceptions=yes" | disableUpgradeValidation ]
     writeFileUTF8 (projDir </> "daml/Main.daml") $
         unlines
             [ "module Main where"