Support structured diagnostics 2

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.1
     , hls-plugin-api               == 2.9.0.1
+    , 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

@@ -573,10 +573,11 @@
                         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))
@@ -633,7 +634,7 @@
                  [] -> error $ "GHC version could not be parsed: " <> version
                  ((runTime, _):_)
                    | compileTime == runTime -> do
                      atomicModifyIORef' cradle_files (\xs -> (cfp:xs,()))
                      session (hieYaml, toNormalizedFilePath' cfp, opts, libDir)
                    | otherwise -> return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[])
              -- Failure case, either a cradle error or the none cradle
@@ -797,10 +798,10 @@
 -- 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>")
@@ -875,13 +876,22 @@
     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
     -- Whenever we spin up a session on Linux, dynamically load libm.so.6
     -- in. We need this in case the binary is statically linked, in which
     -- case the interactive session will fail when trying to load
@@ -1223,6 +1233,6 @@
     , "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

@@ -1,7 +1,8 @@
 {-# LANGUAGE DeriveAnyClass #-}
 
 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 @@
   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]
@@ -84,7 +87,7 @@
     surround start s end = do
       guard (listToMaybe s == Just start)
       guard (listToMaybe (reverse s) == Just end)
       pure $ drop 1 $ take (length s - 1) s
 
 multiCradleErrMessage :: MultiCradleErr -> [String]
 multiCradleErrMessage e =