Add warn-bad-interface-instances flag

digital-asset · May 23, 2024 · 3923696 · 3923696
1 parent b2a9dd9
commit 3923696
Show file tree

Hide file tree

Showing 7 changed files with 53 additions and 5 deletions.
diff --git a/sdk/compiler/daml-lf-tools/BUILD.bazel b/sdk/compiler/daml-lf-tools/BUILD.bazel
@@ -28,6 +28,7 @@ da_haskell_library(
     deps = [
         "//compiler/daml-lf-ast",
         "//compiler/damlc/daml-lf-util",
+        "//compiler/damlc/daml-opts:daml-opts-types",
         "//libs-haskell/da-hs-base",
     ],
 )

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
@@ -31,6 +31,8 @@ module DA.Daml.LF.TypeChecker.Env(
     Gamma,
     emptyGamma,
     SomeErrorOrWarning(..),
+    addDiagnosticSwapIndicator,
+    withDiagnosticSwapIndicatorF,
     ) where
 
 import           Control.Lens hiding (Context)
@@ -69,6 +71,21 @@ getLfVersion = view lfVersion
 getDiagnosticSwapIndicatorF :: forall m gamma. MonadGammaF gamma m => Getter gamma Gamma -> m (Either WarnableError Warning -> Bool)
 getDiagnosticSwapIndicatorF getter = view (getter . diagnosticSwapIndicator)
 
+addDiagnosticSwapIndicator
+  :: (Either WarnableError Warning -> Maybe Bool)
+  -> Gamma -> Gamma
+addDiagnosticSwapIndicator newIndicator =
+  diagnosticSwapIndicator %~ \oldIndicator err ->
+    case newIndicator err of
+      Nothing -> oldIndicator err
+      Just verdict -> verdict
+
+withDiagnosticSwapIndicatorF
+  :: MonadGammaF gamma m
+  => Setter' gamma Gamma -> (Either WarnableError Warning -> Maybe Bool) -> m () -> m ()
+withDiagnosticSwapIndicatorF setter newIndicator =
+  locally setter (addDiagnosticSwapIndicator newIndicator)
+
 getWorld :: MonadGamma m => m World
 getWorld = view world
 

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
@@ -17,6 +17,7 @@ import           DA.Daml.LF.Ast.Alpha (alphaExpr, alphaType)
 import           DA.Daml.LF.TypeChecker.Check (expandTypeSynonyms)
 import           DA.Daml.LF.TypeChecker.Env
 import           DA.Daml.LF.TypeChecker.Error
+import           DA.Daml.Options.Types (WarnBadInterfaceInstances(..))
 import           Data.Bifunctor (first)
 import           Data.Data
 import           Data.Either (partitionEithers)
@@ -61,16 +62,26 @@ runGammaUnderUpgrades Upgrading{ _past = pastAction, _present = presentAction }
     presentResult <- withReaderT _present presentAction
     pure Upgrading { _past = pastResult, _present = presentResult }
 
-checkUpgrade :: Version -> Bool -> LF.Package -> Maybe (LF.PackageId, LF.Package) -> [Diagnostic]
-checkUpgrade version shouldTypecheckUpgrades presentPkg mbUpgradedPackage =
+checkUpgrade :: Version -> Bool -> LF.Package -> Maybe (LF.PackageId, LF.Package) -> WarnBadInterfaceInstances -> [Diagnostic]
+checkUpgrade version shouldTypecheckUpgrades presentPkg mbUpgradedPackage warnBadInterfaceInstances =
     let bothPkgDiagnostics :: Either Error ((), [Warning])
         bothPkgDiagnostics =
             case mbUpgradedPackage of
                 Nothing ->
                     Right ((), [])
                 Just (_, pastPkg) ->
                     let package = Upgrading { _past = pastPkg, _present = presentPkg }
-                        upgradingWorld = fmap (\package -> emptyGamma (initWorldSelf [] package) version) package
+                        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
+                        upgradingWorld = fmap initWorldFromPackage package
                     in
                     runGammaF upgradingWorld $ do
                         when shouldTypecheckUpgrades (checkUpgradeM package)

diff --git a/sdk/compiler/damlc/daml-compiler/src/DA/Daml/Compiler/Dar.hs b/sdk/compiler/damlc/daml-compiler/src/DA/Daml/Compiler/Dar.hs
@@ -112,8 +112,9 @@ buildDar ::
     -> PackageConfigFields
     -> NormalizedFilePath
     -> FromDalf
+    -> WarnBadInterfaceInstances
     -> IO (Maybe (Zip.ZipArchive (), Maybe LF.PackageId))
-buildDar service PackageConfigFields {..} ifDir dalfInput = do
+buildDar service PackageConfigFields {..} ifDir dalfInput warnBadInterfaceInstances = do
     liftIO $
         IdeLogger.logDebug (ideLogger service) $
         "Creating dar: " <> T.pack pSrc
