ghcide 2.9.0.1 → 2.10.0.0

raw patch · 145 files changed

+2103/−2391 lines, 145 filesdep +lens-aesondep +os-stringdep ~basedep ~hls-graphdep ~hls-plugin-apiPVP ok

version bump matches the API change (PVP)

Dependencies added: lens-aeson, os-string

Dependency ranges changed: base, hls-graph, hls-plugin-api

API changes (from Hackage documentation)

Files

• ghcide.cabal +8/−23
• session-loader/Development/IDE/Session.hs +44/−120
• session-loader/Development/IDE/Session/Diagnostics.hs +8/−5
• src/Development/IDE.hs +4/−3
• src/Development/IDE/Core/Actions.hs +47/−34
• src/Development/IDE/Core/Compile.hs +312/−413
• src/Development/IDE/Core/FileStore.hs +40/−11
• src/Development/IDE/Core/OfInterest.hs +3/−2
• src/Development/IDE/Core/PluginUtils.hs +95/−4
• src/Development/IDE/Core/Preprocessor.hs +4/−16
• src/Development/IDE/Core/ProgressReporting.hs +181/−96
• src/Development/IDE/Core/RuleTypes.hs +42/−30
• src/Development/IDE/Core/Rules.hs +79/−83
• src/Development/IDE/Core/Shake.hs +73/−75
• src/Development/IDE/Core/Tracing.hs +1/−1
• src/Development/IDE/Core/WorkerThread.hs +11/−6
• src/Development/IDE/GHC/CPP.hs +5/−5
• src/Development/IDE/GHC/Compat.hs +33/−104
• src/Development/IDE/GHC/Compat/CmdLine.hs +2/−21
• src/Development/IDE/GHC/Compat/Core.hs +54/−91
• src/Development/IDE/GHC/Compat/Driver.hs +155/−0
• src/Development/IDE/GHC/Compat/Env.hs +1/−36
• src/Development/IDE/GHC/Compat/Error.hs +68/−0
• src/Development/IDE/GHC/Compat/Iface.hs +4/−7
• src/Development/IDE/GHC/Compat/Logger.hs +1/−15
• src/Development/IDE/GHC/Compat/Outputable.hs +9/−43
• src/Development/IDE/GHC/Compat/Parser.hs +10/−29
• src/Development/IDE/GHC/Compat/Plugins.hs +14/−63
• src/Development/IDE/GHC/Compat/Units.hs +8/−49
• src/Development/IDE/GHC/Compat/Util.hs +1/−10
• src/Development/IDE/GHC/CoreFile.hs +18/−5
• src/Development/IDE/GHC/Error.hs +60/−44
• src/Development/IDE/GHC/Orphans.hs +49/−26
• src/Development/IDE/GHC/Util.hs +0/−1
• src/Development/IDE/GHC/Warnings.hs +27/−31
• src/Development/IDE/Import/DependencyInformation.hs +4/−10
• src/Development/IDE/Import/FindImports.hs +17/−49
• src/Development/IDE/LSP/HoverDefinition.hs +6/−2
• src/Development/IDE/LSP/Outline.hs +11/−35
• src/Development/IDE/LSP/Server.hs +1/−1
• src/Development/IDE/Main.hs +4/−15
• src/Development/IDE/Plugin/Completions.hs +5/−7
• src/Development/IDE/Plugin/Completions/Logic.hs +0/−10
• src/Development/IDE/Plugin/Completions/Types.hs +2/−3
• src/Development/IDE/Plugin/HLS.hs +83/−2
• src/Development/IDE/Plugin/HLS/GhcIde.hs +2/−0
• src/Development/IDE/Plugin/TypeLenses.hs +11/−4
• src/Development/IDE/Spans/AtPoint.hs +165/−41
• src/Development/IDE/Spans/Common.hs +49/−16
• src/Development/IDE/Spans/Documentation.hs +0/−12
• src/Development/IDE/Spans/Pragmas.hs +7/−5
• src/Development/IDE/Types/Diagnostics.hs +210/−22
• src/Development/IDE/Types/HscEnvEq.hs +33/−45
• src/Development/IDE/Types/Options.hs +2/−2
• src/Development/IDE/Types/Shake.hs +10/−12
• src/Text/Fuzzy/Parallel.hs +10/−11
• test/data/TH/THA.hs +0/−6
• test/data/TH/THB.hs +0/−5
• test/data/TH/THC.hs +0/−5
• test/data/TH/hie.yaml +0/−1
• test/data/THCoreFile/THA.hs +0/−23
• test/data/THCoreFile/THB.hs +0/−13
• test/data/THCoreFile/THC.hs +0/−5
• test/data/THCoreFile/hie.yaml +0/−1
• test/data/THLoading/A.hs +0/−5
• test/data/THLoading/B.hs +0/−4
• test/data/THLoading/THA.hs +0/−7
• test/data/THLoading/THB.hs +0/−5
• test/data/THLoading/hie.yaml +0/−1
• test/data/THNewName/A.hs +0/−6
• test/data/THNewName/B.hs +0/−5
• test/data/THNewName/C.hs +0/−4
• test/data/THNewName/hie.yaml +0/−1
• test/data/THUnboxed/THA.hs +0/−16
• test/data/THUnboxed/THB.hs +0/−5
• test/data/THUnboxed/THC.hs +0/−5
• test/data/THUnboxed/hie.yaml +0/−1
• test/data/boot/A.hs +0/−10
• test/data/boot/A.hs-boot +0/−3
• test/data/boot/B.hs +0/−7
• test/data/boot/C.hs +0/−8
• test/data/boot/hie.yaml +0/−1
• test/data/boot2/A.hs +0/−12
• test/data/boot2/B.hs +0/−8
• test/data/boot2/B.hs-boot +0/−3
• test/data/boot2/C.hs +0/−3
• test/data/boot2/D.hs +0/−3
• test/data/boot2/E.hs +0/−3
• test/data/boot2/hie.yaml +0/−1
• test/data/cabal-exe/a/a.cabal +0/−14
• test/data/cabal-exe/a/src/Main.hs +0/−3
• test/data/cabal-exe/cabal.project +0/−1
• test/data/cabal-exe/hie.yaml +0/−3
• test/data/hover/Bar.hs +0/−4
• test/data/hover/Foo.hs +0/−6
• test/data/hover/GotoHover.hs +0/−70
• test/data/hover/RecordDotSyntax.hs +0/−18
• test/data/hover/hie.yaml +0/−1
• test/data/ignore-fatal/IgnoreFatal.hs +0/−8
• test/data/ignore-fatal/cabal.project +0/−1
• test/data/ignore-fatal/hie.yaml +0/−4
• test/data/ignore-fatal/ignore-fatal.cabal +0/−10
• test/data/multi-unit-reexport/a/A.hs +0/−3
• test/data/multi-unit-reexport/b/B.hs +0/−3
• test/data/multi-unit-reexport/c/C.hs +0/−4
• test/data/multi-unit-reexport/cabal.project +0/−2
• test/data/multi-unit-reexport/hie.yaml +0/−6
• test/data/multi-unit/a/A.hs +0/−3
• test/data/multi-unit/b/B.hs +0/−3
• test/data/multi-unit/c/C.hs +0/−3
• test/data/multi-unit/cabal.project +0/−2
• test/data/multi-unit/hie.yaml +0/−6
• test/data/multi/a/A.hs +0/−3
• test/data/multi/a/a.cabal +0/−9
• test/data/multi/b/B.hs +0/−3
• test/data/multi/b/b.cabal +0/−9
• test/data/multi/c/C.hs +0/−3
• test/data/multi/c/c.cabal +0/−9
• test/data/multi/cabal.project +0/−3
• test/data/multi/hie.yaml +0/−8
• test/data/plugin-knownnat/KnownNat.hs +0/−10
• test/data/plugin-knownnat/cabal.project +0/−4
• test/data/plugin-knownnat/plugin.cabal +0/−9
• test/data/recomp/A.hs +0/−6
• test/data/recomp/B.hs +0/−4
• test/data/recomp/P.hs +0/−5
• test/data/recomp/hie.yaml +0/−1
• test/data/references/Main.hs +0/−14
• test/data/references/OtherModule.hs +0/−9
• test/data/references/OtherOtherModule.hs +0/−3
• test/data/references/References.hs +0/−25
• test/data/references/hie.yaml +0/−1
• test/data/rootUri/dirA/Foo.hs +0/−3
• test/data/rootUri/dirA/foo.cabal +0/−9
• test/data/rootUri/dirB/Foo.hs +0/−3
• test/data/rootUri/dirB/foo.cabal +0/−9
• test/data/symlink/hie.yaml +0/−10
• test/data/symlink/some_loc/Sym.hs +0/−4
• test/data/symlink/src/Foo.hs +0/−4
• test/data/working-dir/a/A.hs +0/−11
• test/data/working-dir/a/B.hs +0/−6
• test/data/working-dir/a/a.cabal +0/−11
• test/data/working-dir/cabal.project +0/−1
• test/data/working-dir/hie.yaml +0/−2
• test/preprocessor/Main.hs +0/−10

@@ -2,7 +2,7 @@ build-type:         Simple category:           Development name:               ghcide-version:            2.9.0.1+version:            2.10.0.0 license:            Apache-2.0 license-file:       LICENSE author:             Digital Asset and Ghcide contributors@@ -14,15 +14,10 @@   https://github.com/haskell/haskell-language-server/tree/master/ghcide#readme  bug-reports:        https://github.com/haskell/haskell-language-server/issues-tested-with:        GHC ==9.10.1 || ==9.8.2 || ==9.6.5 || ==9.4.8 || ==9.2.8+tested-with:        GHC ==9.10.1 || ==9.8.2 || ==9.6.5 || ==9.4.8 extra-source-files:   CHANGELOG.md   README.md-  test/data/**/*.cabal-  test/data/**/*.hs-  test/data/**/*.hs-boot-  test/data/**/*.project-  test/data/**/*.yaml  source-repository head   type:     git@@ -81,16 +76,18 @@     , hie-bios                     ^>=0.14.0     , hie-compat                   ^>=0.3.0.0     , hiedb                        ^>= 0.6.0.0-    , hls-graph                    == 2.9.0.1-    , hls-plugin-api               == 2.9.0.1+    , hls-graph                    == 2.10.0.0+    , hls-plugin-api               == 2.10.0.0     , implicit-hie                 >= 0.1.4.0 && < 0.1.5     , lens+    , lens-aeson     , list-t     , lsp                          ^>=2.7     , lsp-types                    ^>=2.3     , mtl     , opentelemetry                >=0.6.1     , optparse-applicative+    , os-string     , parallel     , prettyprinter                >=1.7     , prettyprinter-ansi-terminal@@ -150,7 +147,9 @@     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@@ -208,20 +207,6 @@   if flag(pedantic)     ghc-options:       -Werror--flag test-exe-  description: Build the ghcide-test-preprocessor executable-  default:     True--executable ghcide-test-preprocessor-  import: warnings-  default-language:   GHC2021-  hs-source-dirs:   test/preprocessor-  main-is:          Main.hs-  build-depends:    base >=4 && <5--  if !flag(test-exe)-    buildable: False  flag executable   description: Build the ghcide executable

@@ -8,7 +8,7 @@   (SessionLoadingOptions(..)   ,CacheDirs(..)   ,loadSessionWithOptions-  ,setInitialDynFlags+  ,getInitialGhcLibDirDefault   ,getHieDbLoc   ,retryOnSqliteBusy   ,retryOnException@@ -62,8 +62,7 @@ import qualified Development.IDE.Session.Implicit    as GhcIde import           Development.IDE.Types.Diagnostics import           Development.IDE.Types.Exports-import           Development.IDE.Types.HscEnvEq      (HscEnvEq, newHscEnvEq,-                                                      newHscEnvEqPreserveImportPaths)+import           Development.IDE.Types.HscEnvEq      (HscEnvEq, newHscEnvEq) import           Development.IDE.Types.Location import           Development.IDE.Types.Options import           GHC.ResponseFile@@ -101,36 +100,32 @@ import           Data.HashMap.Strict                 (HashMap) import           Data.HashSet                        (HashSet) import qualified Data.HashSet                        as Set+import qualified Data.Set                            as OS import           Database.SQLite.Simple import           Development.IDE.Core.Tracing        (withTrace) import           Development.IDE.Core.WorkerThread   (awaitRunInThread,                                                       withWorkerQueue)+import qualified Development.IDE.GHC.Compat.Util     as Compat import           Development.IDE.Session.Diagnostics (renderCradleError) import           Development.IDE.Types.Shake         (WithHieDb,                                                       WithHieDbShield (..),                                                       toNoFileKey)+import           GHC.Data.Graph.Directed import           HieDb.Create import           HieDb.Types-import           HieDb.Utils import           Ide.PluginUtils                     (toAbsolute) import qualified System.Random                       as Random import           System.Random                       (RandomGen) import           Text.ParserCombinators.ReadP        (readP_to_S) ---- See Note [Guidelines For Using CPP In GHCIDE Import Statements]--#if MIN_VERSION_ghc(9,3,0)-import qualified Data.Set                            as OS-import qualified Development.IDE.GHC.Compat.Util     as Compat-import           GHC.Data.Graph.Directed--import           GHC.Data.Bag import           GHC.Driver.Env                      (hsc_all_home_unit_ids) import           GHC.Driver.Errors.Types import           GHC.Types.Error                     (errMsgDiagnostic,                                                       singleMessage) import           GHC.Unit.State++#if MIN_VERSION_ghc(9,13,0)+import           GHC.Driver.Make                     (checkHomeUnitsClosed) #endif  data Log@@ -245,13 +240,6 @@   , getCacheDirs           :: String -> [String] -> IO CacheDirs   -- | Return the GHC lib dir to use for the 'unsafeGlobalDynFlags'   , getInitialGhcLibDir    :: Recorder (WithPriority Log) -> FilePath -> IO (Maybe LibDir)-#if !MIN_VERSION_ghc(9,3,0)-  , fakeUid                :: UnitId-    -- ^ unit id used to tag the internal component built by ghcide-    --   To reuse external interface files the unit ids must match,-    --   thus make sure to build them with `--this-unit-id` set to the-    --   same value as the ghcide fake uid-#endif   }  instance Default SessionLoadingOptions where@@ -260,9 +248,6 @@         ,loadCradle = loadWithImplicitCradle         ,getCacheDirs = getCacheDirsDefault         ,getInitialGhcLibDir = getInitialGhcLibDirDefault-#if !MIN_VERSION_ghc(9,3,0)-        ,fakeUid = Compat.toUnitId (Compat.stringToUnit "main")-#endif         }  -- | Find the cradle for a given 'hie.yaml' configuration.@@ -303,15 +288,6 @@         logWith recorder Warning LogGetInitialGhcLibDirDefaultCradleNone         pure Nothing --- | Sets `unsafeGlobalDynFlags` on using the hie-bios cradle and returns the GHC libdir-setInitialDynFlags :: Recorder (WithPriority Log) -> FilePath -> SessionLoadingOptions -> IO (Maybe LibDir)-setInitialDynFlags recorder rootDir SessionLoadingOptions{..} = do-  libdir <- getInitialGhcLibDir recorder rootDir-  dynFlags <- mapM dynFlagsForPrinting libdir-  logWith recorder Debug LogSettingInitialDynFlags-  mapM_ setUnsafeGlobalDynFlags dynFlags-  pure libdir- -- | If the action throws exception that satisfies predicate then we sleep for -- a duration determined by the random exponential backoff formula, -- `uniformRandom(0, min (maxDelay, (baseDelay * 2) ^ retryAttempt))`, and try@@ -540,26 +516,17 @@                   _inplace = map rawComponentUnitId $ NE.toList all_deps                all_deps' <- forM all_deps $ \RawComponentInfo{..} -> do-                  -- Remove all inplace dependencies from package flags for-                  -- components in this HscEnv-#if MIN_VERSION_ghc(9,3,0)-                  let (df2, uids) = (rawComponentDynFlags, [])-#else-                  let (df2, uids) = _removeInplacePackages fakeUid _inplace rawComponentDynFlags-#endif                   let prefix = show rawComponentUnitId                   -- See Note [Avoiding bad interface files]-                  let hscComponents = sort $ map show uids-                      cacheDirOpts = hscComponents ++ componentOptions opts+                  let cacheDirOpts = componentOptions opts                   cacheDirs <- liftIO $ getCacheDirs prefix cacheDirOpts-                  processed_df <- setCacheDirs recorder cacheDirs df2+                  processed_df <- setCacheDirs recorder cacheDirs rawComponentDynFlags                   -- The final component information, mostly the same but the DynFlags don't                   -- contain any packages which are also loaded                   -- into the same component.                   pure $ ComponentInfo                            { componentUnitId = rawComponentUnitId                            , componentDynFlags = processed_df-                           , componentInternalUnits = uids                            , componentTargets = rawComponentTargets                            , componentFP = rawComponentFP                            , componentCOptions = rawComponentCOptions@@ -585,8 +552,8 @@           -- For GHC's supporting multi component sessions, we create a shared           -- HscEnv but set the active component accordingly           hscEnv <- emptyHscEnv ideNc _libDir-          let new_cache = newComponentCache recorder optExtensions hieYaml _cfp hscEnv-          all_target_details <- new_cache old_deps new_deps rootDir+          let new_cache = newComponentCache recorder optExtensions _cfp hscEnv+          all_target_details <- new_cache old_deps new_deps            this_dep_info <- getDependencyInfo $ maybeToList hieYaml           let (all_targets, this_flags_map, this_options)@@ -599,10 +566,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))@@ -771,24 +739,13 @@             PreferSingleComponentLoading -> LoadFile             PreferMultiComponentLoading  -> LoadWithContext old_fps -#if MIN_VERSION_ghc(9,3,0) emptyHscEnv :: NameCache -> FilePath -> IO HscEnv-#else-emptyHscEnv :: IORef NameCache -> FilePath -> IO HscEnv-#endif emptyHscEnv nc libDir = do     -- We call setSessionDynFlags so that the loader is initialised     -- We need to do this before we call initUnits.     env <- runGhc (Just libDir) $       getSessionDynFlags >>= setSessionDynFlags >> getSession-    -- On GHC 9.2 calling setSessionDynFlags caches the unit databases-    -- for an empty environment. This prevents us from reading the-    -- package database subsequently. So clear the unit db cache in-    -- hsc_unit_dbs     pure $ setNameCache nc (hscSetFlags ((hsc_dflags env){useUnicode = True }) env)-#if !MIN_VERSION_ghc(9,3,0)-              {hsc_unit_dbs = Nothing}-#endif  data TargetDetails = TargetDetails   {@@ -826,23 +783,23 @@     [ (l, (targetEnv, targetDepends)) | l <-  targetLocations]  -#if MIN_VERSION_ghc(9,3,0) setNameCache :: NameCache -> HscEnv -> HscEnv-#else-setNameCache :: IORef NameCache -> HscEnv -> HscEnv-#endif setNameCache nc hsc = hsc { hsc_NC = nc } -#if MIN_VERSION_ghc(9,3,0)+#if MIN_VERSION_ghc(9,13,0)+-- Moved back to implementation in GHC.+checkHomeUnitsClosed' ::  UnitEnv -> OS.Set UnitId -> [DriverMessages]+checkHomeUnitsClosed' ue _ = checkHomeUnitsClosed ue+#elif MIN_VERSION_ghc(9,3,0) -- This function checks the important property that if both p and q are home units -- then any dependency of p, which transitively depends on q is also a home unit. -- 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>")@@ -865,7 +822,7 @@       where         go rest this this_uis =            plusUniqMap_C OS.union-             (addToUniqMap_C OS.union external_depends this (OS.fromList $ this_deps))+             (addToUniqMap_C OS.union external_depends this (OS.fromList this_deps))              rest            where              external_depends = mapUniqMap (OS.fromList . unitDepends)@@ -899,14 +856,12 @@ newComponentCache          :: Recorder (WithPriority Log)          -> [String]           -- ^ File extensions to consider-         -> Maybe FilePath     -- ^ Path to cradle          -> NormalizedFilePath -- ^ Path to file that caused the creation of this component          -> HscEnv             -- ^ An empty HscEnv          -> [ComponentInfo]    -- ^ New components to be loaded          -> [ComponentInfo]    -- ^ old, already existing components-         -> FilePath           -- ^ root dir, see Note [Root Directory]          -> IO [ [TargetDetails] ]-newComponentCache recorder exts cradlePath _cfp hsc_env old_cis new_cis dir = do+newComponentCache recorder exts _cfp hsc_env old_cis new_cis = do     let cis = Map.unionWith unionCIs (mkMap new_cis) (mkMap old_cis)         -- When we have multiple components with the same uid,         -- prefer the new one over the old.@@ -920,18 +875,22 @@     hscEnv' <- -- Set up a multi component session with the other units on GHC 9.4               Compat.initUnits dfs hsc_env -#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+    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-#else-    let isBad = const False-        multi_errs = []-#endif     -- 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@@ -951,26 +910,12 @@      forM (Map.elems cis) $ \ci -> do       let df = componentDynFlags ci-      let createHscEnvEq = maybe newHscEnvEqPreserveImportPaths (newHscEnvEq dir) cradlePath       thisEnv <- do-#if MIN_VERSION_ghc(9,3,0)             -- In GHC 9.4 we have multi component support, and we have initialised all the units             -- above.             -- We just need to set the current unit here             pure $ hscSetActiveUnitId (homeUnitId_ df) hscEnv'-#else-            -- This initializes the units for GHC 9.2-            -- Add the options for the current component to the HscEnv-            -- We want to call `setSessionDynFlags` instead of `hscSetFlags`-            -- because `setSessionDynFlags` also initializes the package database,-            -- which we need for any changes to the package flags in the dynflags-            -- to be visible.-            -- See #2693-            evalGhcEnv hscEnv' $ do-              _ <- setSessionDynFlags df-              getSession-#endif-      henv <- createHscEnvEq thisEnv (zip uids dfs)+      henv <- newHscEnvEq thisEnv       let targetEnv = (if isBad ci then multi_errs else [], Just henv)           targetDepends = componentDependencyInfo ci       logWith recorder Debug $ LogNewComponentCache (targetEnv, targetDepends)@@ -1076,10 +1021,6 @@   -- | Processed DynFlags. Does not contain inplace packages such as local   -- libraries. Can be used to actually load this Component.   , componentDynFlags       :: DynFlags-  -- | Internal units, such as local libraries, that this component-  -- is loaded with. These have been extracted from the original-  -- ComponentOptions.-  , componentInternalUnits  :: [UnitId]   -- | All targets of this components.   , componentTargets        :: [GHC.Target]   -- | Filepath which caused the creation of this component@@ -1201,7 +1142,6 @@       initOne this_opts = do         (dflags', targets') <- addCmdOpts this_opts dflags         let dflags'' =-#if MIN_VERSION_ghc(9,3,0)                 case unitIdString (homeUnitId_ dflags') of                      -- cabal uses main for the unit id of all executable packages                      -- This makes multi-component sessions confused about what@@ -1210,13 +1150,10 @@                      -- This works because there won't be any dependencies on the                      -- executable unit.                      "main" ->-                       let hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack $ this_opts)+                       let hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack this_opts)                            hashed_uid = Compat.toUnitId (Compat.stringToUnit ("main-"++hash))                        in setHomeUnitId_ hashed_uid dflags'                      _ -> dflags'-#else-                dflags'-#endif          let targets = makeTargetsAbsolute root targets'             root = case workingDirectory dflags'' of@@ -1236,14 +1173,7 @@               Compat.setUpTypedHoles $               makeDynFlagsAbsolute compRoot -- makeDynFlagsAbsolute already accounts for workingDirectory               dflags''-        -- initPackages parses the -package flags and-        -- sets up the visibility for each component.-        -- Throws if a -package flag cannot be satisfied.-        -- This only works for GHC <9.2-        -- For GHC >= 9.2, we need to modify the unit env in the hsc_dflags, which-        -- is done later in newComponentCache-        final_flags <- liftIO $ wrapPackageSetupException $ Compat.oldInitUnits dflags'''-        return (final_flags, targets)+        return (dflags''', targets)  setIgnoreInterfacePragmas :: DynFlags -> DynFlags setIgnoreInterfacePragmas df =@@ -1289,12 +1219,6 @@  instance Exception PackageSetupException --- | Wrap any exception as a 'PackageSetupException'-wrapPackageSetupException :: IO a -> IO a-wrapPackageSetupException = handleAny $ \case-  e | Just (pkgE :: PackageSetupException) <- fromException e -> throwIO pkgE-  e -> (throwIO . PackageSetupException . show) e- showPackageSetupException :: PackageSetupException -> String showPackageSetupException GhcVersionMismatch{..} = unwords     ["ghcide compiled against GHC"@@ -1308,6 +1232,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

@@ -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 @@   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]

@@ -10,7 +10,9 @@                                                              getDefinition,                                                              getTypeDefinition) import           Development.IDE.Core.FileExists       as X (getFileExists)-import           Development.IDE.Core.FileStore        as X (getFileContents)+import           Development.IDE.Core.FileStore        as X (getFileContents,+                                                             getFileModTimeContents,+                                                             getUriContents) import           Development.IDE.Core.IdeConfiguration as X (IdeConfiguration (..),                                                              isWorkspaceFile) import           Development.IDE.Core.OfInterest       as X (getFilesOfInterestUntracked)@@ -50,7 +52,6 @@ import           Development.IDE.Plugin                as X import           Development.IDE.Types.Diagnostics     as X import           Development.IDE.Types.HscEnvEq        as X (HscEnvEq (..),-                                                             hscEnv,-                                                             hscEnvWithImportPaths)+                                                             hscEnv) import           Development.IDE.Types.Location        as X import           Ide.Logger                            as X

@@ -3,6 +3,7 @@ ( getAtPoint , getDefinition , getTypeDefinition+, getImplementationDefinition , highlightAtPoint , refsAtPoint , workspaceSymbols@@ -66,56 +67,68 @@   !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)   MaybeT $ liftIO $ fmap (first (toCurrentRange mapping =<<)) <$> AtPoint.atPoint opts hf dkMap env pos' --- | For each Location, determine if we have the PositionMapping--- for the correct file. If not, get the correct position mapping--- and then apply the position mapping to the location.-toCurrentLocations+-- | Converts locations in the source code to their current positions,+-- taking into account changes that may have occurred due to edits.+toCurrentLocation   :: PositionMapping   -> NormalizedFilePath-  -> [Location]-  -> IdeAction [Location]-toCurrentLocations mapping file = mapMaybeM go+  -> Location+  -> IdeAction (Maybe Location)+toCurrentLocation mapping file (Location uri range) =+  -- The Location we are going to might be in a different+  -- file than the one we are calling gotoDefinition from.+  -- So we check that the location file matches the file+  -- we are in.+  if nUri == normalizedFilePathToUri file+  -- The Location matches the file, so use the PositionMapping+  -- we have.+  then pure $ Location uri <$> toCurrentRange mapping range+  -- The Location does not match the file, so get the correct+  -- PositionMapping and use that instead.+  else do+    otherLocationMapping <- fmap (fmap snd) $ runMaybeT $ do+      otherLocationFile <- MaybeT $ pure $ uriToNormalizedFilePath nUri+      useWithStaleFastMT GetHieAst otherLocationFile+    pure $ Location uri <$> (flip toCurrentRange range =<< otherLocationMapping)   where-    go :: Location -> IdeAction (Maybe Location)-    go (Location uri range) =-      -- The Location we are going to might be in a different-      -- file than the one we are calling gotoDefinition from.-      -- So we check that the location file matches the file-      -- we are in.-      if nUri == normalizedFilePathToUri file-      -- The Location matches the file, so use the PositionMapping-      -- we have.-      then pure $ Location uri <$> toCurrentRange mapping range-      -- The Location does not match the file, so get the correct-      -- PositionMapping and use that instead.-      else do-        otherLocationMapping <- fmap (fmap snd) $ runMaybeT $ do-          otherLocationFile <- MaybeT $ pure $ uriToNormalizedFilePath nUri-          useWithStaleFastMT GetHieAst otherLocationFile-        pure $ Location uri <$> (flip toCurrentRange range =<< otherLocationMapping)-      where-        nUri :: NormalizedUri-        nUri = toNormalizedUri uri+    nUri :: NormalizedUri+    nUri = toNormalizedUri uri  -- | Goto Definition.-getDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location])+getDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [(Location, Identifier)]) getDefinition file pos = runMaybeT $ do     ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask     opts <- liftIO $ getIdeOptionsIO ide-    (HAR _ hf _ _ _, mapping) <- useWithStaleFastMT GetHieAst file+    (hf, mapping) <- useWithStaleFastMT GetHieAst file     (ImportMap imports, _) <- useWithStaleFastMT GetImportMap file     !pos' <- MaybeT (pure $ fromCurrentPosition mapping pos)-    locations <- AtPoint.gotoDefinition withHieDb (lookupMod hiedbWriter) opts imports hf pos'-    MaybeT $ Just <$> toCurrentLocations mapping file locations+    locationsWithIdentifier <- AtPoint.gotoDefinition withHieDb (lookupMod hiedbWriter) opts imports hf pos'+    mapMaybeM (\(location, identifier) -> do+      fixedLocation <- MaybeT $ toCurrentLocation mapping file location+      pure $ Just (fixedLocation, identifier)+      ) locationsWithIdentifier -getTypeDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location])++getTypeDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [(Location, Identifier)]) getTypeDefinition file pos = runMaybeT $ do     ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask     opts <- liftIO $ getIdeOptionsIO ide     (hf, mapping) <- useWithStaleFastMT GetHieAst file     !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)-    locations <- AtPoint.gotoTypeDefinition withHieDb (lookupMod hiedbWriter) opts hf pos'-    MaybeT $ Just <$> toCurrentLocations mapping file locations+    locationsWithIdentifier <- AtPoint.gotoTypeDefinition withHieDb (lookupMod hiedbWriter) opts hf pos'+    mapMaybeM (\(location, identifier) -> do+      fixedLocation <- MaybeT $ toCurrentLocation mapping file location+      pure $ Just (fixedLocation, identifier)+      ) locationsWithIdentifier++getImplementationDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location])+getImplementationDefinition file pos = runMaybeT $ do+    ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask+    opts <- liftIO $ getIdeOptionsIO ide+    (hf, mapping) <- useWithStaleFastMT GetHieAst file+    !pos' <- MaybeT (pure $ fromCurrentPosition mapping pos)+    locs <- AtPoint.gotoImplementation withHieDb (lookupMod hiedbWriter) opts hf pos'+    traverse (MaybeT . toCurrentLocation mapping file) locs  highlightAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe [DocumentHighlight]) highlightAtPoint file pos = runMaybeT $ do

