ghcide 2.14.0.0 → 2.15.0.0

raw patch · 31 files changed

+1235/−469 lines, 31 filesdep ~hie-biosdep ~hls-graphdep ~hls-plugin-apiPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: hie-bios, hls-graph, hls-plugin-api

API changes (from Hackage documentation)

Files

• ghcide.cabal +6/−5
• session-loader/Development/IDE/Session.hs +122/−35
• session-loader/Development/IDE/Session/Ghc.hs +55/−21
• session-loader/Development/IDE/Session/Implicit.hs +3/−3
• src/Development/IDE/Core/Compile.hs +167/−126
• src/Development/IDE/Core/FileExists.hs +1/−0
• src/Development/IDE/Core/FileStore.hs +15/−4
• src/Development/IDE/Core/PluginUtils.hs +19/−9
• src/Development/IDE/Core/RuleTypes.hs +55/−16
• src/Development/IDE/Core/Rules.hs +248/−75
• src/Development/IDE/Core/Shake.hs +78/−13
• src/Development/IDE/Core/Text.hs +19/−0
• src/Development/IDE/GHC/Compat/Core.hs +6/−5
• src/Development/IDE/GHC/Compat/Error.hs +30/−0
• src/Development/IDE/GHC/Compat/Logger.hs +1/−1
• src/Development/IDE/GHC/Compat/Outputable.hs +0/−2
• src/Development/IDE/GHC/CoreFile.hs +6/−1
• src/Development/IDE/GHC/Util.hs +5/−0
• src/Development/IDE/GHC/Warnings.hs +2/−1
• src/Development/IDE/Import/DependencyInformation.hs +25/−6
• src/Development/IDE/Import/FindImports.hs +154/−87
• src/Development/IDE/LSP/Notifications.hs +22/−5
• src/Development/IDE/Main.hs +24/−1
• src/Development/IDE/Plugin/Completions.hs +5/−1
• src/Development/IDE/Plugin/Completions/Logic.hs +2/−2
• src/Development/IDE/Spans/AtPoint.hs +4/−14
• src/Development/IDE/Spans/Documentation.hs +47/−14
• src/Development/IDE/Types/Diagnostics.hs +1/−1
• src/Development/IDE/Types/HscEnvEq.hs +13/−9
• src/Development/IDE/Types/KnownTargets.hs +76/−11
• src/Development/IDE/Types/Options.hs +24/−1

@@ -2,7 +2,7 @@ build-type:         Simple category:           Development name:               ghcide-version:            2.14.0.0+version:            2.15.0.0 license:            Apache-2.0 license-file:       LICENSE author:             Digital Asset and Ghcide contributors@@ -63,7 +63,7 @@     , edit-distance     , enummapset     , exceptions-    , extra                        >=1.7.14+    , extra                        >=1.8     , filepath     , fingertree     , focus                        >=1.0.3.2@@ -74,10 +74,10 @@     , Glob     , haddock-library              >=1.8      && <1.12     , hashable-    , hie-bios                     ^>= 0.19.0+    , hie-bios                     ^>= 0.21.0     , hiedb                        ^>= 0.8.0.0-    , hls-graph                    == 2.14.0.0-    , hls-plugin-api               == 2.14.0.0+    , hls-graph                    == 2.15.0.0+    , hls-plugin-api               == 2.15.0.0     , implicit-hie                 >= 0.1.4.0 && < 0.1.5     , lens     , lens-aeson@@ -142,6 +142,7 @@     Development.IDE.Core.RuleTypes     Development.IDE.Core.Service     Development.IDE.Core.Shake+    Development.IDE.Core.Text     Development.IDE.Core.Tracing     Development.IDE.Core.UseStale     Development.IDE.Core.WorkerThread

@@ -9,6 +9,7 @@   ,loadSessionWithOptions   ,getInitialGhcLibDirDefault   ,getHieDbLoc+  ,getHieDbLocIn   ,retryOnSqliteBusy   ,retryOnException   ,SessionLoaderPendingBarrierVar(..)@@ -55,7 +56,7 @@ import qualified Development.IDE.Session.Implicit    as GhcIde import           Development.IDE.Types.Diagnostics import           Development.IDE.Types.Exports-import           Development.IDE.Types.HscEnvEq      (HscEnvEq)+import           Development.IDE.Types.HscEnvEq      (HscEnvEq, hscEnv) import           Development.IDE.Types.Location import           Development.IDE.Types.Options import qualified HIE.Bios                            as HieBios@@ -71,7 +72,7 @@                                                       vcat, viaShow, (<+>)) import           Ide.Types                           (Config,                                                       SessionLoadingPreferenceConfig (..),-                                                      sessionLoading)+                                                      componentsLoading) import           Language.LSP.Protocol.Message import           Language.LSP.Server import           System.Directory@@ -380,11 +381,17 @@  getHieDbLoc :: FilePath -> IO FilePath getHieDbLoc dir = do+  cDir <- IO.getXdgDirectory IO.XdgCache cacheDir+  getHieDbLocIn cDir dir++-- | Like 'getHieDbLoc', but roots the database under @base@ instead of+-- @XDG_CACHE_HOME@.+getHieDbLocIn :: FilePath -> FilePath -> IO FilePath+getHieDbLocIn base 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)+  createDirectoryIfMissing True base+  pure (base </> db)  -- Note [SessionState and batch load] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -394,6 +401,8 @@ -- - 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).+--   Only files owned by the same cradle (the same @hie.yaml@) as the file being+--   loaded are batched together; see 'getExtraFilesToLoad'. -- -- On success: --   - (SBL3) All successfully loaded files are removed from 'pendingFiles' and 'failedFiles',@@ -530,6 +539,11 @@ insertFileMapping state hieYaml ncfp =   STM.insert hieYaml ncfp (filesMap state) +-- | Same as 'insertFileMapping', but never overwrites an existing value.+insertFileMappingIfMissing :: SessionState -> Maybe FilePath -> NormalizedFilePath -> STM ()+insertFileMappingIfMissing state hieYaml ncfp =+  STM.focus (Focus.alter (<|> Just hieYaml)) ncfp (filesMap state)+ -- | Remove a file from the pending file set removeFromPending :: SessionState -> FilePath -> STM () removeFromPending state file =@@ -573,18 +587,27 @@ -- -- 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+--+-- Only files already known to belong to the same cradle as the current file are+-- returned. Handing files owned by a different cradle to a multi-component load+-- makes the build tool fail wholesale — e.g. cabal cannot map the foreign files+-- to any component of this cradle — which poisons the load of the current file.+getExtraFilesToLoad :: SessionState -> Maybe FilePath -> FilePath -> IO [FilePath]+getExtraFilesToLoad state hieYaml 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+  let candidates =+        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+  filterM ownedByThisCradle (Set.toList candidates)+  where+    ownedByThisCradle file = do+      owner <- atomically $ STM.lookup (toNormalizedFilePath' file) (filesMap state)+      pure $ owner == Just hieYaml  -- | We allow users to specify a loading strategy. -- Check whether this config was changed since the last time we have loaded@@ -599,11 +622,11 @@     mLoadingConfig <- liftIO $ readVar biosSessionLoadingVar     case mLoadingConfig of         Nothing -> do-            liftIO $ writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig))+            liftIO $ writeVar biosSessionLoadingVar (Just (componentsLoading clientConfig))             pure False         Just loadingConfig -> do-            liftIO $ writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig))-            pure (loadingConfig /= sessionLoading clientConfig)+            liftIO $ writeVar biosSessionLoadingVar (Just (componentsLoading clientConfig))+            pure (loadingConfig /= componentsLoading clientConfig)  newSessionState :: IO SessionState newSessionState = do@@ -693,14 +716,14 @@     let absolutePathsCradleDeps (eq, deps) = (eq, fmap toAbsolutePath $ Map.keys deps)     returnWithVersion $ \file -> do       let absFile = toAbsolutePath file-      absolutePathsCradleDeps <$> lookupOrWaitCache recorder sessionState absFile+      absolutePathsCradleDeps <$> lookupOrWaitCache recorder sessionState cradleLoc 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+lookupOrWaitCache :: Recorder (WithPriority Log) -> SessionState -> (FilePath -> IO (Maybe FilePath)) -> FilePath -> IO (IdeResult HscEnvEq, DependencyInfo)+lookupOrWaitCache recorder sessionState cradleLoc absFile = do   let ncfp = toNormalizedFilePath' absFile   cacheResult <- maybeM     (return Nothing)@@ -718,8 +741,14 @@     Just r -> return r     Nothing -> do       -- if not ok, we need to reload the session-      atomically $ addToPending sessionState absFile-      lookupOrWaitCache recorder sessionState absFile+      hieYaml <- cradleLoc absFile+      atomically $ do+        -- Insert the mapping into filesMap so the cradle is known up-front.+        -- This ensures we are able to batch requests belonging to the same+        -- cradle.+        insertFileMappingIfMissing sessionState hieYaml ncfp+        addToPending sessionState absFile+      lookupOrWaitCache recorder sessionState cradleLoc absFile  checkInCache :: SessionState -> NormalizedFilePath -> STM (Maybe (IdeResult HscEnvEq, DependencyInfo)) checkInCache sessionState ncfp = runMaybeT $ do@@ -933,6 +962,19 @@   liftIO $ modifyVar (hscEnvs sessionState) $     addComponentInfo (cmapWithPrio LogSessionGhc recorder) getCacheDirs dep_info newTargetDfs (hieYaml, cfp, opts) +{- Note [Modules the build tool has not been told about]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Writing a module and adding it to the cabal file are two steps, so we+constantly see files that exist and are already imported but are not a target+of any component. If we refuse to load such a file it gets no session at all,+and the modules importing it fail to typecheck without reporting anything.++We treat a file below an import path of a component as a module of that+component, because that is what GHC does: its finder searches the -i+directories and never the target list, and a module missing from the targets is+a warning (-Wmissing-home-modules), not an error. A file below no import path+is still an error, we have no options to compile it with.+-} 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')@@ -942,17 +984,61 @@         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+                this_target_details = TargetDetails (TargetFile cfp) this_env this_dep_info [cfp]+                this_flags = (this_env, this_dep_info)+                -- See Note [Modules the build tool has not been told about]+                this_env = case owningComponent all_targets' cfp of+                  Just env -> (missingHomeModuleWarning env cfp, Just env)+                  Nothing  -> ([noTargetError], Nothing)+                noTargetError =+                  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) +-- | -Wmissing-home-modules. GHC only emits it from the driver, which we do not+-- use, so we emit it ourselves.+missingHomeModuleWarning :: HscEnvEq -> NormalizedFilePath -> [FileDiagnostic]+missingHomeModuleWarning env cfp+  | not (wopt Opt_WarnMissingHomeModules dflags) = []+  | otherwise =+      [ ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Warning) cfp+          (T.unlines [message, "It is being compiled with the options of that component."])+          Nothing+      ]+  where+    dflags = hsc_dflags $ hscEnv env+    unit = T.pack $ unitIdString $ homeUnitId_ dflags+    message+      | gopt Opt_BuildingCabalPackage dflags =+          "This module is needed for compilation but not listed in your .cabal file's \+          \other-modules or exposed-modules for '" <> unit <> "'."+      | otherwise =+          "This module is not listed in the options for '" <> unit+            <> "' but needed for compilation."++-- | The component with an import path the file is below. If several match we+-- take the most specific one, the one giving the shortest relative path.+-- See Note [Modules the build tool has not been told about]+owningComponent :: [TargetDetails] -> NormalizedFilePath -> Maybe HscEnvEq+owningComponent targets cfp =+  listToMaybe [ env | (_, env) <- sortOn (length . splitDirectories . fst) candidates ]+  where+    file = fromNormalizedFilePath cfp+    -- makeRelative gives back the file unchanged if it is not below the+    -- directory. Both paths are absolute, so this is unambiguous.+    candidates =+      [ (rel, env)+      | td <- targets+      , Just env <- [snd (targetEnv td)]+      , importPath <- importPaths $ hsc_dflags $ hscEnv env+      , let rel = makeRelative (normalise importPath) file+      , rel /= file+      ]+ -- | 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@@ -1018,8 +1104,8 @@   let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle))                 <> " (for " <> T.pack lfpLog <> ")" -  sessionPref <- asks (sessionLoading . sessionClientConfig)-  extraToLoads <- liftIO $ getExtraFilesToLoad sessionState cfp+  sessionPref <- asks (componentsLoading . sessionClientConfig)+  extraToLoads <- liftIO $ getExtraFilesToLoad sessionState hieYaml cfp   -- Start loading the file!   eopts <- mRunLspTCallback lspEnv (\act -> withIndefiniteProgress progMsg Nothing NotCancellable (const act)) $     withTrace "Load cradle" $ \addTag -> do@@ -1040,7 +1126,7 @@     --     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+    cradleRes <- HieBios.getCompilerOptions (TargetWithContext file old_fps) loadStyle cradle     case cradleRes of         CradleSuccess r -> do             -- Now get the GHC lib dir@@ -1061,8 +1147,9 @@      where         loadStyle = case loadConfig of-            PreferSingleComponentLoading -> LoadFile-            PreferMultiComponentLoading  -> LoadWithContext old_fps+            PreferSingleComponentLoading   -> LoadFile+            PreferMultiComponentLoading    -> LoadFileWithContext+            PreferMultiWholeProjectLoading -> LoadUnitsFromCradle  -- ---------------------------------------------------------------------------- -- Utilities

@@ -150,7 +150,7 @@          -> [ComponentInfo]    -- ^ New components to be loaded          -> [ComponentInfo]    -- ^ old, already existing components          -> IO [ [TargetDetails] ]-newComponentCache recorder exts _cfp hsc_env old_cis new_cis = do+newComponentCache recorder exts cfp hsc_env old_cis new_cis = do     let cis = Map.unionWith unionCIs (mkMap new_cis) (mkMap old_cis)         -- When we have multiple components with the same uid,         -- prefer the new one over the old.@@ -172,7 +172,7 @@ #endif         closure_err_to_multi_err err =             ideErrorWithSource-                (Just "cradle") (Just DiagnosticSeverity_Warning) _cfp+                (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@@ -198,6 +198,15 @@         Nothing  -> pure ()         Just err -> logWith recorder Error $ LogDLLLoadError err +    -- A session representative file of this load. See Note [Session representatives]+    -- Not cfp which may be an error target.+    let repr = fromMaybe cfp $ listToMaybe+          [ loc+          | ci <- Map.elems cis+          , t <- componentTargets ci+          , loc <- targetIdLocations (importPaths (componentDynFlags ci)) exts (targetId t)+          ]+     forM (Map.elems cis) $ \ci -> do       let df = componentDynFlags ci       thisEnv <- do@@ -205,7 +214,7 @@             -- above.             -- We just need to set the current unit here             pure $ hscSetActiveUnitId (homeUnitId_ df) hscEnv'-      henv <- newHscEnvEq thisEnv+      henv <- newHscEnvEq repr thisEnv       let targetEnv = (if isBad ci then multi_errs else [], Just henv)           targetDepends = componentDependencyInfo ci       logWith recorder Debug $ LogNewComponentCache (targetEnv, targetDepends)@@ -280,6 +289,7 @@               Nothing   -> compRoot               Just wdir -> compRoot </> wdir         let dflags''' =+              normaliseImportsPaths $               setWorkingDirectory root $               disableWarningsAsErrors $               -- disabled, generated directly by ghcide instead@@ -296,6 +306,9 @@               dflags''         return (HomeUnitConfig dflags''' targets mHash) +normaliseImportsPaths :: DynFlags -> DynFlags+normaliseImportsPaths dflags = dflags { importPaths = fmap normalise (importPaths dflags)}+ addComponentInfo ::   MonadUnliftIO m =>   Recorder (WithPriority Log) ->@@ -450,9 +463,20 @@ -- 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+    base <- getXdgDirectory XdgCache cacheDir+    pure $ cacheDirsUnder base prefix mFirstHash opts++-- | Like 'getCacheDirsDefault', but roots the cache under @base@ instead of+-- 'XdgCache', so callers can isolate a cache without touching @XDG_CACHE_HOME@.+getCacheDirsIn :: FilePath -> String -> Maybe B.ByteString -> [String] -> CacheDirs+getCacheDirsIn base prefix mFirstHash opts =+    cacheDirsUnder (base </> cacheDir) prefix mFirstHash opts++-- | The per-component cache folder under @base@. See 'getCacheDirsDefault'.+cacheDirsUnder :: FilePath -> String -> Maybe B.ByteString -> [String] -> CacheDirs+cacheDirsUnder base prefix mFirstHash opts = CacheDirs dir dir dir     where+        dir = Just (base </> prefix' ++ "-" ++ opts_hash)         -- Create a unique folder per set of different GHC options.         prefix' = if isJust mFirstHash then "main" else prefix         basectx = case mFirstHash of@@ -487,28 +511,38 @@       targetLocations :: ![NormalizedFilePath]   } +-- | Candidate locations of a target, in search order.+targetIdLocations :: [FilePath]     -- ^ import paths+                  -> [String]       -- ^ extensions to consider+                  -> TargetId+                  -> [NormalizedFilePath]+-- For a target module we consider all the import paths+targetIdLocations is exts (GHC.TargetModule modName) =+    [ toNormalizedFilePath' (i </> moduleNameSlashes modName -<.> ext <> boot)+    | ext <- exts+    , i <- is+    , boot <- ["", "-boot"]+    ]+-- For a 'TargetFile' we consider all the possible module names+targetIdLocations _ _ (GHC.TargetFile f _) = [nf, other]+  where+    nf = toNormalizedFilePath' f+    other+      | "-boot" `isSuffixOf` f = toNormalizedFilePath' (L.dropEnd 5 $ fromNormalizedFilePath nf)+      | otherwise = toNormalizedFilePath' (fromNormalizedFilePath nf ++ "-boot")+ 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]]+fromTargetId is exts tid env dep =+    return [TargetDetails target env dep (targetIdLocations is exts tid)]+  where+    target = case tid of+      GHC.TargetModule modName -> TargetModule modName+      GHC.TargetFile f _       -> TargetFile (toNormalizedFilePath' f)  -- ---------------------------------------------------------------------------- -- Backwards compatibility

