Upgrade validation warnings to errors flag

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",
     ],
 )

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

@@ -64,7 +64,7 @@ import           DA.Daml.LF.TypeChecker.Error
 
 
 -- | Check that a list does /not/ contain duplicate elements.
-checkUnique :: (MonadGamma m, Eq a, Hashable a) => (a -> Error) -> [a] -> m ()
+checkUnique :: (MonadGamma m, Eq a, Hashable a) => (a -> UnwarnableError) -> [a] -> m ()
 checkUnique mkDuplicateError xs = void (foldlM step HS.empty xs)
   where
     step acc x
@@ -338,7 +338,7 @@ typeOfRecUpd typ0 field record update = do
   fieldType <- match _Just (EUnknownField field typ1) (lookup field recordType)
   checkExpr record typ1
   catchAndRethrow
-    (\case
+    (overUnwarnable $ \case
       ETypeMismatch { foundType, expectedType, expr } ->
         EFieldTypeMismatch
           { targetRecord = typ1
@@ -1019,7 +1019,7 @@ checkInterfaceInstance tmplParam iiHead iiBody = do
         Nothing -> throwWithContext (EUnknownMethodInInterfaceInstance iiInterface iiTemplate iiMethodName)
         Just InterfaceMethod{ifmType} ->
           catchAndRethrow
-            (\case
+            (overUnwarnable $ \case
               ETypeMismatch { foundType, expectedType, expr } ->
                 EMethodTypeMismatch
                   { emtmIfaceName = iiInterface
@@ -1034,7 +1034,7 @@ checkInterfaceInstance tmplParam iiHead iiBody = do
 
     -- check view result type matches interface result type
     catchAndRethrow
-      (\case
+      (overUnwarnable $ \case
           ETypeMismatch { foundType, expectedType, expr } ->
             EViewTypeMismatch
               { evtmIfaceName = iiInterface

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

@@ -15,6 +15,7 @@ module DA.Daml.LF.TypeChecker.Env(
     TcMF,
     throwWithContext, throwWithContextF,
     warnWithContext, warnWithContextF,
+    diagnosticWithContext,
     catchAndRethrow,
     inWorld,
     match,
@@ -27,8 +28,11 @@ module DA.Daml.LF.TypeChecker.Env(
     getLfVersion,
     getWorld,
     runGamma, runGammaF,
-    Gamma,
-    emptyGamma
+    Gamma(..),
+    emptyGamma,
+    SomeErrorOrWarning(..),
+    addDiagnosticSwapIndicator,
+    withDiagnosticSwapIndicatorF,
     ) where
 
 import           Control.Lens hiding (Context)
@@ -52,13 +56,36 @@ data Gamma = Gamma
     -- ^ The packages in scope.
   , _lfVersion :: Version
     -- ^ The Daml-LF version of the package being type checked.
+  , _diagnosticSwapIndicator :: Either WarnableError Warning -> Bool
+    -- ^ Function for relaxing errors into warnings and strictifying warnings into errors
   }
 
 makeLenses ''Gamma
 
+class SomeErrorOrWarning d where
+  diagnosticWithContextF :: forall m gamma. MonadGammaF gamma m => Getter gamma Gamma -> d -> m ()
+
 getLfVersion :: MonadGamma m => m Version
 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
 
@@ -84,13 +111,13 @@ runGammaF gamma act = runStateT (runReaderT act gamma) []
 
 -- | Helper function which tries to match on a prism and fails with a provided
 -- error in case is does not match.
-match :: MonadGamma m => Prism' a b -> Error -> a -> m b
+match :: MonadGamma m => Prism' a b -> UnwarnableError -> a -> m b
 match p e x = either (const (throwWithContext e)) pure (matching p x)
 
 -- | Environment containing only the packages in scope but no type or term
 -- variables.
 emptyGamma :: World -> Version -> Gamma
-emptyGamma = Gamma ContextNone mempty mempty
+emptyGamma world version = Gamma ContextNone mempty mempty world version (const False)
 
 -- | Run a computation in the current environment extended by a new type
 -- variable/kind binding. Does not fail on shadowing.
@@ -125,31 +152,54 @@ inWorld look = do
     Left e -> throwWithContext (EUnknownDefinition e)
     Right x -> pure x
 
-throwWithContext :: MonadGamma m => Error -> m a
-throwWithContext err = do
-  ctx <- view locCtx
-  throwError $ EContext ctx err
+diagnosticWithContext :: (SomeErrorOrWarning d, MonadGamma m) => d -> m ()
+diagnosticWithContext = diagnosticWithContextF id
+
+throwWithContext :: MonadGamma m => UnwarnableError -> m a
+throwWithContext = throwWithContextF id
 
 warnWithContext :: MonadGamma m => Warning -> m ()
-warnWithContext warning = do
-  ctx <- view locCtx
-  modify' (WContext ctx warning :)
+warnWithContext = warnWithContextF id
 
 withContext :: MonadGamma m => Context -> m b -> m b
-withContext ctx = local (set locCtx ctx)
+withContext = withContextF id
 
 catchAndRethrow :: MonadGamma m => (Error -> Error) -> m b -> m b
-catchAndRethrow handler mb = catchError mb $ throwWithContext . handler
+catchAndRethrow handler mb = catchError mb $ throwWithContextFRaw id . handler
+
+throwWithContextF :: forall m gamma a. MonadGammaF gamma m => Getter gamma Gamma -> UnwarnableError -> m a
+throwWithContextF getter err = throwWithContextFRaw getter (EUnwarnableError err)
 
-throwWithContextF :: MonadGammaF gamma m => Getter gamma Gamma -> Error -> m a
-throwWithContextF getter err = do
+throwWithContextFRaw :: forall m gamma a. MonadGammaF gamma m => Getter gamma Gamma -> Error -> m a
+throwWithContextFRaw getter err = do
   ctx <- view $ getter . locCtx
   throwError $ EContext ctx err
 
-warnWithContextF :: MonadGammaF gamma m => Getter gamma Gamma -> Warning -> m ()
-warnWithContextF getter warning = do
-  ctx <- view $ getter . locCtx
-  modify' (WContext ctx warning :)
+warnWithContextF :: forall m gamma. MonadGammaF gamma m => Getter gamma Gamma -> Warning -> m ()
+warnWithContextF = diagnosticWithContextF
 
 withContextF :: MonadGammaF gamma m => Setter' gamma Gamma -> Context -> m b -> m b
 withContextF setter ctx = local (set (setter . locCtx) ctx)
+
+instance SomeErrorOrWarning UnwarnableError where
+  diagnosticWithContextF = throwWithContextF
+
+instance SomeErrorOrWarning WarnableError where
+  diagnosticWithContextF getter err = do
+    shouldSwap <- getDiagnosticSwapIndicatorF getter
+    if shouldSwap (Left err)
+       then do
+        ctx <- view $ getter . locCtx
+        modify' (WContext ctx (WErrorToWarning err) :)
+       else do
+        throwWithContextFRaw getter (EWarnableError err)
+
+instance SomeErrorOrWarning Warning where
+  diagnosticWithContextF getter warning = do
+    shouldSwap <- getDiagnosticSwapIndicatorF getter
+    if shouldSwap (Right warning)
+       then do
+        throwWithContextFRaw getter (EWarningToError warning)
+       else do
+        ctx <- view $ getter . locCtx
+        modify' (WContext ctx warning :)