@@ -36,103 +36,109 @@   , sourceTypecheck   , sourceParser   , shareUsages+  , setNonHomeFCHook   ) where -import           Control.Concurrent.Extra-import           Control.Concurrent.STM.Stats      hiding (orElse)-import           Control.DeepSeq                   (NFData (..), force, rnf)-import           Control.Exception                 (evaluate)+import           Control.Concurrent.STM.Stats           hiding (orElse)+import           Control.DeepSeq                        (NFData (..), force,+                                                         rnf)+import           Control.Exception                      (evaluate) import           Control.Exception.Safe-import           Control.Lens                      hiding (List, pre, (<.>))+import           Control.Lens                           hiding (List, pre,+                                                         (<.>)) import           Control.Monad.Extra import           Control.Monad.IO.Class import           Control.Monad.Trans.Except-import qualified Control.Monad.Trans.State.Strict  as S-import           Data.Aeson                        (toJSON)-import           Data.Bifunctor                    (first, second)+import qualified Control.Monad.Trans.State.Strict       as S+import           Data.Aeson                             (toJSON)+import           Data.Bifunctor                         (first, second) import           Data.Binary-import qualified Data.ByteString                   as BS+import qualified Data.ByteString                        as BS import           Data.Coerce-import qualified Data.DList                        as DL+import qualified Data.DList                             as DL import           Data.Functor import           Data.Generics.Aliases import           Data.Generics.Schemes-import qualified Data.HashMap.Strict               as HashMap-import           Data.IntMap                       (IntMap)+import qualified Data.HashMap.Strict                    as HashMap+import           Data.IntMap                            (IntMap) import           Data.IORef import           Data.List.Extra-import qualified Data.Map.Strict                   as Map+import qualified Data.List.NonEmpty                     as NE+import qualified Data.Map.Strict                        as Map import           Data.Maybe-import           Data.Proxy                        (Proxy (Proxy))-import qualified Data.Text                         as T-import           Data.Time                         (UTCTime (..))-import           Data.Tuple.Extra                  (dupe)-import           Data.Unique                       as Unique+import           Data.Proxy                             (Proxy (Proxy))+import qualified Data.Text                              as T+import           Data.Time                              (UTCTime (..), getCurrentTime)+import           Data.Tuple.Extra                       (dupe) import           Debug.Trace-import           Development.IDE.Core.FileStore    (resetInterfaceStore)+import           Development.IDE.Core.FileStore         (resetInterfaceStore) import           Development.IDE.Core.Preprocessor+import           Development.IDE.Core.ProgressReporting (progressUpdate) import           Development.IDE.Core.RuleTypes import           Development.IDE.Core.Shake-import           Development.IDE.Core.Tracing      (withTrace)-import           Development.IDE.GHC.Compat        hiding (loadInterface,-                                                    parseHeader, parseModule,-                                                    tcRnModule, writeHieFile, assert)-import qualified Development.IDE.GHC.Compat        as Compat-import qualified Development.IDE.GHC.Compat        as GHC-import qualified Development.IDE.GHC.Compat.Util   as Util+import           Development.IDE.Core.Tracing           (withTrace)+import           Development.IDE.GHC.Compat             hiding (assert,+                                                         loadInterface,+                                                         parseHeader,+                                                         parseModule,+                                                         tcRnModule,+                                                         writeHieFile)+import qualified Development.IDE.GHC.Compat             as Compat+import qualified Development.IDE.GHC.Compat             as GHC+import qualified Development.IDE.GHC.Compat.Util        as Util import           Development.IDE.GHC.CoreFile import           Development.IDE.GHC.Error-import           Development.IDE.GHC.Orphans       ()+import           Development.IDE.GHC.Orphans            () import           Development.IDE.GHC.Util import           Development.IDE.GHC.Warnings import           Development.IDE.Types.Diagnostics import           Development.IDE.Types.Location import           Development.IDE.Types.Options-import           GHC                               (ForeignHValue,-                                                    GetDocsFailure (..),-                                                    parsedSource)-import qualified GHC.LanguageExtensions            as LangExt+import           GHC                                    (ForeignHValue,+                                                         GetDocsFailure (..),+                                                         parsedSource, ModLocation (..))+import qualified GHC.LanguageExtensions                 as LangExt import           GHC.Serialized-import           HieDb                             hiding (withHieDb)-import qualified Language.LSP.Protocol.Message     as LSP-import           Language.LSP.Protocol.Types       (DiagnosticTag (..))-import qualified Language.LSP.Protocol.Types       as LSP-import qualified Language.LSP.Server               as LSP-import           Prelude                           hiding (mod)+import           HieDb                                  hiding (withHieDb)+import qualified Language.LSP.Protocol.Message          as LSP+import           Language.LSP.Protocol.Types            (DiagnosticTag (..))+import qualified Language.LSP.Server                    as LSP+import           Prelude                                hiding (mod) import           System.Directory import           System.FilePath-import           System.IO.Extra                   (fixIO, newTempFileWithin)+import           System.IO.Extra                        (fixIO,+                                                         newTempFileWithin) -import qualified GHC                               as G+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  -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,3,0)-import           Data.Map                          (Map)-import           GHC.Unit.Module.Graph             (ModuleGraph)-import           Unsafe.Coerce-#endif -#if MIN_VERSION_ghc(9,3,0)-import qualified Data.Set                          as Set-#endif- #if MIN_VERSION_ghc(9,5,0) import           GHC.Core.Lint.Interactive import           GHC.Driver.Config.CoreToStg.Prep #endif  #if MIN_VERSION_ghc(9,7,0)-import           Data.Foldable                     (toList)+import           Data.Foldable                          (toList) import           GHC.Unit.Module.Warnings #else-import           Development.IDE.Core.FileStore    (shareFilePath)+import           Development.IDE.Core.FileStore         (shareFilePath) #endif +import           Development.IDE.GHC.Compat.Driver (hscTypecheckRenameWithDiagnostics)++import Development.IDE.Import.DependencyInformation+import GHC.Driver.Env ( hsc_all_home_unit_ids )+import Development.IDE.Import.FindImports+ --Simple constants to make sure the source is consistently named sourceTypecheck :: T.Text sourceTypecheck = "typecheck"@@ -160,13 +166,18 @@     -> 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+data TypecheckHelpers   = TypecheckHelpers   { getLinkables       :: [NormalizedFilePath] -> IO [LinkableResult] -- ^ hls-graph action to get linkables for files+  , getModuleGraph :: IO DependencyInformation   }  typecheckModule :: IdeDefer@@ -178,24 +189,28 @@         let modSummary = pm_mod_summary pm             dflags = ms_hspp_opts modSummary         initialized <- catchSrcErrors (hsc_dflags hsc) "typecheck (initialize plugins)"-                                      (initPlugins hsc modSummary)+                                      (Loader.initializePlugins (hscSetFlags (ms_hspp_opts modSummary) hsc))         case initialized of           Left errs -> return (errs, Nothing)-          Right (modSummary', hscEnv) -> do-            (warnings, etcm) <- withWarnings sourceTypecheck $ \tweak ->+          Right hscEnv -> do+            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 @@ -223,11 +238,7 @@     -- come from in the IORef,, as these are the modules on whose implementation     -- we depend.     compile_bco_hook :: IORef (ModuleEnv BS.ByteString) -> HscEnv -> SrcSpan -> CoreExpr-#if MIN_VERSION_ghc(9,3,0)                      -> IO (ForeignHValue, [Linkable], PkgsLoaded)-#else-                     -> IO ForeignHValue-#endif     compile_bco_hook var hsc_env srcspan ds_expr       = do { let dflags = hsc_dflags hsc_env @@ -247,10 +258,8 @@            ; let iNTERACTIVELoc = G.ModLocation{ ml_hs_file   = Nothing,                                         ml_hi_file   = panic "hscCompileCoreExpr':ml_hi_file",                                         ml_obj_file  = panic "hscCompileCoreExpr':ml_obj_file",-#if MIN_VERSION_ghc(9,3,0)                                         ml_dyn_obj_file = panic "hscCompileCoreExpr':ml_dyn_obj_file",                                         ml_dyn_hi_file  = panic "hscCompileCoreExpr':ml_dyn_hi_file",-#endif                                         ml_hie_file  = panic "hscCompileCoreExpr':ml_hie_file"                                         }            ; let ictxt = hsc_IC hsc_env@@ -259,9 +268,7 @@                myCoreToStgExpr (hsc_logger hsc_env)                                (hsc_dflags hsc_env)                                ictxt-#if MIN_VERSION_ghc(9,3,0)                                True -- for bytecode-#endif                                (icInteractiveModule ictxt)                                iNTERACTIVELoc                                prepd_expr@@ -271,6 +278,9 @@                        (icInteractiveModule ictxt)                        stg_expr                        [] Nothing+#if MIN_VERSION_ghc(9,11,0)+                       [] -- spt_entries+#endif              -- Exclude wired-in names because we may not have read             -- their interface files, so getLinkDeps will fail@@ -279,11 +289,7 @@              -- Find the linkables for the modules we need            ; let needed_mods = mkUniqSet [-#if MIN_VERSION_ghc(9,3,0)                                            mod -- We need the whole module for 9.4 because of multiple home units modules may have different unit ids-#else-                                           moduleName mod -- On <= 9.2, just the name is enough because all unit ids will be the same-#endif                                           | n <- concatMap (uniqDSetToList . bcoFreeNames) $ bc_bcos bcos                                          , not (isWiredInName n) -- Exclude wired-in names@@ -291,51 +297,33 @@                                          , moduleUnitId mod `elem` home_unit_ids -- Only care about stuff from the home package set                                          ]                  home_unit_ids =-#if MIN_VERSION_ghc(9,3,0)                     map fst (hugElts $ hsc_HUG hsc_env)-#else-                    [homeUnitId_ dflags]-#endif                  mods_transitive = getTransitiveMods hsc_env needed_mods                   -- If we don't support multiple home units, ModuleNames are sufficient because all the units will be the same                  mods_transitive_list =-#if MIN_VERSION_ghc(9,3,0)                                          mapMaybe nodeKeyToInstalledModule $ Set.toList mods_transitive-#else-                                        -- Non det OK as we will put it into maps later anyway-                                         map (Compat.installedModule (homeUnitId_ dflags)) $ nonDetEltsUniqSet mods_transitive-#endif -#if MIN_VERSION_ghc(9,3,0)-           ; moduleLocs <- readIORef (fcModuleCache $ hsc_FC hsc_env)-#else-           ; moduleLocs <- readIORef (hsc_FC hsc_env)-#endif-           ; lbs <- getLinkables [toNormalizedFilePath' file+           ; moduleLocs <- getModuleGraph+           ; lbs <- getLinkables [file                                  | installedMod <- mods_transitive_list-                                 , let ifr = fromJust $ lookupInstalledModuleEnv moduleLocs installedMod-                                       file = case ifr of-                                         InstalledFound loc _ ->-                                           fromJust $ ml_hs_file loc-                                         _ -> panic "hscCompileCoreExprHook: module not found"+                                 , let file = fromJust $ lookupModuleFile (installedMod { moduleUnit = RealUnit (Definite $ moduleUnit installedMod) }) moduleLocs                                  ]            ; let hsc_env' = loadModulesHome (map linkableHomeMod lbs) hsc_env -#if MIN_VERSION_ghc(9,3,0)              {- load it -}-           ; (fv_hvs, lbss, pkgs) <- loadDecls (hscInterp hsc_env') hsc_env' srcspan bcos-           ; let hval = ((expectJust "hscCompileCoreExpr'" $ lookup (idName binding_id) fv_hvs), lbss, pkgs)+#if MIN_VERSION_ghc(9,11,0)+           ; bco_time <- getCurrentTime+           ; (fv_hvs, lbss, pkgs) <- loadDecls (hscInterp hsc_env') hsc_env' srcspan $+                Linkable bco_time (icInteractiveModule ictxt) $ NE.singleton $ BCOs bcos #else-             {- load it -}-           ; fv_hvs <- loadDecls (hscInterp hsc_env') hsc_env' srcspan bcos-           ; let hval = expectJust "hscCompileCoreExpr'" $ lookup (idName binding_id) fv_hvs+           ; (fv_hvs, lbss, pkgs) <- loadDecls (hscInterp hsc_env') hsc_env' srcspan bcos #endif+           ; let hval = (expectJust "hscCompileCoreExpr'" $ lookup (idName binding_id) fv_hvs, lbss, pkgs)             ; modifyIORef' var (flip extendModuleEnvList [(mi_module $ hm_iface hm, linkableHash lb) | lb <- lbs, let hm = linkableHomeMod lb])            ; return hval } -#if MIN_VERSION_ghc(9,3,0)     -- TODO: support backpack     nodeKeyToInstalledModule :: NodeKey -> Maybe InstalledModule     -- We shouldn't get boot files here, but to be safe, never map them to an installed module@@ -346,28 +334,13 @@     nodeKeyToInstalledModule _ = Nothing     moduleToNodeKey :: Module -> NodeKey     moduleToNodeKey mod = NodeKey_Module $ ModNodeKeyWithUid (GWIB (moduleName mod) NotBoot) (moduleUnitId mod)-#endif      -- Compute the transitive set of linkables required     getTransitiveMods hsc_env needed_mods-#if MIN_VERSION_ghc(9,3,0)       = Set.unions (Set.fromList (map moduleToNodeKey mods) : [ dep | m <- mods                                                               , Just dep <- [Map.lookup (moduleToNodeKey m) (mgTransDeps (hsc_mod_graph hsc_env))]                                                               ])       where mods = nonDetEltsUniqSet needed_mods -- OK because we put them into a set immediately after-#else-      = go emptyUniqSet needed_mods-      where-        hpt = hsc_HPT hsc_env-        go seen new-          | isEmptyUniqSet new = seen-          | otherwise = go seen' new'-            where-              seen' = seen `unionUniqSets` new-              new'  = new_deps `minusUniqSet` seen'-              new_deps = unionManyUniqSets [ mkUniqSet $ getDependentMods $ hm_iface mod_info-                                           | mod_info <- eltsUDFM $ udfmIntersectUFM hpt (getUniqSet new)]-#endif      -- | Add a Hook to the DynFlags which captures and returns the     -- typechecked splices before they are run. This information@@ -408,12 +381,12 @@   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 $-                          HsParsedModule { hpm_module = parsedSource pmod,-                                           hpm_src_files = pm_extra_src_files pmod,-                                           hpm_annotations = pm_annotations pmod }+             do  hscTypecheckRenameWithDiagnostics hscEnvTmp ms $+                          HsParsedModule { hpm_module = parsedSource pmod+                                         , hpm_src_files = pm_extra_src_files pmod+                                         }   let rn_info = case mrn_info of         Just x  -> x         Nothing -> error "no renamed info tcRnModule"@@ -422,7 +395,7 @@       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]@@ -442,12 +415,8 @@ -- HLS. To avoid GHC from pessimising HLS, we filter out certain dependency information -- that we track ourselves. See also Note [Recompilation avoidance in the presence of TH] filterUsages :: [Usage] -> [Usage]-#if MIN_VERSION_ghc(9,3,0) filterUsages = filter $ \case UsageHomeModuleInterface{} -> False                               _ -> True-#else-filterUsages = id-#endif  -- | Mitigation for https://gitlab.haskell.org/ghc/ghc/-/issues/22744 -- Important to do this immediately after reading the unit before@@ -473,7 +442,14 @@   details <- makeSimpleDetails hsc_env_tmp tcGblEnv   sf <- finalSafeMode (ms_hspp_opts ms) tcGblEnv   iface' <- mkIfaceTc hsc_env_tmp sf details ms Nothing tcGblEnv-  let iface = iface' { mi_globals = Nothing, mi_usages = filterUsages (mi_usages iface') } -- See Note [Clearing mi_globals after generating an iface]+  -- See Note [Clearing mi_globals after generating an iface]+  let iface = iface'+#if MIN_VERSION_ghc(9,11,0)+                & set_mi_top_env Nothing+                & set_mi_usages (filterUsages (mi_usages iface'))+#else+                { mi_globals = Nothing, mi_usages = filterUsages (mi_usages iface') }+#endif   pure $! mkHiFileResult ms iface details (tmrRuntimeModules tcm) Nothing  mkHiFileResultCompile@@ -498,8 +474,9 @@                                               (cg_binds guts) #endif                                               details-#if MIN_VERSION_ghc(9,3,0)                                               ms+#if MIN_VERSION_ghc(9,11,0)+                                              (tcg_import_decls (tmrTypechecked tcm)) #endif                                               simplified_guts @@ -507,7 +484,17 @@ #if MIN_VERSION_ghc(9,4,2)                     Nothing #endif-  let final_iface = final_iface' {mi_globals = Nothing, mi_usages = filterUsages (mi_usages final_iface')} -- See Note [Clearing mi_globals after generating an iface]+#if MIN_VERSION_ghc(9,11,0)+                    NoStubs []+#endif+  -- See Note [Clearing mi_globals after generating an iface]+  let final_iface = final_iface'+#if MIN_VERSION_ghc(9,11,0)+                      & set_mi_top_env Nothing+                      & set_mi_usages (filterUsages (mi_usages final_iface'))+#else+                      {mi_globals = Nothing, mi_usages = filterUsages (mi_usages final_iface')}+#endif    -- Write the core file now   core_file <- do@@ -515,7 +502,7 @@             core_file = codeGutsToCoreFile iface_hash guts             iface_hash = getModuleHash final_iface         core_hash1 <- atomicFileWrite se core_fp $ \fp ->-          writeBinCoreFile fp core_file+          writeBinCoreFile (hsc_dflags session) fp core_file         -- We want to drop references to guts and read in a serialized, compact version         -- of the core file from disk (as it is deserialised lazily)         -- This is because we don't want to keep the guts in memory for every file in@@ -552,17 +539,9 @@        -- Run corePrep first as we want to test the final version of the program that will       -- get translated to STG/Bytecode-#if MIN_VERSION_ghc(9,3,0)       prepd_binds-#else-      (prepd_binds , _)-#endif         <- corePrep unprep_binds data_tycons-#if MIN_VERSION_ghc(9,3,0)       prepd_binds'-#else-      (prepd_binds', _)-#endif         <- corePrep unprep_binds' data_tycons       let binds  = noUnfoldings $ (map flattenBinds . (:[])) prepd_binds           binds' = noUnfoldings $ (map flattenBinds . (:[])) prepd_binds'@@ -599,8 +578,14 @@     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.@@ -659,11 +644,7 @@                       let env' = tweak (hscSetFlags (ms_hspp_opts summary) session)                           target = platformDefaultBackend (hsc_dflags env')                           newFlags = setBackend target $ updOptLevel 0 $ setOutputFile-#if MIN_VERSION_ghc(9,3,0)                               (Just dot_o)-#else-                              dot_o-#endif                             $ hsc_dflags env'                           session' = hscSetFlags newFlags session #if MIN_VERSION_ghc(9,4,2)@@ -674,18 +655,16 @@                                 (ms_location summary)                                 fp                       obj <- compileFile session' driverNoStop (outputFilename, Just (As False))-#if MIN_VERSION_ghc(9,3,0)                       case obj of                         Nothing -> throwGhcExceptionIO $ Panic "compileFile didn't generate object code"                         Just x -> pure x-#else-                      return obj-#endif-              let unlinked = DotO dot_o_fp               -- Need time to be the modification time for recompilation checking               t <- liftIO $ getModificationTime dot_o_fp-              let linkable = LM t mod [unlinked]-+#if MIN_VERSION_ghc(9,11,0)+              let linkable = Linkable t mod (pure $ DotO dot_o_fp ModuleObject)+#else+              let linkable = LM t mod [DotO dot_o_fp]+#endif               pure (map snd warnings, linkable)  newtype CoreFileTime = CoreFileTime UTCTime@@ -694,15 +673,22 @@ generateByteCode (CoreFileTime time) hscEnv summary guts = do     fmap (either (, Nothing) (second Just)) $           catchSrcErrors (hsc_dflags hscEnv) "bytecode" $ do+#if MIN_VERSION_ghc(9,11,0)+              (warnings, (_, bytecode)) <-+#else               (warnings, (_, bytecode, sptEntries)) <-+#endif                 withWarnings "bytecode" $ \_tweak -> do                       let session = _tweak (hscSetFlags (ms_hspp_opts summary) hscEnv)                           -- TODO: maybe settings ms_hspp_opts is unnecessary?                           summary' = summary { ms_hspp_opts = hsc_dflags session }                       hscInteractive session (mkCgInteractiveGuts guts)                                 (ms_location summary')-              let unlinked = BCOs bytecode sptEntries-              let linkable = LM time (ms_mod summary) [unlinked]+#if MIN_VERSION_ghc(9,11,0)+              let linkable = Linkable time (ms_mod summary) (pure $ BCOs bytecode)+#else+              let linkable = LM time (ms_mod summary) [BCOs bytecode sptEntries]+#endif               pure (map snd warnings, linkable)  demoteTypeErrorsToWarnings :: ParsedModule -> ParsedModule@@ -725,34 +711,23 @@ update_pm_mod_summary up pm =   pm{pm_mod_summary = up $ pm_mod_summary pm} -#if MIN_VERSION_ghc(9,3,0) unDefer :: (Maybe DiagnosticReason, FileDiagnostic) -> (Bool, FileDiagnostic) unDefer (Just (WarningWithFlag Opt_WarnDeferredTypeErrors)         , fd) = (True, upgradeWarningToError fd) unDefer (Just (WarningWithFlag Opt_WarnTypedHoles)                 , fd) = (True, upgradeWarningToError fd) unDefer (Just (WarningWithFlag Opt_WarnDeferredOutOfScopeVariables), fd) = (True, upgradeWarningToError fd)-#else-unDefer :: (WarnReason, FileDiagnostic) -> (Bool, FileDiagnostic)-unDefer (Reason Opt_WarnDeferredTypeErrors         , fd) = (True, upgradeWarningToError fd)-unDefer (Reason Opt_WarnTypedHoles                 , fd) = (True, upgradeWarningToError fd)-unDefer (Reason Opt_WarnDeferredOutOfScopeVariables, fd) = (True, upgradeWarningToError fd)-#endif 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:" -#if MIN_VERSION_ghc(9,3,0) hideDiag :: DynFlags -> (Maybe DiagnosticReason, FileDiagnostic) -> (Maybe DiagnosticReason, FileDiagnostic)-hideDiag originalFlags (w@(Just (WarningWithFlag warning)), (nfp, _sh, fd))-#else-hideDiag :: DynFlags -> (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)-hideDiag originalFlags (w@(Reason warning), (nfp, _sh, fd))-#endif+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@@ -773,29 +748,21 @@     ]  -- | Add a unnecessary/deprecated tag to the required diagnostics.-#if MIN_VERSION_ghc(9,3,0) tagDiag :: (Maybe DiagnosticReason, FileDiagnostic) -> (Maybe DiagnosticReason, FileDiagnostic)-#else-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, 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) }))-#elif MIN_VERSION_ghc(9,3,0)-tagDiag (w@(Just (WarningWithFlag warning)), (nfp, sh, fd))-  | Just tag <- requiresTag warning-  = (w, (nfp, sh, fd { _tags = Just $ tag : concat (_tags fd) }))+  = (w, fd & fdLspDiagnosticL %~ \diag -> diag { _tags = Just $ tags ++ concat (_tags diag) }) #else-tagDiag (w@(Reason 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@@ -822,33 +789,43 @@   (write tempFilePath >>= \x -> renameFile tempFilePath targetPath >> atomically (resetInterfaceStore se (toNormalizedFilePath' targetPath)) >> pure x)     `onException` cleanUp -generateHieAsts :: HscEnv -> TcModuleResult -> IO ([FileDiagnostic], Maybe (HieASTs Type))+generateHieAsts :: HscEnv -> TcModuleResult+#if MIN_VERSION_ghc(9,11,0)+                -> IO ([FileDiagnostic], Maybe (HieASTs Type, NameEntityInfo))+#else+                -> IO ([FileDiagnostic], Maybe (HieASTs Type))+#endif generateHieAsts hscEnv tcm =   handleGenerationErrors' dflags "extended interface generation" $ runHsc hscEnv $ do     -- These varBinds use unitDataConId but it could be anything as the id name is not used     -- during the hie file generation process. It's a workaround for the fact that the hie modules     -- don't export an interface which allows for additional information to be added to hie files.-    let fake_splice_binds = Util.listToBag (map (mkVarBind unitDataConId) (spliceExpressions $ tmrTopLevelSplices tcm))+    let fake_splice_binds =+#if !MIN_VERSION_ghc(9,11,0)+                            Util.listToBag $+#endif+                            map (mkVarBind unitDataConId) (spliceExpressions $ tmrTopLevelSplices tcm)         real_binds = tcg_binds $ tmrTypechecked tcm+        all_binds =+#if MIN_VERSION_ghc(9,11,0)+          fake_splice_binds ++ real_binds+#else+          fake_splice_binds `Util.unionBags` real_binds+#endif         ts = tmrTypechecked tcm :: TcGblEnv         top_ev_binds = tcg_ev_binds ts :: Util.Bag EvBind         insts = tcg_insts ts :: [ClsInst]         tcs = tcg_tcs ts :: [TyCon]-    run ts $-#if MIN_VERSION_ghc(9,3,0)-      pure $ Just $-#else-      Just <$>+        hie_asts = GHC.enrichHie all_binds (tmrRenamed tcm) top_ev_binds insts tcs++    pure $ Just $+#if MIN_VERSION_ghc(9,11,0)+      hie_asts (tcg_type_env ts)+#elif MIN_VERSION_ghc(9,3,0)+      hie_asts #endif-          GHC.enrichHie (fake_splice_binds `Util.unionBags` real_binds) (tmrRenamed tcm) top_ev_binds insts tcs   where     dflags = hsc_dflags hscEnv-    run _ts = -- ts is only used in GHC 9.2-#if !MIN_VERSION_ghc(9,3,0)-        fmap (join . snd) . liftIO . initDs hscEnv _ts-#else-        id-#endif  spliceExpressions :: Splices -> [LHsExpr GhcTc] spliceExpressions Splices{..} =@@ -890,7 +867,6 @@ -- indexHieFile :: ShakeExtras -> ModSummary -> NormalizedFilePath -> Util.Fingerprint -> Compat.HieFile -> IO () indexHieFile se mod_summary srcPath !hash hf = do- IdeOptions{optProgressStyle} <- getIdeOptionsIO se  atomically $ do   pending <- readTVar indexPending   case HashMap.lookup srcPath pending of@@ -911,69 +887,14 @@         unless newerScheduled $ do           -- Using bracket, so even if an exception happen during withHieDb call,           -- the `post` (which clean the progress indicator) will still be called.-          bracket_ (pre optProgressStyle) post $+          bracket_ pre post $             withHieDb (\db -> HieDb.addRefsFromLoaded db targetPath (HieDb.RealFile $ fromNormalizedFilePath srcPath) hash hf')   where     mod_location    = ms_location mod_summary     targetPath      = Compat.ml_hie_file mod_location     HieDbWriter{..} = hiedbWriter se -    -- Get a progress token to report progress and update it for the current file-    pre style = do-      tok <- modifyVar indexProgressToken $ fmap dupe . \case-        x@(Just _) -> pure x-        -- Create a token if we don't already have one-        Nothing -> do-          case lspEnv se of-            Nothing -> pure Nothing-            Just env -> LSP.runLspT env $ do-              u <- LSP.ProgressToken . LSP.InR . T.pack . show . hashUnique <$> liftIO Unique.newUnique-              -- TODO: Wait for the progress create response to use the token-              _ <- LSP.sendRequest LSP.SMethod_WindowWorkDoneProgressCreate (LSP.WorkDoneProgressCreateParams u) (const $ pure ())-              LSP.sendNotification LSP.SMethod_Progress $ LSP.ProgressParams u $-                toJSON $ LSP.WorkDoneProgressBegin-                  { _kind = LSP.AString @"begin"-                  ,  _title = "Indexing"-                  , _cancellable = Nothing-                  , _message = Nothing-                  , _percentage = Nothing-                  }-              pure (Just u)--      (!done, !remaining) <- atomically $ do-        done <- readTVar indexCompleted-        remaining <- HashMap.size <$> readTVar indexPending-        pure (done, remaining)-      let-        progressFrac :: Double-        progressFrac = fromIntegral done / fromIntegral (done + remaining)-        progressPct :: LSP.UInt-        progressPct = floor $ 100 * progressFrac--      whenJust (lspEnv se) $ \env -> whenJust tok $ \token -> LSP.runLspT env $-        LSP.sendNotification LSP.SMethod_Progress $ LSP.ProgressParams token $-          toJSON $-            case style of-                Percentage -> LSP.WorkDoneProgressReport-                    { _kind = LSP.AString @"report"-                    , _cancellable = Nothing-                    , _message = Nothing-                    , _percentage = Just progressPct-                    }-                Explicit -> LSP.WorkDoneProgressReport-                    { _kind = LSP.AString @"report"-                    , _cancellable = Nothing-                    , _message = Just $-                        T.pack " (" <> T.pack (show done) <> "/" <> T.pack (show $ done + remaining) <> ")..."-                    , _percentage = Nothing-                    }-                NoProgress -> LSP.WorkDoneProgressReport-                  { _kind = LSP.AString @"report"-                  , _cancellable = Nothing-                  , _message = Nothing-                  , _percentage = Nothing-                  }-+    pre = progressUpdate indexProgressReporting ProgressStarted     -- Report the progress once we are done indexing this file     post = do       mdone <- atomically $ do@@ -988,20 +909,16 @@         when (coerce $ ideTesting se) $           LSP.sendNotification (LSP.SMethod_CustomMethod (Proxy @"ghcide/reference/ready")) $             toJSON $ fromNormalizedFilePath srcPath-      whenJust mdone $ \done ->-        modifyVar_ indexProgressToken $ \tok -> do-          whenJust (lspEnv se) $ \env -> LSP.runLspT env $-            whenJust tok $ \token ->-              LSP.sendNotification LSP.SMethod_Progress  $ LSP.ProgressParams token $-                toJSON $-                LSP.WorkDoneProgressEnd-                  { _kind = LSP.AString @"end"-                  , _message = Just $ "Finished indexing " <> T.pack (show done) <> " files"-                  }-          -- We are done with the current indexing cycle, so destroy the token-          pure Nothing+      whenJust mdone $ \_ -> progressUpdate indexProgressReporting ProgressCompleted -writeAndIndexHieFile :: HscEnv -> ShakeExtras -> ModSummary -> NormalizedFilePath -> [GHC.AvailInfo] -> HieASTs Type -> BS.ByteString -> IO [FileDiagnostic]+writeAndIndexHieFile+  :: HscEnv -> ShakeExtras -> ModSummary -> NormalizedFilePath -> [GHC.AvailInfo]+#if MIN_VERSION_ghc(9,11,0)+  -> (HieASTs Type, NameEntityInfo)+#else+  -> HieASTs Type+#endif+  -> BS.ByteString -> IO [FileDiagnostic] writeAndIndexHieFile hscEnv se mod_summary srcPath exports ast source =   handleGenerationErrors dflags "extended interface write/compression" $ do     hf <- runHsc hscEnv $@@ -1028,16 +945,25 @@ 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+          )     ]  @@ -1046,9 +972,46 @@ -- Add the current ModSummary to the graph, along with the -- HomeModInfo's of all direct dependencies (by induction hypothesis all -- transitive dependencies will be contained in envs)-mergeEnvs :: HscEnv -> ModuleGraph -> ModSummary -> [HomeModInfo] -> [HscEnv] -> IO HscEnv-mergeEnvs env mg ms extraMods envs = do-#if MIN_VERSION_ghc(9,3,0)+mergeEnvs :: HscEnv+          -> ModuleGraph+          -> DependencyInformation+          -> ModSummary+          -> [HomeModInfo]+          -> [HscEnv]+          -> IO HscEnv+mergeEnvs env mg dep_info ms extraMods envs = do+#if MIN_VERSION_ghc(9,11,0)+    return $! loadModulesHome extraMods $+      let newHug = foldl' mergeHUG (hsc_HUG env) (map hsc_HUG envs) in+      (hscUpdateHUG (const newHug) env){+          hsc_mod_graph = mg,+          hsc_FC = (hsc_FC env)+            { addToFinderCache = \gwib@(GWIB im _) val ->+                  if moduleUnit im `elem` hsc_all_home_unit_ids env+                  then pure ()+                  else addToFinderCache (hsc_FC env) gwib val+            , lookupFinderCache = \gwib@(GWIB im _) ->+                  if moduleUnit im `elem` hsc_all_home_unit_ids env+                  then case lookupModuleFile (im { moduleUnit = RealUnit (Definite $ moduleUnit im) }) dep_info of+                         Nothing -> pure Nothing+                         Just fs -> let ml = fromJust $ do+                                              id <- lookupPathToId (depPathIdMap dep_info) fs+                                              artifactModLocation (idToModLocation (depPathIdMap dep_info) id)+                                    in pure $ Just $ InstalledFound ml im+                  else lookupFinderCache (hsc_FC env) gwib+            }+      }++    where+        mergeHUG (UnitEnvGraph a) (UnitEnvGraph b) = UnitEnvGraph $ Map.unionWith mergeHUE a b+        mergeHUE a b = a { homeUnitEnv_hpt = mergeUDFM (homeUnitEnv_hpt a) (homeUnitEnv_hpt b) }+        mergeUDFM = plusUDFM_C combineModules++        combineModules a b+          | HsSrcFile <- mi_hsc_src (hm_iface a) = a+          | otherwise = b++#elif MIN_VERSION_ghc(9,3,0)     let im  = Compat.installedModule (toUnitId $ moduleUnit $ ms_mod ms) (moduleName (ms_mod ms))         ifr = InstalledFound (ms_location ms) im         curFinderCache = Compat.extendInstalledModuleEnv Compat.emptyInstalledModuleEnv im ifr@@ -1082,33 +1045,9 @@           fcModules' <- newIORef $! foldl' (plusInstalledModuleEnv combineModuleLocations) cur fcModules           fcFiles' <- newIORef $! Map.unions fcFiles           pure $ FinderCache fcModules' fcFiles'--#else-    prevFinderCache <- concatFC <$> mapM (readIORef . hsc_FC) envs-    let im  = Compat.installedModule (toUnitId $ moduleUnit $ ms_mod ms) (moduleName (ms_mod ms))-        ifr = InstalledFound (ms_location ms) im-    newFinderCache <- newIORef $! Compat.extendInstalledModuleEnv prevFinderCache im ifr-    return $! loadModulesHome extraMods $-      env{-          hsc_HPT = foldMapBy mergeUDFM emptyUDFM hsc_HPT envs,-          hsc_FC = newFinderCache,-          hsc_mod_graph = mg-      }--    where-        mergeUDFM = plusUDFM_C combineModules-        combineModules a b-          | HsSrcFile <- mi_hsc_src (hm_iface a) = a-          | otherwise = b-    -- required because 'FinderCache':-    --  1) doesn't have a 'Monoid' instance,-    --  2) is abstract and doesn't export constructors-    -- To work around this, we coerce to the underlying type-    -- To remove this, I plan to upstream the missing Monoid instance-        concatFC :: [FinderCache] -> FinderCache-        concatFC = unsafeCoerce (mconcat @(Map InstalledModule InstalledFindResult)) #endif + withBootSuffix :: HscSource -> ModLocation -> ModLocation withBootSuffix HsBootFile = addBootSuffixLocnOut withBootSuffix _          = id@@ -1152,24 +1091,16 @@           convImport (L _ i) = (-#if !MIN_VERSION_ghc(9,3,0)-                               fmap sl_fs-#endif                                (ideclPkgQual i)                              , reLoc $ ideclName i)          msrImports = implicit_imports ++ imps -#if MIN_VERSION_ghc(9,3,0)         rn_pkg_qual = renameRawPkgQual (hsc_unit_env ppEnv)         rn_imps = fmap (\(pk, lmn@(L _ mn)) -> (rn_pkg_qual mn pk, lmn))         srcImports = rn_imps $ map convImport src_idecls         textualImports = rn_imps $ map convImport (implicit_imports ++ ordinary_imps)         ghc_prim_import = not (null _ghc_prim_imports)-#else-        srcImports = map convImport src_idecls-        textualImports = map convImport (implicit_imports ++ ordinary_imps)-#endif       -- Force bits that might keep the string buffer and DynFlags alive unnecessarily@@ -1185,18 +1116,14 @@      let modl = mkHomeModule (hscHomeUnit ppEnv) mod         sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile-        msrModSummary2 =+        msrModSummary =             ModSummary                 { ms_mod          = modl                 , ms_hie_date     = Nothing-#if MIN_VERSION_ghc(9,3,0)                 , ms_dyn_obj_date    = Nothing                 , ms_ghc_prim_import = ghc_prim_import                 , ms_hs_hash      = _src_hash -#else-                , ms_hs_date      = _modTime-#endif                 , ms_hsc_src      = sourceType                 -- The contents are used by the GetModSummary rule                 , ms_hspp_buf     = Just contents@@ -1210,8 +1137,8 @@                 , ms_textual_imps = textualImports                 } -    msrFingerprint <- liftIO $ computeFingerprint opts msrModSummary2-    (msrModSummary, msrHscEnv) <- liftIO $ initPlugins ppEnv msrModSummary2+    msrFingerprint <- liftIO $ computeFingerprint opts msrModSummary+    msrHscEnv <- liftIO $ Loader.initializePlugins (hscSetFlags (ms_hspp_opts msrModSummary) ppEnv)     return ModSummaryResult{..}     where         -- Compute a fingerprint from the contents of `ModSummary`,@@ -1221,19 +1148,24 @@                   put $ Util.uniq $ moduleNameFS $ moduleName ms_mod                   forM_ (ms_srcimps ++ ms_textual_imps) $ \(mb_p, m) -> do                     put $ Util.uniq $ moduleNameFS $ unLoc m-#if MIN_VERSION_ghc(9,3,0)                     case mb_p of-                      G.NoPkgQual -> pure ()+                      G.NoPkgQual    -> pure ()                       G.ThisPkg uid  -> put $ getKey $ getUnique uid                       G.OtherPkg uid -> put $ getKey $ getUnique uid-#else-                    whenJust mb_p $ put . Util.uniq-#endif             return $! Util.fingerprintFingerprints $                     [ Util.fingerprintString fp                     , fingerPrintImports+                    , modLocationFingerprint ms_location                     ] ++ map Util.fingerprintString opts +        modLocationFingerprint :: ModLocation -> Util.Fingerprint+        modLocationFingerprint ModLocation{..} = Util.fingerprintFingerprints $+            Util.fingerprintString <$> [ fromMaybe "" ml_hs_file+                                         , ml_hi_file+                                         , ml_dyn_hi_file+                                         , ml_obj_file+                                         , ml_dyn_obj_file+                                         , ml_hie_file]  -- | Parse only the module header parseHeader@@ -1250,7 +1182,7 @@    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 @@ -1264,9 +1196,9 @@         -- 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@@ -1283,20 +1215,29 @@        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-             hpm_annotations = mkApiAnns pst              psMessages = getPsMessages pst          in            do-               let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module+               let IdePreprocessedSource preproc_warns preproc_errs parsed = customPreprocessor rdr_module+               let attachNoStructuredError (span, msg) = (span, msg, Nothing) -               unless (null errs) $-                  throwE $ diagFromStrings sourceParser DiagnosticSeverity_Error errs+               unless (null preproc_errs) $+                  throwE $+                    diagFromStrings+                      sourceParser+                      DiagnosticSeverity_Error+                      (fmap attachNoStructuredError preproc_errs) -               let preproc_warnings = diagFromStrings sourceParser DiagnosticSeverity_Warning preproc_warns-               (parsed', msgs) <- liftIO $ applyPluginsParsedResultAction env ms hpm_annotations parsed psMessages+               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                 -- Just because we got a `POk`, it doesn't mean there@@ -1309,8 +1250,7 @@                -- 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,@@ -1323,11 +1263,7 @@                --   - filter out the .hs/.lhs source filename if we have one                --                let n_hspp  = normalise filename-#if MIN_VERSION_ghc(9,3,0)                    TempDir tmp_dir = tmpDir dflags-#else-                   tmp_dir = tmpDir dflags-#endif                    srcs0 = nubOrd $ filter (not . (tmp_dir `isPrefixOf`))                                   $ filter (/= n_hspp)                                   $ map normalise@@ -1343,9 +1279,9 @@                -- filter them out:                srcs2 <- liftIO $ filterM doesFileExist srcs1 -               let pm = ParsedModule ms parsed' srcs2 hpm_annotations-                   warnings = diagFromErrMsgs sourceParser dflags warns-               pure (warnings ++ preproc_warnings, pm)+               let pm = ParsedModule ms parsed' srcs2+                   warnings = diagFromGhcErrorMessages sourceParser dflags warns+               pure (warnings ++ preproc_warning_file_diagnostics, pm)  loadHieFile :: Compat.NameCacheUpdater -> FilePath -> IO GHC.HieFile loadHieFile ncu f = do@@ -1420,6 +1356,7 @@   , old_value   :: Maybe (HiFileResult, FileVersion)   , get_file_version :: NormalizedFilePath -> m (Maybe FileVersion)   , get_linkable_hashes :: [NormalizedFilePath] -> m [BS.ByteString]+  , get_module_graph :: m DependencyInformation   , regenerate  :: Maybe LinkableType -> m ([FileDiagnostic], Maybe HiFileResult) -- ^ Action to regenerate an interface   } @@ -1474,14 +1411,9 @@         -- ncu and read_dflags are only used in GHC >= 9.4         let _ncu = hsc_NC sessionWithMsDynFlags             _read_dflags = hsc_dflags sessionWithMsDynFlags-#if MIN_VERSION_ghc(9,3,0)         read_result <- liftIO $ readIface _read_dflags _ncu mod iface_file-#else-        read_result <- liftIO $ initIfaceCheck (text "readIface") sessionWithMsDynFlags-                              $ readIface mod iface_file-#endif         case read_result of-          Util.Failed{} -> return Nothing+          Util.Failed{}        -> return Nothing           -- important to call `shareUsages` here before checkOldIface           -- consults `mi_usages`           Util.Succeeded iface -> return $ Just (shareUsages iface)@@ -1489,13 +1421,9 @@     -- If mb_old_iface is nothing then checkOldIface will load it for us     -- given that the source is unmodified     (recomp_iface_reqd, mb_checked_iface)-#if MIN_VERSION_ghc(9,3,0)       <- liftIO $ checkOldIface sessionWithMsDynFlags ms _old_iface >>= \case         UpToDateItem x -> pure (UpToDate, Just x)         OutOfDateItem reason x -> pure (NeedsRecompile reason, x)-#else-      <- liftIO $ checkOldIface sessionWithMsDynFlags ms _sourceMod mb_old_iface-#endif      let do_regenerate _reason = withTrace "regenerate interface" $ \setTag -> do           setTag "Module" $ moduleNameString $ moduleName mod@@ -1511,7 +1439,7 @@                    | not (mi_used_th iface) = emptyModuleEnv                    | otherwise = parseRuntimeDeps (md_anns details)              -- Peform the fine grained recompilation check for TH-             maybe_recomp <- checkLinkableDependencies session get_linkable_hashes runtime_deps+             maybe_recomp <- checkLinkableDependencies session get_linkable_hashes get_module_graph runtime_deps              case maybe_recomp of                Just msg -> do_regenerate msg                Nothing@@ -1548,20 +1476,10 @@ -- the runtime dependencies of the module, to check if any of them are out of date -- Hopefully 'runtime_deps' will be empty if the module didn't actually use TH -- See Note [Recompilation avoidance in the presence of TH]-checkLinkableDependencies :: MonadIO m => HscEnv -> ([NormalizedFilePath] -> m [BS.ByteString]) -> ModuleEnv BS.ByteString -> m (Maybe RecompileRequired)-checkLinkableDependencies hsc_env get_linkable_hashes runtime_deps = do-#if MIN_VERSION_ghc(9,3,0)-  moduleLocs <- liftIO $ readIORef (fcModuleCache $ hsc_FC hsc_env)-#else-  moduleLocs <- liftIO $ readIORef (hsc_FC hsc_env)-#endif-  let go (mod, hash) = do-        ifr <- lookupInstalledModuleEnv moduleLocs $ Compat.installedModule (toUnitId $ moduleUnit mod) (moduleName mod)-        case ifr of-          InstalledFound loc _ -> do-            hs <- ml_hs_file loc-            pure (toNormalizedFilePath' hs,hash)-          _ -> Nothing+checkLinkableDependencies :: MonadIO m => HscEnv -> ([NormalizedFilePath] -> m [BS.ByteString]) -> m DependencyInformation -> ModuleEnv BS.ByteString -> m (Maybe RecompileRequired)+checkLinkableDependencies hsc_env get_linkable_hashes get_module_graph runtime_deps = do+  graph <- get_module_graph+  let go (mod, hash) = (,hash) <$> lookupModuleFile mod graph       hs_files = mapM go (moduleEnvToList runtime_deps)   case hs_files of     Nothing -> error "invalid module graph"@@ -1575,27 +1493,16 @@  recompBecause :: String -> RecompileRequired recompBecause =-#if MIN_VERSION_ghc(9,3,0)                 NeedsRecompile .-#endif                 RecompBecause-#if MIN_VERSION_ghc(9,3,0)               . CustomReason-#endif -#if MIN_VERSION_ghc(9,3,0) data SourceModified = SourceModified | SourceUnmodified deriving (Eq, Ord, Show)-#endif  showReason :: RecompileRequired -> String-showReason UpToDate          = "UpToDate"-#if MIN_VERSION_ghc(9,3,0)-showReason (NeedsRecompile MustCompile)    = "MustCompile"-showReason (NeedsRecompile s) = printWithoutUniques s-#else-showReason MustCompile       = "MustCompile"-showReason (RecompBecause s) = s-#endif+showReason UpToDate                     = "UpToDate"+showReason (NeedsRecompile MustCompile) = "MustCompile"+showReason (NeedsRecompile s)           = printWithoutUniques s  mkDetailsFromIface :: HscEnv -> ModIface -> IO ModDetails mkDetailsFromIface session iface = do@@ -1610,11 +1517,7 @@       this_mod = mi_module iface   types_var <- newIORef (md_types details)   let hsc_env' = hscUpdateHPT act (session {-#if MIN_VERSION_ghc(9,3,0)         hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(this_mod, types_var)])-#else-        hsc_type_env_var = Just (this_mod, types_var)-#endif         })   core_binds <- initIfaceCheck (text "l") hsc_env' $ typecheckCoreFile this_mod types_var core_file       -- Implicit binds aren't saved, so we need to regenerate them ourselves.@@ -1622,11 +1525,13 @@       tyCons = typeEnvTyCons (md_types details) #if MIN_VERSION_ghc(9,5,0)   -- In GHC 9.6, the implicit binds are tidied and part of core_binds-  pure $ CgGuts this_mod tyCons core_binds [] NoStubs [] mempty (emptyHpcInfo False) Nothing []-#elif MIN_VERSION_ghc(9,3,0)-  pure $ CgGuts this_mod tyCons (_implicit_binds ++ core_binds) [] NoStubs [] mempty (emptyHpcInfo False) Nothing []+  pure $ CgGuts this_mod tyCons core_binds [] NoStubs [] mempty+#if !MIN_VERSION_ghc(9,11,0)+                (emptyHpcInfo False)+#endif+                Nothing [] #else-  pure $ CgGuts this_mod tyCons (_implicit_binds ++ core_binds) NoStubs [] [] (emptyHpcInfo False) Nothing []+  pure $ CgGuts this_mod tyCons (_implicit_binds ++ core_binds) [] NoStubs [] mempty (emptyHpcInfo False) Nothing [] #endif  coreFileToLinkable :: LinkableType -> HscEnv -> ModSummary -> ModIface -> ModDetails -> CoreFile -> UTCTime -> IO ([FileDiagnostic], Maybe HomeModInfo)@@ -1643,45 +1548,23 @@ getDocsBatch   :: HscEnv   -> [Name]-#if MIN_VERSION_ghc(9,3,0)   -> IO [Either String (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))]-#else-  -> IO [Either String (Maybe HsDocString, IntMap HsDocString)]-#endif getDocsBatch hsc_env _names = do     res <- initIfaceLoad hsc_env $ forM _names $ \name ->         case nameModule_maybe name of             Nothing -> return (Left $ NameHasNoModule name)             Just mod -> do              ModIface {-#if MIN_VERSION_ghc(9,3,0)                         mi_docs = Just Docs{ docs_mod_hdr = mb_doc_hdr                                       , docs_decls = dmap                                       , docs_args = amap                                       }-#else-                        mi_doc_hdr = mb_doc_hdr-                      , mi_decl_docs = DeclDocMap dmap-                      , mi_arg_docs = ArgDocMap amap-#endif                       } <- loadSysInterface (text "getModuleInterface") mod-#if MIN_VERSION_ghc(9,3,0)              if isNothing mb_doc_hdr && isNullUniqMap dmap && isNullUniqMap amap-#else-             if isNothing mb_doc_hdr && Map.null dmap && null amap-#endif                then pure (Left (NoDocsInIface mod $ compiled name))                else pure (Right (-#if MIN_VERSION_ghc(9,3,0)                                   lookupUniqMap dmap name,-#else-                                  Map.lookup name dmap ,-#endif-#if MIN_VERSION_ghc(9,3,0)                                   lookupWithDefaultUniqMap amap mempty name))-#else-                                  Map.findWithDefault mempty name amap))-#endif     return $ map (first $ T.unpack . printOutputable) res   where     compiled n =@@ -1711,7 +1594,7 @@         res <- initIfaceLoad hsc_env $ importDecl name         case res of           Util.Succeeded x -> return (Just x)-          _ -> return Nothing+          _                -> return Nothing   where     exceptionHandle x = x `catch` \(_ :: IOEnvFailure) -> pure Nothing @@ -1721,6 +1604,22 @@       rep c | isPathSeparator c = '_'       rep ':' = '_'       rep c = c++-- | Initialising plugins looks in the finder cache, but we know that the plugin doesn't come from a home module, so don't+-- error out when we don't find it+setNonHomeFCHook :: HscEnv -> HscEnv+setNonHomeFCHook hsc_env =+#if MIN_VERSION_ghc(9,11,0)+  hsc_env { hsc_FC = (hsc_FC hsc_env)+                        { lookupFinderCache = \m@(GWIB im _) ->+                            if moduleUnit im `elem` hsc_all_home_unit_ids hsc_env+                            then pure (Just $ InstalledNotFound [] Nothing)+                            else lookupFinderCache (hsc_FC hsc_env) m+                        }+          }+#else+  hsc_env+#endif  {- Note [Guidelines For Using CPP In GHCIDE Import Statements]    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -3,7 +3,10 @@ {-# LANGUAGE TypeFamilies #-}  module Development.IDE.Core.FileStore(+    getFileModTimeContents,     getFileContents,+    getUriContents,+    getVersionedTextDoc,     setFileModified,     setSomethingModified,     fileStoreRules,@@ -18,12 +21,13 @@     isWatchSupported,     registerFileWatches,     shareFilePath,-    Log(..)+    Log(..),     ) where  import           Control.Concurrent.STM.Stats                 (STM, atomically) import           Control.Concurrent.STM.TQueue                (writeTQueue) import           Control.Exception+import           Control.Lens                                 ((^.)) import           Control.Monad.Extra import           Control.Monad.IO.Class import qualified Data.Binary                                  as B@@ -33,6 +37,7 @@ import           Data.IORef import qualified Data.Text                                    as T import qualified Data.Text                                    as Text+import           Data.Text.Utf16.Rope.Mixed                   (Rope) import           Data.Time import           Data.Time.Clock.POSIX import           Development.IDE.Core.FileUtils@@ -56,13 +61,16 @@                                                                logWith, viaShow,                                                                (<+>)) import qualified Ide.Logger                                   as L-import           Ide.Plugin.Config                            (CheckParents (..),-                                                               Config)+import           Ide.Types+import qualified Language.LSP.Protocol.Lens                   as L import           Language.LSP.Protocol.Message                (toUntypedRegistration) import qualified Language.LSP.Protocol.Message                as LSP import           Language.LSP.Protocol.Types                  (DidChangeWatchedFilesRegistrationOptions (DidChangeWatchedFilesRegistrationOptions),                                                                FileSystemWatcher (..),-                                                               _watchers)+                                                               TextDocumentIdentifier (..),+                                                               VersionedTextDocumentIdentifier (..),+                                                               _watchers,+                                                               uriToNormalizedFilePath) import qualified Language.LSP.Protocol.Types                  as LSP import qualified Language.LSP.Server                          as LSP import           Language.LSP.VFS@@ -175,20 +183,20 @@  getFileContentsImpl     :: NormalizedFilePath-    -> Action ([FileDiagnostic], Maybe (FileVersion, Maybe T.Text))+    -> Action ([FileDiagnostic], Maybe (FileVersion, Maybe Rope)) getFileContentsImpl file = do     -- need to depend on modification time to introduce a dependency with Cutoff     time <- use_ GetModificationTime file     res <- do         mbVirtual <- getVirtualFile file-        pure $ virtualFileText <$> mbVirtual+        pure $ _file_text <$> mbVirtual     pure ([], Just (time, res))  -- | Returns the modification time and the contents. --   For VFS paths, the modification time is the current time.-getFileContents :: NormalizedFilePath -> Action (UTCTime, Maybe T.Text)-getFileContents f = do-    (fv, txt) <- use_ GetFileContents f+getFileModTimeContents :: NormalizedFilePath -> Action (UTCTime, Maybe Rope)+getFileModTimeContents f = do+    (fv, contents) <- use_ GetFileContents f     modTime <- case modificationTime fv of       Just t -> pure t       Nothing -> do@@ -198,8 +206,30 @@           _ -> do             posix <- getModTime $ fromNormalizedFilePath f             pure $ posixSecondsToUTCTime posix-    return (modTime, txt)+    return (modTime, contents) +getFileContents :: NormalizedFilePath -> Action (Maybe Rope)+getFileContents f = snd <$> use_ GetFileContents f++getUriContents :: NormalizedUri -> Action (Maybe Rope)+getUriContents uri =+    join <$> traverse getFileContents (uriToNormalizedFilePath uri)++-- | Given a text document identifier, annotate it with the latest version.+--+-- Like Language.LSP.Server.Core.getVersionedTextDoc, but gets the virtual file+-- from the Shake VFS rather than the LSP VFS.+getVersionedTextDoc :: TextDocumentIdentifier -> Action VersionedTextDocumentIdentifier+getVersionedTextDoc doc = do+  let uri = doc ^. L.uri+  mvf <-+    maybe (pure Nothing) getVirtualFile $+        uriToNormalizedFilePath $ toNormalizedUri uri+  let ver = case mvf of+        Just (VirtualFile lspver _ _) -> lspver+        Nothing                       -> 0+  return (VersionedTextDocumentIdentifier uri ver)+ fileStoreRules :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules () fileStoreRules recorder isWatched = do     getModificationTimeRule recorder@@ -303,4 +333,3 @@           Just v  -> (km, v)           Nothing -> (HashMap.insert k k km, k) {-# NOINLINE shareFilePath  #-}-