@@ -78,12 +78,12 @@   pkgsWithComps <- liftIO $ catMaybes <$> mapM (nestedPkg fp) pkgs   let yaml = fp </> "stack.yaml"   pure $ (,fp) $ case pkgsWithComps of-    [] -> Stack (StackType Nothing (Just yaml))+    [] -> Stack (StackType Nothing (Just yaml) Nothing)     ps -> StackMulti mempty $ do       Package n cs <- ps       c <- cs       let (prefix, comp) = Implicit.stackComponent n c-      pure (prefix, StackType (Just comp) (Just yaml))+      pure (prefix, StackType (Just comp) (Just yaml) Nothing)  -- | By default, we generate a simple cabal cradle which is equivalent to the -- following hie.yaml:@@ -95,7 +95,7 @@ -- -- Note, this only works reliable for reasonably modern cabal versions >= 3.2. simpleCabalCradle :: FilePath -> (CradleTree a, FilePath)-simpleCabalCradle fp = (Cabal $ CabalType Nothing Nothing, fp)+simpleCabalCradle fp = (Cabal $ CabalType Nothing Nothing Nothing, fp)  cabalExecutable :: MaybeT IO FilePath cabalExecutable = MaybeT $ findExecutable "cabal"

@@ -18,6 +18,8 @@   , mkHiFileResultNoCompile   , generateObjectCode   , generateByteCode+  , LinkableFingerprint (..)+  , mkLinkableFingerprint   , generateHieAsts   , writeAndIndexHieFile   , indexHieFile@@ -40,8 +42,7 @@   ) where  import           Control.Concurrent.STM.Stats                 hiding (orElse)-import           Control.DeepSeq                              (NFData (..),-                                                               force, rnf)+import qualified Control.DeepSeq                              as DeepSeq import           Control.Exception                            (evaluate) import           Control.Exception.Safe import           Control.Lens                                 hiding (List, pre,@@ -67,7 +68,9 @@ import           Data.Maybe import           Data.Proxy                                   (Proxy (Proxy)) import qualified Data.Text                                    as T-import           Data.Time                                    (UTCTime (..))+import           Data.Time                                    (Day (ModifiedJulianDay),+                                                               UTCTime (..),+                                                               picosecondsToDiffTime) import           Data.Tuple.Extra                             (dupe) import           Debug.Trace import           Development.IDE.Core.FileStore               (resetInterfaceStore)@@ -110,12 +113,13 @@ import qualified GHC                                          as G import           GHC.Core.Lint.Interactive import           GHC.Driver.Config.CoreToStg.Prep+import           GHC.Driver.Env                               (runHsc')+import           GHC.Driver.Main                              (hscDesugar', hscSimplify') import           GHC.Iface.Ext.Types                          (HieASTs) import qualified GHC.Runtime.Loader                           as Loader import           GHC.Tc.Gen.Splice import           GHC.Types.Error import           GHC.Types.ForeignStubs-import           GHC.Types.HpcInfo import           GHC.Types.TypeEnv  -- See Note [Guidelines For Using CPP In GHCIDE Import Statements]@@ -143,6 +147,10 @@                                                                writeHieFile) #endif +#if !MIN_VERSION_ghc(9,11,0)+import           GHC.Types.HpcInfo                            (emptyHpcInfo)+#endif+ #if MIN_VERSION_ghc(9,11,0) import qualified Data.List.NonEmpty                           as NE import           Data.Time                                    (getCurrentTime)@@ -156,7 +164,6 @@ import           GHC.Unit.Home.PackageTable                   (hptInternalTableRef, hptInternalTableFromRef) import           GHC.Unit.Module.ModIface                     (IfaceTopEnv(..)) import           GHC.Types.Avail                              (emptyDetOrdAvails)-import           GHC.Types.Basic                              (ImportLevel(..), convImportLevel) #endif  #if MIN_VERSION_ghc(9,12,0)@@ -180,7 +187,7 @@     fmap (either (, Nothing) id) $     runExceptT $ do         (diag, modu) <- parseFileContents env optPreprocessor filename ms-        return (diag, Just modu)+        pure (diag, Just modu)   -- | Given a package identifier, what packages does it depend on@@ -191,12 +198,12 @@ computePackageDeps env pkg = do     case lookupUnit env pkg of         Nothing ->-          return $ Left+          pure $ Left             [ ideErrorText                 (toNormalizedFilePath' noFilePath)                 (T.pack $ "unknown package: " ++ show pkg)             ]-        Just pkgInfo -> return $ Right $ unitDepends pkgInfo+        Just pkgInfo -> pure $ Right $ unitDepends pkgInfo  data TypecheckHelpers   = TypecheckHelpers@@ -215,7 +222,7 @@         initialized <- catchSrcErrors (hsc_dflags hsc) "typecheck (initialize plugins)"                                       (Loader.initializePlugins (hscSetFlags (ms_hspp_opts modSummary) hsc))         case initialized of-          Left errs -> return (errs, Nothing)+          Left errs -> pure (errs, Nothing)           Right hscEnv -> do             etcm <-                 let@@ -225,7 +232,7 @@                   catchSrcErrors (hsc_dflags hscEnv) sourceTypecheck $ do                     tcRnModule hscEnv tc_helpers $ demoteIfDefer pm{pm_mod_summary = mod_summary'}             case etcm of-              Left errs -> return (errs, Nothing)+              Left errs -> pure (errs, Nothing)               Right tcm ->                 let addReason diag =                       map (Just (diagnosticReason (errMsgDiagnostic diag)),) $@@ -234,7 +241,7 @@                     diags = concatMap errorPipeline $ Compat.getMessages $ tmrWarnings tcm                     deferredError = any fst diags                 in-                return (map snd diags, Just $ tcm{tmrDeferredError = deferredError})+                pure (map snd diags, Just $ tcm{tmrDeferredError = deferredError})     where         demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id @@ -246,7 +253,7 @@   res <- k (hscSetHooks (addSpliceHook splice_ref . addLinkableDepHook dep_ref $ hsc_hooks env) env)   splices <- readIORef splice_ref   needed_mods <- readIORef dep_ref-  return (res, splices, needed_mods)+  pure (res, splices, needed_mods)   where     addLinkableDepHook :: IORef (ModuleEnv BS.ByteString) -> Hooks -> Hooks     addLinkableDepHook var h = h { hscCompileCoreExprHook = Just (compile_bco_hook var) }@@ -358,7 +365,7 @@ #endif             ; modifyIORef' var (flip extendModuleEnvList [(mi_module $ hm_iface hm, linkableHash lb) | lb <- lbs, let hm = linkableHomeMod lb])-           ; return hval }+           ; pure hval }      -- TODO: support backpack     nodeKeyToInstalledModule :: NodeKey -> Maybe InstalledModule@@ -524,7 +531,7 @@                                   (tcg_import_decls (tmrTypechecked tcm))                                   simplified_guts #else-  let !partial_iface = force $ mkPartialIface session+  let !partial_iface = DeepSeq.force $ mkPartialIface session                                               (cg_binds guts)                                               details                                               ms@@ -550,30 +557,25 @@                       {mi_globals = Nothing, mi_usages = filterUsages (mi_usages final_iface')} #endif -  -- Write the core file now-  core_file <- do+  -- Write the core file now.+  core_hash <- do         let core_fp  = ml_core_file $ ms_location ms             core_file = codeGutsToCoreFile iface_hash guts             iface_hash = getModuleHash final_iface-        core_hash1 <- atomicFileWrite se core_fp $ \fp ->+        _ <- atomicFileWrite se core_fp $ \fp ->           writeBinCoreFile (hsc_dflags session) fp core_file-        -- We want to drop references to guts and read in a serialized, compact version-        -- of the core file from disk (as it is deserialised lazily)-        -- This is because we don't want to keep the guts in memory for every file in-        -- the project as it becomes prohibitively expensive-        -- The serialized file however is much more compact and only requires a few-        -- hundred megabytes of memory total even in a large project with 1000s of-        -- modules-        (coreFile, !core_hash2) <- readBinCoreFile (mkUpdater $ hsc_NC session) core_fp-        pure $ assert (core_hash1 == core_hash2)-             $ Just (coreFile, fingerprintToBS core_hash2)+        -- Only keep around a hash of the file and load in the core file from+        -- disk when needed.+        !hash <- readBinCoreFileHash core_fp+        pure $ Just $! fingerprintToBS hash    -- Verify core file by roundtrip testing and comparison   IdeOptions{optVerifyCoreFile} <- getIdeOptionsIO se-  case core_file of-    Just (core, _) | optVerifyCoreFile -> do+  case core_hash of+    Just _ | optVerifyCoreFile -> do       let core_fp = ml_core_file $ ms_location ms       traceIO $ "Verifying " ++ core_fp+      (core, _) <- readBinCoreFile (mkUpdater $ hsc_NC session) core_fp       let CgGuts{cg_binds = unprep_binds, cg_tycons = tycons } = guts           mod = ms_mod ms           data_tycons = filter isAlgTyCon tycons@@ -633,15 +635,15 @@         panicDoc "verify core failed!" (vcat $ punctuate (text "\n\n") diffs) -- ++ [ppr binds , ppr binds']))     _ -> pure () -  pure ([], Just $! mkHiFileResult ms final_iface details (tmrRuntimeModules tcm) core_file)+  pure ([], Just $! mkHiFileResult ms final_iface details (tmrRuntimeModules tcm) core_hash)    where     dflags = hsc_dflags session'     source = "compile"     catchErrs x = x `catches`-      [ Handler $ return . (,Nothing) . diagFromGhcException source dflags+      [ Handler $ pure . (,Nothing) . diagFromGhcException source dflags       , Handler $ \diag ->-          return+          pure             ( diagFromString                 source DiagnosticSeverity_Error (noSpan "<internal>")                 ("Error during " ++ T.unpack source ++ show @SomeException diag)@@ -665,36 +667,62 @@     -> TcGblEnv     -> IO (IdeResult ModGuts) compileModule (RunSimplifier simplify) session ms tcg =-    fmap (either (, Nothing) (second Just)) $-        catchSrcErrors (hsc_dflags session) "compile" $ do-            (warnings,desugared_guts) <- withWarnings "compile" $ \tweak -> do-                 -- Breakpoints don't survive roundtripping from disk-                 -- and this trips up the verify-core-files check-                 -- They may also lead to other problems.-                 -- We have to setBackend ghciBackend in 9.8 as otherwise-                 -- non-exported definitions are stripped out.-                 -- However, setting this means breakpoints are generated.-                 -- Solution: prevent breakpoing generation by unsetting-                 -- Opt_InsertBreakpoints-               let session' = tweak $ flip hscSetFlags session+  catchSrcErrors (hsc_dflags session) compilePhase compileAction+       >>= \case Left diags             -> pure (diags, Nothing)+                 Right (diags, modGuts) -> pure (diags, Just modGuts)+  where+    compilePhase = "compile"+    compileAction = do+        -- Breakpoints don't survive roundtripping from disk+        -- and this trips up the verify-core-files check+        -- They may also lead to other problems.+        -- We have to setBackend ghciBackend in 9.8 as otherwise+        -- non-exported definitions are stripped out.+        -- However, setting this means breakpoints are generated.+        -- Solution: prevent breakpoing generation by unsetting+        -- Opt_InsertBreakpoints+      let session' = flip hscSetFlags session #if MIN_VERSION_ghc(9,7,0)-                                    $ flip gopt_unset Opt_InsertBreakpoints-                                    $ setBackend ghciBackend+                   $ flip gopt_unset Opt_InsertBreakpoints+                   $ setBackend ghciBackend #endif-                                    $ ms_hspp_opts ms-               -- TODO: maybe settings ms_hspp_opts is unnecessary?-               -- MP: the flags in ModSummary should be right, if they are wrong then-               -- the correct place to fix this is when the ModSummary is created.-               desugar <- hscDesugar session' (ms { ms_hspp_opts = hsc_dflags session' }) tcg-               if simplify-               then do-                 plugins <- readIORef (tcg_th_coreplugins tcg)-                 hscSimplify session' plugins desugar-               else pure desugar-            return (map snd warnings, desugared_guts)+                   $ ms_hspp_opts ms+      -- TODO: maybe settings ms_hspp_opts is unnecessary?+      -- MP: the flags in ModSummary should be right, if they are wrong then+      -- the correct place to fix this is when the ModSummary is created.+      (desugar, msgs) <- do+         runHsc' session' $ do+           desugar <- hscDesugar' (ms_location (ms { ms_hspp_opts = hsc_dflags session' })) tcg+           if simplify+             then do+               plugins <- liftIO $ readIORef (tcg_th_coreplugins tcg)+               hscSimplify' plugins desugar+             else pure desugar+      pure (diagFromErrMsgs compilePhase (hsc_dflags session') $ getWarningMessages msgs, desugar) -generateObjectCode :: HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable)-generateObjectCode session summary guts = do++-- | A horrible hack+-- GHC identifies Linkables using their UTCTime (when they were generated)+-- This is insufficient for our needs, we need to identify linkables by a fingerprint containing+-- both the hash of the linkable itself as well as all of all of its dependencies+--+-- UTCTime has an unbounded integer+-- We can smuggle an arbitary 128 bit fingerprint+-- in the integer+--+-- This way we can ensure we only keep loaded objects (byte/native) with the correct+-- transitive closure.+--+-- This is fine because GHC only uses the time for identity+newtype LinkableFingerprint = LinkableFingerprint UTCTime++mkLinkableFingerprint :: Util.Fingerprint -> LinkableFingerprint+mkLinkableFingerprint (Util.Fingerprint a b) =+  LinkableFingerprint $ UTCTime (ModifiedJulianDay 0) $ picosecondsToDiffTime $+    toInteger a * 2 ^ (64 :: Int) + toInteger b++generateObjectCode :: LinkableFingerprint -> HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable)+generateObjectCode (LinkableFingerprint linkable_fp) session summary guts = do     fmap (either (, Nothing) (second Just)) $           catchSrcErrors (hsc_dflags session) "object" $ do               let dot_o =  ml_obj_file (ms_location summary)@@ -716,19 +744,15 @@                       case obj of                         Nothing -> throwGhcExceptionIO $ Panic "compileFile didn't generate object code"                         Just x -> pure x-              -- Need time to be the modification time for recompilation checking-              t <- liftIO $ getModificationTime dot_o_fp #if MIN_VERSION_ghc(9,11,0)-              let linkable = Linkable t mod (pure $ DotO dot_o_fp ModuleObject)+              let linkable = Linkable linkable_fp mod (pure $ DotO dot_o_fp ModuleObject) #else-              let linkable = LM t mod [DotO dot_o_fp]+              let linkable = LM linkable_fp mod [DotO dot_o_fp] #endif               pure (map snd warnings, linkable) -newtype CoreFileTime = CoreFileTime UTCTime--generateByteCode :: CoreFileTime -> HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable)-generateByteCode (CoreFileTime time) hscEnv summary guts = do+generateByteCode :: LinkableFingerprint -> HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable)+generateByteCode (LinkableFingerprint linkable_fp) hscEnv summary guts = do     fmap (either (, Nothing) (second Just)) $           catchSrcErrors (hsc_dflags hscEnv) "bytecode" $ do @@ -751,9 +775,9 @@ #endif  #if MIN_VERSION_ghc(9,11,0)-              let linkable = Linkable time (ms_mod summary) (pure $ BCOs bytecode)+              let linkable = Linkable linkable_fp (ms_mod summary) (pure $ BCOs bytecode) #else-              let linkable = LM time (ms_mod summary) [BCOs bytecode sptEntries]+              let linkable = LM linkable_fp (ms_mod summary) [BCOs bytecode sptEntries] #endif                pure (map snd warnings, linkable)@@ -1004,15 +1028,15 @@     atomicFileWrite se targetPath $ \fp ->       writeIfaceFile hscEnv fp modIface   where-    modIface = hirModIface tc-    targetPath = ml_hi_file $ ms_location $ hirModSummary tc+    modIface = hirModIface (hirIface tc)+    targetPath = ml_hi_file $ ms_location $ hirModSummary (hirIface tc)     dflags = hsc_dflags hscEnv  handleGenerationErrors :: DynFlags -> T.Text -> IO () -> IO [FileDiagnostic] handleGenerationErrors dflags source action =-  action >> return [] `catches`-    [ Handler $ return . diagFromGhcException source dflags-    , Handler $ \(exception :: SomeException) -> return $+  action >> pure [] `catches`+    [ Handler $ pure . diagFromGhcException source dflags+    , Handler $ \(exception :: SomeException) -> pure $         diagFromString           source DiagnosticSeverity_Error (noSpan "<internal>")           ("Error during " ++ T.unpack source ++ show exception)@@ -1022,9 +1046,9 @@ handleGenerationErrors' :: DynFlags -> T.Text -> IO (Maybe a) -> IO ([FileDiagnostic], Maybe a) handleGenerationErrors' dflags source action =   fmap ([],) action `catches`-    [ Handler $ return . (,Nothing) . diagFromGhcException source dflags+    [ Handler $ pure . (,Nothing) . diagFromGhcException source dflags     , Handler $ \(exception :: SomeException) ->-        return+        pure           ( diagFromString               source DiagnosticSeverity_Error (noSpan "<internal>")               ("Error during " ++ T.unpack source ++ show exception)@@ -1033,6 +1057,21 @@           )     ] +{- Note [Home modules are resolved by HLS]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Which file provides a home module is decided by 'GetLocatedImports' in the build+graph. We do not want GHC to try looking for the module on its own, as this can+lead to subtle correctness or performance bugs (at best GHC goes looking in the+filesystem for a while, for a module which we've already established doesn't+exist).++To prevent GHC's finder from repeating work we've already done in HLS and to+avoid masking bugs in the HLS finding logic, we poison the hook so that GHC can+never succeed in finding home modules by itself.++Only possible from GHC 9.11, where the finder cache became a set of hooks.+-}+ -- Merge the HPTs, module graphs and FinderCaches -- See Note [GhcSessionDeps] in Development.IDE.Core.Rules -- Add the current ModSummary to the graph, along with the@@ -1055,10 +1094,11 @@                         if moduleUnit im `elem` hsc_all_home_unit_ids env                         then pure ()                         else addToFinderCache (hsc_FC env) im val+                  -- See Note [Home modules are resolved by HLS]                   , lookupFinderCache = \im ->                         if moduleUnit im `elem` hsc_all_home_unit_ids env                         then case lookupModuleFile (im { moduleUnit = RealUnit (Definite $ moduleUnit im) }) dep_info of-                               Nothing -> pure Nothing+                               Nothing -> pure $ Just $ InstalledNotFound [] (Just $ moduleUnit im)                                Just fs -> let ml = fromJust $ do                                                     id <- lookupPathToId (depPathIdMap dep_info) fs                                                     artifactModLocation (idToModLocation (depPathIdMap dep_info) id)@@ -1072,7 +1112,7 @@             }       loadModulesHome extraMods hsc_env' #else-    return $! loadModulesHome extraMods $+    pure $! loadModulesHome extraMods $       let newHug = foldl' mergeHUG (hsc_HUG env) (map hsc_HUG envs) in       (hscUpdateHUG (const newHug) env){           hsc_mod_graph = mg,@@ -1081,10 +1121,11 @@                   if moduleUnit im `elem` hsc_all_home_unit_ids env                   then pure ()                   else addToFinderCache (hsc_FC env) gwib val+            -- See Note [Home modules are resolved by HLS]             , lookupFinderCache = \gwib@(GWIB im _) ->                   if moduleUnit im `elem` hsc_all_home_unit_ids env                   then case lookupModuleFile (im { moduleUnit = RealUnit (Definite $ moduleUnit im) }) dep_info of-                         Nothing -> pure Nothing+                         Nothing -> pure $ Just $ InstalledNotFound [] (Just $ moduleUnit im)                          Just fs -> let ml = fromJust $ do                                               id <- lookupPathToId (depPathIdMap dep_info) fs                                               artifactModLocation (idToModLocation (depPathIdMap dep_info) id)@@ -1103,7 +1144,7 @@           hpt_b <- readIORef . hptInternalTableRef . homeUnitEnv_hpt =<< b           hpt_a <- readIORef . hptInternalTableRef . homeUnitEnv_hpt $ a_v           result <- hptInternalTableFromRef =<< (newIORef $! mergeUDFM hpt_a hpt_b)-          return $! a_v { homeUnitEnv_hpt = result }+          pure $! a_v { homeUnitEnv_hpt = result }         mergeUDFM = plusUDFM_C combineModules         combineModules a b           | HsSrcFile <- mi_hsc_src (hm_iface a) = a@@ -1131,7 +1172,7 @@         ifr = InstalledFound (ms_location ms) im         curFinderCache = Compat.extendInstalledModuleEnv Compat.emptyInstalledModuleEnv im ifr     newFinderCache <- concatFC curFinderCache (map hsc_FC envs)-    return $! loadModulesHome extraMods $+    pure $! loadModulesHome extraMods $       let newHug = foldl' mergeHUG (hsc_HUG env) (map hsc_HUG envs) in       (hscUpdateHUG (const newHug) env){           hsc_FC = newFinderCache,@@ -1207,7 +1248,8 @@          msrImports = implicit_imports ++ imps -        rn_pkg_qual = renameRawPkgQual (hsc_unit_env ppEnv)+        unitEnv = hsc_unit_env ppEnv+        rn_pkg_qual = renameRawPkgQual unitEnv         rn_imps = fmap (\(pk, lmn@(L _ mn)) -> (rn_pkg_qual mn pk, lmn)) #if MIN_VERSION_ghc(9,13,0)         -- In GHC 9.13+, ms_srcimps is just [Located ModuleName] and ms_textual_imps includes ImportLevel@@ -1233,8 +1275,8 @@       -- Force bits that might keep the string buffer and DynFlags alive unnecessarily-    liftIO $ evaluate $ rnf srcImports-    liftIO $ evaluate $ rnf textualImports+    liftIO $ evaluate $ DeepSeq.rnf srcImports+    liftIO $ evaluate $ DeepSeq.rnf textualImports       modLoc <- liftIO $ if mod == mAIN_NAME@@ -1268,34 +1310,31 @@                 , ms_textual_imps = textualImports                 } -    msrFingerprint <- liftIO $ computeFingerprint opts msrModSummary+    msrFingerprint <- liftIO $ computeFingerprint opts unitEnv msrImports msrModSummary     msrHscEnv <- liftIO $ Loader.initializePlugins (hscSetFlags (ms_hspp_opts msrModSummary) ppEnv)-    return ModSummaryResult{..}+    pure ModSummaryResult{..}     where-        -- Compute a fingerprint from the contents of `ModSummary`,+        -- Compute a fingerprint from the `msrImports` and the contents of `ModSummary`,         -- eliding the timestamps, the preprocessed source and other non relevant fields-        computeFingerprint opts ModSummary{..} = do+        computeFingerprint opts unitEnv msrImports ModSummary{..} = do             fingerPrintImports <- fingerprintFromPut $ do                   put $ Util.uniq $ moduleNameFS $ moduleName ms_mod-#if MIN_VERSION_ghc(9,13,0)-                  -- In GHC 9.13+, ms_srcimps is [Located ModuleName] and ms_textual_imps is [(ImportLevel, PkgQual, Located ModuleName)]-                  forM_ ms_srcimps $ \m -> do-                    put $ Util.uniq $ moduleNameFS $ unLoc m-                  forM_ ms_textual_imps $ \(_lvl, mb_p, m) -> do-                    put $ Util.uniq $ moduleNameFS $ unLoc m-                    case mb_p of-                      G.NoPkgQual    -> pure ()-                      G.ThisPkg uid  -> put $ getKey $ getUnique uid-                      G.OtherPkg uid -> put $ getKey $ getUnique uid-#else-                  forM_ (ms_srcimps ++ ms_textual_imps) $ \(mb_p, m) -> do-                    put $ Util.uniq $ moduleNameFS $ unLoc m-                    case mb_p of-                      G.NoPkgQual    -> pure ()-                      G.ThisPkg uid  -> put $ getKey $ getUnique uid-                      G.OtherPkg uid -> put $ getKey $ getUnique uid-#endif-            return $! Util.fingerprintFingerprints $++                  forM_ msrImports $ \(L _ decl) -> do+                      let modName = unLoc $ ideclName decl+                          pkgQual = renameRawPkgQual unitEnv modName (ideclPkgQual decl)++                      put $ Util.uniq $ moduleNameFS modName+                      put $ ideclSource decl == IsBoot++                      case pkgQual of+                          G.NoPkgQual    -> pure ()+                          G.ThisPkg uid  -> put $ getKey $ getUnique uid+                          G.OtherPkg uid -> put $ getKey $ getUnique uid++                      put $ Util.uniq . moduleNameFS . unLoc <$> ideclAs decl++            pure $! Util.fingerprintFingerprints $                     [ Util.fingerprintString fp                     , fingerPrintImports                     , modLocationFingerprint ms_location@@ -1338,7 +1377,7 @@             throwE $ diagFromGhcErrorMessages sourceParser dflags errs          let warnings = diagFromGhcErrorMessages sourceParser dflags warns-        return (warnings, rdr_module)+        pure (warnings, rdr_module)  -- | Given a buffer, flags, and file path, produce a -- parsed module (or errors) and any parse warnings. Does not run any preprocessors@@ -1503,9 +1542,9 @@ -- can be later turned into a proper linkable data IdeLinkable = GhcLinkable !Linkable | CoreLinkable !UTCTime !CoreFile -instance NFData IdeLinkable where-  rnf (GhcLinkable lb)      = rnf lb-  rnf (CoreLinkable time _) = rnf time+instance DeepSeq.NFData IdeLinkable where+  rnf (GhcLinkable lb)      = DeepSeq.rnf lb+  rnf (CoreLinkable time _) = DeepSeq.rnf time  ml_core_file :: ModLocation -> FilePath ml_core_file ml = ml_hi_file ml <.> "core"@@ -1523,7 +1562,7 @@   -> m ([FileDiagnostic], Maybe HiFileResult) loadInterface session ms linkableNeeded RecompilationInfo{..} = do     let sessionWithMsDynFlags = hscSetFlags (ms_hspp_opts ms) session-        mb_old_iface = hirModIface . fst <$> old_value+        mb_old_iface = hirModIface . hirIface . fst <$> old_value          core_file = ml_core_file (ms_location ms)         iface_file = ml_hi_file (ms_location ms)@@ -1541,10 +1580,10 @@         read_result <- liftIO $ readIface read_dflags ncu mod iface_file #endif         case read_result of-          Util.Failed{}        -> return Nothing+          Util.Failed{}        -> pure Nothing           -- important to call `shareUsages` here before checkOldIface           -- consults `mi_usages`-          Util.Succeeded iface -> return $ Just (shareUsages iface)+          Util.Succeeded iface -> pure $ Just (shareUsages iface)      -- If mb_old_iface is nothing then checkOldIface will load it for us     -- given that the source is unmodified@@ -1576,12 +1615,14 @@                Just msg -> do_regenerate msg                Nothing                  | isJust linkableNeeded -> handleErrs $ do-                   (coreFile@CoreFile{cf_iface_hash}, core_hash) <- liftIO $+                   -- Only cf_iface_hash is forced, so the buffer behind the+                   -- lazy cf_bindings is dropped when this returns.+                   (CoreFile{cf_iface_hash}, core_hash) <- liftIO $                      readBinCoreFile (mkUpdater $ hsc_NC session) core_file                    if cf_iface_hash == getModuleHash iface-                   then return ([], Just $ mkHiFileResult ms iface details runtime_deps (Just (coreFile, fingerprintToBS core_hash)))+                   then pure ([], Just $ mkHiFileResult ms iface details runtime_deps (Just $! fingerprintToBS core_hash))                    else do_regenerate (recompBecause "Core file out of date (doesn't match iface hash)")-                 | otherwise -> return ([], Just $ mkHiFileResult ms iface details runtime_deps Nothing)+                 | otherwise -> pure ([], Just $ mkHiFileResult ms iface details runtime_deps Nothing)                  where handleErrs = flip catches                          [Handler $ \(e :: IOException) -> do_regenerate (recompBecause $ "Reading core file failed (" ++ show e ++ ")")                          ,Handler $ \(e :: GhcException) -> case e of@@ -1674,12 +1715,12 @@ #endif                 Nothing [] -coreFileToLinkable :: LinkableType -> HscEnv -> ModSummary -> ModIface -> ModDetails -> CoreFile -> UTCTime -> IO ([FileDiagnostic], Maybe HomeModInfo)+coreFileToLinkable :: LinkableType -> HscEnv -> ModSummary -> ModIface -> ModDetails -> CoreFile -> LinkableFingerprint -> IO ([FileDiagnostic], Maybe HomeModInfo) coreFileToLinkable linkableType session ms iface details core_file t = do   cgi_guts <- coreFileToCgGuts session iface details core_file   (warns, lb) <- case linkableType of-    BCOLinkable    -> fmap (maybe emptyHomeModInfoLinkable justBytecode) <$> generateByteCode (CoreFileTime t) session ms cgi_guts-    ObjectLinkable -> fmap (maybe emptyHomeModInfoLinkable justObjects) <$> generateObjectCode session ms cgi_guts+    BCOLinkable    -> fmap (maybe emptyHomeModInfoLinkable justBytecode) <$> generateByteCode t session ms cgi_guts+    ObjectLinkable -> fmap (maybe emptyHomeModInfoLinkable justObjects) <$> generateObjectCode t session ms cgi_guts   pure (warns, Just $ HomeModInfo iface details lb) -- TODO wz1000 handle emptyHomeModInfoLinkable  -- | Non-interactive, batch version of 'InteractiveEval.getDocs'.@@ -1692,7 +1733,7 @@ getDocsBatch hsc_env _names = do     res <- initIfaceLoad hsc_env $ forM _names $ \name ->         case nameModule_maybe name of-            Nothing -> return (Left $ NameHasNoModule name)+            Nothing -> pure (Left $ NameHasNoModule name)             Just mod -> do              ModIface {                         mi_docs = Just Docs{ docs_mod_hdr = mb_doc_hdr@@ -1705,7 +1746,7 @@                else pure (Right (                                   lookupUniqMap dmap name,                                   lookupWithDefaultUniqMap amap mempty name))-    return $ map (first $ T.unpack . printOutputable) res+    pure $ map (first $ T.unpack . printOutputable) res   where     compiled n =       -- TODO: Find a more direct indicator.@@ -1724,17 +1765,17 @@ lookupName hsc_env name = exceptionHandle $ do   mb_thing <- liftIO $ lookupType hsc_env name   case mb_thing of-    x@(Just _) -> return x+    x@(Just _) -> pure x     Nothing       | x@(Just thing) <- wiredInNameTyThing_maybe name       -> do when (needWiredInHomeIface thing)                  (initIfaceLoad hsc_env (loadWiredInHomeIface name))-            return x+            pure x       | otherwise -> do         res <- initIfaceLoad hsc_env $ importDecl name         case res of-          Util.Succeeded x -> return (Just x)-          _                -> return Nothing+          Util.Succeeded x -> pure (Just x)+          _                -> pure Nothing   where     exceptionHandle x = x `catch` \(_ :: IOEnvFailure) -> pure Nothing 

