Add tests for warn-bad-interface-instances flag

digital-asset · May 24, 2024 · 77fd53a · 77fd53a
1 parent b56a3e2
commit 77fd53a
Show file tree

Hide file tree

Showing 4 changed files with 164 additions and 79 deletions.
diff --git a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Env.hs b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Env.hs
@@ -28,7 +28,7 @@ module DA.Daml.LF.TypeChecker.Env(
     getLfVersion,
     getWorld,
     runGamma, runGammaF,
-    Gamma,
+    Gamma(..),
     emptyGamma,
     SomeErrorOrWarning(..),
     addDiagnosticSwapIndicator,
@@ -199,7 +199,7 @@ instance SomeErrorOrWarning Warning where
     shouldSwap <- getDiagnosticSwapIndicatorF getter
     if shouldSwap (Right warning)
        then do
-        throwWithContextFRaw getter (EWarnableError (EWarningToError warning))
+        throwWithContextFRaw getter (EWarnableError (WEWarningToError warning))
        else do
         ctx <- view $ getter . locCtx
         modify' (WContext ctx warning :)

diff --git a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs
@@ -204,32 +204,32 @@ data UnwarnableError
   deriving (Show)
 
 data WarnableError
-  = EUpgradeShouldDefineIfacesAndTemplatesSeparately
-  | EUpgradeShouldDefineIfaceWithoutImplementation !TypeConName ![TypeConName]
-  | EUpgradeShouldDefineTplInSeparatePackage !TypeConName !TypeConName
-  | EWarningToError !Warning
+  = WEUpgradeShouldDefineIfacesAndTemplatesSeparately
+  | WEUpgradeShouldDefineIfaceWithoutImplementation !TypeConName ![TypeConName]
+  | WEUpgradeShouldDefineTplInSeparatePackage !TypeConName !TypeConName
+  | WEWarningToError !Warning
   deriving (Show)
 
 instance Pretty WarnableError where
   pPrint = \case
-    EUpgradeShouldDefineIfacesAndTemplatesSeparately ->
+    WEUpgradeShouldDefineIfacesAndTemplatesSeparately ->
       vsep
         [ "This package defines both interfaces and templates."
         , "This is not recommended - templates are upgradeable, but interfaces are not, which means that this version of the package and its templates can never be uninstalled."
         , "It is recommended that interfaces are defined in their own package separate from their implementations."
         ]
-    EUpgradeShouldDefineIfaceWithoutImplementation iface implementingTemplates ->
+    WEUpgradeShouldDefineIfaceWithoutImplementation iface implementingTemplates ->
       vsep $ concat
         [ [ "The interface " <> pPrint iface <> " was defined in this package and implemented in this package by the following templates:" ]
         , map (quotes . pPrint) implementingTemplates
         , [ "However, it is recommended that interfaces are defined in their own package separate from their implementations." ]
         ]
-    EUpgradeShouldDefineTplInSeparatePackage tpl iface ->
+    WEUpgradeShouldDefineTplInSeparatePackage tpl iface ->
       vsep
         [ "The template " <> pPrint tpl <> " has implemented interface " <> pPrint iface <> ", which is defined in a previous version of this package."
         , "However, it is recommended that interfaces are defined in their own package separate from their implementations."
         ]
-    EWarningToError warning -> pPrint warning
+    WEWarningToError warning -> pPrint warning
 
 data UpgradedRecordOrigin
   = TemplateBody TypeConName

diff --git a/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs b/sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs
@@ -10,7 +10,7 @@ module DA.Daml.LF.TypeChecker.Upgrade (
 
 import           Control.DeepSeq
 import           Control.Monad (unless, forM_, when)
-import           Control.Monad.Reader (withReaderT)
+import           Control.Monad.Reader (withReaderT, local)
 import           Control.Lens hiding (Context)
 import           DA.Daml.LF.Ast as LF
 import           DA.Daml.LF.Ast.Alpha (alphaExpr, alphaType)
@@ -64,23 +64,25 @@ runGammaUnderUpgrades Upgrading{ _past = pastAction, _present = presentAction }
 
 checkUpgrade :: Version -> Bool -> WarnBadInterfaceInstances -> LF.Package -> Maybe (LF.PackageId, LF.Package) -> [Diagnostic]
 checkUpgrade version shouldTypecheckUpgrades warnBadInterfaceInstances presentPkg mbUpgradedPackage =
-    let bothPkgDiagnostics :: Either Error ((), [Warning])
+    let addBadIfaceSwapIndicator :: Gamma -> Gamma
+        addBadIfaceSwapIndicator =
+            if getWarnBadInterfaceInstances warnBadInterfaceInstances
+            then
+                addDiagnosticSwapIndicator (\case
+                    Left WEUpgradeShouldDefineIfaceWithoutImplementation {} -> Just True
+                    Left WEUpgradeShouldDefineTplInSeparatePackage {} -> Just True
+                    Left WEUpgradeShouldDefineIfacesAndTemplatesSeparately {} -> Just True
+                    _ -> Nothing)
+            else id
+        bothPkgDiagnostics :: Either Error ((), [Warning])
         bothPkgDiagnostics =
             case mbUpgradedPackage of
                 Nothing ->
                     Right ((), [])
                 Just (_, pastPkg) ->
                     let package = Upgrading { _past = pastPkg, _present = presentPkg }
                         initWorldFromPackage package =
-                            emptyGamma (initWorldSelf [] package) version &
-                                if getWarnBadInterfaceInstances warnBadInterfaceInstances
-                                then
-                                    addDiagnosticSwapIndicator (\case
-                                        Left EUpgradeShouldDefineIfaceWithoutImplementation {} -> Just True
-                                        Left EUpgradeShouldDefineTplInSeparatePackage {} -> Just True
-                                        Left EUpgradeShouldDefineIfacesAndTemplatesSeparately {} -> Just True
-                                        _ -> Nothing)
-                                else id
+                            addBadIfaceSwapIndicator $ emptyGamma (initWorldSelf [] package) version
                         upgradingWorld = fmap initWorldFromPackage package
                     in
                     runGammaF upgradingWorld $ do
@@ -91,8 +93,9 @@ checkUpgrade version shouldTypecheckUpgrades warnBadInterfaceInstances presentPk
             let world = initWorldSelf [] presentPkg
             in
             runGamma world version $ do
-                 checkNewInterfacesHaveNoTemplates presentPkg
-                 checkNewInterfacesAreUnused presentPkg
+                local addBadIfaceSwapIndicator $ do
+                    checkNewInterfacesAreUnused presentPkg
+                    checkNewInterfacesHaveNoTemplates presentPkg
 
         extractDiagnostics :: Either Error ((), [Warning]) -> [Diagnostic]
         extractDiagnostics result =
@@ -297,14 +300,14 @@ checkNewInterfacesHaveNoTemplates presentPkg =
     in
     forM_ (HMS.toList templateAndInterfaceDefined) $ \(_, (module_, _)) ->
         withContext (ContextDefModule module_) $
-            diagnosticWithContext EUpgradeShouldDefineIfacesAndTemplatesSeparately
+            diagnosticWithContext WEUpgradeShouldDefineIfacesAndTemplatesSeparately
 
 -- This warning should run even when no upgrade target is set
 checkNewInterfacesAreUnused :: LF.Package -> TcM ()
 checkNewInterfacesAreUnused presentPkg =
     forM_ definedAndInstantiated $ \((module_, iface), implementations) ->
         withContext (ContextDefInterface module_ iface IPWhole) $
-            diagnosticWithContext $ EUpgradeShouldDefineIfaceWithoutImplementation (NM.name iface) ((\(_,a,_) -> NM.name a) <$> implementations)
+            diagnosticWithContext $ WEUpgradeShouldDefineIfaceWithoutImplementation (NM.name iface) ((\(_,a,_) -> NM.name a) <$> implementations)
     where
     definedIfaces :: HMS.HashMap (LF.Qualified LF.TypeConName) (Module, DefInterface)
     definedIfaces = HMS.unions
@@ -332,7 +335,7 @@ checkUpgradedInterfacesAreUnused package module_ newInstances = do
                 ifaceInstanceHead = InterfaceInstanceHead ifaceName qualifiedTplName
             in
             withContextF present (ContextTemplate module_ tpl (TPInterfaceInstance ifaceInstanceHead Nothing)) $
-                diagnosticWithContextF present $ EUpgradeShouldDefineTplInSeparatePackage (NM.name tpl) (LF.qualObject (NM.name implementation))
+                diagnosticWithContextF present $ WEUpgradeShouldDefineTplInSeparatePackage (NM.name tpl) (LF.qualObject (NM.name implementation))
     where
     fromUpgradedPackage :: forall a. LF.Qualified a -> Bool
     fromUpgradedPackage identifier =