@@ -29,6 +29,7 @@ import           Control.Concurrent.STM.Stats             (atomically,                                                            modifyTVar') import           Data.Aeson                               (toJSON)+import qualified Data.Aeson                               as Aeson import qualified Data.ByteString                          as BS import           Data.Maybe                               (catMaybes) import           Development.IDE.Core.ProgressReporting@@ -141,7 +142,7 @@                 toJSON $ map fromNormalizedFilePath files      signal (Proxy @"kick/start")-    liftIO $ progressUpdate progress KickStarted+    liftIO $ progressUpdate progress ProgressNewStarted      -- Update the exports map     results <- uses GenerateCore files@@ -152,7 +153,7 @@     let mguts = catMaybes results     void $ liftIO $ atomically $ modifyTVar' exportsMap (updateExportsMapMg mguts) -    liftIO $ progressUpdate progress KickCompleted+    liftIO $ progressUpdate progress ProgressCompleted      GarbageCollectVar var <- getIdeGlobalAction     garbageCollectionScheduled <- liftIO $ readVar var

@@ -1,6 +1,6 @@ {-# LANGUAGE GADTs #-} module Development.IDE.Core.PluginUtils-(-- Wrapped Action functions+(-- * Wrapped Action functions   runActionE , runActionMT , useE@@ -9,13 +9,13 @@ , usesMT , useWithStaleE , useWithStaleMT--- Wrapped IdeAction functions+-- * Wrapped IdeAction functions , runIdeActionE , runIdeActionMT , useWithStaleFastE , useWithStaleFastMT , uriToFilePathE--- Wrapped PositionMapping functions+-- * Wrapped PositionMapping functions , toCurrentPositionE , toCurrentPositionMT , fromCurrentPositionE@@ -23,8 +23,16 @@ , toCurrentRangeE , toCurrentRangeMT , fromCurrentRangeE-, fromCurrentRangeMT) where+, fromCurrentRangeMT+-- * Diagnostics+, activeDiagnosticsInRange+, activeDiagnosticsInRangeMT+-- * Formatting handlers+, mkFormattingHandlers) where +import           Control.Concurrent.STM+import           Control.Lens                         ((^.))+import           Control.Monad.Error.Class            (MonadError (throwError)) import           Control.Monad.Extra import           Control.Monad.IO.Class import           Control.Monad.Reader                 (runReaderT)@@ -32,7 +40,10 @@ import           Control.Monad.Trans.Maybe import           Data.Functor.Identity import qualified Data.Text                            as T+import qualified Data.Text.Utf16.Rope.Mixed           as Rope+import           Development.IDE.Core.FileStore import           Development.IDE.Core.PositionMapping+import           Development.IDE.Core.Service         (runAction) import           Development.IDE.Core.Shake           (IdeAction, IdeRule,                                                        IdeState (shakeExtras),                                                        mkDelayedAction,@@ -40,11 +51,17 @@ import qualified Development.IDE.Core.Shake           as Shake import           Development.IDE.GHC.Orphans          () import           Development.IDE.Graph                hiding (ShakeValue)+import           Development.IDE.Types.Diagnostics import           Development.IDE.Types.Location       (NormalizedFilePath) import qualified Development.IDE.Types.Location       as Location import qualified Ide.Logger                           as Logger import           Ide.Plugin.Error+import           Ide.PluginUtils                      (rangesOverlap)+import           Ide.Types+import qualified Language.LSP.Protocol.Lens           as LSP+import           Language.LSP.Protocol.Message        (SMethod (..)) import qualified Language.LSP.Protocol.Types          as LSP+import qualified StmContainers.Map                    as STM  -- ---------------------------------------------------------------------------- -- Action wrappers@@ -162,3 +179,77 @@ -- |MaybeT version of `fromCurrentRange` fromCurrentRangeMT :: Monad m => PositionMapping -> LSP.Range -> MaybeT m LSP.Range fromCurrentRangeMT mapping = MaybeT . pure . fromCurrentRange mapping++-- ----------------------------------------------------------------------------+-- Diagnostics+-- ----------------------------------------------------------------------------++-- | @'activeDiagnosticsInRangeMT' shakeExtras nfp range@ computes the+-- 'FileDiagnostic' 's that HLS produced and overlap with the given @range@.+--+-- This function is to be used whenever we need an authoritative source of truth+-- for which diagnostics are shown to the user.+-- These diagnostics can be used to provide various IDE features, for example+-- CodeActions, CodeLenses, or refactorings.+--+-- However, why do we need this when computing 'CodeAction's? A 'CodeActionParam'+-- has the 'CodeActionContext' which already contains the diagnostics!+-- But according to the LSP docs, the server shouldn't rely that these Diagnostic+-- are actually up-to-date and accurately reflect the state of the document.+--+-- From the LSP docs:+-- > An array of diagnostics known on the client side overlapping the range+-- > provided to the `textDocument/codeAction` request. They are provided so+-- > that the server knows which errors are currently presented to the user+-- > for the given range. There is no guarantee that these accurately reflect+-- > the error state of the resource. The primary parameter+-- > to compute code actions is the provided range.+--+-- Thus, even when the client sends us the context, we should compute the+-- diagnostics on the server side.+activeDiagnosticsInRangeMT :: MonadIO m => Shake.ShakeExtras -> NormalizedFilePath -> LSP.Range -> MaybeT m [FileDiagnostic]+activeDiagnosticsInRangeMT ide nfp range = do+    MaybeT $ liftIO $ atomically $ do+        mDiags <- STM.lookup (LSP.normalizedFilePathToUri nfp) (Shake.publishedDiagnostics ide)+        case mDiags of+            Nothing -> pure Nothing+            Just fileDiags -> do+                pure $ Just $ filter diagRangeOverlaps fileDiags+    where+        diagRangeOverlaps = \fileDiag ->+            rangesOverlap range (fileDiag ^. fdLspDiagnosticL . LSP.range)++-- | Just like 'activeDiagnosticsInRangeMT'. See the docs of 'activeDiagnosticsInRangeMT' for details.+activeDiagnosticsInRange :: MonadIO m => Shake.ShakeExtras -> NormalizedFilePath -> LSP.Range -> m (Maybe [FileDiagnostic])+activeDiagnosticsInRange ide nfp range = runMaybeT (activeDiagnosticsInRangeMT ide nfp range)++-- ----------------------------------------------------------------------------+-- Formatting handlers+-- ----------------------------------------------------------------------------++-- `mkFormattingHandlers` was moved here from hls-plugin-api package so that+-- `mkFormattingHandlers` can refer to `IdeState`. `IdeState` is defined in the+-- ghcide package, but hls-plugin-api does not depend on ghcide, so `IdeState`+-- is not in scope there.++mkFormattingHandlers :: FormattingHandler IdeState -> PluginHandlers IdeState+mkFormattingHandlers f = mkPluginHandler SMethod_TextDocumentFormatting ( provider SMethod_TextDocumentFormatting)+                      <> mkPluginHandler SMethod_TextDocumentRangeFormatting (provider SMethod_TextDocumentRangeFormatting)+  where+    provider :: forall m. FormattingMethod m => SMethod m -> PluginMethodHandler IdeState m+    provider m ide _pid params+      | Just nfp <- LSP.uriToNormalizedFilePath $ LSP.toNormalizedUri uri = do+        contentsMaybe <- liftIO $ runAction "mkFormattingHandlers" ide $ getFileContents nfp+        case contentsMaybe of+          Just contents -> do+            let (typ, mtoken) = case m of+                  SMethod_TextDocumentFormatting -> (FormatText, params ^. LSP.workDoneToken)+                  SMethod_TextDocumentRangeFormatting -> (FormatRange (params ^. LSP.range), params ^. LSP.workDoneToken)+                  _ -> Prelude.error "mkFormattingHandlers: impossible"+            f ide mtoken typ (Rope.toText contents) nfp opts+          Nothing -> throwError $ PluginInvalidParams $ T.pack $ "Formatter plugin: could not get file contents for " ++ show uri++      | otherwise = throwError $ PluginInvalidParams $ T.pack $ "Formatter plugin: uriToFilePath failed for: " ++ show uri+      where+        uri = params ^. LSP.textDocument . LSP.uri+        opts = params ^. LSP.options

@@ -28,15 +28,11 @@ import           Development.IDE.Types.Diagnostics import           Development.IDE.Types.Location import qualified GHC.LanguageExtensions            as LangExt+import qualified GHC.Runtime.Loader                as Loader+import           GHC.Utils.Logger                  (LogFlags (..)) import           System.FilePath import           System.IO.Extra --- See Note [Guidelines For Using CPP In GHCIDE Import Statements]--#if MIN_VERSION_ghc(9,3,0)-import           GHC.Utils.Logger                  (LogFlags (..))-#endif- -- | Given a file and some contents, apply any necessary preprocessors, --   e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies. preprocessor :: HscEnv -> FilePath -> Maybe Util.StringBuffer -> ExceptT [FileDiagnostic] IO (Util.StringBuffer, [String], HscEnv, Util.Fingerprint)@@ -88,11 +84,7 @@   where     logAction :: IORef [CPPLog] -> LogActionCompat     logAction cppLogs dflags _reason severity srcSpan _style msg = do-#if MIN_VERSION_ghc(9,3,0)       let cppLog = CPPLog (fromMaybe SevWarning severity) srcSpan $ T.pack $ renderWithContext (log_default_user_context dflags) msg-#else-      let cppLog = CPPLog severity srcSpan $ T.pack $ showSDoc dflags msg-#endif       modifyIORef cppLogs (cppLog :)  @@ -112,7 +104,7 @@  diagsFromCPPLogs :: FilePath -> [CPPLog] -> [FileDiagnostic] diagsFromCPPLogs filename logs =-  map (\d -> (toNormalizedFilePath' filename, ShowDiag, cppDiagToDiagnostic d)) $+  map (\d -> ideErrorFromLspDiag (cppDiagToDiagnostic d) (toNormalizedFilePath' filename) Nothing) $     go [] logs   where     -- On errors, CPP calls logAction with a real span for the initial log and@@ -152,17 +144,13 @@     -> Util.StringBuffer     -> IO (Either [FileDiagnostic] ([String], HscEnv)) parsePragmasIntoHscEnv env fp contents = catchSrcErrors dflags0 "pragmas" $ do-#if MIN_VERSION_ghc(9,3,0)     let (_warns,opts) = getOptions (initParserOpts dflags0) contents fp-#else-    let opts = getOptions dflags0 contents fp-#endif      -- Force bits that might keep the dflags and stringBuffer alive unnecessarily     evaluate $ rnf opts      (dflags, _, _) <- parseDynamicFilePragma dflags0 opts-    hsc_env' <- initializePlugins (hscSetFlags dflags env)+    hsc_env' <- Loader.initializePlugins (hscSetFlags dflags env)     return (map unLoc opts, hscSetFlags (disableWarningsAsErrors $ hsc_dflags hsc_env') hsc_env')   where dflags0 = hsc_dflags env 

@@ -1,17 +1,25 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies        #-}+ module Development.IDE.Core.ProgressReporting-  ( ProgressEvent(..)-  , ProgressReporting(..)-  , noProgressReporting-  , progressReporting-  -- utilities, reexported for use in Core.Shake-  , mRunLspT-  , mRunLspTCallback-  -- for tests-  , recordProgress-  , InProgressState(..)+  ( ProgressEvent (..),+    PerFileProgressReporting (..),+    ProgressReporting,+    noPerFileProgressReporting,+    progressReporting,+    progressReportingNoTrace,+    -- utilities, reexported for use in Core.Shake+    mRunLspT,+    mRunLspTCallback,+    -- for tests+    recordProgress,+    InProgressState (..),+    progressStop,+    progressUpdate   )-   where+where +import           Control.Concurrent.STM         (STM) import           Control.Concurrent.STM.Stats   (TVar, atomically,                                                  atomicallyNamed, modifyTVar',                                                  newTVarIO, readTVar, retry)@@ -23,7 +31,6 @@ import           Data.Functor                   (($>)) import qualified Data.Text                      as T import           Development.IDE.GHC.Orphans    ()-import           Development.IDE.Graph          hiding (ShakeValue) import           Development.IDE.Types.Location import           Development.IDE.Types.Options import qualified Focus@@ -33,119 +40,197 @@                                                  withProgress) import qualified Language.LSP.Server            as LSP import qualified StmContainers.Map              as STM-import           UnliftIO                       (Async, async, cancel)+import           UnliftIO                       (Async, async, bracket, cancel)  data ProgressEvent-    = KickStarted-    | KickCompleted+  = ProgressNewStarted+  | ProgressCompleted+  | ProgressStarted -data ProgressReporting  = ProgressReporting-  { progressUpdate :: ProgressEvent -> IO ()-  , inProgress     :: forall a. NormalizedFilePath -> Action a -> Action a-  , progressStop   :: IO ()+data ProgressReporting = ProgressReporting+  { _progressUpdate :: ProgressEvent -> IO (),+    _progressStop   :: IO ()+    -- ^ we are using IO here because creating and stopping the `ProgressReporting`+    -- is different from how we use it.   } -noProgressReporting :: IO ProgressReporting-noProgressReporting = return $ ProgressReporting-  { progressUpdate = const $ pure ()-  , inProgress = const id-  , progressStop   = pure ()+data PerFileProgressReporting = PerFileProgressReporting+  {+    inProgress             :: forall a. NormalizedFilePath -> IO a -> IO a,+    -- ^ see Note [ProgressReporting API and InProgressState]+    progressReportingInner :: ProgressReporting   } +class ProgressReporter a where+    progressUpdate ::  a -> ProgressEvent -> IO ()+    progressStop :: a -> IO ()++instance ProgressReporter ProgressReporting where+    progressUpdate = _progressUpdate+    progressStop = _progressStop++instance ProgressReporter PerFileProgressReporting where+    progressUpdate = _progressUpdate . progressReportingInner+    progressStop = _progressStop . progressReportingInner++{- Note [ProgressReporting API and InProgressState]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The progress of tasks can be tracked in two ways:++1. `ProgressReporting`: we have an internal state that actively tracks the progress.+   Changes to the progress are made directly to this state.++2. `ProgressReporting`: there is an external state that tracks the progress.+   The external state is converted into an STM Int for the purpose of reporting progress.++The `inProgress` function is only useful when we are using `ProgressReporting`.+-}++noProgressReporting :: ProgressReporting+noProgressReporting = ProgressReporting+      { _progressUpdate = const $ pure (),+        _progressStop = pure ()+      }+noPerFileProgressReporting :: IO PerFileProgressReporting+noPerFileProgressReporting =+  return $+    PerFileProgressReporting+      { inProgress = const id,+        progressReportingInner = noProgressReporting+      }+ -- | State used in 'delayedProgressReporting' data State-    = NotStarted-    | Stopped-    | Running (Async ())+  = NotStarted+  | Stopped+  | Running (Async ())  -- | State transitions used in 'delayedProgressReporting' data Transition = Event ProgressEvent | StopProgress  updateState :: IO () -> Transition -> State -> IO State-updateState _      _                    Stopped       = pure Stopped-updateState start (Event KickStarted)   NotStarted    = Running <$> async start-updateState start (Event KickStarted)   (Running job) = cancel job >> Running <$> async start-updateState _     (Event KickCompleted) (Running job) = cancel job $> NotStarted-updateState _     (Event KickCompleted) st            = pure st-updateState _     StopProgress          (Running job) = cancel job $> Stopped-updateState _     StopProgress          st            = pure st+updateState _ _ Stopped = pure Stopped+updateState start (Event ProgressNewStarted) NotStarted = Running <$> async start+updateState start (Event ProgressNewStarted) (Running job) = cancel job >> Running <$> async start+updateState start (Event ProgressStarted) NotStarted = Running <$> async start+updateState _ (Event ProgressStarted) (Running job) = return (Running job)+updateState _ (Event ProgressCompleted) (Running job) = cancel job $> NotStarted+updateState _ (Event ProgressCompleted) st = pure st+updateState _ StopProgress (Running job) = cancel job $> Stopped+updateState _ StopProgress st = pure st  -- | Data structure to track progress across the project-data InProgressState = InProgressState-    { todoVar    :: TVar Int  -- ^ Number of files to do-    , doneVar    :: TVar Int  -- ^ Number of files done-    , currentVar :: STM.Map NormalizedFilePath Int-    }+-- see Note [ProgressReporting API and InProgressState]+data InProgressState+  = InProgressState+      { -- | Number of files to do+        todoVar    :: TVar Int,+        -- | Number of files done+        doneVar    :: TVar Int,+        currentVar :: STM.Map NormalizedFilePath Int+      }  newInProgress :: IO InProgressState newInProgress = InProgressState <$> newTVarIO 0 <*> newTVarIO 0 <*> STM.newIO  recordProgress :: InProgressState -> NormalizedFilePath -> (Int -> Int) -> IO ()-recordProgress InProgressState{..} file shift = do-    (prev, new) <- atomicallyNamed "recordProgress" $ STM.focus alterPrevAndNew file currentVar-    atomicallyNamed "recordProgress2" $ do-        case (prev,new) of-            (Nothing,0) -> modifyTVar' doneVar (+1) >> modifyTVar' todoVar (+1)-            (Nothing,_) -> modifyTVar' todoVar (+1)-            (Just 0, 0) -> pure ()-            (Just 0, _) -> modifyTVar' doneVar pred-            (Just _, 0) -> modifyTVar' doneVar (+1)-            (Just _, _) -> pure ()+recordProgress InProgressState {..} file shift = do+  (prev, new) <- atomicallyNamed "recordProgress" $ STM.focus alterPrevAndNew file currentVar+  atomicallyNamed "recordProgress2" $ case (prev, new) of+    (Nothing, 0) -> modifyTVar' doneVar (+ 1) >> modifyTVar' todoVar (+ 1)+    (Nothing, _) -> modifyTVar' todoVar (+ 1)+    (Just 0, 0)  -> pure ()+    (Just 0, _)  -> modifyTVar' doneVar pred+    (Just _, 0)  -> modifyTVar' doneVar (+ 1)+    (Just _, _)  -> pure ()   where     alterPrevAndNew = do-        prev <- Focus.lookup-        Focus.alter alter-        new <- Focus.lookupWithDefault 0-        return (prev, new)+      prev <- Focus.lookup+      Focus.alter alter+      new <- Focus.lookupWithDefault 0+      return (prev, new)     alter x = let x' = maybe (shift 0) shift x in Just x' -progressReporting-  :: Maybe (LSP.LanguageContextEnv c)-  -> ProgressReportingStyle-  -> IO ProgressReporting-progressReporting Nothing _optProgressStyle = noProgressReporting-progressReporting (Just lspEnv) optProgressStyle = do-    inProgressState <- newInProgress-    progressState <- newVar NotStarted-    let progressUpdate event = updateStateVar $ Event event-        progressStop  = updateStateVar StopProgress-        updateStateVar = modifyVar_ progressState . updateState (lspShakeProgressNew inProgressState)-        inProgress = updateStateForFile inProgressState-    return ProgressReporting{..}-    where-        lspShakeProgressNew :: InProgressState -> IO ()-        lspShakeProgressNew InProgressState{..} =-            LSP.runLspT lspEnv $ withProgress "Processing" Nothing NotCancellable $ \update -> loop update 0-            where-                loop _ _ | optProgressStyle == NoProgress = forever $ liftIO $ threadDelay maxBound-                loop update prevPct = do-                    (todo, done, nextPct) <- liftIO $ atomically $ do-                        todo <- readTVar todoVar-                        done <- readTVar doneVar-                        let nextFrac :: Double-                            nextFrac = if todo == 0 then 0 else fromIntegral done / fromIntegral todo-                            nextPct :: UInt-                            nextPct = floor $ 100 * nextFrac-                        when (nextPct == prevPct) retry-                        pure (todo, done, nextPct) -                    _ <- update (ProgressAmount (Just nextPct) (Just $ T.pack $ show done <> "/" <> show todo))-                    loop update nextPct-        updateStateForFile inProgress file = actionBracket (f succ) (const $ f pred) . const-            -- This functions are deliberately eta-expanded to avoid space leaks.-            -- Do not remove the eta-expansion without profiling a session with at-            -- least 1000 modifications.-            where-              f shift = recordProgress inProgress file shift+-- | `progressReportingNoTrace` initiates a new progress reporting session.+-- It functions similarly to `progressReporting`, but it utilizes an external state for progress tracking.+-- Refer to Note [ProgressReporting API and InProgressState] for more details.+progressReportingNoTrace ::+  STM Int ->+  STM Int ->+  Maybe (LSP.LanguageContextEnv c) ->+  T.Text ->+  ProgressReportingStyle ->+  IO ProgressReporting+progressReportingNoTrace _ _ Nothing _title _optProgressStyle = return noProgressReporting+progressReportingNoTrace todo done (Just lspEnv) title optProgressStyle = do+  progressState <- newVar NotStarted+  let _progressUpdate event = liftIO $ updateStateVar $ Event event+      _progressStop = updateStateVar StopProgress+      updateStateVar = modifyVar_ progressState . updateState (progressCounter lspEnv title optProgressStyle todo done)+  return ProgressReporting {..} -mRunLspT :: Applicative m => Maybe (LSP.LanguageContextEnv c ) -> LSP.LspT c m () -> m ()+-- | `progressReporting` initiates a new progress reporting session.+-- It necessitates the active tracking of progress using the `inProgress` function.+-- Refer to Note [ProgressReporting API and InProgressState] for more details.+progressReporting ::+  Maybe (LSP.LanguageContextEnv c) ->+  T.Text ->+  ProgressReportingStyle ->+  IO PerFileProgressReporting+progressReporting Nothing _title _optProgressStyle = noPerFileProgressReporting+progressReporting (Just lspEnv) title optProgressStyle = do+  inProgressState <- newInProgress+  progressReportingInner <- progressReportingNoTrace (readTVar $ todoVar inProgressState)+                                (readTVar $ doneVar inProgressState) (Just lspEnv) title optProgressStyle+  let+    inProgress :: NormalizedFilePath -> IO a -> IO a+    inProgress = updateStateForFile inProgressState+  return PerFileProgressReporting {..}+  where+    updateStateForFile inProgress file = UnliftIO.bracket (liftIO $ f succ) (const $ liftIO $ f pred) . const+      where+        -- This functions are deliberately eta-expanded to avoid space leaks.+        -- Do not remove the eta-expansion without profiling a session with at+        -- least 1000 modifications.++        f = recordProgress inProgress file++-- Kill this to complete the progress session+progressCounter ::+  LSP.LanguageContextEnv c ->+  T.Text ->+  ProgressReportingStyle ->+  STM Int ->+  STM Int ->+  IO ()+progressCounter lspEnv title optProgressStyle getTodo getDone =+  LSP.runLspT lspEnv $ withProgress title Nothing NotCancellable $ \update -> loop update 0+  where+    loop _ _ | optProgressStyle == NoProgress = forever $ liftIO $ threadDelay maxBound+    loop update prevPct = do+      (todo, done, nextPct) <- liftIO $ atomically $ do+        todo <- getTodo+        done <- getDone+        let nextFrac :: Double+            nextFrac = if todo == 0 then 0 else fromIntegral done / fromIntegral todo+            nextPct :: UInt+            nextPct = floor $ 100 * nextFrac+        when (nextPct == prevPct) retry+        pure (todo, done, nextPct)++      _ <- update (ProgressAmount (Just nextPct) (Just $ T.pack $ show done <> "/" <> show todo))+      loop update nextPct++mRunLspT :: (Applicative m) => Maybe (LSP.LanguageContextEnv c) -> LSP.LspT c m () -> m () mRunLspT (Just lspEnv) f = LSP.runLspT lspEnv f mRunLspT Nothing _       = pure () -mRunLspTCallback :: Monad m-                 => Maybe (LSP.LanguageContextEnv c)-                 -> (LSP.LspT c m a -> LSP.LspT c m a)-                 -> m a-                 -> m a+mRunLspTCallback ::+  (Monad m) =>+  Maybe (LSP.LanguageContextEnv c) ->+  (LSP.LspT c m a -> LSP.LspT c m a) ->+  m a ->+  m a mRunLspTCallback (Just lspEnv) f g = LSP.runLspT lspEnv $ f (lift g) mRunLspTCallback Nothing _ g       = g

@@ -24,7 +24,8 @@ import           Data.Time.Clock.POSIX import           Data.Typeable import           Development.IDE.GHC.Compat                   hiding-                                                              (HieFileResult)+                                                              (HieFileResult,+                                                               assert) import           Development.IDE.GHC.Compat.Util import           Development.IDE.GHC.CoreFile import           Development.IDE.GHC.Util@@ -35,11 +36,12 @@ import           GHC.Generics                                 (Generic)  import           Data.ByteString                              (ByteString)-import           Data.Text                                    (Text)+import           Data.Text.Utf16.Rope.Mixed                   (Rope) import           Development.IDE.Import.FindImports           (ArtifactsLocation) import           Development.IDE.Spans.Common import           Development.IDE.Spans.LocalBindings import           Development.IDE.Types.Diagnostics+import           GHC.Driver.Errors.Types                      (WarningMessages) import           GHC.Serialized                               (Serialized) import           Ide.Logger                                   (Pretty (..),                                                                viaShow)@@ -82,7 +84,7 @@ type instance RuleResult GenerateCore = ModGuts  data GenerateCore = GenerateCore-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable GenerateCore instance NFData   GenerateCore @@ -102,12 +104,12 @@     rnf = rwhnf  data GetLinkable = GetLinkable-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable GetLinkable instance NFData   GetLinkable  data GetImportMap = GetImportMap-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable GetImportMap instance NFData   GetImportMap @@ -157,6 +159,8 @@         -- ^ Which modules did we need at runtime while compiling this file?         -- Used for recompilation checking in the presence of TH         -- Stores the hash of their core file+    , tmrWarnings        :: WarningMessages+        -- ^ Structured warnings for this module.     } instance Show TcModuleResult where     show = show . pm_mod_summary . tmrParsed@@ -275,10 +279,12 @@ type instance RuleResult GetModIface = HiFileResult  -- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk.-type instance RuleResult GetFileContents = (FileVersion, Maybe Text)+type instance RuleResult GetFileContents = (FileVersion, Maybe Rope)  type instance RuleResult GetFileExists = Bool +type instance RuleResult GetFileHash = Fingerprint+ type instance RuleResult AddWatchedFile = Bool  @@ -329,16 +335,22 @@ instance NFData   GetFileContents  data GetFileExists = GetFileExists-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic)  instance NFData   GetFileExists instance Hashable GetFileExists +data GetFileHash = GetFileHash+    deriving (Eq, Show, Generic)++instance NFData   GetFileHash+instance Hashable GetFileHash+ data FileOfInterestStatus   = OnDisk   | Modified { firstOpen :: !Bool -- ^ was this file just opened              }-  deriving (Eq, Show, Typeable, Generic)+  deriving (Eq, Show, Generic) instance Hashable FileOfInterestStatus instance NFData   FileOfInterestStatus @@ -346,7 +358,7 @@     pretty = viaShow  data IsFileOfInterestResult = NotFOI | IsFOI FileOfInterestStatus-  deriving (Eq, Show, Typeable, Generic)+  deriving (Eq, Show, Generic) instance Hashable IsFileOfInterestResult instance NFData   IsFileOfInterestResult @@ -378,17 +390,17 @@ type instance RuleResult GetModSummaryWithoutTimestamps = ModSummaryResult  data GetParsedModule = GetParsedModule-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable GetParsedModule instance NFData   GetParsedModule  data GetParsedModuleWithComments = GetParsedModuleWithComments-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable GetParsedModuleWithComments instance NFData   GetParsedModuleWithComments  data GetLocatedImports = GetLocatedImports-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable GetLocatedImports instance NFData   GetLocatedImports @@ -396,42 +408,42 @@ type instance RuleResult NeedsCompilation = Maybe LinkableType  data NeedsCompilation = NeedsCompilation-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable NeedsCompilation instance NFData   NeedsCompilation  data GetModuleGraph = GetModuleGraph-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable GetModuleGraph instance NFData   GetModuleGraph  data ReportImportCycles = ReportImportCycles-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable ReportImportCycles instance NFData   ReportImportCycles  data TypeCheck = TypeCheck-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable TypeCheck instance NFData   TypeCheck  data GetDocMap = GetDocMap-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable GetDocMap instance NFData   GetDocMap  data GetHieAst = GetHieAst-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable GetHieAst instance NFData   GetHieAst  data GetBindings = GetBindings-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable GetBindings instance NFData   GetBindings  data GhcSession = GhcSession-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable GhcSession instance NFData   GhcSession @@ -440,7 +452,7 @@         -- Required for interactive evaluation, but leads to more cache invalidations         fullModSummary :: Bool     }-    deriving newtype (Eq, Typeable, Hashable, NFData)+    deriving newtype (Eq, Hashable, NFData)  instance Show GhcSessionDeps where     show (GhcSessionDeps_ False) = "GhcSessionDeps"@@ -450,45 +462,45 @@ pattern GhcSessionDeps = GhcSessionDeps_ False  data GetModIfaceFromDisk = GetModIfaceFromDisk-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable GetModIfaceFromDisk instance NFData   GetModIfaceFromDisk  data GetModIfaceFromDiskAndIndex = GetModIfaceFromDiskAndIndex-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable GetModIfaceFromDiskAndIndex instance NFData   GetModIfaceFromDiskAndIndex  data GetModIface = GetModIface-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable GetModIface instance NFData   GetModIface  data IsFileOfInterest = IsFileOfInterest-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable IsFileOfInterest instance NFData   IsFileOfInterest  data GetModSummaryWithoutTimestamps = GetModSummaryWithoutTimestamps-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable GetModSummaryWithoutTimestamps instance NFData   GetModSummaryWithoutTimestamps  data GetModSummary = GetModSummary-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable GetModSummary instance NFData   GetModSummary  -- See Note [Client configuration in Rules] -- | Get the client config stored in the ide state data GetClientSettings = GetClientSettings-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable GetClientSettings instance NFData   GetClientSettings  type instance RuleResult GetClientSettings = Hashed (Maybe Value) -data AddWatchedFile = AddWatchedFile deriving (Eq, Show, Typeable, Generic)+data AddWatchedFile = AddWatchedFile deriving (Eq, Show, Generic) instance Hashable AddWatchedFile instance NFData   AddWatchedFile @@ -508,7 +520,7 @@ instance Show IdeGhcSession where show _ = "IdeGhcSession" instance NFData IdeGhcSession where rnf !_ = () -data GhcSessionIO = GhcSessionIO deriving (Eq, Show, Typeable, Generic)+data GhcSessionIO = GhcSessionIO deriving (Eq, Show, Generic) instance Hashable GhcSessionIO instance NFData   GhcSessionIO 