@@ -6,6 +6,7 @@   , modifyFileExists   , getFileExists   , watchedGlobs+  , allExtensions   , GetFileExists(..)   , Log(..)   )

@@ -307,6 +307,18 @@     atomically $ writeTaskQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles)     void $ restartShakeSession (shakeExtras state) vfs reason [] actionBetweenSession +{- Note [Unique file watcher registration ids]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We send more than one 'client/registerCapability' for watched files: one for+the global source globs, plus one foreach cradle dependency that the globs+do not already cover, see 'addWatchedFileRule'. These are logically distinct+registrations, so they must not share an id.++LSP leaves the meaning of a repeated id undefined. emacs' eglot unregisters the+old watches before re-registering, while neovim and vscode accumulate. We derive+the id from the globs to keep them distinct and idempotent, while supporting+potentially de-registering in the future.+-} registerFileWatches :: [String] -> LSP.LspT Config IO Bool registerFileWatches globs = do       watchSupported <- isWatchSupported@@ -314,12 +326,11 @@       then do         let           regParams    = LSP.RegistrationParams  [toUntypedRegistration registration]-          -- The registration ID is arbitrary and is only used in case we want to deregister (which we won't).-          -- We could also use something like a random UUID, as some other servers do, but this works for-          -- our purposes.-          registration = LSP.TRegistration { _id ="globalFileWatches"+          -- See Note [Unique file watcher registration ids]+          registration = LSP.TRegistration { _id = registrationId                                            , _method = LSP.SMethod_WorkspaceDidChangeWatchedFiles                                            , _registerOptions = Just regOptions}+          registrationId = "hls-file-watches:" <> Text.intercalate "," (map Text.pack globs)           regOptions =             DidChangeWatchedFilesRegistrationOptions { _watchers = watchers }           -- See Note [File existence cache and LSP file watchers] for why this exists, and the choice of watch kind

@@ -56,7 +56,7 @@ import qualified Development.IDE.Types.Location       as Location import qualified Ide.Logger                           as Logger import           Ide.Plugin.Error-import           Ide.PluginUtils                      (rangesOverlap)+import           Ide.PluginUtils                      (asPosition, rangesOverlap) import           Ide.Types import qualified Language.LSP.Protocol.Lens           as LSP import           Language.LSP.Protocol.Message        (SMethod (..))@@ -215,14 +215,26 @@         case mDiags of             Nothing -> pure Nothing             Just fileDiags -> do-                pure $ Just $ filter diagRangeOverlaps fileDiags+                pure $ Just $ filter (diagRangeOverlaps range) fileDiags     where-        diagRangeOverlaps = \fileDiag ->-            rangesOverlap range (fileDiag ^. fdLspDiagnosticL . LSP.range)+        -- The rationale of how to decide whether a 'Range' overlap with the+        -- 'Range' of a diagnostic is explained at+        -- https://github.com/haskell/haskell-language-server/pull/5047+        diagRangeOverlaps range fileDiag+          | Just c <- asPosition range+            -- The client sent us the cursor position, so we check if it+            -- overlaps with the **closed** 'Range' of the diagnostic.+            = LSP.positionInRange c diagRange || c == diagEnd+          | otherwise+            -- The client sent us a selection 'Range', so we check if it+            -- overlaps with the 'Range' of the diagnostic.+            = rangesOverlap range diagRange+          where+            diagRange@(LSP.Range _ diagEnd) = fileDiag ^. fdLspDiagnosticL . LSP.range  -- | Just like 'activeDiagnosticsInRangeMT'. See the docs of 'activeDiagnosticsInRangeMT' for details.-activeDiagnosticsInRange :: MonadIO m => Shake.ShakeExtras -> NormalizedFilePath -> LSP.Range -> m (Maybe [FileDiagnostic])-activeDiagnosticsInRange ide nfp range = runMaybeT (activeDiagnosticsInRangeMT ide nfp range)+activeDiagnosticsInRange :: MonadIO m => Shake.ShakeExtras -> NormalizedFilePath -> LSP.Range -> m [FileDiagnostic]+activeDiagnosticsInRange ide nfp range = concat <$> runMaybeT (activeDiagnosticsInRangeMT ide nfp range)  -- Prefer server-side diagnostics if available; they are authoritative. injectServerDiagnostics :: IdeState -> CodeActionParams -> IO CodeActionParams@@ -231,9 +243,7 @@     Nothing  -> pure []     Just nfp -> do       mDiags <- activeDiagnosticsInRange (shakeExtras ide) nfp _range-      case mDiags of-        Nothing    -> pure []-        Just diags -> pure $ diags ^.. traverse . fdLspDiagnosticL+      pure $ mDiags ^.. traverse . fdLspDiagnosticL   pure $ params & LSP.context . LSP.diagnostics .~ serverDiags  -- ----------------------------------------------------------------------------

@@ -17,17 +17,16 @@     ) where  import           Control.DeepSeq-import qualified Control.Exception                            as E import           Control.Lens import           Data.Aeson.Types                             (Value) import           Data.Hashable import qualified Data.Map                                     as M+import           Data.Maybe                                   (fromMaybe) import           Data.Time.Clock.POSIX import           Data.Typeable import           Development.IDE.GHC.Compat                   hiding                                                               (HieFileResult) import           Development.IDE.GHC.Compat.Util-import           Development.IDE.GHC.CoreFile import           Development.IDE.GHC.Util import           Development.IDE.Graph import           Development.IDE.Import.DependencyInformation@@ -40,7 +39,8 @@  import           Data.ByteString                              (ByteString) import           Data.Text.Utf16.Rope.Mixed                   (Rope)-import           Development.IDE.Import.FindImports           (ArtifactsLocation)+import           Development.IDE.Import.FindImports           (ArtifactsLocation,+                                                               ModuleToFilenames) import           Development.IDE.Spans.Common import           Development.IDE.Spans.LocalBindings import           Development.IDE.Types.Diagnostics@@ -104,6 +104,9 @@   { linkableHomeMod :: !HomeModInfo   , linkableHash    :: !ByteString   -- ^ The hash of the core file+  , linkableVersion :: !ByteString+  -- ^ Fingerprint of the core file and the versions of all transitive+  -- dependencies, identifying the code the linkable links against   }  instance Show LinkableResult where@@ -180,7 +183,8 @@ tmrModSummary :: TcModuleResult -> ModSummary tmrModSummary = pm_mod_summary . tmrParsed -data HiFileResult = HiFileResult+-- | Everything a module contributes to its dependents' typechecking.+data ModIfaceResult = ModIfaceResult     { hirModSummary     :: !ModSummary     -- Bang patterns here are important to stop the result retaining     -- a reference to a typechecked module@@ -191,28 +195,38 @@     -- ^ Fingerprint for the ModIface     , hirRuntimeModules :: !(ModuleEnv ByteString)     -- ^ same as tmrRuntimeModules-    , hirCoreFp         :: !(Maybe (CoreFile, ByteString))-    -- ^ If we wrote a core file for this module, then its contents (lazily deserialised)-    -- along with its hash     } +data HiFileResult = HiFileResult+    { hirIface  :: !ModIfaceResult+    , hirCoreFp :: !(Maybe ByteString)+    -- ^ Hash of the core file, if written.+    }++-- | Content-address for a compiled module. This covers both+-- - the module's ABI, see 'hirIfaceFp'+-- - the serialized corefile for linkables, see 'hirCoreFp'+-- Changing either implies dependents of the module need to be updated. hiFileFingerPrint :: HiFileResult -> ByteString-hiFileFingerPrint HiFileResult{..} = hirIfaceFp <> maybe "" snd hirCoreFp+hiFileFingerPrint HiFileResult{..} = hirIfaceFp hirIface <> fromMaybe "" hirCoreFp -mkHiFileResult :: ModSummary -> ModIface -> ModDetails -> ModuleEnv ByteString -> Maybe (CoreFile, ByteString) -> HiFileResult+mkHiFileResult :: ModSummary -> ModIface -> ModDetails -> ModuleEnv ByteString -> Maybe ByteString -> HiFileResult mkHiFileResult hirModSummary hirModIface hirModDetails hirRuntimeModules hirCoreFp =-    E.assert (case hirCoreFp of-                   Just (CoreFile{cf_iface_hash}, _) -> getModuleHash hirModIface == cf_iface_hash-                   _ -> True)-    HiFileResult{..}+    HiFileResult{hirIface = ModIfaceResult{..}, ..}   where     hirIfaceFp = fingerprintToBS . getModuleHash $ hirModIface -- will always be two bytes +instance NFData ModIfaceResult where+    rnf = rwhnf++instance Show ModIfaceResult where+    show = show . hirModSummary+ instance NFData HiFileResult where     rnf = rwhnf  instance Show HiFileResult where-    show = show . hirModSummary+    show = show . hirIface  -- | Save the uncompressed AST here, we compress it just before writing to disk data HieAstResult@@ -290,9 +304,15 @@ --   This is an internal rule, use 'GetModIface' instead. type instance RuleResult GetModIfaceFromDiskAndIndex = HiFileResult --- | Get a module interface details, either from an interface file or a typechecked module-type instance RuleResult GetModIface = HiFileResult+-- | Get a module interface details, either from an interface file or a typechecked module.+type instance RuleResult GetModIface = ModIfaceResult +-- | Get a compiled module's interface and the core file hash.+type instance RuleResult GetModArtefacts = HiFileResult++-- | Get a module's core file. Depend on this when you need generated code.+type instance RuleResult GetCoreFileHash = ByteString+ -- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk. type instance RuleResult GetFileContents = (FileVersion, Maybe Rope) @@ -411,6 +431,8 @@ -- | Generate a ModSummary with the timestamps and preprocessed content elided, for more successful early cutoff type instance RuleResult GetModSummaryWithoutTimestamps = ModSummaryResult +type instance RuleResult GetModulesPaths = ModuleToFilenames+ data GetParsedModule = GetParsedModule     deriving (Eq, Show, Generic) instance Hashable GetParsedModule@@ -439,6 +461,16 @@ instance Hashable GetModuleGraph instance NFData   GetModuleGraph +data GetModArtefacts = GetModArtefacts+    deriving (Eq, Show, Generic)+instance Hashable GetModArtefacts+instance NFData   GetModArtefacts++data GetCoreFileHash = GetCoreFileHash+    deriving (Eq, Show, Generic)+instance Hashable GetCoreFileHash+instance NFData   GetCoreFileHash+ data GetModuleGraphTransDepsFingerprints = GetModuleGraphTransDepsFingerprints     deriving (Eq, Show, Generic) instance Hashable GetModuleGraphTransDepsFingerprints@@ -522,6 +554,13 @@     deriving (Eq, Show, Generic) instance Hashable GetModSummaryWithoutTimestamps instance NFData   GetModSummaryWithoutTimestamps++-- | Map from module name to paths, from scanning the session's import+-- directories. See Note [Session representatives].+data GetModulesPaths = GetModulesPaths+    deriving (Eq, Show, Generic)+instance Hashable GetModulesPaths+instance NFData   GetModulesPaths  data GetModSummary = GetModSummary     deriving (Eq, Show, Generic)

