ghcide 2.13.0.0 → 2.14.0.0

raw patch · 32 files changed

+2287/−1521 lines, 32 filesdep −os-stringdep ~extradep ~hie-biosdep ~hiedbPVP ok

version bump matches the API change (PVP)

Dependencies removed: os-string

Dependency ranges changed: extra, hie-bios, hiedb, hls-graph, hls-plugin-api, lsp, lsp-types, unordered-containers

API changes (from Hackage documentation)

Files

• ghcide.cabal +12/−10
• session-loader/Development/IDE/Session.hs +1108/−1232
• session-loader/Development/IDE/Session/Dependency.hs +35/−0
• session-loader/Development/IDE/Session/Diagnostics.hs +29/−6
• session-loader/Development/IDE/Session/Ghc.hs +578/−0
• session-loader/Development/IDE/Session/OrderedSet.hs +54/−0
• src/Development/IDE/Core/Actions.hs +5/−1
• src/Development/IDE/Core/Compile.hs +28/−34
• src/Development/IDE/Core/FileStore.hs +4/−4
• src/Development/IDE/Core/PluginUtils.hs +15/−2
• src/Development/IDE/Core/RuleTypes.hs +1/−2
• src/Development/IDE/Core/Rules.hs +32/−13
• src/Development/IDE/Core/Service.hs +5/−0
• src/Development/IDE/Core/Shake.hs +11/−7
• src/Development/IDE/Core/WorkerThread.hs +95/−26
• src/Development/IDE/GHC/Compat.hs +1/−0
• src/Development/IDE/GHC/Compat/Core.hs +0/−4
• src/Development/IDE/GHC/Compat/Util.hs +1/−0
• src/Development/IDE/GHC/Util.hs +5/−2
• src/Development/IDE/LSP/LanguageServer.hs +163/−81
• src/Development/IDE/Main.hs +2/−2
• src/Development/IDE/Plugin/Completions.hs +2/−2
• src/Development/IDE/Plugin/Completions/Logic.hs +1/−1
• src/Development/IDE/Plugin/HLS.hs +48/−32
• src/Development/IDE/Plugin/Test.hs +28/−0
• src/Development/IDE/Plugin/TypeLenses.hs +2/−4
• src/Development/IDE/Spans/AtPoint.hs +7/−5
• src/Development/IDE/Spans/Common.hs +6/−12
• src/Development/IDE/Spans/Pragmas.hs +0/−5
• src/Development/IDE/Types/Diagnostics.hs +0/−1
• src/Development/IDE/Types/HscEnvEq.hs +0/−4
• src/Development/IDE/Types/KnownTargets.hs +9/−29

@@ -2,7 +2,7 @@ build-type:         Simple category:           Development name:               ghcide-version:            2.13.0.0+version:            2.14.0.0 license:            Apache-2.0 license-file:       LICENSE author:             Digital Asset and Ghcide contributors@@ -14,7 +14,7 @@   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.12.2, 9.10.1, 9.8.4, 9.6.7}+tested-with:        GHC == {9.14.1, 9.12.2, 9.10.3, 9.8.4, 9.6.7} extra-source-files:   CHANGELOG.md   README.md@@ -74,20 +74,19 @@     , Glob     , haddock-library              >=1.8      && <1.12     , hashable-    , hie-bios                     ^>=0.17.0-    , hiedb                        ^>= 0.7.0.0-    , hls-graph                    == 2.13.0.0-    , hls-plugin-api               == 2.13.0.0+    , hie-bios                     ^>= 0.19.0+    , hiedb                        ^>= 0.8.0.0+    , hls-graph                    == 2.14.0.0+    , hls-plugin-api               == 2.14.0.0     , implicit-hie                 >= 0.1.4.0 && < 0.1.5     , lens     , lens-aeson     , list-t-    , lsp                          ^>=2.7-    , lsp-types                    ^>=2.3+    , lsp                          ^>=2.8+    , lsp-types                    ^>=2.4     , mtl     , opentelemetry                >=0.6.1     , optparse-applicative-    , os-string     , parallel     , process     , prettyprinter                >=1.7@@ -106,7 +105,7 @@     , transformers     , unliftio                     >=0.2.6     , unliftio-core-    , unordered-containers         >=0.2.10.0+    , unordered-containers         >=0.2.21     , vector    if os(windows)@@ -182,7 +181,9 @@     Development.IDE.Plugin.Test     Development.IDE.Plugin.TypeLenses     Development.IDE.Session+    Development.IDE.Session.Dependency     Development.IDE.Session.Diagnostics+    Development.IDE.Session.Ghc     Development.IDE.Session.Implicit     Development.IDE.Spans.AtPoint     Development.IDE.Spans.Common@@ -206,6 +207,7 @@     Development.IDE.GHC.CPP     Development.IDE.GHC.Warnings     Development.IDE.Types.Action+    Development.IDE.Session.OrderedSet    if flag(pedantic)     ghc-options:

