haskell
diff --git a/‎ghcide-bench/src/Experiments.hs
+1-1 b/‎ghcide-bench/src/Experiments.hs
+1-1
diff --git a/‎ghcide/ghcide.cabal
+3 b/‎ghcide/ghcide.cabal
+3
diff --git a/‎ghcide/session-loader/Development/IDE/Session.hs
+22-12 b/‎ghcide/session-loader/Development/IDE/Session.hs
+22-12
diff --git a/‎ghcide/session-loader/Development/IDE/Session/Diagnostics.hs
+8-5 b/‎ghcide/session-loader/Development/IDE/Session/Diagnostics.hs
+8-5
diff --git a/‎ghcide/src/Development/IDE/Core/Compile.hs
+82-46 b/‎ghcide/src/Development/IDE/Core/Compile.hs
+82-46
@@ -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 "GHC-88464", Nothing) of
                     Nothing   -> pure True
                     Just _err -> pure False
         ),
 
@@ -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
@@ -150,7 +151,9 @@ 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.Error
     Development.IDE.GHC.Compat.Iface
     Development.IDE.GHC.Compat.Logger
     Development.IDE.GHC.Compat.Outputable
 
@@ -573,10 +573,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))
@@ -797,10 +798,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>")
@@ -875,10 +876,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,5,0)
+                (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
@@ -1223,6 +1233,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
@@ -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]
 
@@ -111,6 +111,7 @@ import qualified Data.Set                               as Set
 import qualified GHC                                    as G
 import qualified GHC.Runtime.Loader                as Loader
 import           GHC.Tc.Gen.Splice
+import           GHC.Types.Error
 import           GHC.Types.ForeignStubs
 import           GHC.Types.HpcInfo
 import           GHC.Types.TypeEnv
@@ -130,6 +131,8 @@ import           GHC.Unit.Module.Warnings
 import           Development.IDE.Core.FileStore         (shareFilePath)
 #endif
 
+import           Development.IDE.GHC.Compat.Driver (hscTypecheckRenameWithDiagnostics)
+
 --Simple constants to make sure the source is consistently named
 sourceTypecheck :: T.Text
 sourceTypecheck = "typecheck"
@@ -157,8 +160,12 @@ computePackageDeps
     -> IO (Either [FileDiagnostic] [UnitId])
 computePackageDeps env pkg = do
     case lookupUnit env pkg of