@@ -66,6 +66,7 @@ import           Control.Exception.Safe import           Control.Lens                                 ((%~), (&), (.~)) import           Control.Monad.Extra+import qualified Control.Monad.Extra                          as Extra import           Control.Monad.IO.Unlift import           Control.Monad.Reader import           Control.Monad.State@@ -86,7 +87,11 @@ import qualified Data.IntMap.Strict                           as IntMap import           Data.IORef import           Data.List+#if MIN_VERSION_ghc(9,13,0) import           Data.List.Extra                              (nubOrd, nubOrdOn)+#else+import           Data.List.Extra                              (nubOrdOn)+#endif import qualified Data.Map                                     as M import           Data.Maybe import           Data.Proxy@@ -94,7 +99,6 @@ import qualified Data.Text.Encoding                           as T import qualified Data.Text.Utf16.Rope.Mixed                   as Rope import           Data.Time                                    (UTCTime (..))-import           Data.Time.Clock.POSIX                        (posixSecondsToUTCTime) import           Data.Tuple.Extra import           Data.Typeable                                (cast) import           Development.IDE.Core.Compile@@ -123,6 +127,7 @@                                                                         (nest,                                                                          vcat) import qualified Development.IDE.GHC.Compat.Util              as Util+import           Development.IDE.GHC.CoreFile                 (readBinCoreFile) import           Development.IDE.GHC.Error import           Development.IDE.GHC.Util                     hiding                                                               (modifyDynFlags)@@ -141,11 +146,11 @@ import           GHC.Iface.Ext.Utils                          (generateReferencesMap) import qualified GHC.LanguageExtensions                       as LangExt #if MIN_VERSION_ghc(9,13,0)-import           GHC.Types.PkgQual                            (PkgQual (NoPkgQual)) import           GHC.Types.Basic                              (ImportLevel (..))-import           GHC.Unit.Types                               (GenWithIsBoot(..))+import           GHC.Types.PkgQual                            (PkgQual (NoPkgQual)) import           GHC.Unit.Module.Graph                        (mkModuleEdge) import           GHC.Unit.Module.ModNodeKey                   (mnkModuleName)+import           GHC.Unit.Types                               (GenWithIsBoot (..)) #endif import           HIE.Bios.Ghc.Gap                             (hostIsDynamic) import qualified HieDb@@ -166,7 +171,8 @@                                                                useProperty,                                                                usePropertyByPath) import           Ide.Types                                    (DynFlagsModifications (dynFlagsModifyGlobal, dynFlagsModifyParser),-                                                               PluginId, getVirtualFileFromVFS)+                                                               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),@@ -179,8 +185,20 @@ import           System.Info.Extra                            (isWindows)  +import           Data.Char                                    (isUpper)+import qualified Data.HashSet                                 as HS import qualified Data.IntMap                                  as IM+import qualified Data.Map.Strict                              as Map import           GHC.Fingerprint+import           System.Directory.Extra                       (canonicalizePath,+                                                               doesDirectoryExist,+                                                               listContents)+import           System.FilePath                              (dropExtension,+                                                               makeRelative,+                                                               normalise,+                                                               splitDirectories,+                                                               takeExtension,+                                                               takeFileName)  data Log   = LogShake Shake.Log@@ -320,37 +338,26 @@ getLocatedImportsRule recorder =     define (cmapWithPrio LogShake recorder) $ \GetLocatedImports file -> do         ModSummaryResult{msrModSummary = ms} <- use_ GetModSummaryWithoutTimestamps file-        (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]+                   ++ [(True, NormalLevel, NoPkgQual, modName) | modName <- ms_srcimps ms] #else         let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms] #endif         env_eq <- use_ GhcSession file         let env = hscEnv env_eq-        let import_dirs = map (second homeUnitEnv_dflags) $ hugElts $ hsc_HUG env+        let hug_dflags = map (second homeUnitEnv_dflags) $ hugElts $ hsc_HUG env+        let unit_visibility = Map.fromList $ map mkUnitVisibility hug_dflags         let dflags = hsc_dflags env-        opt <- getIdeOptions-        let getTargetFor modName nfp-                | 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 nfp' = fromMaybe nfp $ HashSet.lookupElement nfp tt-                    itExists <- getFileExists nfp'-                    return $ if itExists then Just nfp' else Nothing-                | otherwise = do-                    itExists <- getFileExists nfp-                    return $ if itExists then Just nfp else Nothing++        moduleMaps <- use_ GetModulesPaths file+ #if MIN_VERSION_ghc(9,13,0)         (diags, imports') <- fmap unzip $ forM imports $ \(isSource, _lvl, mbPkgName, modName) -> do #else         (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do #endif-            diagOrImp <- locateModule (hscSetFlags dflags env) import_dirs (optExtensions opt) getTargetFor modName mbPkgName isSource+            diagOrImp <- locateModule moduleMaps (hscSetFlags dflags env) unit_visibility modName mbPkgName isSource             case diagOrImp of                 Left diags              -> pure (diags, Just (modName, Nothing))                 Right (FileImport path) -> pure ([], Just (modName, Just path))@@ -579,13 +586,14 @@ getDocMapRule :: Recorder (WithPriority Log) -> Rules () getDocMapRule recorder =     define (cmapWithPrio LogShake recorder) $ \GetDocMap file -> do-      -- Stale data for the scenario where a broken module has previously typechecked-      -- but we never generated a DocMap for it-      (tmrTypechecked -> tc, _) <- useWithStale_ TypeCheck file-      (hscEnv -> hsc, _)        <- useWithStale_ GhcSessionDeps file-      (HAR{refMap=rf}, _)       <- useWithStale_ GetHieAst file--      dkMap <- liftIO $ mkDocMap hsc rf tc+      (tmrTypechecked -> tc) <- use_ TypeCheck file+      (hscEnv -> hsc)        <- use_ GhcSessionDeps file+      HAR{refMap=rf}         <- use_ GetHieAst file+      cfg <- getClientConfigAction+      dkMap <- liftIO $ mkDocMap hsc rf tc $ LinkTargets+                { linkSource = linkSourceTo cfg+                , linkDoc = linkDocTo cfg+                }       return ([],Just dkMap)  -- | Persistent rule to ensure that hover doesn't block on startup@@ -637,7 +645,9 @@  getModuleGraphRule :: Recorder (WithPriority Log) -> Rules () getModuleGraphRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake recorder) $ \GetModuleGraph -> do-  fs <- toKnownFiles <$> useNoFile_ GetKnownTargets+  -- Only the files of the project: a file no component claims has no session to+  -- be compiled in. See Note [Files that are not targets]+  fs <- toTargetFiles <$> useNoFile_ GetKnownTargets   dependencyInfoForFiles (HashSet.toList fs)  #if MIN_VERSION_ghc(9,13,0)@@ -656,6 +666,94 @@       _ -> [NormalLevel] #endif +-- See Note [Session representatives]+getModulesPathsRule :: Recorder (WithPriority Log) -> Rules ()+getModulesPathsRule recorder =+  defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetModulesPaths file ->+    use GhcSession file >>= \case+      Nothing -> pure (Nothing, Nothing)+      Just env_eq+        | file == envRepresentative env_eq -> do+            res <- computeModulesPaths env_eq+            pure (Just (fingerprintToBS (mtfFingerprint res)), Just res)+        | otherwise -> do+            res <- use GetModulesPaths (envRepresentative env_eq)+            pure (fingerprintToBS . mtfFingerprint <$> res, res)++{- Note [Session representatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We want to compute `GetModulesPaths` only once, scanning every import+directory once per component rather than once per file. To do this,+we pick a session representative, that is guaranteed to have a non-error+GhcSession because it is a target location of this load.++Then when we are asked for the ModulePaths of a file, we delegate to the+session representative instead (the session representative itself computes+the map).+-}++-- | All the files below a directory.+-- If we cannot list a particular directory, then it doesn't contribute to the search+-- Also handles cyclic directory structures due to symlinks properly+listFilesRecursive :: (FilePath -> Bool) -> FilePath -> IO [FilePath]+listFilesRecursive recurseInto = go []+  where+    go ancestors dir = handle (\(_ :: IOException) -> pure []) $ do+      canonical <- canonicalizePath dir+      if canonical `elem` ancestors then pure [] else do+        (dirs, files) <- Extra.partitionM doesDirectoryExist =<< listContents dir+        below <- traverse (go (canonical : ancestors)) (filter recurseInto dirs)+        pure $ files ++ concat below++computeModulesPaths :: HscEnvEq -> Action ModuleToFilenames+computeModulesPaths env_eq = do+  knownTargets <- useNoFile_ GetKnownTargets+  opt <- getIdeOptions+  let env = hscEnv env_eq+      exts = optExtensions opt+      acceptedExtensions = concatMap (\x -> ['.':x, '.':x <> "-boot"]) exts+      -- Files known to HLS, whether or not they exist on disk yet+      knownPaths =+        [ (fromNormalizedFilePath p, p) | p <- HS.toList $ toKnownFiles knownTargets ]++  unit_maps <- forM (hugElts $ hsc_HUG env) $ \(u, hue) -> do+    dir_maps <- forM (importPaths $ homeUnitEnv_dflags hue) $ \dir' -> do+      let import_dir = normalise dir'+          -- makeRelative gives back the path unchanged if it is not below+          -- import_dir. Both paths are absolute, so this is unambiguous.+          below f = let rel = makeRelative import_dir f+                    in if rel == f then Nothing else Just rel+          toModule rel = mkModuleName $ intercalate "." $+            splitDirectories (dropExtension rel)+          accepted f = takeExtension f `elem` acceptedExtensions+          recurseInto path = case takeFileName path of+            []    -> False+            (x:_) -> isUpper x+          firstWins = foldl'+            (\acc (m, p) -> addToUniqMap_C (\old _ -> old) acc m p) emptyUniqMap+          mkMaps fs =+            let (boot, normal) = partition (("-boot" `isSuffixOf`) . fst) $+                                   filter (accepted . fst) fs+            in ( firstWins [ (toModule rel, p) | (rel, p) <- normal ]+               , HS.fromList (map snd boot)+               )++      scanned <- liftIO $ listFilesRecursive recurseInto import_dir+      let (scanNormal, scanBoot) = mkMaps+            [ (rel, toNormalizedFilePath' f) | f <- scanned, Just rel <- [below f] ]+          (knownNormal, knownBoot) = mkMaps+            [ (rel, p) | (f, p) <- knownPaths, Just rel <- [below f] ]+      -- Known files win within a directory: they may exist only in the editor+      pure (plusUniqMap_C const knownNormal scanNormal, HS.union knownBoot scanBoot)+    -- The first import dir providing a module wins, matching GHC's -i order+    let combineDirs = foldl' (plusUniqMap_C (\old _ -> old)) emptyUniqMap+    pure (u, (combineDirs (map fst dir_maps), HS.unions (map snd dir_maps)))++  let providers u = mapUniqMap (\p -> pure (u, p))+      normal = foldl' (plusUniqMap_C (<>)) emptyUniqMap+        [ providers u m | (u, (m, _)) <- unit_maps ]+  pure $ mkModuleToFilenames normal (HS.unions [ b | (_, (_, b)) <- unit_maps ])+ dependencyInfoForFiles :: [NormalizedFilePath] -> Action (BS.ByteString, DependencyInformation) dependencyInfoForFiles fs = do   (rawDepInfo, bm) <- rawDependencyInformation fs@@ -701,8 +799,15 @@            { getLinkables = unliftIO unlift . uses_ GetLinkable            , getModuleGraph = unliftIO unlift $ useWithSeparateFingerprintRule_ GetModuleGraphTransDepsFingerprints GetModuleGraph fp            }+  -- This 'setFileCacheHook' is neccessary to work correctly+  -- with ghc plugins.+  -- In particular, with plugins we load objects, and in doing so we consult the fileCacheHook to record the hash of the object.+  --+  -- See issue https://github.com/haskell/haskell-language-server/issues/4675 for details+  -- and https://github.com/ucsd-progsys/lh-plugin-demo for a reproducer.+  hsc_env <- setFileCacheHook hsc   addUsageDependencies $ liftIO $-    typecheckModule defer hsc dets pm+    typecheckModule defer hsc_env dets pm   where     addUsageDependencies :: Action (a, Maybe TcModuleResult) -> Action (a, Maybe TcModuleResult)     addUsageDependencies a = do@@ -733,7 +838,7 @@                 [ B.encode (hash (sessionVersion res))                 -- When the session version changes, reload all session                 -- hsc env sessions-                , B.encode (show (sessionLoading config))+                , B.encode (show (componentsLoading config))                 -- The loading config affects session loading.                 -- Invalidate all build nodes.                 -- Changing the session loading config will increment@@ -797,8 +902,17 @@                 -- Fixes the bug in #4631                 env = msrHscEnv msr             depSessions <- map hscEnv <$> uses_ (GhcSessionDeps_ fullModSummary) deps-            ifaces <- uses_ GetModIface deps-            let inLoadOrder = map (\HiFileResult{..} -> HomeModInfo hirModIface hirModDetails emptyHomeModInfoLinkable) ifaces+            needsCode <- uses_ NeedsCompilation deps+            let (codeDeps, plainDeps) = partition (isJust . snd) (zip deps needsCode)+            ifaces <- (++) <$> uses_ GetModIface (map fst codeDeps)+                           <*> (map hirIface <$> uses_ GetModArtefacts (map fst plainDeps))+            -- Load .hs-boot before .hs: the HPT is keyed by module name, and+            -- GHC's addHomeModInfoToHpt overwrites, so the non-boot must be last.+            let inLoadOrder = sortOn (not . isBootHmi)+                  $ map (\ModIfaceResult{..} -> HomeModInfo hirModIface hirModDetails emptyHomeModInfoLinkable) ifaces+                isBootHmi hmi = case mi_hsc_src (hm_iface hmi) of+                  HsBootFile -> True+                  _          -> False             de <- useWithSeparateFingerprintRule_ GetModuleGraphTransDepsFingerprints GetModuleGraph file             mg <- do               if fullModuleGraph@@ -849,7 +963,7 @@             { source_version = ver             , old_value = m_old             , get_file_version = use GetModificationTime_{missingFileDiagnostics = False}-            , get_linkable_hashes = \fs -> map (snd . fromJust . hirCoreFp) <$> uses_ GetModIface fs+            , get_linkable_hashes = \fs -> uses_ GetCoreFileHash fs             , get_module_graph = useWithSeparateFingerprintRule_ GetModuleGraphTransDepsFingerprints GetModuleGraph f             , regenerate = regenerateHiFile session f ms             }@@ -877,7 +991,7 @@   se@ShakeExtras{withHieDb} <- getShakeExtras    -- GetModIfaceFromDisk should have written a `.hie` file, must check if it matches version in db-  let ms = hirModSummary x+  let ms = hirModSummary (hirIface x)       hie_loc = Compat.ml_hie_file $ ms_location ms   fileHash <- liftIO $ Util.getFileHash hie_loc   mrow <- liftIO $ withHieDb (\hieDb -> HieDb.lookupHieFileFromSource hieDb (fromNormalizedFilePath f))@@ -962,31 +1076,40 @@     define (cmapWithPrio LogShake recorder) $ \GenerateCore -> generateCore (RunSimplifier True)  getModIfaceRule :: Recorder (WithPriority Log) -> Rules ()-getModIfaceRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModIface f -> do-  fileOfInterest <- use_ IsFileOfInterest f-  res <- case fileOfInterest of-    IsFOI status -> do-      -- Never load from disk for files of interest-      tmr <- use_ TypeCheck f-      linkableType <- getLinkableType f-      hsc <- hscEnv <$> use_ GhcSessionDeps f-      hsc' <- setFileCacheHook hsc-      let compile = fmap ([],) $ use GenerateCore f-      se <- getShakeExtras-      (diags, !mbHiFile) <- writeCoreFileIfNeeded se hsc' linkableType compile tmr-      let fp = hiFileFingerPrint <$> mbHiFile-      hiDiags <- case mbHiFile of-        Just hiFile-          | OnDisk <- status-          , not (tmrDeferredError tmr) -> liftIO $ writeHiFile se hsc' hiFile-        _ -> pure []-      return (fp, (diags++hiDiags, mbHiFile))-    NotFOI -> do-      hiFile <- use GetModIfaceFromDiskAndIndex f-      let fp = hiFileFingerPrint <$> hiFile-      return (fp, ([], hiFile))--  pure res+getModIfaceRule recorder = do+  defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModArtefacts f -> do+    fileOfInterest <- use_ IsFileOfInterest f+    res <- case fileOfInterest of+      IsFOI status -> do+        -- Never load from disk for files of interest+        tmr <- use_ TypeCheck f+        linkableType <- getLinkableType f+        hsc <- hscEnv <$> use_ GhcSessionDeps f+        hsc' <- setFileCacheHook hsc+        let compile = fmap ([],) $ use GenerateCore f+        se <- getShakeExtras+        (diags, !mbHiFile) <- writeCoreFileIfNeeded se hsc' linkableType compile tmr+        let fp = hiFileFingerPrint <$> mbHiFile+        hiDiags <- case mbHiFile of+          Just hiFile+            | OnDisk <- status+            , not (tmrDeferredError tmr) -> liftIO $ writeHiFile se hsc' hiFile+          _ -> pure []+        return (fp, (diags++hiDiags, mbHiFile))+      NotFOI -> do+        hiFile <- use GetModIfaceFromDiskAndIndex f+        let fp = hiFileFingerPrint <$> hiFile+        return (fp, ([], hiFile))+    pure res+  -- Variants of `GetModArtefacts`, so dependents can be more precise in what+  -- they require from a module.+  defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetModIface file -> do+    hir <- fmap hirIface <$> use GetModArtefacts file+    return (hirIfaceFp <$> hir, hir)+  defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetCoreFileHash file -> do+    hir <- use GetModArtefacts file+    let h = hirCoreFp =<< hir+    return (h, h)  -- | Count of total times we asked GHC to recompile newtype RebuildCounter = RebuildCounter { getRebuildCountVar :: TVar Int }@@ -1111,35 +1234,79 @@  getLinkableRule :: Recorder (WithPriority Log) -> Rules () getLinkableRule recorder =-  defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetLinkable f -> do-    HiFileResult{hirModSummary, hirModIface, hirModDetails, hirCoreFp} <- use_ GetModIface f+  defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleWithOldValue $ \GetLinkable f old_value -> do+    ModIfaceResult{hirModSummary, hirModIface, hirModDetails} <- use_ GetModIface f+    mbCoreFp <- use GetCoreFileHash f     let obj_file  = ml_obj_file (ms_location hirModSummary)         core_file = ml_core_file (ms_location hirModSummary) #if MIN_VERSION_ghc(9,11,0)         mkLinkable t mod l = Linkable t mod (pure l)+        setLinkableTime t (Linkable _ mod l) = Linkable t mod l         dotO o = DotO o ModuleObject+        keepLinkables t mod =+          [ mkLinkable t mod (DotA "dummy")+          , mkLinkable t mod (CoreBindings (error "keepLinkables: bytecode forced"))+          ] #else         mkLinkable t mod l = LM t mod [l]+        setLinkableTime t (LM _ mod l) = LM t mod l         dotO = DotO+        -- An empty part list is treated as bytecode by isObjectLinkable+        keepLinkables t mod = [mkLinkable t mod (DotA "dummy"), LM t mod []] #endif-    case hirCoreFp of+    case mbCoreFp of       Nothing -> error $ "called GetLinkable for a file without a linkable: " ++ show f-      Just (bin_core, fileHash) -> do+      Just fileHash -> do         session <- use_ GhcSessionDeps f+        -- The fast BCO path below reuses the old bytecode and never forces+        -- this, so this serialised buffer isn't retained.+        let readCore = readBinCoreFile (mkUpdater $ hsc_NC $ hscEnv session) core_file         linkableType <- getLinkableType f >>= \case           Nothing -> error $ "called GetLinkable for a file which doesn't need compilation: " ++ show f           Just t -> pure t-        -- Can't use `GetModificationTime` rule because the core file was possibly written in this-        -- very session, so the results aren't reliable-        core_t <- liftIO $ getModTime core_file+        -- We need to depend on the linkables for all dependencies, so that+        -- whenever a dependeny is relinked/reloaded, we unload the current linkable, because+        -- the old version of the current linkable references the old dependency+        --+        -- We get transitivity via induction+        imports <- use_ GetLocatedImports f+        let dep_files = [ artifactFilePath loc | (_, Just loc) <- imports, not (isBootLocation loc) ]+        dep_comps <- uses_ NeedsCompilation dep_files+        dep_versions <- map linkableVersion <$> uses_ GetLinkable [ d | (d, Just _) <- zip dep_files dep_comps ]+        -- We compute a hash/identity for this linkable based on its hash + hash of dependencies+        -- transitive dependencies are included by induction+        version <- liftIO $ fingerprintFromByteString $ BS.concat (fileHash : dep_versions)++        -- GHC identifies linkables by UTCTime, we want to identify them by hash+        -- Smuggle the hash into the UTCTime.+        --+        -- Fine because GHC only checks the UTCTime for equality+        let vfp@(LinkableFingerprint linkable_fp) = mkLinkableFingerprint version+        let m_old_lr = case old_value of+              Shake.Succeeded _ v -> Just v+              Shake.Stale _ _ v   -> Just v+              Shake.Failed _      -> Nothing         (warns, hmi) <- case linkableType of+          -- Bytecode is a function of the core file alone, so if our core file+          -- is unchanged we can reuse the old bytecode. Only its identity+          -- changed, and it is relinked when it is next loaded.+          BCOLinkable+            | Just old_lr <- m_old_lr+            , linkableHash old_lr == fileHash+            , Just bc <- homeModInfoByteCode (linkableHomeMod old_lr)+            -> pure ([], Just $ HomeModInfo hirModIface hirModDetails (justBytecode $ setLinkableTime linkable_fp bc))           -- Bytecode needs to be regenerated from the core file-          BCOLinkable -> liftIO $ coreFileToLinkable linkableType (hscEnv session) hirModSummary hirModIface hirModDetails bin_core (posixSecondsToUTCTime core_t)+          BCOLinkable -> liftIO $ do+            (bin_core, _) <- readCore+            coreFileToLinkable linkableType (hscEnv session) hirModSummary hirModIface hirModDetails bin_core vfp           -- Object code can be read from the disk           ObjectLinkable -> do             -- object file is up to date if it is newer than the core file             -- Can't use a rule like 'GetModificationTime' or 'GetFileExists' because 'coreFileToLinkable' will write the object file, and             -- thus bump its modification time, forcing this rule to be rerun every time.+            -- Can't use `GetModificationTime` for the core file either, because it was+            -- possibly written in this very session, so the results aren't reliable+            core_t <- liftIO $ getModTime core_file             exists <- liftIO $ doesFileExist obj_file             mobj_time <- liftIO $               if exists@@ -1147,8 +1314,10 @@               else pure Nothing             case mobj_time of               Just obj_t-                | obj_t >= core_t -> pure ([], Just $ HomeModInfo hirModIface hirModDetails (justObjects $ mkLinkable (posixSecondsToUTCTime obj_t) (ms_mod hirModSummary) (dotO obj_file)))-              _ -> liftIO $ coreFileToLinkable linkableType (hscEnv session) hirModSummary hirModIface hirModDetails bin_core (error "object doesn't have time")+                | obj_t >= core_t -> pure ([], Just $ HomeModInfo hirModIface hirModDetails (justObjects $ mkLinkable linkable_fp (ms_mod hirModSummary) (dotO obj_file)))+              _ -> liftIO $ do+                (bin_core, _) <- readCore+                coreFileToLinkable linkableType (hscEnv session) hirModSummary hirModIface hirModDetails bin_core vfp         -- Record the linkable so we know not to unload it, and unload old versions         whenJust ((homeModInfoByteCode =<< hmi) <|> (homeModInfoObject =<< hmi)) #if MIN_VERSION_ghc(9,11,0)@@ -1169,11 +1338,14 @@               --just before returning it to be loaded. This has a substantial effect on recompile               --times as the number of loaded modules and splices increases.               ---              --We use a dummy DotA linkable part to fake a NativeCode linkable.-              --The unload function doesn't care about the exact linkable parts.-              unload (hscEnv session) (map (\(mod', time') -> mkLinkable time' mod' (DotA "dummy")) $ moduleEnvToList to_keep)+              --The keep list is split into native code and bytecode halves and loaded+              --linkables only match entries of their own kind, hence one entry of each+              --per module. unload only cares about the module and time, not the+              --contents, therefore the dummies.+              unload (hscEnv session) (concatMap (\(mod', time') -> keepLinkables time' mod') $ moduleEnvToList to_keep)               return (to_keep, ())-        return (fileHash <$ hmi, (warns, LinkableResult <$> hmi <*> pure fileHash))+        let versionBS = fingerprintToBS version+        return (versionBS <$ hmi, (warns, LinkableResult <$> hmi <*> pure fileHash <*> pure versionBS))  -- | For now we always use bytecode unless something uses unboxed sums and tuples along with TH getLinkableType :: NormalizedFilePath -> Action (Maybe LinkableType)@@ -1275,6 +1447,7 @@     getModIfaceRule recorder     getModSummaryRule templateHaskellWarning recorder     getModuleGraphRule recorder+    getModulesPathsRule recorder     getFileHashRule recorder     knownFilesRule recorder     getClientSettingsRule recorder

