Support structured diagnostics

ghcide-bench/src/Experiments.hs

@@ -266,7 +266,7 @@ experiments =
             flip allM docs $ \DocumentPositions{..} -> do
                 bottom <- pred . length . T.lines <$> documentContents doc
                 diags <- getCurrentDiagnostics doc
-                case requireDiagnostic diags (DiagnosticSeverity_Error, (fromIntegral bottom, 8), "Found hole", Nothing) of
+                case requireDiagnostic diags (DiagnosticSeverity_Error, (fromIntegral bottom, 8), "Found hole", Just "88464", Nothing) of
                     Nothing   -> pure True
                     Just _err -> pure False
         ),

ghcide/ghcide.cabal

@@ -83,8 +83,10 @@ library
     , hiedb                        ^>= 0.6.0.0
     , hls-graph                    == 2.9.0.0
     , hls-plugin-api               == 2.9.0.0
+    , http-conduit
     , implicit-hie                 >= 0.1.4.0 && < 0.1.5
     , lens
+    , lens-aeson
     , list-t
     , lsp                          ^>=2.7
     , lsp-types                    ^>=2.3
@@ -134,6 +136,7 @@ library
     Development.IDE.Core.Debouncer
     Development.IDE.Core.FileStore
     Development.IDE.Core.FileUtils
+    Development.IDE.Core.HaskellErrorIndex
     Development.IDE.Core.IdeConfiguration
     Development.IDE.Core.OfInterest
     Development.IDE.Core.PluginUtils
@@ -150,6 +153,7 @@ library
     Development.IDE.GHC.Compat
     Development.IDE.GHC.Compat.Core
     Development.IDE.GHC.Compat.CmdLine
+    Development.IDE.GHC.Compat.Driver
     Development.IDE.GHC.Compat.Env
     Development.IDE.GHC.Compat.Iface
     Development.IDE.GHC.Compat.Logger

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

@@ -578,10 +578,11 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do
                         this_flags = (this_error_env, this_dep_info)
                         this_error_env = ([this_error], Nothing)
                         this_error = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) _cfp
-                                       $ 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"
-                                       ]
+                                       (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"
+                                         ])
+                                       Nothing
 
           void $ modifyVar' fileToFlags $ Map.insert hieYaml this_flags_map
           void $ modifyVar' filesMap $ flip HM.union (HM.fromList (map ((,hieYaml) . fst) $ concatMap toFlagsMap all_targets))
@@ -802,10 +803,10 @@ setNameCache nc hsc = hsc { hsc_NC = nc }
 -- GHC had an implementation of this function, but it was horribly inefficient
 -- We should move back to the GHC implementation on compilers where
 -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/12162 is included
-checkHomeUnitsClosed' ::  UnitEnv -> OS.Set UnitId -> [DriverMessages]
+checkHomeUnitsClosed' ::  UnitEnv -> OS.Set UnitId -> Maybe (Compat.MsgEnvelope DriverMessage)
 checkHomeUnitsClosed' ue home_id_set
-    | OS.null bad_unit_ids = []
-    | otherwise = [singleMessage $ GHC.mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (OS.toList bad_unit_ids)]
+    | OS.null bad_unit_ids = Nothing
+    | otherwise = Just (GHC.mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (OS.toList bad_unit_ids))
   where
     bad_unit_ids = upwards_closure OS.\\ home_id_set
     rootLoc = mkGeneralSrcSpan (Compat.fsLit "<command line>")
@@ -880,10 +881,19 @@ newComponentCache recorder exts _cfp hsc_env old_cis new_cis = do
     hscEnv' <- -- Set up a multi component session with the other units on GHC 9.4
               Compat.initUnits dfs hsc_env
 
-    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
+    let closure_errs = maybeToList $ checkHomeUnitsClosed' (hsc_unit_env hscEnv') (hsc_all_home_unit_ids hscEnv')
+        closure_err_to_multi_err err =
+            ideErrorWithSource
+                (Just "cradle") (Just DiagnosticSeverity_Warning) _cfp
+                (T.pack (Compat.printWithoutUniques (singleMessage err)))
+#if MIN_VERSION_ghc(9,6,1)
+                (Just (fmap GhcDriverMessage err))
+#else
+                Nothing
+#endif
+        multi_errs = map closure_err_to_multi_err closure_errs
         bad_units = OS.fromList $ concat $ do
-            x <- bagToList $ mapBag errMsgDiagnostic $ unionManyBags $ map Compat.getMessages closure_errs
+            x <- map errMsgDiagnostic closure_errs
             DriverHomePackagesNotClosed us <- pure x
             pure us
         isBad ci = (homeUnitId_ (componentDynFlags ci)) `OS.member` bad_units
@@ -1232,6 +1242,6 @@ 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)
+  ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) (toNormalizedFilePath' fp) (T.pack $ showPackageSetupException e) Nothing

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
@@ -27,11 +28,13 @@ data CradleErrorDetails =
   Depicts the cradle error in a user-friendly way.
 -}
 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
+renderCradleError (CradleError deps _ec ms) cradle nfp =
+  let noDetails =
+        ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp (T.unlines $ map T.pack userFriendlyMessage) Nothing
+  in
+  if HieBios.isCabalCradle cradle
+     then noDetails & fdLspDiagnosticL %~ \diag -> diag{_data_ = Just $ Aeson.toJSON CradleErrorDetails{cabalProjectFiles=absDeps}}
+     else noDetails
   where
     absDeps = fmap (cradleRootDir cradle </>) deps
     userFriendlyMessage :: [String]