@@ -64,6 +64,7 @@ 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@@ -91,6 +92,7 @@ import           Data.Proxy import qualified Data.Text                                    as T import qualified Data.Text.Encoding                           as T+import qualified Data.Text.Utf16.Rope.Mixed                   as Rope import           Data.Time                                    (UTCTime (..)) import           Data.Time.Clock.POSIX                        (posixSecondsToUTCTime) import           Data.Tuple.Extra@@ -99,6 +101,7 @@ import           Development.IDE.Core.FileExists              hiding (Log,                                                                LogShake) import           Development.IDE.Core.FileStore               (getFileContents,+                                                               getFileModTimeContents,                                                                getModTime) import           Development.IDE.Core.IdeConfiguration import           Development.IDE.Core.OfInterest              hiding (Log,@@ -159,6 +162,7 @@ import           Language.LSP.Protocol.Message                (SMethod (SMethod_CustomMethod, SMethod_WindowShowMessage)) import           Language.LSP.Protocol.Types                  (MessageType (MessageType_Info),                                                                ShowMessageParams (ShowMessageParams))+import qualified Language.LSP.Protocol.Lens                   as JL import           Language.LSP.Server                          (LspT) import qualified Language.LSP.Server                          as LSP import           Language.LSP.VFS@@ -167,19 +171,10 @@ import           System.Info.Extra                            (isWindows)  -import           GHC.Fingerprint---- See Note [Guidelines For Using CPP In GHCIDE Import Statements]--#if !MIN_VERSION_ghc(9,3,0)-import           GHC                                          (mgModSummaries)-#endif--#if MIN_VERSION_ghc(9,3,0) import qualified Data.IntMap                                  as IM-#endif-+import           GHC.Fingerprint +import           GHC.Driver.Env                      (hsc_all_home_unit_ids)  data Log   = LogShake Shake.Log@@ -230,10 +225,10 @@ -- TODO: return text --> return rope getSourceFileSource :: NormalizedFilePath -> Action BS.ByteString getSourceFileSource nfp = do-    (_, msource) <- getFileContents nfp+    msource <- getFileContents nfp     case msource of         Nothing     -> liftIO $ BS.readFile (fromNormalizedFilePath nfp)-        Just source -> pure $ T.encodeUtf8 source+        Just source -> pure $ T.encodeUtf8 $ Rope.toText source  -- | Parse the contents of a haskell file. getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule)@@ -324,18 +319,11 @@         (KnownTargets targets targetsMap) <- useNoFile_ GetKnownTargets         let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms]         env_eq <- use_ GhcSession file-        let env = hscEnvWithImportPaths env_eq-        let import_dirs = deps env_eq+        let env = hscEnv env_eq+        let import_dirs = map (second homeUnitEnv_dflags) $ hugElts $ hsc_HUG env         let dflags = hsc_dflags env-            isImplicitCradle = isNothing $ envImportPaths env_eq-        let dflags' = if isImplicitCradle-                    then addRelativeImport file (moduleName $ ms_mod ms) dflags-                    else dflags         opt <- getIdeOptions         let getTargetFor modName nfp-                | isImplicitCradle = do-                    itExists <- getFileExists nfp-                    return $ if itExists then Just nfp else Nothing                 | Just (TargetFile nfp') <- HM.lookup (TargetFile nfp) targetsMap = do                     -- reuse the existing NormalizedFilePath in order to maximize sharing                     itExists <- getFileExists nfp'@@ -346,10 +334,11 @@                         nfp' = HM.lookupDefault nfp nfp ttmap                     itExists <- getFileExists nfp'                     return $ if itExists then Just nfp' else Nothing-                | otherwise-                = return Nothing+                | otherwise = do+                    itExists <- getFileExists nfp+                    return $ if itExists then Just nfp else Nothing         (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do-            diagOrImp <- locateModule (hscSetFlags dflags' env) import_dirs (optExtensions opt) getTargetFor modName mbPkgName isSource+            diagOrImp <- locateModule (hscSetFlags dflags env) import_dirs (optExtensions opt) getTargetFor modName mbPkgName isSource             case diagOrImp of                 Left diags              -> pure (diags, Just (modName, Nothing))                 Right (FileImport path) -> pure ([], Just (modName, Just path))@@ -500,17 +489,9 @@     where cycleErrorInFile f (PartOfCycle imp fs)             | f `elem` fs = Just (imp, fs)           cycleErrorInFile _ _ = Nothing-          toDiag imp mods = (fp , ShowDiag , ) $ Diagnostic-            { _range = rng-            , _severity = Just DiagnosticSeverity_Error-            , _source = Just "Import cycle detection"-            , _message = "Cyclic module dependency between " <> showCycle mods-            , _code = Nothing-            , _relatedInformation = Nothing-            , _tags = Nothing-            , _codeDescription = Nothing-            , _data_ = Nothing-            }+          toDiag imp mods =+            ideErrorWithSource (Just "Import cycle detection") (Just DiagnosticSeverity_Error) fp ("Cyclic module dependency between " <> showCycle mods) Nothing+              & fdLspDiagnosticL %~ JL.range .~ rng             where rng = fromMaybe noRange $ srcSpanToRange (getLoc imp)                   fp = toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename (getLoc imp)           getModuleName file = do@@ -539,7 +520,12 @@  getHieAstRuleDefinition :: NormalizedFilePath -> HscEnv -> TcModuleResult -> Action (IdeResult HieAstResult) getHieAstRuleDefinition f hsc tmr = do-  (diags, masts) <- liftIO $ generateHieAsts hsc tmr+  (diags, masts') <- liftIO $ generateHieAsts hsc tmr+#if MIN_VERSION_ghc(9,11,0)+  let masts = fst <$> masts'+#else+  let masts = masts'+#endif   se <- getShakeExtras    isFoi <- use_ IsFileOfInterest f@@ -549,7 +535,7 @@         LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/reference/ready")) $           toJSON $ fromNormalizedFilePath f       pure []-    _ | Just asts <- masts -> do+    _ | Just asts <- masts' -> do           source <- getSourceFileSource f           let exports = tcg_exports $ tmrTypechecked tmr               modSummary = tmrModSummary tmr@@ -630,6 +616,13 @@   fs <- knownTargets   pure (LBS.toStrict $ B.encode $ hash fs, unhashed fs) +getFileHashRule :: Recorder (WithPriority Log) -> Rules ()+getFileHashRule recorder =+    defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetFileHash file -> do+        void $ use_ GetModificationTime file+        fileHash <- liftIO $ Util.getFileHash (fromNormalizedFilePath file)+        return (Just (fingerprintToBS fileHash), ([], Just fileHash))+ getModuleGraphRule :: Recorder (WithPriority Log) -> Rules () getModuleGraphRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake recorder) $ \GetModuleGraph -> do   fs <- toKnownFiles <$> useNoFile_ GetKnownTargets@@ -641,7 +634,6 @@   let (all_fs, _all_ids) = unzip $ HM.toList $ pathToIdMap $ rawPathIdMap rawDepInfo   msrs <- uses GetModSummaryWithoutTimestamps all_fs   let mss = map (fmap msrModSummary) msrs-#if MIN_VERSION_ghc(9,3,0)   let deps = map (\i -> IM.lookup (getFilePathId i) (rawImports rawDepInfo)) _all_ids       nodeKeys = IM.fromList $ catMaybes $ zipWith (\fi mms -> (getFilePathId fi,) . NodeKey_Module . msKey <$> mms) _all_ids mss       mns = catMaybes $ zipWith go mss deps@@ -651,14 +643,6 @@       go (Just ms) _ = Just $ ModuleNode [] ms       go _ _ = Nothing       mg = mkModuleGraph mns-#else-  let mg = mkModuleGraph $-        -- We don't do any instantiation for backpack at this point of time, so it is OK to use-        -- 'extendModSummaryNoDeps'.-        -- This may have to change in the future.-          map extendModSummaryNoDeps $-          catMaybes mss-#endif   pure (fingerprintToBS $ Util.fingerprintFingerprints $ map (maybe fingerprint0 msrFingerprint) msrs, processDependencyInformation rawDepInfo bm mg)  -- This is factored out so it can be directly called from the GetModIface@@ -675,6 +659,7 @@   unlift <- askUnliftIO   let dets = TypecheckHelpers            { getLinkables = unliftIO unlift . uses_ GetLinkable+           , getModuleGraph = unliftIO unlift $ useNoFile_ GetModuleGraph            }   addUsageDependencies $ liftIO $     typecheckModule defer hsc dets pm@@ -776,7 +761,6 @@               then depModuleGraph <$> useNoFile_ GetModuleGraph               else do                 let mgs = map hsc_mod_graph depSessions-#if MIN_VERSION_ghc(9,3,0)                 -- On GHC 9.4+, the module graph contains not only ModSummary's but each `ModuleNode` in the graph                 -- also points to all the direct descendants of the current module. To get the keys for the descendants                 -- we must get their `ModSummary`s@@ -785,17 +769,10 @@                   return $!! map (NodeKey_Module . msKey) dep_mss                 let module_graph_nodes =                       nubOrdOn mkNodeKey (ModuleNode final_deps ms : concatMap mgModSummaries' mgs)-#else-                let module_graph_nodes =-                      -- We don't do any instantiation for backpack at this point of time, so it is OK to use-                      -- 'extendModSummaryNoDeps'.-                      -- This may have to change in the future.-                      map extendModSummaryNoDeps $-                      nubOrdOn ms_mod (ms : concatMap mgModSummaries mgs)-#endif                 liftIO $ evaluate $ liftRnf rwhnf module_graph_nodes                 return $ mkModuleGraph module_graph_nodes-            session' <- liftIO $ mergeEnvs hsc mg ms inLoadOrder depSessions+            de <- useNoFile_ GetModuleGraph+            session' <- liftIO $ mergeEnvs hsc mg de ms inLoadOrder depSessions              -- Here we avoid a call to to `newHscEnvEqWithImportPaths`, which creates a new             -- ExportsMap when it is called. We only need to create the ExportsMap once per@@ -824,9 +801,11 @@             , old_value = m_old             , get_file_version = use GetModificationTime_{missingFileDiagnostics = False}             , get_linkable_hashes = \fs -> map (snd . fromJust . hirCoreFp) <$> uses_ GetModIface fs+            , get_module_graph = useNoFile_ GetModuleGraph             , regenerate = regenerateHiFile session f ms             }-      r <- loadInterface (hscEnv session) ms linkableType recompInfo+      hsc_env' <- setFileCacheHook (hscEnv session)+      r <- loadInterface hsc_env' ms linkableType recompInfo       case r of         (diags, Nothing) -> return (Nothing, (diags, Nothing))         (diags, Just x) -> do@@ -894,23 +873,18 @@     defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModSummary f -> do         session' <- hscEnv <$> use_ GhcSession f         modify_dflags <- getModifyDynFlags dynFlagsModifyGlobal-        let session = hscSetFlags (modify_dflags $ hsc_dflags session') session'-        (modTime, mFileContent) <- getFileContents f+        let session = setNonHomeFCHook $ hscSetFlags (modify_dflags $ hsc_dflags session') session' -- TODO wz1000+        (modTime, mFileContent) <- getFileModTimeContents f         let fp = fromNormalizedFilePath f         modS <- liftIO $ runExceptT $-                getModSummaryFromImports session fp modTime (textToStringBuffer <$> mFileContent)+                getModSummaryFromImports session fp modTime (textToStringBuffer . Rope.toText <$> mFileContent)         case modS of             Right res -> do                 -- Check for Template Haskell                 when (uses_th_qq $ msrModSummary res) $ do                     DisplayTHWarning act <- getIdeGlobalAction                     liftIO act-#if MIN_VERSION_ghc(9,3,0)                 let bufFingerPrint = ms_hs_hash (msrModSummary res)-#else-                bufFingerPrint <- liftIO $-                    fingerprintFromStringBuffer $ fromJust $ ms_hspp_buf $ msrModSummary res-#endif                 let fingerPrint = Util.fingerprintFingerprints                         [ msrFingerprint res, bufFingerPrint ]                 return ( Just (fingerprintToBS fingerPrint) , ([], Just res))@@ -921,9 +895,6 @@         case mbMs of             Just res@ModSummaryResult{..} -> do                 let ms = msrModSummary {-#if !MIN_VERSION_ghc(9,3,0)-                    ms_hs_date = error "use GetModSummary instead of GetModSummaryWithoutTimestamps",-#endif                     ms_hspp_buf = error "use GetModSummary instead of GetModSummaryWithoutTimestamps"                     }                     fp = fingerprintToBS msrFingerprint@@ -933,8 +904,9 @@ generateCore :: RunSimplifier -> NormalizedFilePath -> Action (IdeResult ModGuts) generateCore runSimplifier file = do     packageState <- hscEnv <$> use_ GhcSessionDeps file+    hsc' <- setFileCacheHook packageState     tm <- use_ TypeCheck file-    liftIO $ compileModule runSimplifier packageState (tmrModSummary tm) (tmrTypechecked tm)+    liftIO $ compileModule runSimplifier hsc' (tmrModSummary tm) (tmrTypechecked tm)  generateCoreRule :: Recorder (WithPriority Log) -> Rules () generateCoreRule recorder =@@ -949,14 +921,15 @@       tmr <- use_ TypeCheck f       linkableType <- getLinkableType f       hsc <- hscEnv <$> use_ GhcSessionDeps f+      hsc' <- setFileCacheHook hsc       let compile = fmap ([],) $ use GenerateCore f       se <- getShakeExtras-      (diags, !mbHiFile) <- writeCoreFileIfNeeded se hsc linkableType compile tmr+      (diags, !mbHiFile) <- writeCoreFileIfNeeded se hsc' linkableType compile tmr       let fp = hiFileFingerPrint <$> mbHiFile       hiDiags <- case mbHiFile of         Just hiFile           | OnDisk <- status-          , not (tmrDeferredError tmr) -> liftIO $ writeHiFile se hsc hiFile+          , not (tmrDeferredError tmr) -> liftIO $ writeHiFile se hsc' hiFile         _ -> pure []       return (fp, (diags++hiDiags, mbHiFile))     NotFOI -> do@@ -980,12 +953,21 @@   count <- getRebuildCountVar <$> getIdeGlobalAction   liftIO $ atomically $ modifyTVar' count (+1) +setFileCacheHook :: HscEnv -> Action HscEnv+setFileCacheHook old_hsc_env = do+#if MIN_VERSION_ghc(9,11,0)+  unlift <- askUnliftIO+  return $ old_hsc_env { hsc_FC = (hsc_FC old_hsc_env) { lookupFileCache = unliftIO unlift . use_ GetFileHash . toNormalizedFilePath'  } }+#else+  return old_hsc_env+#endif+ -- | Also generates and indexes the `.hie` file, along with the `.o` file if needed -- Invariant maintained is that if the `.hi` file was successfully written, then the -- `.hie` and `.o` file (if needed) were also successfully written regenerateHiFile :: HscEnvEq -> NormalizedFilePath -> ModSummary -> Maybe LinkableType -> Action ([FileDiagnostic], Maybe HiFileResult) regenerateHiFile sess f ms compNeeded = do-    let hsc = hscEnv sess+    hsc <- setFileCacheHook (hscEnv sess)     opt <- getIdeOptions      -- Embed haddocks in the interface file@@ -1081,10 +1063,16 @@ getLinkableRule :: Recorder (WithPriority Log) -> Rules () getLinkableRule recorder =   defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetLinkable f -> do-    ModSummaryResult{msrModSummary = ms} <- use_ GetModSummary f-    HiFileResult{hirModIface, hirModDetails, hirCoreFp} <- use_ GetModIface f-    let obj_file  = ml_obj_file (ms_location ms)-        core_file = ml_core_file (ms_location ms)+    HiFileResult{hirModSummary, hirModIface, hirModDetails, hirCoreFp} <- use_ GetModIface f+    let obj_file  = ml_obj_file (ms_location hirModSummary)+        core_file = ml_core_file (ms_location hirModSummary)+#if MIN_VERSION_ghc(9,11,0)+        mkLinkable t mod l = Linkable t mod (pure l)+        dotO o = DotO o ModuleObject+#else+        mkLinkable t mod l = LM t mod [l]+        dotO = DotO+#endif     case hirCoreFp of       Nothing -> error $ "called GetLinkable for a file without a linkable: " ++ show f       Just (bin_core, fileHash) -> do@@ -1097,7 +1085,7 @@         core_t <- liftIO $ getModTime core_file         (warns, hmi) <- case linkableType of           -- Bytecode needs to be regenerated from the core file-          BCOLinkable -> liftIO $ coreFileToLinkable linkableType (hscEnv session) ms hirModIface hirModDetails bin_core (posixSecondsToUTCTime core_t)+          BCOLinkable -> liftIO $ coreFileToLinkable linkableType (hscEnv session) hirModSummary hirModIface hirModDetails bin_core (posixSecondsToUTCTime core_t)           -- Object code can be read from the disk           ObjectLinkable -> do             -- object file is up to date if it is newer than the core file@@ -1110,10 +1098,15 @@               else pure Nothing             case mobj_time of               Just obj_t-                | obj_t >= core_t -> pure ([], Just $ HomeModInfo hirModIface hirModDetails (justObjects $ LM (posixSecondsToUTCTime obj_t) (ms_mod ms) [DotO obj_file]))-              _ -> liftIO $ coreFileToLinkable linkableType (hscEnv session) ms hirModIface hirModDetails bin_core (error "object doesn't have time")+                | obj_t >= core_t -> pure ([], Just $ HomeModInfo hirModIface hirModDetails (justObjects $ mkLinkable (posixSecondsToUTCTime obj_t) (ms_mod hirModSummary) (dotO obj_file)))+              _ -> liftIO $ coreFileToLinkable linkableType (hscEnv session) hirModSummary hirModIface hirModDetails bin_core (error "object doesn't have time")         -- Record the linkable so we know not to unload it, and unload old versions-        whenJust ((homeModInfoByteCode =<< hmi) <|> (homeModInfoObject =<< hmi)) $ \(LM time mod _) -> do+        whenJust ((homeModInfoByteCode =<< hmi) <|> (homeModInfoObject =<< hmi))+#if MIN_VERSION_ghc(9,11,0)+          $ \(Linkable time mod _) -> do+#else+          $ \(LM time mod _) -> do+#endif             compiledLinkables <- getCompiledLinkables <$> getIdeGlobalAction             liftIO $ modifyVar compiledLinkables $ \old -> do               let !to_keep = extendModuleEnv old mod time@@ -1127,7 +1120,9 @@               --just before returning it to be loaded. This has a substantial effect on recompile               --times as the number of loaded modules and splices increases.               ---              unload (hscEnv session) (map (\(mod', time') -> LM time' mod' []) $ moduleEnvToList to_keep)+              --We use a dummy DotA linkable part to fake a NativeCode linkable.+              --The unload function doesn't care about the exact linkable parts.+              unload (hscEnv session) (map (\(mod', time') -> mkLinkable time' mod' (DotA "dummy")) $ moduleEnvToList to_keep)               return (to_keep, ())         return (fileHash <$ hmi, (warns, LinkableResult <$> hmi <*> pure fileHash)) @@ -1225,12 +1220,13 @@     reportImportCyclesRule recorder     typeCheckRule recorder     getDocMapRule recorder-    loadGhcSession recorder GhcSessionDepsConfig{fullModuleGraph}+    loadGhcSession recorder def{fullModuleGraph}     getModIfaceFromDiskRule recorder     getModIfaceFromDiskAndIndexRule recorder     getModIfaceRule recorder     getModSummaryRule templateHaskellWarning recorder     getModuleGraphRule recorder+    getFileHashRule recorder     knownFilesRule recorder     getClientSettingsRule recorder     getHieAstsRule recorder

@@ -73,7 +73,8 @@     garbageCollectDirtyKeysOlderThan,     Log(..),     VFSModified(..), getClientConfigAction,-    ThreadQueue(..)+    ThreadQueue(..),+    runWithSignal     ) where  import           Control.Concurrent.Async@@ -82,7 +83,7 @@ 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@@ -123,9 +124,14 @@ import           Development.IDE.Core.PositionMapping import           Development.IDE.Core.ProgressReporting import           Development.IDE.Core.RuleTypes+import           Development.IDE.Types.Options          as Options+import qualified Language.LSP.Protocol.Message          as LSP+import qualified Language.LSP.Server                    as LSP+ import           Development.IDE.Core.Tracing import           Development.IDE.Core.WorkerThread import           Development.IDE.GHC.Compat             (NameCache,+                                                         NameCacheUpdater,                                                          initNameCache,                                                          knownKeyNames) import           Development.IDE.GHC.Orphans            ()@@ -146,25 +152,21 @@ import           Development.IDE.Types.KnownTargets import           Development.IDE.Types.Location import           Development.IDE.Types.Monitoring       (Monitoring (..))-import           Development.IDE.Types.Options import           Development.IDE.Types.Shake import qualified Focus import           GHC.Fingerprint import           GHC.Stack                              (HasCallStack)+import           GHC.TypeLits                           (KnownSymbol) import           HieDb.Types import           Ide.Logger                             hiding (Priority) import qualified Ide.Logger                             as Logger import           Ide.Plugin.Config import qualified Ide.PluginUtils                        as HLS-import           Ide.Types                              (IdePlugins (IdePlugins),-                                                         PluginDescriptor (pluginId),-                                                         PluginId)-import           Language.LSP.Diagnostics+import           Ide.Types import qualified Language.LSP.Protocol.Lens             as L import           Language.LSP.Protocol.Message import           Language.LSP.Protocol.Types import qualified Language.LSP.Protocol.Types            as LSP-import qualified Language.LSP.Server                    as LSP import           Language.LSP.VFS                       hiding (start) import qualified "list-t" ListT import           OpenTelemetry.Eventlog                 hiding (addEvent)@@ -173,20 +175,9 @@ import           System.FilePath                        hiding (makeRelative) import           System.IO.Unsafe                       (unsafePerformIO) import           System.Time.Extra+import           UnliftIO                               (MonadUnliftIO (withRunInIO)) --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,3,0)-import           Data.IORef-import           Development.IDE.GHC.Compat             (NameCacheUpdater (NCU),-                                                         mkSplitUniqSupply,-                                                         upNameCache)-#endif--#if MIN_VERSION_ghc(9,3,0)-import           Development.IDE.GHC.Compat             (NameCacheUpdater)-#endif- data Log   = LogCreateHieDbExportsMapStart   | LogCreateHieDbExportsMapFinish !Int@@ -252,11 +243,10 @@ -- a worker thread. data HieDbWriter   = HieDbWriter-  { indexQueue         :: IndexQueue-  , indexPending       :: TVar (HMap.HashMap NormalizedFilePath Fingerprint) -- ^ Avoid unnecessary/out of date indexing-  , indexCompleted     :: TVar Int -- ^ to report progress-  , indexProgressToken :: Var (Maybe LSP.ProgressToken)-  -- ^ This is a Var instead of a TVar since we need to do IO to initialise/update, so we need a lock+  { indexQueue             :: IndexQueue+  , indexPending           :: TVar (HMap.HashMap NormalizedFilePath Fingerprint) -- ^ Avoid unnecessary/out of date indexing+  , indexCompleted         :: TVar Int -- ^ to report progress+  , indexProgressReporting :: ProgressReporting   }  -- | Actions to queue up on the index worker thread@@ -290,7 +280,7 @@     ,state :: Values     ,diagnostics :: STMDiagnosticStore     ,hiddenDiagnostics :: STMDiagnosticStore-    ,publishedDiagnostics :: STM.Map NormalizedUri [Diagnostic]+    ,publishedDiagnostics :: STM.Map NormalizedUri [FileDiagnostic]     -- ^ This represents the set of diagnostics that we have published.     -- Due to debouncing not every change might get published. @@ -306,7 +296,7 @@     -- positions in a version of that document to positions in the latest version     -- First mapping is delta from previous version and second one is an     -- accumulation to the current version.-    ,progress :: ProgressReporting+    ,progress :: PerFileProgressReporting     ,ideTesting :: IdeTesting     -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants     ,restartShakeSession@@ -315,11 +305,7 @@         -> [DelayedAction ()]         -> IO [Key]         -> IO ()-#if MIN_VERSION_ghc(9,3,0)     ,ideNc :: NameCache-#else-    ,ideNc :: IORef NameCache-#endif     -- | A mapping of module name to known target (or candidate targets, if missing)     ,knownTargetsVar :: TVar (Hashed KnownTargets)     -- | A mapping of exported identifiers for local modules. Updated on kick@@ -677,12 +663,7 @@         restartQueue = tRestartQueue threadQueue         loaderQueue = tLoaderQueue threadQueue -#if MIN_VERSION_ghc(9,3,0)     ideNc <- initNameCache 'r' knownKeyNames-#else-    us <- mkSplitUniqSupply 'r'-    ideNc <- newIORef (initNameCache us knownKeyNames)-#endif     shakeExtras <- do         globals <- newTVarIO HMap.empty         state <- STM.newIO@@ -697,7 +678,10 @@         indexPending <- newTVarIO HMap.empty         indexCompleted <- newTVarIO 0         semanticTokensId <- newTVarIO 0-        indexProgressToken <- newVar Nothing+        indexProgressReporting <- progressReportingNoTrace+            (liftM2 (+) (length <$> readTVar indexPending) (readTVar indexCompleted))+            (readTVar indexCompleted)+            lspEnv "Indexing" optProgressStyle         let hiedbWriter = HieDbWriter{..}         exportsMap <- newTVarIO mempty         -- lazily initialize the exports map with the contents of the hiedb@@ -710,8 +694,8 @@          progress <-             if reportProgress-                then progressReporting lspEnv optProgressStyle-                else noProgressReporting+                then progressReporting lspEnv "Processing" optProgressStyle+                else noPerFileProgressReporting         actionQueue <- newQueue          let clientCapabilities = maybe def LSP.resClientCapabilities lspEnv@@ -775,6 +759,7 @@     for_ runner cancelShakeSession     void $ shakeDatabaseProfile shakeDb     progressStop $ progress shakeExtras+    progressStop $ indexProgressReporting $ hiedbWriter shakeExtras     stopMonitoring  @@ -1080,13 +1065,8 @@ askShake = ask  -#if MIN_VERSION_ghc(9,3,0) mkUpdater :: NameCache -> NameCacheUpdater mkUpdater = id-#else-mkUpdater :: IORef NameCache -> NameCacheUpdater-mkUpdater ref = NCU (upNameCache ref)-#endif  -- | A (maybe) stale result now, and an up to date one later data FastResult a = FastResult { stale :: Maybe (a,PositionMapping), uptoDate :: IO (Maybe a)  }@@ -1192,7 +1172,7 @@     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 +1191,7 @@     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 ()@@ -1238,7 +1218,8 @@ defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do     ShakeExtras{state, progress, dirtyKeys} <- getShakeExtras     options <- getIdeOptions-    (if optSkipProgress options key then id else inProgress progress file) $ do+    let trans g x =  withRunInIO $ \run -> g (run x)+    (if optSkipProgress options key then id else trans (inProgress progress file)) $ do         val <- case mbOld of             Just old | mode == RunDependenciesSame -> do                 mbValue <- liftIO $ atomicallyNamed "define - read 1" $ getValues state key file@@ -1265,7 +1246,7 @@                 (mbBs, (diags, mbRes)) <- actionCatch                     (do v <- action staleV; liftIO $ evaluate $ force v) $                     \(e :: SomeException) -> do-                        pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))+                        pure (Nothing, ([ideErrorText file (T.pack $ show (key, file) ++ show e) | not $ isBadDependency e],Nothing))                  ver <- estimateFileVersionUnsafely key mbRes file                 (bs, res) <- case mbRes of@@ -1347,52 +1328,51 @@   -> 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 =+updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, debouncer, lspEnv, ideTesting} current0 = do   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 :: (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 = second diagsFromRule <$> current0+        current = map (fdLspDiagnosticL %~ 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 ") currentShown diagnostics+        _ <- liftIO $ atomicallyNamed "diagnostics - hidden" $ update (addTagUnsafe "hidden ") 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+            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 newDiags                         Just env -> LSP.runLspT env $ do                             liftIO $ tag "count" (show $ Prelude.length newDiags)                             liftIO $ tag "key" (show k)                             LSP.sendNotification SMethod_TextDocumentPublishDiagnostics $-                                LSP.PublishDiagnosticsParams (fromNormalizedUri uri') (fmap fromIntegral ver) newDiags-                 return action+                                LSP.PublishDiagnosticsParams (fromNormalizedUri uri') (fmap fromIntegral ver) (map fdLspDiagnostic newDiags)+                return action     where         diagsFromRule :: Diagnostic -> Diagnostic         diagsFromRule c@Diagnostic{_range}             | coerce ideTesting = c & L.relatedInformation ?~-                         [-                        DiagnosticRelatedInformation+                        [ DiagnosticRelatedInformation                             (Location                                 (filePathToUri $ fromNormalizedFilePath fp)                                 _range                             )                             (T.pack $ show k)-                            ]+                        ]             | otherwise = c  @@ -1403,26 +1383,28 @@ actionLogger = shakeRecorder <$> getShakeExtras  ---------------------------------------------------------------------------------type STMDiagnosticStore = STM.Map NormalizedUri StoreItem+type STMDiagnosticStore = STM.Map NormalizedUri StoreItem'+data StoreItem' = StoreItem' (Maybe Int32) FileDiagnosticsBySource+type FileDiagnosticsBySource = Map.Map (Maybe T.Text) (SL.SortedList FileDiagnostic) -getDiagnosticsFromStore :: StoreItem -> [Diagnostic]-getDiagnosticsFromStore (StoreItem _ diags) = concatMap SL.fromSortedList $ Map.elems diags+getDiagnosticsFromStore :: StoreItem' -> [FileDiagnostic]+getDiagnosticsFromStore (StoreItem' _ diags) = concatMap SL.fromSortedList $ Map.elems diags  updateSTMDiagnostics ::   (forall a. String -> String -> a -> a) ->   STMDiagnosticStore ->   NormalizedUri ->   Maybe Int32 ->-  DiagnosticsBySource ->-  STM [LSP.Diagnostic]+  FileDiagnosticsBySource ->+  STM [FileDiagnostic] updateSTMDiagnostics addTag store uri mv newDiagsBySource =     getDiagnosticsFromStore . fromJust <$> STM.focus (Focus.alter update *> Focus.lookup) uri store   where-    update (Just(StoreItem mvs dbs))+    update (Just(StoreItem' mvs dbs))       | addTag "previous version" (show mvs) $         addTag "previous count" (show $ Prelude.length $ filter (not.null) $ Map.elems dbs) False = undefined-      | mvs == mv = Just (StoreItem mv (newDiagsBySource <> dbs))-    update _ = Just (StoreItem mv newDiagsBySource)+      | mvs == mv = Just (StoreItem' mv (newDiagsBySource <> dbs))+    update _ = Just (StoreItem' mv newDiagsBySource)  -- | Sets the diagnostics for a file and compilation step --   if you want to clear the diagnostics call this with an empty list@@ -1431,9 +1413,9 @@     -> NormalizedUri     -> Maybe Int32 -- ^ the time that the file these diagnostics originate from was last edited     -> T.Text-    -> [LSP.Diagnostic]+    -> [FileDiagnostic]     -> STMDiagnosticStore-    -> STM [LSP.Diagnostic]+    -> STM [FileDiagnostic] setStageDiagnostics addTag uri ver stage diags ds = updateSTMDiagnostics addTag ds uri ver updatedDiags   where     !updatedDiags = Map.singleton (Just stage) $! SL.toSortedList diags@@ -1442,7 +1424,7 @@     STMDiagnosticStore ->     STM [FileDiagnostic] getAllDiagnostics =-    fmap (concatMap (\(k,v) -> map (fromUri k,ShowDiag,) $ getDiagnosticsFromStore v)) . ListT.toList . STM.listT+    fmap (concatMap (\(_,v) -> getDiagnosticsFromStore v)) . ListT.toList . STM.listT  updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> STM () updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} changes =@@ -1464,3 +1446,19 @@         EM.mapAccumRWithKey (\acc _k (delta, _) -> let new = addOldDelta delta acc in (new, (delta, acc)))             zeroMapping             (EM.insert ver (mkDelta changes, zeroMapping) mappingForUri)++-- | sends a signal whenever shake session is run/restarted+-- being used in cabal and hlint plugin tests to know when its time+-- to look for file diagnostics+kickSignal :: KnownSymbol s => Bool -> Maybe (LSP.LanguageContextEnv c) -> [NormalizedFilePath] -> Proxy s -> Action ()+kickSignal testing lspEnv files msg = when testing $ liftIO $ mRunLspT lspEnv $+  LSP.sendNotification (LSP.SMethod_CustomMethod msg) $+  toJSON $ map fromNormalizedFilePath files++-- | Add kick start/done signal to rule+runWithSignal :: (KnownSymbol s0, KnownSymbol s1, IdeRule k v) => Proxy s0 -> Proxy s1 -> [NormalizedFilePath] -> k -> Action ()+runWithSignal msgStart msgEnd files rule = do+  ShakeExtras{ideTesting = Options.IdeTesting testing, lspEnv} <- getShakeExtras+  kickSignal testing lspEnv files msgStart+  void $ uses rule files+  kickSignal testing lspEnv files msgEnd