@@ -4,6 +4,7 @@ {-# LANGUAGE CPP                   #-} {-# LANGUAGE DerivingStrategies    #-} {-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE ImplicitParams        #-} {-# LANGUAGE PackageImports        #-} {-# LANGUAGE RecursiveDo           #-} {-# LANGUAGE TypeFamilies          #-}@@ -24,7 +25,8 @@ module Development.IDE.Core.Shake(     IdeState, shakeSessionInit, shakeExtras, shakeDb, rootDir,     ShakeExtras(..), getShakeExtras, getShakeExtrasRules,-    KnownTargets(..), Target(..), toKnownFiles, unionKnownTargets, mkKnownTargets,+    KnownTargets(..), Target(..), toKnownFiles, toTargetFiles, unionKnownTargets,+    mkKnownTargets, mkExtraKnownFiles, tombstoneKnownFiles,     IdeRule, IdeResult, RestartQueue,     GetModificationTime(GetModificationTime, GetModificationTime_, missingFileDiagnostics),     shakeOpen, shakeShut,@@ -53,6 +55,7 @@     HLS.getClientConfig,     getPluginConfigAction,     knownTargets,+    updateKnownTargets,     ideLogger,     actionLogger,     getVirtualFile,@@ -86,6 +89,9 @@ import           Control.Concurrent.Strict import           Control.DeepSeq import           Control.Exception.Extra                hiding (bracket_)+#if MIN_VERSION_ghc(9,10,0)+import           Control.Exception.Context              (displayExceptionContext)+#endif import           Control.Lens                           ((%~), (&), (?~)) import           Control.Monad.Extra import           Control.Monad.IO.Class@@ -108,8 +114,8 @@ import qualified Data.HashMap.Strict                    as HMap import           Data.HashSet                           (HashSet) import qualified Data.HashSet                           as HSet-import           Data.List.Extra                        (foldl', partition,-                                                         takeEnd)+import qualified Data.List                              as List+import           Data.List.Extra                        (partition, takeEnd) import qualified Data.Map.Strict                        as Map import           Data.Maybe import qualified Data.SortedList                        as SL@@ -223,10 +229,9 @@       hsep         [ "Finished:" <+> pretty (actionName delayedAct)         , "Took:" <+> pretty (showDuration seconds) ]-    LogBuildSessionFinish e ->-      vcat-        [ "Finished build session"-        , pretty (fmap displayException e) ]+    LogBuildSessionFinish e -> case e of+      Nothing -> "Finished build session"+      Just e -> "Finished build session:" <+> prettyBuildSessionFinishException e     LogDiagsDiffButNoLspEnv fileDiagnostics ->       "updateFileDiagnostics published different from new diagnostics - file diagnostics:"       <+> pretty (showDiagnosticsColored fileDiagnostics)@@ -452,7 +457,9 @@         Just env -> do             config <- liftIO $ LSP.runLspT env HLS.getClientConfig             return x{optCheckProject = pure $ checkProject config,-                     optCheckParents = pure $ checkParents config+                     optCheckParents = pure $ checkParents config,+                     optLinkSourceTo = linkSourceTo config,+                     optLinkDocTo = linkDocTo config                 }  getIdeOptionsIO :: ShakeExtras -> IO IdeOptions@@ -640,6 +647,28 @@   ShakeExtras{knownTargetsVar} <- getShakeExtras   liftIO $ readTVarIO knownTargetsVar +-- | Record files that appeared and disappeared, returning the keys to+-- invalidate. Must be called from the restart thread,+-- see Note [Serializing runs in separate thread].+updateKnownTargets+  :: ShakeExtras+  -> [NormalizedFilePath] -- ^ appeared+  -> [NormalizedFilePath] -- ^ disappeared+  -> IO [Key]+updateKnownTargets ShakeExtras{knownTargetsVar} added removed+  | null added && null removed = pure []+  | otherwise = atomically $ do+      known <- readTVar knownTargetsVar+      -- Registering a file the session loader already knows about would+      -- rebuild everything derived from the targets for no gain.+      -- See Note [Files that are not targets]+      let addedSet = HSet.fromList added `HSet.difference` toKnownFiles (unhashed known)+          known' = flip mapHashed known $+            tombstoneKnownFiles (HSet.fromList removed) addedSet+            . unionKnownTargets (mkExtraKnownFiles addedSet)+      writeTVar knownTargetsVar known'+      pure [toNoFileKey GetKnownTargets | known /= known']+ -- | Seq the result stored in the Shake value. This only -- evaluates the value to WHNF not NF. We take care of the latter -- elsewhere and doing it twice is expensive.@@ -816,7 +845,7 @@                 keys <- ioActionBetweenShakeSession                 -- it is every important to update the dirty keys after we enter the critical section                 -- see Note [Housekeeping rule cache and dirty key outside of hls-graph]-                atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys+                atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> List.foldl' (flip insertKeySet) x keys                 res <- shakeDatabaseProfile shakeDb                 backlog <- readTVarIO $ dirtyKeys shakeExtras                 queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras@@ -909,8 +938,9 @@           return $ do               let exception =                     case res of-                      Left e -> Just e-                      _      -> Nothing+                      Left (fromException -> Just AsyncCancelled) -> Nothing+                      Left e                                      -> Just e+                      _                                           -> Nothing               logWith recorder Debug $ LogBuildSessionFinish exception      -- Do the work in a background thread@@ -1196,7 +1226,11 @@     }   | RuleWithOldValue (k -> NormalizedFilePath -> Value v -> Action (Maybe BS.ByteString, IdeResult v)) --- | Define a new Rule with early cutoff+-- | Define a rule that can rerun without dirtying its dependents.+--+-- A rerun normally prompts every dependent to rerun. Early cutoff content+-- addresses the result, so hls-graph reruns dependents only when the returned+-- fingerprint has changed. defineEarlyCutoff     :: IdeRule k v     => Recorder (WithPriority Log)@@ -1280,7 +1314,7 @@                 (mbBs, (diags, mbRes)) <- actionCatch                     (do v <- action staleV; liftIO $ evaluate $ force v) $                     \(e :: SomeException) -> do-                        pure (Nothing, ([ideErrorText file (T.pack $ show (key, file) ++ show e) | not $ isBadDependency e],Nothing))+                        pure (Nothing, ([ideErrorText file (prettyRuleAbortedByException key file e) | not $ isBadDependency e],Nothing))                  ver <- estimateFileVersionUnsafely key mbRes file                 (bs, res) <- case mbRes of@@ -1324,6 +1358,37 @@         --  * creating a dependency: If everything depends on GetModificationTime, we lose early cutoff         --  * creating bogus "file does not exists" diagnostics         | otherwise = useWithoutDependency (GetModificationTime_ False) fp++    prettyRuleAbortedByException key file e = T.pack $ unlines $+        [ "Rule execution aborted due to exception"+        , ""+        , "Rule: " <> show key+        , "Target: " <> fromNormalizedFilePath file+        , "Message: " <> show e+        ] <>+        [ unlines+            [ "Context:"+            , ctx+            ]+        | Just ctx <- [displayExcContext e]+        ]++displayExcContext :: SomeException -> Maybe String+displayExcContext (SomeException _exc) =+#if MIN_VERSION_ghc(9,10,0)+    case displayExceptionContext ?exceptionContext of+      "" -> Nothing+      dc -> Just dc+#else+    Just $ displayException (SomeException _exc)+#endif++prettyBuildSessionFinishException :: SomeException -> Doc ann+prettyBuildSessionFinishException exc = case fromException exc of+  Nothing -> case displayExcContext exc of+    Nothing  -> pretty (displayException exc)+    Just ctx -> pretty ctx+  Just AsyncCancelled -> viaShow AsyncCancelled -- We don't want to see the stack trace for a cancelled build session  -- Note [Housekeeping rule cache and dirty key outside of hls-graph] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -0,0 +1,19 @@+module Development.IDE.Core.Text+  ( takeLineRange+  , lineAt+  ) where++import           Data.Maybe                 (listToMaybe)+import           Data.Text                  (Text)+import           Data.Text.Utf16.Rope.Mixed (Rope)+import qualified Data.Text.Utf16.Rope.Mixed as Rope++-- | The lines of @rope@ over the 0-based inclusive line range @[from, to]@.+takeLineRange :: Word -> Word -> Rope -> [Text]+takeLineRange from to rope+  | to < from = []+  | otherwise = Rope.lines $ fst $ Rope.splitAtLine (to - from + 1) $ snd $ Rope.splitAtLine from rope++-- | The 0-based line @n@ of @rope@, if it has one.+lineAt :: Word -> Rope -> Maybe Text+lineAt n = listToMaybe . takeLineRange n n

@@ -334,6 +334,7 @@      module GHC.Tc.Instance.Family,     module GHC.Tc.Module,+    module GHC.Tc.TyCl.Class,     module GHC.Tc.Types,     module GHC.Tc.Types.Evidence,     module GHC.Tc.Utils.Env,@@ -445,6 +446,7 @@ import qualified GHC.Runtime.Interpreter     as GHCi import           GHC.Tc.Instance.Family import           GHC.Tc.Module+import           GHC.Tc.TyCl.Class import           GHC.Tc.Types import           GHC.Tc.Types.Evidence       hiding ((<.>)) import           GHC.Tc.Utils.Env@@ -565,17 +567,16 @@ import           GHC.Hs                      (SrcSpanAnn') #endif +-- | Like GHC's, but never adds the boot suffix to the output paths itself.+-- GHC only started doing that in 9.13, so callers that want it apply+-- 'addBootSuffixLocnOut' on all versions. mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO Module.ModLocation #if MIN_VERSION_ghc(9,13,0) mkHomeModLocation df mn f =   let (basename, ext) = FP.splitExtension f       osBasename = unsafeEncodeUtf basename       osExt = unsafeEncodeUtf ext-      hscSrc = case ext of-        ".hs-boot" -> HsBootFile-        ".hsig" -> HsigFile-        _ -> HsSrcFile-  in pure $ GHC.mkHomeModLocation (GHC.initFinderOpts df) mn osBasename osExt hscSrc+  in pure $ GHC.mkHomeModLocation (GHC.initFinderOpts df) mn osBasename osExt HsSrcFile #elif MIN_VERSION_ghc(9,11,0) mkHomeModLocation df mn f =   let osf = unsafeEncodeUtf f

@@ -26,12 +26,14 @@   _TcRnMessageWithCtx,   _GhcPsMessage,   _GhcDsMessage,+  _DsMessage,   _GhcDriverMessage,   _ReportHoleError,   _TcRnIllegalWildcardInType,   _TcRnPartialTypeSignatures,   _TcRnMissingSignature,   _TcRnSolverReport,+  _TcRnUnusedTopBind,   _TcRnMessageWithInfo,   _TypeHole,   _ConstraintHole,@@ -40,9 +42,11 @@   _MismatchMessage,   _TypeEqMismatchActual,   _TypeEqMismatchExpected,+  _CouldNotDeducePred,   ) where  import           Control.Lens+import qualified Data.List.NonEmpty         as NE import           Development.IDE.GHC.Compat (Type) import           GHC.Driver.Errors.Types import           GHC.HsToCore.Errors.Types@@ -77,11 +81,27 @@   GhcDsMessage dsMsg -> Just dsMsg   _ -> Nothing) +_DsMessage :: Fold GhcMessage DsMessage+_DsMessage = prism' GhcDsMessage $ \case+  GhcDsMessage dsmsg -> Just dsmsg+  _ -> Nothing+ _GhcDriverMessage :: Prism' GhcMessage DriverMessage _GhcDriverMessage = prism' GhcDriverMessage (\case   GhcDriverMessage driverMsg -> Just driverMsg   _ -> Nothing) +-- | Focus an unused top-level binding warning (@-Wunused-top-binds@). Structured+-- provenance for this only exists from GHC 9.8 (GHC #20115).+_TcRnUnusedTopBind :: Fold GhcMessage ()+#if MIN_VERSION_ghc(9,8,0)+_TcRnUnusedTopBind = _TcRnMessage . folding (\case+  TcRnUnusedName _ UnusedNameTopDecl -> Just ()+  _                                  -> Nothing)+#else+_TcRnUnusedTopBind = ignored+#endif+ -- | Some 'TcRnMessage's are nested in other constructors for additional context. -- For example, 'TcRnWithHsDocContext' and 'TcRnMessageWithInfo'. -- However, in some occasions you don't need the additional context and you just want@@ -115,6 +135,16 @@ _MismatchMessage focus (Mismatch msg t a c) = (\msg' -> Mismatch msg' t a c) <$> focus msg _MismatchMessage focus (CannotUnifyVariable msg a) = flip CannotUnifyVariable a <$> focus msg _MismatchMessage _ report = pure report++-- | Focus the missing constraint predicate for a @"Could not deduce ..."@ or+-- @"No instance for ..."@ error.+_CouldNotDeducePred :: Fold TcSolverReportMsg Type+_CouldNotDeducePred = folding $ \report -> case report of+  CannotResolveInstance{cannotResolve_item = i} -> Just (errorItemPred i)+  UnboundImplicitParams items -> Just (errorItemPred (NE.head items))+  _ -> case report ^? _MismatchMessage of+    Just CouldNotDeduce{cnd_wanted = w} -> Just (errorItemPred (NE.head w))+    _                                   -> Nothing  -- | Focus 'teq_mismatch_expected' from 'TypeEqMismatch'. _TypeEqMismatchExpected :: Traversal' MismatchMsg Type

