Attach reasons into data field of LSP Diagnostic instead of code field

Had to move `attachReason` between modules to achieve this, which is
fine because it was never exported from its own module.

Author: dylan-thinnes

ghcide/ghcide.cabal

@@ -85,6 +85,7 @@ library
     , hls-plugin-api               == 2.9.0.1
     , implicit-hie                 >= 0.1.4.0 && < 0.1.5
     , lens
+    , lens-aeson
     , list-t
     , lsp                          ^>=2.7
     , lsp-types                    ^>=2.3

ghcide/src/Development/IDE/GHC/Warnings.hs

@@ -7,13 +7,11 @@ module Development.IDE.GHC.Warnings(withWarnings) where
 
 import           Control.Concurrent.Strict
 import           Control.Lens (over)
-import           Data.List
 import qualified Data.Text                         as T
 
 import           Development.IDE.GHC.Compat
-import           Development.IDE.GHC.Error
 import           Development.IDE.Types.Diagnostics
-import           Language.LSP.Protocol.Types       (type (|?) (..))
+import           Development.IDE.GHC.Error
 
 {-
  NOTE on withWarnings and its dangers
@@ -59,24 +57,3 @@ withWarnings diagSource action = do
   res <- action $ \env -> putLogHook (newLogger env) env
   warns <- readVar warnings
   return (reverse $ concat warns, res)
-
-#if MIN_VERSION_ghc(9,3,0)
-attachReason :: Maybe DiagnosticReason -> Diagnostic -> Diagnostic
-attachReason Nothing d = d
-attachReason (Just wr) d = d{_code = InR <$> showReason wr}
- where
-  showReason = \case
-    WarningWithFlag flag -> showFlag flag
-    _                    -> Nothing
-#else
-attachReason :: WarnReason -> Diagnostic -> Diagnostic
-attachReason wr d = d{_code = InR <$> showReason wr}
- where
-  showReason = \case
-    NoReason       -> Nothing
-    Reason flag    -> showFlag flag
-    ErrReason flag -> showFlag =<< flag
-#endif
-
-showFlag :: WarningFlag -> Maybe T.Text
-showFlag flag = ("-W" <>) . T.pack . flagSpecName <$> find ((== flag) . flagSpecFlag) wWarningFlags

ghcide/src/Development/IDE/Types/Diagnostics.hs

@@ -19,18 +19,24 @@ module Development.IDE.Types.Diagnostics (
   ideErrorFromLspDiag,
   showDiagnostics,
   showDiagnosticsColored,
-  IdeResultNoDiagnosticsEarlyCutoff) where
+  IdeResultNoDiagnosticsEarlyCutoff,
+  attachReason,
+  attachedReason) where
 
 import           Control.DeepSeq
 import           Control.Lens
+import qualified Data.Aeson as JSON
+import qualified Data.Aeson.Lens as JSON
 import           Data.ByteString                (ByteString)
+import           Data.List
 import           Data.Maybe                     as Maybe
 import qualified Data.Text                      as T
-import           Development.IDE.GHC.Compat     (GhcMessage, MsgEnvelope)
+import           Development.IDE.GHC.Compat     (GhcMessage, MsgEnvelope, WarningFlag, wWarningFlags, flagSpecFlag, flagSpecName)
 import           Development.IDE.Types.Location
 import           GHC.Generics
-import           GHC.Types.Error                (diagnosticCode, DiagnosticCode (..), errMsgDiagnostic)
+import           GHC.Types.Error                (diagnosticCode, DiagnosticCode (..), errMsgDiagnostic, DiagnosticReason(..), diagnosticReason)
 import           Language.LSP.Diagnostics
+import           Language.LSP.Protocol.Lens     (data_)
 import           Language.LSP.Protocol.Types    as LSP
 import           Prettyprinter
 import           Prettyprinter.Render.Terminal  (Color (..), color)
@@ -69,7 +75,7 @@ ideErrorFromLspDiag lspDiag fdFilePath origMsg =
         case origMsg of
           Nothing -> NoStructuredMessage
           Just msg -> SomeStructuredMessage msg
-      fdLspDiagnostic = lspDiag
+      fdLspDiagnostic = (attachReason (fmap (diagnosticReason . errMsgDiagnostic) origMsg) lspDiag)
 #if MIN_VERSION_ghc(9,6,1)
         { _code = fmap ghcCodeToLspCode . diagnosticCode . errMsgDiagnostic =<< origMsg
         }
@@ -85,6 +91,30 @@ ideErrorFromLspDiag lspDiag fdFilePath origMsg =
   in
   FileDiagnostic {..}
 
+attachedReason :: Traversal' Diagnostic (Maybe JSON.Value)
+attachedReason = data_ . non (JSON.object []) . JSON.atKey "attachedReason"
+
+#if MIN_VERSION_ghc(9,3,0)
+attachReason :: Maybe DiagnosticReason -> Diagnostic -> Diagnostic
+attachReason Nothing = id
+attachReason (Just wr) = attachedReason .~ fmap JSON.toJSON (showReason wr)
+ where
+  showReason = \case
+    WarningWithFlag flag -> showFlag flag
+    _                    -> Nothing
+#else
+attachReason :: WarnReason -> Diagnostic -> Diagnostic
+attachReason wr = attachedReason .~ fmap JSON.toJSON (showReason wr)
+ where
+  showReason = \case
+    NoReason       -> Nothing
+    Reason flag    -> showFlag flag
+    ErrReason flag -> showFlag =<< flag
+#endif
+
+showFlag :: WarningFlag -> Maybe T.Text
+showFlag flag = ("-W" <>) . T.pack . flagSpecName <$> find ((== flag) . flagSpecFlag) wWarningFlags
+
 ideErrorWithSource
   :: Maybe T.Text
   -> Maybe DiagnosticSeverity

haskell-language-server.cabal

@@ -912,11 +912,13 @@ library hls-pragmas-plugin
   hs-source-dirs:   plugins/hls-pragmas-plugin/src
   build-depends:
     , base                  >=4.12 && <5
+    , aeson
     , extra
     , fuzzy
     , ghcide                == 2.9.0.1
     , hls-plugin-api        == 2.9.0.1
     , lens
+    , lens-aeson
     , lsp
     , text
     , transformers

plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs

@@ -15,6 +15,7 @@ module Ide.Plugin.Pragmas
   , AppearWhere(..)
   ) where
 
+import qualified Data.Aeson as JSON
 import           Control.Lens                             hiding (List)
 import           Control.Monad.IO.Class                   (MonadIO (liftIO))
 import           Data.Char                                (isAlphaNum)
@@ -120,8 +121,9 @@ suggest dflags diag =
 -- ---------------------------------------------------------------------
 
 suggestDisableWarning :: Diagnostic -> [PragmaEdit]
-suggestDisableWarning Diagnostic {_code}
-  | Just (LSP.InR (T.stripPrefix "-W" -> Just w)) <- _code
+suggestDisableWarning diagnostic
+  | Just (Just (JSON.String attachedReason)) <- diagnostic ^? attachedReason
+  , Just w <- T.stripPrefix "-W" attachedReason
   , w `notElem` warningBlacklist =
     pure ("Disable \"" <> w <> "\" warnings", OptGHC w)
   | otherwise = []