@@ -61,7 +61,7 @@ -- | Returns a logger that produces telemetry events in a single span. telemetryLogRecorder :: SpanInFlight -> Recorder (WithPriority (Doc a)) telemetryLogRecorder sp = Recorder $ \WithPriority {..} ->-  liftIO $ addEvent sp (fromString $ show priority) (encodeUtf8 $ trim $ renderStrict $ layoutCompact $ payload)+  liftIO $ addEvent sp (fromString $ show priority) (encodeUtf8 $ trim $ renderStrict $ layoutCompact payload)   where     -- eventlog message size is limited by EVENT_PAYLOAD_SIZE_MAX = STG_WORD16_MAX     trim = T.take (fromIntegral(maxBound :: Word16) - 10)

@@ -10,10 +10,13 @@     (withWorkerQueue, awaitRunInThread)  where -import           Control.Concurrent.Async  (withAsync)+import           Control.Concurrent.Async  (AsyncCancelled (AsyncCancelled),+                                            withAsync) import           Control.Concurrent.STM import           Control.Concurrent.Strict (newBarrier, signalBarrier,                                             waitBarrier)+import           Control.Exception.Safe    (Exception (fromException),+                                            SomeException, throwIO, try) import           Control.Monad             (forever) import           Control.Monad.Cont        (ContT (ContT)) @@ -42,13 +45,15 @@                 workerAction l  -- | 'awaitRunInThread' queues up an 'IO' action to be run by a worker thread,--- and then blocks until the result is computed.+-- and then blocks until the result is computed. If the action throws an+-- non-async exception, it is rethrown in the calling thread. awaitRunInThread :: TQueue (IO ()) -> IO result -> IO result awaitRunInThread q act = do     -- Take an action from TQueue, run it and     -- use barrier to wait for the result     barrier <- newBarrier-    atomically $ writeTQueue q $ do-        res <- act-        signalBarrier barrier res-    waitBarrier barrier+    atomically $ writeTQueue q $ try act >>= signalBarrier barrier+    resultOrException <- waitBarrier barrier+    case resultOrException of+        Left e  -> throwIO (e :: SomeException)+        Right r -> return r

@@ -22,16 +22,16 @@  -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,3,0)-import qualified GHC.Driver.Pipeline             as Pipeline-#endif--#if MIN_VERSION_ghc(9,3,0) && !MIN_VERSION_ghc(9,5,0)+#if !MIN_VERSION_ghc(9,5,0) import qualified GHC.Driver.Pipeline.Execute     as Pipeline #endif  #if MIN_VERSION_ghc(9,5,0) import qualified GHC.SysTools.Cpp                as Pipeline+#endif++#if MIN_VERSION_ghc(9,11,0)+import qualified GHC.SysTools.Tasks              as Pipeline #endif  #if MIN_VERSION_ghc(9,11,0)

@@ -98,20 +98,9 @@     extract_cons,     recDotDot, -#if !MIN_VERSION_ghc(9,3,0)-    Dependencies(dep_mods),-    NameCacheUpdater(NCU),-    extendModSummaryNoDeps,-    emsModSummary,-    nonDetNameEnvElts,-    nonDetOccEnvElts,-    upNameCache,-#endif -#if MIN_VERSION_ghc(9,3,0)     Dependencies(dep_direct_mods),     NameCacheUpdater,-#endif  #if MIN_VERSION_ghc(9,5,0)     XModulePs(..),@@ -180,6 +169,7 @@ import           GHC.ByteCode.Types import           GHC.CoreToStg import           GHC.Data.Maybe+import           GHC.Driver.Config.Stg.Pipeline import           GHC.Driver.Env                          as Env import           GHC.Iface.Env import           GHC.Linker.Loader                       (loadDecls, loadExpr)@@ -192,24 +182,12 @@ import           GHC.Types.SrcLoc                        (combineRealSrcSpans) import           GHC.Unit.Home.ModInfo                   (HomePackageTable,                                                           lookupHpt)+import           GHC.Unit.Module.Deps                    (Dependencies (dep_direct_mods),+                                                          Usage (..)) import           GHC.Unit.Module.ModIface  -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,3,0)-import           Data.IORef-import           GHC.Runtime.Interpreter-import           GHC.Unit.Module.Deps                    (Dependencies (dep_mods),-                                                          Usage (..))-import           GHC.Unit.Module.ModSummary-#endif--#if MIN_VERSION_ghc(9,3,0)-import           GHC.Driver.Config.Stg.Pipeline-import           GHC.Unit.Module.Deps                    (Dependencies (dep_direct_mods),-                                                          Usage (..))-#endif- #if !MIN_VERSION_ghc(9,5,0) import           GHC.Core.Lint                           (lintInteractiveExpr) #endif@@ -234,35 +212,19 @@ nonDetFoldOccEnv = foldOccEnv #endif -#if !MIN_VERSION_ghc(9,3,0)-nonDetOccEnvElts :: OccEnv a -> [a]-nonDetOccEnvElts = occEnvElts-#endif  type ModIfaceAnnotation = Annotation -#if !MIN_VERSION_ghc(9,3,0)-nonDetNameEnvElts :: NameEnv a -> [a]-nonDetNameEnvElts = nameEnvElts-#endif  myCoreToStgExpr :: Logger -> DynFlags -> InteractiveContext-#if MIN_VERSION_ghc(9,3,0)             -> Bool-#endif                 -> Module -> ModLocation -> CoreExpr                 -> IO ( Id-#if MIN_VERSION_ghc(9,3,0)                       ,[CgStgTopBinding] -- output program-#else-                      ,[StgTopBinding] -- output program-#endif                       , InfoTableProvMap                       , CollectedCCs ) myCoreToStgExpr logger dflags ictxt-#if MIN_VERSION_ghc(9,3,0)                 for_bytecode-#endif                 this_mod ml prepd_expr = do     {- Create a temporary binding (just because myCoreToStg needs a        binding for the stg2stg step) -}@@ -278,30 +240,20 @@        myCoreToStg logger                    dflags                    ictxt-#if MIN_VERSION_ghc(9,3,0)                    for_bytecode-#endif                    this_mod                    ml                    [NonRec bco_tmp_id prepd_expr]     return (bco_tmp_id, stg_binds, prov_map, collected_ccs)  myCoreToStg :: Logger -> DynFlags -> InteractiveContext-#if MIN_VERSION_ghc(9,3,0)             -> Bool-#endif             -> Module -> ModLocation -> CoreProgram-#if MIN_VERSION_ghc(9,3,0)             -> IO ( [CgStgTopBinding] -- output program-#else-            -> IO ( [StgTopBinding] -- output program-#endif                   , InfoTableProvMap                   , CollectedCCs )  -- CAF cost centre info (declared and used) myCoreToStg logger dflags ictxt-#if MIN_VERSION_ghc(9,3,0)             for_bytecode-#endif             this_mod ml prepd_binds = do     let (stg_binds, denv, cost_centre_info)          = {-# SCC "Core2Stg" #-}@@ -321,7 +273,6 @@     stg_binds2 #endif         <- {-# SCC "Stg2Stg" #-}-#if MIN_VERSION_ghc(9,3,0)            stg2stg logger #if MIN_VERSION_ghc(9,5,0)                    (interactiveInScope ictxt)@@ -329,9 +280,6 @@                    ictxt #endif                    (initStgPipelineOpts dflags for_bytecode) this_mod stg_binds-#else-           stg2stg logger dflags ictxt this_mod stg_binds-#endif      return (stg_binds2, denv, cost_centre_info) @@ -342,11 +290,7 @@ #endif  getDependentMods :: ModIface -> [ModuleName]-#if MIN_VERSION_ghc(9,3,0) getDependentMods = map (gwib_mod . snd) . S.toList . dep_direct_mods . mi_deps-#else-getDependentMods = map gwib_mod . dep_mods . mi_deps-#endif  simplifyExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr #if MIN_VERSION_ghc(9,5,0)@@ -366,57 +310,48 @@  renderMessages :: PsMessages -> (Bag WarnMsg, Bag ErrMsg) renderMessages msgs =-#if MIN_VERSION_ghc(9,3,0)-  let renderMsgs extractor = (fmap . fmap) renderDiagnosticMessageWithHints . getMessages $ extractor msgs+#if MIN_VERSION_ghc(9,5,0)+  let renderMsgs extractor = (fmap . fmap) GhcPsMessage . getMessages $ extractor msgs   in (renderMsgs psWarnings, renderMsgs psErrors) #else-  msgs+  let renderMsgs extractor = (fmap . fmap) renderDiagnosticMessageWithHints . getMessages $ extractor msgs+  in (renderMsgs psWarnings, renderMsgs psErrors) #endif +#if MIN_VERSION_ghc(9,5,0)+pattern PFailedWithErrorMessages :: forall a b. (b -> Bag (MsgEnvelope GhcMessage)) -> ParseResult a+#else pattern PFailedWithErrorMessages :: forall a b. (b -> Bag (MsgEnvelope DecoratedSDoc)) -> ParseResult a+#endif pattern PFailedWithErrorMessages msgs-#if MIN_VERSION_ghc(9,3,0)-     <- PFailed (const . fmap (fmap renderDiagnosticMessageWithHints) . getMessages . getPsErrorMessages -> msgs)+#if MIN_VERSION_ghc(9,5,0)+     <- PFailed (const . fmap (fmap GhcPsMessage) . getMessages . getPsErrorMessages -> msgs) #else-     <- PFailed (const . fmap pprError . getErrorMessages -> msgs)+     <- PFailed (const . fmap (fmap renderDiagnosticMessageWithHints) . getMessages . getPsErrorMessages -> msgs) #endif {-# COMPLETE POk, PFailedWithErrorMessages #-}  hieExportNames :: HieFile -> [(SrcSpan, Name)] hieExportNames = nameListFromAvails . hie_exports -#if MIN_VERSION_ghc(9,3,0) type NameCacheUpdater = NameCache-#else -lookupNameCache :: Module -> OccName -> NameCache -> (NameCache, Name)--- Lookup up the (Module,OccName) in the NameCache--- If you find it, return it; if not, allocate a fresh original name and extend--- the NameCache.--- Reason: this may the first occurrence of (say) Foo.bar we have encountered.--- If we need to explore its value we will load Foo.hi; but meanwhile all we--- need is a Name for it.-lookupNameCache mod occ name_cache =-  case lookupOrigNameCache (nsNames name_cache) mod occ of {-    Just name -> (name_cache, name);-    Nothing   ->-        case takeUniqFromSupply (nsUniqs name_cache) of {-          (uniq, us) ->-              let-                name      = mkExternalName uniq mod occ noSrcSpan-                new_cache = extendNameCache (nsNames name_cache) mod occ name-              in (name_cache{ nsUniqs = us, nsNames = new_cache }, name) }}--upNameCache :: IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c-upNameCache = updNameCache-#endif- mkHieFile' :: ModSummary            -> [Avail.AvailInfo]+#if MIN_VERSION_ghc(9,11,0)+           -> (HieASTs Type, NameEntityInfo)+#else            -> HieASTs Type+#endif            -> BS.ByteString            -> Hsc HieFile-mkHieFile' ms exports asts src = do+mkHieFile' ms exports+#if MIN_VERSION_ghc(9,11,0)+            (asts, entityInfo)+#else+            asts+#endif+            src = do   let Just src_file = ml_hs_file $ ms_location ms       (asts',arr) = compressTypes asts   return $ HieFile@@ -424,6 +359,9 @@       , hie_module = ms_mod ms       , hie_types = arr       , hie_asts = asts'+#if MIN_VERSION_ghc(9,11,0)+      , hie_entity_infos = entityInfo+#endif       -- mkIfaceExports sorts the AvailInfos for stability       , hie_exports = mkIfaceExports exports       , hie_hs_src = src@@ -515,18 +453,20 @@ generatedNodeInfo = Map.lookup GeneratedInfo . getSourcedNodeInfo . sourcedNodeInfo  data GhcVersion-  = GHC92-  | GHC94+  = GHC94   | GHC96   | GHC98   | GHC910+  | GHC912   deriving (Eq, Ord, Show, Enum)  ghcVersionStr :: String ghcVersionStr = VERSION_ghc  ghcVersion :: GhcVersion-#if MIN_VERSION_GLASGOW_HASKELL(9,10,0,0)+#if MIN_VERSION_GLASGOW_HASKELL(9,12,0,0)+ghcVersion = GHC912+#elif MIN_VERSION_GLASGOW_HASKELL(9,10,0,0) ghcVersion = GHC910 #elif MIN_VERSION_GLASGOW_HASKELL(9,8,0,0) ghcVersion = GHC98@@ -534,8 +474,6 @@ ghcVersion = GHC96 #elif MIN_VERSION_GLASGOW_HASKELL(9,4,0,0) ghcVersion = GHC94-#elif MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)-ghcVersion = GHC92 #endif  simpleNodeInfoCompat :: FastStringCompat -> FastStringCompat -> NodeInfo a@@ -568,16 +506,7 @@     -> HscEnv     -> HscEnv loadModulesHome mod_infos e =-#if MIN_VERSION_ghc(9,3,0)   hscUpdateHUG (\hug -> foldl' (flip addHomeModInfoToHug) hug mod_infos) (e { hsc_type_env_vars = emptyKnotVars })-#else-  let !new_modules = addListToHpt (hsc_HPT e) [(mod_name x, x) | x <- mod_infos]-  in e { hsc_HPT = new_modules-       , hsc_type_env_var = Nothing-       }-    where-      mod_name = moduleName . mi_module . hm_iface-#endif  recDotDot :: HsRecFields (GhcPass p) arg -> Maybe Int recDotDot x =

@@ -13,26 +13,7 @@         , liftEwM     ) where -#if MIN_VERSION_ghc(9,3,0) import           GHC.Driver.CmdLine-import           GHC.Driver.Session     (CmdLineP (..), getCmdLineState,-                                         processCmdLineP, putCmdLineState)-#else-import           Control.Monad.IO.Class-import           GHC                    (Located)-import           GHC.Driver.CmdLine-#endif+import           GHC.Driver.Session (CmdLineP (..), getCmdLineState,+                                     processCmdLineP, putCmdLineState) -#if !MIN_VERSION_ghc(9,3,0)--- | A helper to parse a set of flags from a list of command-line arguments, handling--- response files.-processCmdLineP-    :: forall s m. MonadIO m-    => [Flag (CmdLineP s)]  -- ^ valid flags to match against-    -> s                    -- ^ current state-    -> [Located String]     -- ^ arguments to parse-    -> m (([Located String], [Err], [Warn]), s)-                            -- ^ (leftovers, errors, warnings)-processCmdLineP activeFlags s0 args =-    pure $ runCmdLine (processArgs activeFlags args) s0-#endif

@@ -58,9 +58,6 @@     pattern ExposePackage,     parseDynamicFlagsCmdLine,     parseDynamicFilePragma,-#if !MIN_VERSION_ghc(9,3,0)-    WarnReason(..),-#endif     wWarningFlags,     updOptLevel,     -- slightly unsafe@@ -72,12 +69,14 @@     IfaceTyCon(..),     ModIface,     ModIface_(..),+#if MIN_VERSION_ghc(9,11,0)+    pattern ModIface,+    set_mi_top_env,+    set_mi_usages,+#endif     HscSource(..),     WhereFrom(..),     loadInterface,-#if !MIN_VERSION_ghc(9,3,0)-    SourceModified(..),-#endif     loadModuleInterface,     RecompileRequired(..),     mkPartialIface,@@ -236,7 +235,11 @@     ModuleOrigin(..),     PackageName(..),     -- * Linker+#if MIN_VERSION_ghc(9,11,0)+    LinkablePart(..),+#else     Unlinked(..),+#endif     Linkable(..),     unload,     -- * Hooks@@ -359,7 +362,6 @@     module GHC.Parser.Header,     module GHC.Parser.Lexer,     module GHC.Utils.Panic,-#if MIN_VERSION_ghc(9,3,0)     CompileReason(..),     hsc_type_env_vars,     hscUpdateHUG, hsc_HUG,@@ -372,7 +374,6 @@     module GHC.Unit.Finder.Types,     module GHC.Unit.Env,     module GHC.Driver.Phases,-#endif #if !MIN_VERSION_ghc(9,4,0)     pattern HsFieldBind,     hfbAnn,@@ -460,7 +461,7 @@ import           GHC.Tc.Utils.Env import           GHC.Tc.Utils.Monad          hiding (Applicative (..), IORef,                                               MonadFix (..), MonadIO (..), allM,-                                              anyM, concatMapM, mapMaybeM,+                                              anyM, concatMapM, mapMaybeM, foldMapM,                                               (<$>)) import           GHC.Tc.Utils.TcType         as TcType import qualified GHC.Types.Avail             as Avail@@ -495,12 +496,15 @@ import           Data.Foldable               (toList) import           GHC.Core.Multiplicity       (scaledThing) import           GHC.Data.Bag+import qualified GHC.Data.Strict             as Strict+import qualified GHC.Driver.Config.Finder    as GHC+import qualified GHC.Driver.Config.Tidy      as GHC import           GHC.Driver.Env-import           GHC.Hs                       (HsModule (..))-#if !MIN_VERSION_ghc(9,9,0)-import           GHC.Hs                       (SrcSpanAnn')-#endif-import           GHC.Hs.Decls                 hiding (FunDep)+import           GHC.Driver.Env              as GHCi+import           GHC.Driver.Env.KnotVars+import           GHC.Driver.Errors.Types+import           GHC.Hs                      (HsModule (..))+import           GHC.Hs.Decls                hiding (FunDep) import           GHC.Hs.Doc import           GHC.Hs.Expr import           GHC.Hs.Extension@@ -524,73 +528,66 @@ import           GHC.Types.Target            (Target (..), TargetId (..)) import           GHC.Types.TyThing import           GHC.Types.TyThing.Ppr+import           GHC.Types.Unique+import           GHC.Types.Unique.Map+import           GHC.Unit.Env import           GHC.Unit.Finder             hiding (mkHomeModLocation)+import qualified GHC.Unit.Finder             as GHC+import           GHC.Unit.Finder.Types import           GHC.Unit.Home.ModInfo+import           GHC.Unit.Module.Graph import           GHC.Unit.Module.Imported import           GHC.Unit.Module.ModDetails import           GHC.Unit.Module.ModGuts+#if !MIN_VERSION_ghc(9,9,0)+import           GHC.Hs                      (SrcSpanAnn')+#endif import           GHC.Unit.Module.ModIface    (IfaceExport, ModIface,-                                              ModIface_ (..), mi_fix)+                                              ModIface_ (..), mi_fix+#if MIN_VERSION_ghc(9,11,0)+                                             , pattern ModIface+                                             , set_mi_top_env+                                             , set_mi_usages+#endif+                                             ) import           GHC.Unit.Module.ModSummary  (ModSummary (..))+import           GHC.Utils.Error             (mkPlainErrorMsgEnvelope)+import           GHC.Utils.Panic+import           GHC.Utils.TmpFs import           Language.Haskell.Syntax     hiding (FunDep) --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,3,0)-import           GHC.Types.SourceFile        (SourceModified (..))-import qualified GHC.Unit.Finder             as GHC-import           GHC.Unit.Module.Graph       (mkModuleGraph)-#endif+-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if MIN_VERSION_ghc(9,3,0)-import qualified GHC.Data.Strict             as Strict-import qualified GHC.Driver.Config.Finder    as GHC-import qualified GHC.Driver.Config.Tidy      as GHC-import           GHC.Driver.Env              as GHCi-import           GHC.Driver.Env.KnotVars-import           GHC.Driver.Errors.Types-import           GHC.Types.Unique-import           GHC.Types.Unique.Map-import           GHC.Unit.Env-import qualified GHC.Unit.Finder             as GHC-import           GHC.Unit.Finder.Types-import           GHC.Unit.Module.Graph-import           GHC.Utils.Error             (mkPlainErrorMsgEnvelope)-import           GHC.Utils.Panic-import           GHC.Utils.TmpFs+#if MIN_VERSION_ghc(9,11,0)+import System.OsPath #endif  #if !MIN_VERSION_ghc(9,7,0) import           GHC.Types.Avail             (greNamePrintableName) #endif +#if !MIN_VERSION_ghc(9,9,0)+import           GHC.Hs                      (SrcSpanAnn')+#endif+ mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO Module.ModLocation-#if MIN_VERSION_ghc(9,3,0)-mkHomeModLocation df mn f = pure $ GHC.mkHomeModLocation (GHC.initFinderOpts df) mn f+#if MIN_VERSION_ghc(9,11,0)+mkHomeModLocation df mn f =+  let osf = unsafeEncodeUtf f+  in pure $ GHC.mkHomeModLocation (GHC.initFinderOpts df) mn osf #else-mkHomeModLocation = GHC.mkHomeModLocation+mkHomeModLocation df mn f = pure $ GHC.mkHomeModLocation (GHC.initFinderOpts df) mn f #endif -#if MIN_VERSION_ghc(9,3,0) pattern RealSrcSpan :: SrcLoc.RealSrcSpan -> Maybe BufSpan -> SrcLoc.SrcSpan-#else-pattern RealSrcSpan :: SrcLoc.RealSrcSpan -> Maybe BufSpan -> SrcLoc.SrcSpan-#endif -#if MIN_VERSION_ghc(9,3,0) pattern RealSrcSpan x y <- SrcLoc.RealSrcSpan x ((\case Strict.Nothing -> Nothing; Strict.Just a -> Just a) -> y) where   RealSrcSpan x y = SrcLoc.RealSrcSpan x (case y of Nothing -> Strict.Nothing; Just a -> Strict.Just a) -#else-pattern RealSrcSpan x y = SrcLoc.RealSrcSpan x y-#endif {-# COMPLETE RealSrcSpan, UnhelpfulSpan #-} -#if MIN_VERSION_ghc(9,3,0) pattern RealSrcLoc :: SrcLoc.RealSrcLoc -> Strict.Maybe BufPos-> SrcLoc.SrcLoc-#else-pattern RealSrcLoc :: SrcLoc.RealSrcLoc -> Maybe BufPos-> SrcLoc.SrcLoc-#endif pattern RealSrcLoc x y = SrcLoc.RealSrcLoc x y {-# COMPLETE RealSrcLoc, UnhelpfulLoc #-} @@ -664,6 +661,8 @@ #if MIN_VERSION_ghc(9,9,0) instance HasSrcSpan (SrcLoc.GenLocated (EpAnn ann) a) where   getLoc (L l _) = getLoc l+instance HasSrcSpan (SrcLoc.GenLocated (GHC.EpaLocation) a) where+  getLoc = GHC.getHasLoc #else instance HasSrcSpan (SrcSpanAnn' ann) where   getLoc = GHC.locA@@ -703,7 +702,7 @@ loadDLL :: HscEnv -> String -> IO (Maybe String) loadDLL env str = do     res <- GHCi.loadDLL (GHCi.hscInterp env) str-#if MIN_VERSION_ghc(9,11,0)+#if MIN_VERSION_ghc(9,11,0) || (MIN_VERSION_ghc(9, 8, 3) && !MIN_VERSION_ghc(9, 9, 0))     pure $       case res of         Left err_msg -> Just err_msg@@ -718,12 +717,6 @@     (GHCi.hscInterp hsc_env)     hsc_env linkables -#if !MIN_VERSION_ghc(9,3,0)-setOutputFile :: FilePath -> DynFlags -> DynFlags-setOutputFile f d = d {-  outputFile_    = Just f-  }-#endif  isSubspanOfA :: LocatedAn la a -> LocatedAn lb b -> Bool isSubspanOfA a b = SrcLoc.isSubspanOf (GHC.getLocA a) (GHC.getLocA b)@@ -744,7 +737,7 @@ #endif     ,gre_par, gre_lcl, gre_imp = (toList -> gre_imp)} -collectHsBindsBinders :: CollectPass p => Bag (XRec p (HsBindLR p idR)) -> [IdP p]+collectHsBindsBinders :: CollectPass p => LHsBindsLR p idR -> [IdP p] collectHsBindsBinders x = GHC.collectHsBindsBinders CollNoDictBinders x  @@ -752,54 +745,28 @@ makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails makeSimpleDetails hsc_env =   GHC.makeSimpleDetails-#if MIN_VERSION_ghc(9,3,0)               (hsc_logger hsc_env)-#else-              hsc_env-#endif  mkIfaceTc :: HscEnv -> GHC.SafeHaskellMode -> ModDetails -> ModSummary -> Maybe CoreProgram -> TcGblEnv -> IO ModIface mkIfaceTc hscEnv shm md _ms _mcp = #if MIN_VERSION_ghc(9,5,0)   GHC.mkIfaceTc hscEnv shm md _ms _mcp -- mcp::Maybe CoreProgram is only used in GHC >= 9.6-#elif MIN_VERSION_ghc(9,3,0)-  GHC.mkIfaceTc hscEnv shm md _ms -- ms::ModSummary is only used in GHC >= 9.4 #else-  GHC.mkIfaceTc hscEnv shm md+  GHC.mkIfaceTc hscEnv shm md _ms -- ms::ModSummary is only used in GHC >= 9.4 #endif  mkBootModDetailsTc :: HscEnv -> TcGblEnv -> IO ModDetails mkBootModDetailsTc session = GHC.mkBootModDetailsTc-#if MIN_VERSION_ghc(9,3,0)           (hsc_logger session)-#else-          session-#endif -#if !MIN_VERSION_ghc(9,3,0)-type TidyOpts = HscEnv-#endif  initTidyOpts :: HscEnv -> IO TidyOpts initTidyOpts =-#if MIN_VERSION_ghc(9,3,0)   GHC.initTidyOpts-#else-  pure-#endif -#if MIN_VERSION_ghc(9,3,0) driverNoStop :: StopPhase driverNoStop = NoStop-#else-driverNoStop :: Phase-driverNoStop = StopLn-#endif -#if !MIN_VERSION_ghc(9,3,0)-hscUpdateHPT :: (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv-hscUpdateHPT k session = session { hsc_HPT = k (hsc_HPT session) }-#endif  #if !MIN_VERSION_ghc(9,4,0) pattern HsFieldBind :: XHsRecField id -> id -> arg -> Bool -> HsRecField' id arg@@ -846,11 +813,7 @@ #endif  mkSimpleTarget :: DynFlags -> FilePath -> Target-#if MIN_VERSION_ghc(9,3,0) mkSimpleTarget df fp = Target (TargetFile fp Nothing) True (homeUnitId_ df) Nothing-#else-mkSimpleTarget _ fp = Target (TargetFile fp Nothing) True Nothing-#endif  #if MIN_VERSION_ghc(9,7,0) lookupGlobalRdrEnv gre_env occ = lookupGRE gre_env (LookupOccName occ AllRelevantGREs)

@@ -0,0 +1,155 @@+-- ============================================================================+-- DO NOT EDIT+-- This module copies parts of the driver code in GHC.Driver.Main to provide+-- `hscTypecheckRenameWithDiagnostics`.+-- Issue to add this function: https://gitlab.haskell.org/ghc/ghc/-/issues/24996+-- MR to add this function: https://gitlab.haskell.org/ghc/ghc/-/merge_requests/12891+-- ============================================================================++{-# LANGUAGE CPP #-}++module Development.IDE.GHC.Compat.Driver+    ( hscTypecheckRenameWithDiagnostics+    ) where++#if MIN_VERSION_ghc(9,11,0)++import           GHC.Driver.Main            (hscTypecheckRenameWithDiagnostics)++#else++import           Control.Monad+import           GHC.Core+import           GHC.Data.FastString+import           GHC.Data.Maybe+import           GHC.Driver.Env+import           GHC.Driver.Errors.Types+import           GHC.Driver.Main+import           GHC.Driver.Session+import           GHC.Hs+import           GHC.Hs.Dump+import           GHC.Iface.Ext.Ast          (mkHieFile)+import           GHC.Iface.Ext.Binary       (hie_file_result, readHieFile,+                                             writeHieFile)+import           GHC.Iface.Ext.Debug        (diffFile, validateScopes)+import           GHC.Iface.Ext.Types        (getAsts, hie_asts, hie_module)+import           GHC.Tc.Module+import           GHC.Tc.Utils.Monad+import           GHC.Types.SourceFile+import           GHC.Types.SrcLoc+import           GHC.Unit+import           GHC.Unit.Module.ModDetails+import           GHC.Unit.Module.ModIface+import           GHC.Unit.Module.ModSummary+import           GHC.Utils.Error+import           GHC.Utils.Logger+import           GHC.Utils.Outputable+import           GHC.Utils.Panic.Plain++hscTypecheckRenameWithDiagnostics :: HscEnv -> ModSummary -> HsParsedModule+                   -> IO ((TcGblEnv, RenamedStuff), Messages GhcMessage)+hscTypecheckRenameWithDiagnostics hsc_env mod_summary rdr_module =+    runHsc' hsc_env $ hsc_typecheck True mod_summary (Just rdr_module)++-- ============================================================================+-- DO NOT EDIT - Refer to top of file+-- ============================================================================+hsc_typecheck :: Bool -- ^ Keep renamed source?+              -> ModSummary -> Maybe HsParsedModule+              -> Hsc (TcGblEnv, RenamedStuff)+hsc_typecheck keep_rn mod_summary mb_rdr_module = do+    hsc_env <- getHscEnv+    let hsc_src = ms_hsc_src mod_summary+        dflags = hsc_dflags hsc_env+        home_unit = hsc_home_unit hsc_env+        outer_mod = ms_mod mod_summary+        mod_name = moduleName outer_mod+        outer_mod' = mkHomeModule home_unit mod_name+        inner_mod = homeModuleNameInstantiation home_unit mod_name+        src_filename  = ms_hspp_file mod_summary+        real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1+        keep_rn' = gopt Opt_WriteHie dflags || keep_rn+    massert (isHomeModule home_unit outer_mod)+    tc_result <- if hsc_src == HsigFile && not (isHoleModule inner_mod)+        then ioMsgMaybe $ hoistTcRnMessage $ tcRnInstantiateSignature hsc_env outer_mod' real_loc+        else+         do hpm <- case mb_rdr_module of+                    Just hpm -> return hpm+                    Nothing  -> hscParse' mod_summary+            tc_result0 <- tcRnModule' mod_summary keep_rn' hpm+            if hsc_src == HsigFile+                then+#if MIN_VERSION_ghc(9,5,0)+                     do (iface, _) <- liftIO $ hscSimpleIface hsc_env Nothing tc_result0 mod_summary+#else+                     do (iface, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 mod_summary+#endif+                        ioMsgMaybe $ hoistTcRnMessage $+                            tcRnMergeSignatures hsc_env hpm tc_result0 iface+                else return tc_result0+    rn_info <- extract_renamed_stuff mod_summary tc_result+    return (tc_result, rn_info)++-- ============================================================================+-- DO NOT EDIT - Refer to top of file+-- ============================================================================+extract_renamed_stuff :: ModSummary -> TcGblEnv -> Hsc RenamedStuff+extract_renamed_stuff mod_summary tc_result = do+    let rn_info = getRenamedStuff tc_result++    dflags <- getDynFlags+    logger <- getLogger+    liftIO $ putDumpFileMaybe logger Opt_D_dump_rn_ast "Renamer"+                FormatHaskell (showAstData NoBlankSrcSpan NoBlankEpAnnotations rn_info)++    -- Create HIE files+    when (gopt Opt_WriteHie dflags) $ do+        -- I assume this fromJust is safe because `-fwrite-hie-file`+        -- enables the option which keeps the renamed source.+        hieFile <- mkHieFile mod_summary tc_result (fromJust rn_info)+        let out_file = ml_hie_file $ ms_location mod_summary+        liftIO $ writeHieFile out_file hieFile+        liftIO $ putDumpFileMaybe logger Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile)++        -- Validate HIE files+        when (gopt Opt_ValidateHie dflags) $ do+            hs_env <- Hsc $ \e w -> return (e, w)+            liftIO $ do+              -- Validate Scopes+              case validateScopes (hie_module hieFile) $ getAsts $ hie_asts hieFile of+                  [] -> putMsg logger $ text "Got valid scopes"+                  xs -> do+                    putMsg logger $ text "Got invalid scopes"+                    mapM_ (putMsg logger) xs+              -- Roundtrip testing+              file' <- readHieFile (hsc_NC hs_env) out_file+              case diffFile hieFile (hie_file_result file') of+                [] ->+                  putMsg logger $ text "Got no roundtrip errors"+                xs -> do+                  putMsg logger $ text "Got roundtrip errors"+                  let logger' = updateLogFlags logger (log_set_dopt Opt_D_ppr_debug)+                  mapM_ (putMsg logger') xs+    return rn_info++-- ============================================================================+-- DO NOT EDIT - Refer to top of file+-- ============================================================================+#if MIN_VERSION_ghc(9,5,0)+hscSimpleIface :: HscEnv+               -> Maybe CoreProgram+               -> TcGblEnv+               -> ModSummary+               -> IO (ModIface, ModDetails)+hscSimpleIface hsc_env mb_core_program tc_result summary+    = runHsc hsc_env $ hscSimpleIface' mb_core_program tc_result summary+#else+hscSimpleIface :: HscEnv+               -> TcGblEnv+               -> ModSummary+               -> IO (ModIface, ModDetails)+hscSimpleIface hsc_env tc_result summary+    = runHsc hsc_env $ hscSimpleIface' tc_result summary+#endif++#endif