@@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-}--- | Compat module for GHC 9.2 Logger infrastructure.+-- | Compat module for logger infrastructure. module Development.IDE.GHC.Compat.Logger (     putLogHook,     Logger.pushLogHook,

@@ -100,8 +100,6 @@     sty  = mkUserStyle unqual AllTheWay     doc' = pprWithUnitState emptyUnitState doc -- formatErrorWithQual :: DynFlags -> MsgEnvelope DecoratedSDoc -> String formatErrorWithQual dflags e =   showSDoc dflags (pprNoLocMsgEnvelope e)

@@ -8,6 +8,7 @@   , codeGutsToCoreFile   , typecheckCoreFile   , readBinCoreFile+  , readBinCoreFileHash   , writeBinCoreFile   , getImplicitBinds   ) where@@ -54,8 +55,12 @@ readBinCoreFile name_cache fat_hi_path = do     bh <- readBinMem fat_hi_path     file <- getWithUserData name_cache bh-    !fp <- Util.getFileHash fat_hi_path+    !fp <- readBinCoreFileHash fat_hi_path     return (file, fp)++-- The fingerprint of a core file.+readBinCoreFileHash :: FilePath -> IO Fingerprint+readBinCoreFileHash = Util.getFileHash  -- | Write a core file writeBinCoreFile :: DynFlags -> FilePath -> CoreFile -> IO Fingerprint

@@ -28,6 +28,7 @@     disableWarningsAsErrors,     printOutputable,     printOutputableOneLine,+    printOutputableQualified,     getExtensions,     getExtensionsSet,     stripOccNamePrefix,@@ -270,6 +271,10 @@  printOutputableOneLine :: Outputable a => a -> T.Text printOutputableOneLine = printOutputable' printWithoutUniquesOneLine++printOutputableQualified :: Outputable a => PrintUnqualified -> a -> T.Text+printOutputableQualified ctx =+    printOutputable' (printSDocQualifiedUnsafe ctx . ppr)  printOutputable' :: Outputable a => (a -> String) -> a -> T.Text printOutputable' print =

@@ -53,7 +53,8 @@   warnings <- newVar []   let newAction :: DynFlags -> LogActionCompat       newAction dynFlags logFlags wr _ loc prUnqual msg = do-        let wr_d = map ((wr,) . over fdLspDiagnosticL (attachReason wr)) $ diagFromSDocErrMsg diagSource dynFlags (mkWarnMsg dynFlags wr logFlags loc prUnqual msg)+        let wr_d = map ((wr,) . over fdLspDiagnosticL (attachReason wr))+                 $ diagFromSDocErrMsg diagSource dynFlags (mkWarnMsg dynFlags wr logFlags loc prUnqual msg)         modifyVar_ warnings $ return . (wr_d:)       newLogger env = pushLogHook (const (logActionCompat (newAction (hsc_dflags env)))) (hsc_logger env)   res <- action $ \env -> putLogHook (newLogger env) env

@@ -53,7 +53,8 @@ import           Development.IDE.GHC.Compat.Util    (Fingerprint) import qualified Development.IDE.GHC.Compat.Util    as Util import           Development.IDE.GHC.Orphans        ()-import           Development.IDE.Import.FindImports (ArtifactsLocation (..))+import           Development.IDE.Import.FindImports (ArtifactsLocation (..),+                                                     isBootLocation) import           Development.IDE.Types.Diagnostics import           Development.IDE.Types.Location import           GHC.Generics                       (Generic)@@ -273,7 +274,25 @@           foldr (\(p, cs) res ->             let new = IntMap.fromList (map (, IntSet.singleton (coerce p)) (coerce cs))             in IntMap.unionWith IntSet.union new res ) IntMap.empty successEdges-        reverseModuleMap = mkModuleEnv $ map (\(i,sm) -> (showableModule sm, FilePathId i)) $ IntMap.toList rawModuleMap+        -- Map 'Module' to 'FilePathId'. A 'Module' does not distinguish boot+        -- from non-boot, so a real source file and its hs-boot share the same+        -- key. We list boot entries first and non-boot entries second so that+        -- 'mkModuleEnv' (right-biased on duplicates) makes the non-boot entry+        -- win: callers like the 'GetLinkable' rule (via 'lookupModuleFile')+        -- need the non-boot file because hs-boot files don't have linkables.+        --+        -- XXX: It's unclear whether this code can be called in a situation+        --      where a module ONLY has a boot module. If that situation+        --      can't occur, the snippet below can be simplified to simply+        --      filter all boot entries.+        (bootEntries, srcEntries) = partitionEithers+          [ if isBootLocation al+              then Left  (showableModule sm, FilePathId i)+              else Right (showableModule sm, FilePathId i)+          | (i, sm) <- IntMap.toList rawModuleMap+          , Just al <- [IntMap.lookup i (idToPathMap rawPathIdMap)]+          ]+        reverseModuleMap = mkModuleEnv (bootEntries ++ srcEntries)   -- | Given a dependency graph, buildResultGraph detects and propagates errors in that graph as follows:@@ -347,11 +366,11 @@     return $ map (idToPath depPathIdMap . FilePathId) (IntSet.toList (go cur_id IntSet.empty))   where     go :: Int -> IntSet -> IntSet-    go k i =+    go k visited =       let outwards = IntMap.findWithDefault IntSet.empty k depReverseModuleDeps-          res = IntSet.union i outwards-          new = IntSet.difference i outwards-      in IntSet.foldr go res new+          visited' = IntSet.union visited outwards+          new = IntSet.difference outwards visited+      in IntSet.foldr go visited' new  -- | Immediate reverse dependencies of a file immediateReverseDependencies :: NormalizedFilePath -> DependencyInformation -> Maybe [NormalizedFilePath]

