Doc StructuredMessage, modifyFdLspDiagnostic -> fdLspDiagnosticL

Author: dylan-thinnes

ghcide/session-loader/Development/IDE/Session/Diagnostics.hs

@@ -2,6 +2,7 @@
 
 module Development.IDE.Session.Diagnostics where
 import           Control.Applicative
+import           Control.Lens
 import           Control.Monad
 import qualified Data.Aeson                        as Aeson
 import           Data.List
@@ -32,7 +33,7 @@ renderCradleError (CradleError deps _ec ms) cradle nfp =
         ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp (T.unlines $ map T.pack userFriendlyMessage) Nothing
   in
   if HieBios.isCabalCradle cradle
-     then flip modifyFdLspDiagnostic noDetails $ \diag -> diag{_data_ = Just $ Aeson.toJSON CradleErrorDetails{cabalProjectFiles=absDeps}}
+     then noDetails & fdLspDiagnosticL %~ \diag -> diag{_data_ = Just $ Aeson.toJSON CradleErrorDetails{cabalProjectFiles=absDeps}}
      else noDetails
   where
     absDeps = fmap (cradleRootDir cradle </>) deps

ghcide/src/Development/IDE/Core/Compile.hs

@@ -751,8 +751,9 @@ unDefer (Reason Opt_WarnDeferredOutOfScopeVariables, fd) = (True, upgradeWarning
 unDefer ( _                                        , fd) = (False, fd)
 
 upgradeWarningToError :: FileDiagnostic -> FileDiagnostic
-upgradeWarningToError fd =
-  modifyFdLspDiagnostic (\diag -> diag {_severity = Just DiagnosticSeverity_Error, _message = warn2err $ _message diag}) fd where
+upgradeWarningToError =
+  fdLspDiagnosticL %~ \diag -> diag {_severity = Just DiagnosticSeverity_Error, _message = warn2err $ _message diag}
+  where
   warn2err :: T.Text -> T.Text
   warn2err = T.intercalate ": error:" . T.splitOn ": warning:"
 
@@ -794,18 +795,18 @@ tagDiag :: (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)
 #if MIN_VERSION_ghc(9,7,0)
 tagDiag (w@(Just (WarningWithCategory cat)), fd)
   | cat == defaultWarningCategory -- default warning category is for deprecations
-  = (w, modifyFdLspDiagnostic (\diag -> diag { _tags = Just $ DiagnosticTag_Deprecated : concat (_tags diag) }) fd)
+  = (w, fd & fdLspDiagnosticL %~ \diag -> diag { _tags = Just $ DiagnosticTag_Deprecated : concat (_tags diag) })
 tagDiag (w@(Just (WarningWithFlags warnings)), fd)
   | tags <- mapMaybe requiresTag (toList warnings)
-  = (w, modifyFdLspDiagnostic (\diag -> diag { _tags = Just $ tags ++ concat (_tags diag) }) fd)
+  = (w, fd & fdLspDiagnosticL %~ \diag -> diag { _tags = Just $ tags ++ concat (_tags diag) })
 #elif MIN_VERSION_ghc(9,3,0)
 tagDiag (w@(Just (WarningWithFlag warning)), fd)
   | Just tag <- requiresTag warning
-  = (w, modifyFdLspDiagnostic (\diag -> diag { _tags = Just $ tag : concat (_tags diag) }) fd)
+  = (w, fd & fdLspDiagnosticL %~ \diag -> diag { _tags = Just $ tag : concat (_tags diag) })
 #else
 tagDiag (w@(Reason warning), fd)
   | Just tag <- requiresTag warning
-  = (w, modifyFdLspDiagnostic (\diag -> { _tags = Just $ tag : concat (_tags diag) }) fd)
+  = (w, fd & fdLspDiagnosticL %~ \diag -> { _tags = Just $ tag : concat (_tags diag) })
 #endif
   where
     requiresTag :: WarningFlag -> Maybe DiagnosticTag

ghcide/src/Development/IDE/Core/Rules.hs

@@ -64,6 +64,7 @@ import           Control.Concurrent.Strict
 import           Control.DeepSeq
 import           Control.Exception                            (evaluate)
 import           Control.Exception.Safe
+import           Control.Lens                                 ((%~), (&))
 import           Control.Monad.Extra
 import           Control.Monad.IO.Unlift
 import           Control.Monad.Reader
@@ -502,8 +503,8 @@ reportImportCyclesRule recorder =
             | f `elem` fs = Just (imp, fs)
           cycleErrorInFile _ _ = Nothing
           toDiag imp mods =
-            modifyFdLspDiagnostic (\lspDiag -> lspDiag { _range = rng })
-              $ ideErrorWithSource (Just "Import cycle detection") (Just DiagnosticSeverity_Error) fp ("Cyclic module dependency between " <> showCycle mods) Nothing
+            ideErrorWithSource (Just "Import cycle detection") (Just DiagnosticSeverity_Error) fp ("Cyclic module dependency between " <> showCycle mods) Nothing
+              & fdLspDiagnosticL %~ \lspDiag -> (lspDiag { _range = rng } :: Diagnostic)
             where rng = fromMaybe noRange $ srcSpanToRange (getLoc imp)
                   fp = toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename (getLoc imp)
           getModuleName file = do

ghcide/src/Development/IDE/Core/Shake.hs

@@ -82,7 +82,7 @@ import           Control.Concurrent.STM.Stats           (atomicallyNamed)
 import           Control.Concurrent.Strict
 import           Control.DeepSeq
 import           Control.Exception.Extra                hiding (bracket_)
-import           Control.Lens                           ((&), (?~))
+import           Control.Lens                           ((&), (?~), (%~))
 import           Control.Monad.Extra
 import           Control.Monad.IO.Class
 import           Control.Monad.Reader
@@ -1357,7 +1357,7 @@ updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnosti
         addTagUnsafe msg t x v = unsafePerformIO(addTag (msg <> t) x) `seq` v
         update :: (forall a. String -> String -> a -> a) -> [FileDiagnostic] -> STMDiagnosticStore -> STM [FileDiagnostic]
         update addTagUnsafeMethod new store = addTagUnsafeMethod "count" (show $ Prelude.length new) $ setStageDiagnostics addTagUnsafeMethod uri ver (renderKey k) new store
-        current = map (modifyFdLspDiagnostic diagsFromRule) current0
+        current = map (fdLspDiagnosticL %~ diagsFromRule) current0
     addTag "version" (show ver)
     mask_ $ do
         -- Mask async exceptions to ensure that updated diagnostics are always

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

@@ -36,6 +36,7 @@ module Development.IDE.GHC.Error
   , toDSeverity
   ) where
 