@@ -4,11 +4,7 @@ -- 'UnitEnv' and some DynFlags compat functions. module Development.IDE.GHC.Compat.Env (     Env.HscEnv(hsc_FC, hsc_NC, hsc_IC, hsc_mod_graph-#if MIN_VERSION_ghc(9,3,0)               , hsc_type_env_vars-#else-              , hsc_type_env_var-#endif               ),     Env.hsc_HPT,     InteractiveContext(..),@@ -19,9 +15,6 @@     Env.hsc_logger,     Env.hsc_tmpfs,     Env.hsc_unit_env,-#if !MIN_VERSION_ghc(9,3,0)-    Env.hsc_unit_dbs,-#endif     Env.hsc_hooks,     hscSetHooks,     TmpFs,@@ -64,6 +57,7 @@ import           GHC                 (setInteractiveDynFlags)  import           GHC.Driver.Backend  as Backend+import           GHC.Driver.Env      (HscEnv, hscSetActiveUnitId) import qualified GHC.Driver.Env      as Env import           GHC.Driver.Hooks    (Hooks) import           GHC.Driver.Session@@ -76,41 +70,12 @@ import           GHC.Utils.Logger import           GHC.Utils.TmpFs --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,3,0)-import qualified Data.Set            as S-import           GHC.Driver.Env      (HscEnv, hsc_EPS)-#endif--#if MIN_VERSION_ghc(9,3,0)-import           GHC.Driver.Env      (HscEnv, hscSetActiveUnitId)-#endif---#if !MIN_VERSION_ghc(9,3,0)-hscSetActiveUnitId :: UnitId -> HscEnv -> HscEnv-hscSetActiveUnitId _ env = env--reexportedModules :: HscEnv -> S.Set a-reexportedModules _ = S.empty-#endif--#if MIN_VERSION_ghc(9,3,0) hsc_EPS :: HscEnv -> UnitEnv hsc_EPS = Env.hsc_unit_env-#endif -#if !MIN_VERSION_ghc(9,3,0)-workingDirectory :: a -> Maybe b-workingDirectory _ = Nothing- setWorkingDirectory :: FilePath -> DynFlags -> DynFlags-setWorkingDirectory = const id-#else-setWorkingDirectory :: FilePath -> DynFlags -> DynFlags setWorkingDirectory p d = d { workingDirectory =  Just p }-#endif  setHomeUnitId_ :: UnitId -> DynFlags -> DynFlags setHomeUnitId_ uid df = df { Session.homeUnitId_ = uid }

@@ -0,0 +1,68 @@+{-# LANGUAGE CPP             #-}+{-# LANGUAGE TemplateHaskell #-}+module Development.IDE.GHC.Compat.Error (+  -- * Top-level error types and lens for easy access+  MsgEnvelope(..),+  msgEnvelopeErrorL,+  GhcMessage(..),+  -- * Error messages for the typechecking and renamer phase+  TcRnMessage (..),+  TcRnMessageDetailed (..),+  stripTcRnMessageContext,+  -- * Parsing error message+  PsMessage(..),+  -- * Desugaring diagnostic+  DsMessage (..),+  -- * Driver error message+  DriverMessage (..),+  -- * General Diagnostics+  Diagnostic(..),+  -- * Prisms for error selection+  _TcRnMessage,+  _GhcPsMessage,+  _GhcDsMessage,+  _GhcDriverMessage,+  ) where++import           Control.Lens+import           GHC.Driver.Errors.Types+import           GHC.HsToCore.Errors.Types+import           GHC.Tc.Errors.Types+import           GHC.Types.Error++_TcRnMessage :: Prism' GhcMessage TcRnMessage+_TcRnMessage = prism' GhcTcRnMessage (\case+  GhcTcRnMessage tcRnMsg -> Just tcRnMsg+  _ -> Nothing)++_GhcPsMessage :: Prism' GhcMessage PsMessage+_GhcPsMessage = prism' GhcPsMessage (\case+  GhcPsMessage psMsg -> Just psMsg+  _ -> Nothing)++_GhcDsMessage :: Prism' GhcMessage DsMessage+_GhcDsMessage = prism' GhcDsMessage (\case+  GhcDsMessage dsMsg -> Just dsMsg+  _ -> Nothing)++_GhcDriverMessage :: Prism' GhcMessage DriverMessage+_GhcDriverMessage = prism' GhcDriverMessage (\case+  GhcDriverMessage driverMsg -> Just driverMsg+  _ -> Nothing)++-- | Some 'TcRnMessage's are nested in other constructors for additional context.+-- For example, 'TcRnWithHsDocContext' and 'TcRnMessageWithInfo'.+-- However, in some occasions you don't need the additional context and you just want+-- the error message. @'stripTcRnMessageContext'@ recursively unwraps these constructors,+-- until there are no more constructors with additional context.+--+stripTcRnMessageContext :: TcRnMessage -> TcRnMessage+stripTcRnMessageContext = \case+#if MIN_VERSION_ghc(9, 6, 1)+  TcRnWithHsDocContext _ tcMsg -> stripTcRnMessageContext tcMsg+#endif+  TcRnMessageWithInfo _ (TcRnMessageDetailed _ tcMsg) -> stripTcRnMessageContext tcMsg+  msg -> msg++msgEnvelopeErrorL :: Lens' (MsgEnvelope e) e+msgEnvelopeErrorL = lens errMsgDiagnostic (\envelope e -> envelope { errMsgDiagnostic = e } )

@@ -9,25 +9,22 @@ import           Development.IDE.GHC.Compat.Env import           Development.IDE.GHC.Compat.Outputable import           GHC+import           GHC.Driver.Session                    (targetProfile) import qualified GHC.Iface.Load                        as Iface import           GHC.Unit.Finder.Types                 (FindResult)  -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if MIN_VERSION_ghc(9,3,0)-import           GHC.Driver.Session                    (targetProfile)-#endif- #if MIN_VERSION_ghc(9,7,0) import           GHC.Iface.Errors.Ppr                  (missingInterfaceErrorDiagnostic) import           GHC.Iface.Errors.Types                (IfaceMessage) #endif  writeIfaceFile :: HscEnv -> FilePath -> ModIface -> IO ()-#if MIN_VERSION_ghc(9,3,0)+#if MIN_VERSION_ghc(9,11,0)+writeIfaceFile env fp iface = Iface.writeIface (hsc_logger env) (targetProfile $ hsc_dflags env) (Iface.flagsToIfCompression $ hsc_dflags env) fp iface+#elif MIN_VERSION_ghc(9,3,0) writeIfaceFile env fp iface = Iface.writeIface (hsc_logger env) (targetProfile $ hsc_dflags env) fp iface-#else-writeIfaceFile env fp iface = Iface.writeIface (hsc_logger env) (hsc_dflags env) fp iface #endif  cannotFindModule :: HscEnv -> ModuleName -> FindResult -> SDoc

@@ -14,20 +14,14 @@ import           Development.IDE.GHC.Compat.Outputable  +import           GHC.Types.Error import           GHC.Utils.Logger                      as Logger import           GHC.Utils.Outputable --- See Note [Guidelines For Using CPP In GHCIDE Import Statements]--#if MIN_VERSION_ghc(9,3,0)-import           GHC.Types.Error-#endif- putLogHook :: Logger -> HscEnv -> HscEnv putLogHook logger env =   env { hsc_logger = logger } -#if MIN_VERSION_ghc(9,3,0) type LogActionCompat = LogFlags -> Maybe DiagnosticReason -> Maybe Severity -> SrcSpan -> PrintUnqualified -> SDoc -> IO ()  -- alwaysQualify seems to still do the right thing here, according to the "unqualified warnings" test.@@ -41,11 +35,3 @@ #endif logActionCompat logAction logFlags _cls loc = logAction logFlags Nothing Nothing loc alwaysQualify -#else-type LogActionCompat = DynFlags -> WarnReason -> Severity -> SrcSpan -> PrintUnqualified -> SDoc -> IO ()---- alwaysQualify seems to still do the right thing here, according to the "unqualified warnings" test.-logActionCompat :: LogActionCompat -> LogAction-logActionCompat logAction dynFlags wr severity loc = logAction dynFlags wr severity loc alwaysQualify--#endif

@@ -24,7 +24,6 @@     initDiagOpts,     pprMessages, #endif-#if MIN_VERSION_ghc(9,3,0)     DiagnosticReason(..),     renderDiagnosticMessageWithHints,     pprMsgEnvelopeBagWithLoc,@@ -34,10 +33,6 @@     errMsgDiagnostic,     unDecorated,     diagnosticMessage,-#else-    pprWarning,-    pprError,-#endif     -- * Error infrastructure     DecoratedSDoc,     MsgEnvelope,@@ -53,33 +48,24 @@     textDoc,     ) where +import           Data.Maybe+import           GHC.Driver.Config.Diagnostic import           GHC.Driver.Env import           GHC.Driver.Ppr import           GHC.Driver.Session+import           GHC.Parser.Errors.Types import qualified GHC.Types.Error              as Error import           GHC.Types.Name.Ppr import           GHC.Types.Name.Reader import           GHC.Types.SourceError import           GHC.Types.SrcLoc import           GHC.Unit.State+import           GHC.Utils.Error import           GHC.Utils.Outputable         as Out import           GHC.Utils.Panic  -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,3,0)-import           GHC.Parser.Errors-import qualified GHC.Parser.Errors.Ppr        as Ppr-import           GHC.Utils.Error              hiding (mkWarnMsg)-#endif--#if MIN_VERSION_ghc(9,3,0)-import           Data.Maybe-import           GHC.Driver.Config.Diagnostic-import           GHC.Parser.Errors.Types-import           GHC.Utils.Error-#endif- #if MIN_VERSION_ghc(9,5,0) import           GHC.Driver.Errors.Types      (DriverMessage, GhcMessage) #endif@@ -114,41 +100,29 @@     doc' = pprWithUnitState emptyUnitState doc  -#if !MIN_VERSION_ghc(9,3,0)-pprWarning :: PsWarning -> MsgEnvelope DecoratedSDoc-pprWarning =-  Ppr.pprWarning -pprError :: PsError -> MsgEnvelope DecoratedSDoc-pprError =-  Ppr.pprError-#endif- formatErrorWithQual :: DynFlags -> MsgEnvelope DecoratedSDoc -> String formatErrorWithQual dflags e =   showSDoc dflags (pprNoLocMsgEnvelope e) -#if MIN_VERSION_ghc(9,3,0) pprNoLocMsgEnvelope :: MsgEnvelope DecoratedSDoc -> SDoc-#else-pprNoLocMsgEnvelope :: Error.RenderableDiagnostic e => MsgEnvelope e -> SDoc-#endif pprNoLocMsgEnvelope (MsgEnvelope { errMsgDiagnostic = e                                  , errMsgContext   = unqual })   = sdocWithContext $ \_ctx ->     withErrStyle unqual $ #if MIN_VERSION_ghc(9,7,0)       formatBulleted e-#elif MIN_VERSION_ghc(9,3,0)-      formatBulleted _ctx $ e #else-      formatBulleted _ctx $ Error.renderDiagnostic e+      formatBulleted _ctx e #endif   +#if MIN_VERSION_ghc(9,5,0)+type ErrMsg  = MsgEnvelope GhcMessage+type WarnMsg  = MsgEnvelope GhcMessage+#else type ErrMsg  = MsgEnvelope DecoratedSDoc-#if MIN_VERSION_ghc(9,3,0) type WarnMsg  = MsgEnvelope DecoratedSDoc #endif @@ -165,7 +139,6 @@   mkPrintUnqualified (hsc_unit_env env) #endif -#if MIN_VERSION_ghc(9,3,0) renderDiagnosticMessageWithHints :: forall a. Diagnostic a => a -> DecoratedSDoc renderDiagnosticMessageWithHints a = Error.unionDecoratedSDoc   (diagnosticMessage@@ -173,16 +146,9 @@     (defaultDiagnosticOpts @a) #endif     a) (mkDecorated $ map ppr $ diagnosticHints a)-#endif -#if MIN_VERSION_ghc(9,3,0) mkWarnMsg :: DynFlags -> Maybe DiagnosticReason -> b -> SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc mkWarnMsg df reason _logFlags l st doc = fmap renderDiagnosticMessageWithHints $ mkMsgEnvelope (initDiagOpts df) l st (mkPlainDiagnostic (fromMaybe WarningWithoutFlag reason) [] doc)-#else-mkWarnMsg :: a -> b -> DynFlags -> SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc-mkWarnMsg _ _ =-  const Error.mkWarnMsg-#endif  textDoc :: String -> SDoc textDoc = text

@@ -5,22 +5,20 @@ module Development.IDE.GHC.Compat.Parser (     initParserOpts,     initParserState,-    ApiAnns,     PsSpan(..),     pattern HsParsedModule,     type GHC.HsParsedModule,     Development.IDE.GHC.Compat.Parser.hpm_module,     Development.IDE.GHC.Compat.Parser.hpm_src_files,-    Development.IDE.GHC.Compat.Parser.hpm_annotations,     pattern ParsedModule,     Development.IDE.GHC.Compat.Parser.pm_parsed_source,     type GHC.ParsedModule,     Development.IDE.GHC.Compat.Parser.pm_mod_summary,     Development.IDE.GHC.Compat.Parser.pm_extra_src_files,-    Development.IDE.GHC.Compat.Parser.pm_annotations,-    mkApiAnns,     -- * API Annotations+#if !MIN_VERSION_ghc(9,11,0)     Anno.AnnKeywordId(..),+#endif     pattern EpaLineComment,     pattern EpaBlockComment     ) where@@ -38,17 +36,8 @@                                                   pm_mod_summary,                                                   pm_parsed_source) import qualified GHC-import           GHC.Hs                          (hpm_module, hpm_src_files)---- See Note [Guidelines For Using CPP In GHCIDE Import Statements]--#if !MIN_VERSION_ghc(9,3,0)-import qualified GHC.Driver.Config               as Config-#endif--#if MIN_VERSION_ghc(9,3,0) import qualified GHC.Driver.Config.Parser        as Config-#endif+import           GHC.Hs                          (hpm_module, hpm_src_files)   @@ -60,34 +49,28 @@ initParserState =   Lexer.initParserState --- GHC 9.2 does not have ApiAnns anymore packaged in ParsedModule. Now the--- annotations are found in the ast.-type ApiAnns = ()- #if MIN_VERSION_ghc(9,5,0)-pattern HsParsedModule :: Located (HsModule GhcPs) -> [FilePath] -> ApiAnns -> GHC.HsParsedModule+pattern HsParsedModule :: Located (HsModule GhcPs) -> [FilePath] -> GHC.HsParsedModule #else-pattern HsParsedModule :: Located HsModule -> [FilePath] -> ApiAnns -> GHC.HsParsedModule+pattern HsParsedModule :: Located HsModule -> [FilePath] -> GHC.HsParsedModule #endif pattern HsParsedModule     { hpm_module     , hpm_src_files-    , hpm_annotations-    } <- ( (,()) -> (GHC.HsParsedModule{..}, hpm_annotations))+    } <- GHC.HsParsedModule{..}     where-        HsParsedModule hpm_module hpm_src_files _hpm_annotations =+        HsParsedModule hpm_module hpm_src_files =             GHC.HsParsedModule hpm_module hpm_src_files  -pattern ParsedModule :: ModSummary -> ParsedSource -> [FilePath] -> ApiAnns -> GHC.ParsedModule+pattern ParsedModule :: ModSummary -> ParsedSource -> [FilePath] -> GHC.ParsedModule pattern ParsedModule     { pm_mod_summary     , pm_parsed_source     , pm_extra_src_files-    , pm_annotations-    } <- ( (,()) -> (GHC.ParsedModule{..}, pm_annotations))+    } <- GHC.ParsedModule{..}     where-        ParsedModule ms parsed extra_src_files _anns =+        ParsedModule ms parsed extra_src_files =             GHC.ParsedModule              { pm_mod_summary = ms              , pm_parsed_source = parsed@@ -95,6 +78,4 @@              } {-# COMPLETE ParsedModule :: GHC.ParsedModule #-} -mkApiAnns :: PState -> ApiAnns-mkApiAnns = const () 

@@ -7,8 +7,6 @@     defaultPlugin,     PluginWithArgs(..),     applyPluginsParsedResultAction,-    initializePlugins,-    initPlugins,      -- * Static plugins     StaticPlugin(..),@@ -20,79 +18,32 @@     ) where  import           Development.IDE.GHC.Compat.Core-import           Development.IDE.GHC.Compat.Env        (hscSetFlags, hsc_dflags)-import           Development.IDE.GHC.Compat.Parser     as Parser+import           Development.IDE.GHC.Compat.Parser as Parser -import qualified GHC.Driver.Env                        as Env-import           GHC.Driver.Plugins                    (Plugin (..),-                                                        PluginWithArgs (..),-                                                        StaticPlugin (..),-                                                        defaultPlugin,-                                                        withPlugins)-import qualified GHC.Runtime.Loader                    as Loader+import qualified GHC.Driver.Env                    as Env+import           GHC.Driver.Plugins                (ParsedResult (..),+                                                    Plugin (..),+                                                    PluginWithArgs (..),+                                                    PsMessages (..),+                                                    StaticPlugin (..),+                                                    defaultPlugin,+                                                    staticPlugins, withPlugins)+import qualified GHC.Parser.Lexer                  as Lexer --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,3,0)-import           Data.Bifunctor                        (bimap)-import           Development.IDE.GHC.Compat.Outputable as Out-import           Development.IDE.GHC.Compat.Util       (Bag)-#endif--#if MIN_VERSION_ghc(9,3,0)-import           GHC.Driver.Plugins                    (ParsedResult (..),-                                                        PsMessages (..),-                                                        staticPlugins)-import qualified GHC.Parser.Lexer                      as Lexer-#endif--#if !MIN_VERSION_ghc(9,3,0)-type PsMessages = (Bag WarnMsg, Bag ErrMsg)-#endif- getPsMessages :: PState -> PsMessages getPsMessages pst =-#if MIN_VERSION_ghc(9,3,0)   uncurry PsMessages $ Lexer.getPsMessages pst-#else-  bimap (fmap pprWarning) (fmap pprError) $ getMessages pst-#endif -applyPluginsParsedResultAction :: HscEnv -> ModSummary -> Parser.ApiAnns -> ParsedSource -> PsMessages -> IO (ParsedSource, PsMessages)-applyPluginsParsedResultAction env ms hpm_annotations parsed msgs = do+applyPluginsParsedResultAction :: HscEnv -> ModSummary -> ParsedSource -> PsMessages -> IO (ParsedSource, PsMessages)+applyPluginsParsedResultAction env ms parsed msgs = do   -- Apply parsedResultAction of plugins   let applyPluginAction p opts = parsedResultAction p opts ms-#if MIN_VERSION_ghc(9,3,0)-  fmap (\result -> (hpm_module (parsedResultModule result), (parsedResultMessages result))) $ runHsc env $ withPlugins-#else-  fmap (\parsed_module -> (hpm_module parsed_module, msgs)) $ runHsc env $ withPlugins-#endif-#if MIN_VERSION_ghc(9,3,0)+  fmap (\result -> (hpm_module (parsedResultModule result), parsedResultMessages result)) $ runHsc env $ withPlugins       (Env.hsc_plugins env)-#else-      env-#endif       applyPluginAction-#if MIN_VERSION_ghc(9,3,0)-      (ParsedResult (HsParsedModule parsed [] hpm_annotations) msgs)-#else-      (HsParsedModule parsed [] hpm_annotations)-#endif+      (ParsedResult (HsParsedModule parsed []) msgs) -initializePlugins :: HscEnv -> IO HscEnv-initializePlugins env = do-    Loader.initializePlugins env --- | Plugins aren't stored in ModSummary anymore since GHC 9.2, but this--- function still returns it for compatibility with 8.10-initPlugins :: HscEnv -> ModSummary -> IO (ModSummary, HscEnv)-initPlugins session modSummary = do-    session1 <- initializePlugins (hscSetFlags (ms_hspp_opts modSummary) session)-    return (modSummary{ms_hspp_opts = hsc_dflags session1}, session1)- hsc_static_plugins :: HscEnv -> [StaticPlugin]-#if MIN_VERSION_ghc(9,3,0) hsc_static_plugins = staticPlugins . Env.hsc_plugins-#else-hsc_static_plugins = Env.hsc_static_plugins-#endif

@@ -5,7 +5,6 @@     -- * UnitState     UnitState,     initUnits,-    oldInitUnits,     unitState,     getUnitName,     explicitUnits,@@ -53,10 +52,17 @@ import           Development.IDE.GHC.Compat.Outputable import           Prelude                               hiding (mod) +import           Control.Monad+import qualified Data.List.NonEmpty                    as NE+import qualified Data.Map.Strict                       as Map+import qualified GHC import qualified GHC.Data.ShortText                    as ST+import qualified GHC.Driver.Session                    as DynFlags+import           GHC.Types.PkgQual                     (PkgQual (NoPkgQual)) import           GHC.Types.Unique.Set import           GHC.Unit.External import qualified GHC.Unit.Finder                       as GHC+import           GHC.Unit.Home.ModInfo import qualified GHC.Unit.Info                         as UnitInfo import           GHC.Unit.State                        (LookupResult, UnitInfo,                                                         UnitInfoMap,@@ -69,40 +75,19 @@ import qualified GHC.Unit.State                        as State import           GHC.Unit.Types --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,3,0)-import           GHC.Data.FastString-import           GHC.Unit.Env-import           GHC.Unit.Finder                       hiding-                                                       (findImportedModule)-import qualified GHC.Unit.Types                        as Unit-#endif--#if MIN_VERSION_ghc(9,3,0)-import           Control.Monad-import qualified Data.List.NonEmpty                    as NE-import qualified Data.Map.Strict                       as Map-import qualified GHC-import qualified GHC.Driver.Session                    as DynFlags-import           GHC.Types.PkgQual                     (PkgQual (NoPkgQual))-import           GHC.Unit.Home.ModInfo-#endif-- type PreloadUnitClosure = UniqSet UnitId  unitState :: HscEnv -> UnitState unitState = ue_units . hsc_unit_env -#if MIN_VERSION_ghc(9,3,0) createUnitEnvFromFlags :: NE.NonEmpty DynFlags -> HomeUnitGraph createUnitEnvFromFlags unitDflags =   let     newInternalUnitEnv dflags = mkHomeUnitEnv dflags emptyHomePackageTable Nothing     unitEnvList = NE.map (\dflags -> (homeUnitId_ dflags, newInternalUnitEnv dflags)) unitDflags   in-    unitEnv_new (Map.fromList (NE.toList (unitEnvList)))+    unitEnv_new (Map.fromList (NE.toList unitEnvList))  initUnits :: [DynFlags] -> HscEnv -> IO HscEnv initUnits unitDflags env = do@@ -135,25 +120,11 @@         , ue_eps             = ue_eps (hsc_unit_env env)         }   pure $ hscSetFlags dflags1 $ hscSetUnitEnv unit_env env-#else-initUnits :: [DynFlags] -> HscEnv -> IO HscEnv-initUnits _df env = pure env -- Can't do anything here, oldInitUnits should already be called-#endif  --- | oldInitUnits only needs to modify DynFlags for GHC <9.2--- For GHC >= 9.2, we need to set the hsc_unit_env also, that is--- done later by initUnits-oldInitUnits :: DynFlags -> IO DynFlags-oldInitUnits = pure- explicitUnits :: UnitState -> [Unit] explicitUnits ue =-#if MIN_VERSION_ghc(9,3,0)   map fst $ State.explicitUnits ue-#else-  State.explicitUnits ue-#endif  listVisibleModuleNames :: HscEnv -> [ModuleName] listVisibleModuleNames env =@@ -166,11 +137,7 @@ lookupModuleWithSuggestions   :: HscEnv   -> ModuleName-#if MIN_VERSION_ghc(9,3,0)   -> GHC.PkgQual-#else-  -> Maybe FastString-#endif   -> LookupResult lookupModuleWithSuggestions env modname mpkg =   State.lookupModuleWithSuggestions (unitState env) modname mpkg@@ -204,10 +171,6 @@ installedModule :: unit -> ModuleName -> GenModule unit installedModule        = Module -#if !MIN_VERSION_ghc(9,3,0)-moduleUnitId :: Module -> UnitId-moduleUnitId = Unit.toUnitId . Unit.moduleUnit-#endif  filterInplaceUnits :: [UnitId] -> [PackageFlag] -> ([UnitId], [PackageFlag]) filterInplaceUnits us packageFlags =@@ -225,11 +188,7 @@  findImportedModule :: HscEnv -> ModuleName -> IO (Maybe Module) findImportedModule env mn = do-#if MIN_VERSION_ghc(9,3,0)     res <- GHC.findImportedModule env mn NoPkgQual-#else-    res <- GHC.findImportedModule env mn Nothing-#endif     case res of         Found _ mod -> pure . pure $ mod         _           -> pure Nothing

@@ -68,6 +68,7 @@  import           Control.Exception.Safe  (MonadCatch, catch, try) import           GHC.Data.Bag+import           GHC.Data.Bool import           GHC.Data.BooleanFormula import           GHC.Data.EnumSet import           GHC.Data.FastString@@ -79,13 +80,3 @@ import           GHC.Utils.Fingerprint import           GHC.Utils.Outputable    (pprHsString) import           GHC.Utils.Panic         hiding (try)---- See Note [Guidelines For Using CPP In GHCIDE Import Statements]--#if !MIN_VERSION_ghc(9,3,0)-import           GHC.Utils.Misc-#endif--#if MIN_VERSION_ghc(9,3,0)-import           GHC.Data.Bool-#endif

@@ -26,6 +26,9 @@ import           GHC.Fingerprint import           GHC.Iface.Binary import           GHC.Iface.Env+#if MIN_VERSION_ghc(9,11,0)+import qualified GHC.Iface.Load                  as Iface+#endif import           GHC.Iface.Recomp.Binary         (fingerprintBinMem) import           GHC.IfaceToCore import           GHC.Types.Id.Make@@ -87,14 +90,20 @@     return (file, fp)  -- | Write a core file-writeBinCoreFile :: FilePath -> CoreFile -> IO Fingerprint-writeBinCoreFile core_path fat_iface = do+writeBinCoreFile :: DynFlags -> FilePath -> CoreFile -> IO Fingerprint+writeBinCoreFile _dflags core_path fat_iface = do     bh <- openBinMem initBinMemSize      let quietTrace =           QuietBinIFace -    putWithUserData quietTrace bh fat_iface+    putWithUserData+      quietTrace+#if MIN_VERSION_ghc(9,11,0)+      (Iface.flagsToIfCompression _dflags)+#endif+      bh+      fat_iface      -- And send the result to the file     writeBinMem bh core_path@@ -141,7 +150,11 @@     | (op, val_index) <- classAllSelIds cls `zip` [0..] ]  get_defn :: Id -> CoreBind-get_defn identifier = NonRec identifier (unfoldingTemplate (realIdUnfolding identifier))+get_defn identifier = NonRec identifier templ+  where+    templ = case maybeUnfoldingTemplate (realIdUnfolding identifier) of+              Nothing -> error "get_dfn: no unfolding template"+              Just x  -> x  toIfaceTopBndr1 :: Module -> Id -> IfaceId toIfaceTopBndr1 mod identifier@@ -197,7 +210,7 @@         name' <- newIfaceName (mkVarOcc $ getOccString name)         pure $ ifid{ ifName = name' }       | otherwise = pure ifid-    unmangle_decl_name _ifid = error $ "tcIfaceId: got non IfaceId: "+    unmangle_decl_name _ifid = error "tcIfaceId: got non IfaceId: "     -- invariant: 'IfaceId' is always a 'IfaceId' constructor     getIfaceId (AnId identifier) = identifier     getIfaceId _                 = error "tcIfaceId: got non Id"

@@ -1,11 +1,15 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP                      #-}+{-# LANGUAGE DisambiguateRecordFields #-} -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 module Development.IDE.GHC.Error   (     -- * Producing Diagnostic values-    diagFromErrMsgs+    diagFromGhcErrorMessages+  , diagFromErrMsgs   , diagFromErrMsg+  , diagFromSDocErrMsgs+  , diagFromSDocErrMsg   , diagFromString   , diagFromStrings   , diagFromGhcException@@ -33,10 +37,13 @@   , toDSeverity   ) where +import           Control.Lens import           Data.Maybe import           Data.String                       (fromString) import qualified Data.Text                         as T-import           Development.IDE.GHC.Compat        (DecoratedSDoc, MsgEnvelope,+import           Data.Tuple.Extra                  (uncurry3)+import           Development.IDE.GHC.Compat        (GhcMessage, MsgEnvelope,+                                                    errMsgDiagnostic,                                                     errMsgSeverity, errMsgSpan,                                                     formatErrorWithQual,                                                     srcErrorMessages)@@ -51,30 +58,51 @@                                                     CodePointRange (CodePointRange))  -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 :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> Maybe (MsgEnvelope GhcMessage) -> FileDiagnostic+diagFromText diagSource sev 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 DecoratedSDoc -> [FileDiagnostic]-diagFromErrMsg diagSource dflags e =-    [ diagFromText diagSource sev (errMsgSpan e)-      $ T.pack $ formatErrorWithQual dflags e-    | Just sev <- [toDSeverity $ errMsgSeverity e]]+diagFromErrMsg :: T.Text -> DynFlags -> MsgEnvelope GhcMessage -> [FileDiagnostic]+diagFromErrMsg diagSource dflags origErr =+    let err = fmap (\e -> (Compat.renderDiagnosticMessageWithHints e, Just origErr)) origErr+    in+    diagFromSDocWithOptionalOrigMsg diagSource dflags err -diagFromErrMsgs :: T.Text -> DynFlags -> Compat.Bag (MsgEnvelope DecoratedSDoc) -> [FileDiagnostic]+-- | Compatibility function for creating '[FileDiagnostic]' from+-- a 'Compat.Bag' of GHC error messages.+-- The function signature changes based on the GHC version.+-- While this is not desirable, it avoids more CPP statements in code+-- that implements actual logic.+#if MIN_VERSION_ghc(9,5,0)+diagFromGhcErrorMessages :: T.Text -> DynFlags -> Compat.Bag (MsgEnvelope GhcMessage) -> [FileDiagnostic]+diagFromGhcErrorMessages sourceParser dflags errs =+    diagFromErrMsgs sourceParser dflags errs+#else+diagFromGhcErrorMessages :: T.Text -> DynFlags -> Compat.Bag (MsgEnvelope Compat.DecoratedSDoc) -> [FileDiagnostic]+diagFromGhcErrorMessages sourceParser dflags errs =+    diagFromSDocErrMsgs sourceParser dflags errs+#endif++diagFromErrMsgs :: T.Text -> DynFlags -> Compat.Bag (MsgEnvelope GhcMessage) -> [FileDiagnostic] diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) . Compat.bagToList +diagFromSDocErrMsg :: T.Text -> DynFlags -> MsgEnvelope Compat.DecoratedSDoc -> [FileDiagnostic]+diagFromSDocErrMsg diagSource dflags err =+    diagFromSDocWithOptionalOrigMsg diagSource dflags (fmap (,Nothing) err)++diagFromSDocErrMsgs :: T.Text -> DynFlags -> Compat.Bag (MsgEnvelope Compat.DecoratedSDoc) -> [FileDiagnostic]+diagFromSDocErrMsgs diagSource dflags = concatMap (diagFromSDocErrMsg diagSource dflags) . Compat.bagToList++diagFromSDocWithOptionalOrigMsg :: T.Text -> DynFlags -> MsgEnvelope (Compat.DecoratedSDoc, Maybe (MsgEnvelope GhcMessage)) -> [FileDiagnostic]+diagFromSDocWithOptionalOrigMsg diagSource dflags err =+    [ diagFromText diagSource sev (errMsgSpan err) (T.pack (formatErrorWithQual dflags (fmap fst err))) (snd (errMsgDiagnostic err))+    | Just sev <- [toDSeverity $ errMsgSeverity err]]+ -- | Convert a GHC SrcSpan to a DAML compiler Range srcSpanToRange :: SrcSpan -> Maybe Range srcSpanToRange (UnhelpfulSpan _)           = Nothing@@ -157,27 +185,19 @@ -- | Convert a GHC severity to a DAML compiler Severity. Severities below -- "Warning" level are dropped (returning Nothing). toDSeverity :: GHC.Severity -> Maybe D.DiagnosticSeverity-#if !MIN_VERSION_ghc(9,3,0)-toDSeverity SevOutput      = Nothing-toDSeverity SevInteractive = Nothing-toDSeverity SevDump        = Nothing-toDSeverity SevInfo        = Just DiagnosticSeverity_Information-toDSeverity SevFatal       = Just DiagnosticSeverity_Error-#else-toDSeverity SevIgnore      = Nothing-#endif-toDSeverity SevWarning     = Just DiagnosticSeverity_Warning-toDSeverity SevError       = Just DiagnosticSeverity_Error+toDSeverity SevIgnore  = Nothing+toDSeverity SevWarning = Just DiagnosticSeverity_Warning+toDSeverity SevError   = Just DiagnosticSeverity_Error   -- | Produce a bag of GHC-style errors (@ErrorMessages@) from the given --   (optional) locations and message strings.-diagFromStrings :: T.Text -> D.DiagnosticSeverity -> [(SrcSpan, String)] -> [FileDiagnostic]-diagFromStrings diagSource sev = concatMap (uncurry (diagFromString diagSource sev))+diagFromStrings :: T.Text -> D.DiagnosticSeverity -> [(SrcSpan, String, Maybe (MsgEnvelope GhcMessage))] -> [FileDiagnostic]+diagFromStrings diagSource sev = concatMap (uncurry3 (diagFromString diagSource sev))  -- | Produce a GHC-style error from a source span and a message.-diagFromString :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> String -> [FileDiagnostic]-diagFromString diagSource sev sp x = [diagFromText diagSource sev sp $ T.pack x]+diagFromString :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> String -> Maybe (MsgEnvelope GhcMessage) -> [FileDiagnostic]+diagFromString diagSource sev sp x origMsg = [diagFromText diagSource sev sp (T.pack x) origMsg]   -- | Produces an "unhelpful" source span with the given string.@@ -207,15 +227,11 @@       Right <$> ghcM     where         ghcExceptionToDiagnostics = return . Left . diagFromGhcException fromWhere dflags-        sourceErrorToDiagnostics = return . Left . diagFromErrMsgs fromWhere dflags-#if MIN_VERSION_ghc(9,3,0)-                                        . fmap (fmap Compat.renderDiagnosticMessageWithHints) . Compat.getMessages-#endif-                                        . srcErrorMessages-+        sourceErrorToDiagnostics diag = pure $ Left $+          diagFromErrMsgs fromWhere dflags (Compat.getMessages (srcErrorMessages diag))  diagFromGhcException :: T.Text -> DynFlags -> GhcException -> [FileDiagnostic]-diagFromGhcException diagSource dflags exc = diagFromString diagSource DiagnosticSeverity_Error (noSpan "<Internal>") (showGHCE dflags exc)+diagFromGhcException diagSource dflags exc = diagFromString diagSource DiagnosticSeverity_Error (noSpan "<Internal>") (showGHCE dflags exc) Nothing  showGHCE :: DynFlags -> GhcException -> String showGHCE dflags exc = case exc of

@@ -7,7 +7,9 @@ -- | Orphan instances for GHC. --   Note that the 'NFData' instances may not be law abiding. module Development.IDE.GHC.Orphans() where-import           Development.IDE.GHC.Compat+import           Development.IDE.GHC.Compat        hiding+                                                   (DuplicateRecordFields,+                                                    FieldSelectors) import           Development.IDE.GHC.Util  import           Control.DeepSeq@@ -17,26 +19,18 @@ import           Data.String                       (IsString (fromString)) import           Data.Text                         (unpack) +import           Data.Bifunctor                    (Bifunctor (..)) import           GHC.ByteCode.Types import           GHC.Data.Bag import           GHC.Data.FastString import qualified GHC.Data.StringBuffer             as SB-import           GHC.Types.SrcLoc---- See Note [Guidelines For Using CPP In GHCIDE Import Statements]--#if !MIN_VERSION_ghc(9,3,0)-import           GHC.Types.Unique                  (getKey)-import           GHC.Unit.Module.Graph             (ModuleGraph)-#endif--import           Data.Bifunctor                    (Bifunctor (..)) import           GHC.Parser.Annotation--#if MIN_VERSION_ghc(9,3,0)+import           GHC.Types.FieldLabel              (DuplicateRecordFields (DuplicateRecordFields, NoDuplicateRecordFields),+                                                    FieldSelectors (FieldSelectors, NoFieldSelectors)) import           GHC.Types.PkgQual+import           GHC.Types.SrcLoc -#endif+-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]  #if MIN_VERSION_ghc(9,5,0) import           GHC.Unit.Home.ModInfo@@ -57,6 +51,17 @@ instance NFData ModDetails where rnf = rwhnf instance NFData SafeHaskellMode where rnf = rwhnf instance Show Linkable where show = unpack . printOutputable+#if MIN_VERSION_ghc(9,11,0)+instance NFData Linkable where rnf (Linkable a b c) = rnf a `seq` rnf b `seq` rnf c+instance NFData LinkableObjectSort where rnf = rwhnf+instance NFData LinkablePart where+  rnf (DotO a b)         = rnf a `seq` rnf b+  rnf (DotA f)           = rnf f+  rnf (DotDLL f)         = rnf f+  rnf (BCOs a)           = seqCompiledByteCode a+  rnf (CoreBindings wcb) = rnf wcb+  rnf (LazyBCOs a b)     = seqCompiledByteCode a `seq` rnf b+#else instance NFData Linkable where rnf (LM a b c) = rnf a `seq` rnf b `seq` rnf c instance NFData Unlinked where   rnf (DotO f)           = rnf f@@ -66,14 +71,24 @@ #if MIN_VERSION_ghc(9,5,0)   rnf (CoreBindings wcb) = rnf wcb   rnf (LoadedBCOs us)    = rnf us+#endif+#endif +#if MIN_VERSION_ghc(9,5,0) instance NFData WholeCoreBindings where+#if MIN_VERSION_ghc(9,11,0)+  rnf (WholeCoreBindings bs m ml f) = rnf bs `seq` rnf m `seq` rnf ml `seq` rnf f+#else   rnf (WholeCoreBindings bs m ml) = rnf bs `seq` rnf m `seq` rnf ml+#endif  instance NFData ModLocation where+#if MIN_VERSION_ghc(9,11,0)+    rnf (OsPathModLocation mf f1 f2 f3 f4 f5) = rnf mf `seq` rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5+#else     rnf (ModLocation mf f1 f2 f3 f4 f5) = rnf mf `seq` rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5- #endif+#endif  instance Show PackageFlag where show = unpack . printOutputable instance Show InteractiveImport where show = unpack . printOutputable@@ -88,9 +103,6 @@ instance Show Module where     show = moduleNameString . moduleName -#if !MIN_VERSION_ghc(9,3,0)-instance Outputable a => Show (GenLocated SrcSpan a) where show = unpack . printOutputable-#endif  #if !MIN_VERSION_ghc(9,5,0) instance (NFData l, NFData e) => NFData (GenLocated l e) where@@ -131,12 +143,6 @@ instance NFData HieFile where     rnf = rwhnf -#if !MIN_VERSION_ghc(9,3,0)-deriving instance Eq SourceModified-deriving instance Show SourceModified-instance NFData SourceModified where-    rnf = rwhnf-#endif  instance Hashable ModuleName where     hashWithSalt salt = hashWithSalt salt . show@@ -222,7 +228,6 @@ instance NFData HomeModInfo where   rnf (HomeModInfo iface dets link) = rwhnf iface `seq` rnf dets `seq` rnf link -#if MIN_VERSION_ghc(9,3,0) instance NFData PkgQual where   rnf NoPkgQual      = ()   rnf (ThisPkg uid)  = rnf uid@@ -233,7 +238,6 @@  instance NFData NodeKey where   rnf = rwhnf-#endif  #if MIN_VERSION_ghc(9,5,0) instance NFData HomeModLinkable where@@ -246,8 +250,27 @@ instance NFData (Pat (GhcPass Renamed)) where     rnf = rwhnf +instance NFData (HsExpr (GhcPass Typechecked)) where+    rnf = rwhnf++instance NFData (Pat (GhcPass Typechecked)) where+    rnf = rwhnf+ instance NFData Extension where   rnf = rwhnf  instance NFData (UniqFM Name [Name]) where   rnf (ufmToIntMap -> m) = rnf m++#if !MIN_VERSION_ghc(9,5,0)+instance NFData DuplicateRecordFields where+  rnf DuplicateRecordFields   = ()+  rnf NoDuplicateRecordFields = ()++instance NFData FieldSelectors where+  rnf FieldSelectors   = ()+  rnf NoFieldSelectors = ()++instance NFData FieldLabel where+  rnf (FieldLabel a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d+#endif

@@ -255,7 +255,6 @@ -- Tracing exactprint terms  -- | Print a GHC value in `defaultUserStyle` without unique symbols.--- It uses `showSDocUnsafe` with `unsafeGlobalDynFlags` internally. -- -- This is the most common print utility. -- It will do something additionally compared to what the 'Outputable' instance does.

@@ -6,15 +6,37 @@ module Development.IDE.GHC.Warnings(withWarnings) where  import           Control.Concurrent.Strict-import           Data.List+import           Control.Lens                      (over) import qualified Data.Text                         as T  import           Development.IDE.GHC.Compat import           Development.IDE.GHC.Error import           Development.IDE.Types.Diagnostics-import           Language.LSP.Protocol.Types       (type (|?) (..)) +{-+ Note [withWarnings and its dangers]+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    withWarnings collects warnings by registering a custom logger which extracts+    the SDocs of those warnings. If you receive warnings this way, you will not+    get them in a structured form. In the medium term we'd like to remove all+    uses of withWarnings to get structured messages everywhere we can. +    For the time being, withWarnings is no longer used for anything in the main+    typecheckModule codepath, but it is still used for bytecode/object code+    generation, as well as a few other places.++    I suspect some of these functions (e.g. codegen) will need deeper changes to+    be able to get diagnostics as a list, though I don't have great evidence for+    that atm. I haven't taken a look to see if those functions that are wrapped+    with this could produce diagnostics another way.++    It would be good for someone to take a look. What we've done so far gives us+    diagnostics for renaming and typechecking, and doesn't require us to copy+    too much code from GHC or make any deeper changes, and lets us get started+    with the bulk of the useful plugin work, but it would be good to have all+    diagnostics with structure be collected that way.+-}+ -- | Take a GHC monadic action (e.g. @typecheckModule pm@ for some -- parsed module 'pm@') and produce a "decorated" action that will -- harvest any warnings encountered executing the action. The 'phase'@@ -24,42 +46,16 @@ --   https://github.com/ghc/ghc/blob/5f1d949ab9e09b8d95319633854b7959df06eb58/compiler/main/GHC.hs#L623-L640 --   which basically says that log_action is taken from the ModSummary when GHC feels like it. --   The given argument lets you refresh a ModSummary log_action-#if MIN_VERSION_ghc(9,3,0)+--+-- Also, See Note [withWarnings and its dangers] for some commentary on this function. withWarnings :: T.Text -> ((HscEnv -> HscEnv) -> IO a) -> IO ([(Maybe DiagnosticReason, FileDiagnostic)], a)-#else-withWarnings :: T.Text -> ((HscEnv -> HscEnv) -> IO a) -> IO ([(WarnReason, FileDiagnostic)], a)-#endif 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,) . 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   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-attachReason Nothing d = d-attachReason (Just wr) d = d{_code = InR <$> showReason wr}- where-  showReason = \case-    WarningWithFlag flag -> showFlag flag-    _                    -> Nothing-#else-attachReason :: WarnReason -> Diagnostic -> Diagnostic-attachReason wr d = d{_code = InR <$> showReason wr}- where-  showReason = \case-    NoReason       -> Nothing-    Reason flag    -> showFlag flag-    ErrReason flag -> showFlag =<< flag-#endif--showFlag :: WarningFlag -> Maybe T.Text-showFlag flag = ("-W" <>) . T.pack . flagSpecName <$> find ((== flag) . flagSpecFlag) wWarningFlags

@@ -20,6 +20,7 @@   , insertImport   , pathToId   , idToPath+  , idToModLocation   , reachableModules   , processDependencyInformation   , transitiveDeps@@ -47,21 +48,14 @@ import qualified Data.List.NonEmpty                 as NonEmpty import           Data.Maybe import           Data.Tuple.Extra                   hiding (first, second)+import           Development.IDE.GHC.Compat import           Development.IDE.GHC.Orphans        ()-import           GHC.Generics                       (Generic)-import           Prelude                            hiding (mod)- import           Development.IDE.Import.FindImports (ArtifactsLocation (..)) import           Development.IDE.Types.Diagnostics import           Development.IDE.Types.Location--import           Development.IDE.GHC.Compat---- See Note [Guidelines For Using CPP In GHCIDE Import Statements]+import           GHC.Generics                       (Generic)+import           Prelude                            hiding (mod) -#if !MIN_VERSION_ghc(9,3,0)-import           GHC.Unit.Module.Graph              (ModuleGraph)-#endif  -- | The imports for a given module. newtype ModuleImports = ModuleImports

@@ -14,29 +14,23 @@   ) where  import           Control.DeepSeq-import           Development.IDE.GHC.Compat        as Compat-import           Development.IDE.GHC.Error         as ErrUtils-import           Development.IDE.GHC.Orphans       ()-import           Development.IDE.Types.Diagnostics-import           Development.IDE.Types.Location---- standard imports import           Control.Monad.Extra import           Control.Monad.IO.Class import           Data.List                         (find, isSuffixOf) import           Data.Maybe import qualified Data.Set                          as S+import           Development.IDE.GHC.Compat        as Compat+import           Development.IDE.GHC.Error         as ErrUtils+import           Development.IDE.GHC.Orphans       ()+import           Development.IDE.Types.Diagnostics+import           Development.IDE.Types.Location+import           GHC.Types.PkgQual+import           GHC.Unit.State import           System.FilePath --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,3,0)-import           Development.IDE.GHC.Compat.Util-#endif--#if MIN_VERSION_ghc(9,3,0)-import           GHC.Types.PkgQual-import           GHC.Unit.State+#if MIN_VERSION_ghc(9,11,0)+import           GHC.Driver.DynFlags #endif  data Import@@ -105,12 +99,11 @@ -- It only returns Just for unit-ids which are possible to import into the -- current module. In particular, it will return Nothing for 'main' components -- as they can never be imported into another package.-#if MIN_VERSION_ghc(9,3,0) mkImportDirs :: HscEnv -> (UnitId, DynFlags) -> Maybe (UnitId, ([FilePath], S.Set ModuleName))-mkImportDirs _env (i, flags) = Just (i, (importPaths flags, reexportedModules flags))+#if MIN_VERSION_ghc(9,11,0)+mkImportDirs _env (i, flags) = Just (i, (importPaths flags, S.fromList $ map reexportTo $ reexportedModules flags)) #else-mkImportDirs :: HscEnv -> (UnitId, DynFlags) -> Maybe (PackageName, (UnitId, [FilePath], S.Set ModuleName))-mkImportDirs env (i, flags) = (, (i, importPaths flags, S.empty)) <$> getUnitName env i+mkImportDirs _env (i, flags) = Just (i, (importPaths flags, reexportedModules flags)) #endif  -- | locate a module in either the file system or the package database. Where we go from *daml to@@ -122,42 +115,22 @@     -> [String]                        -- ^ File extensions     -> (ModuleName -> NormalizedFilePath -> m (Maybe NormalizedFilePath))  -- ^ does file exist predicate     -> Located ModuleName              -- ^ Module name-#if MIN_VERSION_ghc(9,3,0)     -> PkgQual                -- ^ Package name-#else-    -> Maybe FastString                -- ^ Package name-#endif     -> Bool                            -- ^ Is boot module     -> m (Either [FileDiagnostic] Import) locateModule env comp_info exts targetFor modName mbPkgName isSource = do   case mbPkgName of-#if MIN_VERSION_ghc(9,3,0)     -- 'ThisPkg' just means some home module, not the current unit     ThisPkg uid       | Just (dirs, reexports) <- lookup uid import_paths           -> lookupLocal uid dirs reexports       | otherwise -> return $ Left $ notFoundErr env modName $ LookupNotFound []-#else-    -- "this" means that we should only look in the current package-    Just "this" -> do-      lookupLocal (homeUnitId_ dflags) (importPaths dflags) S.empty-#endif     -- if a package name is given we only go look for a package-#if MIN_VERSION_ghc(9,3,0)     OtherPkg uid       | Just (dirs, reexports) <- lookup uid import_paths           -> lookupLocal uid dirs reexports-#else-    Just pkgName-      | Just (uid, dirs, reexports) <- lookup (PackageName pkgName) import_paths-          -> lookupLocal uid dirs reexports-#endif       | otherwise -> lookupInPackageDB-#if MIN_VERSION_ghc(9,3,0)     NoPkgQual -> do-#else-    Nothing -> do-#endif        -- Reexports for current unit have to be empty because they only apply to other units depending on the       -- current unit. If we set the reexports to be the actual reexports then we risk looping forever trying@@ -181,7 +154,11 @@       -- about which module unit a imports.       -- Without multi-component support it is hard to recontruct the dependency environment so       -- unit a will have both unit b and unit c in scope.+#if MIN_VERSION_ghc(9,11,0)+      map (\uid -> let this_df = homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue) in (uid, importPaths this_df, S.fromList $ map reexportTo $ reexportedModules this_df)) hpt_deps+#else       map (\uid -> let this_df = homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue) in (uid, importPaths this_df, reexportedModules this_df)) hpt_deps+#endif     ue = hsc_unit_env env     units = homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId_ dflags) ue     hpt_deps :: [UnitId]@@ -196,11 +173,7 @@       -- This is particularly important for Paths_* modules which get generated for every component but unless you use it in       -- each component will end up being found in the wrong place and cause a multi-cradle match failure.     _import_paths' = -- import_paths' is only used in GHC < 9.4-#if MIN_VERSION_ghc(9,3,0)             import_paths-#else-            map snd import_paths-#endif      toModLocation uid file = liftIO $ do         loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file)@@ -226,7 +199,7 @@   mkError' $ ppr' $ cannotFindModule env modName0 $ lookupToFindResult reason   where     dfs = hsc_dflags env-    mkError' = diagFromString "not found" DiagnosticSeverity_Error (Compat.getLoc modName)+    mkError' doc = diagFromString "not found" DiagnosticSeverity_Error (Compat.getLoc modName) doc Nothing     modName0 = unLoc modName     ppr' = showSDoc dfs     -- We convert the lookup result to a find result to reuse GHC's cannotFindModule pretty printer.@@ -263,10 +236,5 @@   , fr_suggestions = []   } -#if MIN_VERSION_ghc(9,3,0) noPkgQual :: PkgQual noPkgQual = NoPkgQual-#else-noPkgQual :: Maybe a-noPkgQual = Nothing-#endif

@@ -7,8 +7,10 @@     ( Log(..)     -- * For haskell-language-server     , hover+    , foundHover     , gotoDefinition     , gotoTypeDefinition+    , gotoImplementation     , documentHighlight     , references     , wsSymbols@@ -46,9 +48,11 @@ gotoDefinition     :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (MessageResult Method_TextDocumentDefinition) hover              :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (Hover |? Null) gotoTypeDefinition :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (MessageResult Method_TextDocumentTypeDefinition)+gotoImplementation :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (MessageResult Method_TextDocumentImplementation) documentHighlight  :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) ([DocumentHighlight] |? Null)-gotoDefinition = request "Definition" getDefinition (InR $ InR Null) (InL . Definition. InR)-gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InR Null) (InL . Definition. InR)+gotoDefinition = request "Definition" getDefinition (InR $ InR Null) (InL . Definition . InR . map fst)+gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InR Null) (InL . Definition . InR . map fst)+gotoImplementation = request "Implementation" getImplementationDefinition (InR $ InR Null) (InL . Definition . InR) hover          = request "Hover"      getAtPoint     (InR Null)     foundHover documentHighlight = request "DocumentHighlight" highlightAtPoint (InR Null) InL 