@@ -1,36 +1,47 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP            #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE NamedFieldPuns #-}  module Development.IDE.Import.FindImports   ( locateModule-  , locateModuleFile   , Import(..)   , ArtifactsLocation(..)   , modSummaryToArtifactsLocation   , isBootLocation-  , mkImportDirs+  , ModuleToFilenames(..)+  , mkModuleToFilenames+  , mkUnitVisibility   ) where  import           Control.DeepSeq-import           Control.Monad.Extra import           Control.Monad.IO.Class-import           Data.List                         (find, isSuffixOf)-import           Data.Maybe+import qualified Data.HashSet                      as HS+import           Data.List                         (intercalate, isSuffixOf,+                                                    sort, sortOn)+import           Data.List.NonEmpty                (NonEmpty)+import qualified Data.List.NonEmpty                as NE+import           Data.Map.Strict                   (Map)+import qualified Data.Map.Strict                   as Map import qualified Data.Set                          as S import           Development.IDE.GHC.Compat        as Compat import           Development.IDE.GHC.Error         as ErrUtils import           Development.IDE.GHC.Orphans       () import           Development.IDE.Types.Diagnostics import           Development.IDE.Types.Location+import           GHC.Fingerprint+import           GHC.Generics import           GHC.Types.PkgQual-import           GHC.Unit.State-import           System.FilePath+import           GHC.Unit   #if MIN_VERSION_ghc(9,11,0)-import           GHC.Driver.DynFlags+import           GHC.Driver.DynFlags               (ReexportedModule (..),+                                                    hiddenModules)+#else+import           GHC.Driver.Session                (hiddenModules) #endif  data Import@@ -41,7 +52,8 @@ data ArtifactsLocation = ArtifactsLocation   { artifactFilePath    :: !NormalizedFilePath   , artifactModLocation :: !(Maybe ModLocation)-  , artifactIsSource    :: !Bool          -- ^ True if a module is a source input+  , artifactIsSource    :: !Bool          -- ^ 'True' for a real Haskell source file ('HsSrcFile');+                                          -- 'False' for a boot ('HsBootFile') or signature ('HsigFile') file.   , artifactModule      :: !(Maybe Module)   } deriving Show @@ -65,99 +77,161 @@       Just modSum -> isSource (ms_hsc_src modSum)     mbMod = ms_mod <$> ms +-- | For each module name, the units that provide it and the exact location+-- where the unit has it.+-- see 'locateModuleFile' for how we decide which unit an import actually+-- resolves to.+data ModuleToFilenames = ModuleToFilenames {+  -- | Modules and the unit, source pairs they correspond to+  moduleMap      :: UniqMap ModuleName (NonEmpty (UnitId, NormalizedFilePath)),+  -- | Boot files we know exist. If you want to check if a boot file exists,+  -- check this field for precisely the -boot file corresponding to the non-boot+  -- file you have already resolved.+  bootFiles      :: HS.HashSet NormalizedFilePath,+  -- | Fingerprint of the two, for early cutoff+  mtfFingerprint :: !Fingerprint+}+  deriving Generic++-- | The fingerprint is strict and computing it forces the map and the set, so+-- there is nothing left to force. Deep forcing here would traverse them again+-- for every file of the session.+instance NFData ModuleToFilenames where+  rnf = rwhnf++instance Show ModuleToFilenames where+  show mtf = "ModuleToFilenames " ++ show (mtfFingerprint mtf)++mkModuleToFilenames+    :: UniqMap ModuleName (NonEmpty (UnitId, NormalizedFilePath))+    -> HS.HashSet NormalizedFilePath+    -> ModuleToFilenames+mkModuleToFilenames normal boots =+    ModuleToFilenames normal boots (fingerprintFingerprints [fpMap normal, fpSet boots])+  where+    fpMap m = fingerprintFingerprints+      [ fingerprintString $ intercalate "\0" $+          moduleNameString mn :+          concat [ [unitIdString u, fromNormalizedFilePath p] | (u, p) <- NE.toList provs ]+      | (mn, provs) <- sortOn (moduleNameString . fst) (nonDetEltsUFM (getUniqMap m))+      ]+    fpSet s = fingerprintString $ intercalate "\0" $+      sort $ map fromNormalizedFilePath $ HS.toList s+ data LocateResult   = LocateNotFound-  | LocateFoundReexport UnitId+  | LocateFoundReexport UnitId ModuleName+    -- ^ The unit reexporting the module, and the name it has there   | LocateFoundFile UnitId NormalizedFilePath --- | locate a module in the file system. Where we go from *daml to Haskell-locateModuleFile :: MonadIO m-             => [(UnitId, [FilePath], S.Set ModuleName)]-             -> [String]-             -> (ModuleName -> NormalizedFilePath -> m (Maybe NormalizedFilePath))-             -> Bool-             -> ModuleName-             -> m LocateResult-locateModuleFile import_dirss exts targetFor isSource modName = do-  let candidates import_dirs =-        [ toNormalizedFilePath' (prefix </> moduleNameSlashes modName <.> maybeBoot ext)-           | prefix <- import_dirs , ext <- exts]-  mf <- firstJustM go (concat [map (uid,) (candidates dirs) | (uid, dirs, _) <- import_dirss])-  case mf of-    Nothing ->-      case find (\(_ , _, reexports) -> S.member modName reexports) import_dirss of-        Just (uid,_,_) -> pure $ LocateFoundReexport uid-        Nothing        -> pure LocateNotFound-    Just (uid,file) -> pure $ LocateFoundFile uid file-  where-    go (uid, candidate) = fmap ((uid,) <$>) $ targetFor modName candidate-    maybeBoot ext-      | isSource = ext ++ "-boot"-      | otherwise = ext+-- | What a home unit exposes to the units depending on it.+data UnitVisibility = UnitVisibility+  { uvReexports :: Map ModuleName ModuleName+    -- ^ The name we import it under, and the name it has in the unit it is+    -- reexported from+  , uvHidden    :: S.Set ModuleName+  } --- | This function is used to map a package name to a set of import paths.--- It only returns Just for unit-ids which are possible to import into the--- current module. In particular, it will return Nothing for 'main' components--- as they can never be imported into another package.-mkImportDirs :: HscEnv -> (UnitId, DynFlags) -> Maybe (UnitId, ([FilePath], S.Set ModuleName))+-- | What a home unit exposes, from its flags.+mkUnitVisibility :: (UnitId, DynFlags) -> (UnitId, UnitVisibility)+mkUnitVisibility (i, flags) = (i, UnitVisibility reexports (hiddenModules flags))+  where #if MIN_VERSION_ghc(9,11,0)-mkImportDirs _env (i, flags) = Just (i, (importPaths flags, S.fromList $ map reexportTo $ reexportedModules flags))+    -- Earlier entries win, as in 'GHC.Driver.Config.Finder.initFinderOpts'+    reexports = Map.fromList+      [ (reexportTo r, reexportFrom r) | r <- reverse (reexportedModules flags) ] #else-mkImportDirs _env (i, flags) = Just (i, (importPaths flags, reexportedModules flags))+    reexports = Map.fromSet id (reexportedModules flags) #endif +-- | Locate a module in the file system.+--+-- We go through the units in the given order and do exactly what GHC's finder+-- does: if the unit reexports the module we start again from that unit, if it+-- hides the module we skip it, and otherwise it provides the module if it has+-- a file for it. A unit that is not in the list is not visible to the importer.+locateModuleFile+  :: ModuleToFilenames+  -> ModuleName+  -> [(UnitId, Maybe UnitVisibility)]+     -- ^ Units to search, in priority order. 'Nothing' for the importing unit,+     -- whose own reexports and hidden modules do not apply to it.+  -> LocateResult+locateModuleFile ModuleToFilenames{moduleMap} modName = go+  where+    providers = maybe [] NE.toList $ lookupUniqMap moduleMap modName++    go [] = LocateNotFound+    go ((uid, mbVisibility) : units)+      | Just vis <- mbVisibility+      , Just realName <- Map.lookup modName (uvReexports vis)+      = LocateFoundReexport uid realName+      | Just vis <- mbVisibility+      , modName `S.member` uvHidden vis+      = go units+      | Just file <- lookup uid providers+      = LocateFoundFile uid file+      | otherwise+      = go units+ -- | locate a module in either the file system or the package database. Where we go from *daml to -- Haskell locateModule     :: MonadIO m-    => HscEnv-    -> [(UnitId, DynFlags)] -- ^ Import directories-    -> [String]                        -- ^ File extensions-    -> (ModuleName -> NormalizedFilePath -> m (Maybe NormalizedFilePath))  -- ^ does file exist predicate+    => ModuleToFilenames+    -> HscEnv+    -> Map UnitId UnitVisibility       -- ^ What each home unit exposes     -> Located ModuleName              -- ^ Module name     -> PkgQual                -- ^ Package name     -> Bool                            -- ^ Is boot module     -> m (Either [FileDiagnostic] Import)-locateModule env comp_info exts targetFor modName mbPkgName isSource = do+locateModule moduleMaps env unit_visibility modName mbPkgName isSource = do   case mbPkgName of     -- 'ThisPkg' just means some home module, not the current unit+    -- A home unit qualifier is not a package, so the package database is not+    -- consulted when the module is not in that unit     ThisPkg uid-      | Just (dirs, reexports) <- lookup uid import_paths-          -> lookupLocal uid dirs reexports-      | otherwise -> return $ Left $ notFoundErr env modName $ LookupNotFound []+      | uid == homeUnitId_ dflags -> lookupIn moduleNotFound [(uid, Nothing)]+      | Just vis <- Map.lookup uid unit_visibility -> lookupIn moduleNotFound [(uid, Just vis)]+      | otherwise -> moduleNotFound     -- if a package name is given we only go look for a package     OtherPkg uid-      | Just (dirs, reexports) <- lookup uid import_paths-          -> lookupLocal uid dirs reexports+      | Just vis <- Map.lookup uid unit_visibility -> lookupIn lookupInPackageDB [(uid, Just vis)]       | otherwise -> lookupInPackageDB-    NoPkgQual -> do--      -- Reexports for current unit have to be empty because they only apply to other units depending on the-      -- current unit. If we set the reexports to be the actual reexports then we risk looping forever trying-      -- to find the module from the perspective of the current unit.-      mbFile <- locateModuleFile ((homeUnitId_ dflags, importPaths dflags, S.empty) : other_imports) exts targetFor isSource $ unLoc modName-      case mbFile of-        LocateNotFound -> lookupInPackageDB-        -- Lookup again with the perspective of the unit reexporting the file-        LocateFoundReexport uid -> locateModule (hscSetActiveUnitId uid env) comp_info exts targetFor modName noPkgQual isSource-        LocateFoundFile uid file -> toModLocation uid file+    NoPkgQual -> lookupIn lookupInPackageDB searchUnits   where     dflags = hsc_dflags env-    import_paths = mapMaybe (mkImportDirs env) comp_info-    other_imports =-      -- Instead of bringing all the units into scope, only bring into scope the units-      -- this one depends on.-      -- This way if you have multiple units with the same module names, we won't get confused-      -- For example if unit a imports module M from unit B, when there is also a module M in unit C,-      -- and unit a only depends on unit b, without this logic there is the potential to get confused-      -- about which module unit a imports.-      -- Without multi-component support it is hard to recontruct the dependency environment so-      -- unit a will have both unit b and unit c in scope.-#if MIN_VERSION_ghc(9,11,0)-      map (\uid -> let this_df = homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue) in (uid, importPaths this_df, S.fromList $ map reexportTo $ reexportedModules this_df)) hpt_deps-#else-      map (\uid -> let this_df = homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue) in (uid, importPaths this_df, reexportedModules this_df)) hpt_deps-#endif++    moduleNotFound = return $ Left $ notFoundErr env modName $ LookupNotFound []++    lookupIn onNotFound units =+      case locateModuleFile moduleMaps (unLoc modName) units of+        LocateNotFound -> onNotFound+        -- Look again from the perspective of the unit reexporting the module,+        -- under the name it has there+        LocateFoundReexport uid realName ->+          locateModule moduleMaps (hscSetActiveUnitId uid env) unit_visibility+            (const realName <$> modName) noPkgQual isSource+        LocateFoundFile uid file+          -- The search only ever finds source files. A SOURCE import takes the+          -- boot file next to the source file we found, and fails if there is+          -- none, we do not go looking anywhere else.+          | isSource -> maybe moduleNotFound (toModLocation uid) (bootFile file)+          | otherwise -> toModLocation uid file++    bootFile file+      | boot `HS.member` bootFiles moduleMaps = Just boot+      | otherwise = Nothing+      where boot = toNormalizedFilePath' $ fromNormalizedFilePath file <> "-boot"++    -- The units an unqualified import may come from: the current unit first,+    -- then its dependencies, in the given order, which decides who wins when+    -- several provide the module.+    -- The current unit's own reexports and hidden modules do not apply to it,+    -- which also stops the reexport search from looping.+    searchUnits = (homeUnitId_ dflags, Nothing) :+      [ (uid, Map.lookup uid unit_visibility) | uid <- hpt_deps ]+     ue = hsc_unit_env env     units = homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId_ dflags) ue     hpt_deps :: [UnitId]@@ -166,15 +240,8 @@     toModLocation uid file = liftIO $ do         loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file)         let genMod = mkModule (RealUnit $ Definite uid) (unLoc modName)  -- TODO support backpack holes-        return $ Right $ FileImport $ ArtifactsLocation file (Just loc) (not isSource) (Just genMod)--    lookupLocal uid dirs reexports = do-      mbFile <- locateModuleFile [(uid, dirs, reexports)] exts targetFor isSource $ unLoc modName-      case mbFile of-        LocateNotFound -> return $ Left $ notFoundErr env modName $ LookupNotFound []-        -- Lookup again with the perspective of the unit reexporting the file-        LocateFoundReexport uid' -> locateModule (hscSetActiveUnitId uid' env) comp_info exts targetFor modName noPkgQual isSource-        LocateFoundFile uid' file -> toModLocation uid' file+            loc' = if isSource then addBootSuffixLocnOut loc else loc+        return $ Right $ FileImport $ ArtifactsLocation file (Just loc') (not isSource) (Just genMod)      lookupInPackageDB = do       case Compat.lookupModuleWithSuggestions env (unLoc modName) mbPkgName of

@@ -21,7 +21,8 @@ import qualified Data.HashMap.Strict                   as HM import qualified Data.HashSet                          as S import qualified Data.Text                             as Text-import           Development.IDE.Core.FileExists       (modifyFileExists,+import           Development.IDE.Core.FileExists       (allExtensions,+                                                        modifyFileExists,                                                         watchedGlobs) import           Development.IDE.Core.FileStore        (registerFileWatches,                                                         resetFileStore,@@ -37,6 +38,8 @@ import           Ide.Logger import           Ide.Types import           Numeric.Natural+import           System.Directory                      (doesFileExist)+import           System.FilePath                       (takeExtension)  data Log   = LogShake Shake.Log@@ -71,8 +74,11 @@       whenUriFile _uri $ \file -> do           -- We don't know if the file actually exists, or if the contents match those on disk           -- For example, vscode restores previously unsaved contents on open-          setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file $-            addFileOfInterest ide file Modified{firstOpen=True}+          setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file $ do+            -- An unsaved file is not on disk, so the session loader never saw+            -- it. Register it so imports of it can be resolved.+            ks <- updateKnownTargets (shakeExtras ide) [file] []+            (<> ks) <$> addFileOfInterest ide file Modified{firstOpen=True}       logWith recorder Debug $ LogOpenedTextDocument _uri    , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidChange $@@ -94,9 +100,13 @@         \ide vfs _ (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do           whenUriFile _uri $ \file -> do               let msg = "Closed text document: " <> getUri _uri+              -- A file that was only ever open in the editor stops existing+              -- when it is closed+              onDisk <- doesFileExist (fromNormalizedFilePath file)               setSomethingModified (VFSModified vfs) ide (Text.unpack msg) $ do                 scheduleGarbageCollection ide-                deleteFileOfInterest ide file+                ks <- updateKnownTargets (shakeExtras ide) [] [file | not onDisk]+                (<> ks) <$> deleteFileOfInterest ide file               logWith recorder Debug $ LogClosedTextDocument _uri    , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeWatchedFiles $@@ -115,10 +125,17 @@         unless (null fileEvents') $ do             let msg = show fileEvents'             logWith recorder Debug $ LogWatchedFileEvents (Text.pack msg)+            exts <- allExtensions <$> getIdeOptionsIO (shakeExtras ide)+            let sourceFiles c =+                  [ nfp | (nfp, c') <- fileEvents', c' == c+                  , takeExtension (fromNormalizedFilePath nfp) `elem` map ('.':) exts ]             setSomethingModified (VFSModified vfs) ide msg $ do                 ks1 <- resetFileStore ide fileEvents'                 ks2 <- modifyFileExists ide fileEvents'-                return (ks1 <> ks2)+                ks3 <- updateKnownTargets (shakeExtras ide)+                         (sourceFiles FileChangeType_Created)+                         (sourceFiles FileChangeType_Deleted)+                return (ks1 <> ks2 <> ks3)    , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeWorkspaceFolders $       \ide _ _ (DidChangeWorkspaceFoldersParams events) -> liftIO $ do

@@ -111,6 +111,7 @@                                                            PluginDescriptor (PluginDescriptor, pluginCli),                                                            PluginId (PluginId),                                                            ipMap, pluginId)+import qualified Language.LSP.Protocol.Types              as LSP import qualified Language.LSP.Server                      as LSP import           Numeric.Natural                          (Natural) import           Options.Applicative                      hiding (action)@@ -300,7 +301,29 @@     let hlsPlugin = asGhcIdePlugin (cmapWithPrio LogPluginHLS recorder) argsHlsPlugins         hlsCommands = allLspCmdIds' pid argsHlsPlugins         plugins = hlsPlugin <> argsGhcidePlugin-        options = argsLspOptions { LSP.optExecuteCommandCommands = LSP.optExecuteCommandCommands argsLspOptions <> Just hlsCommands }+        options =+          argsLspOptions+            { LSP.optExecuteCommandCommands = LSP.optExecuteCommandCommands argsLspOptions <> Just hlsCommands+            , LSP.optWorkspaceWillRenameFileOperationRegistrationOptions = fileModificationOptions+            , LSP.optWorkspaceDidRenameFileOperationRegistrationOptions = fileModificationOptions+            , LSP.optWorkspaceWillDeleteFileOperationRegistrationOptions = fileModificationOptions+            , LSP.optWorkspaceDidDeleteFileOperationRegistrationOptions = fileModificationOptions+            , LSP.optWorkspaceWillCreateFileOperationRegistrationOptions = fileModificationOptions+            , LSP.optWorkspaceDidCreateFileOperationRegistrationOptions = fileModificationOptions+            }+        fileModificationOptions =+          Just $+            LSP.FileOperationRegistrationOptions+              [ LSP.FileOperationFilter+                  { _scheme = Just "file"+                  , _pattern =+                      LSP.FileOperationPattern+                        { _glob = "**/*.hs"+                        , _matches = Just LSP.FileOperationPatternKind_File+                        , _options = Nothing+                        }+                  }+              ]         argsParseConfig = getConfigFromNotification argsHlsPlugins         rules = do             argsRules

@@ -56,6 +56,8 @@  import qualified Ide.Plugin.Config                        as Config +import           Development.IDE.Types.Options            (LinkTargets (..),+                                                           linkTargets) import qualified GHC.LanguageExtensions                   as LangExt  data Log = LogShake Shake.Log deriving Show@@ -136,7 +138,9 @@           Nothing                                      -> (mempty, mempty)     doc <- case lookupNameEnv dm name of       Just doc -> pure $ spanDocToMarkdown doc-      Nothing -> liftIO $ spanDocToMarkdown . fst <$> getDocumentationTryGhc (hscEnv sess) name+      Nothing -> liftIO $ do+        ltgts <- linkTargets <$> getIdeOptionsIO (shakeExtras ide)+        spanDocToMarkdown . fst <$> getDocumentationTryGhc (hscEnv sess) ltgts name     typ <- case lookupNameEnv km name of       _ | not needType -> pure Nothing       Just ty -> pure (safeTyThingType True ty)

@@ -40,6 +40,7 @@ import           Data.Ord                                 (Down (Down)) import qualified Data.Set                                 as Set import           Development.IDE.Core.PositionMapping+import           Development.IDE.Core.Text                (lineAt) import           Development.IDE.GHC.Compat               hiding (isQual, ppr) import qualified Development.IDE.GHC.Compat               as GHC import           Development.IDE.GHC.Compat.Util@@ -876,8 +877,7 @@             lastMaybe = headMaybe . reverse          -- grab the entire line the cursor is at-        curLine <- headMaybe $ Rope.lines-                             $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (fromIntegral l) ropetext+        curLine <- lineAt (fromIntegral l) ropetext         let beforePos = T.take (fromIntegral c) curLine         -- the word getting typed, after previous space and before cursor         curWord <-

@@ -25,7 +25,8 @@   ) where  -import           GHC.Data.FastString                  (lengthFS)+import           GHC.Data.FastString                  (LexicalFastString (..),+                                                       lengthFS) import qualified GHC.Utils.Outputable                 as O  import           Development.IDE.GHC.Error@@ -50,7 +51,6 @@ import           Control.Monad.IO.Class import           Control.Monad.Trans.Class import           Control.Monad.Trans.Maybe-import           Data.Coerce                          (coerce) import qualified Data.HashMap.Strict                  as HM import qualified Data.Map.Strict                      as M import           Data.Maybe@@ -669,18 +669,8 @@  pointCommand :: HieASTs t -> Position -> (HieAST t -> a) -> [a] pointCommand hf pos k =-    M.elems $ flip M.mapMaybeWithKey (getAsts hf) $ \fs ast ->-      -- Since GHC 9.2:-      -- getAsts :: Map HiePath (HieAst a)-      -- type HiePath = LexicalFastString-      ---      -- but before:-      -- getAsts :: Map HiePath (HieAst a)-      -- type HiePath = FastString-      ---      -- 'coerce' here to avoid an additional function for maintaining-      -- backwards compatibility.-      case selectSmallestContaining (sp $ coerce fs) ast of+    M.elems $ flip M.mapMaybeWithKey (getAsts hf) $ \(LexicalFastString fs) ast ->+      case selectSmallestContaining (sp fs) ast of         Nothing   -> Nothing         Just ast' -> Just $ k ast'  where