-        Nothing -> return $ Left [ideErrorText (toNormalizedFilePath' noFilePath) $
-            T.pack $ "unknown package: " ++ show pkg]
+        Nothing ->
+          return $ Left
+            [ ideErrorText
+                (toNormalizedFilePath' noFilePath)
+                (T.pack $ "unknown package: " ++ show pkg)
+            ]
         Just pkgInfo -> return $ Right $ unitDepends pkgInfo
 
 newtype TypecheckHelpers
@@ -179,20 +186,24 @@ typecheckModule (IdeDefer defer) hsc tc_helpers pm = do
         case initialized of
           Left errs -> return (errs, Nothing)
           Right hscEnv -> do
-            (warnings, etcm) <- withWarnings sourceTypecheck $ \tweak ->
+            etcm <-
                 let
-                  session = tweak (hscSetFlags dflags hscEnv)
-                   -- TODO: maybe settings ms_hspp_opts is unnecessary?
-                  mod_summary'' = modSummary { ms_hspp_opts = hsc_dflags session}
+                   -- TODO: maybe setting ms_hspp_opts is unnecessary?
+                  mod_summary' = modSummary { ms_hspp_opts = hsc_dflags hscEnv}
                 in
                   catchSrcErrors (hsc_dflags hscEnv) sourceTypecheck $ do
-                    tcRnModule session tc_helpers $ demoteIfDefer pm{pm_mod_summary = mod_summary''}
-            let errorPipeline = unDefer . hideDiag dflags . tagDiag
-                diags = map errorPipeline warnings
-                deferredError = any fst diags
+                    tcRnModule hscEnv tc_helpers $ demoteIfDefer pm{pm_mod_summary = mod_summary'}
             case etcm of
-              Left errs -> return (map snd diags ++ errs, Nothing)
-              Right tcm -> return (map snd diags, Just $ tcm{tmrDeferredError = deferredError})
+              Left errs -> return (errs, Nothing)
+              Right tcm ->
+                let addReason diag =
+                      map (Just (diagnosticReason (errMsgDiagnostic diag)),) $
+                        diagFromErrMsg sourceTypecheck (hsc_dflags hscEnv) diag
+                    errorPipeline = map (unDefer . hideDiag dflags . tagDiag) . addReason
+                    diags = concatMap errorPipeline $ Compat.getMessages $ tmrWarnings tcm
+                    deferredError = any fst diags
+                in
+                return (map snd diags, Just $ tcm{tmrDeferredError = deferredError})
     where
         demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id
 
@@ -358,9 +369,9 @@ tcRnModule hsc_env tc_helpers pmod = do
   let ms = pm_mod_summary pmod
       hsc_env_tmp = hscSetFlags (ms_hspp_opts ms) hsc_env
 
-  ((tc_gbl_env', mrn_info), splices, mod_env)
+  (((tc_gbl_env', mrn_info), warning_messages), splices, mod_env)
       <- captureSplicesAndDeps tc_helpers hsc_env_tmp $ \hscEnvTmp ->
-             do  hscTypecheckRename hscEnvTmp ms $
+             do  hscTypecheckRenameWithDiagnostics hscEnvTmp ms $
                           HsParsedModule { hpm_module = parsedSource pmod
                                          , hpm_src_files = pm_extra_src_files pmod
                                          }
@@ -372,7 +383,7 @@ tcRnModule hsc_env tc_helpers pmod = do
       mod_env_anns = map (\(mod, hash) -> Annotation (ModuleTarget mod) $ toSerialized BS.unpack hash)
                          (moduleEnvToList mod_env)
       tc_gbl_env = tc_gbl_env' { tcg_ann_env = extendAnnEnvList (tcg_ann_env tc_gbl_env') mod_env_anns }
-  pure (TcModuleResult pmod rn_info tc_gbl_env splices False mod_env)
+  pure (TcModuleResult pmod rn_info tc_gbl_env splices False mod_env warning_messages)
 
 
 -- Note [Clearing mi_globals after generating an iface]
@@ -535,8 +546,14 @@ mkHiFileResultCompile se session' tcm simplified_guts = catchErrs $ do
     source = "compile"
     catchErrs x = x `catches`
       [ Handler $ return . (,Nothing) . diagFromGhcException source dflags
-      , Handler $ return . (,Nothing) . diagFromString source DiagnosticSeverity_Error (noSpan "<internal>")
-      . (("Error during " ++ T.unpack source) ++) . show @SomeException
+      , Handler $ \diag ->
+          return
+            ( diagFromString
+                source DiagnosticSeverity_Error (noSpan "<internal>")
+                ("Error during " ++ T.unpack source ++ show @SomeException diag)
+                Nothing
+            , Nothing
+            )
       ]
 
 -- | Whether we should run the -O0 simplifier when generating core.
@@ -660,15 +677,16 @@ unDefer (Just (WarningWithFlag Opt_WarnDeferredOutOfScopeVariables), fd) = (True
 unDefer ( _                                        , fd) = (False, fd)
 
 upgradeWarningToError :: FileDiagnostic -> FileDiagnostic
-upgradeWarningToError (nfp, sh, fd) =
-  (nfp, sh, fd{_severity = Just DiagnosticSeverity_Error, _message = warn2err $ _message 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:"
 
 hideDiag :: DynFlags -> (Maybe DiagnosticReason, FileDiagnostic) -> (Maybe DiagnosticReason, FileDiagnostic)
-hideDiag originalFlags (w@(Just (WarningWithFlag warning)), (nfp, _sh, fd))
+hideDiag originalFlags (w@(Just (WarningWithFlag warning)), fd)
   | not (wopt warning originalFlags)
-  = (w, (nfp, HideDiag, fd))
+  = (w, fd { fdShouldShowDiagnostic = HideDiag })
 hideDiag _originalFlags t = t
 
 -- | Warnings which lead to a diagnostic tag
@@ -692,18 +710,18 @@ unnecessaryDeprecationWarningFlags
 tagDiag :: (Maybe DiagnosticReason, FileDiagnostic) -> (Maybe DiagnosticReason, FileDiagnostic)
 
 #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, fd & fdLspDiagnosticL %~ \diag -> diag { _tags = Just $ DiagnosticTag_Deprecated : concat (_tags diag) })
+tagDiag (w@(Just (WarningWithFlags warnings)), fd)
   | tags <- mapMaybe requiresTag (toList warnings)
-  = (w, (nfp, sh, fd { _tags = Just $ tags ++ concat (_tags fd) }))
+  = (w, fd & fdLspDiagnosticL %~ \diag -> diag { _tags = Just $ tags ++ concat (_tags diag) })
 #else
-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, fd & fdLspDiagnosticL %~ \diag -> diag { _tags = Just $ tag : concat (_tags diag) })
 #endif
-  where
+    where
     requiresTag :: WarningFlag -> Maybe DiagnosticTag
 #if !MIN_VERSION_ghc(9,7,0)
     -- doesn't exist on 9.8, we use WarningWithCategory instead
@@ -859,16 +877,25 @@ handleGenerationErrors :: DynFlags -> T.Text -> IO () -> IO [FileDiagnostic]
 handleGenerationErrors dflags source action =
   action >> return [] `catches`
     [ Handler $ return . diagFromGhcException source dflags
-    , Handler $ return . diagFromString source DiagnosticSeverity_Error (noSpan "<internal>")
-    . (("Error during " ++ T.unpack source) ++) . show @SomeException
+    , Handler $ \(exception :: SomeException) -> return $
+        diagFromString
+          source DiagnosticSeverity_Error (noSpan "<internal>")
+          ("Error during " ++ T.unpack source ++ show exception)
+          Nothing
     ]
 
 handleGenerationErrors' :: DynFlags -> T.Text -> IO (Maybe a) -> IO ([FileDiagnostic], Maybe a)
 handleGenerationErrors' dflags source action =
   fmap ([],) action `catches`
     [ Handler $ return . (,Nothing) . diagFromGhcException source dflags
-    , Handler $ return . (,Nothing) . diagFromString source DiagnosticSeverity_Error (noSpan "<internal>")
-    . (("Error during " ++ T.unpack source) ++) . show @SomeException
+    , Handler $ \(exception :: SomeException) ->
+        return
+          ( diagFromString
+              source DiagnosticSeverity_Error (noSpan "<internal>")
+              ("Error during " ++ T.unpack source ++ show exception)
+              Nothing
+          , Nothing
+          )
     ]
 
 
@@ -1048,7 +1075,7 @@ parseHeader dflags filename contents = do
    let loc  = mkRealSrcLoc (Util.mkFastString filename) 1 1
    case unP Compat.parseHeader (initParserState (initParserOpts dflags) contents loc) of
      PFailedWithErrorMessages msgs ->
-        throwE $ diagFromErrMsgs sourceParser dflags $ msgs dflags
+        throwE $ diagFromGhcErrorMessages sourceParser dflags $ msgs dflags
      POk pst rdr_module -> do
         let (warns, errs) = renderMessages $ getPsMessages pst
 
@@ -1062,9 +1089,9 @@ parseHeader dflags filename contents = do
         -- errors are those from which a parse tree just can't
         -- be produced.
         unless (null errs) $
-            throwE $ diagFromErrMsgs sourceParser dflags errs
+            throwE $ diagFromGhcErrorMessages sourceParser dflags errs
 
-        let warnings = diagFromErrMsgs sourceParser dflags warns
+        let warnings = diagFromGhcErrorMessages sourceParser dflags warns
         return (warnings, rdr_module)
 
 -- | Given a buffer, flags, and file path, produce a
@@ -1081,18 +1108,28 @@ parseFileContents env customPreprocessor filename ms = do
        dflags = ms_hspp_opts ms
        contents = fromJust $ ms_hspp_buf ms
    case unP Compat.parseModule (initParserState (initParserOpts dflags) contents loc) of
-     PFailedWithErrorMessages msgs -> throwE $ diagFromErrMsgs sourceParser dflags $ msgs dflags
+     PFailedWithErrorMessages msgs ->
+       throwE $ diagFromGhcErrorMessages sourceParser dflags $ msgs dflags
      POk pst rdr_module ->
          let
              psMessages = getPsMessages pst
          in
            do
-               let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module
-
-               unless (null errs) $
-                  throwE $ diagFromStrings sourceParser DiagnosticSeverity_Error errs
-
-               let preproc_warnings = diagFromStrings sourceParser DiagnosticSeverity_Warning preproc_warns
+               let IdePreprocessedSource preproc_warns preproc_errs parsed = customPreprocessor rdr_module
+               let attachNoStructuredError (span, msg) = (span, msg, Nothing)
+
+               unless (null preproc_errs) $
+                  throwE $
+                    diagFromStrings
+                      sourceParser
+                      DiagnosticSeverity_Error
+                      (fmap attachNoStructuredError preproc_errs)
+
+               let preproc_warning_file_diagnostics =
+                     diagFromStrings
+                      sourceParser
+                      DiagnosticSeverity_Warning
+                      (fmap attachNoStructuredError preproc_warns)
                (parsed', msgs) <- liftIO $ applyPluginsParsedResultAction env ms parsed psMessages
                let (warns, errors) = renderMessages msgs
 
@@ -1106,8 +1143,7 @@ parseFileContents env customPreprocessor filename ms = do
                -- errors are those from which a parse tree just can't
                -- be produced.
                unless (null errors) $
-                 throwE $ diagFromErrMsgs sourceParser dflags errors
-
+                 throwE $ diagFromGhcErrorMessages sourceParser dflags errors
 
                -- To get the list of extra source files, we take the list
                -- that the parser gave us,
@@ -1137,8 +1173,8 @@ parseFileContents env customPreprocessor filename ms = do
                srcs2 <- liftIO $ filterM doesFileExist srcs1
 
                let pm = ParsedModule ms parsed' srcs2
-                   warnings = diagFromErrMsgs sourceParser dflags warns
-               pure (warnings ++ preproc_warnings, pm)
+                   warnings = diagFromGhcErrorMessages sourceParser dflags warns
+               pure (warnings ++ preproc_warning_file_diagnostics, pm)
 
 loadHieFile :: Compat.NameCacheUpdater -> FilePath -> IO GHC.HieFile
 loadHieFile ncu f = do