@@ -152,7 +153,7 @@ buildDar service PackageConfigFields {..} ifDir dalfInput = do
 
                  MaybeT $
                      runDiagnosticCheck $ diagsToIdeResult (toNormalizedFilePath' pSrc) $
-                         TypeChecker.Upgrade.checkUpgrade lfVersion pTypecheckUpgrades pkg mbUpgradedPackage
+                         TypeChecker.Upgrade.checkUpgrade lfVersion pTypecheckUpgrades warnBadInterfaceInstances pkg mbUpgradedPackage
                  MaybeT $ finalPackageCheck (toNormalizedFilePath' pSrc) pkg
 
                  let pkgModuleNames = map (Ghc.mkModuleName . T.unpack) $ LF.packageModuleNames pkg

diff --git a/sdk/compiler/damlc/daml-opts/daml-opts-types/DA/Daml/Options/Types.hs b/sdk/compiler/damlc/daml-opts/daml-opts-types/DA/Daml/Options/Types.hs
@@ -10,6 +10,7 @@ module DA.Daml.Options.Types
     , EnableScenarios(..)
     , EnableInterfaces(..)
     , AllowLargeTuples(..)
+    , WarnBadInterfaceInstances(..)
     , StudioAutorunAllScenarios(..)
     , SkipScenarioValidation(..)
     , DlintRulesFile(..)
@@ -127,6 +128,8 @@ data Options = Options
   -- packages from remote ledgers.
   , optAllowLargeTuples :: AllowLargeTuples
   -- ^ Do not warn when tuples of size > 5 are used
+  , optWarnBadInterfaceInstances :: WarnBadInterfaceInstances
+  -- ^ Do not warn when tuples of size > 5 are used
   }
 
 newtype IncrementalBuild = IncrementalBuild { getIncrementalBuild :: Bool }
@@ -187,6 +190,9 @@ newtype EnableScenarios = EnableScenarios { getEnableScenarios :: Bool }
 newtype AllowLargeTuples = AllowLargeTuples { getAllowLargeTuples :: Bool }
     deriving Show
 
+newtype WarnBadInterfaceInstances = WarnBadInterfaceInstances { getWarnBadInterfaceInstances :: Bool }
+  deriving Show
+
 newtype StudioAutorunAllScenarios = StudioAutorunAllScenarios { getStudioAutorunAllScenarios :: Bool }
     deriving Show
 
@@ -271,6 +277,7 @@ defaultOptions mbVersion =
         , optEnableOfInterestRule = False
         , optAccessTokenPath = Nothing
         , optAllowLargeTuples = AllowLargeTuples False
+        , optWarnBadInterfaceInstances = WarnBadInterfaceInstances False
         }
 
 pkgNameVersion :: LF.PackageName -> Maybe LF.PackageVersion -> UnitId

diff --git a/sdk/compiler/damlc/lib/DA/Cli/Damlc.hs b/sdk/compiler/damlc/lib/DA/Cli/Damlc.hs
@@ -981,6 +981,7 @@ buildEffect relativize pkgConfig@PackageConfigFields{..} opts mbOutFile incremen
               pkgConfig
               (toNormalizedFilePath' $ fromMaybe ifaceDir $ optIfaceDir opts)
               (FromDalf False)
+              (optWarnBadInterfaceInstances opts)
       (dar, mPkgId) <- mbErr "ERROR: Creation of DAR file failed." mbDar
       fp <- targetFilePath relativize $ unitIdString (pkgNameVersion pName pVersion)
       createDarFile loggerH fp dar

diff --git a/sdk/compiler/damlc/lib/DA/Cli/Options.hs b/sdk/compiler/damlc/lib/DA/Cli/Options.hs
@@ -446,6 +446,7 @@ optionsParser numProcessors enableScenarioService parsePkgName parseDlintUsage =
     optEnableInterfaces <- enableInterfacesOpt
     optAllowLargeTuples <- allowLargeTuplesOpt
     optTestFilter <- compilePatternExpr <$> optTestPattern
+    optWarnBadInterfaceInstances <- warnBadInterfaceInstancesOpt
 
     return Options{..}
   where
@@ -572,6 +573,15 @@ optionsParser numProcessors enableScenarioService parsePkgName parseDlintUsage =
         <> help "Set path to CPP."
         <> internal
 
+optWarnBadInterfaceInstances :: Parser WarnBadInterfaceInstances
+optWarnBadInterfaceInstances =
+  WarnBadInterfaceInstances <$>
+  flagYesNoAuto
+    "warn-bad-interface-instances"
+    False
+    "Convert errors about bad, non-upgradeable interface instances into warnings."
+    idm
+
 optGhcCustomOptions :: Parser [String]
 optGhcCustomOptions =
     fmap concat $ many $