@@ -1,1235 +1,1111 @@-{-# LANGUAGE CPP          #-}-{-# LANGUAGE TypeFamilies #-}--{-|-The logic for setting up a ghcide session by tapping into hie-bios.--}-module Development.IDE.Session-  (SessionLoadingOptions(..)-  ,CacheDirs(..)-  ,loadSessionWithOptions-  ,getInitialGhcLibDirDefault-  ,getHieDbLoc-  ,retryOnSqliteBusy-  ,retryOnException-  ,Log(..)-  ,runWithDb-  ) where---- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses--- the real GHC library and the types are incompatible. Furthermore, when--- building with ghc-lib we need to make this Haskell agnostic, so no hie-bios!--import           Control.Concurrent.Strict-import           Control.Exception.Safe              as Safe-import           Control.Monad-import           Control.Monad.Extra                 as Extra-import           Control.Monad.IO.Class-import qualified Crypto.Hash.SHA1                    as H-import           Data.Aeson                          hiding (Error)-import           Data.Bifunctor-import qualified Data.ByteString.Base16              as B16-import qualified Data.ByteString.Char8               as B-import           Data.Default-import           Data.Either.Extra-import           Data.Function-import           Data.Hashable                       hiding (hash)-import qualified Data.HashMap.Strict                 as HM-import           Data.IORef-import           Data.List-import           Data.List.Extra                     as L-import           Data.List.NonEmpty                  (NonEmpty (..))-import qualified Data.List.NonEmpty                  as NE-import qualified Data.Map.Strict                     as Map-import           Data.Maybe-import           Data.Proxy-import qualified Data.Text                           as T-import           Data.Time.Clock-import           Data.Version-import           Development.IDE.Core.RuleTypes-import           Development.IDE.Core.Shake          hiding (Log, knownTargets,-                                                      withHieDb)-import qualified Development.IDE.GHC.Compat          as Compat-import           Development.IDE.GHC.Compat.CmdLine-import           Development.IDE.GHC.Compat.Core     hiding (Target, TargetFile,-                                                      TargetModule, Var,-                                                      Warning, getOptions)-import qualified Development.IDE.GHC.Compat.Core     as GHC-import           Development.IDE.GHC.Compat.Env      hiding (Logger)-import           Development.IDE.GHC.Compat.Units    (UnitId)-import           Development.IDE.GHC.Util-import           Development.IDE.Graph               (Action)-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)-import           Development.IDE.Types.Location-import           Development.IDE.Types.Options-import           GHC.ResponseFile-import qualified HIE.Bios                            as HieBios-import qualified HIE.Bios.Cradle.Utils               as HieBios-import           HIE.Bios.Environment                hiding (getCacheDir)-import           HIE.Bios.Types                      hiding (Log)-import qualified HIE.Bios.Types                      as HieBios-import           Ide.Logger                          (Pretty (pretty),-                                                      Priority (Debug, Error, Info, Warning),-                                                      Recorder, WithPriority,-                                                      cmapWithPrio, logWith,-                                                      nest,-                                                      toCologActionWithPrio,-                                                      vcat, viaShow, (<+>))-import           Ide.Types                           (SessionLoadingPreferenceConfig (..),-                                                      sessionLoading)-import           Language.LSP.Protocol.Message-import           Language.LSP.Server-import           System.Directory-import qualified System.Directory.Extra              as IO-import           System.FilePath-import           System.Info--import           Control.Applicative                 (Alternative ((<|>)))-import           Data.Void--import           Control.Concurrent.STM.Stats        (atomically, modifyTVar',-                                                      readTVar, writeTVar)-import           Control.Concurrent.STM.TQueue-import           Control.DeepSeq-import           Control.Exception                   (evaluate)-import           Control.Monad.IO.Unlift             (MonadUnliftIO)-import           Control.Monad.Trans.Cont            (ContT (ContT, runContT))-import           Data.Foldable                       (for_)-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           Ide.PluginUtils                     (toAbsolute)-import qualified System.Random                       as Random-import           System.Random                       (RandomGen)-import           Text.ParserCombinators.ReadP        (readP_to_S)--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-  = LogSettingInitialDynFlags-  | LogGetInitialGhcLibDirDefaultCradleFail !CradleError !FilePath !(Maybe FilePath) !(Cradle Void)-  | LogGetInitialGhcLibDirDefaultCradleNone-  | LogHieDbRetry !Int !Int !Int !SomeException-  | LogHieDbRetriesExhausted !Int !Int !Int !SomeException-  | LogHieDbWriterThreadSQLiteError !SQLError-  | LogHieDbWriterThreadException !SomeException-  | LogInterfaceFilesCacheDir !FilePath-  | LogKnownFilesUpdated !(HashMap Target (HashSet NormalizedFilePath))-  | LogMakingNewHscEnv ![UnitId]-  | LogDLLLoadError !String-  | LogCradlePath !FilePath-  | LogCradleNotFound !FilePath-  | LogSessionLoadingResult !(Either [CradleError] (ComponentOptions, FilePath, String))-  | LogCradle !(Cradle Void)-  | LogNoneCradleFound FilePath-  | LogNewComponentCache !(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)-  | LogHieBios HieBios.Log-  | LogSessionLoadingChanged-deriving instance Show Log--instance Pretty Log where-  pretty = \case-    LogNoneCradleFound path ->-      "None cradle found for" <+> pretty path <+> ", ignoring the file"-    LogSettingInitialDynFlags ->-      "Setting initial dynflags..."-    LogGetInitialGhcLibDirDefaultCradleFail cradleError rootDirPath hieYamlPath cradle ->-      nest 2 $-        vcat-          [ "Couldn't load cradle for ghc libdir."-          , "Cradle error:" <+> viaShow cradleError-          , "Root dir path:" <+> pretty rootDirPath-          , "hie.yaml path:" <+> pretty hieYamlPath-          , "Cradle:" <+> viaShow cradle ]-    LogGetInitialGhcLibDirDefaultCradleNone ->-      "Couldn't load cradle. Cradle not found."-    LogHieDbRetry delay maxDelay retriesRemaining e ->-      nest 2 $-        vcat-          [ "Retrying hiedb action..."-          , "delay:" <+> pretty delay-          , "maximum delay:" <+> pretty maxDelay-          , "retries remaining:" <+> pretty retriesRemaining-          , "SQLite error:" <+> pretty (displayException e) ]-    LogHieDbRetriesExhausted baseDelay maxDelay retriesRemaining e ->-      nest 2 $-        vcat-          [ "Retries exhausted for hiedb action."-          , "base delay:" <+> pretty baseDelay-          , "maximum delay:" <+> pretty maxDelay-          , "retries remaining:" <+> pretty retriesRemaining-          , "Exception:" <+> pretty (displayException e) ]-    LogHieDbWriterThreadSQLiteError e ->-      nest 2 $-        vcat-          [ "HieDb writer thread SQLite error:"-          , pretty (displayException e) ]-    LogHieDbWriterThreadException e ->-      nest 2 $-        vcat-          [ "HieDb writer thread exception:"-          , pretty (displayException e) ]-    LogInterfaceFilesCacheDir path ->-      "Interface files cache directory:" <+> pretty path-    LogKnownFilesUpdated targetToPathsMap ->-      nest 2 $-        vcat-          [ "Known files updated:"-          , viaShow $ (HM.map . Set.map) fromNormalizedFilePath targetToPathsMap-          ]-    LogMakingNewHscEnv inPlaceUnitIds ->-      "Making new HscEnv. In-place unit ids:" <+> pretty (map show inPlaceUnitIds)-    LogDLLLoadError errorString ->-      "Error dynamically loading libm.so.6:" <+> pretty errorString-    LogCradlePath path ->-      "Cradle path:" <+> pretty path-    LogCradleNotFound path ->-      vcat-        [ "No [cradle](https://github.com/mpickering/hie-bios#hie-bios) found for" <+> pretty path <> "."-        , "Proceeding with [implicit cradle](https://hackage.haskell.org/package/implicit-hie)."-        , "You should ignore this message, unless you see a 'Multi Cradle: No prefixes matched' error." ]-    LogSessionLoadingResult e ->-      "Session loading result:" <+> viaShow e-    LogCradle cradle ->-      "Cradle:" <+> viaShow cradle-    LogNewComponentCache componentCache ->-      "New component cache HscEnvEq:" <+> viaShow componentCache-    LogHieBios msg -> pretty msg-    LogSessionLoadingChanged ->-      "Session Loading config changed, reloading the full session."---- | Bump this version number when making changes to the format of the data stored in hiedb-hiedbDataVersion :: String-hiedbDataVersion = "2"--data CacheDirs = CacheDirs-  { hiCacheDir, hieCacheDir, oCacheDir :: Maybe FilePath}--data SessionLoadingOptions = SessionLoadingOptions-  { findCradle             :: FilePath -> IO (Maybe FilePath)-  -- | Load the cradle with an optional 'hie.yaml' location.-  -- If a 'hie.yaml' is given, use it to load the cradle.-  -- Otherwise, use the provided project root directory to determine the cradle type.-  , loadCradle             :: Recorder (WithPriority Log) -> Maybe FilePath -> FilePath -> IO (HieBios.Cradle Void)-  -- | Given the project name and a set of command line flags,-  --   return the path for storing generated GHC artifacts,-  --   or 'Nothing' to respect the cradle setting-  , getCacheDirs           :: String -> [String] -> IO CacheDirs-  -- | Return the GHC lib dir to use for the 'unsafeGlobalDynFlags'-  , getInitialGhcLibDir    :: Recorder (WithPriority Log) -> FilePath -> IO (Maybe LibDir)-  }--instance Default SessionLoadingOptions where-    def =  SessionLoadingOptions-        {findCradle = HieBios.findCradle-        ,loadCradle = loadWithImplicitCradle-        ,getCacheDirs = getCacheDirsDefault-        ,getInitialGhcLibDir = getInitialGhcLibDirDefault-        }---- | Find the cradle for a given 'hie.yaml' configuration.------ If a 'hie.yaml' is given, the cradle is read from the config.---  If this config does not comply to the "hie.yaml"--- specification, an error is raised.------ If no location for "hie.yaml" is provided, the implicit config is used--- using the provided root directory for discovering the project.--- The implicit config uses different heuristics to determine the type--- of the project that may or may not be accurate.-loadWithImplicitCradle-  :: Recorder (WithPriority Log)-  -> Maybe FilePath-  -- ^ Optional 'hie.yaml' location. Will be used if given.-  -> FilePath-  -- ^ Root directory of the project. Required as a fallback-  -- if no 'hie.yaml' location is given.-  -> IO (HieBios.Cradle Void)-loadWithImplicitCradle recorder mHieYaml rootDir = do-  let logger = toCologActionWithPrio (cmapWithPrio LogHieBios recorder)-  case mHieYaml of-    Just yaml -> HieBios.loadCradle logger yaml-    Nothing   -> GhcIde.loadImplicitCradle logger rootDir--getInitialGhcLibDirDefault :: Recorder (WithPriority Log) -> FilePath -> IO (Maybe LibDir)-getInitialGhcLibDirDefault recorder rootDir = do-  hieYaml <- findCradle def (rootDir </> "a")-  cradle <- loadCradle def recorder hieYaml rootDir-  libDirRes <- getRuntimeGhcLibDir cradle-  case libDirRes of-      CradleSuccess libdir -> pure $ Just $ LibDir libdir-      CradleFail err -> do-        logWith recorder Error $ LogGetInitialGhcLibDirDefaultCradleFail err rootDir hieYaml cradle-        pure Nothing-      CradleNone -> do-        logWith recorder Warning LogGetInitialGhcLibDirDefaultCradleNone-        pure Nothing---- | 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--- the action again for a maximum of `maxRetryCount` times.--- `MonadIO`, `MonadCatch` are used as constraints because there are a few--- HieDb functions that don't return IO values.-retryOnException-  :: (MonadIO m, MonadCatch m, RandomGen g, Exception e)-  => (e -> Maybe e) -- ^ only retry on exception if this predicate returns Just-  -> Recorder (WithPriority Log)-  -> Int -- ^ maximum backoff delay in microseconds-  -> Int -- ^ base backoff delay in microseconds-  -> Int -- ^ maximum number of times to retry-  -> g -- ^ random number generator-  -> m a -- ^ action that may throw exception-  -> m a-retryOnException exceptionPred recorder maxDelay !baseDelay !maxTimesRetry rng action = do-  result <- tryJust exceptionPred action-  case result of-    Left e-      | maxTimesRetry > 0 -> do-        -- multiply by 2 because baseDelay is midpoint of uniform range-        let newBaseDelay = min maxDelay (baseDelay * 2)-        let (delay, newRng) = Random.randomR (0, newBaseDelay) rng-        let newMaxTimesRetry = maxTimesRetry - 1-        liftIO $ do-          logWith recorder Warning $ LogHieDbRetry delay maxDelay newMaxTimesRetry (toException e)-          threadDelay delay-        retryOnException exceptionPred recorder maxDelay newBaseDelay newMaxTimesRetry newRng action--      | otherwise -> do-        liftIO $ do-          logWith recorder Warning $ LogHieDbRetriesExhausted baseDelay maxDelay maxTimesRetry (toException e)-          throwIO e--    Right b -> pure b---- | in microseconds-oneSecond :: Int-oneSecond = 1000000---- | in microseconds-oneMillisecond :: Int-oneMillisecond = 1000---- | default maximum number of times to retry hiedb call-maxRetryCount :: Int-maxRetryCount = 10--retryOnSqliteBusy :: (MonadIO m, MonadCatch m, RandomGen g)-                  => Recorder (WithPriority Log) -> g -> m a -> m a-retryOnSqliteBusy recorder rng action =-  let isErrorBusy e-        | SQLError{ sqlError = ErrorBusy } <- e = Just e-        | otherwise = Nothing-  in-    retryOnException isErrorBusy recorder oneSecond oneMillisecond maxRetryCount rng action--makeWithHieDbRetryable :: RandomGen g => Recorder (WithPriority Log) -> g -> HieDb -> WithHieDb-makeWithHieDbRetryable recorder rng hieDb f =-  retryOnSqliteBusy recorder rng (f hieDb)---- | Wraps `withHieDb` to provide a database connection for reading, and a `HieWriterChan` for--- writing. Actions are picked off one by one from the `HieWriterChan` and executed in serial--- by a worker thread using a dedicated database connection.--- This is done in order to serialize writes to the database, or else SQLite becomes unhappy------ Also see Note [Serializing runs in separate thread]-runWithDb :: Recorder (WithPriority Log) -> FilePath -> ContT () IO (WithHieDbShield, IndexQueue)-runWithDb recorder fp = ContT $ \k -> do-  -- use non-deterministic seed because maybe multiple HLS start at same time-  -- and send bursts of requests-  rng <- Random.newStdGen-  -- Delete the database if it has an incompatible schema version-  retryOnSqliteBusy-    recorder-    rng-    (withHieDb fp (const $ pure ()) `Safe.catch` \IncompatibleSchemaVersion{} -> removeFile fp)--  withHieDb fp $ \writedb -> do-    -- the type signature is necessary to avoid concretizing the tyvar-    -- e.g. `withWriteDbRetryable initConn` without type signature will-    -- instantiate tyvar `a` to `()`-    let withWriteDbRetryable :: WithHieDb-        withWriteDbRetryable = makeWithHieDbRetryable recorder rng writedb-    withWriteDbRetryable initConn---    -- Clear the index of any files that might have been deleted since the last run-    _ <- withWriteDbRetryable deleteMissingRealFiles-    _ <- withWriteDbRetryable garbageCollectTypeNames--    runContT (withWorkerQueue (writer withWriteDbRetryable)) $ \chan ->-        withHieDb fp (\readDb -> k (WithHieDbShield $ makeWithHieDbRetryable recorder rng readDb, chan))-  where-    writer withHieDbRetryable l = do-        -- TODO: probably should let exceptions be caught/logged/handled by top level handler-        l withHieDbRetryable-          `Safe.catch` \e@SQLError{} -> do-            logWith recorder Error $ LogHieDbWriterThreadSQLiteError e-          `Safe.catchAny` \f -> do-            logWith recorder Error $ LogHieDbWriterThreadException f---getHieDbLoc :: FilePath -> IO FilePath-getHieDbLoc dir = do-  let db = intercalate "-" [dirHash, takeBaseName dir, Compat.ghcVersionStr, hiedbDataVersion] <.> "hiedb"-      dirHash = B.unpack $ B16.encode $ H.hash $ B.pack dir-  cDir <- IO.getXdgDirectory IO.XdgCache cacheDir-  createDirectoryIfMissing True cDir-  pure (cDir </> db)---- | Given a root directory, return a Shake 'Action' which setups an--- 'IdeGhcSession' given a file.--- Some of the many things this does:------ * Find the cradle for the file--- * Get the session options,--- * Get the GHC lib directory--- * Make sure the GHC compiletime and runtime versions match--- * Restart the Shake session------ This is the key function which implements multi-component support. All--- components mapping to the same hie.yaml file are mapped to the same--- HscEnv which is updated as new components are discovered.--loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> TQueue (IO ()) -> IO (Action IdeGhcSession)-loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do-  let toAbsolutePath = toAbsolute rootDir -- see Note [Root Directory]-  cradle_files <- newIORef []-  -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file-  hscEnvs <- newVar Map.empty :: IO (Var HieMap)-  -- Mapping from a Filepath to HscEnv-  fileToFlags <- newVar Map.empty :: IO (Var FlagsMap)-  -- Mapping from a Filepath to its 'hie.yaml' location.-  -- Should hold the same Filepaths as 'fileToFlags', otherwise-  -- they are inconsistent. So, everywhere you modify 'fileToFlags',-  -- you have to modify 'filesMap' as well.-  filesMap <- newVar HM.empty :: IO (Var FilesMap)-  -- Version of the mappings above-  version <- newVar 0-  biosSessionLoadingVar <- newVar Nothing :: IO (Var (Maybe SessionLoadingPreferenceConfig))-  let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar version)-  -- This caches the mapping from Mod.hs -> hie.yaml-  cradleLoc <- liftIO $ memoIO $ \v -> do-      res <- findCradle v-      -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path-      -- try and normalise that-      -- e.g. see https://github.com/haskell/ghcide/issues/126-      let res' = toAbsolutePath <$> res-      return $ normalise <$> res'--  return $ do-    clientConfig <- getClientConfigAction-    extras@ShakeExtras{restartShakeSession, ideNc, knownTargetsVar, lspEnv-                      } <- getShakeExtras-    let invalidateShakeCache = do-            void $ modifyVar' version succ-            return $ toNoFileKey GhcSessionIO--    IdeOptions{ optTesting = IdeTesting optTesting-              , optCheckProject = getCheckProject-              , optExtensions-              , optHaddockParse-              } <- getIdeOptions--        -- populate the knownTargetsVar with all the-        -- files in the project so that `knownFiles` can learn about them and-        -- we can generate a complete module graph-    let extendKnownTargets newTargets = do-          knownTargets <- concatForM  newTargets $ \TargetDetails{..} ->-            case targetTarget of-              TargetFile f -> do-                -- If a target file has multiple possible locations, then we-                -- assume they are all separate file targets.-                -- This happens with '.hs-boot' files if they are in the root directory of the project.-                -- GHC reports options such as '-i. A' as 'TargetFile A.hs' instead of 'TargetModule A'.-                -- In 'fromTargetId', we dutifully look for '.hs-boot' files and add them to the-                -- targetLocations of the TargetDetails. Then we add everything to the 'knownTargetsVar'.-                -- However, when we look for a 'Foo.hs-boot' file in 'FindImports.hs', we look for either-                ---                --  * TargetFile Foo.hs-boot-                --  * TargetModule Foo-                ---                -- If we don't generate a TargetFile for each potential location, we will only have-                -- 'TargetFile Foo.hs' in the 'knownTargetsVar', thus not find 'TargetFile Foo.hs-boot'-                -- and also not find 'TargetModule Foo'.-                fs <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations-                pure $ map (\fp -> (TargetFile fp, Set.singleton fp)) (nubOrd (f:fs))-              TargetModule _ -> do-                found <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations-                return [(targetTarget, Set.fromList found)]-          hasUpdate <- atomically $ do-            known <- readTVar knownTargetsVar-            let known' = flip mapHashed known $ \k -> unionKnownTargets k (mkKnownTargets knownTargets)-                hasUpdate = if known /= known' then Just (unhashed known') else Nothing-            writeTVar knownTargetsVar known'-            pure hasUpdate-          for_ hasUpdate $ \x ->-            logWith recorder Debug $ LogKnownFilesUpdated (targetMap x)-          return $ toNoFileKey GetKnownTargets--    -- Create a new HscEnv from a hieYaml root and a set of options-    let packageSetup :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath)-                     -> IO ([ComponentInfo], [ComponentInfo])-        packageSetup (hieYaml, cfp, opts, libDir) = do-          -- Parse DynFlags for the newly discovered component-          hscEnv <- emptyHscEnv ideNc libDir-          newTargetDfs <- evalGhcEnv hscEnv $ setOptions optHaddockParse cfp opts (hsc_dflags hscEnv) rootDir-          let deps = componentDependencies opts ++ maybeToList hieYaml-          dep_info <- getDependencyInfo (fmap toAbsolutePath deps)-          -- Now lookup to see whether we are combining with an existing HscEnv-          -- or making a new one. The lookup returns the HscEnv and a list of-          -- information about other components loaded into the HscEnv-          -- (unitId, DynFlag, Targets)-          modifyVar hscEnvs $ \m -> do-              -- Just deps if there's already an HscEnv-              -- Nothing is it's the first time we are making an HscEnv-              let oldDeps = Map.lookup hieYaml m-              let -- Add the raw information about this component to the list-                  -- We will modify the unitId and DynFlags used for-                  -- compilation but these are the true source of-                  -- information.-                  new_deps = fmap (\(df, targets) -> RawComponentInfo (homeUnitId_ df) df targets cfp opts dep_info) newTargetDfs-                  all_deps = new_deps `NE.appendList` fromMaybe [] oldDeps-                  -- Get all the unit-ids for things in this component-                  _inplace = map rawComponentUnitId $ NE.toList all_deps--              all_deps' <- forM all_deps $ \RawComponentInfo{..} -> do-                  let prefix = show rawComponentUnitId-                  -- See Note [Avoiding bad interface files]-                  let cacheDirOpts = componentOptions opts-                  cacheDirs <- liftIO $ getCacheDirs prefix cacheDirOpts-                  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-                           , componentTargets = rawComponentTargets-                           , componentFP = rawComponentFP-                           , componentCOptions = rawComponentCOptions-                           , componentDependencyInfo = rawComponentDependencyInfo-                           }-              -- Modify the map so the hieYaml now maps to the newly updated-              -- ComponentInfos-              -- Returns-              -- . The information for the new component which caused this cache miss-              -- . The modified information (without -inplace flags) for-              --   existing packages-              let (new,old) = NE.splitAt (NE.length new_deps) all_deps'-              pure (Map.insert hieYaml (NE.toList all_deps) m, (new,old))---    let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath)-                -> IO (IdeResult HscEnvEq,[FilePath])-        session args@(hieYaml, _cfp, _opts, _libDir) = do-          (new_deps, old_deps) <- packageSetup args--          -- For each component, now make a new HscEnvEq which contains the-          -- HscEnv for the hie.yaml file but the DynFlags for that component-          -- 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 _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)-                = case HM.lookup _cfp flags_map' of-                    Just this -> (all_targets', flags_map', this)-                    Nothing -> (this_target_details : all_targets', HM.insert _cfp this_flags flags_map', this_flags)-                  where all_targets' = concat all_target_details-                        flags_map' = HM.fromList (concatMap toFlagsMap all_targets')-                        this_target_details = TargetDetails (TargetFile _cfp) this_error_env this_dep_info [_cfp]-                        this_flags = (this_error_env, this_dep_info)-                        this_error_env = ([this_error], Nothing)-                        this_error = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) _cfp-                                       (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))-          -- The VFS doesn't change on cradle edits, re-use the old one.-          -- Invalidate all the existing GhcSession build nodes by restarting the Shake session-          keys2 <- invalidateShakeCache-          restartShakeSession VFSUnmodified "new component" [] $ do-            keys1 <- extendKnownTargets all_targets-            return [keys1, keys2]--          -- Typecheck all files in the project on startup-          checkProject <- getCheckProject-          unless (null new_deps || not checkProject) $ do-                cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations all_targets)-                void $ shakeEnqueue extras $ mkDelayedAction "InitialLoad" Debug $ void $ do-                    mmt <- uses GetModificationTime cfps'-                    let cs_exist = catMaybes (zipWith (<$) cfps' mmt)-                    modIfaces <- uses GetModIface cs_exist-                    -- update exports map-                    shakeExtras <- getShakeExtras-                    let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces-                    liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>)--          return $ second Map.keys this_options--    let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath])-        consultCradle hieYaml cfp = do-           let lfpLog = makeRelative rootDir cfp-           logWith recorder Info $ LogCradlePath lfpLog-           when (isNothing hieYaml) $-             logWith recorder Warning $ LogCradleNotFound lfpLog-           cradle <- loadCradle recorder hieYaml rootDir-           when optTesting $ mRunLspT lspEnv $-            sendNotification (SMethod_CustomMethod (Proxy @"ghcide/cradle/loaded")) (toJSON cfp)--           -- Display a user friendly progress message here: They probably don't know what a cradle is-           let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle))-                         <> " (for " <> T.pack lfpLog <> ")"-           eopts <- mRunLspTCallback lspEnv (\act -> withIndefiniteProgress progMsg Nothing NotCancellable (const act)) $-              withTrace "Load cradle" $ \addTag -> do-                  addTag "file" lfpLog-                  old_files <- readIORef cradle_files-                  res <- cradleToOptsAndLibDir recorder (sessionLoading clientConfig) cradle cfp old_files-                  addTag "result" (show res)-                  return res--           logWith recorder Debug $ LogSessionLoadingResult eopts-           case eopts of-             -- The cradle gave us some options so get to work turning them-             -- into and HscEnv.-             Right (opts, libDir, version) -> do-               let compileTime = fullCompilerVersion-               case reverse $ readP_to_S parseVersion version of-                 [] -> error $ "GHC version could not be parsed: " <> version-                 ((runTime, _):_)-                   | compileTime == runTime -> do-                     atomicModifyIORef' cradle_files (\xs -> (cfp:xs,()))-                     session (hieYaml, toNormalizedFilePath' cfp, opts, libDir)-                   | otherwise -> return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[])-             -- Failure case, either a cradle error or the none cradle-             Left err -> do-               dep_info <- getDependencyInfo (maybeToList hieYaml)-               let ncfp = toNormalizedFilePath' cfp-               let res = (map (\err' -> renderCradleError err' cradle ncfp) err, Nothing)-               void $ modifyVar' fileToFlags $-                    Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info))-               void $ modifyVar' filesMap $ HM.insert ncfp hieYaml-               return (res, maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err)--    let-        -- | We allow users to specify a loading strategy.-        -- Check whether this config was changed since the last time we have loaded-        -- a session.-        ---        -- If the loading configuration changed, we likely should restart the session-        -- in its entirety.-        didSessionLoadingPreferenceConfigChange :: IO Bool-        didSessionLoadingPreferenceConfigChange = do-          mLoadingConfig <- readVar biosSessionLoadingVar-          case mLoadingConfig of-            Nothing -> do-              writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig))-              pure False-            Just loadingConfig -> do-              writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig))-              pure (loadingConfig /= sessionLoading clientConfig)--    -- This caches the mapping from hie.yaml + Mod.hs -> [String]-    -- Returns the Ghc session and the cradle dependencies-    let sessionOpts :: (Maybe FilePath, FilePath)-                    -> IO (IdeResult HscEnvEq, [FilePath])-        sessionOpts (hieYaml, file) = do-          Extra.whenM didSessionLoadingPreferenceConfigChange $ do-            logWith recorder Info LogSessionLoadingChanged-            -- If the dependencies are out of date then clear both caches and start-            -- again.-            modifyVar_ fileToFlags (const (return Map.empty))-            modifyVar_ filesMap (const (return HM.empty))-            -- Don't even keep the name cache, we start from scratch here!-            modifyVar_ hscEnvs (const (return Map.empty))--          v <- Map.findWithDefault HM.empty hieYaml <$> readVar fileToFlags-          let cfp = toAbsolutePath file-          case HM.lookup (toNormalizedFilePath' cfp) v of-            Just (opts, old_di) -> do-              deps_ok <- checkDependencyInfo old_di-              if not deps_ok-                then do-                  -- If the dependencies are out of date then clear both caches and start-                  -- again.-                  modifyVar_ fileToFlags (const (return Map.empty))-                  modifyVar_ filesMap (const (return HM.empty))-                  -- Keep the same name cache-                  modifyVar_ hscEnvs (return . Map.adjust (const []) hieYaml )-                  consultCradle hieYaml cfp-                else return (opts, Map.keys old_di)-            Nothing -> consultCradle hieYaml cfp--    -- The main function which gets options for a file. We only want one of these running-    -- at a time. Therefore the IORef contains the currently running cradle, if we try-    -- to get some more options then we wait for the currently running action to finish-    -- before attempting to do so.-    let getOptions :: FilePath -> IO (IdeResult HscEnvEq, [FilePath])-        getOptions file = do-            let ncfp = toNormalizedFilePath' (toAbsolutePath file)-            cachedHieYamlLocation <- HM.lookup ncfp <$> readVar filesMap-            hieYaml <- cradleLoc file-            let-              -- Each one of deps will be registered as a FileSystemWatcher in the GhcSession action-              -- so that we can get a workspace/didChangeWatchedFiles notification when a dep changes.-              -- The GlobPattern of a FileSystemWatcher can be absolute or relative.-              -- We use the absolute one because it is supported by more LSP clients.-              -- Here we make sure deps are absolute and later we use those absolute deps as GlobPattern.-              absolutePathsCradleDeps (eq, deps)-                = (eq, fmap toAbsolutePath deps)-            (absolutePathsCradleDeps <$> sessionOpts (join cachedHieYamlLocation <|> hieYaml, file))  `Safe.catch` \e ->-                return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml)--    returnWithVersion $ \file -> do-      -- see Note [Serializing runs in separate thread]-      awaitRunInThread que $ getOptions file---- | Run the specific cradle on a specific FilePath via hie-bios.--- This then builds dependencies or whatever based on the cradle, gets the--- GHC options/dynflags needed for the session and the GHC library directory-cradleToOptsAndLibDir :: Recorder (WithPriority Log) -> SessionLoadingPreferenceConfig -> Cradle Void -> FilePath -> [FilePath]-                      -> IO (Either [CradleError] (ComponentOptions, FilePath, String))-cradleToOptsAndLibDir recorder loadConfig cradle file old_fps = do-    -- let noneCradleFoundMessage :: FilePath -> T.Text-    --     noneCradleFoundMessage f = T.pack $ "none cradle found for " <> f <> ", ignoring the file"-    -- Start off by getting the session options-    logWith recorder Debug $ LogCradle cradle-    cradleRes <- HieBios.getCompilerOptions file loadStyle cradle-    case cradleRes of-        CradleSuccess r -> do-            -- Now get the GHC lib dir-            libDirRes <- getRuntimeGhcLibDir cradle-            versionRes <- getRuntimeGhcVersion cradle-            case liftA2 (,) libDirRes versionRes of-                -- This is the successful path-                (CradleSuccess (libDir, version)) -> pure (Right (r, libDir, version))-                CradleFail err       -> return (Left [err])-                CradleNone           -> do-                    logWith recorder Info $ LogNoneCradleFound file-                    return (Left [])--        CradleFail err -> return (Left [err])-        CradleNone -> do-            logWith recorder Info $ LogNoneCradleFound file-            return (Left [])--    where-        loadStyle = case loadConfig of-            PreferSingleComponentLoading -> LoadFile-            PreferMultiComponentLoading  -> LoadWithContext old_fps--emptyHscEnv :: NameCache -> FilePath -> IO HscEnv-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-    pure $ setNameCache nc (hscSetFlags ((hsc_dflags env){useUnicode = True }) env)--data TargetDetails = TargetDetails-  {-      targetTarget    :: !Target,-      targetEnv       :: !(IdeResult HscEnvEq),-      targetDepends   :: !DependencyInfo,-      targetLocations :: ![NormalizedFilePath]-  }--fromTargetId :: [FilePath]          -- ^ import paths-             -> [String]            -- ^ extensions to consider-             -> TargetId-             -> IdeResult HscEnvEq-             -> DependencyInfo-             -> IO [TargetDetails]--- For a target module we consider all the import paths-fromTargetId is exts (GHC.TargetModule modName) env dep = do-    let fps = [i </> moduleNameSlashes modName -<.> ext <> boot-              | ext <- exts-              , i <- is-              , boot <- ["", "-boot"]-              ]-    let locs = fmap toNormalizedFilePath' fps-    return [TargetDetails (TargetModule modName) env dep locs]--- For a 'TargetFile' we consider all the possible module names-fromTargetId _ _ (GHC.TargetFile f _) env deps = do-    let nf = toNormalizedFilePath' f-    let other-          | "-boot" `isSuffixOf` f = toNormalizedFilePath' (L.dropEnd 5 $ fromNormalizedFilePath nf)-          | otherwise = toNormalizedFilePath' (fromNormalizedFilePath nf ++ "-boot")-    return [TargetDetails (TargetFile nf) env deps [nf, other]]--toFlagsMap :: TargetDetails -> [(NormalizedFilePath, (IdeResult HscEnvEq, DependencyInfo))]-toFlagsMap TargetDetails{..} =-    [ (l, (targetEnv, targetDepends)) | l <-  targetLocations]---setNameCache :: NameCache -> HscEnv -> HscEnv-setNameCache nc hsc = hsc { hsc_NC = nc }--#if MIN_VERSION_ghc(9,13,0)--- Moved back to implementation in GHC.-checkHomeUnitsClosed' ::  UnitEnv -> OS.Set UnitId -> [DriverMessages]-checkHomeUnitsClosed' ue _ = checkHomeUnitsClosed ue-#else--- 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 -> Maybe (Compat.MsgEnvelope DriverMessage)-checkHomeUnitsClosed' ue home_id_set-    | 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>")--    graph :: Graph (Node UnitId UnitId)-    graph = graphFromEdgedVerticesUniq graphNodes--    -- downwards closure of graph-    downwards_closure-      = graphFromEdgedVerticesUniq [ DigraphNode uid uid (OS.toList deps)-                                   | (uid, deps) <- Map.toList (allReachable graph node_key)]--    inverse_closure = transposeG downwards_closure--    upwards_closure = OS.fromList $ map node_key $ reachablesG inverse_closure [DigraphNode uid uid [] | uid <- OS.toList home_id_set]--    all_unit_direct_deps :: UniqMap UnitId (OS.Set UnitId)-    all_unit_direct_deps-      = unitEnv_foldWithKey go emptyUniqMap $ ue_home_unit_graph ue-      where-        go rest this this_uis =-           plusUniqMap_C OS.union-             (addToUniqMap_C OS.union external_depends this (OS.fromList this_deps))-             rest-           where-             external_depends = mapUniqMap (OS.fromList . unitDepends)-#if !MIN_VERSION_ghc(9,7,0)-                              $ listToUniqMap $ Map.toList-#endif--                              $ unitInfoMap this_units-             this_units = homeUnitEnv_units this_uis-             this_deps = [ Compat.toUnitId unit | (unit,Just _) <- explicitUnits this_units]--    graphNodes :: [Node UnitId UnitId]-    graphNodes = go OS.empty home_id_set-      where-        go done todo-          = case OS.minView todo of-              Nothing -> []-              Just (uid, todo')-                | OS.member uid done -> go done todo'-                | otherwise -> case lookupUniqMap all_unit_direct_deps uid of-                    Nothing -> pprPanic "uid not found" (Compat.ppr (uid, all_unit_direct_deps))-                    Just depends ->-                      let todo'' = (depends OS.\\ done) `OS.union` todo'-                      in DigraphNode uid uid (OS.toList depends) : go (OS.insert uid done) todo''-#endif---- | Create a mapping from FilePaths to HscEnvEqs--- This combines all the components we know about into--- an appropriate session, which is a multi component--- session on GHC 9.4+-newComponentCache-         :: Recorder (WithPriority Log)-         -> [String]           -- ^ File extensions to consider-         -> 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-         -> IO [ [TargetDetails] ]-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.-        -- However, we might have added some targets to the old unit-        -- (see special target), so preserve those-        unionCIs new_ci old_ci = new_ci { componentTargets = componentTargets new_ci ++ componentTargets old_ci }-        mkMap = Map.fromListWith unionCIs . map (\ci -> (componentUnitId ci, ci))-    let dfs = map componentDynFlags $ Map.elems cis-        uids = Map.keys cis-    logWith recorder Info $ LogMakingNewHscEnv uids-    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,13,0)-    let closure_errs_raw = checkHomeUnitsClosed' (hsc_unit_env hscEnv') (hsc_all_home_unit_ids hscEnv')-        closure_errs = concatMap (Compat.bagToList . Compat.getMessages) closure_errs_raw-#else-    let closure_errs = maybeToList $ checkHomeUnitsClosed' (hsc_unit_env hscEnv') (hsc_all_home_unit_ids hscEnv')-#endif-        closure_err_to_multi_err err =-            ideErrorWithSource-                (Just "cradle") (Just DiagnosticSeverity_Warning) _cfp-                (T.pack (Compat.printWithoutUniques (singleMessage err)))-                (Just (fmap GhcDriverMessage err))-        multi_errs = map closure_err_to_multi_err closure_errs-        bad_units = OS.fromList $ concat $ do-            x <- map errMsgDiagnostic closure_errs-            DriverHomePackagesNotClosed us <- pure x-            pure us-        isBad ci = (homeUnitId_ (componentDynFlags ci)) `OS.member` bad_units-    -- Whenever we spin up a session on Linux, dynamically load libm.so.6-    -- in. We need this in case the binary is statically linked, in which-    -- case the interactive session will fail when trying to load-    -- ghc-prim, which happens whenever Template Haskell is being-    -- evaluated or haskell-language-server's eval plugin tries to run-    -- some code. If the binary is dynamically linked, then this will have-    -- no effect.-    -- See https://github.com/haskell/haskell-language-server/issues/221-    -- We need to do this after the call to setSessionDynFlags initialises-    -- the loader-    when (os == "linux") $ do-      initObjLinker hscEnv'-      res <- loadDLL hscEnv' "libm.so.6"-      case res of-        Nothing  -> pure ()-        Just err -> logWith recorder Error $ LogDLLLoadError err--    forM (Map.elems cis) $ \ci -> do-      let df = componentDynFlags ci-      thisEnv <- do-            -- 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'-      henv <- newHscEnvEq thisEnv-      let targetEnv = (if isBad ci then multi_errs else [], Just henv)-          targetDepends = componentDependencyInfo ci-      logWith recorder Debug $ LogNewComponentCache (targetEnv, targetDepends)-      evaluate $ liftRnf rwhnf $ componentTargets ci--      let mk t = fromTargetId (importPaths df) exts (targetId t) targetEnv targetDepends-      ctargets <- concatMapM mk (componentTargets ci)--      return (L.nubOrdOn targetTarget ctargets)--{- Note [Avoiding bad interface files]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Originally, we set the cache directory for the various components once-on the first occurrence of the component.-This works fine if these components have no references to each other,-but you have components that depend on each other, the interface files are-updated for each component.-After restarting the session and only opening the component that depended-on the other, suddenly the interface files of this component are stale.-However, from the point of view of `ghcide`, they do not look stale,-thus, not regenerated and the IDE shows weird errors such as:-```-typecheckIface-Declaration for Rep_ClientRunFlags-Axiom branches Rep_ClientRunFlags:-  Failed to load interface for ‘Distribution.Simple.Flag’-  Use -v to see a list of the files searched for.-```-and-```-expectJust checkFamInstConsistency-CallStack (from HasCallStack):-  error, called at compiler\\utils\\Maybes.hs:55:27 in ghc:Maybes-  expectJust, called at compiler\\typecheck\\FamInst.hs:461:30 in ghc:FamInst-```--and many more.--To mitigate this, we set the cache directory for each component dependent-on the components of the current `HscEnv`, additionally to the component options-of the respective components.-Assume two components, c1, c2, where c2 depends on c1, and the options of the-respective components are co1, co2.-If we want to load component c2, followed by c1, we set the cache directory for-each component in this way:--  * Load component c2-    * (Cache Directory State)-        - name of c2 + co2-  * Load component c1-    * (Cache Directory State)-        - name of c2 + name of c1 + co2-        - name of c2 + name of c1 + co1--Overall, we created three cache directories. If we opened c1 first, then we-create a fourth cache directory.-This makes sure that interface files are always correctly updated.--Since this causes a lot of recompilation, we only update the cache-directory,-if the dependencies of a component have really changed.-E.g. when you load two executables, they can not depend on each other. They-should be filtered out, such that we dont have to re-compile everything.--}---- | Set the cache-directory based on the ComponentOptions and a list of--- internal packages.--- For the exact reason, see Note [Avoiding bad interface files].-setCacheDirs :: MonadUnliftIO m => Recorder (WithPriority Log) -> CacheDirs -> DynFlags -> m DynFlags-setCacheDirs recorder CacheDirs{..} dflags = do-    logWith recorder Info $ LogInterfaceFilesCacheDir (fromMaybe cacheDir hiCacheDir)-    pure $ dflags-          & maybe id setHiDir hiCacheDir-          & maybe id setHieDir hieCacheDir-          & maybe id setODir oCacheDir---- See Note [Multi Cradle Dependency Info]-type DependencyInfo = Map.Map FilePath (Maybe UTCTime)-type HieMap = Map.Map (Maybe FilePath) [RawComponentInfo]--- | Maps a "hie.yaml" location to all its Target Filepaths and options.-type FlagsMap = Map.Map (Maybe FilePath) (HM.HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo))--- | Maps a Filepath to its respective "hie.yaml" location.--- It aims to be the reverse of 'FlagsMap'.-type FilesMap = HM.HashMap NormalizedFilePath (Maybe FilePath)---- This is pristine information about a component-data RawComponentInfo = RawComponentInfo-  { rawComponentUnitId         :: UnitId-  -- | Unprocessed DynFlags. Contains inplace packages such as libraries.-  -- We do not want to use them unprocessed.-  , rawComponentDynFlags       :: DynFlags-  -- | All targets of this components.-  , rawComponentTargets        :: [GHC.Target]-  -- | Filepath which caused the creation of this component-  , rawComponentFP             :: NormalizedFilePath-  -- | Component Options used to load the component.-  , rawComponentCOptions       :: ComponentOptions-  -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file-  -- to last modification time. See Note [Multi Cradle Dependency Info].-  , rawComponentDependencyInfo :: DependencyInfo-  }---- This is processed information about the component, in particular the dynflags will be modified.-data ComponentInfo = ComponentInfo-  { componentUnitId         :: UnitId-  -- | Processed DynFlags. Does not contain inplace packages such as local-  -- libraries. Can be used to actually load this Component.-  , componentDynFlags       :: DynFlags-  -- | All targets of this components.-  , componentTargets        :: [GHC.Target]-  -- | Filepath which caused the creation of this component-  , componentFP             :: NormalizedFilePath-  -- | Component Options used to load the component.-  , componentCOptions       :: ComponentOptions-  -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file-  -- to last modification time. See Note [Multi Cradle Dependency Info]-  , componentDependencyInfo :: DependencyInfo-  }---- | Check if any dependency has been modified lately.-checkDependencyInfo :: DependencyInfo -> IO Bool-checkDependencyInfo old_di = do-  di <- getDependencyInfo (Map.keys old_di)-  return (di == old_di)---- Note [Multi Cradle Dependency Info]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- Why do we implement our own file modification tracking here?--- The primary reason is that the custom caching logic is quite complicated and going into shake--- adds even more complexity and more indirection. I did try for about 5 hours to work out how to--- use shake rules rather than IO but eventually gave up.---- | Computes a mapping from a filepath to its latest modification date.--- See Note [Multi Cradle Dependency Info] why we do this ourselves instead--- of letting shake take care of it.-getDependencyInfo :: [FilePath] -> IO DependencyInfo-getDependencyInfo fs = Map.fromList <$> mapM do_one fs--  where-    safeTryIO :: IO a -> IO (Either IOException a)-    safeTryIO = Safe.try--    do_one :: FilePath -> IO (FilePath, Maybe UTCTime)-    do_one fp = (fp,) . eitherToMaybe <$> safeTryIO (getModificationTime fp)---- | This function removes all the -package flags which refer to packages we--- are going to deal with ourselves. For example, if a executable depends--- on a library component, then this function will remove the library flag--- from the package flags for the executable------ There are several places in GHC (for example the call to hptInstances in--- tcRnImports) which assume that all modules in the HPT have the same unit--- ID. Therefore we create a fake one and give them all the same unit id.-_removeInplacePackages --Only used in ghc < 9.4-    :: UnitId     -- ^ fake uid to use for our internal component-    -> [UnitId]-    -> DynFlags-    -> (DynFlags, [UnitId])-_removeInplacePackages fake_uid us df = (setHomeUnitId_ fake_uid $-                                       df { packageFlags = ps }, uids)-  where-    (uids, ps) = Compat.filterInplaceUnits us (packageFlags df)---- | Memoize an IO function, with the characteristics:------   * If multiple people ask for a result simultaneously, make sure you only compute it once.------   * If there are exceptions, repeatedly reraise them.------   * If the caller is aborted (async exception) finish computing it anyway.-memoIO :: Ord a => (a -> IO b) -> IO (a -> IO b)-memoIO op = do-    ref <- newVar Map.empty-    return $ \k -> join $ mask_ $ modifyVar ref $ \mp ->-        case Map.lookup k mp of-            Nothing -> do-                res <- onceFork $ op k-                return (Map.insert k res mp, res)-            Just res -> return (mp, res)--unit_flags :: [Flag (CmdLineP [String])]-unit_flags = [defFlag "unit"  (SepArg addUnit)]--addUnit :: String -> EwM (CmdLineP [String]) ()-addUnit unit_str = liftEwM $ do-  units <- getCmdLineState-  putCmdLineState (unit_str : units)---- | Throws if package flags are unsatisfiable-setOptions :: GhcMonad m-    => OptHaddockParse-    -> NormalizedFilePath-    -> ComponentOptions-    -> DynFlags-    -> FilePath -- ^ root dir, see Note [Root Directory]-    -> m (NonEmpty (DynFlags, [GHC.Target]))-setOptions haddockOpt cfp (ComponentOptions theOpts compRoot _) dflags rootDir = do-    ((theOpts',_errs,_warns),units) <- processCmdLineP unit_flags [] (map noLoc theOpts)-    case NE.nonEmpty units of-      Just us -> initMulti us-      Nothing -> do-        (df, targets) <- initOne (map unLoc theOpts')-        -- A special target for the file which caused this wonderful-        -- component to be created. In case the cradle doesn't list all the targets for-        -- the component, in which case things will be horribly broken anyway.-        ---        -- When we have a singleComponent that is caused to be loaded due to a-        -- file, we assume the file is part of that component. This is useful-        -- for bare GHC sessions, such as many of the ones used in the testsuite-        ---        -- We don't do this when we have multiple components, because each-        -- component better list all targets or there will be anarchy.-        -- It is difficult to know which component to add our file to in-        -- that case.-        -- Multi unit arguments are likely to come from cabal, which-        -- does list all targets.-        ---        -- If we don't end up with a target for the current file in the end, then-        -- we will report it as an error for that file-        let abs_fp = toAbsolute rootDir (fromNormalizedFilePath cfp)-        let special_target = Compat.mkSimpleTarget df abs_fp-        pure $ (df, special_target : targets) :| []-    where-      initMulti unitArgFiles =-        forM unitArgFiles $ \f -> do-          args <- liftIO $ expandResponse [f]-          -- The reponse files may contain arguments like "+RTS",-          -- and hie-bios doesn't expand the response files of @-unit@ arguments.-          -- Thus, we need to do the stripping here.-          initOne $ HieBios.removeRTS $ HieBios.removeVerbosityOpts args-      initOne this_opts = do-        (dflags', targets') <- addCmdOpts this_opts dflags-        let dflags'' =-                case unitIdString (homeUnitId_ dflags') of-                     -- cabal uses main for the unit id of all executable packages-                     -- This makes multi-component sessions confused about what-                     -- options to use for that component.-                     -- Solution: hash the options and use that as part of the unit id-                     -- 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)-                           hashed_uid = Compat.toUnitId (Compat.stringToUnit ("main-"++hash))-                       in setHomeUnitId_ hashed_uid dflags'-                     _ -> dflags'--        let targets = makeTargetsAbsolute root targets'-            root = case workingDirectory dflags'' of-              Nothing   -> compRoot-              Just wdir -> compRoot </> wdir-        let dflags''' =-              setWorkingDirectory root $-              disableWarningsAsErrors $-              -- disabled, generated directly by ghcide instead-              flip gopt_unset Opt_WriteInterface $-              -- disabled, generated directly by ghcide instead-              -- also, it can confuse the interface stale check-              dontWriteHieFiles $-              setIgnoreInterfacePragmas $-              setBytecodeLinkerOptions $-              enableOptHaddock haddockOpt $-              disableOptimisation $-              Compat.setUpTypedHoles $-              makeDynFlagsAbsolute compRoot -- makeDynFlagsAbsolute already accounts for workingDirectory-              dflags''-        return (dflags''', targets)--setIgnoreInterfacePragmas :: DynFlags -> DynFlags-setIgnoreInterfacePragmas df =-    gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges--disableOptimisation :: DynFlags -> DynFlags-disableOptimisation df = updOptLevel 0 df---- | We always compile with '-haddock' unless explicitly disabled.------ This avoids inconsistencies when doing recompilation checking which was--- observed in https://github.com/haskell/haskell-language-server/issues/4511-enableOptHaddock :: OptHaddockParse -> DynFlags -> DynFlags-enableOptHaddock HaddockParse d   = gopt_set d Opt_Haddock-enableOptHaddock NoHaddockParse d = d--setHiDir :: FilePath -> DynFlags -> DynFlags-setHiDir f d =-    -- override user settings to avoid conflicts leading to recompilation-    d { hiDir      = Just f}--setODir :: FilePath -> DynFlags -> DynFlags-setODir f d =-    -- override user settings to avoid conflicts leading to recompilation-    d { objectDir = Just f}--getCacheDirsDefault :: String -> [String] -> IO CacheDirs-getCacheDirsDefault prefix opts = do-    dir <- Just <$> getXdgDirectory XdgCache (cacheDir </> prefix ++ "-" ++ opts_hash)-    return $ CacheDirs dir dir dir-    where-        -- Create a unique folder per set of different GHC options, assuming that each different set of-        -- GHC options will create incompatible interface files.-        opts_hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack opts)---- | Sub directory for the cache path-cacheDir :: String-cacheDir = "ghcide"+{-# LANGUAGE TypeFamilies #-}++{-|+The logic for setting up a ghcide session by tapping into hie-bios.+-}+module Development.IDE.Session+  (SessionLoadingOptions(..)+  ,CacheDirs(..)+  ,loadSessionWithOptions+  ,getInitialGhcLibDirDefault+  ,getHieDbLoc+  ,retryOnSqliteBusy+  ,retryOnException+  ,SessionLoaderPendingBarrierVar(..)+  ,setSessionLoaderPendingBarrier+  ,clearSessionLoaderPendingBarrier+  ,Log(..)+  ,runWithDb+  ) where++-- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses+-- the real GHC library and the types are incompatible. Furthermore, when+-- building with ghc-lib we need to make this Haskell agnostic, so no hie-bios!++import           Control.Concurrent.Strict+import           Control.Exception.Safe              as Safe+import           Control.Monad+import           Control.Monad.Extra                 as Extra+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Maybe           (MaybeT (MaybeT, runMaybeT))+import qualified Crypto.Hash.SHA1                    as H+import           Data.Aeson                          hiding (Error, Key)+import qualified Data.ByteString.Base16              as B16+import qualified Data.ByteString.Char8               as B+import           Data.Default+import           Data.Hashable                       hiding (hash)+import qualified Data.HashMap.Strict                 as HM+import           Data.List+import           Data.List.Extra                     as L+import qualified Data.Map.Strict                     as Map+import           Data.Maybe+import           Data.Proxy+import qualified Data.Text                           as T+import           Data.Version+import           Development.IDE.Core.RuleTypes+import           Development.IDE.Core.Shake          hiding (Log, knownTargets,+                                                      withHieDb)+import qualified Development.IDE.GHC.Compat          as Compat+import           Development.IDE.GHC.Compat.Core     hiding (Target, TargetFile,+                                                      TargetModule, Var,+                                                      Warning, getOptions)+import           Development.IDE.GHC.Compat.Env      hiding (Logger)+import           Development.IDE.GHC.Util+import           Development.IDE.Graph               (Action, Key)+import qualified Development.IDE.Session.Implicit    as GhcIde+import           Development.IDE.Types.Diagnostics+import           Development.IDE.Types.Exports+import           Development.IDE.Types.HscEnvEq      (HscEnvEq)+import           Development.IDE.Types.Location+import           Development.IDE.Types.Options+import qualified HIE.Bios                            as HieBios+import           HIE.Bios.Environment                hiding (getCacheDir)+import           HIE.Bios.Types                      hiding (Log)+import qualified HIE.Bios.Types                      as HieBios+import           Ide.Logger                          (Pretty (pretty),+                                                      Priority (Debug, Error, Info, Warning),+                                                      Recorder, WithPriority,+                                                      cmapWithPrio, logWith,+                                                      nest,+                                                      toCologActionWithPrio,+                                                      vcat, viaShow, (<+>))+import           Ide.Types                           (Config,+                                                      SessionLoadingPreferenceConfig (..),+                                                      sessionLoading)+import           Language.LSP.Protocol.Message+import           Language.LSP.Server+import           System.Directory+import qualified System.Directory.Extra              as IO+import           System.FilePath+import           System.Info++import           Control.Applicative                 (Alternative ((<|>)))+import           Data.Void++import           Control.Concurrent.STM.Stats        (atomically, modifyTVar',+                                                      readTVar, writeTVar)+import           Control.Monad.Trans.Cont            (ContT (ContT, runContT))+import           Data.Foldable                       (for_)+import           Data.HashMap.Strict                 (HashMap)+import           Data.HashSet                        (HashSet)+import qualified Data.HashSet                        as Set+import           Database.SQLite.Simple+import           Development.IDE.Core.Tracing        (withTrace)+import           Development.IDE.Core.WorkerThread+import           Development.IDE.Session.Dependency+import           Development.IDE.Session.Diagnostics (renderCradleError)+import           Development.IDE.Session.Ghc         hiding (Log)+import           Development.IDE.Types.Shake         (WithHieDb,+                                                      WithHieDbShield (..),+                                                      toNoFileKey)+import           HieDb.Create+import           HieDb.Types+import           Ide.PluginUtils                     (toAbsolute)+import qualified System.Random                       as Random+import           System.Random                       (RandomGen)+import           Text.ParserCombinators.ReadP        (readP_to_S)++import           Control.Concurrent.STM              (STM, TVar)+import qualified Control.Monad.STM                   as STM+import           Control.Monad.Trans.Reader+import qualified Development.IDE.Session.Ghc         as Ghc+import qualified Development.IDE.Session.OrderedSet  as S+import qualified Focus+import qualified StmContainers.Map                   as STM++data Log+  = LogSettingInitialDynFlags+  | LogGetInitialGhcLibDirDefaultCradleFail !CradleError !FilePath !(Maybe FilePath) !(Cradle Void)+  | LogGetInitialGhcLibDirDefaultCradleNone+  | LogHieDbRetry !Int !Int !Int !SomeException+  | LogHieDbRetriesExhausted !Int !Int !Int !SomeException+  | LogHieDbWriterThreadSQLiteError !SQLError+  | LogHieDbWriterThreadException !SomeException+  | LogKnownFilesUpdated !(HashMap Target (HashSet NormalizedFilePath))+  | LogCradlePath !FilePath+  | LogCradleNotFound !FilePath+  | LogSessionLoadingResult !(Either [CradleError] (ComponentOptions, FilePath, String))+  | LogCradle !(Cradle Void)+  | LogNoneCradleFound FilePath+  | LogHieBios HieBios.Log+  | LogSessionLoadingChanged+  | LogSessionWorkerThread LogWorkerThread+  | LogSessionNewLoadedFiles ![FilePath]+  | LogSessionReloadOnError FilePath ![FilePath]+  | LogGetOptionsLoop !FilePath+  | LogLookupSessionCache !FilePath+  | LogTime !String+  | LogSessionGhc Ghc.Log+deriving instance Show Log++instance Pretty Log where+  pretty = \case+    LogSessionWorkerThread msg -> pretty msg+    LogTime s -> "Time:" <+> pretty s+    LogLookupSessionCache path -> "Looking up session cache for" <+> pretty path+    LogGetOptionsLoop fp -> "Loop: getOptions for" <+> pretty fp+    LogSessionReloadOnError path files ->+      "Reloading file due to error in" <+> pretty path <+> "with files:" <+> pretty files+    LogSessionNewLoadedFiles files ->+      "New loaded files:" <+> pretty files+    LogNoneCradleFound path ->+      "None cradle found for" <+> pretty path <+> ", ignoring the file"+    LogSettingInitialDynFlags ->+      "Setting initial dynflags..."+    LogGetInitialGhcLibDirDefaultCradleFail cradleError rootDirPath hieYamlPath cradle ->+      nest 2 $+        vcat+          [ "Couldn't load cradle for ghc libdir."+          , "Cradle error:" <+> viaShow cradleError+          , "Root dir path:" <+> pretty rootDirPath+          , "hie.yaml path:" <+> pretty hieYamlPath+          , "Cradle:" <+> viaShow cradle ]+    LogGetInitialGhcLibDirDefaultCradleNone ->+      "Couldn't load cradle. Cradle not found."+    LogHieDbRetry delay maxDelay retriesRemaining e ->+      nest 2 $+        vcat+          [ "Retrying hiedb action..."+          , "delay:" <+> pretty delay+          , "maximum delay:" <+> pretty maxDelay+          , "retries remaining:" <+> pretty retriesRemaining+          , "SQLite error:" <+> pretty (displayException e) ]+    LogHieDbRetriesExhausted baseDelay maxDelay retriesRemaining e ->+      nest 2 $+        vcat+          [ "Retries exhausted for hiedb action."+          , "base delay:" <+> pretty baseDelay+          , "maximum delay:" <+> pretty maxDelay+          , "retries remaining:" <+> pretty retriesRemaining+          , "Exception:" <+> pretty (displayException e) ]+    LogHieDbWriterThreadSQLiteError e ->+      nest 2 $+        vcat+          [ "HieDb writer thread SQLite error:"+          , pretty (displayException e) ]+    LogHieDbWriterThreadException e ->+      nest 2 $+        vcat+          [ "HieDb writer thread exception:"+          , pretty (displayException e) ]+    LogKnownFilesUpdated targetToPathsMap ->+      nest 2 $+        vcat+          [ "Known files updated:"+          , viaShow $ (HM.map . Set.map) fromNormalizedFilePath targetToPathsMap+          ]+    LogCradlePath path ->+      "Cradle path:" <+> pretty path+    LogCradleNotFound path ->+      vcat+        [ "No [cradle](https://github.com/mpickering/hie-bios#hie-bios) found for" <+> pretty path <> "."+        , "Proceeding with [implicit cradle](https://hackage.haskell.org/package/implicit-hie)."+        , "You should ignore this message, unless you see a 'Multi Cradle: No prefixes matched' error." ]+    LogSessionLoadingResult e ->+      "Session loading result:" <+> viaShow e+    LogCradle cradle ->+      "Cradle:" <+> viaShow cradle+    LogHieBios msg -> pretty msg+    LogSessionGhc msg -> pretty msg+    LogSessionLoadingChanged ->+      "Session Loading config changed, reloading the full session."++-- | Bump this version number when making changes to the format of the data stored in hiedb+hiedbDataVersion :: String+hiedbDataVersion = "2"++data SessionLoadingOptions = SessionLoadingOptions+  { findCradle             :: FilePath -> IO (Maybe FilePath)+  -- | Load the cradle with an optional 'hie.yaml' location.+  -- If a 'hie.yaml' is given, use it to load the cradle.+  -- Otherwise, use the provided project root directory to determine the cradle type.+  , loadCradle             :: Recorder (WithPriority Log) -> Maybe FilePath -> FilePath -> IO (HieBios.Cradle Void)+  -- | Given the project name and a set of command line flags,+  --   return the path for storing generated GHC artifacts,+  --   or 'Nothing' to respect the cradle setting+  , getCacheDirs           :: String -> Maybe B.ByteString -> [String] -> IO CacheDirs+  -- | Return the GHC lib dir to use for the 'unsafeGlobalDynFlags'+  , getInitialGhcLibDir    :: Recorder (WithPriority Log) -> FilePath -> IO (Maybe LibDir)+  }++instance Default SessionLoadingOptions where+    def =  SessionLoadingOptions+        {findCradle = HieBios.findCradle+        ,loadCradle = loadWithImplicitCradle+        ,getCacheDirs = getCacheDirsDefault+        ,getInitialGhcLibDir = getInitialGhcLibDirDefault+        }++-- | Find the cradle for a given 'hie.yaml' configuration.+--+-- If a 'hie.yaml' is given, the cradle is read from the config.+--  If this config does not comply to the "hie.yaml"+-- specification, an error is raised.+--+-- If no location for "hie.yaml" is provided, the implicit config is used+-- using the provided root directory for discovering the project.+-- The implicit config uses different heuristics to determine the type+-- of the project that may or may not be accurate.+loadWithImplicitCradle+  :: Recorder (WithPriority Log)+  -> Maybe FilePath+  -- ^ Optional 'hie.yaml' location. Will be used if given.+  -> FilePath+  -- ^ Root directory of the project. Required as a fallback+  -- if no 'hie.yaml' location is given.+  -> IO (HieBios.Cradle Void)+loadWithImplicitCradle recorder mHieYaml rootDir = do+  let logger = toCologActionWithPrio (cmapWithPrio LogHieBios recorder)+  case mHieYaml of+    Just yaml -> HieBios.loadCradle logger yaml+    Nothing   -> GhcIde.loadImplicitCradle logger rootDir++getInitialGhcLibDirDefault :: Recorder (WithPriority Log) -> FilePath -> IO (Maybe LibDir)+getInitialGhcLibDirDefault recorder rootDir = do+  hieYaml <- findCradle def (rootDir </> "a")+  cradle <- loadCradle def recorder hieYaml rootDir+  libDirRes <- getRuntimeGhcLibDir cradle+  case libDirRes of+      CradleSuccess libdir -> pure $ Just $ LibDir libdir+      CradleFail err -> do+        logWith recorder Error $ LogGetInitialGhcLibDirDefaultCradleFail err rootDir hieYaml cradle+        pure Nothing+      CradleNone -> do+        logWith recorder Warning LogGetInitialGhcLibDirDefaultCradleNone+        pure Nothing++-- | 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+-- the action again for a maximum of `maxRetryCount` times.+-- `MonadIO`, `MonadCatch` are used as constraints because there are a few+-- HieDb functions that don't return IO values.+retryOnException+  :: (MonadIO m, MonadCatch m, RandomGen g, Exception e)+  => (e -> Maybe e) -- ^ only retry on exception if this predicate returns Just+  -> Recorder (WithPriority Log)+  -> Int -- ^ maximum backoff delay in microseconds+  -> Int -- ^ base backoff delay in microseconds+  -> Int -- ^ maximum number of times to retry+  -> g -- ^ random number generator+  -> m a -- ^ action that may throw exception+  -> m a+retryOnException exceptionPred recorder maxDelay !baseDelay !maxTimesRetry rng action = do+  result <- tryJust exceptionPred action+  case result of+    Left e+      | maxTimesRetry > 0 -> do+        -- multiply by 2 because baseDelay is midpoint of uniform range+        let newBaseDelay = min maxDelay (baseDelay * 2)+        let (delay, newRng) = Random.randomR (0, newBaseDelay) rng+        let newMaxTimesRetry = maxTimesRetry - 1+        liftIO $ do+          logWith recorder Warning $ LogHieDbRetry delay maxDelay newMaxTimesRetry (toException e)+          threadDelay delay+        retryOnException exceptionPred recorder maxDelay newBaseDelay newMaxTimesRetry newRng action++      | otherwise -> do+        liftIO $ do+          logWith recorder Warning $ LogHieDbRetriesExhausted baseDelay maxDelay maxTimesRetry (toException e)+          throwIO e++    Right b -> pure b++-- | in microseconds+oneSecond :: Int+oneSecond = 1000000++-- | in microseconds+oneMillisecond :: Int+oneMillisecond = 1000++-- | default maximum number of times to retry hiedb call+maxRetryCount :: Int+maxRetryCount = 10++retryOnSqliteBusy :: (MonadIO m, MonadCatch m, RandomGen g)+                  => Recorder (WithPriority Log) -> g -> m a -> m a+retryOnSqliteBusy recorder rng action =+  let isErrorBusy e+        | SQLError{ sqlError = ErrorBusy } <- e = Just e+        | otherwise = Nothing+  in+    retryOnException isErrorBusy recorder oneSecond oneMillisecond maxRetryCount rng action++makeWithHieDbRetryable :: RandomGen g => Recorder (WithPriority Log) -> g -> HieDb -> WithHieDb+makeWithHieDbRetryable recorder rng hieDb f =+  retryOnSqliteBusy recorder rng (f hieDb)++-- | Wraps `withHieDb` to provide a database connection for reading, and a `HieWriterChan` for+-- writing. Actions are picked off one by one from the `HieWriterChan` and executed in serial+-- by a worker thread using a dedicated database connection.+-- This is done in order to serialize writes to the database, or else SQLite becomes unhappy+--+-- Also see Note [Serializing runs in separate thread]+runWithDb :: Recorder (WithPriority Log) -> FilePath -> ContT () IO (WithHieDbShield, IndexQueue)+runWithDb recorder fp = ContT $ \k -> do+  -- use non-deterministic seed because maybe multiple HLS start at same time+  -- and send bursts of requests+  rng <- Random.newStdGen+  -- Delete the database if it has an incompatible schema version+  retryOnSqliteBusy+    recorder+    rng+    (withHieDb fp (const $ pure ()) `Safe.catch` \IncompatibleSchemaVersion{} -> removeFile fp)++  withHieDb fp $ \writedb -> do+    -- the type signature is necessary to avoid concretizing the tyvar+    -- e.g. `withWriteDbRetryable initConn` without type signature will+    -- instantiate tyvar `a` to `()`+    let withWriteDbRetryable :: WithHieDb+        withWriteDbRetryable = makeWithHieDbRetryable recorder rng writedb+    withWriteDbRetryable (setupHieDb . getConn)+++    -- Clear the index of any files that might have been deleted since the last run+    _ <- withWriteDbRetryable deleteMissingRealFiles+    _ <- withWriteDbRetryable garbageCollectTypeNames++    runContT (withWorkerQueue (cmapWithPrio LogSessionWorkerThread recorder) "hiedb thread" (writer withWriteDbRetryable))+        $ \chan -> withHieDb fp (\readDb -> k (WithHieDbShield $ makeWithHieDbRetryable recorder rng readDb, chan))+  where+    writer withHieDbRetryable l = do+        -- TODO: probably should let exceptions be caught/logged/handled by top level handler+        l withHieDbRetryable+          `Safe.catch` \e@SQLError{} -> do+            logWith recorder Error $ LogHieDbWriterThreadSQLiteError e+          `Safe.catchAny` \f -> do+            logWith recorder Error $ LogHieDbWriterThreadException f+++getHieDbLoc :: FilePath -> IO FilePath+getHieDbLoc dir = do+  let db = intercalate "-" [dirHash, takeBaseName dir, Compat.ghcVersionStr, hiedbDataVersion] <.> "hiedb"+      dirHash = B.unpack $ B16.encode $ H.hash $ B.pack dir+  cDir <- IO.getXdgDirectory IO.XdgCache cacheDir+  createDirectoryIfMissing True cDir+  pure (cDir </> db)++-- Note [SessionState and batch load]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- SessionState manages the state for batch loading files in the session loader.+--+-- - When a new file needs to be loaded, it is added to the 'pendingFiles' set.+-- - The loader processes files from 'pendingFiles', attempting to load them in batches.+-- - (SBL1) If a file is already in 'failedFiles', it is loaded individually (single-file mode).+-- - (SBL2) Otherwise, the loader tries to load as many files as possible together (batch mode).+--+-- On success:+--   - (SBL3) All successfully loaded files are removed from 'pendingFiles' and 'failedFiles',+--     and added to 'loadedFiles'.+--+-- On failure:+--   - (SBL4) If loading a single file fails, it is added to 'failedFiles' and removed from 'loadedFiles' and 'pendingFiles'.+--   - (SBL5) If batch loading fails, all files attempted are added to 'failedFiles'.+--+-- This approach ensures efficient batch loading while isolating problematic files for individual handling.++-- SBL3+handleBatchLoadSuccess :: Foldable t => Recorder (WithPriority Log) -> SessionState -> Maybe FilePath -> HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo) -> t TargetDetails -> IO ()+handleBatchLoadSuccess recorder sessionState hieYaml this_flags_map all_targets =  do+  pendings <- getPendingFiles sessionState+  -- this_flags_map might contains files not in pendingFiles, take the intersection+  let newLoaded = pendings `Set.intersection` Set.fromList (fromNormalizedFilePath <$> HM.keys this_flags_map)+  atomically $ do+    STM.insert this_flags_map hieYaml (fileToFlags sessionState)+    insertAllFileMappings sessionState $ map ((hieYaml,) . fst) $ concatMap toFlagsMap all_targets+  logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoaded+  atomically $ forM_ (Set.toList newLoaded) $ flip S.delete (pendingFiles sessionState)+  mapM_ (removeErrorLoadingFile sessionState) (Set.toList newLoaded)+  addCradleFiles sessionState newLoaded++-- SBL5+handleBatchLoadFailure :: SessionState -> [FilePath] -> IO ()+handleBatchLoadFailure sessionState files = do+  mapM_ (addErrorLoadingFile sessionState) files++-- SBL4+handleSingleLoadFailure :: SessionState -> FilePath -> IO ()+handleSingleLoadFailure sessionState file = do+  addErrorLoadingFile sessionState file+  atomically $ S.delete file (pendingFiles sessionState)+  removeCradleFile sessionState file++data SessionState = SessionState+  { loadedFiles  :: !(Var (HashSet FilePath))+  -- ^ Set of files that loaded successfully+  , failedFiles  :: !(Var (HashSet FilePath))+  -- ^ Set of files that we tried to load but failed+  -- for various reasons, such as cradle load errors+  , pendingFiles :: !(S.OrderedSet FilePath)+  -- ^ Files we are currently trying to load into the HLS session.+  , hscEnvs      :: !(Var HieMap)+  -- ^ Map @hie.yaml@ location to all components that have this @hie.yaml@ as+  -- the root location.+  , fileToFlags  :: !FlagsMap+  -- ^ Map @hie.yaml@ to all modules that have this @hie.yaml@ as the root location.+  , filesMap     :: !FilesMap+  -- ^ Maps a 'NormalizedFilePath' to its @hie.yaml@, the reverse of 'fileToFlags'.+  , version      :: !(Var Int)+    -- ^ Session loading version, incremented whenever the shake cache needs to be invalidated.+  , sessionLoadingPreferenceConfig :: !(Var (Maybe SessionLoadingPreferenceConfig))+    -- ^ How do we load files? The user can choose to load multiple components at once+    -- or to load only one component after the other.+    --+    -- Changing this value invalidates the entire shake session.+  }++newtype SessionLoaderPendingBarrierVar = SessionLoaderPendingBarrierVar (TVar (Maybe Int))+instance IsIdeGlobal SessionLoaderPendingBarrierVar++setSessionLoaderPendingBarrier :: IdeState -> Int -> IO ()+setSessionLoaderPendingBarrier ideState n = do+  SessionLoaderPendingBarrierVar barrier <- getIdeGlobalState ideState+  atomically $ writeTVar barrier (Just n)++clearSessionLoaderPendingBarrier :: IdeState -> IO ()+clearSessionLoaderPendingBarrier ideState = do+  SessionLoaderPendingBarrierVar barrier <- getIdeGlobalState ideState+  atomically $ writeTVar barrier Nothing++waitForSessionLoaderPendingBarrier :: TVar (Maybe Int) -> SessionState -> IO ()+waitForSessionLoaderPendingBarrier barrier state =+  -- Block the session-loader queue until we have enqueued enough pending files.+  -- This is used by tests to enforce true batch setup before consuming pending work.+  atomically $ do+    mTarget <- readTVar barrier+    case mTarget of+      Nothing -> pure ()+      Just targetSize -> do+        pending <- S.toHashSet (pendingFiles state)+        if Set.size pending < targetSize+          then STM.retry+          else writeTVar barrier Nothing++-- | Helper functions for SessionState management+-- These functions encapsulate common operations on the SessionState++-- | Add a file to the set of files with errors during loading+addErrorLoadingFile :: MonadIO m =>  SessionState -> FilePath -> m ()+addErrorLoadingFile state file =+  liftIO $ modifyVar_' (failedFiles state) (\xs -> return $ Set.insert file xs)++-- | Remove a file from the set of files with errors during loading+removeErrorLoadingFile :: MonadIO m => SessionState -> FilePath -> m ()+removeErrorLoadingFile state file =+  liftIO $ modifyVar_' (failedFiles state) (\xs -> return $ Set.delete file xs)++addCradleFiles :: MonadIO m => SessionState -> HashSet FilePath -> m ()+addCradleFiles state files =+  liftIO $ modifyVar_' (loadedFiles state) (\xs -> return $ files <> xs)++-- | Remove a file from the cradle files set+removeCradleFile :: MonadIO m =>  SessionState -> FilePath -> m ()+removeCradleFile state file =+  liftIO $ modifyVar_' (loadedFiles state) (\xs -> return $ Set.delete file xs)++-- | Clear error loading files and reset to empty set+clearErrorLoadingFiles :: MonadIO m => SessionState -> m ()+clearErrorLoadingFiles state =+  liftIO $ modifyVar_' (failedFiles state) (const $ return Set.empty)++-- | Clear cradle files and reset to empty set+clearCradleFiles :: MonadIO m => SessionState -> m ()+clearCradleFiles state =+  liftIO $ modifyVar_' (loadedFiles state) (const $ return Set.empty)++-- | Reset the file maps in the session state+resetFileMaps :: SessionState -> STM ()+resetFileMaps state = do+  STM.reset (filesMap state)+  STM.reset (fileToFlags state)++-- | Insert or update file flags for a specific hieYaml and normalized file path+insertFileFlags :: SessionState -> Maybe FilePath -> NormalizedFilePath -> (IdeResult HscEnvEq, DependencyInfo) -> STM ()+insertFileFlags state hieYaml ncfp flags =+  STM.focus (Focus.insertOrMerge HM.union (HM.singleton ncfp flags)) hieYaml (fileToFlags state)++-- | Insert a file mapping from normalized path to hieYaml location+insertFileMapping :: SessionState -> Maybe FilePath -> NormalizedFilePath -> STM ()+insertFileMapping state hieYaml ncfp =+  STM.insert hieYaml ncfp (filesMap state)++-- | Remove a file from the pending file set+removeFromPending :: SessionState -> FilePath -> STM ()+removeFromPending state file =+  S.delete file (pendingFiles state)++-- | Add a file to the pending file set+addToPending :: SessionState -> FilePath -> STM ()+addToPending state file =+  S.insert file (pendingFiles state)++-- | Insert multiple file mappings at once+insertAllFileMappings :: SessionState -> [(Maybe FilePath, NormalizedFilePath)] -> STM ()+insertAllFileMappings state mappings =+  mapM_ (\(yaml, path) -> insertFileMapping state yaml path) mappings++-- | Increment the version counter+incrementVersion :: SessionState -> IO Int+incrementVersion state = modifyVar' (version state) succ++-- | Get files from the pending file set+getPendingFiles :: SessionState -> IO (HashSet FilePath)+getPendingFiles state = atomically $ S.toHashSet (pendingFiles state)++-- | Handle errors during session loading by recording file as having error and removing from pending+handleSingleFileProcessingError' :: SessionState -> Maybe FilePath -> FilePath -> PackageSetupException -> SessionM ()+handleSingleFileProcessingError' state hieYaml file e = do+  handleSingleFileProcessingError state hieYaml file [renderPackageSetupException file e] mempty++-- | Common pattern: Insert file flags, insert file mapping, and remove from pending+handleSingleFileProcessingError :: SessionState -> Maybe FilePath -> FilePath -> [FileDiagnostic] -> [FilePath] -> SessionM ()+handleSingleFileProcessingError state hieYaml file diags extraDepFiles = liftIO $ do+  dep <- getDependencyInfo $ maybeToList hieYaml <> extraDepFiles+  let ncfp = toNormalizedFilePath' file+  let flags = ((diags, Nothing), dep)+  handleSingleLoadFailure state file+  atomically $ do+    insertFileFlags state hieYaml ncfp flags+    insertFileMapping state hieYaml ncfp++-- | Get the set of extra files to load based on the current file path.+--+-- If the current file is in error loading files, we fallback to single loading mode (empty set)+-- Otherwise, we remove error files from pending files and also exclude the current file+getExtraFilesToLoad :: SessionState -> FilePath -> IO [FilePath]+getExtraFilesToLoad state cfp = do+  pendingFiles <- getPendingFiles state+  errorFiles <- readVar (failedFiles state)+  old_files <- readVar (loadedFiles state)+  -- if the file is in error loading files, we fall back to single loading mode+  return $+    Set.toList $+      if cfp `Set.member` errorFiles+        then Set.empty+        -- remove error files from pending files since error loading need to load one by one+        else (Set.delete cfp $ pendingFiles `Set.difference` errorFiles) <> old_files++-- | We allow users to specify a loading strategy.+-- Check whether this config was changed since the last time we have loaded+-- a session.+--+-- If the loading configuration changed, we likely should restart the session+-- in its entirety.+didSessionLoadingPreferenceConfigChange :: SessionState -> SessionM Bool+didSessionLoadingPreferenceConfigChange s = do+    clientConfig <- asks sessionClientConfig+    let biosSessionLoadingVar = sessionLoadingPreferenceConfig s+    mLoadingConfig <- liftIO $ readVar biosSessionLoadingVar+    case mLoadingConfig of+        Nothing -> do+            liftIO $ writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig))+            pure False+        Just loadingConfig -> do+            liftIO $ writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig))+            pure (loadingConfig /= sessionLoading clientConfig)++newSessionState :: IO SessionState+newSessionState = do+  -- Initialize SessionState+  sessionState <- SessionState+    <$> newVar (Set.fromList [])  -- loadedFiles+    <*> newVar (Set.fromList [])  -- failedFiles+    <*> S.newIO                     -- pendingFiles+    <*> newVar Map.empty            -- hscEnvs+    <*> STM.newIO                   -- fileToFlags+    <*> STM.newIO                   -- filesMap+    <*> newVar 0                    -- version+    <*> newVar Nothing              -- sessionLoadingPreferenceConfig+  return sessionState++-- | Given a root directory, return a Shake 'Action' which setups an+-- 'IdeGhcSession' given a file.+-- Some of the many things this does:+--+-- * Find the cradle for the file+-- * Get the session options,+-- * Get the GHC lib directory+-- * Make sure the GHC compiletime and runtime versions match+-- * Restart the Shake session+--+-- This is the key function which implements multi-component support. All+-- components mapping to the same hie.yaml file are mapped to the same+-- HscEnv which is updated as new components are discovered.++loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> TaskQueue (IO ()) -> IO (Action IdeGhcSession)+loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do+  let toAbsolutePath = toAbsolute rootDir -- see Note [Root Directory]++  sessionState <- newSessionState+  let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar (version sessionState))++  -- This caches the mapping from Mod.hs -> hie.yaml+  cradleLoc <- liftIO $ memoIO $ \v -> do+      res <- findCradle v+      -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path+      -- try and normalise that+      -- e.g. see https://github.com/haskell/ghcide/issues/126+      let res' = toAbsolutePath <$> res+      return $ normalise <$> res'++  return $ do+    clientConfig <- getClientConfigAction+    extras@ShakeExtras{ideNc, knownTargetsVar+                      } <- getShakeExtras+    let invalidateShakeCache = do+            void $ incrementVersion sessionState+            return $ toNoFileKey GhcSessionIO++    ideOptions <- getIdeOptions+    SessionLoaderPendingBarrierVar pendingBarrier <- getIdeGlobalAction++    -- see Note [Serializing runs in separate thread]+    -- Start the 'getOptionsLoop' if the queue is empty+    liftIO $ atomically $+      Extra.whenM (isEmptyTaskQueue que) $ do+        let newSessionLoadingOptions = SessionLoadingOptions+              { findCradle = cradleLoc+              , ..+              }+            sessionShake = SessionShake+              { restartSession = restartShakeSession extras+              , invalidateCache = invalidateShakeCache+              , enqueueActions = shakeEnqueue extras+              }+            sessionEnv = SessionEnv+              { sessionLspContext = lspEnv extras+              , sessionRootDir = rootDir+              , sessionIdeOptions = ideOptions+              , sessionPendingBarrier = pendingBarrier+              , sessionClientConfig = clientConfig+              , sessionSharedNameCache = ideNc+              , sessionLoadingOptions = newSessionLoadingOptions+              }++        writeTaskQueue que (runReaderT (getOptionsLoop recorder sessionShake sessionState knownTargetsVar) sessionEnv)++    -- Each one of deps will be registered as a FileSystemWatcher in the GhcSession action+    -- so that we can get a workspace/didChangeWatchedFiles notification when a dep changes.+    -- The GlobPattern of a FileSystemWatcher can be absolute or relative.+    -- We use the absolute one because it is supported by more LSP clients.+    -- Here we make sure deps are absolute and later we use those absolute deps as GlobPattern.+    let absolutePathsCradleDeps (eq, deps) = (eq, fmap toAbsolutePath $ Map.keys deps)+    returnWithVersion $ \file -> do+      let absFile = toAbsolutePath file+      absolutePathsCradleDeps <$> lookupOrWaitCache recorder sessionState absFile++-- | Given a file, this function will return the HscEnv and the dependencies+-- it would look up the cache first, if the cache is not available, it would+-- submit a request to the getOptionsLoop to get the options for the file+-- and wait until the options are available+lookupOrWaitCache :: Recorder (WithPriority Log) -> SessionState -> FilePath -> IO (IdeResult HscEnvEq, DependencyInfo)+lookupOrWaitCache recorder sessionState absFile = do+  let ncfp = toNormalizedFilePath' absFile+  cacheResult <- maybeM+    (return Nothing)+    (guardedA (checkDependencyInfo . snd))+    (atomically $ do+      -- wait until target file is not in pendingFiles+      Extra.whenM (S.lookup absFile (pendingFiles sessionState)) STM.retry+      -- check if in the cache+      checkInCache sessionState ncfp)+++  logWith recorder Debug $ LogLookupSessionCache absFile++  case cacheResult of+    Just r -> return r+    Nothing -> do+      -- if not ok, we need to reload the session+      atomically $ addToPending sessionState absFile+      lookupOrWaitCache recorder sessionState absFile++checkInCache :: SessionState -> NormalizedFilePath -> STM (Maybe (IdeResult HscEnvEq, DependencyInfo))+checkInCache sessionState ncfp = runMaybeT $ do+  cachedHieYamlLocation <- MaybeT $ STM.lookup ncfp (filesMap sessionState)+  m <- MaybeT $ STM.lookup cachedHieYamlLocation (fileToFlags sessionState)+  MaybeT $ pure $ HM.lookup ncfp m++-- | Modify the shake state.+data SessionShake = SessionShake+  { restartSession :: VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO ()+  , invalidateCache :: IO Key+  , enqueueActions :: DelayedAction () -> IO (IO ())+  }++-- | Read-only data that the initialisation logic needs access to.+data SessionEnv = SessionEnv+  { sessionLspContext      :: Maybe (LanguageContextEnv Config)+  , sessionRootDir         :: FilePath+  , sessionIdeOptions      :: IdeOptions+  , sessionPendingBarrier  :: TVar (Maybe Int)+  , sessionClientConfig    :: Config+  , sessionSharedNameCache :: NameCache+  , sessionLoadingOptions  :: SessionLoadingOptions+  }++type SessionM = ReaderT SessionEnv IO++-- | The main function which gets options for a file.+--+-- The general approach is as follows:+-- 1. Find the 'hie.yaml' for the next file target, if there is any.+-- 2. Check in the cache, whether the given 'hie.yaml' was already loaded before+-- 3.1. If it wasn't, initialise a new session and continue with step 4.+-- 3.2. If it is loaded, check whether we need to reload the session, e.g. because the `.cabal` file was modified+-- 3.2.1. If we need to reload, remove the+--+-- See Note [SessionState and batch load] for an overview of the strategy.+getOptionsLoop :: Recorder (WithPriority Log) -> SessionShake -> SessionState -> TVar (Hashed KnownTargets) -> SessionM ()+getOptionsLoop recorder sessionShake sessionState knownTargetsVar = forever $ do+  pendingBarrier <- asks sessionPendingBarrier+  IdeTesting isTestMode <- asks (optTesting . sessionIdeOptions)+  when isTestMode $+    liftIO $ waitForSessionLoaderPendingBarrier pendingBarrier sessionState++  -- Get the next file to load+  file <- liftIO $ atomically $ S.readQueue (pendingFiles sessionState)+  logWith recorder Debug (LogGetOptionsLoop file)++  hieLoc <- findHieYamlForTarget (filesMap sessionState) file+  sessionOpts recorder sessionShake sessionState knownTargetsVar (hieLoc, file)+    `Safe.catch` handleSingleFileProcessingError' sessionState hieLoc file++findHieYamlForTarget :: FilesMap -> FilePath -> SessionM (Maybe FilePath)+findHieYamlForTarget filesMapping file = do+  let ncfp = toNormalizedFilePath' file+  cachedHieYamlLocation <- join <$> liftIO (atomically (STM.lookup ncfp filesMapping))+  sessionLoadingOptions <- asks sessionLoadingOptions+  hieYaml <- liftIO $ findCradle sessionLoadingOptions file+  pure $ cachedHieYamlLocation <|> hieYaml++-- | This caches the mapping from hie.yaml + Mod.hs -> [String]+-- Returns the Ghc session and the cradle dependencies+sessionOpts :: Recorder (WithPriority Log) -> SessionShake -> SessionState -> TVar (Hashed KnownTargets) -> (Maybe FilePath, FilePath) -> SessionM ()+sessionOpts recorder sessionShake sessionState knownTargetsVar (hieYaml, file) = do+  Extra.whenM (didSessionLoadingPreferenceConfigChange sessionState) $ do+    logWith recorder Info LogSessionLoadingChanged+    liftIO $ atomically $ resetFileMaps sessionState+    -- Don't even keep the name cache, we start from scratch here!+    liftIO $ modifyVar_ (hscEnvs sessionState) (const (return Map.empty))+    -- cleanup error loading files and cradle files+    clearErrorLoadingFiles sessionState+    clearCradleFiles sessionState+    cacheKey <- liftIO $ invalidateCache sessionShake+    liftIO $ restartSession sessionShake VFSUnmodified "didSessionLoadingPreferenceConfigChange" [] (return [cacheKey])++  v <- liftIO $ atomically $ STM.lookup hieYaml (fileToFlags sessionState)+  case v >>= HM.lookup (toNormalizedFilePath' file) of+    Just (_opts, old_di) -> do+      deps_ok <- liftIO $ checkDependencyInfo old_di+      if not deps_ok+        then do+          -- if deps are old, we can try to load the error files again+          removeErrorLoadingFile sessionState file+          removeCradleFile sessionState file+          -- If the dependencies are out of date then clear both caches and start+          -- again.+          liftIO $ atomically $ resetFileMaps sessionState+          -- Keep the same name cache+          liftIO $ modifyVar_ (hscEnvs sessionState) (return . Map.adjust (const []) hieYaml)+          -- This file needs to be reloaded!+          consultCradle recorder sessionShake sessionState knownTargetsVar hieYaml file+        else do+          -- If deps are ok, we can just remove the file from pending files.+          -- This unblocks the STM waiting in 'lookupOrWaitCache'.+          liftIO $ atomically $ removeFromPending sessionState file+    Nothing ->+        -- This file has never been loaded before, so actually load it now!+        consultCradle recorder sessionShake sessionState knownTargetsVar hieYaml file++consultCradle :: Recorder (WithPriority Log) -> SessionShake -> SessionState -> TVar (Hashed KnownTargets) -> Maybe FilePath -> FilePath -> SessionM ()+consultCradle recorder sessionShake sessionState knownTargetsVar hieYaml cfp = do+  (cradle, eopts) <- loadCradleWithNotifications recorder sessionState hieYaml cfp++  logWith recorder Debug $ LogSessionLoadingResult eopts+  let ncfp = toNormalizedFilePath' cfp+  case eopts of+    -- The cradle gave us some options so get to work turning them+    -- into and HscEnv.+    Right (opts, libDir, version) -> do+      let compileTime = fullCompilerVersion+      case reverse $ readP_to_S parseVersion version of+        [] -> error $ "GHC version could not be parsed: " <> version+        ((runTime, _):_)+          | compileTime == runTime -> session recorder sessionShake sessionState knownTargetsVar (hieYaml, ncfp, opts, libDir)+          | otherwise -> handleSingleFileProcessingError' sessionState hieYaml cfp (GhcVersionMismatch{..})+    -- Failure case, either a cradle error or the none cradle+    Left err -> do+        -- what if the error to load file is one of old_files ?+        let attemptToLoadFiles = Set.delete cfp $ Set.fromList $ concatMap cradleErrorLoadingFiles err+        old_files <- liftIO $ readVar (loadedFiles sessionState)+        let errorToLoadNewFiles = cfp : Set.toList (attemptToLoadFiles `Set.difference` old_files)+        if length errorToLoadNewFiles > 1+        then do+            -- We tried loading multiple files, but some failed to load!+            -- Unfortunately, 'hie-bios' is an all-or-nothing kind of deal,+            -- and we don't know whether some of the files could have been loaded,+            -- or none of them have been!+            -- To work around this, we try to remove the failing targets from the set of extra targets,+            -- to still get a fast reload.+            --+            -- How do we do this? We mark all of the extra target files as files that failed to+            -- to load and retry to load the original target.+            -- We decide the extra targets in 'getExtraFilesToLoad', which takes the+            -- set of failed targets into account.+            liftIO $ handleBatchLoadFailure sessionState errorToLoadNewFiles+            -- retry without other files+            logWith recorder Info $ LogSessionReloadOnError cfp (Set.toList attemptToLoadFiles)+            consultCradle recorder sessionShake sessionState knownTargetsVar hieYaml cfp+        else do+            -- We are only loading this file and it failed, so we definitely know,+            -- we can't load it.+            -- Add it to the list of permanently failed to load targets and do not retry!+            let res = map (\err' -> renderCradleError err' cradle ncfp) err+            handleSingleFileProcessingError sessionState hieYaml cfp res $ concatMap cradleErrorDependencies err++-- | Set up the GHC session for the new 'ComponentOptions' we have discovered.+--+-- The units found in these 'ComponentOptions' are merged with the set of existing home units,+-- replacing the older home unit with the new ones.+-- We update the GHC session to use a multiple home unit session, and restart the shake session accordingly.+session ::+    Recorder (WithPriority Log) ->+    SessionShake ->+    SessionState ->+    TVar (Hashed KnownTargets) ->+    (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) ->+    SessionM ()+session recorder sessionShake sessionState knownTargetsVar(hieYaml, cfp, opts, libDir) = do+  let initEmptyHscEnv = emptyHscEnvM libDir+  (new_components_info, old_components_info) <- packageSetup recorder sessionState initEmptyHscEnv (hieYaml, cfp, opts)++  -- For each component, now make a new HscEnvEq which contains the+  -- HscEnv for the hie.yaml file but the DynFlags for that component+  -- For GHC's supporting multi component sessions, we create a shared+  -- HscEnv but set the active component accordingly+  hscEnv <- initEmptyHscEnv+  ideOptions <- asks sessionIdeOptions+  let new_cache = newComponentCache (cmapWithPrio LogSessionGhc recorder) (optExtensions ideOptions) cfp hscEnv+  all_target_details <- liftIO $ new_cache old_components_info new_components_info+  (all_targets, this_flags_map) <- liftIO $ addErrorTargetIfUnknown all_target_details hieYaml cfp+  -- The VFS doesn't change on cradle edits, re-use the old one.+  -- Invalidate all the existing GhcSession build nodes by restarting the Shake session+  liftIO $ do+    checkProject <- optCheckProject ideOptions+    restartSession sessionShake VFSUnmodified "new component" [] $ do+        -- It is necessary to call 'handleBatchLoadSuccess' in restartSession+        -- to ensure the GhcSession rule does not return before a new session is started.+        -- Otherwise, invalid compilation results may propagate to downstream rules,+        -- potentially resulting in lost diagnostics and other issues.+        handleBatchLoadSuccess recorder sessionState hieYaml this_flags_map all_targets+        keys2 <- invalidateCache sessionShake+        keys1 <- extendKnownTargets recorder knownTargetsVar all_targets+        -- Typecheck all files in the project on startup+        unless (null new_components_info || not checkProject) $ do+            cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations all_targets)+            void $ enqueueActions sessionShake $ mkDelayedAction "InitialLoad" Debug $ void $ do+                mmt <- uses GetModificationTime cfps'+                let cs_exist = catMaybes (zipWith (<$) cfps' mmt)+                modIfaces <- uses GetModIface cs_exist+                -- update exports map+                shakeExtras <- getShakeExtras+                let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces+                liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>)+        return [keys1, keys2]++-- | Create a new HscEnv from a hieYaml root and a set of options+packageSetup :: Recorder (WithPriority Log) -> SessionState -> SessionM HscEnv -> (Maybe FilePath, NormalizedFilePath, ComponentOptions) -> SessionM ([ComponentInfo], [ComponentInfo])+packageSetup recorder sessionState newEmptyHscEnv (hieYaml, cfp, opts) = do+  getCacheDirs <- asks (getCacheDirs . sessionLoadingOptions)+  haddockparse <- asks (optHaddockParse . sessionIdeOptions)+  rootDir <- asks sessionRootDir+  -- Parse DynFlags for the newly discovered component+  hscEnv <- newEmptyHscEnv+  newTargetDfs <- liftIO $ evalGhcEnv hscEnv $ setOptions haddockparse cfp opts (hsc_dflags hscEnv) rootDir+  let deps = componentDependencies opts ++ maybeToList hieYaml+  dep_info <- liftIO $ getDependencyInfo (fmap (toAbsolute rootDir) deps)+  -- Now lookup to see whether we are combining with an existing HscEnv+  -- or making a new one. The lookup returns the HscEnv and a list of+  -- information about other components loaded into the HscEnv+  -- (unitId, DynFlag, Targets)+  liftIO $ modifyVar (hscEnvs sessionState) $+    addComponentInfo (cmapWithPrio LogSessionGhc recorder) getCacheDirs dep_info newTargetDfs (hieYaml, cfp, opts)++addErrorTargetIfUnknown :: Foldable t => t [TargetDetails] -> Maybe FilePath -> NormalizedFilePath -> IO ([TargetDetails], HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo))+addErrorTargetIfUnknown all_target_details hieYaml cfp = do+  let flags_map' = HM.fromList (concatMap toFlagsMap all_targets')+      all_targets' = concat all_target_details+  this_dep_info <- getDependencyInfo $ maybeToList hieYaml+  let (all_targets, this_flags_map) = case HM.lookup cfp flags_map' of+        Just _ -> (all_targets', flags_map')+        Nothing -> (this_target_details : all_targets', HM.insert cfp this_flags flags_map')+          where+                this_target_details = TargetDetails (TargetFile cfp) this_error_env this_dep_info [cfp]+                this_flags = (this_error_env, this_dep_info)+                this_error_env = ([this_error], Nothing)+                this_error = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) cfp+                                (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+  pure (all_targets, this_flags_map)++-- | Populate the knownTargetsVar with all the+-- files in the project so that `knownFiles` can learn about them and+-- we can generate a complete module graph+extendKnownTargets :: Recorder (WithPriority Log) -> TVar (Hashed KnownTargets) -> [TargetDetails] -> IO Key+extendKnownTargets recorder knownTargetsVar newTargets = do+  knownTargets <- concatForM  newTargets $ \TargetDetails{..} ->+    case targetTarget of+      TargetFile f -> do+        -- If a target file has multiple possible locations, then we+        -- assume they are all separate file targets.+        -- This happens with '.hs-boot' files if they are in the root directory of the project.+        -- GHC reports options such as '-i. A' as 'TargetFile A.hs' instead of 'TargetModule A'.+        -- In 'fromTargetId', we dutifully look for '.hs-boot' files and add them to the+        -- targetLocations of the TargetDetails. Then we add everything to the 'knownTargetsVar'.+        -- However, when we look for a 'Foo.hs-boot' file in 'FindImports.hs', we look for either+        --+        --  * TargetFile Foo.hs-boot+        --  * TargetModule Foo+        --+        -- If we don't generate a TargetFile for each potential location, we will only have+        -- 'TargetFile Foo.hs' in the 'knownTargetsVar', thus not find 'TargetFile Foo.hs-boot'+        -- and also not find 'TargetModule Foo'.+        fs <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations+        pure $ map (\fp -> (TargetFile fp, Set.singleton fp)) (nubOrd (f:fs))+      TargetModule _ -> do+        found <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations+        return [(targetTarget, Set.fromList found)]+  hasUpdate <- atomically $ do+    known <- readTVar knownTargetsVar+    let known' = flip mapHashed known $ \k -> unionKnownTargets k (mkKnownTargets knownTargets)+        hasUpdate = if known /= known' then Just (unhashed known') else Nothing+    writeTVar knownTargetsVar known'+    pure hasUpdate+  for_ hasUpdate $ \x ->+    logWith recorder Debug $ LogKnownFilesUpdated (targetMap x)+  return $ toNoFileKey GetKnownTargets+++loadCradleWithNotifications ::+  Recorder (WithPriority Log) ->+  SessionState ->+  Maybe FilePath ->+  FilePath ->+  SessionM (Cradle Void, Either [CradleError] (ComponentOptions, FilePath, String))+loadCradleWithNotifications recorder sessionState hieYaml cfp = do+  rootDir <- asks sessionRootDir+  let lfpLog = makeRelative rootDir cfp+  logWith recorder Info $ LogCradlePath lfpLog+  when (isNothing hieYaml) $+    logWith recorder Warning $ LogCradleNotFound lfpLog++  -- Find the 'Cradle' for the target+  loadingOptions <- asks sessionLoadingOptions+  cradle <- liftIO $ loadCradle loadingOptions recorder hieYaml rootDir++  -- Test notification for better observability.+  IdeTesting isTesting <- asks (optTesting . sessionIdeOptions)+  lspEnv <- asks sessionLspContext+  when isTesting $ mRunLspT lspEnv $+    sendNotification (SMethod_CustomMethod (Proxy @"ghcide/cradle/loaded")) (toJSON cfp)++  -- Display a user friendly progress message here: They probably don't know what a cradle is+  let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle))+                <> " (for " <> T.pack lfpLog <> ")"++  sessionPref <- asks (sessionLoading . sessionClientConfig)+  extraToLoads <- liftIO $ getExtraFilesToLoad sessionState cfp+  -- Start loading the file!+  eopts <- mRunLspTCallback lspEnv (\act -> withIndefiniteProgress progMsg Nothing NotCancellable (const act)) $+    withTrace "Load cradle" $ \addTag -> do+        addTag "file" lfpLog+        res <- liftIO $ cradleToOptsAndLibDir recorder sessionPref cradle cfp extraToLoads+        addTag "result" (show res)+        return res+  pure (cradle, eopts)+++-- | Run the specific cradle on a specific FilePath via hie-bios.+-- This then builds dependencies or whatever based on the cradle, gets the+-- GHC options/dynflags needed for the session and the GHC library directory+cradleToOptsAndLibDir :: Recorder (WithPriority Log) -> SessionLoadingPreferenceConfig -> Cradle Void -> FilePath -> [FilePath]+                      -> IO (Either [CradleError] (ComponentOptions, FilePath, String))+cradleToOptsAndLibDir recorder loadConfig cradle file old_fps = do+    -- let noneCradleFoundMessage :: FilePath -> T.Text+    --     noneCradleFoundMessage f = T.pack $ "none cradle found for " <> f <> ", ignoring the file"+    -- Start off by getting the session options+    logWith recorder Debug $ LogCradle cradle+    cradleRes <- HieBios.getCompilerOptions file loadStyle cradle+    case cradleRes of+        CradleSuccess r -> do+            -- Now get the GHC lib dir+            libDirRes <- getRuntimeGhcLibDir cradle+            versionRes <- getRuntimeGhcVersion cradle+            case liftA2 (,) libDirRes versionRes of+                -- This is the successful path+                (CradleSuccess (libDir, version)) -> pure (Right (r, libDir, version))+                CradleFail err       -> return (Left [err])+                CradleNone           -> do+                    logWith recorder Info $ LogNoneCradleFound file+                    return (Left [])++        CradleFail err -> return (Left [err])+        CradleNone -> do+            logWith recorder Info $ LogNoneCradleFound file+            return (Left [])++    where+        loadStyle = case loadConfig of+            PreferSingleComponentLoading -> LoadFile+            PreferMultiComponentLoading  -> LoadWithContext old_fps++-- ----------------------------------------------------------------------------+-- Utilities+-- ----------------------------------------------------------------------------++emptyHscEnvM :: FilePath -> SessionM HscEnv+emptyHscEnvM libDir = do+  nc <- asks sessionSharedNameCache+  liftIO $ Ghc.emptyHscEnv nc libDir++toFlagsMap :: TargetDetails -> [(NormalizedFilePath, (IdeResult HscEnvEq, DependencyInfo))]+toFlagsMap TargetDetails{..} =+    [ (l, (targetEnv, targetDepends)) | l <-  targetLocations]++-- | Mapping from @hie.yaml@ to all components that have been loaded+-- from this @hie.yaml@ location.+--+-- See Note [Multi Cradle Dependency Info]+type HieMap = Map.Map (Maybe FilePath) [RawComponentInfo]++-- | Maps a @hie.yaml@ location to all its Target Filepaths and options.+-- Reverse of 'FilesMap'.+type FlagsMap = STM.Map (Maybe FilePath) (HM.HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo))+-- | Maps a Filepath to its respective @hie.yaml@ location.+-- It aims to be the reverse of 'FlagsMap'.+type FilesMap = STM.Map NormalizedFilePath (Maybe FilePath)++-- | Memoize an IO function, with the characteristics:+--+--   * If multiple people ask for a result simultaneously, make sure you only compute it once.+--+--   * If there are exceptions, repeatedly reraise them.+--+--   * If the caller is aborted (async exception) finish computing it anyway.+memoIO :: Ord a => (a -> IO b) -> IO (a -> IO b)+memoIO op = do+    ref <- newVar Map.empty+    return $ \k -> join $ mask_ $ modifyVar ref $ \mp ->+        case Map.lookup k mp of+            Nothing -> do+                res <- onceFork $ op k+                return (Map.insert k res mp, res)+            Just res -> return (mp, res)  ---------------------------------------------------------------------------------------------------- 

@@ -0,0 +1,35 @@+module Development.IDE.Session.Dependency where++import           Control.Exception.Safe as Safe+import           Data.Either.Extra+import qualified Data.Map.Strict        as Map+import           Data.Time.Clock+import           System.Directory++type DependencyInfo = Map.Map FilePath (Maybe UTCTime)++-- | Check if any dependency has been modified lately.+checkDependencyInfo :: DependencyInfo -> IO Bool+checkDependencyInfo old_di = do+  di <- getDependencyInfo (Map.keys old_di)+  return (di == old_di)++-- Note [Multi Cradle Dependency Info]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Why do we implement our own file modification tracking here?+-- The primary reason is that the custom caching logic is quite complicated and going into shake+-- adds even more complexity and more indirection. I did try for about 5 hours to work out how to+-- use shake rules rather than IO but eventually gave up.++-- | Computes a mapping from a filepath to its latest modification date.+-- See Note [Multi Cradle Dependency Info] why we do this ourselves instead+-- of letting shake take care of it.+getDependencyInfo :: [FilePath] -> IO DependencyInfo+getDependencyInfo fs = Map.fromList <$> mapM do_one fs++  where+    safeTryIO :: IO a -> IO (Either IOException a)+    safeTryIO = Safe.try++    do_one :: FilePath -> IO (FilePath, Maybe UTCTime)+    do_one fp = (fp,) . eitherToMaybe <$> safeTryIO (getModificationTime fp)

@@ -18,11 +18,24 @@  data CradleErrorDetails =   CradleErrorDetails-    { cabalProjectFiles :: [FilePath]+    { cradleDependencies    :: [FilePath]     -- ^ files related to the cradle error     -- i.e. .cabal, cabal.project, etc.+    , structuredCradleError :: Maybe StructuredCradleError+    -- ^ structured information about the cradle error+    -- i.e. unknownModules error     } deriving (Show, Eq, Ord, Read, Generic, Aeson.ToJSON, Aeson.FromJSON) +data StructuredCradleError+  = UnknownModuleError UnknownModuleDetails+  deriving (Show, Eq, Ord, Read, Generic, Aeson.ToJSON, Aeson.FromJSON)++data UnknownModuleDetails =+  UnknownModuleDetails+    { moduleFilePath      :: FilePath+    , suggestedModuleName :: String+    } deriving (Show, Eq, Ord, Read, Generic, Aeson.ToJSON, Aeson.FromJSON)+ {- | Takes a cradle error, the corresponding cradle and the file path where   the cradle error occurred (of the file we attempted to load).   Depicts the cradle error in a user-friendly way.@@ -33,7 +46,12 @@         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}}+     then noDetails & fdLspDiagnosticL %~ \diag -> diag+            { _data_ = Just $ Aeson.toJSON CradleErrorDetails+                { cradleDependencies = absDeps+                , structuredCradleError = fmap UnknownModuleError mkUnknownModuleDetails+                }+            }      else noDetails   where     ms = cradleErrorStderr cradleError@@ -41,13 +59,18 @@     absDeps = fmap (cradleRootDir cradle </>) (cradleErrorDependencies cradleError)     userFriendlyMessage :: [String]     userFriendlyMessage-      | HieBios.isCabalCradle cradle = fromMaybe ms $ fileMissingMessage <|> mkUnknownModuleMessage+      | HieBios.isCabalCradle cradle = fromMaybe ms $ fileMissingMessage <|> (unknownModuleMessage (fromNormalizedFilePath nfp) <$ mkUnknownModuleDetails)       | otherwise = ms -    mkUnknownModuleMessage :: Maybe [String]-    mkUnknownModuleMessage+    -- Produce structured details when unknown module error is detected+    mkUnknownModuleDetails :: Maybe UnknownModuleDetails+    mkUnknownModuleDetails       | any (isInfixOf "Failed extracting script block:") ms =-          Just $ unknownModuleMessage (fromNormalizedFilePath nfp)+          let fp = fromNormalizedFilePath nfp+          in Just UnknownModuleDetails+               { moduleFilePath   = fp+               , suggestedModuleName = dropExtension (takeFileName fp)+               }       | otherwise = Nothing      fileMissingMessage :: Maybe [String]

@@ -0,0 +1,578 @@+{-# LANGUAGE CPP #-}+module Development.IDE.Session.Ghc where++import           Control.Monad+import           Control.Monad.Extra                as Extra+import           Control.Monad.IO.Class+import qualified Crypto.Hash.SHA1                   as H+import qualified Data.ByteString.Base16             as B16+import qualified Data.ByteString.Char8              as B+import           Data.Function+import           Data.List+import           Data.List.Extra                    as L+import           Data.List.NonEmpty                 (NonEmpty (..))+import qualified Data.List.NonEmpty                 as NE+import qualified Data.Map.Strict                    as Map+import           Data.Maybe+import qualified Data.Text                          as T+import           Development.IDE.Core.Shake         hiding (Log, knownTargets,+                                                     withHieDb)+import qualified Development.IDE.GHC.Compat         as Compat+import           Development.IDE.GHC.Compat.CmdLine+import           Development.IDE.GHC.Compat.Core    hiding (Target, TargetFile,+                                                     TargetModule, Var, Warning,+                                                     getOptions)+import qualified Development.IDE.GHC.Compat.Core    as GHC+import           Development.IDE.GHC.Compat.Env     hiding (Logger)+import           Development.IDE.GHC.Compat.Units   (UnitId)+import           Development.IDE.GHC.Util+import           Development.IDE.Types.Diagnostics+import           Development.IDE.Types.HscEnvEq     (HscEnvEq, newHscEnvEq)+import           Development.IDE.Types.Location+import           GHC.ResponseFile+import qualified HIE.Bios.Cradle.Utils              as HieBios+import           HIE.Bios.Environment               hiding (getCacheDir)+import           HIE.Bios.Types                     hiding (Log)+import           Ide.Logger                         (Pretty (pretty),+                                                     Priority (Debug, Error, Info),+                                                     Recorder, WithPriority,+                                                     logWith, viaShow, (<+>))+import           System.Directory+import           System.FilePath+import           System.Info+++import           Control.DeepSeq+import           Control.Exception                  (evaluate)+import           Control.Monad.IO.Unlift            (MonadUnliftIO)+import qualified Data.Set                           as OS+import qualified Development.IDE.GHC.Compat.Util    as Compat+import           Development.IDE.Session.Dependency+import           Development.IDE.Types.Options+import           GHC.Data.Graph.Directed+import           Ide.PluginUtils                    (toAbsolute)++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+  = LogInterfaceFilesCacheDir !FilePath+  | LogMakingNewHscEnv ![UnitId]+  | LogNewComponentCache !(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)+  | LogDLLLoadError !String+deriving instance Show Log++instance Pretty Log where+  pretty = \case+    LogInterfaceFilesCacheDir path ->+      "Interface files cache directory:" <+> pretty path+    LogMakingNewHscEnv inPlaceUnitIds ->+      "Making new HscEnv. In-place unit ids:" <+> pretty (map show inPlaceUnitIds)+    LogNewComponentCache componentCache ->+      "New component cache HscEnvEq:" <+> viaShow componentCache+    LogDLLLoadError errorString ->+      "Error dynamically loading libm.so.6:" <+> pretty errorString+-- | Configuration info for a particular home unit.+data HomeUnitConfig = HomeUnitConfig+  {+  -- | The dynamic flags to compile this specific unit.+    homeUnitDynFlags :: DynFlags+  -- | All the targets for this unit.+  , homeUnitTargets  :: [GHC.Target]+  -- | Optional hash seed to differentiate home units+  -- with same `-this-unit-id`. Used when `-this-unit-id` is "main",+  -- which is common when loading a single target.+  , homeUnitHash     :: Maybe B.ByteString+  }+-- This is pristine information about a component+data RawComponentInfo = RawComponentInfo+  { rawComponentUnitId         :: UnitId+  -- | Unprocessed DynFlags. Contains inplace packages such as libraries.+  -- We do not want to use them unprocessed.+  , rawComponentDynFlags       :: DynFlags+  -- | All targets of this components.+  , rawComponentTargets        :: [GHC.Target]+  -- | Filepath which caused the creation of this component+  , rawComponentFP             :: NormalizedFilePath+  -- | Component Options used to load the component.+  , rawComponentCOptions       :: ComponentOptions+  -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file+  -- to last modification time. See Note [Multi Cradle Dependency Info].+  , rawComponentDependencyInfo :: DependencyInfo+  -- | An optional hash seed generated in 'setOptions' for the unit id "main".+  , rawComponentHash           :: Maybe B.ByteString+  }++-- This is processed information about the component, in particular the dynflags will be modified.+data ComponentInfo = ComponentInfo+  { componentUnitId         :: UnitId+  -- | Processed DynFlags. Does not contain inplace packages such as local+  -- libraries. Can be used to actually load this Component.+  , componentDynFlags       :: DynFlags+  -- | All targets of this components.+  , componentTargets        :: [GHC.Target]+  -- | Filepath which caused the creation of this component+  , componentFP             :: NormalizedFilePath+  -- | Component Options used to load the component.+  , componentCOptions       :: ComponentOptions+  -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file+  -- to last modification time. See Note [Multi Cradle Dependency Info]+  , componentDependencyInfo :: DependencyInfo+  }+++unit_flags :: [Flag (CmdLineP [String])]+unit_flags = [defFlag "unit"  (SepArg addUnit)]++addUnit :: String -> EwM (CmdLineP [String]) ()+addUnit unit_str = liftEwM $ do+  units <- getCmdLineState+  putCmdLineState (unit_str : units)+++-- | Create a mapping from FilePaths to HscEnvEqs+-- This combines all the components we know about into+-- an appropriate session, which is a multi component+-- session on GHC 9.4++newComponentCache+         :: Recorder (WithPriority Log)+         -> [String]           -- ^ File extensions to consider+         -> 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+         -> IO [ [TargetDetails] ]+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.+        -- However, we might have added some targets to the old unit+        -- (see special target), so preserve those+        unionCIs new_ci old_ci = new_ci { componentTargets = componentTargets new_ci ++ componentTargets old_ci }+        mkMap = Map.fromListWith unionCIs . map (\ci -> (componentUnitId ci, ci))+    let dfs = map componentDynFlags $ Map.elems cis+        uids = Map.keys cis+    logWith recorder Info $ LogMakingNewHscEnv uids+    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,13,0)+    let closure_errs_raw = checkHomeUnitsClosed' (hsc_unit_env hscEnv') (hsc_all_home_unit_ids hscEnv')+        closure_errs = concatMap (Compat.bagToList . Compat.getMessages) closure_errs_raw+#else+    let closure_errs = maybeToList $ checkHomeUnitsClosed' (hsc_unit_env hscEnv') (hsc_all_home_unit_ids hscEnv')+#endif+        closure_err_to_multi_err err =+            ideErrorWithSource+                (Just "cradle") (Just DiagnosticSeverity_Warning) _cfp+                (T.pack (Compat.printWithoutUniques (singleMessage err)))+                (Just (fmap GhcDriverMessage err))+        multi_errs = map closure_err_to_multi_err closure_errs+        bad_units = OS.fromList $ concat $ do+            x <- map errMsgDiagnostic closure_errs+            DriverHomePackagesNotClosed us <- pure x+            pure us+        isBad ci = (homeUnitId_ (componentDynFlags ci)) `OS.member` bad_units+    -- Whenever we spin up a session on Linux, dynamically load libm.so.6+    -- in. We need this in case the binary is statically linked, in which+    -- case the interactive session will fail when trying to load+    -- ghc-prim, which happens whenever Template Haskell is being+    -- evaluated or haskell-language-server's eval plugin tries to run+    -- some code. If the binary is dynamically linked, then this will have+    -- no effect.+    -- See https://github.com/haskell/haskell-language-server/issues/221+    -- We need to do this after the call to setSessionDynFlags initialises+    -- the loader+    when (os == "linux") $ do+      initObjLinker hscEnv'+      res <- loadDLL hscEnv' "libm.so.6"+      case res of+        Nothing  -> pure ()+        Just err -> logWith recorder Error $ LogDLLLoadError err++    forM (Map.elems cis) $ \ci -> do+      let df = componentDynFlags ci+      thisEnv <- do+            -- 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'+      henv <- newHscEnvEq thisEnv+      let targetEnv = (if isBad ci then multi_errs else [], Just henv)+          targetDepends = componentDependencyInfo ci+      logWith recorder Debug $ LogNewComponentCache (targetEnv, targetDepends)+      evaluate $ liftRnf rwhnf $ componentTargets ci++      let mk t = fromTargetId (importPaths df) exts (targetId t) targetEnv targetDepends+      ctargets <- concatMapM mk (componentTargets ci)++      return (L.nubOrdOn targetTarget ctargets)++-- | Throws if package flags are unsatisfiable+setOptions :: GhcMonad m+    => OptHaddockParse+    -> NormalizedFilePath+    -> ComponentOptions+    -> DynFlags+    -> FilePath -- ^ root dir, see Note [Root Directory]+    -> m (NonEmpty HomeUnitConfig)+setOptions haddockOpt cfp (ComponentOptions theOpts compRoot _) dflags rootDir = do+    ((theOpts',_errs,_warns),units) <- processCmdLineP unit_flags [] (map noLoc theOpts)+    case NE.nonEmpty units of+      Just us -> initMulti us+      Nothing -> do+        (HomeUnitConfig df targets mHash) <- initOne (map unLoc theOpts')+        -- A special target for the file which caused this wonderful+        -- component to be created. In case the cradle doesn't list all the targets for+        -- the component, in which case things will be horribly broken anyway.+        --+        -- When we have a singleComponent that is caused to be loaded due to a+        -- file, we assume the file is part of that component. This is useful+        -- for bare GHC sessions, such as many of the ones used in the testsuite+        --+        -- We don't do this when we have multiple components, because each+        -- component better list all targets or there will be anarchy.+        -- It is difficult to know which component to add our file to in+        -- that case.+        -- Multi unit arguments are likely to come from cabal, which+        -- does list all targets.+        --+        -- If we don't end up with a target for the current file in the end, then+        -- we will report it as an error for that file+        let abs_fp = toAbsolute rootDir (fromNormalizedFilePath cfp)+        let special_target = Compat.mkSimpleTarget df abs_fp+        pure $ HomeUnitConfig df (special_target : targets) mHash :| []+    where+      initMulti unitArgFiles =+        forM unitArgFiles $ \f -> do+          args <- liftIO $ expandResponse [f]+          -- The reponse files may contain arguments like "+RTS",+          -- and hie-bios doesn't expand the response files of @-unit@ arguments.+          -- Thus, we need to do the stripping here.+          initOne $ HieBios.removeRTS $ HieBios.removeVerbosityOpts args+      initOne this_opts = do+        (dflags', targets') <- addCmdOpts this_opts dflags+        let (dflags'',mHash) =+                case unitIdString (homeUnitId_ dflags') of+                     -- cabal uses main for the unit id of all executable packages+                     -- This makes multi-component sessions confused about what+                     -- options to use for that component.+                     -- Solution: hash the options and use that as part of the unit id+                     -- This works because there won't be any dependencies on the+                     -- executable unit.+                     "main" ->+                       let hashBytes =H.finalize $ H.updates H.init (map B.pack this_opts)+                           hash =  B.unpack $ B16.encode hashBytes+                           hashed_uid = Compat.toUnitId (Compat.stringToUnit ("main-"++hash))+                       in (setHomeUnitId_ hashed_uid dflags', Just hashBytes)+                     _ -> (dflags', Nothing)++        let targets = makeTargetsAbsolute root targets'+            root = case workingDirectory dflags'' of+              Nothing   -> compRoot+              Just wdir -> compRoot </> wdir+        let dflags''' =+              setWorkingDirectory root $+              disableWarningsAsErrors $+              -- disabled, generated directly by ghcide instead+              flip gopt_unset Opt_WriteInterface $+              -- disabled, generated directly by ghcide instead+              -- also, it can confuse the interface stale check+              dontWriteHieFiles $+              setIgnoreInterfacePragmas $+              setBytecodeLinkerOptions $+              enableOptHaddock haddockOpt $+              disableOptimisation $+              Compat.setUpTypedHoles $+              makeDynFlagsAbsolute compRoot -- makeDynFlagsAbsolute already accounts for workingDirectory+              dflags''+        return (HomeUnitConfig dflags''' targets mHash)++addComponentInfo ::+  MonadUnliftIO m =>+  Recorder (WithPriority Log) ->+  (String -> Maybe B.ByteString -> [String] -> IO CacheDirs) ->+  DependencyInfo ->+  NonEmpty HomeUnitConfig->+  (Maybe FilePath, NormalizedFilePath, ComponentOptions) ->+  Map.Map (Maybe FilePath) [RawComponentInfo] ->+  m (Map.Map (Maybe FilePath) [RawComponentInfo], ([ComponentInfo], [ComponentInfo]))+addComponentInfo recorder getCacheDirs dep_info newDynFlags (hieYaml, cfp, opts) m = do+  -- Just deps if there's already an HscEnv+  -- Nothing is it's the first time we are making an HscEnv+  let oldDeps = Map.lookup hieYaml m+  let -- Add the raw information about this component to the list+      -- We will modify the unitId and DynFlags used for+      -- compilation but these are the true source of+      -- information.+      new_deps = fmap (\(HomeUnitConfig df targets mHash) -> RawComponentInfo (homeUnitId_ df) df targets cfp opts dep_info mHash) newDynFlags+      all_deps = new_deps `NE.appendList` fromMaybe [] oldDeps+      -- Get all the unit-ids for things in this component++  all_deps' <- forM all_deps $ \RawComponentInfo{..} -> do+    let prefix = show rawComponentUnitId+    -- See Note [Avoiding bad interface files]+    let cacheDirOpts = componentOptions opts+    cacheDirs <- liftIO $ getCacheDirs prefix rawComponentHash cacheDirOpts+    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+      , componentTargets = rawComponentTargets+      , componentFP = rawComponentFP+      , componentCOptions = rawComponentCOptions+      , componentDependencyInfo = rawComponentDependencyInfo+      }+  -- Modify the map so the hieYaml now maps to the newly updated+  -- ComponentInfos+  -- Returns+  -- . The information for the new component which caused this cache miss+  -- . The modified information (without -inplace flags) for+  --   existing packages+  let (new,old) = NE.splitAt (NE.length new_deps) all_deps'+  pure (Map.insert hieYaml (NE.toList all_deps) m, (new,old))++setIgnoreInterfacePragmas :: DynFlags -> DynFlags+setIgnoreInterfacePragmas df =+    gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges++disableOptimisation :: DynFlags -> DynFlags+disableOptimisation df = updOptLevel 0 df++-- | We always compile with '-haddock' unless explicitly disabled.+--+-- This avoids inconsistencies when doing recompilation checking which was+-- observed in https://github.com/haskell/haskell-language-server/issues/4511+enableOptHaddock :: OptHaddockParse -> DynFlags -> DynFlags+enableOptHaddock HaddockParse d   = gopt_set d Opt_Haddock+enableOptHaddock NoHaddockParse d = d++setHiDir :: FilePath -> DynFlags -> DynFlags+setHiDir f d =+    -- override user settings to avoid conflicts leading to recompilation+    d { hiDir      = Just f}++setODir :: FilePath -> DynFlags -> DynFlags+setODir f d =+    -- override user settings to avoid conflicts leading to recompilation+    d { objectDir = Just f}++data CacheDirs = CacheDirs+  { hiCacheDir, hieCacheDir, oCacheDir :: Maybe FilePath}++{- Note [Avoiding bad interface files]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Originally, we set the cache directory for the various components once+on the first occurrence of the component.+This works fine if these components have no references to each other,+but you have components that depend on each other, the interface files are+updated for each component.+After restarting the session and only opening the component that depended+on the other, suddenly the interface files of this component are stale.+However, from the point of view of `ghcide`, they do not look stale,+thus, not regenerated and the IDE shows weird errors such as:+```+typecheckIface+Declaration for Rep_ClientRunFlags+Axiom branches Rep_ClientRunFlags:+  Failed to load interface for ‘Distribution.Simple.Flag’+  Use -v to see a list of the files searched for.+```+and+```+expectJust checkFamInstConsistency+CallStack (from HasCallStack):+  error, called at compiler\\utils\\Maybes.hs:55:27 in ghc:Maybes+  expectJust, called at compiler\\typecheck\\FamInst.hs:461:30 in ghc:FamInst+```++and many more.++To mitigate this, we set the cache directory for each component dependent+on the components of the current `HscEnv`, additionally to the component options+of the respective components.+Assume two components, c1, c2, where c2 depends on c1, and the options of the+respective components are co1, co2.+If we want to load component c2, followed by c1, we set the cache directory for+each component in this way:++  * Load component c2+    * (Cache Directory State)+        - name of c2 + co2+  * Load component c1+    * (Cache Directory State)+        - name of c2 + name of c1 + co2+        - name of c2 + name of c1 + co1++Overall, we created three cache directories. If we opened c1 first, then we+create a fourth cache directory.+This makes sure that interface files are always correctly updated.++Since this causes a lot of recompilation, we only update the cache-directory,+if the dependencies of a component have really changed.+E.g. when you load two executables, they can not depend on each other. They+should be filtered out, such that we dont have to re-compile everything.+-}+++-- | Set the cache-directory based on the ComponentOptions and a list of+-- internal packages.+-- For the exact reason, see Note [Avoiding bad interface files].+setCacheDirs :: MonadUnliftIO m => Recorder (WithPriority Log) -> CacheDirs -> DynFlags -> m DynFlags+setCacheDirs recorder CacheDirs{..} dflags = do+    logWith recorder Info $ LogInterfaceFilesCacheDir (fromMaybe cacheDir hiCacheDir)+    pure $ dflags+          & maybe id setHiDir hiCacheDir+          & maybe id setHieDir hieCacheDir+          & maybe id setODir oCacheDir++-- | Append the hash to the unit id to create unique cache folders.+--+-- This function generates a single, unified hash.+-- If an optional base hash (@mFirstHash@) is provided—which+-- is common for a single target with `-this-unit-id` as "main"-+-- we set the prefix to "main", extract the context generated+-- from the @mFirstHash@, and update the @opts@ into the same hash.+--+-- This guarantees a unique cache folder for different GHC+-- options(avoiding incompatible interface files) while+-- keeping the path short and clean.+getCacheDirsDefault :: String -> Maybe B.ByteString -> [String] -> IO CacheDirs+getCacheDirsDefault prefix mFirstHash opts = do+    dir <- Just <$> getXdgDirectory XdgCache (cacheDir </> prefix' ++ "-" ++ opts_hash)+    return $ CacheDirs dir dir dir+    where+        -- Create a unique folder per set of different GHC options.+        prefix' = if isJust mFirstHash then "main" else prefix+        basectx = case mFirstHash of+          Just h  -> H.updates H.init [h]+          Nothing -> H.init+        opts_hash = B.unpack $ B16.encode $ H.finalize $ H.updates basectx (map B.pack opts)++setNameCache :: NameCache -> HscEnv -> HscEnv+setNameCache nc hsc = hsc { hsc_NC = nc }++-- | Sub directory for the cache path+cacheDir :: String+cacheDir = "ghcide"++emptyHscEnv :: NameCache -> FilePath -> IO HscEnv+emptyHscEnv nc libDir = do+    -- We call setSessionDynFlags so that the loader is initialised+    -- We need to do this before we call initUnits.+    env <- liftIO $ runGhc (Just libDir) $+      getSessionDynFlags >>= setSessionDynFlags >> getSession+    pure $ setNameCache nc (hscSetFlags ((hsc_dflags env){useUnicode = True }) env)++-- ----------------------------------------------------------------------------+-- Target Details+-- ----------------------------------------------------------------------------++data TargetDetails = TargetDetails+  {+      targetTarget    :: !Target,+      targetEnv       :: !(IdeResult HscEnvEq),+      targetDepends   :: !DependencyInfo,+      targetLocations :: ![NormalizedFilePath]+  }++fromTargetId :: [FilePath]          -- ^ import paths+             -> [String]            -- ^ extensions to consider+             -> TargetId+             -> IdeResult HscEnvEq+             -> DependencyInfo+             -> IO [TargetDetails]+-- For a target module we consider all the import paths+fromTargetId is exts (GHC.TargetModule modName) env dep = do+    let fps = [i </> moduleNameSlashes modName -<.> ext <> boot+              | ext <- exts+              , i <- is+              , boot <- ["", "-boot"]+              ]+    let locs = fmap toNormalizedFilePath' fps+    return [TargetDetails (TargetModule modName) env dep locs]+-- For a 'TargetFile' we consider all the possible module names+fromTargetId _ _ (GHC.TargetFile f _) env deps = do+    let nf = toNormalizedFilePath' f+    let other+          | "-boot" `isSuffixOf` f = toNormalizedFilePath' (L.dropEnd 5 $ fromNormalizedFilePath nf)+          | otherwise = toNormalizedFilePath' (fromNormalizedFilePath nf ++ "-boot")+    return [TargetDetails (TargetFile nf) env deps [nf, other]]++-- ----------------------------------------------------------------------------+-- Backwards compatibility+-- ----------------------------------------------------------------------------++#if MIN_VERSION_ghc(9,13,0)+-- Moved back to implementation in GHC.+checkHomeUnitsClosed' ::  UnitEnv -> OS.Set UnitId -> [DriverMessages]+checkHomeUnitsClosed' ue _ = checkHomeUnitsClosed ue+#else+-- 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 -> Maybe (Compat.MsgEnvelope DriverMessage)+checkHomeUnitsClosed' ue home_id_set+    | 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>")++    graph :: Graph (Node UnitId UnitId)+    graph = graphFromEdgedVerticesUniq graphNodes++    -- downwards closure of graph+    downwards_closure+      = graphFromEdgedVerticesUniq [ DigraphNode uid uid (OS.toList deps)+                                   | (uid, deps) <- Map.toList (allReachable graph node_key)]++    inverse_closure = transposeG downwards_closure++    upwards_closure = OS.fromList $ map node_key $ reachablesG inverse_closure [DigraphNode uid uid [] | uid <- OS.toList home_id_set]++    all_unit_direct_deps :: UniqMap UnitId (OS.Set UnitId)+    all_unit_direct_deps+      = unitEnv_foldWithKey go emptyUniqMap $ ue_home_unit_graph ue+      where+        go rest this this_uis =+           plusUniqMap_C OS.union+             (addToUniqMap_C OS.union external_depends this (OS.fromList this_deps))+             rest+           where+             external_depends = mapUniqMap (OS.fromList . unitDepends)+#if !MIN_VERSION_ghc(9,7,0)+                              $ listToUniqMap $ Map.toList+#endif++                              $ unitInfoMap this_units+             this_units = homeUnitEnv_units this_uis+             this_deps = [ Compat.toUnitId unit | (unit,Just _) <- explicitUnits this_units]++    graphNodes :: [Node UnitId UnitId]+    graphNodes = go OS.empty home_id_set+      where+        go done todo+          = case OS.minView todo of+              Nothing -> []+              Just (uid, todo')+                | OS.member uid done -> go done todo'+                | otherwise -> case lookupUniqMap all_unit_direct_deps uid of+                    Nothing -> pprPanic "uid not found" (Compat.ppr (uid, all_unit_direct_deps))+                    Just depends ->+                      let todo'' = (depends OS.\\ done) `OS.union` todo'+                      in DigraphNode uid uid (OS.toList depends) : go (OS.insert uid done) todo''+#endif

@@ -0,0 +1,54 @@+module Development.IDE.Session.OrderedSet where++import           Control.Concurrent.STM        (STM, TQueue, newTQueueIO)+import           Control.Concurrent.STM.TQueue (readTQueue, writeTQueue)+import           Control.Monad                 (when)+import           Data.Hashable                 (Hashable)+import qualified Data.HashSet+import qualified Focus+import qualified ListT                         as LT+import qualified StmContainers.Set             as S+import           StmContainers.Set             (Set)+++data OrderedSet a = OrderedSet+  { insertionOrder :: TQueue a+  , elements       :: Set a+  }++-- | Insert an element into the ordered set.+-- If the element is not already present, it is added to both the queue and set.+-- If the element already exists, ignore it+insert :: Hashable a => a -> OrderedSet a -> STM ()+insert a (OrderedSet que s) = do+    (_, inserted) <- S.focus (Focus.testingIfInserts $ Focus.insert ()) a s+    -- if already in the set+    when inserted $ writeTQueue que a++newIO :: Hashable a => IO (OrderedSet a)+newIO = do+    que <- newTQueueIO+    s <- S.newIO+    return (OrderedSet que s)++-- | Read the first element from the queue.+-- If an element is not in the set, it means it has been deleted,+-- so we retry until we find a valid element that exists in the set.+readQueue :: Hashable a => OrderedSet a -> STM a+readQueue rs@(OrderedSet que s) = do+                f <- readTQueue que+                b <- S.lookup f s+                -- retry if no files are left in the queue+                if b then return f else readQueue rs++lookup :: Hashable a => a -> OrderedSet a -> STM Bool+lookup a (OrderedSet _ s) = S.lookup a s++-- | Delete an element from the set.+-- The queue is not modified directly; stale entries are filtered out lazily+-- during reading operations (see 'readQueue').+delete :: Hashable a => a -> OrderedSet a -> STM ()+delete a (OrderedSet _ s) = S.delete a s++toHashSet :: Hashable a => OrderedSet a -> STM (Data.HashSet.HashSet a)+toHashSet (OrderedSet _ s) = Data.HashSet.fromList <$> LT.toList (S.listT s)

@@ -24,6 +24,8 @@ import           Development.IDE.Core.RuleTypes import           Development.IDE.Core.Service import           Development.IDE.Core.Shake+import           Development.IDE.GHC.Compat           (DynFlags (..),+                                                       ms_hspp_opts) import           Development.IDE.Graph import qualified Development.IDE.Spans.AtPoint        as AtPoint import           Development.IDE.Types.HscEnvEq       (hscEnv)@@ -52,12 +54,14 @@   shakeExtras <- lift askShake    env <- hscEnv . fst <$> useWithStaleFastMT GhcSession file+  modSummary <- fst <$> useWithStaleFastMT GetModSummary file   dkMap <- lift $ maybe (DKMap mempty mempty mempty) fst <$> runMaybeT (useWithStaleFastMT GetDocMap file)+  let enabledExtensions = extensionFlags (ms_hspp_opts (msrModSummary modSummary))    !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)    MaybeT $ liftIO $ fmap (first (toCurrentRange mapping =<<)) <$>-    AtPoint.atPoint opts shakeExtras hf dkMap env pos'+    AtPoint.atPoint opts shakeExtras hf dkMap env pos' enabledExtensions  -- | Converts locations in the source code to their current positions, -- taking into account changes that may have occurred due to edits.

@@ -75,6 +75,7 @@ import           Development.IDE.Core.ProgressReporting       (progressUpdate) import           Development.IDE.Core.RuleTypes import           Development.IDE.Core.Shake+import           Development.IDE.Core.WorkerThread            (writeTaskQueue) import           Development.IDE.Core.Tracing                 (withTrace) import qualified Development.IDE.GHC.Compat                   as Compat import qualified Development.IDE.GHC.Compat                   as GHC@@ -155,7 +156,7 @@ import           GHC.Unit.Home.PackageTable                   (hptInternalTableRef, hptInternalTableFromRef) import           GHC.Unit.Module.ModIface                     (IfaceTopEnv(..)) import           GHC.Types.Avail                              (emptyDetOrdAvails)-import           GHC.Types.Basic                              (ImportLevel(..))+import           GHC.Types.Basic                              (ImportLevel(..), convImportLevel) #endif  #if MIN_VERSION_ghc(9,12,0)@@ -941,7 +942,7 @@       -- hiedb doesn't use the Haskell src, so we clear it to avoid unnecessarily keeping it around       let !hf' = hf{hie_hs_src = mempty}       modifyTVar' indexPending $ HashMap.insert srcPath hash-      writeTQueue indexQueue $ \withHieDb -> do+      writeTaskQueue indexQueue $ \withHieDb -> do         -- We are now in the worker thread         -- Check if a newer index of this file has been scheduled, and if so skip this one         newerScheduled <- atomically $ do@@ -1171,13 +1172,10 @@ getModSummaryFromImports   :: HscEnv   -> FilePath-  -> UTCTime   -> Maybe Util.StringBuffer   -> ExceptT [FileDiagnostic] IO ModSummaryResult--- modTime is only used in GHC < 9.4-getModSummaryFromImports env fp _modTime mContents = do--- src_hash is only used in GHC >= 9.4-    (contents, opts, ppEnv, _src_hash) <- preprocessor env fp mContents+getModSummaryFromImports env fp mContents = do+    (contents, opts, ppEnv, src_hash) <- preprocessor env fp mContents      let dflags = hsc_dflags ppEnv @@ -1193,8 +1191,7 @@         (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource.unLoc) imps          -- GHC.Prim doesn't exist physically, so don't go looking for it.-        -- ghc_prim_imports is only used in GHC >= 9.4-        (ordinary_imps, _ghc_prim_imports)+        (ordinary_imps, ghc_prim_imports)           = partition ((/= moduleName gHC_PRIM) . unLoc                       . ideclName . unLoc)                       ord_idecls@@ -1215,12 +1212,24 @@ #if MIN_VERSION_ghc(9,13,0)         -- In GHC 9.13+, ms_srcimps is just [Located ModuleName] and ms_textual_imps includes ImportLevel         srcImports = map snd $ rn_imps $ map convImport src_idecls-        textualImports = map (\(pk, lmn) -> (NormalLevel, pk, lmn)) $ rn_imps $ map convImport (implicit_imports ++ ordinary_imps)++        -- Extract import level along with pkg qualifier and module name+        convImportWithLevel (L _ i) = (convImportLevel (ideclLevelSpec i)+                                      , ideclPkgQual i+                                      , reLoc $ ideclName i)++        -- Rename package qualifiers while preserving import levels+        rn_imps_with_level = fmap (\(lvl, pk, lmn@(L _ mn)) -> (lvl, rn_pkg_qual mn pk, lmn))++        -- Implicit imports (prelude) are always NormalLevel;+        -- explicit user imports preserve their declared level+        textualImports = map (\(pk, lmn) -> (NormalLevel, pk, lmn)) (rn_imps $ map convImport implicit_imports)+                      ++ rn_imps_with_level (map convImportWithLevel ordinary_imps) #else         srcImports = rn_imps $ map convImport src_idecls         textualImports = rn_imps $ map convImport (implicit_imports ++ ordinary_imps) #endif-        ghc_prim_import = not (null _ghc_prim_imports)+        ghc_prim_import = not (null ghc_prim_imports)       -- Force bits that might keep the string buffer and DynFlags alive unnecessarily@@ -1240,11 +1249,11 @@             ModSummary                 { ms_mod          = modl                 , ms_hie_date     = Nothing-                , ms_dyn_obj_date    = Nothing+                , ms_dyn_obj_date = Nothing #if !MIN_VERSION_ghc(9,13,0)                 , ms_ghc_prim_import = ghc_prim_import #endif-                , ms_hs_hash      = _src_hash+                , ms_hs_hash      = src_hash                  , ms_hsc_src      = sourceType                 -- The contents are used by the GetModSummary rule@@ -1515,36 +1524,21 @@ loadInterface session ms linkableNeeded RecompilationInfo{..} = do     let sessionWithMsDynFlags = hscSetFlags (ms_hspp_opts ms) session         mb_old_iface = hirModIface . fst <$> old_value-        mb_old_version = snd <$> old_value          core_file = ml_core_file (ms_location ms)         iface_file = ml_hi_file (ms_location ms)          !mod = ms_mod ms -    mb_dest_version <- case mb_old_version of-      Just ver -> pure $ Just ver-      Nothing  -> get_file_version (toNormalizedFilePath' iface_file)--    -- The source is modified if it is newer than the destination (iface file)-    -- A more precise check for the core file is performed later-    let _sourceMod = case mb_dest_version of -- sourceMod is only used in GHC < 9.4-          Nothing -> SourceModified -- destination file doesn't exist, assume modified source-          Just dest_version-            | source_version <= dest_version -> SourceUnmodified-            | otherwise -> SourceModified--    -- old_iface is only used in GHC >= 9.4-    _old_iface <- case mb_old_iface of+    old_iface <- case mb_old_iface of       Just iface -> pure (Just iface)       Nothing -> do-        -- ncu and read_dflags are only used in GHC >= 9.4-        let _ncu = hsc_NC sessionWithMsDynFlags-            _read_dflags = hsc_dflags sessionWithMsDynFlags+        let ncu = hsc_NC sessionWithMsDynFlags+            read_dflags = hsc_dflags sessionWithMsDynFlags #if MIN_VERSION_ghc(9,13,0)-        read_result <- liftIO $ readIface (hsc_hooks sessionWithMsDynFlags) (hsc_logger sessionWithMsDynFlags) _read_dflags _ncu mod iface_file+        read_result <- liftIO $ readIface (hsc_hooks sessionWithMsDynFlags) (hsc_logger sessionWithMsDynFlags) read_dflags ncu mod iface_file #else-        read_result <- liftIO $ readIface _read_dflags _ncu mod iface_file+        read_result <- liftIO $ readIface read_dflags ncu mod iface_file #endif         case read_result of           Util.Failed{}        -> return Nothing@@ -1555,7 +1549,7 @@     -- 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)-      <- liftIO $ checkOldIface sessionWithMsDynFlags ms _old_iface >>= \case+      <- liftIO $ checkOldIface sessionWithMsDynFlags ms old_iface >>= \case         UpToDateItem x -> pure (UpToDate, Just x)         OutOfDateItem reason x -> pure (NeedsRecompile reason, x) 

@@ -25,7 +25,6 @@     ) where  import           Control.Concurrent.STM.Stats                 (STM, atomically)-import           Control.Concurrent.STM.TQueue                (writeTQueue) import           Control.Exception import           Control.Lens                                 ((^.)) import           Control.Monad.Extra@@ -45,6 +44,7 @@ import           Development.IDE.Core.RuleTypes import           Development.IDE.Core.Shake                   hiding (Log) import qualified Development.IDE.Core.Shake                   as Shake+import           Development.IDE.Core.WorkerThread import           Development.IDE.GHC.Orphans                  () import           Development.IDE.Graph import           Development.IDE.Import.DependencyInformation@@ -252,8 +252,8 @@     maybe (pure Nothing) getVirtualFile $         uriToNormalizedFilePath $ toNormalizedUri uri   let ver = case mvf of-        Just (VirtualFile lspver _ _) -> lspver-        Nothing                       -> 0+        Just (VirtualFile lspver _ _ _) -> lspver+        Nothing                         -> 0   return (VersionedTextDocumentIdentifier uri ver)  fileStoreRules :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules ()@@ -304,7 +304,7 @@ setSomethingModified :: VFSModified -> IdeState -> String -> IO [Key] -> IO () setSomethingModified vfs state reason actionBetweenSession = do     -- Update database to remove any files that might have been renamed/deleted-    atomically $ writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles)+    atomically $ writeTaskQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles)     void $ restartShakeSession (shakeExtras state) vfs reason [] actionBetweenSession  registerFileWatches :: [String] -> LSP.LspT Config IO Bool