@@ -19,22 +19,18 @@ import           Development.IDE.GHC.Compat import           Development.IDE.GHC.Error      (rangeToRealSrcSpan,                                                  realSrcSpanToRange)-import           Development.IDE.Types.Location import           Development.IDE.GHC.Util       (printOutputable)+import           Development.IDE.Types.Location import           Ide.Types-import           Language.LSP.Protocol.Types             (DocumentSymbol (..),+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types    (DocumentSymbol (..),                                                  DocumentSymbolParams (DocumentSymbolParams, _textDocument),                                                  SymbolKind (..),                                                  TextDocumentIdentifier (TextDocumentIdentifier),-                                                 type (|?) (InL, InR), uriToFilePath)-import          Language.LSP.Protocol.Message+                                                 type (|?) (InL, InR),+                                                 uriToFilePath) --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,3,0)-import qualified Data.Text                      as T-#endif- moduleOutline   :: PluginMethodHandler IdeState Method_TextDocumentDocumentSymbol moduleOutline ideState _ DocumentSymbolParams{ _textDocument = TextDocumentIdentifier uri }@@ -118,21 +114,13 @@         , L (locA -> RealSrcSpan l' _) n <- cs         , let l'' = case con of                 L (locA -> RealSrcSpan l''' _) _ -> l'''-                _ -> l'+                _                                -> l'         ]     }   where     cvtFld :: LFieldOcc GhcPs -> Maybe DocumentSymbol-#if MIN_VERSION_ghc(9,3,0)     cvtFld (L (locA -> RealSrcSpan l' _) n) = Just $ (defDocumentSymbol l' :: DocumentSymbol)-#else-    cvtFld (L (RealSrcSpan l' _) n) = Just $ (defDocumentSymbol l' :: DocumentSymbol)-#endif-#if MIN_VERSION_ghc(9,3,0)                 { _name = printOutputable (unLoc (foLabel n))-#else-                { _name = printOutputable (unLoc (rdrNameFieldOcc n))-#endif                 , _kind = SymbolKind_Field                 }     cvtFld _  = Nothing@@ -148,23 +136,13 @@ documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (InstD _ DataFamInstD { dfid_inst = DataFamInstDecl FamEqn { feqn_tycon, feqn_pats } }))   = Just (defDocumentSymbol l :: DocumentSymbol)     { _name =-#if MIN_VERSION_ghc(9,3,0)-        printOutputable $ pprHsArgsApp (unLoc feqn_tycon) Prefix (feqn_pats)-#else-        printOutputable (unLoc feqn_tycon) <> " " <> T.unwords-                (map printOutputable feqn_pats)-#endif+        printOutputable $ pprHsArgsApp (unLoc feqn_tycon) Prefix feqn_pats     , _kind = SymbolKind_Interface     } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (InstD _ TyFamInstD { tfid_inst = TyFamInstDecl _ FamEqn { feqn_tycon, feqn_pats } }))   = Just (defDocumentSymbol l :: DocumentSymbol)     { _name =-#if MIN_VERSION_ghc(9,3,0)-        printOutputable $ pprHsArgsApp (unLoc feqn_tycon) Prefix (feqn_pats)-#else-        printOutputable (unLoc feqn_tycon) <> " " <> T.unwords-                (map printOutputable feqn_pats)-#endif+        printOutputable $ pprHsArgsApp (unLoc feqn_tycon) Prefix feqn_pats     , _kind = SymbolKind_Interface     } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (DerivD _ DerivDecl { deriv_type })) =@@ -267,18 +245,16 @@     get_flds_h98 :: HsConDeclH98Details GhcPs                  -> [LFieldOcc GhcPs]     get_flds_h98 (RecCon flds) = get_flds (reLoc flds)-    get_flds_h98 _ = []+    get_flds_h98 _             = []      get_flds_gadt :: HsConDeclGADTDetails GhcPs                   -> [LFieldOcc GhcPs] #if MIN_VERSION_ghc(9,9,0)     get_flds_gadt (RecConGADT _ flds) = get_flds (reLoc flds)-#elif MIN_VERSION_ghc(9,3,0)-    get_flds_gadt (RecConGADT flds _) = get_flds (reLoc flds) #else-    get_flds_gadt (RecConGADT flds) = get_flds (reLoc flds)+    get_flds_gadt (RecConGADT flds _) = get_flds (reLoc flds) #endif-    get_flds_gadt _ = []+    get_flds_gadt _                   = []      get_flds :: Located [LConDeclField GhcPs]              -> [LFieldOcc GhcPs]

@@ -41,7 +41,7 @@       trace x = otTracedHandler "Request" (show _method) $ \sp -> do         traceWithSpan sp _params         x-  writeChan chan $ ReactorRequest (_id) (trace $ LSP.runLspT env $ resp' =<< k ide _params) (LSP.runLspT env . resp' . Left)+  writeChan chan $ ReactorRequest _id (trace $ LSP.runLspT env $ resp' =<< k ide _params) (LSP.runLspT env . resp' . Left)  notificationHandler   :: forall m c. PluginMethod Notification m =>

@@ -16,7 +16,6 @@                                                            putMVar, tryReadMVar) import           Control.Concurrent.STM.Stats             (dumpSTMStats) import           Control.Exception.Safe                   (SomeException,-                                                           catchAny,                                                            displayException) import           Control.Monad.Extra                      (concatMapM, unless,                                                            when)@@ -32,7 +31,7 @@ import           Data.Maybe                               (catMaybes, isJust) import qualified Data.Text                                as T import           Development.IDE                          (Action,-                                                           Priority (Debug, Error),+                                                           Priority (Debug),                                                            Rules, hDuplicateTo') import           Development.IDE.Core.Debouncer           (Debouncer,                                                            newAsyncDebouncer)@@ -72,9 +71,9 @@ import qualified Development.IDE.Plugin.Test              as Test import           Development.IDE.Session                  (SessionLoadingOptions,                                                            getHieDbLoc,+                                                           getInitialGhcLibDirDefault,                                                            loadSessionWithOptions,-                                                           retryOnSqliteBusy,-                                                           setInitialDynFlags)+                                                           retryOnSqliteBusy) import qualified Development.IDE.Session                  as Session import           Development.IDE.Types.Location           (NormalizedUri,                                                            toNormalizedFilePath')@@ -136,7 +135,6 @@   | LogLspStart [PluginId]   | LogLspStartDuration !Seconds   | LogShouldRunSubset !Bool-  | LogSetInitialDynFlagsException !SomeException   | LogConfigurationChange T.Text   | LogService Service.Log   | LogShake Shake.Log@@ -160,8 +158,6 @@       "Started LSP server in" <+> pretty (showDuration duration)     LogShouldRunSubset shouldRunSubset ->       "shouldRunSubset:" <+> pretty shouldRunSubset-    LogSetInitialDynFlagsException e ->-      "setInitialDynFlags:" <+> pretty (displayException e)     LogConfigurationChange msg -> "Configuration changed:" <+> pretty msg     LogService msg -> pretty msg     LogShake msg -> pretty msg@@ -329,13 +325,6 @@                 getIdeState env rootPath withHieDb threadQueue = do                   t <- ioT                   logWith recorder Info $ LogLspStartDuration t-                  -- We want to set the global DynFlags right now, so that we can use-                  -- `unsafeGlobalDynFlags` even before the project is configured-                  _mlibdir <--                      setInitialDynFlags (cmapWithPrio LogSession recorder) rootPath argsSessionLoadingOptions-                          -- TODO: should probably catch/log/rethrow at top level instead-                          `catchAny` (\e -> logWith recorder Error (LogSetInitialDynFlagsException e) >> pure Nothing)-                   sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions rootPath (tLoaderQueue threadQueue)                   config <- LSP.runLspT env LSP.getConfig                   let def_options = argsIdeOptions config sessionLoader@@ -435,7 +424,7 @@             let root = argsProjectRoot             dbLoc <- getHieDbLoc root             hPutStrLn stderr $ "Using hiedb at: " ++ dbLoc-            mlibdir <- setInitialDynFlags (cmapWithPrio LogSession recorder) root def+            mlibdir <- getInitialGhcLibDirDefault (cmapWithPrio LogSession recorder) root             rng <- newStdGen             case mlibdir of                 Nothing     -> exitWith $ ExitFailure 1

@@ -19,6 +19,7 @@ import           Data.Maybe import qualified Data.Text                                as T import           Development.IDE.Core.Compile+import           Development.IDE.Core.FileStore           (getUriContents) import           Development.IDE.Core.PluginUtils import           Development.IDE.Core.PositionMapping import           Development.IDE.Core.RuleTypes@@ -133,11 +134,7 @@                   $ runIdeActionE "CompletionResolve.GhcSessionDeps" (shakeExtras ide)                   $ useWithStaleFastE GhcSessionDeps file     let nc = ideNc $ shakeExtras ide-#if MIN_VERSION_ghc(9,3,0)     name <- liftIO $ lookupNameCache nc mod occ-#else-    name <- liftIO $ upNameCache nc (lookupNameCache mod occ)-#endif     mdkm <- liftIO $ runIdeAction "CompletionResolve.GetDocMap" (shakeExtras ide) $ useWithStaleFast GetDocMap file     let (dm,km) = case mdkm of           Just (DKMap docMap tyThingMap, _) -> (docMap,tyThingMap)@@ -169,8 +166,9 @@   CompletionParams{_textDocument=TextDocumentIdentifier uri                   ,_position=position                   ,_context=completionContext} = ExceptT $ do-    contents <- pluginGetVirtualFile $ toNormalizedUri uri-    fmap Right $ case (contents, uriToFilePath' uri) of+    contentsMaybe <-+      liftIO $ runAction "Completion" ide $ getUriContents $ toNormalizedUri uri+    fmap Right $ case (contentsMaybe, uriToFilePath' uri) of       (Just cnts, Just path) -> do         let npath = toNormalizedFilePath' path         (ideOpts, compls, moduleExports, astres) <- liftIO $ runIdeAction "Completion" (shakeExtras ide) $ do@@ -204,7 +202,7 @@             pure (opts, fmap (,pm,binds) compls, moduleExports, astres)         case compls of           Just (cci', parsedMod, bindMap) -> do-            let pfix = getCompletionPrefix position cnts+            let pfix = getCompletionPrefixFromRope position cnts             case (pfix, completionContext) of               (PosPrefixInfo _ "" _ _, Just CompletionContext { _triggerCharacter = Just "."})                 -> return (InL [])

@@ -74,11 +74,6 @@  -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,3,0)-import           GHC.Plugins                              (defaultSDocContext,-                                                           renderWithContext)-#endif- #if MIN_VERSION_ghc(9,5,0) import           Language.Haskell.Syntax.Basic #endif@@ -514,13 +509,8 @@             --             -- is encoded as @[[arg1, arg2], [arg3], [arg4]]@             -- Hence, we must concat nested arguments into one to get all the fields.-#if MIN_VERSION_ghc(9,3,0)         extract ConDeclField{..}             = map (foLabel . unLoc) cd_fld_names-#else-        extract ConDeclField{..}-            = map (rdrNameFieldOcc . unLoc) cd_fld_names-#endif         -- XConDeclField         extract _ = [] findRecordCompl _ _ _ = []

@@ -16,7 +16,6 @@ import           Data.Aeson.Types import           Data.Hashable                (Hashable) import           Data.Text                    (Text)-import           Data.Typeable                (Typeable) import           Development.IDE.GHC.Compat import           Development.IDE.Graph        (RuleResult) import           Development.IDE.Spans.Common ()@@ -31,12 +30,12 @@ type instance RuleResult NonLocalCompletions = CachedCompletions  data LocalCompletions = LocalCompletions-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable LocalCompletions instance NFData   LocalCompletions  data NonLocalCompletions = NonLocalCompletions-    deriving (Eq, Show, Typeable, Generic)+    deriving (Eq, Show, Generic) instance Hashable NonLocalCompletions instance NFData   NonLocalCompletions 

@@ -10,7 +10,10 @@     ) where  import           Control.Exception             (SomeException)+import           Control.Lens                  ((^.)) import           Control.Monad+import qualified Control.Monad.Extra           as Extra+import           Control.Monad.IO.Class        (MonadIO) import           Control.Monad.Trans.Except    (runExceptT) import qualified Data.Aeson                    as A import           Data.Bifunctor                (first)@@ -22,7 +25,7 @@ import           Data.List.NonEmpty            (NonEmpty, nonEmpty, toList) import qualified Data.List.NonEmpty            as NE import qualified Data.Map                      as Map-import           Data.Maybe                    (mapMaybe)+import           Data.Maybe                    (isNothing, mapMaybe) import           Data.Some import           Data.String import           Data.Text                     (Text)@@ -39,6 +42,7 @@ import           Ide.Plugin.HandleRequestTypes import           Ide.PluginUtils               (getClientConfig) import           Ide.Types                     as HLS+import qualified Language.LSP.Protocol.Lens    as JL import           Language.LSP.Protocol.Message import           Language.LSP.Protocol.Types import qualified Language.LSP.Server           as LSP@@ -58,6 +62,7 @@     | LogNoPluginForMethod (Some SMethod)     | LogInvalidCommandIdentifier     | ExceptionInPlugin PluginId (Some SMethod) SomeException+    | LogResolveDefaultHandler (Some SMethod)  instance Pretty Log where   pretty = \case@@ -71,6 +76,8 @@     ExceptionInPlugin plId (Some method) exception ->         "Exception in plugin " <> viaShow plId <> " while processing "           <> pretty method <> ": " <> viaShow exception+    LogResolveDefaultHandler (Some method) ->+        "No plugin can handle" <+> pretty method <+> "request. Return object unchanged." instance Show Log where show = renderString . layoutCompact . pretty  noPluginHandles :: Recorder (WithPriority Log) -> SMethod m -> [(PluginId, HandleRequestResult)] -> IO (Either (TResponseError m) c)@@ -250,8 +257,16 @@         let (fs, dfs) = List.partition (\(_, desc, _) -> handlesRequest m params desc config == HandlesRequest) fs'         let disabledPluginsReason = (\(x, desc, _) -> (x, handlesRequest m params desc config)) <$> dfs         -- Clients generally don't display ResponseErrors so instead we log any that we come across+        -- However, some clients do display ResponseErrors! See for example the issues:+        -- https://github.com/haskell/haskell-language-server/issues/4467+        -- https://github.com/haskell/haskell-language-server/issues/4451         case nonEmpty fs of-          Nothing -> liftIO $ noPluginHandles recorder m disabledPluginsReason+          Nothing -> do+            liftIO (fallbackResolveHandler recorder m params) >>= \case+              Nothing ->+                liftIO $ noPluginHandles recorder m disabledPluginsReason+              Just result ->+                pure $ Right result           Just neFs -> do             let  plidsAndHandlers = fmap (\(plid,_,handler) -> (plid,handler)) neFs             es <- runHandlerM $ runConcurrently exceptionInPlugin m plidsAndHandlers ide params@@ -272,6 +287,72 @@               Just xs -> do                 pure $ Right $ combineResponses m config caps params xs +-- | Fallback Handler for resolve requests.+-- For all kinds of `*/resolve` requests, if they don't have a 'data_' value,+-- produce the original item, since no other plugin has any resolve data.+--+-- This is an internal handler, so it cannot be turned off and should be opaque+-- to the end-user.+-- This function does not take the ServerCapabilities into account, and assumes+-- clients will only send these requests, if and only if the Language Server+-- advertised support for it.+--+-- See Note [Fallback Handler for LSP resolve requests] for justification and reasoning.+fallbackResolveHandler :: MonadIO m => Recorder (WithPriority Log) -> SMethod s -> MessageParams s -> m (Maybe (MessageResult s))+fallbackResolveHandler recorder m params = do+    let result = case m of+          SMethod_InlayHintResolve+              | noResolveData params -> Just params+          SMethod_CompletionItemResolve+              | noResolveData params -> Just params+          SMethod_CodeActionResolve+              | noResolveData params -> Just params+          SMethod_WorkspaceSymbolResolve+              | noResolveData params -> Just params+          SMethod_CodeLensResolve+              | noResolveData params -> Just params+          SMethod_DocumentLinkResolve+              | noResolveData params -> Just params+          _ -> Nothing+    logResolveHandling result+    pure result+    where+        noResolveData :: JL.HasData_ p (Maybe a) => p -> Bool+        noResolveData p = isNothing $ p ^. JL.data_++        -- We only log if we are handling the request.+        -- If we don't handle this request, this should be logged+        -- on call-site.+        logResolveHandling p = Extra.whenJust p $ \_ -> do+          logWith recorder Debug $ LogResolveDefaultHandler (Some m)++{- Note [Fallback Handler for LSP resolve requests]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++We have a special fallback for `*/resolve` requests.++We had multiple reports, where `resolve` requests (such as+`completion/resolve` and `codeAction/resolve`) are rejected+by HLS since the `_data_` field of the respective LSP feature has not been+populated by HLS.+This makes sense, as we only support `resolve` for certain kinds of+`CodeAction`/`Completions`, when they contain particularly expensive+properties, such as documentation or non-local type signatures.++So what to do? We can see two options:++1. Be dumb and permissive: if no plugin wants to resolve a request, then+   just respond positively with the original item! Potentially this masks+   real issues, but may not be too bad. If a plugin thinks it can+   handle the request but it then fails to resolve it, we should still return a failure.+2. Try and be smart: we try to figure out requests that we're "supposed" to+   resolve (e.g. those with a data field), and fail if no plugin wants to handle those.+   This is possible since we set data.+   So as long as we maintain the invariant that only things which need resolving get+   data, then it could be okay.++In 'fallbackResolveHandler', we implement the option (2).+-}  -- --------------------------------------------------------------------- 

