Change FileDiagnostic type synonym to a datatype

dylan-thinnes · dylan-thinnes · commit d5b70e0251e2 · 2024-06-10T16:31:16.000+01:00
diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs
@@ -599,7 +599,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do
                         this_target_details = TargetDetails (TargetFile _cfp) this_error_env this_dep_info [_cfp]
                         this_flags = (this_error_env, this_dep_info)
                         this_error_env = ([this_error], Nothing)
-                        this_error = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) _cfp
+                        this_error = uncurry (FileDiagnostic _cfp) $ ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error)
                                        $ T.unlines
                                        [ "No cradle target found. Is this file listed in the targets of your cradle?"
                                        , "If you are using a .cabal file, please ensure that this module is listed in either the exposed-modules or other-modules section"
@@ -923,7 +923,7 @@ newComponentCache recorder exts cradlePath _cfp hsc_env old_cis new_cis dir = do
 
 #if MIN_VERSION_ghc(9,3,0)
     let closure_errs = checkHomeUnitsClosed' (hsc_unit_env hscEnv') (hsc_all_home_unit_ids hscEnv')
-        multi_errs = map (ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Warning) _cfp . T.pack . Compat.printWithoutUniques) closure_errs
+        multi_errs = map (uncurry (FileDiagnostic _cfp) . ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Warning) . T.pack . Compat.printWithoutUniques) closure_errs
         bad_units = OS.fromList $ concat $ do
             x <- bagToList $ mapBag errMsgDiagnostic $ unionManyBags $ map Compat.getMessages closure_errs
             DriverHomePackagesNotClosed us <- pure x
@@ -1309,6 +1309,8 @@ showPackageSetupException PackageSetupException{..} = unwords
     , "failed to load packages:", message <> "."
     , "\nPlease ensure that ghcide is compiled with the same GHC installation as the project."]
 
-renderPackageSetupException :: FilePath -> PackageSetupException -> (NormalizedFilePath, ShowDiagnostic, Diagnostic)
+renderPackageSetupException :: FilePath -> PackageSetupException -> FileDiagnostic
 renderPackageSetupException fp e =
-    ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) (toNormalizedFilePath' fp) (T.pack $ showPackageSetupException e)
+  let (showDiag, lspDiag) = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) (T.pack $ showPackageSetupException e)
+  in
+  FileDiagnostic (toNormalizedFilePath' fp) showDiag lspDiag
diff --git a/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs b/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs
@@ -29,9 +29,11 @@ data CradleErrorDetails =
 renderCradleError :: CradleError -> Cradle a -> NormalizedFilePath -> FileDiagnostic
 renderCradleError (CradleError deps _ec ms) cradle nfp
   | HieBios.isCabalCradle cradle =
-      let (fp, showDiag, diag) = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp $ T.unlines $ map T.pack userFriendlyMessage in
-        (fp, showDiag, diag{_data_ = Just $ Aeson.toJSON CradleErrorDetails{cabalProjectFiles=absDeps}})
-  | otherwise = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp $ T.unlines $ map T.pack userFriendlyMessage
+      let (showDiag, diag) = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) $ T.unlines $ map T.pack userFriendlyMessage
+       in FileDiagnostic nfp showDiag diag{_data_ = Just $ Aeson.toJSON CradleErrorDetails{cabalProjectFiles=absDeps}}
+  | otherwise =
+      let (showDiag, diag) = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) $ T.unlines $ map T.pack userFriendlyMessage
+       in FileDiagnostic nfp showDiag diag
   where
     absDeps = fmap (cradleRootDir cradle </>) deps
     userFriendlyMessage :: [String]
diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs
@@ -739,20 +739,20 @@ unDefer (Reason Opt_WarnDeferredOutOfScopeVariables, fd) = (True, upgradeWarning
 unDefer ( _                                        , fd) = (False, fd)
 
 upgradeWarningToError :: FileDiagnostic -> FileDiagnostic
-upgradeWarningToError (nfp, sh, fd) =
-  (nfp, sh, fd{_severity = Just DiagnosticSeverity_Error, _message = warn2err $ _message fd}) where
+upgradeWarningToError fd =
+  modifyFdLspDiagnostic (\diag -> diag {_severity = Just DiagnosticSeverity_Error, _message = warn2err $ _message diag}) fd where
   warn2err :: T.Text -> T.Text
   warn2err = T.intercalate ": error:" . T.splitOn ": warning:"
 
 #if MIN_VERSION_ghc(9,3,0)
 hideDiag :: DynFlags -> (Maybe DiagnosticReason, FileDiagnostic) -> (Maybe DiagnosticReason, FileDiagnostic)
-hideDiag originalFlags (w@(Just (WarningWithFlag warning)), (nfp, _sh, fd))
+hideDiag originalFlags (w@(Just (WarningWithFlag warning)), fd)
 #else
 hideDiag :: DynFlags -> (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)
-hideDiag originalFlags (w@(Reason warning), (nfp, _sh, fd))
+hideDiag originalFlags (w@(Reason warning), fd)
 #endif
   | not (wopt warning originalFlags)
-  = (w, (nfp, HideDiag, fd))
+  = (w, fd { fdShouldShowDiagnostic = HideDiag })
 hideDiag _originalFlags t = t
 
 -- | Warnings which lead to a diagnostic tag
@@ -780,20 +780,20 @@ tagDiag :: (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)
 #endif
 
 #if MIN_VERSION_ghc(9,7,0)
-tagDiag (w@(Just (WarningWithCategory cat)), (nfp, sh, fd))
+tagDiag (w@(Just (WarningWithCategory cat)), fd)
   | cat == defaultWarningCategory -- default warning category is for deprecations
-  = (w, (nfp, sh, fd { _tags = Just $ DiagnosticTag_Deprecated : concat (_tags fd) }))
-tagDiag (w@(Just (WarningWithFlags warnings)), (nfp, sh, fd))
+  = (w, modifyFdLspDiagnostic (\diag -> diag { _tags = Just $ DiagnosticTag_Deprecated : concat (_tags diag) }) fd)
+tagDiag (w@(Just (WarningWithFlags warnings)), fd)
   | tags <- mapMaybe requiresTag (toList warnings)
-  = (w, (nfp, sh, fd { _tags = Just $ tags ++ concat (_tags fd) }))
+  = (w, modifyFdLspDiagnostic (\diag -> diag { _tags = Just $ tags ++ concat (_tags diag) }) fd)
 #elif MIN_VERSION_ghc(9,3,0)
-tagDiag (w@(Just (WarningWithFlag warning)), (nfp, sh, fd))
+tagDiag (w@(Just (WarningWithFlag warning)), fd)
   | Just tag <- requiresTag warning
-  = (w, (nfp, sh, fd { _tags = Just $ tag : concat (_tags fd) }))
+  = (w, modifyFdLspDiagnostic (\diag -> diag { _tags = Just $ tag : concat (_tags diag) }) fd)
 #else
-tagDiag (w@(Reason warning), (nfp, sh, fd))
+tagDiag (w@(Reason warning), fd)
   | Just tag <- requiresTag warning
-  = (w, (nfp, sh, fd { _tags = Just $ tag : concat (_tags fd) }))
+  = (w, modifyFdLspDiagnostic (\diag -> { _tags = Just $ tag : concat (_tags diag) }) fd)
 #endif
   where
     requiresTag :: WarningFlag -> Maybe DiagnosticTag
diff --git a/ghcide/src/Development/IDE/Core/Preprocessor.hs b/ghcide/src/Development/IDE/Core/Preprocessor.hs
@@ -112,7 +112,7 @@ data CPPDiag
 
 diagsFromCPPLogs :: FilePath -> [CPPLog] -> [FileDiagnostic]
 diagsFromCPPLogs filename logs =
-  map (\d -> (toNormalizedFilePath' filename, ShowDiag, cppDiagToDiagnostic d)) $
+  map (\d -> FileDiagnostic (toNormalizedFilePath' filename) ShowDiag (cppDiagToDiagnostic d)) $
     go [] logs
   where
     -- On errors, CPP calls logAction with a real span for the initial log and
diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs
@@ -501,7 +501,7 @@ reportImportCyclesRule recorder =
     where cycleErrorInFile f (PartOfCycle imp fs)
             | f `elem` fs = Just (imp, fs)
           cycleErrorInFile _ _ = Nothing
-          toDiag imp mods = (fp , ShowDiag , ) $ Diagnostic
+          toDiag imp mods = FileDiagnostic fp ShowDiag $ Diagnostic
             { _range = rng
             , _severity = Just DiagnosticSeverity_Error
             , _source = Just "Import cycle detection"
diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs
@@ -1192,7 +1192,7 @@ defineEarlyCutoff recorder (Rule op) = addRule $ \(Q (key, file)) (old :: Maybe
     extras <- getShakeExtras
     let diagnostics ver diags = do
             traceDiagnostics diags
-            updateFileDiagnostics recorder file ver (newKey key) extras . map (\(_,y,z) -> (y,z)) $ diags
+            updateFileDiagnostics recorder file ver (newKey key) extras diags
     defineEarlyCutoff' diagnostics (==) key file old mode $ const $ op key file
 defineEarlyCutoff recorder (RuleNoDiagnostics op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ \traceDiagnostics -> do
     let diagnostics _ver diags = do
@@ -1211,7 +1211,7 @@ defineEarlyCutoff recorder (RuleWithOldValue op) = addRule $ \(Q (key, file)) (o
     extras <- getShakeExtras
     let diagnostics ver diags = do
             traceDiagnostics diags
-            updateFileDiagnostics recorder file ver (newKey key) extras . map (\(_,y,z) -> (y,z)) $ diags
+            updateFileDiagnostics recorder file ver (newKey key) extras diags
     defineEarlyCutoff' diagnostics (==) key file old mode $ op key file
 
 defineNoFile :: IdeRule k v => Recorder (WithPriority Log) -> (k -> Action v) -> Rules ()
@@ -1347,34 +1347,34 @@ updateFileDiagnostics :: MonadIO m
   -> Maybe Int32
   -> Key
   -> ShakeExtras
-  -> [(ShowDiagnostic,Diagnostic)] -- ^ current results
+  -> [FileDiagnostic] -- ^ current results
   -> m ()
 updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, debouncer, lspEnv, ideTesting} current0 =
   liftIO $ withTrace ("update diagnostics " <> fromString(fromNormalizedFilePath fp)) $ \ addTag -> do
     addTag "key" (show k)
-    let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current
+    let (currentShown, currentHidden) = partition ((== ShowDiag) . fdShouldShowDiagnostic) current
         uri = filePathToUri' fp
         addTagUnsafe :: String -> String -> String -> a -> a
         addTagUnsafe msg t x v = unsafePerformIO(addTag (msg <> t) x) `seq` v
         update :: (forall a. String -> String -> a -> a) -> [Diagnostic] -> STMDiagnosticStore -> STM [Diagnostic]
         update addTagUnsafeMethod new store = addTagUnsafeMethod "count" (show $ Prelude.length new) $ setStageDiagnostics addTagUnsafeMethod uri ver (renderKey k) new store
-        current = second diagsFromRule <$> current0
+        current = map (modifyFdLspDiagnostic diagsFromRule) current0
     addTag "version" (show ver)
     mask_ $ do
         -- Mask async exceptions to ensure that updated diagnostics are always
         -- published. Otherwise, we might never publish certain diagnostics if
         -- an exception strikes between modifyVar but before
         -- publishDiagnosticsNotification.
-        newDiags <- liftIO $ atomicallyNamed "diagnostics - update" $ update (addTagUnsafe "shown ") (map snd currentShown) diagnostics
-        _ <- liftIO $ atomicallyNamed "diagnostics - hidden" $ update (addTagUnsafe "hidden ") (map snd currentHidden) hiddenDiagnostics
+        newDiags <- liftIO $ atomicallyNamed "diagnostics - update" $ update (addTagUnsafe "shown ") (map fdLspDiagnostic currentShown) diagnostics
+        _ <- liftIO $ atomicallyNamed "diagnostics - hidden" $ update (addTagUnsafe "hidden ") (map fdLspDiagnostic currentHidden) hiddenDiagnostics
         let uri' = filePathToUri' fp
         let delay = if null newDiags then 0.1 else 0
         registerEvent debouncer delay uri' $ withTrace ("report diagnostics " <> fromString (fromNormalizedFilePath fp)) $ \tag -> do
              join $ mask_ $ do
                  lastPublish <- atomicallyNamed "diagnostics - publish" $ STM.focus (Focus.lookupWithDefault [] <* Focus.insert newDiags) uri' publishedDiagnostics
                  let action = when (lastPublish /= newDiags) $ case lspEnv of
                         Nothing -> -- Print an LSP event.
-                            logWith recorder Info $ LogDiagsDiffButNoLspEnv (map (fp, ShowDiag,) newDiags)
+                            logWith recorder Info $ LogDiagsDiffButNoLspEnv (map (FileDiagnostic fp ShowDiag) newDiags)
                         Just env -> LSP.runLspT env $ do
                             liftIO $ tag "count" (show $ Prelude.length newDiags)
                             liftIO $ tag "key" (show k)
@@ -1442,7 +1442,7 @@ getAllDiagnostics ::
     STMDiagnosticStore ->
     STM [FileDiagnostic]
 getAllDiagnostics =
-    fmap (concatMap (\(k,v) -> map (fromUri k,ShowDiag,) $ getDiagnosticsFromStore v)) . ListT.toList . STM.listT
+    fmap (concatMap (\(k,v) -> map (FileDiagnostic (fromUri k) ShowDiag) $ getDiagnosticsFromStore v)) . ListT.toList . STM.listT
 
 updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> STM ()
 updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} changes =
diff --git a/ghcide/src/Development/IDE/GHC/Error.hs b/ghcide/src/Development/IDE/GHC/Error.hs
@@ -52,17 +52,22 @@ import           Language.LSP.VFS                  (CodePointPosition (CodePoint
 
 
 diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic
-diagFromText diagSource sev loc msg = (toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename loc,ShowDiag,)
-    Diagnostic
-    { _range    = fromMaybe noRange $ srcSpanToRange loc
-    , _severity = Just sev
-    , _source   = Just diagSource -- not shown in the IDE, but useful for ghcide developers
-    , _message  = msg
-    , _code     = Nothing
-    , _relatedInformation = Nothing
-    , _tags     = Nothing
-    , _codeDescription = Nothing
-    , _data_   = Nothing
+diagFromText diagSource sev loc msg =
+  FileDiagnostic
+    { fdFilePath = toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename loc
+    , fdShouldShowDiagnostic = ShowDiag
+    , fdLspDiagnostic =
+        Diagnostic
+        { _range    = fromMaybe noRange $ srcSpanToRange loc
+        , _severity = Just sev
+        , _source   = Just diagSource -- not shown in the IDE, but useful for ghcide developers
+        , _message  = msg
+        , _code     = Nothing
+        , _relatedInformation = Nothing
+        , _tags     = Nothing
+        , _codeDescription = Nothing
+        , _data_   = Nothing
+        }
     }
 
 -- | Produce a GHC-style error from a source span and a message.
diff --git a/ghcide/src/Development/IDE/GHC/Warnings.hs b/ghcide/src/Development/IDE/GHC/Warnings.hs
@@ -33,15 +33,12 @@ withWarnings diagSource action = do
   warnings <- newVar []
   let newAction :: DynFlags -> LogActionCompat
       newAction dynFlags logFlags wr _ loc prUnqual msg = do
-        let wr_d = map ((wr,) . third3 (attachReason wr)) $ diagFromErrMsg diagSource dynFlags $ mkWarnMsg dynFlags wr logFlags loc prUnqual msg
+        let wr_d = map ((wr,) . modifyFdLspDiagnostic (attachReason wr)) $ diagFromErrMsg 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
   warns <- readVar warnings
   return (reverse $ concat warns, res)
-  where
-    third3 :: (c -> d) -> (a, b, c) -> (a, b, d)
-    third3 f (a, b, c) = (a, b, f c)
 
 #if MIN_VERSION_ghc(9,3,0)
 attachReason :: Maybe DiagnosticReason -> Diagnostic -> Diagnostic
diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs
@@ -30,7 +30,7 @@ import           Development.IDE                      (GhcSession (..),
                                                        HscEnvEq (hscEnv),
                                                        RuleResult, Rules, Uri,
                                                        define, srcSpanToRange,
-                                                       usePropertyAction)
+                                                       usePropertyAction, FileDiagnostic (..))
 import           Development.IDE.Core.Compile         (TcModuleResult (..))
 import           Development.IDE.Core.PluginUtils
 import           Development.IDE.Core.PositionMapping (PositionMapping,
@@ -126,7 +126,7 @@ codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentif
           -- We don't actually pass any data to resolve, however we need this
           -- dummy type to make sure HLS resolves our lens
           [ CodeLens _range Nothing (Just $ toJSON TypeLensesResolve)
-            | (dFile, _, diag@Diagnostic{_range}) <- diags
+            | FileDiagnostic dFile _ diag@Diagnostic{_range} <- diags
             , dFile == nfp
             , isGlobalDiagnostic diag]
         -- The second option is to generate lenses from the GlobalBindingTypeSig
diff --git a/ghcide/src/Development/IDE/Types/Diagnostics.hs b/ghcide/src/Development/IDE/Types/Diagnostics.hs
@@ -1,11 +1,13 @@
 -- Copyright (c) 2019 The DAML Authors. All rights reserved.
 -- SPDX-License-Identifier: Apache-2.0
 
+{-# LANGUAGE DeriveGeneric #-}
 
 module Development.IDE.Types.Diagnostics (
   LSP.Diagnostic(..),
   ShowDiagnostic(..),
-  FileDiagnostic,
+  FileDiagnostic(..),
+  modifyFdLspDiagnostic,
   IdeResult,
   LSP.DiagnosticSeverity(..),
   DiagnosticStore,
@@ -20,6 +22,7 @@ import           Data.ByteString                (ByteString)
 import           Data.Maybe                     as Maybe
 import qualified Data.Text                      as T
 import           Development.IDE.Types.Location
+import           GHC.Generics
 import           Language.LSP.Diagnostics
 import           Language.LSP.Protocol.Types    as LSP (Diagnostic (..),
                                                         DiagnosticSeverity (..))
@@ -45,15 +48,18 @@ type IdeResult v = ([FileDiagnostic], Maybe v)
 type IdeResultNoDiagnosticsEarlyCutoff  v = (Maybe ByteString, Maybe v)
 
 ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic
-ideErrorText = ideErrorWithSource (Just "compiler") (Just DiagnosticSeverity_Error)
+ideErrorText fdFilePath msg =
+  let (fdShouldShowDiagnostic, fdLspDiagnostic) =
+        ideErrorWithSource (Just "compiler") (Just DiagnosticSeverity_Error) msg
+  in
+  FileDiagnostic{..}
 
 ideErrorWithSource
   :: Maybe T.Text
   -> Maybe DiagnosticSeverity
-  -> a
   -> T.Text
-  -> (a, ShowDiagnostic, Diagnostic)
-ideErrorWithSource source sev fp msg = (fp, ShowDiag, LSP.Diagnostic {
+  -> (ShowDiagnostic, Diagnostic)
+ideErrorWithSource source sev msg = (ShowDiag, LSP.Diagnostic {
     _range = noRange,
     _severity = sev,
     _code = Nothing,
@@ -86,7 +92,18 @@ instance NFData ShowDiagnostic where
 --   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.
 --
-type FileDiagnostic = (NormalizedFilePath, ShowDiagnostic, Diagnostic)
+data FileDiagnostic = FileDiagnostic
+  { fdFilePath :: NormalizedFilePath
+  , fdShouldShowDiagnostic :: ShowDiagnostic
+  , fdLspDiagnostic :: Diagnostic
+  }
+  deriving (Eq, Ord, Show, Generic)
+
+instance NFData FileDiagnostic
+
+modifyFdLspDiagnostic :: (Diagnostic -> Diagnostic) -> FileDiagnostic -> FileDiagnostic
+modifyFdLspDiagnostic f diag =
+  diag { fdLspDiagnostic = f (fdLspDiagnostic diag) }
 
 prettyRange :: Range -> Doc Terminal.AnsiStyle
 prettyRange Range{..} = f _start <> "-" <> f _end
@@ -106,10 +123,10 @@ prettyDiagnostics :: [FileDiagnostic] -> Doc Terminal.AnsiStyle
 prettyDiagnostics = vcat . map prettyDiagnostic
 
 prettyDiagnostic :: FileDiagnostic -> Doc Terminal.AnsiStyle
-prettyDiagnostic (fp, sh, LSP.Diagnostic{..}) =
+prettyDiagnostic FileDiagnostic { fdFilePath, fdShouldShowDiagnostic, fdLspDiagnostic = LSP.Diagnostic{..} } =
     vcat
-        [ slabel_ "File:    " $ pretty (fromNormalizedFilePath fp)
-        , slabel_ "Hidden:  " $ if sh == ShowDiag then "no" else "yes"
+        [ slabel_ "File:    " $ pretty (fromNormalizedFilePath fdFilePath)
+        , slabel_ "Hidden:  " $ if fdShouldShowDiagnostic == ShowDiag then "no" else "yes"
         , slabel_ "Range:   " $ prettyRange _range
         , slabel_ "Source:  " $ pretty _source
         , slabel_ "Severity:" $ pretty $ show sev