+import           Control.Lens
 import           Data.Maybe
 import           Data.String                       (fromString)
 import qualified Data.Text                         as T
@@ -57,11 +58,11 @@ import           Language.LSP.VFS                  (CodePointPosition (CodePoint
 
 diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> Maybe (MsgEnvelope GhcMessage) -> FileDiagnostic
 diagFromText diagSource sev loc msg origMsg =
-  modifyFdLspDiagnostic (\diag -> diag { D._range = fromMaybe noRange $ srcSpanToRange loc }) $
-    D.ideErrorWithSource
-      (Just diagSource) (Just sev)
-      (toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename loc)
-      msg origMsg
+  D.ideErrorWithSource
+    (Just diagSource) (Just sev)
+    (toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename loc)
+    msg origMsg
+    & fdLspDiagnosticL %~ \diag -> diag { D._range = fromMaybe noRange $ srcSpanToRange loc }
 
 -- | Produce a GHC-style error from a source span and a message.
 diagFromErrMsg :: T.Text -> DynFlags -> MsgEnvelope GhcMessage -> [FileDiagnostic]

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

@@ -6,6 +6,7 @@
 module Development.IDE.GHC.Warnings(withWarnings) where
 
 import           Control.Concurrent.Strict
+import           Control.Lens (over)
 import           Data.List
 import qualified Data.Text                         as T
 
@@ -33,7 +34,7 @@ withWarnings diagSource action = do
   warnings <- newVar []
   let newAction :: DynFlags -> LogActionCompat
       newAction dynFlags logFlags wr _ loc prUnqual msg = do
-        let wr_d = map ((wr,) . modifyFdLspDiagnostic (attachReason wr)) $ diagFromSDocErrMsg diagSource dynFlags (mkWarnMsg dynFlags wr logFlags loc prUnqual msg)
+        let wr_d = map ((wr,) . over fdLspDiagnosticL (attachReason wr)) $ diagFromSDocErrMsg diagSource dynFlags (mkWarnMsg dynFlags wr logFlags loc prUnqual msg)
         modifyVar_ warnings $ return . (wr_d:)
       newLogger env = pushLogHook (const (logActionCompat (newAction (hsc_dflags env)))) (hsc_logger env)
   res <- action $ \env -> putLogHook (newLogger env) env

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

@@ -2,17 +2,14 @@
 -- SPDX-License-Identifier: Apache-2.0
 
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE CPP #-}
 
 module Development.IDE.Types.Diagnostics (
   LSP.Diagnostic(..),
   ShowDiagnostic(..),
   FileDiagnostic(..),
-  fdFilePath,
-  fdShouldShowDiagnostic,
-  fdLspDiagnostic,
-  fdStructuredMessage,
-  modifyFdLspDiagnostic,
+  fdLspDiagnosticL,
   StructuredMessage(..),
   IdeResult,
   LSP.DiagnosticSeverity(..),
@@ -25,6 +22,7 @@ module Development.IDE.Types.Diagnostics (
   IdeResultNoDiagnosticsEarlyCutoff) where
 
 import           Control.DeepSeq
+import           Control.Lens
 import           Data.ByteString                (ByteString)
 import           Data.Maybe                     as Maybe
 import qualified Data.Text                      as T
@@ -68,14 +66,20 @@ ideErrorFromLspDiag
 ideErrorFromLspDiag lspDiag fdFilePath origMsg =
   let fdShouldShowDiagnostic = ShowDiag
       fdStructuredMessage =
-        maybe NoStructuredMessage SomeStructuredMessage origMsg
+        case origMsg of
+          Nothing -> NoStructuredMessage
+          Just msg -> SomeStructuredMessage msg
       fdLspDiagnostic = lspDiag
+#if MIN_VERSION_ghc(9,6,1)
         { _code = fmap ghcCodeToLspCode . diagnosticCode . errMsgDiagnostic =<< origMsg
         }
+#endif
+#if MIN_VERSION_ghc(9,8,1)
       ghcCodeToLspCode :: DiagnosticCode -> Int32 LSP.|? T.Text
-#if MIN_VERSION_ghc(9,10,1)
       ghcCodeToLspCode = InR . T.pack . show
-#else
+#elif MIN_VERSION_ghc(9,6,1)
+      -- DiagnosticCode only got a show instance in 9.8.1
+      ghcCodeToLspCode :: DiagnosticCode -> Int32 LSP.|? T.Text
       ghcCodeToLspCode (DiagnosticCode prefix c) = InR $ T.pack $ prefix ++ "-" ++ printf "%05d" c
 #endif
   in
@@ -119,22 +123,9 @@ data ShowDiagnostic
 instance NFData ShowDiagnostic where
     rnf = rwhnf
 
--- | Human readable diagnostics for a specific file.
---
---   This type packages a pretty printed, human readable error message
---   along with the related source location so that we can display the error
---   on either the console or in the IDE at the right source location.
---
-data FileDiagnostic = FileDiagnostic
-  { fdFilePath :: NormalizedFilePath
-  , fdShouldShowDiagnostic :: ShowDiagnostic
-  , fdLspDiagnostic :: Diagnostic
-  , fdStructuredMessage :: StructuredMessage
-  }
-  deriving (Eq, Ord, Show, Generic)
-
-instance NFData FileDiagnostic
-
+-- | A Maybe-like wrapper for a GhcMessage that doesn't try to compare, show, or
+-- force the GhcMessage inside, so that we can derive Show, Eq, Ord, NFData on
+-- FileDiagnostic
 data StructuredMessage
   = NoStructuredMessage
   | SomeStructuredMessage (MsgEnvelope GhcMessage)
@@ -159,9 +150,25 @@ instance NFData StructuredMessage where
   rnf NoStructuredMessage = ()
   rnf SomeStructuredMessage {} = ()
 
-modifyFdLspDiagnostic :: (Diagnostic -> Diagnostic) -> FileDiagnostic -> FileDiagnostic
-modifyFdLspDiagnostic f diag =
-  diag { fdLspDiagnostic = f (fdLspDiagnostic diag) }
+-- | Human readable diagnostics for a specific file.
+--
+--   This type packages a pretty printed, human readable error message
+--   along with the related source location so that we can display the error
+--   on either the console or in the IDE at the right source location.
+--
+data FileDiagnostic = FileDiagnostic
+  { fdFilePath :: NormalizedFilePath
+  , fdShouldShowDiagnostic :: ShowDiagnostic
+  , fdLspDiagnostic :: Diagnostic
+  , fdStructuredMessage :: StructuredMessage
+  }
+  deriving (Eq, Ord, Show, Generic)
+
+instance NFData FileDiagnostic
+
+makeLensesWith
+    (lensRules & lensField .~ mappingNamer (pure . (++ "L")))
+    ''FileDiagnostic
 
 prettyRange :: Range -> Doc Terminal.AnsiStyle
 prettyRange Range{..} = f _start <> "-" <> f _end