@@ -27,18 +27,18 @@ -- * Diagnostics , activeDiagnosticsInRange , activeDiagnosticsInRangeMT+, injectServerDiagnostics -- * Formatting handlers , mkFormattingHandlers) where  import           Control.Concurrent.STM-import           Control.Lens                         ((^.))+import           Control.Lens import           Control.Monad.Error.Class            (MonadError (throwError)) import           Control.Monad.Extra import           Control.Monad.IO.Class import           Control.Monad.Reader                 (runReaderT) import           Control.Monad.Trans.Except 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@@ -60,6 +60,7 @@ import           Ide.Types import qualified Language.LSP.Protocol.Lens           as LSP import           Language.LSP.Protocol.Message        (SMethod (..))+import           Language.LSP.Protocol.Types          (CodeActionParams) import qualified Language.LSP.Protocol.Types          as LSP import qualified StmContainers.Map                    as STM @@ -222,6 +223,18 @@ -- | 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)++-- Prefer server-side diagnostics if available; they are authoritative.+injectServerDiagnostics :: IdeState -> CodeActionParams -> IO CodeActionParams+injectServerDiagnostics ide params@LSP.CodeActionParams{_textDocument=LSP.TextDocumentIdentifier{_uri}, _range} = do+  serverDiags <- case LSP.uriToNormalizedFilePath (LSP.toNormalizedUri _uri) of+    Nothing  -> pure []+    Just nfp -> do+      mDiags <- activeDiagnosticsInRange (shakeExtras ide) nfp _range+      case mDiags of+        Nothing    -> pure []+        Just diags -> pure $ diags ^.. traverse . fdLspDiagnosticL+  pure $ params & LSP.context . LSP.diagnostics .~ serverDiags  -- ---------------------------------------------------------------------------- -- Formatting handlers