@@ -51,6 +51,8 @@                       Hover.gotoDefinition recorder ide TextDocumentPositionParams{..})                   <> mkPluginHandler SMethod_TextDocumentTypeDefinition (\ide _ TypeDefinitionParams{..} ->                       Hover.gotoTypeDefinition recorder ide TextDocumentPositionParams{..})+                  <> mkPluginHandler SMethod_TextDocumentImplementation (\ide _ ImplementationParams{..} ->+                      Hover.gotoImplementation recorder ide TextDocumentPositionParams{..})                   <> mkPluginHandler SMethod_TextDocumentDocumentHighlight (\ide _ DocumentHighlightParams{..} ->                       Hover.documentHighlight recorder ide TextDocumentPositionParams{..})                   <> mkPluginHandler SMethod_TextDocumentReferences (Hover.references recorder)

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP              #-} {-# LANGUAGE DeriveAnyClass   #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE TypeFamilies     #-}@@ -26,7 +27,8 @@ import qualified Data.Map                             as Map import           Data.Maybe                           (catMaybes, maybeToList) import qualified Data.Text                            as T-import           Development.IDE                      (GhcSession (..),+import           Development.IDE                      (FileDiagnostic (..),+                                                       GhcSession (..),                                                        HscEnvEq (hscEnv),                                                        RuleResult, Rules, Uri,                                                        define, srcSpanToRange,@@ -126,9 +128,10 @@           -- 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-            , dFile == nfp-            , isGlobalDiagnostic diag]+            | diag <- diags+            , let lspDiag@Diagnostic {_range} = fdLspDiagnostic diag+            , fdFilePath diag == nfp+            , isGlobalDiagnostic lspDiag]         -- The second option is to generate lenses from the GlobalBindingTypeSig         -- rule. This is the only type that needs to have the range adjusted         -- with PositionMapping.@@ -319,7 +322,11 @@         let name = idName identifier         hasSig name $ do           env <- tcInitTidyEnv+#if MIN_VERSION_ghc(9,11,0)+          let ty = tidyOpenType env (idType identifier)+#else           let (_, ty) = tidyOpenType env (idType identifier)+#endif           pure $ GlobalBindingTypeSig name (printName name <> " :: " <> showDoc (pprSigmaType ty)) (name `elemNameSet` exports)       patToSig p = do         let name = patSynName p

@@ -10,6 +10,7 @@     atPoint   , gotoDefinition   , gotoTypeDefinition+  , gotoImplementation   , documentHighlight   , pointCommand   , referencesAtPoint@@ -23,6 +24,10 @@   , LookupModule   ) where ++import           GHC.Data.FastString                  (lengthFS)+import qualified GHC.Utils.Outputable                 as O+ import           Development.IDE.GHC.Error import           Development.IDE.GHC.Orphans          () import           Development.IDE.Types.Location@@ -31,6 +36,7 @@ import           Prelude                              hiding (mod)  -- compiler and infrastructure+import           Development.IDE.Core.Compile         (setNonHomeFCHook) import           Development.IDE.Core.PositionMapping import           Development.IDE.Core.RuleTypes import           Development.IDE.GHC.Compat@@ -52,9 +58,13 @@  import qualified Data.Array                           as A import           Data.Either-import           Data.List                            (isSuffixOf) import           Data.List.Extra                      (dropEnd1, nubOrd) ++import           Data.Either.Extra                    (eitherToMaybe)+import           Data.List                            (isSuffixOf, sortOn)+import           Data.Tree+import qualified Data.Tree                            as T import           Data.Version                         (showVersion) import           Development.IDE.Types.Shake          (WithHieDb) import           HieDb                                hiding (pointCommand,@@ -171,14 +181,19 @@     highlights = do       n <- ns       ref <- fromMaybe [] (M.lookup (Right n) rf)-      pure $ makeHighlight ref-    makeHighlight (sp,dets) =-      DocumentHighlight (realSrcSpanToRange sp) (Just $ highlightType $ identInfo dets)+      maybeToList (makeHighlight n ref)+    makeHighlight n (sp,dets)+      | isTvNameSpace (nameNameSpace n) && isBadSpan n sp = Nothing+      | otherwise = Just $ DocumentHighlight (realSrcSpanToRange sp) (Just $ highlightType $ identInfo dets)     highlightType s =       if any (isJust . getScopeFromContext) s         then DocumentHighlightKind_Write         else DocumentHighlightKind_Read +    isBadSpan :: Name -> RealSrcSpan -> Bool+    isBadSpan n sp = srcSpanStartLine sp /= srcSpanEndLine sp || (srcSpanEndCol sp - srcSpanStartCol sp > lengthFS (occNameFS $ nameOccName n))++-- | Locate the type definition of the name at a given position. gotoTypeDefinition   :: MonadIO m   => WithHieDb@@ -186,7 +201,7 @@   -> IdeOptions   -> HieAstResult   -> Position-  -> MaybeT m [Location]+  -> MaybeT m [(Location, Identifier)] gotoTypeDefinition withHieDb lookupModule ideOpts srcSpans pos   = lift $ typeLocationsAtPoint withHieDb lookupModule ideOpts pos srcSpans @@ -197,12 +212,25 @@   -> LookupModule m   -> IdeOptions   -> M.Map ModuleName NormalizedFilePath-  -> HieASTs a+  -> HieAstResult   -> Position-  -> MaybeT m [Location]+  -> MaybeT m [(Location, Identifier)] gotoDefinition withHieDb getHieFile ideOpts imports srcSpans pos   = lift $ locationsAtPoint withHieDb getHieFile ideOpts imports pos srcSpans +-- | Locate the implementation definition of the name at a given position.+-- Goto Implementation for an overloaded function.+gotoImplementation+  :: MonadIO m+  => WithHieDb+  -> LookupModule m+  -> IdeOptions+  -> HieAstResult+  -> Position+  -> MaybeT m [Location]+gotoImplementation withHieDb getHieFile ideOpts srcSpans pos+  = lift $ instanceLocationsAtPoint withHieDb getHieFile ideOpts pos srcSpans+ -- | Synopsis for the name at a given position. atPoint   :: IdeOptions@@ -211,13 +239,13 @@   -> HscEnv   -> Position   -> IO (Maybe (Maybe Range, [T.Text]))-atPoint IdeOptions{} (HAR _ hf _ _ (kind :: HieKind hietype)) (DKMap dm km) env pos =+atPoint IdeOptions{} (HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (DKMap dm km) env pos =     listToMaybe <$> sequence (pointCommand hf pos hoverInfo)   where     -- Hover info for values/data     hoverInfo :: HieAST hietype -> IO (Maybe Range, [T.Text])     hoverInfo ast = do-        prettyNames <- mapM prettyName filteredNames+        prettyNames <- mapM prettyName names         pure (Just range, prettyNames ++ pTypes)       where         pTypes :: [T.Text]@@ -234,24 +262,34 @@         info :: NodeInfo hietype         info = nodeInfoH kind ast +        -- We want evidence variables to be displayed last.+        -- Evidence trees contain information of secondary relevance.         names :: [(Identifier, IdentifierDetails hietype)]-        names = M.assocs $ nodeIdentifiers info--        -- Check for evidence bindings-        isInternal :: (Identifier, IdentifierDetails a) -> Bool-        isInternal (Right _, dets) =-          any isEvidenceContext $ identInfo dets-        isInternal (Left _, _) = False--        filteredNames :: [(Identifier, IdentifierDetails hietype)]-        filteredNames = filter (not . isInternal) names+        names = sortOn (any isEvidenceUse . identInfo . snd) $ M.assocs $ nodeIdentifiers info          prettyName :: (Either ModuleName Name, IdentifierDetails hietype) -> IO T.Text-        prettyName (Right n, dets) = pure $ T.unlines $-          wrapHaskell (printOutputable n <> maybe "" (" :: " <>) ((prettyType <$> identType dets) <|> maybeKind))-          : maybeToList (pretty (definedAt n) (prettyPackageName n))-          ++ catMaybes [ T.unlines . spanDocToMarkdown <$> lookupNameEnv dm n-                       ]+        prettyName (Right n, dets)+          -- We want to print evidence variable using a readable tree structure.+          -- Evidence variables contain information why a particular instance or+          -- type equality was chosen, paired with location information.+          | any isEvidenceUse (identInfo dets) =+            let+              -- The evidence tree may not be present for some reason, e.g., the 'Name' is not+              -- present in the tree.+              -- Thus, we need to handle it here, but in practice, this should never be 'Nothing'.+              evidenceTree = maybe "" (printOutputable . renderEvidenceTree) (getEvidenceTree rf n)+            in+              pure $ evidenceTree <> "\n"+          -- Identifier details that are not evidence variables are used to display type information and+          -- documentation of that name.+          | otherwise =+            let+              typeSig = wrapHaskell (printOutputable n <> maybe "" (" :: " <>) ((prettyType <$> identType dets) <|> maybeKind))+              definitionLoc = maybeToList (pretty (definedAt n) (prettyPackageName n))+              docs = maybeToList (T.unlines . spanDocToMarkdown <$> lookupNameEnv dm n)+            in+              pure $ T.unlines $+                [typeSig] ++ definitionLoc ++ docs           where maybeKind = fmap printOutputable $ safeTyThingType =<< lookupNameEnv km n                 pretty Nothing Nothing = Nothing                 pretty (Just define) Nothing = Just $ define <> "\n"@@ -269,7 +307,7 @@         -- the package(with version) this `ModuleName` belongs to.         packageNameForImportStatement :: ModuleName -> IO T.Text         packageNameForImportStatement mod = do-          mpkg <- findImportedModule env mod :: IO (Maybe Module)+          mpkg <- findImportedModule (setNonHomeFCHook env) mod :: IO (Maybe Module)           let moduleName = printOutputable mod           case mpkg >>= packageNameWithVersion of             Nothing             -> pure moduleName@@ -285,7 +323,7 @@               version = T.pack $ showVersion (unitPackageVersion conf)           pure $ pkgName <> "-" <> version -        -- Type info for the current node, it may contains several symbols+        -- Type info for the current node, it may contain several symbols         -- for one range, like wildcard         types :: [hietype]         types = nodeType info@@ -294,10 +332,13 @@         prettyTypes = map (("_ :: "<>) . prettyType) types          prettyType :: hietype -> T.Text-        prettyType t = case kind of-          HieFresh -> printOutputable t-          HieFromDisk full_file -> printOutputable $ hieTypeToIface $ recoverFullType t (hie_types full_file)+        prettyType = printOutputable . expandType +        expandType :: a -> SDoc+        expandType t = case kind of+          HieFresh -> ppr t+          HieFromDisk full_file -> ppr $ hieTypeToIface $ recoverFullType t (hie_types full_file)+         definedAt :: Name -> Maybe T.Text         definedAt name =           -- do not show "at <no location info>" and similar messages@@ -306,6 +347,67 @@             UnhelpfulLoc {} | isInternalName name || isSystemName name -> Nothing             _ -> Just $ "*Defined " <> printOutputable (pprNameDefnLoc name) <> "*" +        -- We want to render the root constraint even if it is a let,+        -- but we don't want to render any subsequent lets+        renderEvidenceTree :: Tree (EvidenceInfo a) -> SDoc+        -- However, if the root constraint is simply a<n indirection (via let) to a single other constraint,+        -- we can still skip rendering it+        -- The evidence ghc generates is made up of a few primitives, like @WpLet@ (let bindings),+        -- @WpEvLam@ (lambda abstractions) and so on.+        -- The let binding refers to these lets.+        --+        -- For example, evidence for @Show ([Int], Bool)@ might look like:+        --+        -- @+        --   $dShow,[]IntBool = $fShow,[]IntBool+        --   -- indirection, we don't gain anything by printing this+        --   $fShow,[]IntBool = $dShow, $fShow[]Int $fShowBool+        --   -- This is the root "let" we render as a tree+        --   $fShow[]Int = $dShow[] $fShowInt+        --   -- second level let, collapse it into its parent $fShow,[]IntBool+        --   $fShowInt = base:Data.Int.$dShowInt+        --   -- indirection, remove it+        --   $fShowBool = base:Data.Bool.$dShowBool+        --   -- indirection, remove it+        --+        --   in $dShow,[]IntBool+        -- @+        --+        -- On doing this we end up with the tree @Show ([Int], Bool) -> (Show (,), Show [], Show Int, Show Bool)@+        --+        -- It is also quite helpful to look at the @.hie@ file directly to see how the+        -- evidence information is presented on disk. @hiedb dump <mod.hie>@+        renderEvidenceTree (T.Node (EvidenceInfo{evidenceDetails=Just (EvLetBind _,_,_)}) [x])+          = renderEvidenceTree x+        renderEvidenceTree (T.Node (EvidenceInfo{evidenceDetails=Just (EvLetBind _,_,_), ..}) xs)+          = hang (text "Evidence of constraint `" O.<> expandType evidenceType O.<> "`") 2 $+                 vcat $ text "constructed using:" : map renderEvidenceTree' xs+        renderEvidenceTree (T.Node (EvidenceInfo{..}) _)+          = hang (text "Evidence of constraint `" O.<> expandType evidenceType O.<> "`") 2 $+                 vcat $ printDets evidenceSpan evidenceDetails : map (text . T.unpack) (maybeToList $ definedAt evidenceVar)++        -- renderEvidenceTree' skips let bound evidence variables and prints the children directly+        renderEvidenceTree' (T.Node (EvidenceInfo{evidenceDetails=Just (EvLetBind _,_,_)}) xs)+          = vcat (map renderEvidenceTree' xs)+        renderEvidenceTree' (T.Node (EvidenceInfo{..}) _)+          = hang (text "- `" O.<> expandType evidenceType O.<> "`") 2 $+              vcat $+                printDets evidenceSpan evidenceDetails : map (text . T.unpack) (maybeToList $ definedAt evidenceVar)++        printDets :: RealSrcSpan -> Maybe (EvVarSource, Scope, Maybe Span) -> SDoc+        printDets _    Nothing = text "using an external instance"+        printDets ospn (Just (src,_,mspn)) = pprSrc+                                      $$ text "at" <+> text (T.unpack $ srcSpanToMdLink location)+          where+            location = realSrcSpanToLocation spn+            -- Use the bind span if we have one, else use the occurrence span+            spn = fromMaybe ospn mspn+            pprSrc = case src of+              -- Users don't know what HsWrappers are+              EvWrapperBind -> "bound by type signature or pattern"+              _             -> ppr src++-- | Find 'Location's of type definition at a specific point and return them along with their 'Identifier's. typeLocationsAtPoint   :: forall m    . MonadIO m@@ -314,14 +416,14 @@   -> IdeOptions   -> Position   -> HieAstResult-  -> m [Location]+  -> m [(Location, Identifier)] typeLocationsAtPoint withHieDb lookupModule _ideOptions pos (HAR _ ast _ _ hieKind) =   case hieKind of     HieFromDisk hf ->       let arr = hie_types hf           ts = concat $ pointCommand ast pos getts           unfold = map (arr A.!)-          getts x = nodeType ni  ++ (mapMaybe identType $ M.elems $ nodeIdentifiers ni)+          getts x = nodeType ni  ++ mapMaybe identType (M.elems $ nodeIdentifiers ni)             where ni = nodeInfo' x           getTypes' ts' = flip concatMap (unfold ts') $ \case             HTyVarTy n -> [n]@@ -332,12 +434,12 @@             HQualTy a b -> getTypes' [a,b]             HCastTy a -> getTypes' [a]             _ -> []-        in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation withHieDb lookupModule) (getTypes' ts)+        in fmap nubOrd $ concatMapM (\n -> fmap (maybe [] (fmap (,Right n))) (nameToLocation withHieDb lookupModule n)) (getTypes' ts)     HieFresh ->       let ts = concat $ pointCommand ast pos getts-          getts x = nodeType ni  ++ (mapMaybe identType $ M.elems $ nodeIdentifiers ni)+          getts x = nodeType ni  ++ mapMaybe identType (M.elems $ nodeIdentifiers ni)             where ni = nodeInfo x-        in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation withHieDb lookupModule) (getTypes ts)+        in fmap nubOrd $ concatMapM (\n -> fmap (maybe [] (fmap (,Right n))) (nameToLocation withHieDb lookupModule n)) (getTypes ts)  namesInType :: Type -> [Name] namesInType (TyVarTy n)      = [varName n]@@ -350,24 +452,46 @@ namesInType _                = []  getTypes :: [Type] -> [Name]-getTypes ts = concatMap namesInType ts+getTypes = concatMap namesInType +-- | Find 'Location's of definition at a specific point and return them along with their 'Identifier's. locationsAtPoint-  :: forall m a+  :: forall m    . MonadIO m   => WithHieDb   -> LookupModule m   -> IdeOptions   -> M.Map ModuleName NormalizedFilePath   -> Position-  -> HieASTs a-  -> m [Location]-locationsAtPoint withHieDb lookupModule _ideOptions imports pos ast =+  -> HieAstResult+  -> m [(Location, Identifier)]+locationsAtPoint withHieDb lookupModule _ideOptions imports pos (HAR _ ast _rm _ _) =   let ns = concat $ pointCommand ast pos (M.keys . getNodeIds)       zeroPos = Position 0 0       zeroRange = Range zeroPos zeroPos-      modToLocation m = fmap (\fs -> pure $ Location (fromNormalizedUri $ filePathToUri' fs) zeroRange) $ M.lookup m imports-    in fmap (nubOrd . concat) $ mapMaybeM (either (pure . modToLocation) $ nameToLocation withHieDb lookupModule) ns+      modToLocation m = fmap (\fs -> pure (Location (fromNormalizedUri $ filePathToUri' fs) zeroRange)) $ M.lookup m imports+   in fmap (nubOrd . concat) $ mapMaybeM+        (either (\m -> pure ((fmap $ fmap (,Left m)) (modToLocation m)))+                (\n -> fmap (fmap $ fmap (,Right n)) (nameToLocation withHieDb lookupModule n)))+        ns++-- | Find 'Location's of a implementation definition at a specific point.+instanceLocationsAtPoint+  :: forall m+   . MonadIO m+  => WithHieDb+  -> LookupModule m+  -> IdeOptions+  -> Position+  -> HieAstResult+  -> m [Location]+instanceLocationsAtPoint withHieDb lookupModule _ideOptions pos (HAR _ ast _rm _ _) =+  let ns = concat $ pointCommand ast pos (M.keys . getNodeIds)+      evTrees = mapMaybe (eitherToMaybe >=> getEvidenceTree _rm) ns+      evNs = concatMap (map (evidenceVar) . T.flatten) evTrees+   in fmap (nubOrd . concat) $ mapMaybeM+        (nameToLocation withHieDb lookupModule)+        evNs  -- | Given a 'Name' attempt to find the location where it is defined. nameToLocation :: MonadIO m => WithHieDb -> LookupModule m -> Name -> m (Maybe [Location])

@@ -13,22 +13,26 @@ , spanDocToMarkdownForTest , DocMap , TyThingMap+, srcSpanToMdLink ) where  import           Control.DeepSeq+import           Data.Bifunctor               (second) import           Data.List.Extra import           Data.Maybe import qualified Data.Text                    as T-import           GHC.Generics-+import           Development.IDE.GHC.Util+import qualified Documentation.Haddock.Parser as H+import qualified Documentation.Haddock.Types  as H import           GHC+import           GHC.Generics+import           System.FilePath -import           Data.Bifunctor               (second)+import           Control.Lens import           Development.IDE.GHC.Compat import           Development.IDE.GHC.Orphans  ()-import           Development.IDE.GHC.Util-import qualified Documentation.Haddock.Parser as H-import qualified Documentation.Haddock.Types  as H+import qualified Language.LSP.Protocol.Lens   as JL+import           Language.LSP.Protocol.Types  type DocMap = NameEnv SpanDoc type TyThingMap = NameEnv TyThing@@ -54,13 +58,8 @@ safeTyThingId _                                = Nothing  -- Possible documentation for an element in the code-#if MIN_VERSION_ghc(9,3,0) data SpanDoc   = SpanDocString [HsDocString] SpanDocUris-#else-data SpanDoc-  = SpanDocString HsDocString SpanDocUris-#endif   | SpanDocText   [T.Text] SpanDocUris   deriving stock (Eq, Show, Generic)   deriving anyclass NFData@@ -97,11 +96,7 @@ spanDocToMarkdown = \case     (SpanDocString docs uris) ->         let doc = T.pack $ haddockToMarkdown $ H.toRegular $ H._doc $ H.parseParas Nothing $-#if MIN_VERSION_ghc(9,3,0)                       renderHsDocStrings docs-#else-                      unpackHDS docs-#endif         in  go [doc] uris     (SpanDocText txt uris) -> go txt uris   where@@ -118,8 +113,14 @@   [ linkify "Documentation" <$> mdoc   , linkify "Source" <$> msrc   ]-  where linkify title uri = "[" <> title <> "](" <> uri <> ")" +-- | Generate a markdown link.+--+-- >>> linkify "Title" "uri"+-- "[Title](Uri)"+linkify :: T.Text -> T.Text -> T.Text+linkify title uri = "[" <> title <> "](" <> uri <> ")"+ spanDocToMarkdownForTest :: String -> String spanDocToMarkdownForTest   = haddockToMarkdown . H.toRegular . H._doc . H.parseParas Nothing@@ -224,3 +225,35 @@   = case lines s of       []           -> ""       (first:rest) -> unlines $ first : map (("  " ++) . trimStart) rest++-- | Generate a source link for the 'Location' according to VSCode's supported form:+-- https://github.com/microsoft/vscode/blob/b3ec8181fc49f5462b5128f38e0723ae85e295c2/src/vs/platform/opener/common/opener.ts#L151-L160+--+srcSpanToMdLink :: Location -> T.Text+srcSpanToMdLink location =+  let+    uri = location ^. JL.uri+    range = location ^. JL.range+    -- LSP 'Range' starts at '0', but link locations start at '1'.+    intText n = T.pack $ show (n + 1)+    srcRangeText =+      T.concat+        [ "L"+        , intText (range ^. JL.start . JL.line)+        , ","+        , intText (range ^. JL.start . JL.character)+        , "-L"+        , intText (range ^. JL.end . JL.line)+        , ","+        , intText (range ^. JL.end . JL.character)+        ]++    -- If the 'Location' is a 'FilePath', display it in shortened form.+    -- This avoids some redundancy and better readability for the user.+    title = case uriToFilePath uri of+      Just fp -> T.pack (takeFileName fp) <> ":" <> intText (range ^. JL.start . JL.line)+      Nothing -> getUri uri++    srcLink = getUri uri <> "#" <> srcRangeText+  in+   linkify title srcLink

@@ -41,16 +41,8 @@   -> IO DocAndTyThingMap mkDocMap env rm this_mod =   do-#if MIN_VERSION_ghc(9,3,0)      (Just Docs{docs_decls = UniqMap this_docs}) <- extractDocs (hsc_dflags env) this_mod-#else-     (_ , DeclDocMap this_docs, _) <- extractDocs this_mod-#endif-#if MIN_VERSION_ghc(9,3,0)      d <- foldrM getDocs (fmap (\(_, x) -> (map hsDocString x) `SpanDocString` SpanDocUris Nothing Nothing) this_docs) names-#else-     d <- foldrM getDocs (mkNameEnv $ M.toList $ fmap (`SpanDocString` SpanDocUris Nothing Nothing) this_docs) names-#endif      k <- foldrM getType (tcg_type_env this_mod) names      pure $ DKMap d k   where@@ -84,11 +76,7 @@       Left _    -> return []       Right res -> zipWithM unwrap res names   where-#if MIN_VERSION_ghc(9,3,0)     unwrap (Right (Just docs, _)) n = SpanDocString (map hsDocString docs) <$> getUris n-#else-    unwrap (Right (Just docs, _)) n = SpanDocString docs <$> getUris n-#endif     unwrap _ n                      = mkSpanDocText n      mkSpanDocText name =

@@ -15,6 +15,8 @@ import qualified Data.Maybe                      as Maybe import           Data.Text                       (Text, pack) import qualified Data.Text                       as Text+import           Data.Text.Utf16.Rope.Mixed      (Rope)+import qualified Data.Text.Utf16.Rope.Mixed      as Rope import           Development.IDE                 (srcSpanToRange, IdeState, NormalizedFilePath, GhcSession (..), getFileContents, hscEnv, runAction) import           Development.IDE.GHC.Compat import           Development.IDE.GHC.Compat.Util@@ -27,10 +29,10 @@ import           Development.IDE.Core.PluginUtils import qualified Language.LSP.Protocol.Lens     as L -getNextPragmaInfo :: DynFlags -> Maybe Text -> NextPragmaInfo-getNextPragmaInfo dynFlags mbSourceText =-  if | Just sourceText <- mbSourceText-     , let sourceStringBuffer = stringToStringBuffer (Text.unpack sourceText)+getNextPragmaInfo :: DynFlags -> Maybe Rope -> NextPragmaInfo+getNextPragmaInfo dynFlags mbSource =+  if | Just source <- mbSource+     , let sourceStringBuffer = stringToStringBuffer (Text.unpack (Rope.toText source))      , POk _ parserState <- parsePreDecl dynFlags sourceStringBuffer      -> case parserState of          ParserStateNotDone{ nextPragma } -> nextPragma@@ -56,7 +58,7 @@ getFirstPragma :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError m NextPragmaInfo getFirstPragma (PluginId pId) state nfp = do   (hscEnv -> hsc_dflags -> sessionDynFlags, _) <- runActionE (T.unpack pId <> ".GhcSession") state $ useWithStaleE GhcSession nfp-  (_, fileContents) <- liftIO $ runAction (T.unpack pId <> ".GetFileContents") state $ getFileContents nfp+  fileContents <- liftIO $ runAction (T.unpack pId <> ".GetFileContents") state $ getFileContents nfp   pure $ getNextPragmaInfo sessionDynFlags fileContents  -- Pre-declaration comments parser -----------------------------------------------------

@@ -1,32 +1,69 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE CPP             #-}+{-# LANGUAGE DeriveGeneric   #-}+{-# LANGUAGE TemplateHaskell #-}  module Development.IDE.Types.Diagnostics (   LSP.Diagnostic(..),   ShowDiagnostic(..),-  FileDiagnostic,+  FileDiagnostic(..),+  fdFilePathL,+  fdLspDiagnosticL,+  fdShouldShowDiagnosticL,+  fdStructuredMessageL,+  StructuredMessage(..),+  _NoStructuredMessage,+  _SomeStructuredMessage,   IdeResult,   LSP.DiagnosticSeverity(..),   DiagnosticStore,   ideErrorText,   ideErrorWithSource,+  ideErrorFromLspDiag,   showDiagnostics,   showDiagnosticsColored,-  IdeResultNoDiagnosticsEarlyCutoff) where+#if MIN_VERSION_ghc(9,5,0)+  showGhcCode,+#endif+  IdeResultNoDiagnosticsEarlyCutoff,+  attachReason,+  attachedReason) where +import           Control.Applicative            ((<|>)) import           Control.DeepSeq+import           Control.Lens+import qualified Data.Aeson                     as JSON+import qualified Data.Aeson.Lens                as JSON import           Data.ByteString                (ByteString)+import           Data.Foldable import           Data.Maybe                     as Maybe import qualified Data.Text                      as T+import           Development.IDE.GHC.Compat     (GhcMessage, MsgEnvelope,+                                                 WarningFlag, flagSpecFlag,+                                                 flagSpecName, wWarningFlags) import           Development.IDE.Types.Location+import           GHC.Generics+#if MIN_VERSION_ghc(9,5,0)+import           GHC.Types.Error                (DiagnosticCode (..),+                                                 DiagnosticReason (..),+                                                 diagnosticCode,+                                                 diagnosticReason,+                                                 errMsgDiagnostic)+#else+import           GHC.Types.Error                (DiagnosticReason (..),+                                                 diagnosticReason,+                                                 errMsgDiagnostic)+#endif import           Language.LSP.Diagnostics-import           Language.LSP.Protocol.Types    as LSP (Diagnostic (..),-                                                        DiagnosticSeverity (..))+import           Language.LSP.Protocol.Lens     (data_)+import           Language.LSP.Protocol.Types    as LSP import           Prettyprinter import           Prettyprinter.Render.Terminal  (Color (..), color) import qualified Prettyprinter.Render.Terminal  as Terminal import           Prettyprinter.Render.Text+import           Text.Printf                    (printf)   -- | The result of an IDE operation. Warnings and errors are in the Diagnostic,@@ -44,26 +81,102 @@ -- | an IdeResult with a fingerprint type IdeResultNoDiagnosticsEarlyCutoff  v = (Maybe ByteString, Maybe v) +-- | Produce a 'FileDiagnostic' for the given 'NormalizedFilePath'+-- with an error message. ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic-ideErrorText = ideErrorWithSource (Just "compiler") (Just DiagnosticSeverity_Error)+ideErrorText nfp msg =+  ideErrorWithSource (Just "compiler") (Just DiagnosticSeverity_Error) nfp msg Nothing +-- | Create a 'FileDiagnostic' from an existing 'LSP.Diagnostic' for a+-- specific 'NormalizedFilePath'.+-- The optional 'MsgEnvelope GhcMessage' is the original error message+-- that was used for creating the 'LSP.Diagnostic'.+-- It is included here, to allow downstream consumers, such as HLS plugins,+-- to provide LSP features based on the structured error messages.+-- Additionally, if available, we insert the ghc error code into the+-- 'LSP.Diagnostic'. These error codes are used in https://errors.haskell.org/+-- to provide documentation and explanations for error messages.+ideErrorFromLspDiag+  :: LSP.Diagnostic+  -> NormalizedFilePath+  -> Maybe (MsgEnvelope GhcMessage)+  -> FileDiagnostic+ideErrorFromLspDiag lspDiag fdFilePath mbOrigMsg =+  let fdShouldShowDiagnostic = ShowDiag+      fdStructuredMessage =+        case mbOrigMsg of+          Nothing  -> NoStructuredMessage+          Just msg -> SomeStructuredMessage msg+      fdLspDiagnostic =+        lspDiag+          & attachReason (fmap (diagnosticReason . errMsgDiagnostic) mbOrigMsg)+          & setGhcCode mbOrigMsg+  in+  FileDiagnostic {..}++-- | Set the code of the 'LSP.Diagnostic' to the GHC diagnostic code which is linked+-- to https://errors.haskell.org/.+setGhcCode :: Maybe (MsgEnvelope GhcMessage) -> LSP.Diagnostic -> LSP.Diagnostic+#if MIN_VERSION_ghc(9,5,0)+setGhcCode mbOrigMsg diag =+  let mbGhcCode = do+          origMsg <- mbOrigMsg+          code <- diagnosticCode (errMsgDiagnostic origMsg)+          pure (InR (showGhcCode code))+  in+  diag { _code = mbGhcCode <|> _code diag }+#else+setGhcCode _ diag = diag+#endif++#if MIN_VERSION_ghc(9,9,0)+-- DiagnosticCode only got a show instance in 9.10.1+showGhcCode :: DiagnosticCode -> T.Text+showGhcCode = T.pack . show+#elif MIN_VERSION_ghc(9,5,0)+showGhcCode :: DiagnosticCode -> T.Text+showGhcCode (DiagnosticCode prefix c) = T.pack $ prefix ++ "-" ++ printf "%05d" c+#endif++attachedReason :: Traversal' Diagnostic (Maybe JSON.Value)+attachedReason = data_ . non (JSON.object []) . JSON.atKey "attachedReason"++attachReason :: Maybe DiagnosticReason -> Diagnostic -> Diagnostic+attachReason Nothing = id+attachReason (Just wr) = attachedReason .~ fmap JSON.toJSON (showReason wr)+ where+  showReason = \case+    WarningWithFlag flag -> Just $ catMaybes [showFlag flag]+#if MIN_VERSION_ghc(9,7,0)+    WarningWithFlags flags -> Just $ catMaybes (fmap showFlag $ toList flags)+#endif+    _                    -> Nothing++showFlag :: WarningFlag -> Maybe T.Text+showFlag flag = ("-W" <>) . T.pack . flagSpecName <$> find ((== flag) . flagSpecFlag) wWarningFlags+ ideErrorWithSource   :: Maybe T.Text   -> Maybe DiagnosticSeverity-  -> a+  -> NormalizedFilePath   -> T.Text-  -> (a, ShowDiagnostic, Diagnostic)-ideErrorWithSource source sev fp msg = (fp, ShowDiag, LSP.Diagnostic {-    _range = noRange,-    _severity = sev,-    _code = Nothing,-    _source = source,-    _message = msg,-    _relatedInformation = Nothing,-    _tags = Nothing,-    _codeDescription = Nothing,-    _data_ = Nothing-    })+  -> Maybe (MsgEnvelope GhcMessage)+  -> FileDiagnostic+ideErrorWithSource source sev fdFilePath msg origMsg =+  let lspDiagnostic =+        LSP.Diagnostic {+          _range = noRange,+          _severity = sev,+          _code = Nothing,+          _source = source,+          _message = msg,+          _relatedInformation = Nothing,+          _tags = Nothing,+          _codeDescription = Nothing,+          _data_ = Nothing+        }+  in+  ideErrorFromLspDiag lspDiagnostic fdFilePath origMsg  -- | Defines whether a particular diagnostic should be reported --   back to the user.@@ -80,14 +193,79 @@ instance NFData ShowDiagnostic where     rnf = rwhnf +-- | 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. FileDiagnostic only uses this as metadata so we can safely+-- ignore it in fields.+--+-- Instead of pattern matching on these constructors directly, consider 'Prism' from+-- the 'lens' package. This allows to conveniently pattern match deeply into the 'MsgEnvelope GhcMessage'+-- constructor.+-- The module 'Development.IDE.GHC.Compat.Error' implements additional 'Lens's and 'Prism's,+-- allowing you to avoid importing GHC modules directly.+--+-- For example, to pattern match on a 'TcRnMessage' you can use the lens:+--+-- @+--   message ^? _SomeStructuredMessage . msgEnvelopeErrorL . _TcRnMessage+-- @+--+-- This produces a value of type `Maybe TcRnMessage`.+--+-- Further, consider utility functions such as 'stripTcRnMessageContext', which strip+-- context from error messages which may be more convenient in certain situations.+data StructuredMessage+  = NoStructuredMessage+  | SomeStructuredMessage (MsgEnvelope GhcMessage)+  deriving (Generic)++instance Show StructuredMessage where+  show NoStructuredMessage      = "NoStructuredMessage"+  show SomeStructuredMessage {} = "SomeStructuredMessage"++instance Eq StructuredMessage where+  (==) NoStructuredMessage NoStructuredMessage           = True+  (==) SomeStructuredMessage {} SomeStructuredMessage {} = True+  (==) _ _                                               = False++instance Ord StructuredMessage where+  compare NoStructuredMessage NoStructuredMessage           = EQ+  compare SomeStructuredMessage {} SomeStructuredMessage {} = EQ+  compare NoStructuredMessage SomeStructuredMessage {}      = GT+  compare SomeStructuredMessage {} NoStructuredMessage      = LT++instance NFData StructuredMessage where+  rnf NoStructuredMessage      = ()+  rnf SomeStructuredMessage {} = ()+ -- | 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. ---type FileDiagnostic = (NormalizedFilePath, ShowDiagnostic, Diagnostic)+--   It also optionally keeps a structured diagnostic message GhcMessage in+--   StructuredMessage.+--+data FileDiagnostic = FileDiagnostic+  { fdFilePath             :: NormalizedFilePath+  , fdShouldShowDiagnostic :: ShowDiagnostic+  , fdLspDiagnostic        :: Diagnostic+    -- | The original diagnostic that was used to produce 'fdLspDiagnostic'.+    -- We keep it here, so downstream consumers, e.g. HLS plugins, can use the+    -- the structured error messages and don't have to resort to parsing+    -- error messages via regexes or similar.+    --+    -- The optional GhcMessage inside of this StructuredMessage is ignored for+    -- Eq, Ord, Show, and NFData instances. This is fine because this field+    -- should only ever be metadata and should never be used to distinguish+    -- between FileDiagnostics.+  , fdStructuredMessage    :: StructuredMessage+  }+  deriving (Eq, Ord, Show, Generic) +instance NFData FileDiagnostic+ prettyRange :: Range -> Doc Terminal.AnsiStyle prettyRange Range{..} = f _start <> "-" <> f _end     where f Position{..} = pretty (show $ _line+1) <> colon <> pretty (show $ _character+1)@@ -106,13 +284,17 @@ 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+        , slabel_ "Code:    " $ case _code of+                                  Just (InR text) -> pretty text+                                  Just (InL i)    -> pretty i+                                  Nothing         -> "<none>"         , slabel_ "Message: "             $ case sev of               LSP.DiagnosticSeverity_Error       -> annotate $ color Red@@ -150,3 +332,9 @@  defaultTermWidth :: Int defaultTermWidth = 80++makePrisms ''StructuredMessage++makeLensesWith+    (lensRules & lensField .~ mappingNamer (pure . (++ "L")))+    ''FileDiagnostic