@@ -22,6 +22,7 @@ import           Data.Maybe import qualified Data.Set                        as S import qualified Data.Text                       as T+import           Data.Version                    (showVersion) import           Development.IDE.Core.Compile import           Development.IDE.Core.RuleTypes import           Development.IDE.GHC.Compat@@ -29,8 +30,12 @@ import           Development.IDE.GHC.Error import           Development.IDE.GHC.Util        (printOutputable) import           Development.IDE.Spans.Common+import           Development.IDE.Types.Options   (LinkTargets (..)) import           GHC.Iface.Ext.Utils             (RefMap)-import           Language.LSP.Protocol.Types     (filePathToUri, getUri)+import           GHC.Plugins                     (GenericUnitInfo (unitPackageName))+import           Ide.Types                       (OptLinkTo (..))+import           Language.LSP.Protocol.Types     (Uri (..), filePathToUri,+                                                  getUri) import           Prelude                         hiding (mod) import           System.Directory import           System.FilePath@@ -40,8 +45,9 @@   :: HscEnv   -> RefMap a   -> TcGblEnv+  -> LinkTargets   -> IO DocAndTyThingMap-mkDocMap env rm this_mod =+mkDocMap env rm this_mod linkTgts =   do      (Just Docs{docs_decls = UniqMap this_docs, docs_args = UniqMap this_arg_docs}) <- extractDocs (hsc_dflags env) this_mod      d <- foldrM getDocs (fmap (\(_, x) -> (map hsDocString x) `SpanDocString` SpanDocUris Nothing Nothing) this_docs) names@@ -52,7 +58,7 @@     getDocs n nameMap       | maybe True (mod ==) $ nameModule_maybe n = pure nameMap -- we already have the docs in this_docs, or they do not exist       | otherwise = do-      (doc, _argDoc) <- getDocumentationTryGhc env n+      (doc, _argDoc) <- getDocumentationTryGhc env linkTgts n       pure $ extendNameEnv nameMap n doc     getType n nameMap       | Nothing <- lookupNameEnv nameMap n@@ -62,7 +68,7 @@     getArgDocs n nameMap       | maybe True (mod ==) $ nameModule_maybe n = pure nameMap       | otherwise = do-      (_doc, argDoc) <- getDocumentationTryGhc env n+      (_doc, argDoc) <- getDocumentationTryGhc env linkTgts n       pure $ extendNameEnv nameMap n argDoc     names = rights $ S.toList idents     idents = M.keysSet rm@@ -72,13 +78,13 @@ lookupKind env =     fmap (fromRight Nothing) . catchSrcErrors (hsc_dflags env) "span" . lookupName env -getDocumentationTryGhc :: HscEnv -> Name -> IO (SpanDoc, IntMap SpanDoc)-getDocumentationTryGhc env n =-  (fromMaybe (emptySpanDoc, mempty) . listToMaybe <$> getDocumentationsTryGhc env [n])+getDocumentationTryGhc :: HscEnv -> LinkTargets -> Name -> IO (SpanDoc, IntMap SpanDoc)+getDocumentationTryGhc env l2h n =+  (fromMaybe (emptySpanDoc, mempty) . listToMaybe <$> getDocumentationsTryGhc env l2h [n])     `catch` (\(_ :: IOEnvFailure) -> pure (emptySpanDoc, mempty)) -getDocumentationsTryGhc :: HscEnv -> [Name] -> IO [(SpanDoc, IntMap SpanDoc)]-getDocumentationsTryGhc env names = do+getDocumentationsTryGhc :: HscEnv -> LinkTargets -> [Name] -> IO [(SpanDoc, IntMap SpanDoc)]+getDocumentationsTryGhc env linkTgts names = do   resOr <- catchSrcErrors (hsc_dflags env) "docs" $ getDocsBatch env names   case resOr of       Left _    -> return []@@ -95,10 +101,20 @@       (docFu, srcFu) <-         case nameModule_maybe name of           Just mod -> liftIO $ do-            doc <- toFileUriText $ lookupDocHtmlForModule env mod-            src <- toFileUriText $ lookupSrcHtmlForModule env mod-            return (doc, src)+            doc <- lookupDocHtmlForModule env mod+            src <- lookupSrcHtmlForModule env mod+            -- If found, the local files are used as hints for the hackage links, this helps with symbols defined in an internal module but re-exported by another.+            let+              LinkTargets{linkDoc,linkSource} = linkTgts+              doc_link = case linkDoc of+                LinkToHackage -> toHackageDocUriText env mod (takeFileName <$> doc)+                LinkToLocal   -> toFileUriText doc+              src_link = case linkSource of+                LinkToHackage -> toHackageSrcUriText env mod (takeFileName <$> src)+                LinkToLocal   -> toFileUriText src+            pure (doc_link, src_link)           Nothing -> pure (Nothing, Nothing)+       let docUri = (<> "#" <> selector <> printOutputable name) <$> docFu           srcUri = (<> "#" <> printOutputable name) <$> srcFu           selector@@ -106,7 +122,21 @@             | otherwise = "t:"       return $ SpanDocUris docUri srcUri -    toFileUriText = (fmap . fmap) (getUri . filePathToUri)+    toFileUriText = fmap (getUri . filePathToUri)+    toHackageUriText subdir sep env mod hint = do+     ui <- lookupUnit env (moduleUnit mod)+     let htmlFile = case hint of+           Nothing -> T.intercalate sep (map T.pack $ moduleNameChunks mod) <> ".html"+           Just foundFile -> T.replace "-" sep $ T.pack foundFile+     pure $!+      mconcat $+      [ "https://hackage.haskell.org/package/"+      , printOutputable (unitPackageName ui), "-", T.pack $ showVersion (unitPackageVersion ui), "/"+      , subdir , "/"+      , htmlFile+      ]+    toHackageDocUriText mod = toHackageUriText "docs" "-" mod+    toHackageSrcUriText mod = toHackageUriText "docs/src" "." mod  getDocumentation  :: HasSrcSpan name@@ -146,9 +176,12 @@     --  first Language.LSP.Types.Uri.html and Language-Haskell-LSP-Types-Uri.html     --  then Language.LSP.Types.html and Language-Haskell-LSP-Types.html etc.     mns = do-      chunks <- (reverse . drop1 . inits . splitOn ".") $ (moduleNameString . moduleName) m+      chunks <- (reverse . drop1 . inits) $ moduleNameChunks m       -- The file might use "." or "-" as separator       map (`intercalate` chunks) [".", "-"]++moduleNameChunks :: Module -> [String]+moduleNameChunks m = splitOn "." $ (moduleNameString . moduleName) m  lookupHtmls :: HscEnv -> Unit -> Maybe [FilePath] lookupHtmls df ui =

@@ -164,7 +164,7 @@   in   ideErrorFromLspDiag lspDiagnostic fdFilePath origMsg --- | Defines whether a particular diagnostic should be reported+-- | Defines whether a particular diagnostic should be reported --   back to the user. -- --   One important use case is "missing signature" code lenses,

@@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-} module Development.IDE.Types.HscEnvEq (   HscEnvEq,-    hscEnv, newHscEnvEq,+    hscEnv, newHscEnvEq, envRepresentative,     updateHscEnvEq,     envPackageExports,     envVisibleModuleNames,@@ -12,6 +12,7 @@ import           Control.Concurrent.Strict       (modifyVar, newVar) import           Control.DeepSeq                 (force, rwhnf) import           Control.Exception               (evaluate, mask, throwIO)+import qualified Control.Exception               as Exc import           Control.Monad.Extra             (eitherM, join, mapMaybeM) import           Data.Either                     (fromRight) import           Data.IORef@@ -23,6 +24,7 @@ import           Development.IDE.GHC.Util        (lookupPackageConfig) import           Development.IDE.Graph.Classes import           Development.IDE.Types.Exports   (ExportsMap, createExportsMap)+import           Development.IDE.Types.Location  (NormalizedFilePath) import           GHC.Driver.Env                  (hsc_all_home_unit_ids) import           OpenTelemetry.Eventlog          (withSpan) @@ -39,6 +41,8 @@         -- but it could panic due to a ghc bug: https://github.com/haskell/haskell-language-server/issues/1365         -- So it's wrapped in IO here for error handling         -- If Nothing, 'listVisibleModuleNames' panic+    , envRepresentative     :: !NormalizedFilePath+        -- ^ See Note [Session representatives]     }  updateHscEnvEq :: HscEnvEq -> HscEnv -> IO HscEnvEq@@ -47,8 +51,8 @@   update <$> Unique.newUnique  -- | Wrap an 'HscEnv' into an 'HscEnvEq'.-newHscEnvEq :: HscEnv -> IO HscEnvEq-newHscEnvEq hscEnv' = do+newHscEnvEq :: NormalizedFilePath -> HscEnv -> IO HscEnvEq+newHscEnvEq envRepresentative hscEnv' = do      mod_cache <- newIORef emptyInstalledModuleEnv     -- This finder cache is for things which are outside of things which are tracked@@ -56,14 +60,14 @@ #if MIN_VERSION_ghc(9,11,0)     let hscEnv = hscEnv'                { hsc_FC = FinderCache-                        { flushFinderCaches = \_ -> error "GHC should never call flushFinderCaches outside the driver"+                        { flushFinderCaches = \_ -> throwIO $ Exc.ErrorCall "flushFinderCaches: GHC should never call flushFinderCaches outside the driver" #if MIN_VERSION_ghc(9,13,0)                         , addToFinderCache  = \im val -> do #else                         , addToFinderCache  = \(GWIB im _) val -> do #endif                             if moduleUnit im `elem` hsc_all_home_unit_ids hscEnv'-                            then error "tried to add home module to FC"+                            then throwIO $ Exc.ErrorCall "addToFinderCache: tried to add home module to FC"                             else atomicModifyIORef' mod_cache $ \c -> (extendInstalledModuleEnv c im val, ()) #if MIN_VERSION_ghc(9,13,0)                         , lookupFinderCache = \im -> do@@ -71,9 +75,9 @@                         , lookupFinderCache = \(GWIB im _) -> do #endif                             if moduleUnit im `elem` hsc_all_home_unit_ids hscEnv'-                            then error ("tried to lookup home module from FC" ++ showSDocUnsafe (ppr (im, hsc_all_home_unit_ids hscEnv')))+                            then throwIO $ Exc.ErrorCall ("lookupFinderCache: tried to lookup home module from FC: " ++ showSDocUnsafe (ppr (im, hsc_all_home_unit_ids hscEnv')))                             else lookupInstalledModuleEnv <$> readIORef mod_cache <*> pure im-                        , lookupFileCache = \fp -> error ("not used by HLS" ++ fp)+                        , lookupFileCache = \fp -> throwIO $ Exc.ErrorCall ("lookupFileCache: Called without using setFileCacheHook for target: " ++ fp)                         }                 } @@ -128,9 +132,9 @@   a == b = envUnique a == envUnique b  instance NFData HscEnvEq where-  rnf (HscEnvEq a b _ _) =+  rnf (HscEnvEq a b _ _ e) =       -- deliberately skip the package exports map and visible module names-      rnf (Unique.hashUnique a) `seq` rwhnf b+      rnf (Unique.hashUnique a) `seq` rwhnf b `seq` rnf e  instance Hashable HscEnvEq where   hashWithSalt s = hashWithSalt s . envUnique

@@ -3,9 +3,12 @@ module Development.IDE.Types.KnownTargets ( KnownTargets(..)                                           , emptyKnownTargets                                           , mkKnownTargets+                                          , mkExtraKnownFiles                                           , unionKnownTargets+                                          , tombstoneKnownFiles                                           , Target(..)-                                          , toKnownFiles) where+                                          , toKnownFiles+                                          , toTargetFiles) where  import           Control.DeepSeq import           Data.Hashable@@ -18,34 +21,96 @@ import           Development.IDE.Types.Location import           GHC.Generics --- | A mapping of module name to known files-newtype KnownTargets = KnownTargets-  { targetMap :: (HashMap Target (HashSet NormalizedFilePath)) }+-- | What HLS knows about the files of the workspace+data KnownTargets = KnownTargets+  { targetMap  :: !(HashMap Target (HashSet NormalizedFilePath))+    -- ^ What the session loader discovered: the modules the project is made of+  , knownExtra :: !(HashSet NormalizedFilePath)+    -- ^ Files reported present by the client that no target declares. See+    -- Note [Files that are not targets]+  , knownGone  :: !(HashSet NormalizedFilePath)+    -- ^ Files reported gone by the client. See Note [Tombstones]+  }   deriving Show +{- Note [Files that are not targets]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A workspace often has source files that belong to no session/component like test+fixtures and scratch files. The client reports them like any other and we have+to record them, so that we can maintain an accurate view of the filesystem state+based off which we can run and rerun rules, particularly the ones that resolve+imports like 'GetModulesPaths' and 'GetLocatedImports'. +They are not project modules though, so they are kept apart from the targets.+'toKnownFiles' includes these files, but 'toTargetFiles' does not, because a+file without a component has no session to be compiled in.+-}++{- Note [Tombstones]+~~~~~~~~~~~~~~~~~~~~+'targetMap' is only ever added to: 'extendKnownTargets' unions into it and the+session loader never removes anything. So a file that disappears cannot be+expressed by deleting an entry. Often there is no entry to delete, and deleting+one that is not there leaves 'KnownTargets' equal to what it was, hash and all,+so the early cutoff on 'GetKnownTargets' fires and nothing reruns: the deletion+would be invisible.++Recording the deletion always changes the value, so the rules reading it rerun.+'GetModulesPaths' has to, or an import keeps resolving to a file that is gone,+since 'toKnownFiles' is what tells it about files the file system scan cannot+see. 'GetModuleGraph' has to, or a deleted target stays a root of the graph.++Both 'toKnownFiles' and 'toTargetFiles' hide tombstoned files, which also covers+a target rediscovered by a later cradle load: 'extendKnownTargets' adds the+candidate locations of a 'TargetFile' without checking they exist. A file that+comes back clears its tombstone.+-}+ unionKnownTargets :: KnownTargets -> KnownTargets -> KnownTargets-unionKnownTargets (KnownTargets tm) (KnownTargets tm') =-  KnownTargets (HMap.unionWith (<>) tm tm')+unionKnownTargets (KnownTargets tm extra gone) (KnownTargets tm' extra' gone') =+  KnownTargets (HMap.unionWith (<>) tm tm') (extra <> extra') (gone <> gone')  mkKnownTargets :: [(Target, HashSet NormalizedFilePath)] -> KnownTargets-mkKnownTargets vs = KnownTargets (HMap.fromList vs)+mkKnownTargets vs = KnownTargets (HMap.fromList vs) HSet.empty HSet.empty +-- | See Note [Files that are not targets]+mkExtraKnownFiles :: HashSet NormalizedFilePath -> KnownTargets+mkExtraKnownFiles fs = KnownTargets HMap.empty fs HSet.empty++-- | Record files as gone, and files that came back as present again.+tombstoneKnownFiles+  :: HashSet NormalizedFilePath -- ^ gone+  -> HashSet NormalizedFilePath -- ^ back+  -> KnownTargets -> KnownTargets+tombstoneKnownFiles gone back kt =+  kt { knownGone = (knownGone kt `HSet.union` gone) `HSet.difference` back }+ instance NFData KnownTargets where-  rnf (KnownTargets tm) = rnf tm `seq` ()+  rnf (KnownTargets tm extra gone) = rnf tm `seq` rnf extra `seq` rnf gone `seq` ()  instance Eq KnownTargets where   k1 == k2 = targetMap k1 == targetMap k2+          && knownExtra k1 == knownExtra k2+          && knownGone k1 == knownGone k2  instance Hashable KnownTargets where-  hashWithSalt s (KnownTargets hm) = hashWithSalt s hm+  hashWithSalt s (KnownTargets hm extra gone) =+    hashWithSalt (hashWithSalt (hashWithSalt s hm) (HSet.toList extra)) (HSet.toList gone)  emptyKnownTargets :: KnownTargets-emptyKnownTargets = KnownTargets HMap.empty+emptyKnownTargets = KnownTargets HMap.empty HSet.empty HSet.empty  data Target = TargetModule ModuleName | TargetFile NormalizedFilePath   deriving ( Eq, Ord, Generic, Show )   deriving anyclass (Hashable, NFData) +-- | Every file that is there, as far as we have been told. toKnownFiles :: KnownTargets -> HashSet NormalizedFilePath-toKnownFiles = HSet.unions . HMap.elems . targetMap+toKnownFiles kt = (targets `HSet.union` knownExtra kt) `HSet.difference` knownGone kt+  where targets = HSet.unions (HMap.elems (targetMap kt))++-- | The files of the project, as declared by the session loader.+-- See Note [Files that are not targets]+toTargetFiles :: KnownTargets -> HashSet NormalizedFilePath+toTargetFiles kt =+  HSet.unions (HMap.elems (targetMap kt)) `HSet.difference` knownGone kt

@@ -16,6 +16,8 @@   , IdeGhcSession(..)   , OptHaddockParse(..)   , ProgressReportingStyle(..)+  , LinkTargets(..)+  , linkTargets   ) where  import           Control.Lens@@ -26,7 +28,8 @@ import           Development.IDE.Graph import           Development.IDE.Types.Diagnostics import           Ide.Plugin.Config-import           Ide.Types                         (DynFlagsModifications)+import           Ide.Types                         (DynFlagsModifications,+                                                    OptLinkTo (..)) import qualified Language.LSP.Protocol.Lens        as L import qualified Language.LSP.Protocol.Types       as LSP @@ -85,8 +88,23 @@       -- ^ Experimental feature to re-run only the subset of the Shake graph that has changed   , optVerifyCoreFile     :: Bool     -- ^ Verify core files after serialization+  , optLinkSourceTo       :: OptLinkTo+    -- ^ `Source` link to Hackage or local sources.+  , optLinkDocTo          :: OptLinkTo+    -- ^ `Documentation` link to Hackage or local docs.   } +data LinkTargets = LinkTargets+  { linkSource :: !OptLinkTo+  , linkDoc    :: !OptLinkTo+  }++linkTargets :: IdeOptions -> LinkTargets+linkTargets IdeOptions{..} = LinkTargets+  { linkSource = optLinkSourceTo+  , linkDoc = optLinkDocTo+  }+ data OptHaddockParse = HaddockParse | NoHaddockParse   deriving (Eq,Ord,Show,Enum) @@ -138,6 +156,8 @@     ,optRunSubset = True     ,optVerifyCoreFile = False     ,optMaxDirtyAge = 100+    ,optLinkSourceTo = LinkToLocal+    ,optLinkDocTo = LinkToLocal     }  defaultSkipProgress :: Typeable a => a -> Bool@@ -150,6 +170,9 @@     -- don't do progress for GetModificationTime as there are lot of redundant nodes     -- (for the interface files)     _ | Just GetModificationTime_{} <- cast key -> True+    -- don't do progress for these, counted via GetModArtefacts instead+    _ | Just GetModIface <- cast key            -> True+    _ | Just GetCoreFileHash <- cast key        -> True     _                                           -> False