@@ -25,8 +25,7 @@ import           Data.Time.Clock.POSIX import           Data.Typeable import           Development.IDE.GHC.Compat                   hiding-                                                              (HieFileResult,-                                                               assert)+                                                              (HieFileResult) import           Development.IDE.GHC.Compat.Util import           Development.IDE.GHC.CoreFile import           Development.IDE.GHC.Util

@@ -86,7 +86,7 @@ import qualified Data.IntMap.Strict                           as IntMap import           Data.IORef import           Data.List-import           Data.List.Extra                              (nubOrdOn)+import           Data.List.Extra                              (nubOrd, nubOrdOn) import qualified Data.Map                                     as M import           Data.Maybe import           Data.Proxy@@ -101,7 +101,6 @@ 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,@@ -143,7 +142,10 @@ import qualified GHC.LanguageExtensions                       as LangExt #if MIN_VERSION_ghc(9,13,0) import           GHC.Types.PkgQual                            (PkgQual (NoPkgQual))-import           GHC.Types.Basic                              (ImportLevel (NormalLevel))+import           GHC.Types.Basic                              (ImportLevel (..))+import           GHC.Unit.Types                               (GenWithIsBoot(..))+import           GHC.Unit.Module.Graph                        (mkModuleEdge)+import           GHC.Unit.Module.ModNodeKey                   (mnkModuleName) #endif import           HIE.Bios.Ghc.Gap                             (hostIsDynamic) import qualified HieDb@@ -164,7 +166,7 @@                                                                useProperty,                                                                usePropertyByPath) import           Ide.Types                                    (DynFlagsModifications (dynFlagsModifyGlobal, dynFlagsModifyParser),-                                                               PluginId)+                                                               PluginId, getVirtualFileFromVFS) import qualified Language.LSP.Protocol.Lens                   as JL import           Language.LSP.Protocol.Message                (SMethod (SMethod_CustomMethod, SMethod_WindowShowMessage)) import           Language.LSP.Protocol.Types                  (MessageType (MessageType_Info),@@ -318,7 +320,7 @@ getLocatedImportsRule recorder =     define (cmapWithPrio LogShake recorder) $ \GetLocatedImports file -> do         ModSummaryResult{msrModSummary = ms} <- use_ GetModSummaryWithoutTimestamps file-        (KnownTargets targets targetsMap) <- useNoFile_ GetKnownTargets+        (KnownTargets targets) <- useNoFile_ GetKnownTargets #if MIN_VERSION_ghc(9,13,0)         let imports = [(False, lvl, mbPkgName, modName) | (lvl, mbPkgName, modName) <- ms_textual_imps ms]                    ++ [(True, NormalLevel, NoPkgQual, noLoc modName) | L _ modName <- ms_srcimps ms]@@ -331,14 +333,13 @@         let dflags = hsc_dflags env         opt <- getIdeOptions         let getTargetFor modName nfp-                | Just (TargetFile nfp') <- HM.lookup (TargetFile nfp) targetsMap = do+                | Just (TargetFile nfp') <- HM.lookupKey (TargetFile nfp) targets = do                     -- reuse the existing NormalizedFilePath in order to maximize sharing                     itExists <- getFileExists nfp'                     return $ if itExists then Just nfp' else Nothing                 | Just tt <- HM.lookup (TargetModule modName) targets = do                     -- reuse the existing NormalizedFilePath in order to maximize sharing-                    let ttmap = HM.mapWithKey const (HashSet.toMap tt)-                        nfp' = HM.lookupDefault nfp nfp ttmap+                    let nfp' = fromMaybe nfp $ HashSet.lookupElement nfp tt                     itExists <- getFileExists nfp'                     return $ if itExists then Just nfp' else Nothing                 | otherwise = do@@ -522,7 +523,7 @@   res <- readHieFileForSrcFromDisk recorder file   vfsRef <- asks vfsVar   vfsData <- liftIO $ _vfsMap <$> readTVarIO vfsRef-  (currentSource, ver) <- liftIO $ case M.lookup (filePathToUri' file) vfsData of+  (currentSource, ver) <- liftIO $ case getVirtualFileFromVFS (VFS vfsData) (filePathToUri' file) of     Nothing -> (,Nothing) . T.decodeUtf8 <$> BS.readFile (fromNormalizedFilePath file)     Just vf -> pure (virtualFileText vf, Just $ virtualFileVersion vf)   let refmap = generateReferencesMap . getAsts . Compat.hie_asts $ res@@ -639,6 +640,22 @@   fs <- toKnownFiles <$> useNoFile_ GetKnownTargets   dependencyInfoForFiles (HashSet.toList fs) +#if MIN_VERSION_ghc(9,13,0)+-- | Build level-aware module graph edges from a ModSummary and a list of dependency NodeKeys.+-- A module can be imported at multiple levels (e.g. @import splice M@ + @import M@),+-- so we collect ALL levels per module and produce one edge per (module, level) pair.+-- This is required for GHC 9.14's level-aware module graph (@mg_zero_graph@).+mkLevelEdges :: ModSummary -> [NodeKey] -> [ModuleNodeEdge]+mkLevelEdges ms dep_node_keys = concatMap (\nk -> map (\lvl -> mkModuleEdge lvl nk) (lookupLevels nk)) dep_node_keys+  where+    importLevelsMap = M.map nubOrd $ M.fromListWith (++)+      [(unLoc mn, [lvl]) | (lvl, _pkg, mn) <- ms_textual_imps ms]+    lookupLevels nk = case nk of+      NodeKey_Module mnk ->+        M.findWithDefault [NormalLevel] (gwib_mod $ mnkModuleName mnk) importLevelsMap+      _ -> [NormalLevel]+#endif+ dependencyInfoForFiles :: [NormalizedFilePath] -> Action (BS.ByteString, DependencyInformation) dependencyInfoForFiles fs = do   (rawDepInfo, bm) <- rawDependencyInformation fs@@ -651,7 +668,8 @@ #if MIN_VERSION_ghc(9,13,0)       go (Just ms) (Just (Right (ModuleImports xs))) = Just $ ModuleNode this_dep_edges (ModuleNodeCompile ms)         where this_dep_ids = mapMaybe snd xs-              this_dep_edges = map mkNormalEdge $ mapMaybe (\fi -> IM.lookup (getFilePathId fi) nodeKeys) this_dep_ids+              this_dep_node_keys = mapMaybe (\fi -> IM.lookup (getFilePathId fi) nodeKeys) this_dep_ids+              this_dep_edges = mkLevelEdges ms this_dep_node_keys       go (Just ms) _ = Just $ ModuleNode [] (ModuleNodeCompile ms) #else       go (Just ms) (Just (Right (ModuleImports xs))) = Just $ ModuleNode this_dep_keys ms@@ -794,8 +812,9 @@                   dep_mss <- map msrModSummary <$> uses_ GetModSummaryWithoutTimestamps deps                   return $!! map (NodeKey_Module . msKey) dep_mss #if MIN_VERSION_ghc(9,13,0)+                let final_dep_edges = mkLevelEdges ms final_deps                 let module_graph_nodes =-                      nubOrdOn mkNodeKey (ModuleNode (map mkNormalEdge final_deps) (ModuleNodeCompile ms) : concatMap mgModSummaries' mgs)+                      nubOrdOn mkNodeKey (ModuleNode final_dep_edges (ModuleNodeCompile ms) : concatMap mgModSummaries' mgs) #else                 let module_graph_nodes =                       nubOrdOn mkNodeKey (ModuleNode final_deps ms : concatMap mgModSummaries' mgs)@@ -904,10 +923,10 @@         session' <- hscEnv <$> use_ GhcSession f         modify_dflags <- getModifyDynFlags dynFlagsModifyGlobal         let session = setNonHomeFCHook $ hscSetFlags (modify_dflags $ hsc_dflags session') session' -- TODO wz1000-        (modTime, mFileContent) <- getFileModTimeContents f+        mFileContent <- getFileContents f         let fp = fromNormalizedFilePath f         modS <- liftIO $ runExceptT $-                getModSummaryFromImports session fp modTime (textToStringBuffer . Rope.toText <$> mFileContent)+                getModSummaryFromImports session fp (textToStringBuffer . Rope.toText <$> mFileContent)         case modS of             Right res -> do                 -- Check for Template Haskell

@@ -17,10 +17,13 @@     ) where  import           Control.Applicative              ((<|>))+import           Control.Concurrent.STM           (newTVarIO)+import           Control.Monad.IO.Class           (liftIO) import           Development.IDE.Core.Debouncer import           Development.IDE.Core.FileExists  (fileExistsRules) import           Development.IDE.Core.OfInterest  hiding (Log, LogShake) import           Development.IDE.Graph+import           Development.IDE.Session          (SessionLoaderPendingBarrierVar (..)) import           Development.IDE.Types.Options    (IdeOptions (..)) import           Ide.Logger                       as Logger (Pretty (pretty),                                                              Priority (Debug),@@ -89,6 +92,8 @@         (optShakeOptions options)         metrics         (do+            pendingBarrier <- liftIO $ newTVarIO Nothing+            addIdeGlobal $ SessionLoaderPendingBarrierVar pendingBarrier             addIdeGlobal $ GlobalIdeOptions options             ofInterestRules (cmapWithPrio LogOfInterest recorder)             fileExistsRules (cmapWithPrio LogFileExists recorder) lspEnv

@@ -25,7 +25,7 @@     IdeState, shakeSessionInit, shakeExtras, shakeDb, rootDir,     ShakeExtras(..), getShakeExtras, getShakeExtrasRules,     KnownTargets(..), Target(..), toKnownFiles, unionKnownTargets, mkKnownTargets,-    IdeRule, IdeResult,+    IdeRule, IdeResult, RestartQueue,     GetModificationTime(GetModificationTime, GetModificationTime_, missingFileDiagnostics),     shakeOpen, shakeShut,     shakeEnqueue,@@ -261,12 +261,15 @@ -- | Actions to queue up on the index worker thread -- The inner `(HieDb -> IO ()) -> IO ()` wraps `HieDb -> IO ()` -- with (currently) retry functionality-type IndexQueue = TQueue (((HieDb -> IO ()) -> IO ()) -> IO ())+type IndexQueue = TaskQueue (((HieDb -> IO ()) -> IO ()) -> IO ())+type RestartQueue = TaskQueue (IO ())+type LoaderQueue = TaskQueue (IO ()) + data ThreadQueue = ThreadQueue {     tIndexQueue     :: IndexQueue-    , tRestartQueue :: TQueue (IO ())-    , tLoaderQueue  :: TQueue (IO ())+    , tRestartQueue :: RestartQueue+    , tLoaderQueue  :: LoaderQueue }  -- Note [Semantic Tokens Cache Location]@@ -337,9 +340,9 @@       -- ^ Default HLS config, only relevant if the client does not provide any Config     , dirtyKeys :: TVar KeySet       -- ^ Set of dirty rule keys since the last Shake run-    , restartQueue :: TQueue (IO ())+    , restartQueue :: RestartQueue       -- ^ Queue of restart actions to be run.-    , loaderQueue :: TQueue (IO ())+    , loaderQueue :: LoaderQueue       -- ^ Queue of loader actions to be run.     } @@ -401,7 +404,8 @@ getVirtualFile :: NormalizedFilePath -> Action (Maybe VirtualFile) getVirtualFile nf = do   vfs <- fmap _vfsMap . liftIO . readTVarIO . vfsVar =<< getShakeExtras-  pure $! Map.lookup (filePathToUri' nf) vfs -- Don't leak a reference to the entire map+  pure $!  -- Don't leak a reference to the entire map+    getVirtualFileFromVFS (VFS vfs) $ filePathToUri' nf  -- Take a snapshot of the current LSP VFS vfsSnapshot :: Maybe (LSP.LanguageContextEnv a) -> IO VFS

@@ -7,19 +7,40 @@ see Note [Serializing runs in separate thread] -} module Development.IDE.Core.WorkerThread-    (withWorkerQueue, awaitRunInThread)- where+  ( LogWorkerThread (..),+    withWorkerQueue,+    awaitRunInThread,+    TaskQueue,+    isEmptyTaskQueue,+    writeTaskQueue,+    withWorkerQueueSimple+  )+where -import           Control.Concurrent.Async  (AsyncCancelled (AsyncCancelled),-                                            withAsync)+import           Control.Concurrent.Async  (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.Exception.Safe    (SomeException, finally, throwIO,+                                            try) import           Control.Monad.Cont        (ContT (ContT))+import qualified Data.Text                 as T+import           Ide.Logger +data LogWorkerThread+  = LogThreadEnding !T.Text+  | LogThreadEnded !T.Text+  | LogSingleWorkStarting !T.Text+  | LogSingleWorkEnded !T.Text+  deriving (Show)++instance Pretty LogWorkerThread where+  pretty = \case+    LogThreadEnding t -> "Worker thread ending:" <+> pretty t+    LogThreadEnded t -> "Worker thread ended:" <+> pretty t+    LogSingleWorkStarting t -> "Worker starting a unit of work: " <+> pretty t+    LogSingleWorkEnded t -> "Worker ended a unit of work: " <+> pretty t+ {- Note [Serializing runs in separate thread] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -30,30 +51,78 @@ Originally we used various ways to implement this, but it was hard to maintain and error prone. Moreover, we can not stop these threads uniformly when we are shutting down the server. -}+data TaskQueue a = TaskQueue (TQueue a) +data ExitOrTask t = Exit | Task t++newTaskQueueIO :: IO (TaskQueue a)+newTaskQueueIO = TaskQueue <$> newTQueueIO++-- | 'withWorkerQueueSimple' is a simplified version of 'withWorkerQueue'+-- for the common case where the worker function is just 'id'.+withWorkerQueueSimple :: Recorder (WithPriority LogWorkerThread) -> T.Text -> ContT () IO (TaskQueue (IO ()))+withWorkerQueueSimple recorder title = withWorkerQueue recorder title id+ -- | 'withWorkerQueue' creates a new 'TQueue', and launches a worker -- thread which polls the queue for requests and runs the given worker -- function on them.-withWorkerQueue :: (t -> IO a) -> ContT () IO (TQueue t)-withWorkerQueue workerAction = ContT $ \mainAction -> do-    q <- newTQueueIO-    withAsync (writerThread q) $ \_ -> mainAction q-    where-        writerThread q =-            forever $ do-                l <- atomically $ readTQueue q-                workerAction l+withWorkerQueue :: Recorder (WithPriority LogWorkerThread) -> T.Text -> (t -> IO ()) -> ContT () IO (TaskQueue t)+withWorkerQueue recorder title workerAction = ContT $ \mainAction -> do+  q <- newTaskQueueIO+  -- Use a TMVar as a stop flag to coordinate graceful shutdown.+  -- The worker thread checks this flag before dequeuing each job; if set, it exits immediately,+  -- ensuring that no new work is started after shutdown is requested.+  -- This mechanism is necessary because some downstream code may swallow async exceptions,+  -- making 'cancel' unreliable for stopping the thread in all cases.+  -- If 'cancel' does interrupt the thread (e.g., while blocked in STM or in a cooperative job),+  -- the thread exits immediately and never checks the TMVar; in such cases, the stop flag is redundant.+  b <- newEmptyTMVarIO+  withAsync (writerThread q b) $ \_ -> do+    mainAction q+    -- if we want to debug the exact location the worker swallows an async exception, we can+    -- temporarily comment out the `finally` clause.+        `finally` atomically (putTMVar b ())+    logWith recorder Debug (LogThreadEnding title)+  logWith recorder Debug (LogThreadEnded title)+  where+    writerThread q b =+      -- See above: check stop flag before dequeuing, exit if set, otherwise run next job.+      do+        task <- atomically $ do+          task <- tryReadTaskQueue q+          isEm <- isEmptyTMVar b+          case (isEm, task) of+            (False, _)   -> return Exit -- stop flag set, exit+            (_, Just t)  -> return $ Task t -- got a task, run it+            (_, Nothing) -> retry -- no task, wait+        case task of+          Exit -> return ()+          Task t -> do+                logWith recorder Debug $ LogSingleWorkStarting title+                workerAction t+                logWith recorder Debug $ LogSingleWorkEnded title+                writerThread q b + -- | 'awaitRunInThread' queues up an 'IO' action to be run by a worker thread, -- 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 $ try act >>= signalBarrier barrier-    resultOrException <- waitBarrier barrier-    case resultOrException of-        Left e  -> throwIO (e :: SomeException)-        Right r -> return r+awaitRunInThread :: TaskQueue (IO ()) -> IO result -> IO result+awaitRunInThread (TaskQueue q) act = do+  -- Take an action from TQueue, run it and+  -- use barrier to wait for the result+  barrier <- newBarrier+  atomically $ writeTQueue q (try act >>= signalBarrier barrier)+  resultOrException <- waitBarrier barrier+  case resultOrException of+    Left e  -> throwIO (e :: SomeException)+    Right r -> return r++writeTaskQueue :: TaskQueue a -> a -> STM ()+writeTaskQueue (TaskQueue q) = writeTQueue q++isEmptyTaskQueue :: TaskQueue a -> STM Bool+isEmptyTaskQueue (TaskQueue q) = isEmptyTQueue q++tryReadTaskQueue :: TaskQueue a -> STM (Maybe a)+tryReadTaskQueue (TaskQueue q) = tryReadTQueue q

@@ -506,5 +506,6 @@             unRecFieldsDotDot <$>             unLoc <$> rec_dotdot x +extract_cons :: DataDefnCons a -> [a] extract_cons (NewTypeCon x)      = [x] extract_cons (DataTypeCons _ xs) = xs

@@ -484,7 +484,6 @@  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@@ -531,9 +530,6 @@ 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 #if MIN_VERSION_ghc(9,11,0)

@@ -31,6 +31,7 @@     Pair(..),     -- * EnumSet     EnumSet,+    member,     toList,     -- * FastString exports     FastString,

@@ -29,6 +29,7 @@     printOutputable,     printOutputableOneLine,     getExtensions,+    getExtensionsSet,     stripOccNamePrefix,     ) where @@ -279,8 +280,11 @@ {-# INLINE printOutputable #-}  getExtensions :: ParsedModule -> [Extension]-getExtensions = toList . extensionFlags . ms_hspp_opts . pm_mod_summary+getExtensions = toList . getExtensionsSet +getExtensionsSet :: ParsedModule -> EnumSet Extension+getExtensionsSet = extensionFlags . ms_hspp_opts . pm_mod_summary+ -- | When e.g. DuplicateRecordFields is enabled, compiler generates -- names like "$sel:accessor:One" and "$sel:accessor:Two" to -- disambiguate record selectors@@ -331,4 +335,3 @@   , "$c"   , "$m"   ]-

@@ -12,6 +12,7 @@     , ThreadQueue     , runWithWorkerThreads     , Setup (..)+    , ServerLifecycleContext (..)     ) where  import           Control.Concurrent.STM@@ -35,12 +36,17 @@ import           UnliftIO.Exception  import qualified Colog.Core                            as Colog+import           Control.Concurrent.Extra              (newBarrier,+                                                        signalBarrier,+                                                        waitBarrier) import           Control.Monad.IO.Unlift               (MonadUnliftIO)-import           Control.Monad.Trans.Cont              (evalContT)+import           Control.Monad.Trans.Cont              (ContT (..), evalContT)+import           Data.Foldable                         (traverse_) import           Development.IDE.Core.IdeConfiguration+import           Development.IDE.Core.Service          (shutdown) import           Development.IDE.Core.Shake            hiding (Log) import           Development.IDE.Core.Tracing-import           Development.IDE.Core.WorkerThread     (withWorkerQueue)+import           Development.IDE.Core.WorkerThread import qualified Development.IDE.Session               as Session import           Development.IDE.Types.Shake           (WithHieDb,                                                         WithHieDbShield (..))@@ -48,6 +54,8 @@ import           Language.LSP.Server                   (LanguageContextEnv,                                                         LspServerLog,                                                         type (<~>))+import           System.Timeout                        (timeout)+ data Log   = LogRegisteringIdeConfig !IdeConfiguration   | LogReactorThreadException !SomeException@@ -56,11 +64,26 @@   | LogCancelledRequest !SomeLspId   | LogSession Session.Log   | LogLspServer LspServerLog-  | LogServerShutdownMessage+  | LogReactorShutdownRequested Bool+  | LogShutDownTimeout Int+  | LogServerExitWith (Either () Int)+  | LogReactorShutdownConfirmed !T.Text   deriving Show  instance Pretty Log where   pretty = \case+    LogReactorShutdownRequested b ->+      "Requested reactor shutdown; stop signal posted: " <+> pretty b+    LogReactorShutdownConfirmed msg ->+      "Reactor shutdown confirmed: " <+> pretty msg+    LogServerExitWith (Right 0) ->+      "Server exited successfully"+    LogServerExitWith (Right code) ->+      "Server exited with failure code" <+> pretty code+    LogServerExitWith (Left ()) ->+      "Server forcefully exited due to exception in reactor thread"+    LogShutDownTimeout seconds ->+      "Shutdown timeout, the server will exit now after waiting for" <+> pretty seconds  <+> "seconds"     LogRegisteringIdeConfig ideConfig ->       -- This log is also used to identify if HLS starts successfully in vscode-haskell,       -- don't forget to update the corresponding test in vscode-haskell if the text in@@ -80,8 +103,33 @@       "Cancelled request" <+> viaShow requestId     LogSession msg -> pretty msg     LogLspServer msg -> pretty msg-    LogServerShutdownMessage -> "Received shutdown message" +-- | Context of the LSP language server.+-- This record encapsulates all the configuration and callback functions+-- needed to set up and run the language server initialization process.+data ServerLifecycleContext config = ServerLifecycleContext+  { ctxRecorder :: Recorder (WithPriority Log)+    -- ^ Logger for recording server events and diagnostics+  , ctxDefaultRoot :: FilePath+    -- ^ Default root directory for the workspace, see Note [Root Directory]+  , ctxGetHieDbLoc :: FilePath -> IO FilePath+    -- ^ Function to determine the HIE database location for a given root path+  , ctxGetIdeState :: LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> ThreadQueue -> IO IdeState+    -- ^ Function to create and initialize the IDE state with the given environment+  , ctxUntilReactorStopSignal :: IO () -> IO ()+    -- ^ Lifetime control: MVar to signal reactor shutdown+  , ctxConfirmReactorShutdown :: T.Text -> IO ()+    -- ^ Callback to log/confirm reactor shutdown with a reason+  , ctxForceShutdown :: IO ()+    -- ^ Action to forcefully exit the server when exception occurs+  , ctxClearReqId :: SomeLspId -> IO ()+    -- ^ Function to clear/cancel a request by its ID+  , ctxWaitForCancel :: SomeLspId -> IO ()+    -- ^ Function to wait for a request cancellation by its ID+  , ctxClientMsgChan :: Chan ReactorMessage+    -- ^ Channel for communicating with the reactor message loop+  }+ data Setup config m a   = MkSetup   { doInitialize :: LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either (TResponseError Method_Initialize) (LSP.LanguageContextEnv config, a))@@ -136,8 +184,8 @@             outH             serverDefinition -    untilMVar clientMsgVar $-        runServer `finally` sequence_ onExit+    untilMVar' clientMsgVar runServer `finally` sequence_ onExit+        >>= logWith recorder Info . LogServerExitWith  setupLSP ::      forall config.@@ -155,8 +203,21 @@    -- An MVar to control the lifetime of the reactor loop.   -- The loop will be stopped and resources freed when it's full-  reactorLifetime <- newEmptyMVar-  let stopReactorLoop = void $ tryPutMVar reactorLifetime ()+  reactorStopSignal <- newEmptyMVar+  reactorConfirmBarrier <- newBarrier+  let+    untilReactorStopSignal = untilMVar reactorStopSignal+    confirmReactorShutdown reason = do+      logWith recorder Debug $ LogReactorShutdownConfirmed reason+      signalBarrier reactorConfirmBarrier ()+    requestReactorShutdown = do+      k <- tryPutMVar reactorStopSignal ()+      logWith recorder Info $ LogReactorShutdownRequested k+      let timeOutSeconds = 2+      timeout (timeOutSeconds * 1_000_000) (waitBarrier reactorConfirmBarrier) >>= \case+        Just () -> pure ()+        -- If we don't get confirmation within 2 seconds, we log a warning and shutdown anyway.+        Nothing -> logWith recorder Warning $ LogShutDownTimeout timeOutSeconds    -- Forcefully exit   let exit = void $ tryPutMVar clientMsgVar ()@@ -185,85 +246,107 @@   let staticHandlers = mconcat         [ userHandlers         , cancelHandler cancelRequest-        , exitHandler exit-        , shutdownHandler recorder stopReactorLoop+        , shutdownHandler recorder requestReactorShutdown         ]         -- Cancel requests are special since they need to be handled         -- out of order to be useful. Existing handlers are run afterwards. -  let doInitialize = handleInit recorder defaultRoot getHieDbLoc getIdeState reactorLifetime exit clearReqId waitForCancel clientMsgChan+  let lifecycleCtx = ServerLifecycleContext+        { ctxRecorder = recorder+        , ctxDefaultRoot = defaultRoot+        , ctxGetHieDbLoc = getHieDbLoc+        , ctxGetIdeState = getIdeState+        , ctxUntilReactorStopSignal = untilReactorStopSignal+        , ctxConfirmReactorShutdown = confirmReactorShutdown+        , ctxForceShutdown = exit+        , ctxClearReqId = clearReqId+        , ctxWaitForCancel = waitForCancel+        , ctxClientMsgChan = clientMsgChan+        } -  let interpretHandler (env,  st) = LSP.Iso (LSP.runLspT env . flip (runReaderT . unServerM) (clientMsgChan,st)) liftIO+  let doInitialize = handleInit lifecycleCtx -  let onExit = [stopReactorLoop, exit]+  let interpretHandler (env,  st) = LSP.Iso (LSP.runLspT env . flip (runReaderT . unServerM) (clientMsgChan,st)) liftIO+  let onExit = [void $ tryPutMVar reactorStopSignal ()]    pure MkSetup {doInitialize, staticHandlers, interpretHandler, onExit}   handleInit-    :: Recorder (WithPriority Log)-    -> FilePath -- ^ root directory, see Note [Root Directory]-    -> (FilePath -> IO FilePath)-    -> (LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> ThreadQueue -> IO IdeState)-    -> MVar ()-    -> IO ()-    -> (SomeLspId -> IO ())-    -> (SomeLspId -> IO ())-    -> Chan ReactorMessage+    :: ServerLifecycleContext config     -> LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState))-handleInit recorder defaultRoot getHieDbLoc getIdeState lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (TRequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do+handleInit lifecycleCtx env (TRequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do     traceWithSpan sp params-    -- only shift if lsp root is different from the rootDir-    -- see Note [Root Directory]+  -- only shift if lsp root is different from the rootDir+  -- see Note [Root Directory]+    let+      recorder = ctxRecorder lifecycleCtx+      defaultRoot = ctxDefaultRoot lifecycleCtx+      untilReactorStopSignal = ctxUntilReactorStopSignal lifecycleCtx+      lifetimeConfirm = ctxConfirmReactorShutdown lifecycleCtx     root <- case LSP.resRootPath env of-        Just lspRoot | lspRoot /= defaultRoot -> setCurrentDirectory lspRoot >> return lspRoot-        _ -> pure defaultRoot-    dbLoc <- getHieDbLoc root+      Just lspRoot | lspRoot /= defaultRoot -> setCurrentDirectory lspRoot >> return lspRoot+      _ -> pure defaultRoot+    dbLoc <- ctxGetHieDbLoc lifecycleCtx root     let initConfig = parseConfiguration params     logWith recorder Info $ LogRegisteringIdeConfig initConfig-    dbMVar <- newEmptyMVar-+    ideMVar <- newEmptyMVar -    let handleServerException (Left e) = do+    let+      loggedTeardown me = do+        -- shutdown shake+        case me of+          Left e -> do+            lifetimeConfirm "due to exception in reactor thread"             logWith recorder Error $ LogReactorThreadException e-            exitClientMsg-        handleServerException (Right _) = pure ()+            ctxForceShutdown lifecycleCtx+          _ -> do+            lifetimeConfirm "due to shutdown message"+            return () -        exceptionInHandler e = do-            logWith recorder Error $ LogReactorMessageActionException e+      exceptionInHandler e = do+        logWith recorder Error $ LogReactorMessageActionException e -        checkCancelled :: forall m . LspId m -> IO () -> (TResponseError m -> IO ()) -> IO ()-        checkCancelled _id act k =-            let sid = SomeLspId _id-            in flip finally (clearReqId sid) $-                catch (do-                    -- We could optimize this by first checking if the id-                    -- is in the cancelled set. However, this is unlikely to be a-                    -- bottleneck and the additional check might hide-                    -- issues with async exceptions that need to be fixed.-                    cancelOrRes <- race (waitForCancel sid) act-                    case cancelOrRes of-                        Left () -> do-                            logWith recorder Debug $ LogCancelledRequest sid-                            k $ TResponseError (InL LSPErrorCodes_RequestCancelled) "" Nothing-                        Right res -> pure res-                ) $ \(e :: SomeException) -> do+      checkCancelled :: forall m . LspId m -> IO () -> (TResponseError m -> IO ()) -> IO ()+      checkCancelled _id act k =+        let sid = SomeLspId _id+         in flip finally (ctxClearReqId lifecycleCtx sid) $+              catch+                (do+                  -- We could optimize this by first checking if the id+                  -- is in the cancelled set. However, this is unlikely to be a+                  -- bottleneck and the additional check might hide+                  -- issues with async exceptions that need to be fixed.+                  cancelOrRes <- race (ctxWaitForCancel lifecycleCtx sid) act+                  case cancelOrRes of+                    Left () -> do+                      logWith recorder Debug $ LogCancelledRequest sid+                      k $ TResponseError (InL LSPErrorCodes_RequestCancelled) "" Nothing+                    Right res -> pure res+                )+                $ \(e :: SomeException) -> do                     exceptionInHandler e                     k $ TResponseError (InR ErrorCodes_InternalError) (T.pack $ show e) Nothing-    _ <- flip forkFinally handleServerException $ do-        untilMVar lifetime $ runWithWorkerThreads (cmapWithPrio LogSession recorder) dbLoc $ \withHieDb' threadQueue' -> do-            putMVar dbMVar (WithHieDbShield withHieDb',threadQueue')-            forever $ do-                msg <- readChan clientMsgChan-                -- We dispatch notifications synchronously and requests asynchronously-                -- This is to ensure that all file edits and config changes are applied before a request is handled-                case msg of-                    ReactorNotification act -> handle exceptionInHandler act-                    ReactorRequest _id act k -> void $ async $ checkCancelled _id act k-        logWith recorder Info LogReactorThreadStopped+    _ <- flip forkFinally loggedTeardown $ do+      -- Need to be careful about when the shutdown occurs, it needs to be shut+      -- down after the session loader and restarting threads, and before the+      -- hiedb connections are closed.+      let shutdownSession = tryReadMVar ideMVar >>= traverse_ shutdown+      runWithWorkerThreads (cmapWithPrio LogSession recorder) dbLoc shutdownSession $ \withHieDb' threadQueue' -> do+        ide <- ctxGetIdeState lifecycleCtx env root withHieDb' threadQueue'+        putMVar ideMVar ide+        -- Keep this after putMVar ideMVar ide; otherwise shutdown during+        -- initialization could leave handleInit blocked indefinitely on readMVar.+        untilReactorStopSignal $ forever $ do+          msg <- readChan $ ctxClientMsgChan lifecycleCtx+          -- We dispatch notifications synchronously and requests asynchronously+          -- This is to ensure that all file edits and config changes are applied before a request is handled+          case msg of+            ReactorNotification act  -> handle exceptionInHandler act+            ReactorRequest _id act k -> void $ async $ checkCancelled _id act k+      logWith recorder Info LogReactorThreadStopped -    (WithHieDbShield withHieDb, threadQueue) <- takeMVar dbMVar-    ide <- getIdeState env root withHieDb threadQueue+    ide <- readMVar ideMVar     registerIdeConfiguration (shakeExtras ide) initConfig     pure $ Right (env,ide) @@ -271,12 +354,16 @@ -- | runWithWorkerThreads -- create several threads to run the session, db and session loader -- see Note [Serializing runs in separate thread]-runWithWorkerThreads :: Recorder (WithPriority Session.Log) -> FilePath -> (WithHieDb -> ThreadQueue -> IO ()) -> IO ()-runWithWorkerThreads recorder dbLoc f = evalContT $ do-            sessionRestartTQueue <- withWorkerQueue id-            sessionLoaderTQueue <- withWorkerQueue id-            (WithHieDbShield hiedb, threadQueue) <- runWithDb recorder dbLoc-            liftIO $ f hiedb (ThreadQueue threadQueue sessionRestartTQueue sessionLoaderTQueue)+runWithWorkerThreads :: Recorder (WithPriority Session.Log) -> FilePath -> IO () -> (WithHieDb -> ThreadQueue -> IO ()) -> IO ()+runWithWorkerThreads recorder dbLoc shutdownSession f = evalContT $ do+  (WithHieDbShield hiedb, threadQueue) <- runWithDb recorder dbLoc+  -- The shake session needs to be shut down prior to the hiedb connections+  -- being cleaned up, otherwise shake could be referencing dead connections.+  -- This is passed in via the callsites.+  ContT $ \action -> action () `finally` shutdownSession+  sessionRestartTQueue <- withWorkerQueueSimple (cmapWithPrio Session.LogSessionWorkerThread recorder) "RestartTQueue"+  sessionLoaderTQueue <- withWorkerQueueSimple (cmapWithPrio Session.LogSessionWorkerThread recorder) "SessionLoaderTQueue"+  liftIO $ f hiedb (ThreadQueue threadQueue sessionRestartTQueue sessionLoaderTQueue)  -- | Runs the action until it ends or until the given MVar is put. --   It is important, that the thread that puts the 'MVar' is not dropped before it puts the 'MVar' i.e. it should@@ -286,6 +373,9 @@ untilMVar :: MonadUnliftIO m => MVar () -> m a -> m () untilMVar mvar io = race_ (readMVar mvar) io +untilMVar' :: MonadUnliftIO m => MVar a -> m b -> m (Either a b)+untilMVar' mvar io = race (readMVar mvar) io+ cancelHandler :: (SomeLspId -> IO ()) -> LSP.Handlers (ServerM c) cancelHandler cancelRequest = LSP.notificationHandler SMethod_CancelRequest $ \TNotificationMessage{_params=CancelParams{_id}} ->   liftIO $ cancelRequest (SomeLspId (toLspId _id))@@ -294,18 +384,11 @@         toLspId (InR y) = IdString y  shutdownHandler :: Recorder (WithPriority Log) -> IO () -> LSP.Handlers (ServerM c)-shutdownHandler recorder stopReactor = LSP.requestHandler SMethod_Shutdown $ \_ resp -> do-    (_, ide) <- ask-    liftIO $ logWith recorder Debug LogServerShutdownMessage-    -- stop the reactor to free up the hiedb connection-    liftIO stopReactor-    -- flush out the Shake session to record a Shake profile if applicable-    liftIO $ shakeShut ide+shutdownHandler _recorder requestReactorShutdown = LSP.requestHandler SMethod_Shutdown $ \_ resp -> do+    -- stop the reactor to free up the hiedb connection and shut down shake+    liftIO requestReactorShutdown     resp $ Right Null -exitHandler :: IO () -> LSP.Handlers (ServerM c)-exitHandler exit = LSP.notificationHandler SMethod_Exit $ const $ liftIO exit- modifyOptions :: LSP.Options -> LSP.Options modifyOptions x = x{ LSP.optTextDocumentSync   = Just $ tweakTDS origTDS                    }@@ -313,4 +396,3 @@         tweakTDS tds = tds{_openClose=Just True, _change=Just TextDocumentSyncKind_Incremental, _save=Just $ InR $ SaveOptions Nothing}         origTDS = fromMaybe tdsDefault $ LSP.optTextDocumentSync x         tdsDefault = TextDocumentSyncOptions Nothing Nothing Nothing Nothing Nothing-

@@ -378,7 +378,7 @@         Check argFiles -> do           let dir = argsProjectRoot           dbLoc <- getHieDbLoc dir-          runWithWorkerThreads (cmapWithPrio LogSession recorder) dbLoc $ \hiedb threadQueue -> do+          runWithWorkerThreads (cmapWithPrio LogSession recorder) dbLoc mempty $ \hiedb threadQueue -> do             -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error             hSetEncoding stdout utf8             hSetEncoding stderr utf8@@ -436,7 +436,7 @@         Custom (IdeCommand c) -> do           let root = argsProjectRoot           dbLoc <- getHieDbLoc root-          runWithWorkerThreads (cmapWithPrio LogSession recorder) dbLoc $ \hiedb threadQueue -> do+          runWithWorkerThreads (cmapWithPrio LogSession recorder) dbLoc mempty $ \hiedb threadQueue -> do             sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions "." (tLoaderQueue threadQueue)             let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader                 ideOptions = def_options

@@ -139,9 +139,9 @@       Nothing -> liftIO $ spanDocToMarkdown . fst <$> getDocumentationTryGhc (hscEnv sess) name     typ <- case lookupNameEnv km name of       _ | not needType -> pure Nothing-      Just ty -> pure (safeTyThingType ty)+      Just ty -> pure (safeTyThingType True ty)       Nothing -> do-        (safeTyThingType =<<) <$> liftIO (lookupName (hscEnv sess) name)+        (safeTyThingType True =<<) <$> liftIO (lookupName (hscEnv sess) name)     let det1 = case typ of           Just ty -> Just (":: " <> printOutputable (stripForall ty) <> "\n")           Nothing -> Nothing

@@ -867,7 +867,7 @@  -- |From the given cursor position, gets the prefix module or record for autocompletion getCompletionPrefix :: Position -> VFS.VirtualFile -> PosPrefixInfo-getCompletionPrefix pos (VFS.VirtualFile _ _ ropetext) = getCompletionPrefixFromRope pos ropetext+getCompletionPrefix pos (VFS.VirtualFile _ _ ropetext _) = getCompletionPrefixFromRope pos ropetext  getCompletionPrefixFromRope :: Position -> Rope.Rope -> PosPrefixInfo getCompletionPrefixFromRope pos@(Position l c) ropetext =

@@ -9,49 +9,51 @@     , Log(..)     ) where -import           Control.Exception             (SomeException)-import           Control.Lens                  ((^.))+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)-import           Data.Dependent.Map            (DMap)-import qualified Data.Dependent.Map            as DMap+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)+import           Data.Dependent.Map               (DMap)+import qualified Data.Dependent.Map               as DMap import           Data.Dependent.Sum import           Data.Either-import qualified Data.List                     as List-import           Data.List.NonEmpty            (NonEmpty, nonEmpty, toList)-import qualified Data.List.NonEmpty            as NE-import qualified Data.Map                      as Map-import           Data.Maybe                    (isNothing, mapMaybe)+import qualified Data.List                        as List+import           Data.List.NonEmpty               (NonEmpty, nonEmpty, toList)+import qualified Data.List.NonEmpty               as NE+import qualified Data.Map                         as Map+import           Data.Maybe                       (isNothing, mapMaybe) import           Data.Some import           Data.String-import           Data.Text                     (Text)-import qualified Data.Text                     as T-import           Development.IDE.Core.Shake    hiding (Log)+import           Data.Text                        (Text)+import qualified Data.Text                        as T+import           Development.IDE.Core.PluginUtils (injectServerDiagnostics)+import           Development.IDE.Core.Shake       hiding (Log) import           Development.IDE.Core.Tracing-import           Development.IDE.Graph         (Rules)+import           Development.IDE.Graph            (Rules) import           Development.IDE.LSP.Server import           Development.IDE.Plugin-import qualified Development.IDE.Plugin        as P+import qualified Development.IDE.Plugin           as P import           Ide.Logger import           Ide.Plugin.Config import           Ide.Plugin.Error import           Ide.Plugin.HandleRequestTypes-import           Ide.PluginUtils               (getClientConfig)-import           Ide.Types                     as HLS-import qualified Language.LSP.Protocol.Lens    as JL+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+import qualified Language.LSP.Server              as LSP import           Language.LSP.VFS-import           Prettyprinter.Render.String   (renderString)-import           Text.Regex.TDFA.Text          ()-import           UnliftIO                      (MonadUnliftIO, liftIO)-import           UnliftIO.Async                (forConcurrently)-import           UnliftIO.Exception            (catchAny)+import           Prettyprinter.Render.String      (renderString)+import           Text.Regex.TDFA.Text             ()+import           UnliftIO                         (MonadUnliftIO, liftIO,+                                                   readTVarIO)+import           UnliftIO.Async                   (forConcurrently)+import           UnliftIO.Exception               (catchAny)  -- --------------------------------------------------------------------- --@@ -250,12 +252,14 @@         PluginHandlers hs = HLS.pluginHandlers pluginDesc     handlers = mconcat $ do       (IdeMethod m :=> IdeHandler fs') <- DMap.assocs handlers'-      pure $ requestHandler m $ \ide params -> do+      pure $ requestHandler m $ \ide params' -> do+        vfs <- readTVarIO $ vfsVar $ shakeExtras ide+        params <- liftIO $ preprocessMessageParams ide m params'         config <- Ide.PluginUtils.getClientConfig         -- Only run plugins that are allowed to run on this request, save the         -- list of disabled plugins incase that's all we have-        let (fs, dfs) = List.partition (\(_, desc, _) -> handlesRequest m params desc config == HandlesRequest) fs'-        let disabledPluginsReason = (\(x, desc, _) -> (x, handlesRequest m params desc config)) <$> dfs+        let (fs, dfs) = List.partition (\(_, desc, _) -> handlesRequest vfs m params desc config == HandlesRequest) fs'+        let disabledPluginsReason = (\(x, desc, _) -> (x, handlesRequest vfs 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@@ -287,6 +291,18 @@               Just xs -> do                 pure $ Right $ combineResponses m config caps params xs ++-- | Preprocess 'MessageParams' and insert custom data.+--+-- In issue https://github.com/haskell/haskell-language-server/issues/4056, we+-- established that HLS should rely on server-side 'Diagnostic's to compute 'CodeAction's+-- To ensure consistency, we intercept 'CodeAction's requests and explicitly inject+-- server-side 'Diagnostic's before delegating to the 'PluginHandler'.+preprocessMessageParams :: IdeState -> SMethod m -> MessageParams m -> IO (MessageParams m)+preprocessMessageParams ide m params = case m of+    SMethod_TextDocumentCodeAction -> injectServerDiagnostics ide params+    _                              -> pure params+ -- | 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.@@ -370,7 +386,7 @@       pure $ notificationHandler m $ \ide vfs params -> do         config <- Ide.PluginUtils.getClientConfig         -- Only run plugins that are enabled for this request-        let fs = filter (\(_, desc, _) -> handlesRequest m params desc config == HandlesRequest) fs'+        let fs = filter (\(_, desc, _) -> handlesRequest vfs m params desc config == HandlesRequest) fs'         case nonEmpty fs of           Nothing -> do             logWith recorder Warning (LogNoPluginForMethod $ Some m)

@@ -12,6 +12,7 @@   ) where  import           Control.Concurrent                   (threadDelay)+import qualified Control.Exception                    as E import           Control.Monad import           Control.Monad.Except                 (ExceptT (..), throwError) import           Control.Monad.IO.Class@@ -23,6 +24,7 @@ import           Data.Bifunctor import           Data.CaseInsensitive                 (CI, original) import qualified Data.HashMap.Strict                  as HM+import qualified Data.HashSet                         as Set import           Data.Maybe                           (isJust) import           Data.Proxy import           Data.String@@ -41,6 +43,8 @@ import           Development.IDE.Graph.Internal.Types (Result (resultBuilt, resultChanged, resultVisited),                                                        Step (Step)) import qualified Development.IDE.Graph.Internal.Types as Graph+import           Development.IDE.Session              (clearSessionLoaderPendingBarrier,+                                                       setSessionLoaderPendingBarrier) import           Development.IDE.Types.Action import           Development.IDE.Types.HscEnvEq       (HscEnvEq (hscEnv)) import           Development.IDE.Types.Location       (fromUri)@@ -60,6 +64,7 @@     | GetShakeSessionQueueCount      -- ^ :: Number     | WaitForShakeQueue -- ^ Block until the Shake queue is empty. Returns Null     | WaitForIdeRule String Uri      -- ^ :: WaitForIdeRuleResult+    | WaitForIdeRules String [Uri]   -- ^ :: [WaitForIdeRuleResult]     | GetBuildKeysVisited        -- ^ :: [(String]     | GetBuildKeysBuilt          -- ^ :: [(String]     | GetBuildKeysChanged        -- ^ :: [(String]@@ -114,6 +119,17 @@     success <- runAction ("WaitForIdeRule " <> k <> " " <> show file) s $ parseAction (fromString k) nfp     let res = WaitForIdeRuleResult <$> success     return $ bimap PluginInvalidParams toJSON res+testRequestHandler s (WaitForIdeRules k files) = liftIO $ do+    let nfps = fmap (fromUri . toNormalizedUri) files+        uniqueCount = Set.size (Set.fromList nfps)+        act = runAction ("WaitForIdeRules " <> k <> " " <> show files) s $ parseActions (fromString k) nfps+    success <-+      if uniqueCount > 0+        then (setSessionLoaderPendingBarrier s uniqueCount >> act)+              `E.finally` clearSessionLoaderPendingBarrier s+        else act+    let res = fmap (fmap WaitForIdeRuleResult) success+    return $ bimap PluginInvalidParams toJSON res testRequestHandler s GetBuildKeysBuilt = liftIO $ do     keys <- getDatabaseKeys resultBuilt $ shakeDb s     return $ Right $ toJSON $ map show keys@@ -158,6 +174,18 @@ parseAction "gethieast" fp = Right . isJust <$> use GetHieAst fp parseAction "getFileContents" fp = Right . isJust <$> use GetFileContents fp parseAction other _ = return $ Left $ "Cannot parse ide rule: " <> pack (original other)++parseActions :: CI String -> [NormalizedFilePath] -> Action (Either Text [Bool])+parseActions "typecheck" fps = Right . fmap isJust <$> uses TypeCheck fps+parseActions "getLocatedImports" fps = Right . fmap isJust <$> uses GetLocatedImports fps+parseActions "getmodsummary" fps = Right . fmap isJust <$> uses GetModSummary fps+parseActions "getmodsummarywithouttimestamps" fps = Right . fmap isJust <$> uses GetModSummaryWithoutTimestamps fps+parseActions "getparsedmodule" fps = Right . fmap isJust <$> uses GetParsedModule fps+parseActions "ghcsession" fps = Right . fmap isJust <$> uses GhcSession fps+parseActions "ghcsessiondeps" fps = Right . fmap isJust <$> uses GhcSessionDeps fps+parseActions "gethieast" fps = Right . fmap isJust <$> uses GetHieAst fps+parseActions "getFileContents" fps = Right . fmap isJust <$> uses GetFileContents fps+parseActions other _ = return $ Left $ "Cannot parse ide rule: " <> pack (original other)  -- | a command that blocks forever. Used for testing blockCommandId :: Text

@@ -16,7 +16,7 @@  import           Control.Concurrent.STM.Stats         (atomically) import           Control.DeepSeq                      (rwhnf)-import           Control.Lens                         (to, (?~), (^?))+import           Control.Lens                         ((?~), (^?)) import           Control.Monad                        (mzero) import           Control.Monad.Extra                  (whenMaybe) import           Control.Monad.IO.Class               (MonadIO (liftIO))@@ -51,8 +51,7 @@ import           Development.IDE.GHC.Compat import           Development.IDE.GHC.Compat.Error     (_TcRnMessage,                                                        _TcRnMissingSignature,-                                                       msgEnvelopeErrorL,-                                                       stripTcRnMessageContext)+                                                       msgEnvelopeErrorL) import           Development.IDE.GHC.Util             (printName) import           Development.IDE.Graph.Classes import           Development.IDE.Types.Location       (Position (Position, _line),@@ -91,7 +90,6 @@                                                        TextEdit (TextEdit),                                                        WorkspaceEdit (WorkspaceEdit),                                                        type (|?) (..))-import           Text.Regex.TDFA                      ((=~))  data Log = LogShake Shake.Log deriving Show 

@@ -41,7 +41,8 @@ import           Development.IDE.Core.RuleTypes import           Development.IDE.GHC.Compat import qualified Development.IDE.GHC.Compat.Util      as Util-import           Development.IDE.GHC.Util             (printOutputable)+import           Development.IDE.GHC.Util             (printOutputable,+                                                       printOutputableOneLine) import           Development.IDE.Spans.Common import           Development.IDE.Types.Options @@ -260,8 +261,9 @@   -> DocAndTyThingMap   -> HscEnv   -> Position+  -> Util.EnumSet Extension   -> IO (Maybe (Maybe Range, [T.Text]))-atPoint opts@IdeOptions{} shakeExtras@ShakeExtras{ withHieDb, hiedbWriter } har@(HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (DKMap dm km _am) env pos =+atPoint opts@IdeOptions{} shakeExtras@ShakeExtras{ withHieDb, hiedbWriter } har@(HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (DKMap dm km _am) env pos enabledExtensions =     listToMaybe <$> sequence (pointCommand hf pos hoverInfo)   where     -- Hover info for values/data@@ -317,7 +319,7 @@             let               typeSig = case identType dets of                 Just t -> prettyType (Just n) locationsMap t-                Nothing -> case safeTyThingType =<< lookupNameEnv km n of+                Nothing -> case safeTyThingType (Util.member LinearTypes enabledExtensions) =<< lookupNameEnv km n of                   Just kind -> prettyTypeFromType (Just n) locationsMap kind                   Nothing   -> wrapHaskell (printOutputable n)               definitionLoc = maybeToList (pretty (definedAt n) (prettyPackageName n))@@ -371,11 +373,11 @@          prettyTypeFromType :: Maybe Name -> M.Map Name Location -> Type -> T.Text         prettyTypeFromType boundNameMay locationsMap ty =-          prettyTypeCommon boundNameMay locationsMap (S.fromList $ namesInType ty) (printOutputable ty)+          prettyTypeCommon boundNameMay locationsMap (S.fromList $ namesInType ty) (printOutputableOneLine ty)          prettyType :: Maybe Name -> M.Map Name Location -> hietype -> T.Text         prettyType boundNameMay locationsMap t =-          prettyTypeCommon boundNameMay locationsMap (typeNames t) (printOutputable . expandType $ t)+          prettyTypeCommon boundNameMay locationsMap (typeNames t) (printOutputableOneLine . expandType $ t)          prettyTypeCommon :: Maybe Name -> M.Map Name Location -> Set Name -> T.Text -> T.Text         prettyTypeCommon boundNameMay locationsMap names expandedType =

@@ -4,7 +4,6 @@  module Development.IDE.Spans.Common (   unqualIEWrapName-, safeTyThingId , safeTyThingType , SpanDoc(..) , SpanDocUris(..)@@ -44,17 +43,12 @@ unqualIEWrapName :: IEWrappedName GhcPs -> T.Text unqualIEWrapName = printOutputable . rdrNameOcc . ieWrappedName --- From haskell-ide-engine/src/Haskell/Ide/Engine/Support/HieExtras.hs-safeTyThingType :: TyThing -> Maybe Type-safeTyThingType thing-  | Just i <- safeTyThingId thing = Just (varType i)-safeTyThingType (ATyCon tycon)    = Just (tyConKind tycon)-safeTyThingType _                 = Nothing--safeTyThingId :: TyThing -> Maybe Id-safeTyThingId (AnId i)                         = Just i-safeTyThingId (AConLike (RealDataCon dataCon)) = Just (dataConWrapId dataCon)-safeTyThingId _                                = Nothing+safeTyThingType :: Bool -> TyThing -> Maybe Type+safeTyThingType showLinearType (AConLike (RealDataCon dataCon))+                                    = Just (dataConDisplayType showLinearType dataCon)+safeTyThingType _ (AnId i)          = Just (varType i)+safeTyThingType _ (ATyCon tycon)    = Just (tyConKind tycon)+safeTyThingType _ _                 = Nothing  -- Possible documentation for an element in the code data SpanDoc

@@ -40,12 +40,7 @@      | otherwise      -> NextPragmaInfo 0 Nothing --- NOTE(ozkutuk): `RecordPuns` extension is renamed to `NamedFieldPuns`--- in GHC 9.4, but we still want to insert `NamedFieldPuns` in pre-9.4--- GHC as well, hence the replacement.--- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/6156 showExtension :: Extension -> Text-showExtension NamedFieldPuns = "NamedFieldPuns" showExtension ext = pack (show ext)  insertNewPragma :: NextPragmaInfo -> Extension -> LSP.TextEdit

@@ -29,7 +29,6 @@   attachReason,   attachedReason) where -import           Control.Applicative            ((<|>)) import           Control.DeepSeq import           Control.Lens import qualified Data.Aeson                     as JSON

@@ -15,7 +15,6 @@ import           Control.Monad.Extra             (eitherM, join, mapMaybeM) import           Data.Either                     (fromRight) import           Data.IORef-import qualified Data.Map                        as M import           Data.Unique                     (Unique) import qualified Data.Unique                     as Unique import           Development.IDE.GHC.Compat      hiding (newUnique)@@ -25,9 +24,7 @@ import           Development.IDE.Graph.Classes import           Development.IDE.Types.Exports   (ExportsMap, createExportsMap) import           GHC.Driver.Env                  (hsc_all_home_unit_ids)-import           Ide.PluginUtils                 (toAbsolute) import           OpenTelemetry.Eventlog          (withSpan)-import           System.Directory                (makeAbsolute)   -- | An 'HscEnv' with equality. Two values are considered equal@@ -54,7 +51,6 @@ newHscEnvEq hscEnv' = do      mod_cache <- newIORef emptyInstalledModuleEnv-    file_cache <- newIORef M.empty     -- This finder cache is for things which are outside of things which are tracked     -- by HLS. For example, non-home modules, dependent object files etc #if MIN_VERSION_ghc(9,11,0)

@@ -19,49 +19,29 @@ import           GHC.Generics  -- | A mapping of module name to known files-data KnownTargets = KnownTargets-  { targetMap      :: !(HashMap Target (HashSet NormalizedFilePath))-  -- | 'normalisingMap' is a cached copy of `HMap.mapKey const targetMap`-  ---  -- At startup 'GetLocatedImports' is called on all known files. Say you have 10000-  -- modules in your project then this leads to 10000 calls to 'GetLocatedImports'-  -- running concurrently.-  ---  -- In `GetLocatedImports` the known targets are consulted and the targetsMap-  -- is created by mapping the known targets. This map is used for introducing-  -- sharing amongst filepaths.  This operation copies a local copy of the `target`-  --  map which is local to the rule.-  ---  -- @-  -- let targetsMap = HMap.mapWithKey const targets-  -- @-  ---  -- So now each rule has a 'HashMap' of size 10000 held locally to it and depending-  -- on how the threads are scheduled there will be 10000^2 elements in total-  -- allocated in 'HashMap's. This used a lot of memory.-  ---  -- Solution: Return the 'normalisingMap' in the result of the `GetKnownTargets` rule so it is shared across threads.-  , normalisingMap :: !(HashMap Target Target) } deriving Show+newtype KnownTargets = KnownTargets+  { targetMap :: (HashMap Target (HashSet NormalizedFilePath)) }+  deriving Show   unionKnownTargets :: KnownTargets -> KnownTargets -> KnownTargets-unionKnownTargets (KnownTargets tm nm) (KnownTargets tm' nm') =-  KnownTargets (HMap.unionWith (<>) tm tm') (HMap.union nm nm')+unionKnownTargets (KnownTargets tm) (KnownTargets tm') =+  KnownTargets (HMap.unionWith (<>) tm tm')  mkKnownTargets :: [(Target, HashSet NormalizedFilePath)] -> KnownTargets-mkKnownTargets vs = KnownTargets (HMap.fromList vs) (HMap.fromList [(k,k) | (k,_) <- vs ])+mkKnownTargets vs = KnownTargets (HMap.fromList vs)  instance NFData KnownTargets where-  rnf (KnownTargets tm nm) = rnf tm `seq` rnf nm `seq` ()+  rnf (KnownTargets tm) = rnf tm `seq` ()  instance Eq KnownTargets where   k1 == k2 = targetMap k1 == targetMap k2  instance Hashable KnownTargets where-  hashWithSalt s (KnownTargets hm _) = hashWithSalt s hm+  hashWithSalt s (KnownTargets hm) = hashWithSalt s hm  emptyKnownTargets :: KnownTargets-emptyKnownTargets = KnownTargets HMap.empty HMap.empty+emptyKnownTargets = KnownTargets HMap.empty  data Target = TargetModule ModuleName | TargetFile NormalizedFilePath   deriving ( Eq, Ord, Generic, Show )