ghcide 1.6.0.1 → 1.7.0.0

raw patch · 68 files changed

+4482/−2832 lines, 68 filesdep +enummapsetdep ~ghc-exactprintdep ~hie-biosdep ~hls-graphnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: enummapset

Dependency ranges changed: ghc-exactprint, hie-bios, hls-graph, hls-plugin-api, prettyprinter, unliftio

API changes (from Hackage documentation)

Files

• bench/hist/Main.hs +2/−1
• bench/lib/Experiments.hs +26/−8
• exe/Main.hs +76/−17
• ghcide.cabal +14/−8
• session-loader/Development/IDE/Session.hs +186/−90
• src/Development/IDE.hs +3/−3
• src/Development/IDE/Core/Compile.hs +395/−113
• src/Development/IDE/Core/FileExists.hs +45/−39
• src/Development/IDE/Core/FileStore.hs +68/−101
• src/Development/IDE/Core/FileUtils.hs +31/−0
• src/Development/IDE/Core/OfInterest.hs +22/−7
• src/Development/IDE/Core/RuleTypes.hs +17/−6
• src/Development/IDE/Core/Rules.hs +206/−191
• src/Development/IDE/Core/Service.hs +31/−10
• src/Development/IDE/Core/Shake.hs +272/−216
• src/Development/IDE/Core/UseStale.hs +162/−162
• src/Development/IDE/GHC/CPP.hs +63/−63
• src/Development/IDE/GHC/Compat.hs +155/−1
• src/Development/IDE/GHC/Compat/CPP.hs +204/−204
• src/Development/IDE/GHC/Compat/Core.hs +8/−0
• src/Development/IDE/GHC/Compat/Outputable.hs +35/−24
• src/Development/IDE/GHC/Compat/Parser.hs +17/−2
• src/Development/IDE/GHC/ExactPrint.hs +15/−14
• src/Development/IDE/GHC/Orphans.hs +23/−12
• src/Development/IDE/GHC/Util.hs +19/−12
• src/Development/IDE/Import/DependencyInformation.hs +2/−4
• src/Development/IDE/LSP/LanguageServer.hs +45/−28
• src/Development/IDE/LSP/Notifications.hs +33/−20
• src/Development/IDE/LSP/Outline.hs +23/−29
• src/Development/IDE/LSP/Server.hs +7/−4
• src/Development/IDE/Main.hs +113/−69
• src/Development/IDE/Main/HeapStats.hs +75/−53
• src/Development/IDE/Plugin/CodeAction.hs +48/−30
• src/Development/IDE/Plugin/CodeAction/Args.hs +1/−1
• src/Development/IDE/Plugin/CodeAction/ExactPrint.hs +61/−17
• src/Development/IDE/Plugin/Completions.hs +24/−11
• src/Development/IDE/Plugin/Completions/Logic.hs +20/−23
• src/Development/IDE/Plugin/HLS.hs +21/−11
• src/Development/IDE/Plugin/HLS/GhcIde.hs +18/−5
• src/Development/IDE/Plugin/Test.hs +5/−0
• src/Development/IDE/Plugin/TypeLenses.hs +18/−7
• src/Development/IDE/Spans/AtPoint.hs +12/−11
• src/Development/IDE/Spans/Common.hs +31/−20
• src/Development/IDE/Spans/Documentation.hs +225/−224
• src/Development/IDE/Spans/LocalBindings.hs +140/−140
• src/Development/IDE/Spans/Pragmas.hs +11/−2
• src/Development/IDE/Types/Exports.hs +8/−9
• src/Development/IDE/Types/HscEnvEq.hs +153/−153
• src/Development/IDE/Types/Logger.hs +313/−10
• src/Development/IDE/Types/Options.hs +1/−11
• src/Development/IDE/Types/Shake.hs +3/−3
• src/Generics/SYB/GHC.hs +124/−124
• src/Text/Fuzzy/Parallel.hs +93/−138
• test/data/cabal-exe/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-0.1.0.0/x/a/build/a/autogen/Paths_a.hs +0/−50
• test/data/hover/GotoHover.hs +3/−0
• test/data/multi/a/A.hs +1/−1
• test/data/multi/a/a.cabal +1/−1
• test/data/multi/c/C.hs +3/−0
• test/data/multi/c/c.cabal +9/−0
• test/data/multi/cabal.project +1/−1
• test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.2/a-1.0.0/build/autogen/Paths_a.hs +0/−50
• test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-1.0.0/build/autogen/Paths_a.hs +0/−50
• test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/b-1.0.0/build/autogen/Paths_b.hs +0/−50
• test/data/multi/hie.yaml +2/−0
• test/exe/FuzzySearch.hs +132/−0
• test/exe/HieDbRetry.hs +27/−16
• test/exe/Main.hs +555/−151
• test/src/Development/IDE/Test.hs +25/−1

@@ -57,7 +57,6 @@ import           System.Console.GetOpt import           System.FilePath - configPath :: FilePath configPath = "bench/config.yaml" @@ -88,6 +87,8 @@ ghcideBuildRules = MkBuildRules findGhcForBuildSystem "ghcide" projectDepends buildGhcide   where       projectDepends = do+        need . map ("../hls-graph/src" </>) =<< getDirectoryFiles "../hls-graph/src" ["//*.hs"]+        need . map ("../hls-plugin-api/src" </>) =<< getDirectoryFiles "../hls-plugin-api/src" ["//*.hs"]         need . map ("src" </>) =<< getDirectoryFiles "src" ["//*.hs"]         need . map ("session-loader" </>) =<< getDirectoryFiles "session-loader" ["//*.hs"]         need =<< getDirectoryFiles "." ["*.cabal"]

@@ -37,7 +37,9 @@                                                   getBuildKeysBuilt,                                                   getBuildKeysChanged,                                                   getBuildKeysVisited,-                                                  getStoredKeys)+                                                  getStoredKeys,+                                                  getRebuildsCount,+                                                  ) import           Development.IDE.Test.Diagnostic import           Development.Shake               (CmdOption (Cwd, FileStdout),                                                   cmd_)@@ -329,12 +331,15 @@         , "setup"         , "userTime"         , "delayedTime"+        , "firstBuildTime"+        , "averageTimePerResponse"         , "totalTime"         , "buildRulesBuilt"         , "buildRulesChanged"         , "buildRulesVisited"         , "buildRulesTotal"         , "buildEdges"+        , "ghcRebuilds"         ]       rows =         [ [ name,@@ -344,15 +349,21 @@             show runSetup',             show userWaits,             show delayedWork,+            show $ firstResponse+firstResponseDelayed,+            -- Exclude first response as it has a lot of setup time included+            -- Assume that number of requests = number of modules * number of samples+            show ((userWaits - firstResponse)/((fromIntegral samples - 1)*modules)),             show runExperiment,             show rulesBuilt,             show rulesChanged,             show rulesVisited,             show rulesTotal,-            show edgesTotal+            show edgesTotal,+            show rebuildsTotal           ]           | (Bench {name, samples}, BenchRun {..}) <- results,             let runSetup' = if runSetup < 0.01 then 0 else runSetup+                modules = fromIntegral $ length $ exampleModules $ example ?config         ]       csv = unlines $ map (intercalate ", ") (headers : rows)   writeFile (outputCSV ?config) csv@@ -369,12 +380,14 @@             showDuration runSetup',             showDuration userWaits,             showDuration delayedWork,+            showDuration firstResponse,             showDuration runExperiment,             show rulesBuilt,             show rulesChanged,             show rulesVisited,             show rulesTotal,-            show edgesTotal+            show edgesTotal,+            show rebuildsTotal           ]           | (Bench {name, samples}, BenchRun {..}) <- results,             let runSetup' = if runSetup < 0.01 then 0 else runSetup@@ -420,16 +433,19 @@     runExperiment :: !Seconds,     userWaits     :: !Seconds,     delayedWork   :: !Seconds,+    firstResponse :: !Seconds,+    firstResponseDelayed :: !Seconds,     rulesBuilt    :: !Int,     rulesChanged  :: !Int,     rulesVisited  :: !Int,     rulesTotal    :: !Int,     edgesTotal    :: !Int,+    rebuildsTotal :: !Int,     success       :: !Bool   }  badRun :: BenchRun-badRun = BenchRun 0 0 0 0 0 0 0 0 0 0 False+badRun = BenchRun 0 0 0 0 0 0 0 0 0 0 0 0 0 False  waitForProgressStart :: Session () waitForProgressStart = void $ do@@ -482,8 +498,8 @@        liftIO $ output $ "Running " <> name <> " benchmark"       (runSetup, ()) <- duration $ benchSetup docs-      let loop !userWaits !delayedWork 0 = return $ Just (userWaits, delayedWork)-          loop !userWaits !delayedWork n = do+      let loop' (Just timeForFirstResponse) !userWaits !delayedWork 0 = return $ Just (userWaits, delayedWork, timeForFirstResponse)+          loop' timeForFirstResponse !userWaits !delayedWork n = do             (t, res) <- duration $ experiment docs             if not res               then return Nothing@@ -491,17 +507,19 @@                 output (showDuration t)                 -- Wait for the delayed actions to finish                 td <- waitForBuildQueue-                loop (userWaits+t) (delayedWork+td) (n -1)+                loop' (timeForFirstResponse <|> (Just (t,td))) (userWaits+t) (delayedWork+td) (n -1)+          loop = loop' Nothing        (runExperiment, result) <- duration $ loop 0 0 samples       let success = isJust result-          (userWaits, delayedWork) = fromMaybe (0,0) result+          (userWaits, delayedWork, (firstResponse, firstResponseDelayed)) = fromMaybe (0,0,(0,0)) result        rulesTotal <- length <$> getStoredKeys       rulesBuilt <- either (const 0) length <$> getBuildKeysBuilt       rulesChanged <- either (const 0) length <$> getBuildKeysChanged       rulesVisited <- either (const 0) length <$> getBuildKeysVisited       edgesTotal   <- fromRight 0 <$> getBuildEdgesCount+      rebuildsTotal <- fromRight 0 <$> getRebuildsCount        return BenchRun {..} 

@@ -8,20 +8,34 @@ import           Arguments                         (Arguments (..),                                                     getArguments) import           Control.Monad.Extra               (unless)+import           Control.Monad.IO.Class            (liftIO) import           Data.Default                      (def)+import           Data.Function                     ((&)) import           Data.Version                      (showVersion) import           Development.GitRev                (gitHash)-import           Development.IDE                   (Priority (Debug, Info),-                                                    action)+import           Development.IDE                   (action) import           Development.IDE.Core.OfInterest   (kick) import           Development.IDE.Core.Rules        (mainRule)+import qualified Development.IDE.Core.Rules        as Rules import           Development.IDE.Core.Tracing      (withTelemetryLogger)-import           Development.IDE.Graph             (ShakeOptions (shakeThreads))-import qualified Development.IDE.Main              as Main+import qualified Development.IDE.Main              as IDEMain import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde+import           Development.IDE.Types.Logger      (Logger (Logger),+                                                    LoggingColumn (DataColumn, PriorityColumn),+                                                    Pretty (pretty),+                                                    Priority (Debug, Info, Error),+                                                    Recorder (Recorder),+                                                    WithPriority (WithPriority, priority),+                                                    cfilter, cmapWithPrio,+                                                    makeDefaultStderrRecorder, layoutPretty, renderStrict, defaultLayoutOptions)+import qualified Development.IDE.Types.Logger      as Logger import           Development.IDE.Types.Options+import           GHC.Stack                         (emptyCallStack)+import           Language.LSP.Server               as LSP+import           Language.LSP.Types                as LSP import           Ide.Plugin.Config                 (Config (checkParents, checkProject)) import           Ide.PluginUtils                   (pluginDescToIdePlugins)+import           Ide.Types                         (PluginDescriptor (pluginNotificationHandlers), defaultPluginDescriptor, mkPluginNotificationHandler) import           Paths_ghcide                      (version) import qualified System.Directory.Extra            as IO import           System.Environment                (getExecutablePath)@@ -29,6 +43,17 @@ import           System.IO                         (hPutStrLn, stderr) import           System.Info                       (compilerVersion) +data Log+  = LogIDEMain IDEMain.Log+  | LogRules Rules.Log+  | LogGhcIde GhcIde.Log++instance Pretty Log where+  pretty = \case+    LogIDEMain log -> pretty log+    LogRules log   -> pretty log+    LogGhcIde log  -> pretty log+ ghcideVersion :: IO String ghcideVersion = do   path <- getExecutablePath@@ -42,7 +67,12 @@  main :: IO () main = withTelemetryLogger $ \telemetryLogger -> do-    let hlsPlugins = pluginDescToIdePlugins GhcIde.descriptors+    -- stderr recorder just for plugin cli commands+    pluginCliRecorder <-+      cmapWithPrio pretty+      <$> makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) Info++    let hlsPlugins = pluginDescToIdePlugins (GhcIde.descriptors (cmapWithPrio LogGhcIde pluginCliRecorder))     -- WARNING: If you write to stdout before runLanguageServer     --          then the language server will not work     Arguments{..} <- getArguments hlsPlugins@@ -55,30 +85,59 @@       Nothing   -> IO.getCurrentDirectory       Just root -> IO.setCurrentDirectory root >> IO.getCurrentDirectory -    let logPriority = if argsVerbose then Debug else Info-        arguments = if argsTesting then Main.testing else Main.defaultArguments logPriority+    let minPriority = if argsVerbose then Debug else Info -    Main.defaultMain arguments-        { Main.argsProjectRoot = Just argsCwd-        , Main.argCommand = argsCommand-        ,Main.argsLogger = Main.argsLogger arguments <> pure telemetryLogger+    docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) minPriority -        ,Main.argsRules = do+    (lspLogRecorder, cb1) <- Logger.withBacklog Logger.lspClientLogRecorder+    (lspMessageRecorder, cb2) <- Logger.withBacklog Logger.lspClientMessageRecorder+    -- This plugin just installs a handler for the `initialized` notification, which then+    -- picks up the LSP environment and feeds it to our recorders+    let lspRecorderPlugin = (defaultPluginDescriptor "LSPRecorderCallback")+          { pluginNotificationHandlers = mkPluginNotificationHandler LSP.SInitialized $ \_ _ _ _ -> do+              env <- LSP.getLspEnv+              liftIO $ (cb1 <> cb2) env+          }++    let docWithFilteredPriorityRecorder =+          (docWithPriorityRecorder & cfilter (\WithPriority{ priority } -> priority >= minPriority)) <>+          (lspLogRecorder & cmapWithPrio (renderStrict . layoutPretty defaultLayoutOptions)+                          & cfilter (\WithPriority{ priority } -> priority >= minPriority)) <>+          (lspMessageRecorder & cmapWithPrio (renderStrict . layoutPretty defaultLayoutOptions)+                              & cfilter (\WithPriority{ priority } -> priority >= Error))++    -- exists so old-style logging works. intended to be phased out+    let logger = Logger $ \p m -> Logger.logger_ docWithFilteredPriorityRecorder (WithPriority p emptyCallStack (pretty m))++    let recorder = docWithFilteredPriorityRecorder+                 & cmapWithPrio pretty++    let arguments =+          if argsTesting+          then IDEMain.testing (cmapWithPrio LogIDEMain recorder) logger+          else IDEMain.defaultArguments (cmapWithPrio LogIDEMain recorder) logger++    IDEMain.defaultMain (cmapWithPrio LogIDEMain recorder) arguments+        { IDEMain.argsProjectRoot = Just argsCwd+        , IDEMain.argCommand = argsCommand+        , IDEMain.argsLogger = IDEMain.argsLogger arguments <> pure telemetryLogger+        , IDEMain.argsHlsPlugins = IDEMain.argsHlsPlugins arguments <> pluginDescToIdePlugins [lspRecorderPlugin]++        , IDEMain.argsRules = do             -- install the main and ghcide-plugin rules-            mainRule def+            mainRule (cmapWithPrio LogRules recorder) def             -- install the kick action, which triggers a typecheck on every             -- Shake database restart, i.e. on every user edit.             unless argsDisableKick $                 action kick -        ,Main.argsThreads = case argsThreads of 0 -> Nothing ; i -> Just (fromIntegral i)+        , IDEMain.argsThreads = case argsThreads of 0 -> Nothing ; i -> Just (fromIntegral i) -        ,Main.argsIdeOptions = \config sessionLoader ->-            let defOptions = Main.argsIdeOptions arguments config sessionLoader+        , IDEMain.argsIdeOptions = \config sessionLoader ->+            let defOptions = IDEMain.argsIdeOptions arguments config sessionLoader             in defOptions                 { optShakeProfiling = argsShakeProfiling                 , optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling-                , optShakeOptions = (optShakeOptions defOptions){shakeThreads = argsThreads}                 , optCheckParents = pure $ checkParents config                 , optCheckProject = pure $ checkProject config                 , optRunSubset = not argsConservativeChangeTracking

@@ -2,7 +2,7 @@ build-type:         Simple category:           Development name:               ghcide-version:            1.6.0.1+version:            1.7.0.0 license:            Apache-2.0 license-file:       LICENSE author:             Digital Asset and Ghcide contributors@@ -13,7 +13,7 @@     A library for building Haskell IDE's on top of the GHC API. homepage:           https://github.com/haskell/haskell-language-server/tree/master/ghcide#readme bug-reports:        https://github.com/haskell/haskell-language-server/issues-tested-with:        GHC == 8.6.5 || == 8.8.4 || == 8.10.6 || == 8.10.7 || == 9.0.1 || == 9.0.2 || == 9.2.1+tested-with:        GHC == 8.6.5 || == 8.8.4 || == 8.10.6 || == 8.10.7 || == 9.0.1 || == 9.0.2 || == 9.2.1 || == 9.2.2 extra-source-files: README.md CHANGELOG.md                     test/data/**/*.project                     test/data/**/*.cabal@@ -50,7 +50,7 @@         dlist,         exceptions,         extra >= 1.7.4,-        fuzzy,+        enummapset,         filepath,         fingertree,         focus,@@ -60,7 +60,7 @@         haddock-library >= 1.8 && < 1.11,         hashable,         hie-compat ^>= 0.2.0.0,-        hls-plugin-api ^>= 1.2.0.2 || ^>= 1.3,+        hls-plugin-api ^>= 1.4,         lens,         list-t,         hiedb == 0.4.1.*,@@ -79,7 +79,7 @@         rope-utf16-splay,         safe,         safe-exceptions,-        hls-graph ^>= 1.6,+        hls-graph ^>= 1.7,         sorted-list,         sqlite-simple,         stm,@@ -105,7 +105,7 @@         ghc-check >=0.5.0.4,         ghc-paths,         cryptohash-sha1 >=0.11.100 && <0.12,-        hie-bios >= 0.8 && < 0.9.0,+        hie-bios ^>= 0.9.1,         implicit-hie-cradle ^>= 0.3.0.5 || ^>= 0.5,         base16-bytestring >=0.1.1 && <1.1     if os(windows)@@ -148,6 +148,7 @@         Development.IDE.Main.HeapStats         Development.IDE.Core.Debouncer         Development.IDE.Core.FileStore+        Development.IDE.Core.FileUtils         Development.IDE.Core.IdeConfiguration         Development.IDE.Core.OfInterest         Development.IDE.Core.PositionMapping@@ -205,6 +206,7 @@         Development.IDE.Plugin.HLS.GhcIde         Development.IDE.Plugin.Test         Development.IDE.Plugin.TypeLenses+        Text.Fuzzy.Parallel      other-modules:         Development.IDE.Core.FileExists@@ -216,7 +218,6 @@         Development.IDE.Plugin.Completions.Logic         Development.IDE.Session.VersionCheck         Development.IDE.Types.Action-        Text.Fuzzy.Parallel      ghc-options:                 -Wall@@ -371,6 +372,7 @@         directory,         extra,         filepath,+        fuzzy,         --------------------------------------------------------------         -- The MIN_VERSION_ghc macro relies on MIN_VERSION pragmas         -- which require depending on ghc. So the tests need to depend@@ -385,11 +387,13 @@         lsp,         lsp-types,         hls-plugin-api,-        network-uri,         lens,         list-t,         lsp-test ^>= 0.14,+        monoid-subclasses,+        network-uri,         optparse-applicative,+        parallel,         process,         QuickCheck,         quickcheck-instances,@@ -410,6 +414,7 @@         tasty-rerun,         text,         unordered-containers,+        vector,     if (impl(ghc >= 8.6) && impl(ghc < 9.2))       build-depends:           record-dot-preprocessor,@@ -423,6 +428,7 @@         Development.IDE.Test.Runfiles         Experiments         Experiments.Types+        FuzzySearch         Progress         HieDbRetry     default-extensions:

@@ -1,5 +1,6 @@-{-# LANGUAGE RankNTypes   #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes                #-}+{-# LANGUAGE TypeFamilies              #-}  {-| The logic for setting up a ghcide session by tapping into hie-bios.@@ -14,6 +15,7 @@   ,runWithDb   ,retryOnSqliteBusy   ,retryOnException+  ,Log(..)   ) where  -- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses@@ -27,7 +29,7 @@ import           Control.Monad.Extra import           Control.Monad.IO.Class import qualified Crypto.Hash.SHA1                     as H-import           Data.Aeson+import           Data.Aeson                           hiding (Error) import           Data.Bifunctor import qualified Data.ByteString.Base16               as B16 import qualified Data.ByteString.Char8                as B@@ -44,11 +46,12 @@ import           Data.Time.Clock import           Data.Version import           Development.IDE.Core.RuleTypes-import           Development.IDE.Core.Shake           hiding (withHieDb)+import           Development.IDE.Core.Shake           hiding (Log, Priority,+                                                       withHieDb) import qualified Development.IDE.GHC.Compat           as Compat import           Development.IDE.GHC.Compat.Core      hiding (Target,                                                        TargetFile, TargetModule,-                                                       Var)+                                                       Var, Warning) import qualified Development.IDE.GHC.Compat.Core      as GHC import           Development.IDE.GHC.Compat.Env       hiding (Logger) import           Development.IDE.GHC.Compat.Units     (UnitId)@@ -60,7 +63,11 @@ import           Development.IDE.Types.HscEnvEq       (HscEnvEq, newHscEnvEq,                                                        newHscEnvEqPreserveImportPaths) import           Development.IDE.Types.Location-import           Development.IDE.Types.Logger+import           Development.IDE.Types.Logger         (Pretty (pretty),+                                                       Priority (Debug, Error, Info, Warning),+                                                       Recorder, WithPriority,+                                                       logWith, nest, vcat,+                                                       viaShow, (<+>)) import           Development.IDE.Types.Options import           GHC.Check import qualified HIE.Bios                             as HieBios@@ -72,7 +79,6 @@ import           System.Directory import qualified System.Directory.Extra               as IO import           System.FilePath-import           System.IO import           System.Info  import           Control.Applicative                  (Alternative ((<|>)))@@ -82,6 +88,8 @@                                                        readTVar, writeTVar) import           Control.Concurrent.STM.TQueue import           Data.Foldable                        (for_)+import           Data.HashMap.Strict                  (HashMap)+import           Data.HashSet                         (HashSet) import qualified Data.HashSet                         as Set import           Database.SQLite.Simple import           Development.IDE.Core.Tracing         (withTrace)@@ -91,7 +99,96 @@ import           HieDb.Utils import           System.Random                        (RandomGen) import qualified System.Random                        as Random+import Control.Monad.IO.Unlift (MonadUnliftIO) +data Log+  = LogSettingInitialDynFlags+  | LogGetInitialGhcLibDirDefaultCradleFail !CradleError !FilePath !(Maybe FilePath) !(Cradle Void)+  | LogGetInitialGhcLibDirDefaultCradleNone+  | LogHieDbRetry !Int !Int !Int !SomeException+  | LogHieDbRetriesExhausted !Int !Int !Int !SomeException+  | LogHieDbWriterThreadSQLiteError !SQLError+  | LogHieDbWriterThreadException !SomeException+  | LogInterfaceFilesCacheDir !FilePath+  | LogKnownFilesUpdated !(HashMap Target (HashSet NormalizedFilePath))+  | LogMakingNewHscEnv ![UnitId]+  | LogDLLLoadError !String+  | LogCradlePath !FilePath+  | LogCradleNotFound !FilePath+  | LogSessionLoadingResult !(Either [CradleError] (ComponentOptions, FilePath))+  | LogCradle !(Cradle Void)+  | LogNoneCradleFound FilePath+  | LogNewComponentCache !(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)+deriving instance Show Log++instance Pretty Log where+  pretty = \case+    LogNoneCradleFound path ->+      "None cradle found for" <+> pretty path <+> ", ignoring the file"+    LogSettingInitialDynFlags ->+      "Setting initial dynflags..."+    LogGetInitialGhcLibDirDefaultCradleFail cradleError rootDirPath hieYamlPath cradle ->+      nest 2 $+        vcat+          [ "Couldn't load cradle for ghc libdir."+          , "Cradle error:" <+> viaShow cradleError+          , "Root dir path:" <+> pretty rootDirPath+          , "hie.yaml path:" <+> pretty hieYamlPath+          , "Cradle:" <+> viaShow cradle ]+    LogGetInitialGhcLibDirDefaultCradleNone ->+      "Couldn't load cradle. Cradle not found."+    LogHieDbRetry delay maxDelay maxRetryCount e ->+      nest 2 $+        vcat+          [ "Retrying hiedb action..."+          , "delay:" <+> pretty delay+          , "maximum delay:" <+> pretty maxDelay+          , "retries remaining:" <+> pretty maxRetryCount+          , "SQLite error:" <+> pretty (displayException e) ]+    LogHieDbRetriesExhausted baseDelay maxDelay maxRetryCount e ->+      nest 2 $+        vcat+          [ "Retries exhausted for hiedb action."+          , "base delay:" <+> pretty baseDelay+          , "maximum delay:" <+> pretty maxDelay+          , "retries remaining:" <+> pretty maxRetryCount+          , "Exception:" <+> pretty (displayException e) ]+    LogHieDbWriterThreadSQLiteError e ->+      nest 2 $+        vcat+          [ "HieDb writer thread SQLite error:"+          , pretty (displayException e) ]+    LogHieDbWriterThreadException e ->+      nest 2 $+        vcat+          [ "HieDb writer thread exception:"+          , pretty (displayException e) ]+    LogInterfaceFilesCacheDir path ->+      "Interface files cache directory:" <+> pretty path+    LogKnownFilesUpdated targetToPathsMap ->+      nest 2 $+        vcat+          [ "Known files updated:"+          , viaShow $ (HM.map . Set.map) fromNormalizedFilePath targetToPathsMap+          ]+    LogMakingNewHscEnv inPlaceUnitIds ->+      "Making new HscEnv. In-place unit ids:" <+> pretty (map show inPlaceUnitIds)+    LogDLLLoadError errorString ->+      "Error dynamically loading libm.so.6:" <+> pretty errorString+    LogCradlePath path ->+      "Cradle path:" <+> pretty path+    LogCradleNotFound path ->+      vcat+        [ "No [cradle](https://github.com/mpickering/hie-bios#hie-bios) found for" <+> pretty path <> "."+        , "Proceeding with [implicit cradle](https://hackage.haskell.org/package/implicit-hie)."+        , "You should ignore this message, unless you see a 'Multi Cradle: No prefixes matched' error." ]+    LogSessionLoadingResult e ->+      "Session loading result:" <+> viaShow e+    LogCradle cradle ->+      "Cradle:" <+> viaShow cradle+    LogNewComponentCache componentCache ->+      "New component cache HscEnvEq:" <+> viaShow componentCache+ -- | Bump this version number when making changes to the format of the data stored in hiedb hiedbDataVersion :: String hiedbDataVersion = "1"@@ -110,7 +207,7 @@   --   or 'Nothing' to respect the cradle setting   , getCacheDirs           :: String -> [String] -> IO CacheDirs   -- | Return the GHC lib dir to use for the 'unsafeGlobalDynFlags'-  , getInitialGhcLibDir    :: Logger -> FilePath -> IO (Maybe LibDir)+  , getInitialGhcLibDir    :: Recorder (WithPriority Log) -> FilePath -> IO (Maybe LibDir)   , fakeUid                :: UnitId     -- ^ unit id used to tag the internal component built by ghcide     --   To reuse external interface files the unit ids must match,@@ -119,7 +216,7 @@   }  instance Default SessionLoadingOptions where-    def = SessionLoadingOptions+    def =  SessionLoadingOptions         {findCradle = HieBios.findCradle         ,loadCradle = loadWithImplicitCradle         ,getCacheDirs = getCacheDirsDefault@@ -148,26 +245,27 @@     Just yaml -> HieBios.loadCradle yaml     Nothing   -> loadImplicitHieCradle $ addTrailingPathSeparator rootDir -getInitialGhcLibDirDefault :: Logger -> FilePath -> IO (Maybe LibDir)-getInitialGhcLibDirDefault logger rootDir = do+getInitialGhcLibDirDefault :: Recorder (WithPriority Log) -> FilePath -> IO (Maybe LibDir)+getInitialGhcLibDirDefault recorder rootDir = do+  let log = logWith recorder   hieYaml <- findCradle def rootDir   cradle <- loadCradle def hieYaml rootDir-  logDebug logger $ T.pack $ "setInitialDynFlags cradle: " ++ show cradle   libDirRes <- getRuntimeGhcLibDir cradle   case libDirRes of       CradleSuccess libdir -> pure $ Just $ LibDir libdir       CradleFail err -> do-        hPutStrLn stderr $ "Couldn't load cradle for libdir: " ++ show (err,rootDir,hieYaml,cradle)+        log Error $ LogGetInitialGhcLibDirDefaultCradleFail err rootDir hieYaml cradle         pure Nothing       CradleNone -> do-        hPutStrLn stderr "Couldn't load cradle (CradleNone)"+        log Warning LogGetInitialGhcLibDirDefaultCradleNone         pure Nothing  -- | Sets `unsafeGlobalDynFlags` on using the hie-bios cradle and returns the GHC libdir-setInitialDynFlags :: Logger -> FilePath -> SessionLoadingOptions -> IO (Maybe LibDir)-setInitialDynFlags logger rootDir SessionLoadingOptions{..} = do-  libdir <- getInitialGhcLibDir logger rootDir+setInitialDynFlags :: Recorder (WithPriority Log) -> FilePath -> SessionLoadingOptions -> IO (Maybe LibDir)+setInitialDynFlags recorder rootDir SessionLoadingOptions{..} = do+  libdir <- getInitialGhcLibDir recorder rootDir   dynFlags <- mapM dynFlagsForPrinting libdir+  logWith recorder Debug LogSettingInitialDynFlags   mapM_ setUnsafeGlobalDynFlags dynFlags   pure libdir @@ -180,14 +278,14 @@ retryOnException   :: (MonadIO m, MonadCatch m, RandomGen g, Exception e)   => (e -> Maybe e) -- ^ only retry on exception if this predicate returns Just-  -> Logger+  -> Recorder (WithPriority Log)   -> Int -- ^ maximum backoff delay in microseconds   -> Int -- ^ base backoff delay in microseconds   -> Int -- ^ maximum number of times to retry   -> g -- ^ random number generator   -> m a -- ^ action that may throw exception   -> m a-retryOnException exceptionPred logger maxDelay !baseDelay !maxRetryCount rng action = do+retryOnException exceptionPred recorder maxDelay !baseDelay !maxRetryCount rng action = do   result <- tryJust exceptionPred action   case result of     Left e@@ -197,30 +295,18 @@         let (delay, newRng) = Random.randomR (0, newBaseDelay) rng         let newMaxRetryCount = maxRetryCount - 1         liftIO $ do-          logWarning logger $ "Retrying - " <> makeLogMsgComponentsText (Right delay) newMaxRetryCount e+          log Warning $ LogHieDbRetry delay maxDelay newMaxRetryCount (toException e)           threadDelay delay-        retryOnException exceptionPred logger maxDelay newBaseDelay newMaxRetryCount newRng action+        retryOnException exceptionPred recorder maxDelay newBaseDelay newMaxRetryCount newRng action        | otherwise -> do         liftIO $ do-          logWarning logger $ "Retries exhausted - " <> makeLogMsgComponentsText (Left baseDelay) maxRetryCount e+          log Warning $ LogHieDbRetriesExhausted baseDelay maxDelay maxRetryCount (toException e)           throwIO e      Right b -> pure b   where-    -- e.g. delay: 1010102, maximumDelay: 12010, maxRetryCount: 9, exception: SQLError { ... }-    makeLogMsgComponentsText delay newMaxRetryCount e =-      let-        logMsgComponents =-          [ either-              (("base delay: " <>) . T.pack . show)-              (("delay: " <>) . T.pack . show)-              delay-          , "maximumDelay: " <> T.pack (show maxDelay)-          , "maxRetryCount: " <> T.pack (show newMaxRetryCount)-          , "exception: " <> T.pack (show e)]-      in-        T.intercalate ", " logMsgComponents+    log = logWith recorder  -- | in microseconds oneSecond :: Int@@ -235,30 +321,30 @@ maxRetryCount = 10  retryOnSqliteBusy :: (MonadIO m, MonadCatch m, RandomGen g)-                  => Logger -> g -> m a -> m a-retryOnSqliteBusy logger rng action =+                  => Recorder (WithPriority Log) -> g -> m a -> m a+retryOnSqliteBusy recorder rng action =   let isErrorBusy e         | SQLError{ sqlError = ErrorBusy } <- e = Just e         | otherwise = Nothing   in-    retryOnException isErrorBusy logger oneSecond oneMillisecond maxRetryCount rng action+    retryOnException isErrorBusy recorder oneSecond oneMillisecond maxRetryCount rng action -makeWithHieDbRetryable :: RandomGen g => Logger -> g -> HieDb -> WithHieDb-makeWithHieDbRetryable logger rng hieDb f =-  retryOnSqliteBusy logger rng (f hieDb)+makeWithHieDbRetryable :: RandomGen g => Recorder (WithPriority Log) -> g -> HieDb -> WithHieDb+makeWithHieDbRetryable recorder rng hieDb f =+  retryOnSqliteBusy recorder rng (f hieDb)  -- | Wraps `withHieDb` to provide a database connection for reading, and a `HieWriterChan` for -- writing. Actions are picked off one by one from the `HieWriterChan` and executed in serial -- by a worker thread using a dedicated database connection. -- This is done in order to serialize writes to the database, or else SQLite becomes unhappy-runWithDb :: Logger -> FilePath -> (WithHieDb -> IndexQueue -> IO ()) -> IO ()-runWithDb logger fp k = do+runWithDb :: Recorder (WithPriority Log) -> FilePath -> (WithHieDb -> IndexQueue -> IO ()) -> IO ()+runWithDb recorder fp k = do   -- use non-deterministic seed because maybe multiple HLS start at same time   -- and send bursts of requests   rng <- Random.newStdGen   -- Delete the database if it has an incompatible schema version   retryOnSqliteBusy-    logger+    recorder     rng     (withHieDb fp (const $ pure ()) `Safe.catch` \IncompatibleSchemaVersion{} -> removeFile fp) @@ -267,14 +353,16 @@     -- e.g. `withWriteDbRetrable initConn` without type signature will     -- instantiate tyvar `a` to `()`     let withWriteDbRetryable :: WithHieDb-        withWriteDbRetryable = makeWithHieDbRetryable logger rng writedb+        withWriteDbRetryable = makeWithHieDbRetryable recorder rng writedb     withWriteDbRetryable initConn      chan <- newTQueueIO      withAsync (writerThread withWriteDbRetryable chan) $ \_ -> do-      withHieDb fp (\readDb -> k (makeWithHieDbRetryable logger rng readDb) chan)+      withHieDb fp (\readDb -> k (makeWithHieDbRetryable recorder rng readDb) chan)   where+    log = logWith recorder+     writerThread :: WithHieDb -> IndexQueue -> IO ()     writerThread withHieDbRetryable chan = do       -- Clear the index of any files that might have been deleted since the last run@@ -282,11 +370,12 @@       _ <- withHieDbRetryable garbageCollectTypeNames       forever $ do         k <- atomically $ readTQueue chan+        -- TODO: probably should let exceptions be caught/logged/handled by top level handler         k withHieDbRetryable           `Safe.catch` \e@SQLError{} -> do-            logDebug logger $ T.pack $ "SQLite error in worker, ignoring: " ++ show e+            log Error $ LogHieDbWriterThreadSQLiteError e           `Safe.catchAny` \e -> do-            logDebug logger $ T.pack $ "Uncaught error in database worker, ignoring: " ++ show e+            log Error $ LogHieDbWriterThreadException e   getHieDbLoc :: FilePath -> IO FilePath@@ -310,11 +399,11 @@ -- This is the key function which implements multi-component support. All -- components mapping to the same hie.yaml file are mapped to the same -- HscEnv which is updated as new components are discovered.-loadSession :: FilePath -> IO (Action IdeGhcSession)-loadSession = loadSessionWithOptions def+loadSession :: Recorder (WithPriority Log) -> FilePath -> IO (Action IdeGhcSession)+loadSession recorder = loadSessionWithOptions recorder def -loadSessionWithOptions :: SessionLoadingOptions -> FilePath -> IO (Action IdeGhcSession)-loadSessionWithOptions SessionLoadingOptions{..} dir = do+loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> IO (Action IdeGhcSession)+loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do   -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file   hscEnvs <- newVar Map.empty :: IO (Var HieMap)   -- Mapping from a Filepath to HscEnv@@ -340,7 +429,7 @@   runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq,[FilePath])))    return $ do-    extras@ShakeExtras{logger, restartShakeSession, ideNc, knownTargetsVar, lspEnv+    extras@ShakeExtras{restartShakeSession, ideNc, knownTargetsVar, lspEnv                       } <- getShakeExtras     let invalidateShakeCache :: IO ()         invalidateShakeCache = do@@ -371,8 +460,7 @@             logDirtyKeys <- recordDirtyKeys extras GetKnownTargets [emptyFilePath]             return (logDirtyKeys >> pure hasUpdate)           for_ hasUpdate $ \x ->-                logDebug logger $ "Known files updated: " <>-                    T.pack(show $ (HM.map . Set.map) fromNormalizedFilePath x)+            logWith recorder Debug $ LogKnownFilesUpdated x      -- Create a new HscEnv from a hieYaml root and a set of options     -- If the hieYaml file already has an HscEnv, the new component is@@ -412,7 +500,7 @@                   let hscComponents = sort $ map show uids                       cacheDirOpts = hscComponents ++ componentOptions opts                   cacheDirs <- liftIO $ getCacheDirs prefix cacheDirOpts-                  processed_df <- setCacheDirs logger cacheDirs df2+                  processed_df <- setCacheDirs recorder cacheDirs df2                   -- The final component information, mostly the same but the DynFlags don't                   -- contain any packages which are also loaded                   -- into the same component.@@ -427,7 +515,7 @@               -- scratch again (for now)               -- It's important to keep the same NameCache though for reasons               -- that I do not fully understand-              logInfo logger (T.pack ("Making new HscEnv" ++ show inplace))+              log Info $ LogMakingNewHscEnv inplace               hscEnv <- emptyHscEnv ideNc libDir               newHscEnv <-                 -- Add the options for the current component to the HscEnv@@ -463,10 +551,10 @@             initObjLinker hscEnv             res <- loadDLL hscEnv "libm.so.6"             case res of-              Nothing -> pure ()-              Just err -> logDebug logger $ T.pack $-                "Error dynamically loading libm.so.6:\n" <> err+              Nothing  -> pure ()+              Just err -> log Error $ LogDLLLoadError err +           -- Make a map from unit-id to DynFlags, this is used when trying to           -- resolve imports. (especially PackageImports)           let uids = map (\ci -> (componentUnitId ci, componentDynFlags ci)) (new : old_deps)@@ -476,7 +564,7 @@            -- New HscEnv for the component in question, returns the new HscEnvEq and           -- a mapping from FilePath to the newly created HscEnvEq.-          let new_cache = newComponentCache logger optExtensions hieYaml _cfp hscEnv uids+          let new_cache = newComponentCache recorder optExtensions hieYaml _cfp hscEnv uids           (cs, res) <- new_cache new           -- Modified cache targets for everything else in the hie.yaml file           -- which now uses the same EPS and so on@@ -493,8 +581,10 @@            -- Invalidate all the existing GhcSession build nodes by restarting the Shake session           invalidateShakeCache-          restartShakeSession "new component" [] +          -- The VFS doesn't change on cradle edits, re-use the old one.+          restartShakeSession VFSUnmodified "new component" []+           -- Typecheck all files in the project on startup           checkProject <- getCheckProject           unless (null cs || not checkProject) $ do@@ -513,10 +603,10 @@     let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath])         consultCradle hieYaml cfp = do            lfp <- flip makeRelative cfp <$> getCurrentDirectory-           logInfo logger $ T.pack ("Consulting the cradle for " <> show lfp)+           log Info $ LogCradlePath lfp             when (isNothing hieYaml) $-             logWarning logger $ implicitCradleWarning lfp+             log Warning $ LogCradleNotFound lfp             cradle <- loadCradle hieYaml dir            lfp <- flip makeRelative cfp <$> getCurrentDirectory@@ -530,12 +620,11 @@            eopts <- mRunLspTCallback lspEnv (withIndefiniteProgress progMsg NotCancellable) $               withTrace "Load cradle" $ \addTag -> do                   addTag "file" lfp-                  res <- cradleToOptsAndLibDir logger cradle cfp+                  res <- cradleToOptsAndLibDir recorder cradle cfp                   addTag "result" (show res)                   return res --           logDebug logger $ T.pack ("Session loading result: " <> show eopts)+           log Debug $ LogSessionLoadingResult eopts            case eopts of              -- The cradle gave us some options so get to work turning them              -- into and HscEnv.@@ -598,16 +687,19 @@         as <- async $ getOptions file         return (as, wait as)       pure opts+  where+    log = logWith recorder  -- | Run the specific cradle on a specific FilePath via hie-bios. -- This then builds dependencies or whatever based on the cradle, gets the -- GHC options/dynflags needed for the session and the GHC library directory--cradleToOptsAndLibDir :: Show a => Logger -> Cradle a -> FilePath+cradleToOptsAndLibDir :: Recorder (WithPriority Log) -> Cradle Void -> FilePath                       -> IO (Either [CradleError] (ComponentOptions, FilePath))-cradleToOptsAndLibDir logger cradle file = do+cradleToOptsAndLibDir recorder cradle file = do+    -- let noneCradleFoundMessage :: FilePath -> T.Text+    --     noneCradleFoundMessage f = T.pack $ "none cradle found for " <> f <> ", ignoring the file"     -- Start off by getting the session options-    logDebug logger $ T.pack $ "Output from setting up the cradle " <> show cradle+    logWith recorder Debug $ LogCradle cradle     cradleRes <- HieBios.getCompilerOptions file cradle     case cradleRes of         CradleSuccess r -> do@@ -617,13 +709,14 @@                 -- This is the successful path                 CradleSuccess libDir -> pure (Right (r, libDir))                 CradleFail err       -> return (Left [err])-                -- For the None cradle perhaps we still want to report an Info-                -- message about the fact that the file is being ignored.-                CradleNone           -> return (Left [])+                CradleNone           -> do+                    logWith recorder Info $ LogNoneCradleFound file+                    return (Left [])          CradleFail err -> return (Left [err])-        -- Same here-        CradleNone -> return (Left [])+        CradleNone -> do+            logWith recorder Info $ LogNoneCradleFound file+            return (Left [])  emptyHscEnv :: IORef NameCache -> FilePath -> IO HscEnv emptyHscEnv nc libDir = do@@ -669,7 +762,7 @@  -- | Create a mapping from FilePaths to HscEnvEqs newComponentCache-         :: Logger+         :: Recorder (WithPriority Log)          -> [String]       -- File extensions to consider          -> Maybe FilePath -- Path to cradle          -> NormalizedFilePath -- Path to file that caused the creation of this component@@ -677,17 +770,26 @@          -> [(UnitId, DynFlags)]          -> ComponentInfo          -> IO ( [TargetDetails], (IdeResult HscEnvEq, DependencyInfo))-newComponentCache logger exts cradlePath cfp hsc_env uids ci = do+newComponentCache recorder exts cradlePath cfp hsc_env uids ci = do     let df = componentDynFlags ci-    let hscEnv' = hscSetFlags df hsc_env-                          { hsc_IC = (hsc_IC hsc_env) { ic_dflags = df } }+    hscEnv' <-+      -- Add the options for the current component to the HscEnv+      -- We want to call `setSessionDynFlags` instead of `hscSetFlags`+      -- because `setSessionDynFlags` also initializes the package database,+      -- which we need for any changes to the package flags in the dynflags+      -- to be visible.+      -- See #2693+      evalGhcEnv hsc_env $ do+        _ <- setSessionDynFlags $ df+        getSession +     let newFunc = maybe newHscEnvEqPreserveImportPaths newHscEnvEq cradlePath     henv <- newFunc hscEnv' uids     let targetEnv = ([], Just henv)         targetDepends = componentDependencyInfo ci         res = (targetEnv, targetDepends)-    logDebug logger ("New Component Cache HscEnvEq: " <> T.pack (show res))+    logWith recorder Debug $ LogNewComponentCache res      let mk t = fromTargetId (importPaths df) exts (targetId t) targetEnv targetDepends     ctargets <- concatMapM mk (componentTargets ci)@@ -755,9 +857,9 @@ -- | Set the cache-directory based on the ComponentOptions and a list of -- internal packages. -- For the exact reason, see Note [Avoiding bad interface files].-setCacheDirs :: MonadIO m => Logger -> CacheDirs -> DynFlags -> m DynFlags-setCacheDirs logger CacheDirs{..} dflags = do-    liftIO $ logInfo logger $ "Using interface files cache dir: " <> T.pack (fromMaybe cacheDir hiCacheDir)+setCacheDirs :: MonadUnliftIO m => Recorder (WithPriority Log) -> CacheDirs -> DynFlags -> m DynFlags+setCacheDirs recorder CacheDirs{..} dflags = do+    logWith recorder Info $ LogInterfaceFilesCacheDir (fromMaybe cacheDir hiCacheDir)     pure $ dflags           & maybe id setHiDir hiCacheDir           & maybe id setHieDir hieCacheDir@@ -930,12 +1032,6 @@ cacheDir :: String cacheDir = "ghcide" -implicitCradleWarning :: FilePath -> T.Text-implicitCradleWarning fp =-  "No [cradle](https://github.com/mpickering/hie-bios#hie-bios) found for "-  <> T.pack fp <>-  ".\n Proceeding with [implicit cradle](https://hackage.haskell.org/package/implicit-hie).\n"<>-  "You should ignore this message, unless you see a 'Multi Cradle: No prefixes matched' error." ----------------------------------------------------------------------------------------------------  data PackageSetupException

@@ -17,8 +17,7 @@                                                              isWorkspaceFile) import           Development.IDE.Core.OfInterest       as X (getFilesOfInterestUntracked) import           Development.IDE.Core.RuleTypes        as X-import           Development.IDE.Core.Rules            as X (IsHiFileStable (..),-                                                             getClientConfigAction,+import           Development.IDE.Core.Rules            as X (getClientConfigAction,                                                              getParsedModule) import           Development.IDE.Core.Service          as X (runAction) import           Development.IDE.Core.Shake            as X (FastResult (..),@@ -41,7 +40,8 @@                                                              useWithStaleFast,                                                              useWithStaleFast',                                                              useWithStale_,-                                                             use_, uses, uses_)+                                                             use_, uses, uses_,+                                                             VFSModified(..)) import           Development.IDE.GHC.Compat            as X (GhcVersion (..),                                                              ghcVersion) import           Development.IDE.GHC.Error             as X

@@ -26,14 +26,56 @@   , getModSummaryFromImports   , loadHieFile   , loadInterface+  , RecompilationInfo(..)   , loadModulesHome   , getDocsBatch   , lookupName-  ,mergeEnvs) where+  , mergeEnvs+  ) where +import           Control.Concurrent.Extra+import           Control.Concurrent.STM.Stats      hiding (orElse)+import           Control.DeepSeq                   (force, liftRnf, rnf, rwhnf)+import           Control.Exception                 (evaluate)+import           Control.Exception.Safe+import           Control.Lens                      hiding (List)+import           Control.Monad.Except+import           Control.Monad.Extra+import           Control.Monad.Trans.Except+import           Data.Aeson                        (toJSON)+import           Data.Bifunctor                    (first, second)+import           Data.Binary+import qualified Data.Binary                       as B+import qualified Data.ByteString                   as BS+import qualified Data.ByteString.Lazy              as LBS+import           Data.Coerce+import qualified Data.DList                        as DL+import           Data.Functor+import qualified Data.HashMap.Strict               as HashMap+import           Data.IORef+import           Data.IntMap                       (IntMap)+import qualified Data.IntMap.Strict                as IntMap+import           Data.List.Extra+import           Data.Map                          (Map)+import qualified Data.Map.Strict                   as Map+import           Data.Maybe+import qualified Data.Text                         as T+import           Data.Time                         (UTCTime (..),+                                                    getCurrentTime)+import           Data.Time.Clock.POSIX             (posixSecondsToUTCTime)+import           Data.Tuple.Extra                  (dupe)+import           Data.Unique                       as Unique+import           Debug.Trace import           Development.IDE.Core.Preprocessor import           Development.IDE.Core.RuleTypes import           Development.IDE.Core.Shake+import           Development.IDE.Core.Tracing      (withTrace)+import           Development.IDE.GHC.Compat        hiding (loadInterface,+                                                    parseHeader, parseModule,+                                                    tcRnModule, writeHieFile)+import qualified Development.IDE.GHC.Compat        as Compat+import qualified Development.IDE.GHC.Compat        as GHC+import qualified Development.IDE.GHC.Compat.Util   as Util import           Development.IDE.GHC.Error import           Development.IDE.GHC.Orphans       () import           Development.IDE.GHC.Util@@ -42,26 +84,25 @@ import           Development.IDE.Types.Diagnostics import           Development.IDE.Types.Location import           Development.IDE.Types.Options--import           Development.IDE.GHC.Compat        hiding (loadInterface,-                                                    parseHeader, parseModule,-                                                    tcRnModule, writeHieFile)-import qualified Development.IDE.GHC.Compat        as Compat-import qualified Development.IDE.GHC.Compat        as GHC-import qualified Development.IDE.GHC.Compat.Util   as Util-+import           GHC                               (ForeignHValue,+                                                    GetDocsFailure (..),+                                                    mgModSummaries,+                                                    parsedSource)+import qualified GHC.LanguageExtensions            as LangExt+import           GHC.Serialized import           HieDb-+import qualified Language.LSP.Server               as LSP import           Language.LSP.Types                (DiagnosticTag (..))+import qualified Language.LSP.Types                as LSP+import           System.Directory+import           System.FilePath+import           System.IO.Extra                   (fixIO, newTempFileWithin)+import           Unsafe.Coerce -#if MIN_VERSION_ghc(8,10,0)-import           Control.DeepSeq                   (force, liftRnf, rnf, rwhnf)-#else-import           Control.DeepSeq                   (liftRnf, rnf, rwhnf)+#if !MIN_VERSION_ghc(8,10,0) import           ErrUtils #endif - #if MIN_VERSION_ghc(9,0,1) import           GHC.Tc.Gen.Splice #else@@ -69,53 +110,18 @@ #endif  #if MIN_VERSION_ghc(9,2,0)+import           Development.IDE.GHC.Compat.Util   (emptyUDFM, fsLit,+                                                    plusUDFM_C)+import           GHC                               (Anchor (anchor),+                                                    EpaComment (EpaComment),+                                                    EpaCommentTok (EpaBlockComment, EpaLineComment),+                                                    epAnnComments,+                                                    priorComments)+import qualified GHC                               as G+import           GHC.Hs                            (LEpaComment) import qualified GHC.Types.Error                   as Error #endif -import           Control.Exception                 (evaluate)-import           Control.Exception.Safe-import           Control.Lens                      hiding (List)-import           Control.Monad.Except-import           Control.Monad.Extra-import           Control.Monad.Trans.Except-import           Data.Bifunctor                    (first, second)-import qualified Data.ByteString                   as BS-import qualified Data.DList                        as DL-import           Data.IORef-import qualified Data.IntMap.Strict                as IntMap-import           Data.List.Extra-import qualified Data.Map.Strict                   as Map-import           Data.Maybe-import qualified Data.Text                         as T-import           Data.Time                         (UTCTime, getCurrentTime)-import qualified GHC.LanguageExtensions            as LangExt-import           System.Directory-import           System.FilePath-import           System.IO.Extra                   (fixIO, newTempFileWithin)---- GHC API imports--- GHC API imports-import           GHC                               (GetDocsFailure (..),-                                                    mgModSummaries,-                                                    parsedSource)--import           Control.Concurrent.Extra-import           Control.Concurrent.STM.Stats      hiding (orElse)-import           Data.Aeson                        (toJSON)-import           Data.Binary-import           Data.Coerce-import           Data.Functor-import qualified Data.HashMap.Strict               as HashMap-import           Data.IntMap                       (IntMap)-import           Data.Map                          (Map)-import           Data.Tuple.Extra                  (dupe)-import           Data.Unique                       as Unique-import           Development.IDE.Core.Tracing      (withTrace)-import           Development.IDE.GHC.Compat.Util   (emptyUDFM, plusUDFM_C)-import qualified Language.LSP.Server               as LSP-import qualified Language.LSP.Types                as LSP-import           Unsafe.Coerce- -- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'. parseModule     :: IdeOptions@@ -143,7 +149,7 @@  typecheckModule :: IdeDefer                 -> HscEnv-                -> [Linkable] -- ^ linkables not to unload+                -> ModuleEnv UTCTime -- ^ linkables not to unload                 -> ParsedModule                 -> IO (IdeResult TcModuleResult) typecheckModule (IdeDefer defer) hsc keep_lbls pm = do@@ -171,16 +177,110 @@     where         demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id --- | Add a Hook to the DynFlags which captures and returns the--- typechecked splices before they are run. This information--- is used for hover.-captureSplices :: HscEnv -> (HscEnv -> IO a) -> IO (a, Splices)-captureSplices env k = do+-- | Install hooks to capture the splices as well as the runtime module dependencies+captureSplicesAndDeps :: HscEnv -> (HscEnv -> IO a) -> IO (a, Splices, UniqSet ModuleName)+captureSplicesAndDeps env k = do   splice_ref <- newIORef mempty-  res <- k (hscSetHooks (addSpliceHook splice_ref (hsc_hooks env)) env)+  dep_ref <- newIORef emptyUniqSet+  res <- k (hscSetHooks (addSpliceHook splice_ref . addLinkableDepHook dep_ref $ hsc_hooks env) env)   splices <- readIORef splice_ref-  return (res, splices)+  needed_mods <- readIORef dep_ref+  return (res, splices, needed_mods)   where+    addLinkableDepHook :: IORef (UniqSet ModuleName) -> Hooks -> Hooks+    addLinkableDepHook var h = h { hscCompileCoreExprHook = Just (compile_bco_hook var) }++    -- We want to record exactly which linkables/modules the typechecker needed at runtime+    -- This is useful for recompilation checking.+    -- See Note [Recompilation avoidance in the presence of TH]+    --+    -- From hscCompileCoreExpr' in GHC+    -- To update, copy hscCompileCoreExpr' (the implementation of+    -- hscCompileCoreExprHook) verbatim, and add code to extract all the free+    -- names in the compiled bytecode, recording the modules that those names+    -- come from in the IORef,, as these are the modules on whose implementation+    -- we depend.+    --+    -- Only compute direct dependencies instead of transitive dependencies.+    -- It is much cheaper to store the direct dependencies, we can compute+    -- the transitive ones when required.+    -- Also only record dependencies from the home package+    compile_bco_hook :: IORef (UniqSet ModuleName) -> HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue+    compile_bco_hook var hsc_env srcspan ds_expr+      = do { let dflags = hsc_dflags hsc_env++             {- Simplify it -}+           ; simpl_expr <- simplifyExpr dflags hsc_env ds_expr++             {- Tidy it (temporary, until coreSat does cloning) -}+           ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr++             {- Prepare for codegen -}+           ; prepd_expr <- corePrepExpr dflags hsc_env tidy_expr++             {- Lint if necessary -}+           ; lintInteractiveExpr "hscCompileExpr" hsc_env prepd_expr+++#if MIN_VERSION_ghc(9,2,0)+           ; let iNTERACTIVELoc = G.ModLocation{ ml_hs_file   = Nothing,+                                        ml_hi_file   = panic "hscCompileCoreExpr':ml_hi_file",+                                        ml_obj_file  = panic "hscCompileCoreExpr':ml_obj_file",+                                        ml_hie_file  = panic "hscCompileCoreExpr':ml_hie_file" }+           ; let ictxt = hsc_IC hsc_env++           ; (binding_id, stg_expr, _, _) <-+               myCoreToStgExpr (hsc_logger hsc_env)+                               (hsc_dflags hsc_env)+                               ictxt+                               (icInteractiveModule ictxt)+                               iNTERACTIVELoc+                               prepd_expr++             {- Convert to BCOs -}+           ; bcos <- byteCodeGen hsc_env+                       (icInteractiveModule ictxt)+                       stg_expr+                       [] Nothing+           ; let needed_mods = mkUniqSet [ moduleName mod | n <- concatMap (uniqDSetToList . bcoFreeNames) $ bc_bcos bcos+                                         , Just mod <- [nameModule_maybe n] -- Names from other modules+                                         , not (isWiredInName n) -- Exclude wired-in names+                                         , moduleUnitId mod == homeUnitId_ dflags -- Only care about stuff from the home package+                                         ]+            -- Exclude wired-in names because we may not have read+            -- their interface files, so getLinkDeps will fail+            -- All wired-in names are in the base package, which we link+            -- by default, so we can safely ignore them here.++             {- load it -}+           ; fv_hvs <- loadDecls (hscInterp hsc_env) hsc_env srcspan bcos+           ; let hval = (expectJust "hscCompileCoreExpr'" $ lookup (idName binding_id) fv_hvs)+#else+             {- Convert to BCOs -}+           ; bcos <- coreExprToBCOs hsc_env+                       (icInteractiveModule (hsc_IC hsc_env)) prepd_expr++           ; let needed_mods = mkUniqSet [ moduleName mod | n <- uniqDSetToList (bcoFreeNames bcos)+                                         , Just mod <- [nameModule_maybe n] -- Names from other modules+                                         , not (isWiredInName n) -- Exclude wired-in names+                                         , moduleUnitId mod == homeUnitId_ dflags -- Only care about stuff from the home package+                                         ]+            -- Exclude wired-in names because we may not have read+            -- their interface files, so getLinkDeps will fail+            -- All wired-in names are in the base package, which we link+            -- by default, so we can safely ignore them here.++             {- link it -}+           ; hval <- linkExpr hsc_env srcspan bcos+#endif++           ; modifyIORef' var (unionUniqSets needed_mods)+           ; return hval }+++    -- | Add a Hook to the DynFlags which captures and returns the+    -- typechecked splices before they are run. This information+    -- is used for hover.     addSpliceHook :: IORef Splices -> Hooks -> Hooks     addSpliceHook var h = h { runMetaHook = Just (splice_hook (runMetaHook h) var) } @@ -208,15 +308,20 @@             pure $ f aw'  -tcRnModule :: HscEnv -> [Linkable] -> ParsedModule -> IO TcModuleResult+tcRnModule+  :: HscEnv+  -> ModuleEnv UTCTime -- ^ Program linkables not to unload+  -> ParsedModule+  -> IO TcModuleResult tcRnModule hsc_env keep_lbls pmod = do   let ms = pm_mod_summary pmod       hsc_env_tmp = hscSetFlags (ms_hspp_opts ms) hsc_env+      hpt = hsc_HPT hsc_env -  unload hsc_env_tmp keep_lbls+  unload hsc_env_tmp $ map (\(mod, time) -> LM time mod []) $ moduleEnvToList keep_lbls -  ((tc_gbl_env, mrn_info), splices)-      <- liftIO $ captureSplices hsc_env_tmp $ \hsc_env_tmp ->+  ((tc_gbl_env', mrn_info), splices, mods)+      <- captureSplicesAndDeps hsc_env_tmp $ \hsc_env_tmp ->              do  hscTypecheckRename hsc_env_tmp ms $                           HsParsedModule { hpm_module = parsedSource pmod,                                            hpm_src_files = pm_extra_src_files pmod,@@ -224,8 +329,30 @@   let rn_info = case mrn_info of         Just x  -> x         Nothing -> error "no renamed info tcRnModule"-  pure (TcModuleResult pmod rn_info tc_gbl_env splices False) +      -- Compute the transitive set of linkables required+      mods_transitive = go emptyUniqSet mods+        where+          go seen new+            | isEmptyUniqSet new = seen+            | otherwise = go seen' new'+              where+                seen' = seen `unionUniqSets` new+                new'  = new_deps `minusUniqSet` seen'+                new_deps = unionManyUniqSets [ mkUniqSet $ getDependentMods $ hm_iface mod_info+                                             | mod_info <- eltsUDFM $ udfmIntersectUFM hpt (getUniqSet new)]++      -- The linkables we depend on at runtime are the transitive closure of 'mods'+      -- restricted to the home package+      -- See Note [Recompilation avoidance in the presence of TH]+      mod_env = filterModuleEnv (\m _ -> elementOfUniqSet (moduleName m) mods_transitive) keep_lbls -- Could use restrictKeys if the constructors were exported++      -- Serialize mod_env so we can read it from the interface+      mod_env_anns = map (\(mod, time) -> Annotation (ModuleTarget mod) $ toSerialized serializeModDepTime (ModDepTime time))+                         (moduleEnvToList mod_env)+      tc_gbl_env = tc_gbl_env' { tcg_ann_env = extendAnnEnvList (tcg_ann_env tc_gbl_env') mod_env_anns }+  pure (TcModuleResult pmod rn_info tc_gbl_env splices False mod_env)+ mkHiFileResultNoCompile :: HscEnv -> TcModuleResult -> IO HiFileResult mkHiFileResultNoCompile session tcm = do   let hsc_env_tmp = hscSetFlags (ms_hspp_opts ms) session@@ -239,7 +366,7 @@   (iface, _) <- mkIfaceTc hsc_env_tmp Nothing sf details tcGblEnv #endif   let mod_info = HomeModInfo iface details Nothing-  pure $! mkHiFileResult ms mod_info+  pure $! mkHiFileResult ms mod_info (tmrRuntimeModules tcm)  mkHiFileResultCompile     :: HscEnv@@ -277,7 +404,7 @@   (final_iface,_) <- mkIface session Nothing details simplified_guts #endif   let mod_info = HomeModInfo final_iface details linkable-  pure (diags, Just $! mkHiFileResult ms mod_info)+  pure (diags, Just $! mkHiFileResult ms mod_info (tmrRuntimeModules tcm))    where     dflags = hsc_dflags session'@@ -932,56 +1059,211 @@ loadHieFile ncu f = do   GHC.hie_file_result <$> GHC.readHieFile ncu f ++{- Note [Recompilation avoidance in the presence of TH]++Most versions of GHC we currently support don't have a working implementation of+code unloading for object code, and no version of GHC supports this on certain+platforms like Windows. This makes it completely infeasible for interactive use,+as symbols from previous compiles will shadow over all future compiles.++This means that we need to use bytecode when generating code for Template+Haskell. Unfortunately, we can't serialize bytecode, so we will always need+to recompile when the IDE starts. However, we can put in place a much tighter+recompilation avoidance scheme for subsequent compiles:++1. If the source file changes, then we always need to recompile+   a. For files of interest, we will get explicit `textDocument/change` events+   that will let us invalidate our build products+   b. For files we read from disk, we can detect source file changes by+   comparing the `mtime` of the source file with the build product (.hi/.o) file+   on disk.+2. If GHC's recompilation avoidance scheme based on interface file hashes says+   that we need to recompile, the we need to recompile.+3. If the file in question requires code generation then, we need to recompile+   if we don't have the appropriate kind of build products.+   a. If we already have the build products in memory, and the conditions 1 and+   2 above hold, then we don't need to recompile+   b. If we are generating object code, then we can also search for it on+   disk and ensure it is up to date. Notably, we did _not_ previously re-use+   old bytecode from memory when `hls-graph`/`shake` decided to rebuild the+   `HiFileResult` for some reason++4. If the file in question used Template Haskell on the previous compile, then+  we need to recompile if any `Linkable` in its transitive closure changed. This+  sounds bad, but it is possible to make some improvements.+  In particular, we only need to recompile if any of the `Linkable`s actually used during the previous compile change.++How can we tell if a `Linkable` was actually used while running some TH?++GHC provides a `hscCompileCoreExprHook` which lets us intercept bytecode as+it is being compiled and linked. We can inspect the bytecode to see which+`Linkable` dependencies it requires, and record this for use in+recompilation checking.+We record all the home package modules of the free names that occur in the+bytecode. The `Linkable`s required are then the transitive closure of these+modules in the home-package environment. This is the same scheme as used by+GHC to find the correct things to link in before running bytecode.++This works fine if we already have previous build products in memory, but+what if we are reading an interface from disk? Well, we can smuggle in the+necessary information (linkable `Module`s required as well as the time they+were generated) using `Annotation`s, which provide a somewhat general purpose+way to serialise arbitrary information along with interface files.++Then when deciding whether to recompile, we need to check that the versions+of the linkables used during a previous compile match whatever is currently+in the HPT.+-}++data RecompilationInfo m+  = RecompilationInfo+  { source_version :: FileVersion+  , old_value   :: Maybe (HiFileResult, FileVersion)+  , get_file_version :: NormalizedFilePath -> m (Maybe FileVersion)+  , regenerate  :: Maybe LinkableType -> m ([FileDiagnostic], Maybe HiFileResult) -- ^ Action to regenerate an interface+  }+ -- | Retuns an up-to-date module interface, regenerating if needed. --   Assumes file exists. --   Requires the 'HscEnv' to be set up with dependencies+-- See Note [Recompilation avoidance in the presence of TH] loadInterface   :: (MonadIO m, MonadMask m)   => HscEnv   -> ModSummary-  -> SourceModified   -> Maybe LinkableType-  -> (Maybe LinkableType -> m ([FileDiagnostic], Maybe HiFileResult)) -- ^ Action to regenerate an interface+  -> RecompilationInfo m   -> m ([FileDiagnostic], Maybe HiFileResult)-loadInterface session ms sourceMod linkableNeeded regen = do+loadInterface session ms linkableNeeded RecompilationInfo{..} = do     let sessionWithMsDynFlags = hscSetFlags (ms_hspp_opts ms) session-    res <- liftIO $ checkOldIface sessionWithMsDynFlags ms sourceMod Nothing-    case res of-          (UpToDate, Just iface)-            -- If the module used TH splices when it was last-            -- compiled, then the recompilation check is not-            -- accurate enough (https://gitlab.haskell.org/ghc/ghc/-/issues/481)-            -- and we must ignore-            -- it.  However, if the module is stable (none of-            -- the modules it depends on, directly or-            -- indirectly, changed), then we *can* skip-            -- recompilation. This is why the SourceModified-            -- type contains SourceUnmodifiedAndStable, and-            -- it's pretty important: otherwise ghc --make-            -- would always recompile TH modules, even if-            -- nothing at all has changed. Stability is just-            -- the same check that make is doing for us in-            -- one-shot mode.-            | not (mi_used_th iface) || SourceUnmodifiedAndStable == sourceMod-            -> do-             linkable <- case linkableNeeded of-               Just ObjectLinkable -> liftIO $ findObjectLinkableMaybe (ms_mod ms) (ms_location ms)-               _ -> pure Nothing+        mb_old_iface = hm_iface    . hirHomeMod . fst <$> old_value+        mb_old_version = snd <$> old_value -             -- We don't need to regenerate if the object is up do date, or we don't need one-             let objUpToDate = isNothing linkableNeeded || case linkable of-                   Nothing                -> False-                   Just (LM obj_time _ _) -> obj_time > ms_hs_date ms-             if objUpToDate-             then do-               hmi <- liftIO $ mkDetailsFromIface sessionWithMsDynFlags iface linkable-               return ([], Just $ mkHiFileResult ms hmi)-             else regen linkableNeeded-          (_reason, _) -> withTrace "regenerate interface" $ \setTag -> do-                 setTag "Module" $ moduleNameString $ moduleName $ ms_mod ms-                 setTag "Reason" $ showReason _reason-                 regen linkableNeeded+        obj_file = ml_obj_file (ms_location ms) +        !mod = ms_mod ms++    mb_dest_version <- case mb_old_version of+      Just ver -> pure $ Just ver+      Nothing ->  get_file_version $ toNormalizedFilePath' $ case linkableNeeded of+          Just ObjectLinkable -> ml_obj_file (ms_location ms)+          _                   -> ml_hi_file (ms_location ms)++    -- The source is modified if it is newer than the destination+    let sourceMod = case mb_dest_version of+          Nothing -> SourceModified -- desitination file doesn't exist, assume modified source+          Just dest_version+            | source_version <= dest_version -> SourceUnmodified+            | otherwise -> SourceModified++    -- If mb_old_iface is nothing then checkOldIface will load it for us+    (recomp_iface_reqd, mb_checked_iface)+      <- liftIO $ checkOldIface sessionWithMsDynFlags ms sourceMod mb_old_iface+++    let+      (recomp_obj_reqd, mb_linkable) = case linkableNeeded of+        Nothing -> (UpToDate, Nothing)+        Just linkableType -> case old_value of+          -- We don't have an old result+          Nothing -> recompMaybeBecause "missing"+          -- We have an old result+          Just (old_hir, old_file_version) ->+            case hm_linkable $ hirHomeMod old_hir of+              Nothing -> recompMaybeBecause "missing [not needed before]"+              Just old_lb+                | Just True <- mi_used_th <$> mb_checked_iface -- No need to recompile if TH wasn't used+                , old_file_version /= source_version -> recompMaybeBecause "out of date"++                -- Check if it is the correct type+                -- Ideally we could use object-code in case we already have+                -- it when we are generating bytecode, but this is difficult because something+                -- below us may be bytecode, and object code can't depend on bytecode+                | ObjectLinkable <- linkableType, isObjectLinkable old_lb+                -> (UpToDate, Just old_lb)++                | BCOLinkable    <- linkableType , not (isObjectLinkable old_lb)+                -> (UpToDate, Just old_lb)++                | otherwise -> recompMaybeBecause "missing [wrong type]"+          where+            recompMaybeBecause msg = case linkableType of+              BCOLinkable -> (RecompBecause ("bytecode "++ msg), Nothing)+              ObjectLinkable -> case mb_dest_version of -- The destination file should be the object code+                Nothing -> (RecompBecause ("object code "++ msg), Nothing)+                Just disk_obj_version@(ModificationTime t) ->+                  -- If we make it this far, assume that the object code on disk is up to date+                  -- This assertion works because of the sourceMod check+                  assert (disk_obj_version >= source_version)+                         (UpToDate, Just $ LM (posixSecondsToUTCTime t) mod [DotO obj_file])+                Just (VFSVersion _) -> error "object code in vfs"++    let do_regenerate _reason = withTrace "regenerate interface" $ \setTag -> do+          setTag "Module" $ moduleNameString $ moduleName mod+          setTag "Reason" $ showReason _reason+          liftIO $ traceMarkerIO $ "regenerate interface " ++ show (moduleNameString $ moduleName mod, showReason _reason)+          regenerate linkableNeeded++    case (mb_checked_iface, recomp_iface_reqd <> recomp_obj_reqd) of+      (Just iface, UpToDate) -> do+         -- Force it because we don't want to retain old modsummaries or linkables+         lb <- liftIO $ evaluate $ force mb_linkable++         -- If we have an old value, just return it+         case old_value of+           Just (old_hir, _)+             | Just msg <- checkLinkableDependencies (hsc_HPT sessionWithMsDynFlags) (hirRuntimeModules old_hir)+             -> do_regenerate msg+             | otherwise -> return ([], Just old_hir)+           Nothing -> do+             hmi <- liftIO $ mkDetailsFromIface sessionWithMsDynFlags iface lb+             -- parse the runtime dependencies from the annotations+             let runtime_deps+                   | not (mi_used_th iface) = emptyModuleEnv+                   | otherwise = parseRuntimeDeps (md_anns (hm_details hmi))+             return ([], Just $ mkHiFileResult ms hmi runtime_deps)+      (_, _reason) -> do_regenerate _reason++-- | ModDepTime is stored as an annotation in the iface to+-- keep track of runtime dependencies+newtype ModDepTime = ModDepTime UTCTime++deserializeModDepTime :: [Word8] -> ModDepTime+deserializeModDepTime xs = ModDepTime $ case decode (LBS.pack xs) of+  (a,b) -> UTCTime (toEnum a) (toEnum b)++serializeModDepTime :: ModDepTime -> [Word8]+serializeModDepTime (ModDepTime l) = LBS.unpack $+  B.encode (fromEnum $ utctDay l, fromEnum $ utctDayTime l)++-- | Find the runtime dependencies by looking at the annotations+-- serialized in the iface+parseRuntimeDeps :: [ModIfaceAnnotation] -> ModuleEnv UTCTime+parseRuntimeDeps anns = mkModuleEnv $ mapMaybe go anns+  where+    go (Annotation (ModuleTarget mod) payload)+      | Just (ModDepTime t) <- fromSerialized deserializeModDepTime payload+      = Just (mod, t)+    go _ = Nothing++-- | checkLinkableDependencies compares the linkables in the home package to+-- the runtime dependencies of the module, to check if any of them are out of date+-- Hopefully 'runtime_deps' will be empty if the module didn't actually use TH+-- See Note [Recompilation avoidance in the presence of TH]+checkLinkableDependencies :: HomePackageTable -> ModuleEnv UTCTime -> Maybe RecompileRequired+checkLinkableDependencies hpt runtime_deps+  | isEmptyModuleEnv out_of_date = Nothing -- Nothing out of date, so don't recompile+  | otherwise = Just $+      RecompBecause $ "out of date runtime dependencies: " ++ intercalate ", " (map show (moduleEnvKeys out_of_date))+  where+    out_of_date = filterModuleEnv (\mod time -> case lookupHpt hpt (moduleName mod) of+                                                  Nothing -> False+                                                  Just hm -> case hm_linkable hm of+                                                    Nothing -> False+                                                    Just lm -> linkableTime lm /= time)+                                  runtime_deps+ showReason :: RecompileRequired -> String showReason UpToDate          = "UpToDate" showReason MustCompile       = "MustCompile"@@ -1019,7 +1301,7 @@ #endif                                   Map.findWithDefault mempty name amap))     case res of-        Just x  -> return $ map (first $ T.unpack . showGhc) x+        Just x  -> return $ map (first $ T.unpack . printOutputable) x         Nothing -> throwErrors #if MIN_VERSION_ghc(9,2,0)                      $ Error.getErrorMessages msgs

@@ -7,6 +7,7 @@   , getFileExists   , watchedGlobs   , GetFileExists(..)+  , Log(..)   ) where @@ -18,12 +19,17 @@ import qualified Data.ByteString                       as BS import           Data.List                             (partition) import           Data.Maybe-import           Development.IDE.Core.FileStore+import           Development.IDE.Core.FileStore        hiding (Log, LogShake)+import qualified Development.IDE.Core.FileStore        as FileStore import           Development.IDE.Core.IdeConfiguration import           Development.IDE.Core.RuleTypes-import           Development.IDE.Core.Shake+import           Development.IDE.Core.Shake            hiding (Log)+import qualified Development.IDE.Core.Shake            as Shake import           Development.IDE.Graph import           Development.IDE.Types.Location+import           Development.IDE.Types.Logger          (Pretty (pretty),+                                                        Recorder, WithPriority,+                                                        cmapWithPrio) import           Development.IDE.Types.Options import qualified Focus import           Ide.Plugin.Config                     (Config)@@ -82,6 +88,16 @@  instance IsIdeGlobal FileExistsMapVar +data Log+  = LogFileStore FileStore.Log+  | LogShake Shake.Log+  deriving Show++instance Pretty Log where+  pretty = \case+    LogFileStore log -> pretty log+    LogShake log     -> pretty log+ -- | Grab the current global value of 'FileExistsMap' without acquiring a dependency getFileExistsMapUntracked :: Action FileExistsMap getFileExistsMapUntracked = do@@ -93,8 +109,7 @@ modifyFileExists state changes = do   FileExistsMapVar var <- getIdeGlobalState state   -- Masked to ensure that the previous values are flushed together with the map update-    -- update the map-  mask_ $ join $ atomicallyNamed "modifyFileExists" $ do+  join $ mask_ $ atomicallyNamed "modifyFileExists" $ do     forM_ changes $ \(f,c) ->         case fromChange c of             Just c' -> STM.focus (Focus.insert c') f var@@ -116,14 +131,6 @@ -------------------------------------------------------------------------------------  -- | Returns True if the file exists---   Note that a file is not considered to exist unless it is saved to disk.---   In particular, VFS existence is not enough.---   Consider the following example:---     1. The file @A.hs@ containing the line @import B@ is added to the files of interest---        Since @B.hs@ is neither open nor exists, GetLocatedImports finds Nothing---     2. The editor creates a new buffer @B.hs@---        Unless the editor also sends a @DidChangeWatchedFile@ event, ghcide will not pick it up---        Most editors, e.g. VSCode, only send the event when the file is saved to disk. getFileExists :: NormalizedFilePath -> Action Bool getFileExists fp = use_ GetFileExists fp @@ -157,8 +164,8 @@ -- | Installs the 'getFileExists' rules. --   Provides a fast implementation if client supports dynamic watched files. --   Creates a global state as a side effect in that case.-fileExistsRules :: Maybe (LanguageContextEnv Config) -> VFSHandle -> Rules ()-fileExistsRules lspEnv vfs = do+fileExistsRules :: Recorder (WithPriority Log) -> Maybe (LanguageContextEnv Config) -> Rules ()+fileExistsRules recorder lspEnv = do   supportsWatchedFiles <- case lspEnv of     Nothing      -> pure False     Just lspEnv' -> liftIO $  runLspT lspEnv' isWatchSupported@@ -179,19 +186,19 @@         else const $ pure False    if supportsWatchedFiles-    then fileExistsRulesFast isWatched vfs-    else fileExistsRulesSlow vfs+    then fileExistsRulesFast recorder isWatched+    else fileExistsRulesSlow recorder -  fileStoreRules vfs isWatched+  fileStoreRules (cmapWithPrio LogFileStore recorder) isWatched  -- Requires an lsp client that provides WatchedFiles notifications, but assumes that this has already been checked.-fileExistsRulesFast :: (NormalizedFilePath -> Action Bool) -> VFSHandle -> Rules ()-fileExistsRulesFast isWatched vfs =-    defineEarlyCutoff $ RuleNoDiagnostics $ \GetFileExists file -> do+fileExistsRulesFast :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules ()+fileExistsRulesFast recorder isWatched =+    defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetFileExists file -> do         isWF <- isWatched file         if isWF-            then fileExistsFast vfs file-            else fileExistsSlow vfs file+            then fileExistsFast file+            else fileExistsSlow file  {- Note [Invalidating file existence results] We have two mechanisms for getting file existence information:@@ -209,8 +216,8 @@ we use 'alwaysRerun'. -} -fileExistsFast :: VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe Bool)-fileExistsFast vfs file = do+fileExistsFast :: NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe Bool)+fileExistsFast file = do     -- Could in principle use 'alwaysRerun' here, but it's too slwo, See Note [Invalidating file existence results]     mp <- getFileExistsMapUntracked @@ -219,28 +226,27 @@       Just exist -> pure exist       -- We don't know about it: use the slow route.       -- Note that we do *not* call 'fileExistsSlow', as that would trigger 'alwaysRerun'.-      Nothing    -> liftIO $ getFileExistsVFS vfs file+      Nothing    -> getFileExistsVFS file     pure (summarizeExists exist, Just exist)  summarizeExists :: Bool -> Maybe BS.ByteString summarizeExists x = Just $ if x then BS.singleton 1 else BS.empty -fileExistsRulesSlow :: VFSHandle -> Rules ()-fileExistsRulesSlow vfs =-  defineEarlyCutoff $ RuleNoDiagnostics $ \GetFileExists file -> fileExistsSlow vfs file+fileExistsRulesSlow :: Recorder (WithPriority Log) -> Rules ()+fileExistsRulesSlow recorder =+  defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetFileExists file -> fileExistsSlow file -fileExistsSlow :: VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe Bool)-fileExistsSlow vfs file = do+fileExistsSlow :: NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe Bool)+fileExistsSlow file = do     -- See Note [Invalidating file existence results]     alwaysRerun-    exist <- liftIO $ getFileExistsVFS vfs file+    exist <- getFileExistsVFS file     pure (summarizeExists exist, Just exist) -getFileExistsVFS :: VFSHandle -> NormalizedFilePath -> IO Bool-getFileExistsVFS vfs file = do-    -- we deliberately and intentionally wrap the file as an FilePath WITHOUT mkAbsolute-    -- so that if the file doesn't exist, is on a shared drive that is unmounted etc we get a properly-    -- cached 'No' rather than an exception in the wrong place-    handle (\(_ :: IOException) -> return False) $-        (isJust <$> getVirtualFile vfs (filePathToUri' file)) ||^-        Dir.doesFileExist (fromNormalizedFilePath file)+getFileExistsVFS :: NormalizedFilePath -> Action Bool+getFileExistsVFS file = do+  vf <- getVirtualFile file+  if isJust vf+  then pure True+  else liftIO $ handle (\(_ :: IOException) -> return False) $+         Dir.doesFileExist (fromNormalizedFilePath file)

@@ -5,15 +5,11 @@  module Development.IDE.Core.FileStore(     getFileContents,-    getVirtualFile,     setFileModified,     setSomethingModified,     fileStoreRules,     modificationTime,     typecheckParents,-    VFSHandle,-    makeVFSHandle,-    makeLSPVFSHandle,     resetFileStore,     resetInterfaceStore,     getModificationTimeImpl,@@ -21,26 +17,25 @@     getFileContentsImpl,     getModTime,     isWatchSupported,-    registerFileWatches+    registerFileWatches,+    Log(..)     ) where  import           Control.Concurrent.STM.Stats                 (STM, atomically,                                                                modifyTVar') import           Control.Concurrent.STM.TQueue                (writeTQueue)-import           Control.Concurrent.Strict import           Control.Exception import           Control.Monad.Extra import           Control.Monad.IO.Class import qualified Data.ByteString                              as BS import           Data.Either.Extra-import qualified Data.Map.Strict                              as Map-import           Data.Maybe import qualified Data.Rope.UTF16                              as Rope import qualified Data.Text                                    as T import           Data.Time import           Data.Time.Clock.POSIX import           Development.IDE.Core.RuleTypes-import           Development.IDE.Core.Shake+import           Development.IDE.Core.Shake                   hiding (Log)+import           Development.IDE.Core.FileUtils import           Development.IDE.GHC.Orphans                  () import           Development.IDE.Graph import           Development.IDE.Import.DependencyInformation@@ -55,8 +50,6 @@ #ifdef mingw32_HOST_OS import qualified System.Directory                             as Dir #else-import           System.Posix.Files                           (getFileStatus,-                                                               modificationTimeHiRes) #endif  import qualified Development.IDE.Types.Logger                 as L@@ -67,8 +60,14 @@ import           Data.List                                    (foldl') import qualified Data.Text                                    as Text import           Development.IDE.Core.IdeConfiguration        (isWorkspaceFile)-import           Language.LSP.Server                          hiding-                                                              (getVirtualFile)+import qualified Development.IDE.Core.Shake                   as Shake+import           Development.IDE.Types.Logger                 (Pretty (pretty),+                                                               Priority (Info),+                                                               Recorder,+                                                               WithPriority,+                                                               cmapWithPrio,+                                                               logWith, viaShow,+                                                               (<+>)) import qualified Language.LSP.Server                          as LSP import           Language.LSP.Types                           (DidChangeWatchedFilesRegistrationOptions (DidChangeWatchedFilesRegistrationOptions),                                                                FileChangeType (FcChanged),@@ -80,29 +79,25 @@ import           Language.LSP.VFS import           System.FilePath -makeVFSHandle :: IO VFSHandle-makeVFSHandle = do-    vfsVar <- newVar (1, Map.empty)-    pure VFSHandle-        { getVirtualFile = \uri -> do-              (_nextVersion, vfs) <- readVar vfsVar-              pure $ Map.lookup uri vfs-        , setVirtualFileContents = Just $ \uri content ->-              void $ modifyVar' vfsVar $ \(nextVersion, vfs) -> (nextVersion + 1, ) $-                  case content of-                    Nothing -> Map.delete uri vfs-                    -- The second version number is only used in persistFileVFS which we do not use so we set it to 0.-                    Just content -> Map.insert uri (VirtualFile nextVersion 0 (Rope.fromText content)) vfs-        }+data Log+  = LogCouldNotIdentifyReverseDeps !NormalizedFilePath+  | LogTypeCheckingReverseDeps !NormalizedFilePath !(Maybe [NormalizedFilePath])+  | LogShake Shake.Log+  deriving Show -makeLSPVFSHandle :: LanguageContextEnv c -> VFSHandle-makeLSPVFSHandle lspEnv = VFSHandle-    { getVirtualFile = runLspT lspEnv . LSP.getVirtualFile-    , setVirtualFileContents = Nothing-   }+instance Pretty Log where+  pretty = \case+    LogCouldNotIdentifyReverseDeps path ->+      "Could not identify reverse dependencies for" <+> viaShow path+    (LogTypeCheckingReverseDeps path reverseDepPaths) ->+      "Typechecking reverse dependecies for"+      <+> viaShow path+      <> ":"+      <+> pretty (fmap (fmap show) reverseDepPaths)+    LogShake log -> pretty log -addWatchedFileRule :: (NormalizedFilePath -> Action Bool) -> Rules ()-addWatchedFileRule isWatched = defineNoDiagnostics $ \AddWatchedFile f -> do+addWatchedFileRule :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules ()+addWatchedFileRule recorder isWatched = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \AddWatchedFile f -> do   isAlreadyWatched <- isWatched f   isWp <- isWorkspaceFile f   if isAlreadyWatched then pure (Just True) else@@ -114,20 +109,19 @@             Nothing -> pure $ Just False  -getModificationTimeRule :: VFSHandle -> Rules ()-getModificationTimeRule vfs = defineEarlyCutoff $ Rule $ \(GetModificationTime_ missingFileDiags) file ->-    getModificationTimeImpl vfs missingFileDiags file+getModificationTimeRule :: Recorder (WithPriority Log) -> Rules ()+getModificationTimeRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \(GetModificationTime_ missingFileDiags) file ->+    getModificationTimeImpl missingFileDiags file -getModificationTimeImpl :: VFSHandle-    -> Bool-    -> NormalizedFilePath-    -> Action-        (Maybe BS.ByteString, ([FileDiagnostic], Maybe FileVersion))-getModificationTimeImpl vfs missingFileDiags file = do+getModificationTimeImpl+  :: Bool+  -> NormalizedFilePath+  -> Action (Maybe BS.ByteString, ([FileDiagnostic], Maybe FileVersion))+getModificationTimeImpl missingFileDiags file = do     let file' = fromNormalizedFilePath file     let wrap time = (Just $ LBS.toStrict $ B.encode $ toRational time, ([], Just $ ModificationTime time))-    mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file-    case mbVirtual of+    mbVf <- getVirtualFile file+    case mbVf of         Just (virtualFileVersion -> ver) -> do             alwaysRerun             pure (Just $ LBS.toStrict $ B.encode ver, ([], Just $ VFSVersion ver))@@ -180,43 +174,23 @@             _ -> pure ()  --- Dir.getModificationTime is surprisingly slow since it performs--- a ton of conversions. Since we do not actually care about--- the format of the time, we can get away with something cheaper.--- For now, we only try to do this on Unix systems where it seems to get the--- time spent checking file modifications (which happens on every change)--- from > 0.5s to ~0.15s.--- We might also want to try speeding this up on Windows at some point.--- TODO leverage DidChangeWatchedFile lsp notifications on clients that--- support them, as done for GetFileExists-getModTime :: FilePath -> IO POSIXTime-getModTime f =-#ifdef mingw32_HOST_OS-    utcTimeToPOSIXSeconds <$> Dir.getModificationTime f-#else-    modificationTimeHiRes <$> getFileStatus f-#endif- modificationTime :: FileVersion -> Maybe UTCTime modificationTime VFSVersion{}             = Nothing modificationTime (ModificationTime posix) = Just $ posixSecondsToUTCTime posix -getFileContentsRule :: VFSHandle -> Rules ()-getFileContentsRule vfs = define $ \GetFileContents file -> getFileContentsImpl vfs file+getFileContentsRule :: Recorder (WithPriority Log) -> Rules ()+getFileContentsRule recorder = define (cmapWithPrio LogShake recorder) $ \GetFileContents file -> getFileContentsImpl file  getFileContentsImpl-    :: VFSHandle-    -> NormalizedFilePath+    :: NormalizedFilePath     -> Action ([FileDiagnostic], Maybe (FileVersion, Maybe T.Text))-getFileContentsImpl vfs file = do+getFileContentsImpl file = do     -- need to depend on modification time to introduce a dependency with Cutoff     time <- use_ GetModificationTime file-    res <- liftIO $ ideTryIOException file $ do-        mbVirtual <- getVirtualFile vfs $ filePathToUri' file+    res <- do+        mbVirtual <- getVirtualFile file         pure $ Rope.toText . _text <$> mbVirtual-    case res of-        Left err       -> return ([err], Nothing)-        Right contents -> return ([], Just (time, contents))+    pure ([], Just (time, res))  ideTryIOException :: NormalizedFilePath -> IO a -> IO (Either FileDiagnostic a) ideTryIOException fp act =@@ -240,64 +214,57 @@             pure $ posixSecondsToUTCTime posix     return (modTime, txt) -fileStoreRules :: VFSHandle -> (NormalizedFilePath -> Action Bool) -> Rules ()-fileStoreRules vfs isWatched = do-    addIdeGlobal vfs-    getModificationTimeRule vfs-    getFileContentsRule vfs-    addWatchedFileRule isWatched+fileStoreRules :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules ()+fileStoreRules recorder isWatched = do+    getModificationTimeRule recorder+    getFileContentsRule recorder+    addWatchedFileRule recorder isWatched  -- | Note that some buffer for a specific file has been modified but not -- with what changes.-setFileModified :: IdeState+setFileModified :: Recorder (WithPriority Log)+                -> VFSModified+                -> IdeState                 -> Bool -- ^ Was the file saved?                 -> NormalizedFilePath                 -> IO ()-setFileModified state saved nfp = do+setFileModified recorder vfs state saved nfp = do     ideOptions <- getIdeOptionsIO $ shakeExtras state     doCheckParents <- optCheckParents ideOptions     let checkParents = case doCheckParents of           AlwaysCheck -> True           CheckOnSave -> saved           _           -> False-    VFSHandle{..} <- getIdeGlobalState state-    when (isJust setVirtualFileContents) $-        fail "setFileModified can't be called on this type of VFSHandle"     join $ atomically $ recordDirtyKeys (shakeExtras state) GetModificationTime [nfp]-    restartShakeSession (shakeExtras state) (fromNormalizedFilePath nfp ++ " (modified)") []+    restartShakeSession (shakeExtras state) vfs (fromNormalizedFilePath nfp ++ " (modified)") []     when checkParents $-      typecheckParents state nfp+      typecheckParents recorder state nfp -typecheckParents :: IdeState -> NormalizedFilePath -> IO ()-typecheckParents state nfp = void $ shakeEnqueue (shakeExtras state) parents-  where parents = mkDelayedAction "ParentTC" L.Debug (typecheckParentsAction nfp)+typecheckParents :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> IO ()+typecheckParents recorder state nfp = void $ shakeEnqueue (shakeExtras state) parents+  where parents = mkDelayedAction "ParentTC" L.Debug (typecheckParentsAction recorder nfp) -typecheckParentsAction :: NormalizedFilePath -> Action ()-typecheckParentsAction nfp = do+typecheckParentsAction :: Recorder (WithPriority Log) -> NormalizedFilePath -> Action ()+typecheckParentsAction recorder nfp = do     revs <- transitiveReverseDependencies nfp <$> useNoFile_ GetModuleGraph-    logger <- logger <$> getShakeExtras-    let log = L.logInfo logger . T.pack+    let log = logWith recorder     case revs of-      Nothing -> liftIO $ log $ "Could not identify reverse dependencies for " ++ show nfp+      Nothing -> log Info $ LogCouldNotIdentifyReverseDeps nfp       Just rs -> do-        liftIO $ (log $ "Typechecking reverse dependencies for " ++ show nfp ++ ": " ++ show revs)-          `catch` \(e :: SomeException) -> log (show e)+        log Info $ LogTypeCheckingReverseDeps nfp revs         void $ uses GetModIface rs  -- | Note that some keys have been modified and restart the session --   Only valid if the virtual file system was initialised by LSP, as that --   independently tracks which files are modified.-setSomethingModified :: IdeState -> [Key] -> String -> IO ()-setSomethingModified state keys reason = do-    VFSHandle{..} <- getIdeGlobalState state-    when (isJust setVirtualFileContents) $-        fail "setSomethingModified can't be called on this type of VFSHandle"+setSomethingModified :: VFSModified -> IdeState -> [Key] -> String -> IO ()+setSomethingModified vfs state keys reason = do     -- Update database to remove any files that might have been renamed/deleted     atomically $ do         writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles)         modifyTVar' (dirtyKeys $ shakeExtras state) $ \x ->             foldl' (flip HSet.insert) x keys-    void $ restartShakeSession (shakeExtras state) reason []+    void $ restartShakeSession (shakeExtras state) vfs reason []  registerFileWatches :: [String] -> LSP.LspT Config IO Bool registerFileWatches globs = do

@@ -0,0 +1,31 @@+{-# LANGUAGE CPP          #-}++module Development.IDE.Core.FileUtils(+    getModTime,+    ) where+++import           Data.Time.Clock.POSIX+#ifdef mingw32_HOST_OS+import qualified System.Directory                             as Dir+#else+import           System.Posix.Files                           (getFileStatus,+                                                               modificationTimeHiRes)+#endif++-- Dir.getModificationTime is surprisingly slow since it performs+-- a ton of conversions. Since we do not actually care about+-- the format of the time, we can get away with something cheaper.+-- For now, we only try to do this on Unix systems where it seems to get the+-- time spent checking file modifications (which happens on every change)+-- from > 0.5s to ~0.15s.+-- We might also want to try speeding this up on Windows at some point.+-- TODO leverage DidChangeWatchedFile lsp notifications on clients that+-- support them, as done for GetFileExists+getModTime :: FilePath -> IO POSIXTime+getModTime f =+#ifdef mingw32_HOST_OS+    utcTimeToPOSIXSeconds <$> Dir.getModificationTime f+#else+    modificationTimeHiRes <$> getFileStatus f+#endif

@@ -14,8 +14,10 @@     deleteFileOfInterest,     setFilesOfInterest,     kick, FileOfInterestStatus(..),-    OfInterestVar(..)-    ,scheduleGarbageCollection) where+    OfInterestVar(..),+    scheduleGarbageCollection,+    Log(..)+    ) where  import           Control.Concurrent.Strict import           Control.Monad@@ -32,24 +34,37 @@ import           Data.Maybe                               (catMaybes) import           Development.IDE.Core.ProgressReporting import           Development.IDE.Core.RuleTypes-import           Development.IDE.Core.Shake+import           Development.IDE.Core.Shake               hiding (Log)+import qualified Development.IDE.Core.Shake               as Shake import           Development.IDE.Plugin.Completions.Types import           Development.IDE.Types.Exports import           Development.IDE.Types.Location-import           Development.IDE.Types.Logger+import           Development.IDE.Types.Logger             (Pretty (pretty),+                                                           Recorder,+                                                           WithPriority,+                                                           cmapWithPrio,+                                                           logDebug) import           Development.IDE.Types.Options            (IdeTesting (..)) import qualified Language.LSP.Server                      as LSP import qualified Language.LSP.Types                       as LSP +data Log = LogShake Shake.Log+  deriving Show++instance Pretty Log where+  pretty = \case+    LogShake log -> pretty log+ newtype OfInterestVar = OfInterestVar (Var (HashMap NormalizedFilePath FileOfInterestStatus))+ instance IsIdeGlobal OfInterestVar  -- | The rule that initialises the files of interest state.-ofInterestRules :: Rules ()-ofInterestRules = do+ofInterestRules :: Recorder (WithPriority Log) -> Rules ()+ofInterestRules recorder = do     addIdeGlobal . OfInterestVar =<< liftIO (newVar HashMap.empty)     addIdeGlobal . GarbageCollectVar =<< liftIO (newVar False)-    defineEarlyCutoff $ RuleNoDiagnostics $ \IsFileOfInterest f -> do+    defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \IsFileOfInterest f -> do         alwaysRerun         filesOfInterest <- getFilesOfInterestUntracked         let foi = maybe NotFOI IsFOI $ f `HashMap.lookup` filesOfInterest

@@ -138,6 +138,9 @@     -- ^ Typechecked splice information     , tmrDeferedError    :: !Bool     -- ^ Did we defer any type errors for this module?+    , tmrRuntimeModules  :: !(ModuleEnv UTCTime)+        -- ^ Which modules did we need at runtime while compiling this file?+        -- Used for recompilation checking in the presence of TH     } instance Show TcModuleResult where     show = show . pm_mod_summary . tmrParsed@@ -158,13 +161,15 @@     -- ^ Fingerprint for the ModIface     , hirLinkableFp :: ByteString     -- ^ Fingerprint for the Linkable+    , hirRuntimeModules :: !(ModuleEnv UTCTime)+    -- ^ same as tmrRuntimeModules     }  hiFileFingerPrint :: HiFileResult -> ByteString hiFileFingerPrint HiFileResult{..} = hirIfaceFp <> hirLinkableFp -mkHiFileResult :: ModSummary -> HomeModInfo -> HiFileResult-mkHiFileResult hirModSummary hirHomeMod = HiFileResult{..}+mkHiFileResult :: ModSummary -> HomeModInfo -> ModuleEnv UTCTime -> HiFileResult+mkHiFileResult hirModSummary hirHomeMod hirRuntimeModules = HiFileResult{..}   where     hirIfaceFp = fingerprintToBS . getModuleHash . hm_iface $ hirHomeMod -- will always be two bytes     hirLinkableFp = case hm_linkable hirHomeMod of@@ -290,10 +295,12 @@ -- | Get the modification time of a file. type instance RuleResult GetModificationTime = FileVersion +-- | Either the mtime from disk or an LSP version+--   LSP versions always compare as greater than on disk versions data FileVersion-    = VFSVersion !Int32-    | ModificationTime !POSIXTime-    deriving (Show, Generic)+    = ModificationTime !POSIXTime -- order of constructors is relevant+    | VFSVersion !Int32+    deriving (Show, Generic, Eq, Ord)  instance NFData FileVersion @@ -414,7 +421,11 @@         -- Required for interactive evaluation, but leads to more cache invalidations         fullModSummary :: Bool     }-    deriving newtype (Eq, Show, Typeable, Hashable, NFData)+    deriving newtype (Eq, Typeable, Hashable, NFData)++instance Show GhcSessionDeps where+    show (GhcSessionDeps_ False) = "GhcSessionDeps"+    show (GhcSessionDeps_ True) = "GhcSessionDepsFull"  pattern GhcSessionDeps :: GhcSessionDeps pattern GhcSessionDeps = GhcSessionDeps_ False

@@ -30,7 +30,6 @@     usePropertyAction,     -- * Rules     CompiledLinkables(..),-    IsHiFileStable(..),     getParsedModuleRule,     getParsedModuleWithCommentsRule,     getLocatedImportsRule,@@ -42,7 +41,6 @@     getModIfaceFromDiskRule,     getModIfaceRule,     getModSummaryRule,-    isHiFileStableRule,     getModuleGraphRule,     knownFilesRule,     getClientSettingsRule,@@ -56,7 +54,9 @@     ghcSessionDepsDefinition,     getParsedModuleDefinition,     typeCheckRuleDefinition,+    getRebuildCount,     GhcSessionDepsConfig(..),+    Log(..),     DisplayTHWarning(..),     ) where @@ -84,6 +84,7 @@ import qualified Data.HashSet                                 as HashSet import           Data.Hashable import           Data.IORef+import           Control.Concurrent.STM.TVar import           Data.IntMap.Strict                           (IntMap) import qualified Data.IntMap.Strict                           as IntMap import           Data.List@@ -96,29 +97,29 @@ import           Data.Time                                    (UTCTime (..)) import           Data.Tuple.Extra import           Development.IDE.Core.Compile-import           Development.IDE.Core.FileExists+import           Development.IDE.Core.FileExists hiding (LogShake, Log) import           Development.IDE.Core.FileStore               (getFileContents,-                                                               modificationTime,                                                                resetInterfaceStore) import           Development.IDE.Core.IdeConfiguration-import           Development.IDE.Core.OfInterest+import           Development.IDE.Core.OfInterest hiding (LogShake, Log) import           Development.IDE.Core.PositionMapping import           Development.IDE.Core.RuleTypes-import           Development.IDE.Core.Service-import           Development.IDE.Core.Shake+import           Development.IDE.Core.Service hiding (LogShake, Log)+import           Development.IDE.Core.Shake hiding (Log)+import           Development.IDE.GHC.Compat.Env import           Development.IDE.GHC.Compat                   hiding-                                                              (parseModule,+                                                              (vcat, nest, parseModule,                                                                TargetId(..),                                                                loadInterface,-                                                               Var)-import qualified Development.IDE.GHC.Compat                   as Compat+                                                               Var,+                                                               (<+>))+import qualified Development.IDE.GHC.Compat                   as Compat hiding (vcat, nest) import qualified Development.IDE.GHC.Compat.Util              as Util import           Development.IDE.GHC.Error-import           Development.IDE.GHC.ExactPrint+import           Development.IDE.GHC.ExactPrint hiding (LogShake, Log) import           Development.IDE.GHC.Util                     hiding                                                               (modifyDynFlags) import           Development.IDE.Graph-import           Development.IDE.Graph.Classes import           Development.IDE.Import.DependencyInformation import           Development.IDE.Import.FindImports import qualified Development.IDE.Spans.AtPoint                as AtPoint@@ -127,9 +128,7 @@ import           Development.IDE.Types.Diagnostics            as Diag import           Development.IDE.Types.HscEnvEq import           Development.IDE.Types.Location-import qualified Development.IDE.Types.Logger                 as L import           Development.IDE.Types.Options-import           GHC.Generics                                 (Generic) import qualified GHC.LanguageExtensions                       as LangExt import qualified HieDb import           Ide.Plugin.Config@@ -150,7 +149,37 @@ import Language.LSP.Server (LspT) import System.Info.Extra (isWindows) import HIE.Bios.Ghc.Gap (hostIsDynamic)+import Development.IDE.Types.Logger (Recorder, logWith, cmapWithPrio, WithPriority, Pretty (pretty), (<+>), nest, vcat)+import qualified Development.IDE.Core.Shake as Shake+import qualified Development.IDE.GHC.ExactPrint as ExactPrint hiding (LogShake)+import qualified Development.IDE.Types.Logger as Logger+import qualified Development.IDE.Types.Shake as Shake +data Log+  = LogShake Shake.Log+  | LogReindexingHieFile !NormalizedFilePath+  | LogLoadingHieFile !NormalizedFilePath+  | LogLoadingHieFileFail !FilePath !SomeException+  | LogLoadingHieFileSuccess !FilePath+  | LogExactPrint ExactPrint.Log+  deriving Show++instance Pretty Log where+  pretty = \case+    LogShake log -> pretty log+    LogReindexingHieFile path ->+      "Re-indexing hie file for" <+> pretty (fromNormalizedFilePath path)+    LogLoadingHieFile path ->+      "LOADING HIE FILE FOR" <+> pretty (fromNormalizedFilePath path)+    LogLoadingHieFileFail path e ->+      nest 2 $+        vcat+          [ "FAILED LOADING HIE FILE FOR" <+> pretty path+          , pretty (displayException e) ]+    LogLoadingHieFileSuccess path ->+      "SUCCEEDED LOADING HIE FILE FOR" <+> pretty path+    LogExactPrint log -> pretty log+ templateHaskellInstructions :: T.Text templateHaskellInstructions = "https://haskell-language-server.readthedocs.io/en/latest/troubleshooting.html#static-binaries" @@ -207,10 +236,10 @@ -- See https://github.com/haskell/ghcide/pull/350#discussion_r370878197 -- and https://github.com/mpickering/ghcide/pull/22#issuecomment-625070490 -- GHC wiki about: https://gitlab.haskell.org/ghc/ghc/-/wikis/api-annotations-getParsedModuleRule :: Rules ()-getParsedModuleRule =+getParsedModuleRule :: Recorder (WithPriority Log) -> Rules ()+getParsedModuleRule recorder =   -- this rule does not have early cutoff since all its dependencies already have it-  define $ \GetParsedModule file -> do+  define (cmapWithPrio LogShake recorder) $ \GetParsedModule file -> do     ModSummaryResult{msrModSummary = ms'} <- use_ GetModSummary file     sess <- use_ GhcSession file     let hsc = hscEnv sess@@ -280,11 +309,11 @@ -- | This rule provides a ParsedModule preserving all annotations, -- including keywords, punctuation and comments. -- So it is suitable for use cases where you need a perfect edit.-getParsedModuleWithCommentsRule :: Rules ()-getParsedModuleWithCommentsRule =+getParsedModuleWithCommentsRule :: Recorder (WithPriority Log) -> Rules ()+getParsedModuleWithCommentsRule recorder =   -- The parse diagnostics are owned by the GetParsedModule rule   -- For this reason, this rule does not produce any diagnostics-  defineNoDiagnostics $ \GetParsedModuleWithComments file -> do+  defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \GetParsedModuleWithComments file -> do     ModSummaryResult{msrModSummary = ms} <- use_ GetModSummary file     sess <- use_ GhcSession file     opt <- getIdeOptions@@ -315,9 +344,9 @@         Nothing   -> pure (diag, Nothing)         Just modu -> pure (diag, Just modu) -getLocatedImportsRule :: Rules ()-getLocatedImportsRule =-    define $ \GetLocatedImports file -> do+getLocatedImportsRule :: Recorder (WithPriority Log) -> Rules ()+getLocatedImportsRule recorder =+    define (cmapWithPrio LogShake recorder) $ \GetLocatedImports file -> do         ModSummaryResult{msrModSummary = ms} <- use_ GetModSummaryWithoutTimestamps file         targets <- useNoFile_ GetKnownTargets         let targetsMap = HM.mapWithKey const targets@@ -376,7 +405,7 @@ execRawDepM :: Monad m => StateT (RawDependencyInformation, IntMap a1) m a2 -> m (RawDependencyInformation, IntMap a1) execRawDepM act =     execStateT act-        ( RawDependencyInformation IntMap.empty emptyPathIdMap IntMap.empty+        ( RawDependencyInformation IntMap.empty emptyPathIdMap IntMap.empty IntMap.empty         , IntMap.empty         ) @@ -403,6 +432,11 @@           let al = modSummaryToArtifactsLocation f msum           -- Get a fresh FilePathId for the new file           fId <- getFreshFid al+          -- Record this module and its location+          whenJust msum $ \ms ->+            modifyRawDepInfo (\rd -> rd { rawModuleNameMap = IntMap.insert (getFilePathId fId)+                                                                           (ShowableModuleName (moduleName $ ms_mod ms))+                                                                           (rawModuleNameMap rd)})           -- Adding an edge to the bootmap so we can make sure to           -- insert boot nodes before the real files.           addBootMap al fId@@ -474,15 +508,15 @@     dropBootSuffix :: FilePath -> FilePath     dropBootSuffix hs_src = reverse . drop (length @[] "-boot") . reverse $ hs_src -getDependencyInformationRule :: Rules ()-getDependencyInformationRule =-    define $ \GetDependencyInformation file -> do+getDependencyInformationRule :: Recorder (WithPriority Log) -> Rules ()+getDependencyInformationRule recorder =+    define (cmapWithPrio LogShake recorder) $ \GetDependencyInformation file -> do        rawDepInfo <- rawDependencyInformation [file]        pure ([], Just $ processDependencyInformation rawDepInfo) -reportImportCyclesRule :: Rules ()-reportImportCyclesRule =-    define $ \ReportImportCycles file -> fmap (\errs -> if null errs then ([], Just ()) else (errs, Nothing)) $ do+reportImportCyclesRule :: Recorder (WithPriority Log) -> Rules ()+reportImportCyclesRule recorder =+    define (cmapWithPrio LogShake recorder) $ \ReportImportCycles file -> fmap (\errs -> if null errs then ([], Just ()) else (errs, Nothing)) $ do         DependencyInformation{..} <- use_ GetDependencyInformation file         let fileId = pathToId depPathIdMap file         case IntMap.lookup (getFilePathId fileId) depErrorNodes of@@ -514,22 +548,21 @@            pure (moduleNameString . moduleName . ms_mod $ ms)           showCycle mods  = T.intercalate ", " (map T.pack mods) -getHieAstsRule :: Rules ()-getHieAstsRule =-    define $ \GetHieAst f -> do+getHieAstsRule :: Recorder (WithPriority Log) -> Rules ()+getHieAstsRule recorder =+    define (cmapWithPrio LogShake recorder) $ \GetHieAst f -> do       tmr <- use_ TypeCheck f       hsc <- hscEnv <$> use_ GhcSessionDeps f       getHieAstRuleDefinition f hsc tmr -persistentHieFileRule :: Rules ()-persistentHieFileRule = addPersistentRule GetHieAst $ \file -> runMaybeT $ do-  res <- readHieFileForSrcFromDisk file-  vfs <- asks vfs-  (currentSource,ver) <- liftIO $ do-    mvf <- getVirtualFile vfs $ filePathToUri' file-    case mvf of-      Nothing -> (,Nothing) . T.decodeUtf8 <$> BS.readFile (fromNormalizedFilePath file)-      Just vf -> pure (Rope.toText $ _text vf, Just $ _lsp_version vf)+persistentHieFileRule :: Recorder (WithPriority Log) -> Rules ()+persistentHieFileRule recorder = addPersistentRule GetHieAst $ \file -> runMaybeT $ do+  res <- readHieFileForSrcFromDisk recorder file+  vfsRef <- asks vfsVar+  vfsData <- liftIO $ vfsMap <$> readTVarIO vfsRef+  (currentSource, ver) <- liftIO $ case M.lookup (filePathToUri' file) vfsData of+    Nothing -> (,Nothing) . T.decodeUtf8 <$> BS.readFile (fromNormalizedFilePath file)+    Just vf -> pure (Rope.toText $ _text vf, Just $ _lsp_version vf)   let refmap = Compat.generateReferencesMap . Compat.getAsts . Compat.hie_asts $ res       del = deltaFromDiff (T.decodeUtf8 $ Compat.hie_hs_src res) currentSource   pure (HAR (Compat.hie_module res) (Compat.hie_asts res) refmap mempty (HieFromDisk res),del,ver)@@ -557,8 +590,8 @@       typemap = AtPoint.computeTypeReferences . Compat.getAsts <$> masts   pure (diags <> diagsWrite, HAR (ms_mod $ tmrModSummary tmr) <$> masts <*> refmap <*> typemap <*> pure HieFresh) -getImportMapRule :: Rules ()-getImportMapRule = define $ \GetImportMap f -> do+getImportMapRule :: Recorder (WithPriority Log) -> Rules ()+getImportMapRule recorder = define (cmapWithPrio LogShake recorder) $ \GetImportMap f -> do   im <- use GetLocatedImports f   let mkImports fileImports = M.fromList $ mapMaybe (\(m, mfp) -> (unLoc m,) . artifactFilePath <$> mfp) fileImports   pure ([], ImportMap . mkImports <$> im)@@ -567,17 +600,17 @@ persistentImportMapRule :: Rules () persistentImportMapRule = addPersistentRule GetImportMap $ \_ -> pure $ Just (ImportMap mempty, idDelta, Nothing) -getBindingsRule :: Rules ()-getBindingsRule =-  define $ \GetBindings f -> do+getBindingsRule :: Recorder (WithPriority Log) -> Rules ()+getBindingsRule recorder =+  define (cmapWithPrio LogShake recorder) $ \GetBindings f -> do     HAR{hieKind=kind, refMap=rm} <- use_ GetHieAst f     case kind of       HieFresh      -> pure ([], Just $ bindings rm)       HieFromDisk _ -> pure ([], Nothing) -getDocMapRule :: Rules ()-getDocMapRule =-    define $ \GetDocMap file -> do+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@@ -591,40 +624,39 @@ persistentDocMapRule :: Rules () persistentDocMapRule = addPersistentRule GetDocMap $ \_ -> pure $ Just (DKMap mempty mempty, idDelta, Nothing) -readHieFileForSrcFromDisk :: NormalizedFilePath -> MaybeT IdeAction Compat.HieFile-readHieFileForSrcFromDisk file = do+readHieFileForSrcFromDisk :: Recorder (WithPriority Log) -> NormalizedFilePath -> MaybeT IdeAction Compat.HieFile+readHieFileForSrcFromDisk recorder file = do   ShakeExtras{withHieDb} <- ask-  log <- asks $ L.logDebug . logger   row <- MaybeT $ liftIO $ withHieDb (\hieDb -> HieDb.lookupHieFileFromSource hieDb $ fromNormalizedFilePath file)   let hie_loc = HieDb.hieModuleHieFile row-  liftIO $ log $ "LOADING HIE FILE :" <> T.pack (show file)-  exceptToMaybeT $ readHieFileFromDisk hie_loc+  liftIO $ logWith recorder Logger.Debug $ LogLoadingHieFile file+  exceptToMaybeT $ readHieFileFromDisk recorder hie_loc -readHieFileFromDisk :: FilePath -> ExceptT SomeException IdeAction Compat.HieFile-readHieFileFromDisk hie_loc = do+readHieFileFromDisk :: Recorder (WithPriority Log) -> FilePath -> ExceptT SomeException IdeAction Compat.HieFile+readHieFileFromDisk recorder hie_loc = do   nc <- asks ideNc-  log <- asks $ L.logDebug . logger   res <- liftIO $ tryAny $ loadHieFile (mkUpdater nc) hie_loc-  liftIO . log $ either (const $ "FAILED LOADING HIE FILE FOR:" <> T.pack (show hie_loc))-                        (const $ "SUCCEEDED LOADING HIE FILE FOR:" <> T.pack (show hie_loc))-                        res+  let log = (liftIO .) . logWith recorder+  case res of+    Left e -> log Logger.Debug $ LogLoadingHieFileFail hie_loc e+    Right _ -> log Logger.Debug $ LogLoadingHieFileSuccess hie_loc   except res  -- | Typechecks a module.-typeCheckRule :: Rules ()-typeCheckRule = define $ \TypeCheck file -> do+typeCheckRule :: Recorder (WithPriority Log) -> Rules ()+typeCheckRule recorder = define (cmapWithPrio LogShake recorder) $ \TypeCheck file -> do     pm <- use_ GetParsedModule file     hsc  <- hscEnv <$> use_ GhcSessionDeps file     typeCheckRuleDefinition hsc pm -knownFilesRule :: Rules ()-knownFilesRule = defineEarlyCutOffNoFile $ \GetKnownTargets -> do+knownFilesRule :: Recorder (WithPriority Log) -> Rules ()+knownFilesRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake recorder) $ \GetKnownTargets -> do   alwaysRerun   fs <- knownTargets   pure (LBS.toStrict $ B.encode $ hash fs, unhashed fs) -getModuleGraphRule :: Rules ()-getModuleGraphRule = defineNoFile $ \GetModuleGraph -> do+getModuleGraphRule :: Recorder (WithPriority Log) -> Rules ()+getModuleGraphRule recorder = defineNoFile (cmapWithPrio LogShake recorder) $ \GetModuleGraph -> do   fs <- toKnownFiles <$> useNoFile_ GetKnownTargets   rawDepInfo <- rawDependencyInformation (HashSet.toList fs)   pure $ processDependencyInformation rawDepInfo@@ -655,19 +687,16 @@  -- | Get all the linkables stored in the graph, i.e. the ones we *do not* need to unload. -- Doesn't actually contain the code, since we don't need it to unload-currentLinkables :: Action [Linkable]+currentLinkables :: Action (ModuleEnv UTCTime) currentLinkables = do     compiledLinkables <- getCompiledLinkables <$> getIdeGlobalAction-    hm <- liftIO $ readVar compiledLinkables-    pure $ map go $ moduleEnvToList hm-  where-    go (mod, time) = LM time mod []+    liftIO $ readVar compiledLinkables -loadGhcSession :: GhcSessionDepsConfig -> Rules ()-loadGhcSession ghcSessionDepsConfig = do+loadGhcSession :: Recorder (WithPriority Log) -> GhcSessionDepsConfig -> Rules ()+loadGhcSession recorder ghcSessionDepsConfig = do     -- This function should always be rerun because it tracks changes     -- to the version of the collection of HscEnv's.-    defineEarlyCutOffNoFile $ \GhcSessionIO -> do+    defineEarlyCutOffNoFile (cmapWithPrio LogShake recorder) $ \GhcSessionIO -> do         alwaysRerun         opts <- getIdeOptions         res <- optGhcSession opts@@ -675,7 +704,7 @@         let fingerprint = LBS.toStrict $ B.encode $ hash (sessionVersion res)         return (fingerprint, res) -    defineEarlyCutoff $ Rule $ \GhcSession file -> do+    defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GhcSession file -> do         IdeGhcSession{loadSessionFun} <- useNoFile_ GhcSessionIO         (val,deps) <- liftIO $ loadSessionFun $ fromNormalizedFilePath file @@ -689,18 +718,10 @@                   use_ GetModificationTime nfp         mapM_ addDependency deps -        opts <- getIdeOptions-        let cutoffHash =-              case optShakeFiles opts of-                -- optShakeFiles is only set in the DAML case.-                -- https://github.com/haskell/ghcide/pull/522#discussion_r428622915-                Just {} -> ""-                -- Hash the HscEnvEq returned so cutoff if it didn't change-                -- from last time-                Nothing -> LBS.toStrict $ B.encode (hash (snd val))+        let cutoffHash = LBS.toStrict $ B.encode (hash (snd val))         return (Just cutoffHash, val) -    defineNoDiagnostics $ \(GhcSessionDeps_ fullModSummary) file -> do+    defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \(GhcSessionDeps_ fullModSummary) file -> do         env <- use_ GhcSession file         ghcSessionDepsDefinition fullModSummary ghcSessionDepsConfig env file @@ -738,16 +759,26 @@  -- | Load a iface from disk, or generate it if there isn't one or it is out of date -- This rule also ensures that the `.hie` and `.o` (if needed) files are written out.-getModIfaceFromDiskRule :: Rules ()-getModIfaceFromDiskRule = defineEarlyCutoff $ Rule $ \GetModIfaceFromDisk f -> do+getModIfaceFromDiskRule :: Recorder (WithPriority Log) -> Rules ()+getModIfaceFromDiskRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleWithOldValue $ \GetModIfaceFromDisk f old -> do   ms <- msrModSummary <$> use_ GetModSummary f   mb_session <- use GhcSessionDeps f   case mb_session of     Nothing -> return (Nothing, ([], Nothing))     Just session -> do-      sourceModified <- use_ IsHiFileStable f       linkableType <- getLinkableType f-      r <- loadInterface (hscEnv session) ms sourceModified linkableType (regenerateHiFile session f ms)+      ver <- use_ GetModificationTime f+      let m_old = case old of+            Shake.Succeeded (Just old_version) v -> Just (v, old_version)+            Shake.Stale _   (Just old_version) v -> Just (v, old_version)+            _ -> Nothing+          recompInfo = RecompilationInfo+            { source_version = ver+            , old_value = m_old+            , get_file_version = use GetModificationTime_{missingFileDiagnostics = False}+            , regenerate = regenerateHiFile session f ms+            }+      r <- loadInterface (hscEnv session) ms linkableType recompInfo       case r of         (diags, Nothing) -> return (Nothing, (diags, Nothing))         (diags, Just x) -> do@@ -762,10 +793,10 @@ -- `.hie` file. There should be an up2date `.hie` file on -- disk since we are careful to write out the `.hie` file before writing the -- `.hi` file-getModIfaceFromDiskAndIndexRule :: Rules ()-getModIfaceFromDiskAndIndexRule =+getModIfaceFromDiskAndIndexRule :: Recorder (WithPriority Log) -> Rules ()+getModIfaceFromDiskAndIndexRule recorder =   -- doesn't need early cutoff since all its dependencies already have it-  defineNoDiagnostics $ \GetModIfaceFromDiskAndIndex f -> do+  defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \GetModIfaceFromDiskAndIndex f -> do   x <- use_ GetModIfaceFromDisk f   se@ShakeExtras{withHieDb} <- getShakeExtras @@ -787,63 +818,28 @@     -- Not in db, must re-index     _ -> do       ehf <- liftIO $ runIdeAction "GetModIfaceFromDiskAndIndex" se $ runExceptT $-        readHieFileFromDisk hie_loc+        readHieFileFromDisk recorder hie_loc       case ehf of         -- Uh oh, we failed to read the file for some reason, need to regenerate it         Left err -> fail $ "failed to read .hie file " ++ show hie_loc ++ ": " ++ displayException err         -- can just re-index the file we read from disk         Right hf -> liftIO $ do-          L.logDebug (logger se) $ "Re-indexing hie file for" <> T.pack (fromNormalizedFilePath f)+          logWith recorder Logger.Debug $ LogReindexingHieFile f           indexHieFile se ms f hash hf    return (Just x) -isHiFileStableRule :: Rules ()-isHiFileStableRule = defineEarlyCutoff $ RuleNoDiagnostics $ \IsHiFileStable f -> do-    ms <- msrModSummary <$> use_ GetModSummaryWithoutTimestamps f-    let hiFile = toNormalizedFilePath'-                $ Compat.ml_hi_file $ ms_location ms-    mbHiVersion <- use  GetModificationTime_{missingFileDiagnostics=False} hiFile-    modVersion  <- use_ GetModificationTime f-    sourceModified <- case mbHiVersion of-        Nothing -> pure SourceModified-        Just x ->-            if modificationTime x < modificationTime modVersion-                then pure SourceModified-                else do-                    fileImports <- use_ GetLocatedImports f-                    let imports = fmap artifactFilePath . snd <$> fileImports-                    deps <- uses_ IsHiFileStable (catMaybes imports)-                    pure $ if all (== SourceUnmodifiedAndStable) deps-                           then SourceUnmodifiedAndStable-                           else SourceUnmodified-    return (Just (summarize sourceModified), Just sourceModified)-  where-      summarize SourceModified            = BS.singleton 1-      summarize SourceUnmodified          = BS.singleton 2-      summarize SourceUnmodifiedAndStable = BS.singleton 3--displayTHWarning :: LspT c IO ()-displayTHWarning-  | not isWindows && not hostIsDynamic = do-      LSP.sendNotification SWindowShowMessage $-        ShowMessageParams MtInfo $ T.unwords-          [ "This HLS binary does not support Template Haskell."-          , "Follow the [instructions](" <> templateHaskellInstructions <> ")"-          , "to build an HLS binary with support for Template Haskell."-          ]-  | otherwise = return ()--newtype DisplayTHWarning = DisplayTHWarning (IO ())+newtype DisplayTHWarning = DisplayTHWarning (IO()) instance IsIdeGlobal DisplayTHWarning -getModSummaryRule :: Rules ()-getModSummaryRule = do-    env <- lspEnv <$> getShakeExtrasRules-    displayItOnce <- liftIO $ once $ LSP.runLspT (fromJust env) displayTHWarning-    addIdeGlobal (DisplayTHWarning displayItOnce)+getModSummaryRule :: LspT Config IO () -> Recorder (WithPriority Log) -> Rules ()+getModSummaryRule displayTHWarning recorder = do+    menv <- lspEnv <$> getShakeExtrasRules+    forM_ menv $ \env -> do+        displayItOnce <- liftIO $ once $ LSP.runLspT env displayTHWarning+        addIdeGlobal (DisplayTHWarning displayItOnce) -    defineEarlyCutoff $ Rule $ \GetModSummary f -> do+    defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModSummary f -> do         session' <- hscEnv <$> use_ GhcSession f         modify_dflags <- getModifyDynFlags dynFlagsModifyGlobal         let session = hscSetFlags (modify_dflags $ hsc_dflags session') session'@@ -864,7 +860,7 @@                 return ( Just (fingerprintToBS fingerPrint) , ([], Just res))             Left diags -> return (Nothing, (diags, Nothing)) -    defineEarlyCutoff $ RuleNoDiagnostics $ \GetModSummaryWithoutTimestamps f -> do+    defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetModSummaryWithoutTimestamps f -> do         ms <- use GetModSummary f         case ms of             Just res@ModSummaryResult{..} -> do@@ -883,12 +879,12 @@     setPriority priorityGenerateCore     liftIO $ compileModule runSimplifier packageState (tmrModSummary tm) (tmrTypechecked tm) -generateCoreRule :: Rules ()-generateCoreRule =-    define $ \GenerateCore -> generateCore (RunSimplifier True)+generateCoreRule :: Recorder (WithPriority Log) -> Rules ()+generateCoreRule recorder =+    define (cmapWithPrio LogShake recorder) $ \GenerateCore -> generateCore (RunSimplifier True) -getModIfaceRule :: Rules ()-getModIfaceRule = defineEarlyCutoff $ Rule $ \GetModIface f -> do+getModIfaceRule :: Recorder (WithPriority Log) -> Rules ()+getModIfaceRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModIface f -> do   fileOfInterest <- use_ IsFileOfInterest f   res@(_,(_,mhmi)) <- case fileOfInterest of     IsFOI status -> do@@ -916,6 +912,20 @@       liftIO $ void $ modifyVar' compiledLinkables $ \old -> extendModuleEnv old mod time   pure res +-- | Count of total times we asked GHC to recompile+newtype RebuildCounter = RebuildCounter { getRebuildCountVar :: TVar Int }+instance IsIdeGlobal RebuildCounter++getRebuildCount :: Action Int+getRebuildCount = do+  count <- getRebuildCountVar <$> getIdeGlobalAction+  liftIO $ readTVarIO count++incrementRebuildCount :: Action ()+incrementRebuildCount = do+  count <- getRebuildCountVar <$> getIdeGlobalAction+  liftIO $ atomically $ modifyTVar' count (+1)+ -- | Also generates and indexes the `.hie` file, along with the `.o` file if needed -- Invariant maintained is that if the `.hi` file was successfully written, then the -- `.hie` and `.o` file (if needed) were also successfully written@@ -945,10 +955,10 @@               Just tmr -> do                  -- compile writes .o file-                let compile = compileModule (RunSimplifier True) hsc (pm_mod_summary pm) $ tmrTypechecked tmr+                let compile = liftIO $ compileModule (RunSimplifier True) hsc (pm_mod_summary pm) $ tmrTypechecked tmr                  -- Bang pattern is important to avoid leaking 'tmr'-                (diags'', !res) <- liftIO $ compileToObjCodeIfNeeded hsc compNeeded compile tmr+                (diags'', !res) <- compileToObjCodeIfNeeded hsc compNeeded compile tmr                  -- Write hi file                 hiDiags <- case res of@@ -972,18 +982,17 @@                     pure (hiDiags <> gDiags <> concat wDiags)                   Nothing -> pure [] -                 return (diags <> diags' <> diags'' <> hiDiags, res)  -type CompileMod m = m (IdeResult ModGuts)- -- | HscEnv should have deps included already-compileToObjCodeIfNeeded :: MonadIO m => HscEnv -> Maybe LinkableType -> CompileMod m -> TcModuleResult -> m (IdeResult HiFileResult)-compileToObjCodeIfNeeded hsc Nothing _ tmr = liftIO $ do-  res <- mkHiFileResultNoCompile hsc tmr+compileToObjCodeIfNeeded :: HscEnv -> Maybe LinkableType -> Action (IdeResult ModGuts) -> TcModuleResult -> Action (IdeResult HiFileResult)+compileToObjCodeIfNeeded hsc Nothing _ tmr = do+  incrementRebuildCount+  res <- liftIO $ mkHiFileResultNoCompile hsc tmr   pure ([], Just $! res) compileToObjCodeIfNeeded hsc (Just linkableType) getGuts tmr = do+  incrementRebuildCount   (diags, mguts) <- getGuts   case mguts of     Nothing -> pure (diags, Nothing)@@ -991,8 +1000,8 @@       (diags', !res) <- liftIO $ mkHiFileResultCompile hsc tmr guts linkableType       pure (diags++diags', res) -getClientSettingsRule :: Rules ()-getClientSettingsRule = defineEarlyCutOffNoFile $ \GetClientSettings -> do+getClientSettingsRule :: Recorder (WithPriority Log) -> Rules ()+getClientSettingsRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake recorder) $ \GetClientSettings -> do   alwaysRerun   settings <- clientSettings <$> getIdeConfiguration   return (LBS.toStrict $ B.encode $ hash settings, settings)@@ -1084,6 +1093,7 @@ newtype CompiledLinkables = CompiledLinkables { getCompiledLinkables :: Var (ModuleEnv UTCTime) } instance IsIdeGlobal CompiledLinkables + writeHiFileAction :: HscEnv -> HiFileResult -> Action [FileDiagnostic] writeHiFileAction hsc hiFile = do     extras <- getShakeExtras@@ -1097,33 +1107,48 @@       checkForImportCycles :: Bool     -- | Disable TH for improved performance in large codebases     , enableTemplateHaskell :: Bool+    -- | Warning to show when TH is not supported by the current HLS binary+    , templateHaskellWarning :: LspT Config IO ()     } -instance Default RulesConfig where def = RulesConfig True True+instance Default RulesConfig where+    def = RulesConfig True True displayTHWarning+      where+        displayTHWarning :: LspT c IO ()+        displayTHWarning+            | not isWindows && not hostIsDynamic = do+                LSP.sendNotification SWindowShowMessage $+                    ShowMessageParams MtInfo $ T.unwords+                    [ "This HLS binary does not support Template Haskell."+                    , "Follow the [instructions](" <> templateHaskellInstructions <> ")"+                    , "to build an HLS binary with support for Template Haskell."+                    ]+            | otherwise = return ()  -- | A rule that wires per-file rules together-mainRule :: RulesConfig -> Rules ()-mainRule RulesConfig{..} = do+mainRule :: Recorder (WithPriority Log) -> RulesConfig -> Rules ()+mainRule recorder RulesConfig{..} = do     linkables <- liftIO $ newVar emptyModuleEnv     addIdeGlobal $ CompiledLinkables linkables-    getParsedModuleRule-    getParsedModuleWithCommentsRule-    getLocatedImportsRule-    getDependencyInformationRule-    reportImportCyclesRule-    typeCheckRule-    getDocMapRule-    loadGhcSession def{checkForImportCycles}-    getModIfaceFromDiskRule-    getModIfaceFromDiskAndIndexRule-    getModIfaceRule-    getModSummaryRule-    isHiFileStableRule-    getModuleGraphRule-    knownFilesRule-    getClientSettingsRule-    getHieAstsRule-    getBindingsRule+    rebuildCountVar <- liftIO $ newTVarIO 0+    addIdeGlobal $ RebuildCounter rebuildCountVar+    getParsedModuleRule recorder+    getParsedModuleWithCommentsRule recorder+    getLocatedImportsRule recorder+    getDependencyInformationRule recorder+    reportImportCyclesRule recorder+    typeCheckRule recorder+    getDocMapRule recorder+    loadGhcSession recorder def{checkForImportCycles}+    getModIfaceFromDiskRule recorder+    getModIfaceFromDiskAndIndexRule recorder+    getModIfaceRule recorder+    getModSummaryRule templateHaskellWarning recorder+    getModuleGraphRule recorder+    knownFilesRule recorder+    getClientSettingsRule recorder+    getHieAstsRule recorder+    getBindingsRule recorder     -- This rule uses a custom newness check that relies on the encoding     --  produced by 'encodeLinkable'. This works as follows:     --   * <previous> -> <new>@@ -1131,22 +1156,12 @@     --   * Object/BCO -> NoLinkable      : the prev linkable can be ignored, signal "no change"     --   * otherwise                     : the prev linkable cannot be reused, signal "value has changed"     if enableTemplateHaskell-      then defineEarlyCutoff $ RuleWithCustomNewnessCheck (<=) $ \NeedsCompilation file ->+      then defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleWithCustomNewnessCheck (<=) $ \NeedsCompilation file ->                 needsCompilationRule file-      else defineNoDiagnostics $ \NeedsCompilation _ -> return $ Just Nothing-    generateCoreRule-    getImportMapRule-    getAnnotatedParsedSourceRule-    persistentHieFileRule+      else defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \NeedsCompilation _ -> return $ Just Nothing+    generateCoreRule recorder+    getImportMapRule recorder+    getAnnotatedParsedSourceRule (cmapWithPrio LogExactPrint recorder)+    persistentHieFileRule recorder     persistentDocMapRule     persistentImportMapRule---- | Given the path to a module src file, this rule returns True if the--- corresponding `.hi` file is stable, that is, if it is newer---   than the src file, and all its dependencies are stable too.-data IsHiFileStable = IsHiFileStable-    deriving (Eq, Show, Typeable, Generic)-instance Hashable IsHiFileStable-instance NFData   IsHiFileStable--type instance RuleResult IsHiFileStable = SourceModified

@@ -15,45 +15,67 @@     getDiagnostics,     ideLogger,     updatePositionMapping,+    Log(..),     ) where  import           Control.Applicative             ((<|>)) import           Development.IDE.Core.Debouncer import           Development.IDE.Core.FileExists (fileExistsRules)-import           Development.IDE.Core.OfInterest+import           Development.IDE.Core.OfInterest hiding (Log, LogShake) import           Development.IDE.Graph-import           Development.IDE.Types.Logger    as Logger+import           Development.IDE.Types.Logger    as Logger (Logger,+                                                            Pretty (pretty),+                                                            Priority (Debug),+                                                            Recorder,+                                                            WithPriority,+                                                            cmapWithPrio) import           Development.IDE.Types.Options   (IdeOptions (..)) import           Ide.Plugin.Config import qualified Language.LSP.Server             as LSP import qualified Language.LSP.Types              as LSP  import           Control.Monad-import           Development.IDE.Core.Shake+import qualified Development.IDE.Core.FileExists as FileExists+import qualified Development.IDE.Core.OfInterest as OfInterest+import           Development.IDE.Core.Shake      hiding (Log)+import qualified Development.IDE.Core.Shake      as Shake import           Development.IDE.Types.Shake     (WithHieDb) import           System.Environment              (lookupEnv)  +data Log+  = LogShake Shake.Log+  | LogOfInterest OfInterest.Log+  | LogFileExists FileExists.Log+  deriving Show++instance Pretty Log where+  pretty = \case+    LogShake log      -> pretty log+    LogOfInterest log -> pretty log+    LogFileExists log -> pretty log+ ------------------------------------------------------------ -- Exposed API  -- | Initialise the Compiler Service.-initialise :: Config+initialise :: Recorder (WithPriority Log)+           -> Config            -> Rules ()            -> Maybe (LSP.LanguageContextEnv Config)            -> Logger            -> Debouncer LSP.NormalizedUri            -> IdeOptions-           -> VFSHandle            -> WithHieDb            -> IndexQueue            -> IO IdeState-initialise defaultConfig mainRule lspEnv logger debouncer options vfs withHieDb hiedbChan = do+initialise recorder defaultConfig mainRule lspEnv logger debouncer options withHieDb hiedbChan = do     shakeProfiling <- do         let fromConf = optShakeProfiling options         fromEnv <- lookupEnv "GHCIDE_BUILD_PROFILING"         return $ fromConf <|> fromEnv     shakeOpen+        (cmapWithPrio LogShake recorder)         lspEnv         defaultConfig         logger@@ -63,12 +85,11 @@         (optTesting options)         withHieDb         hiedbChan-        vfs         (optShakeOptions options)           $ do             addIdeGlobal $ GlobalIdeOptions options-            ofInterestRules-            fileExistsRules lspEnv vfs+            ofInterestRules (cmapWithPrio LogOfInterest recorder)+            fileExistsRules (cmapWithPrio LogFileExists recorder) lspEnv             mainRule  -- | Shutdown the Compiler Service.@@ -80,4 +101,4 @@ -- e.g., the ofInterestRule. runAction :: String -> IdeState -> Action a -> IO a runAction herald ide act =-  join $ shakeEnqueue (shakeExtras ide) (mkDelayedAction herald Logger.Info act)+  join $ shakeEnqueue (shakeExtras ide) (mkDelayedAction herald Logger.Debug act)

@@ -42,7 +42,6 @@     RuleBody(..),     define, defineNoDiagnostics,     defineEarlyCutoff,-    defineOnDisk, needOnDisk, needOnDisks,     defineNoFile, defineEarlyCutOffNoFile,     getDiagnostics,     mRunLspT, mRunLspTCallback,@@ -58,11 +57,11 @@     setPriority,     ideLogger,     actionLogger,+    getVirtualFile,     FileVersion(..),     Priority(..),     updatePositionMapping,     deleteValue, recordDirtyKeys,-    OnDiskRule(..),     WithProgressFunc, WithIndefiniteProgressFunc,     ProgressEvent(..),     DelayedAction, mkDelayedAction,@@ -73,30 +72,44 @@     IndexQueue,     HieDb,     HieDbWriter(..),-    VFSHandle(..),     addPersistentRule,     garbageCollectDirtyKeys,     garbageCollectDirtyKeysOlderThan,+    Log(..),+    VFSModified(..)     ) where  import           Control.Concurrent.Async import           Control.Concurrent.STM+import           Control.Concurrent.STM.Stats           (atomicallyNamed) import           Control.Concurrent.Strict import           Control.DeepSeq+import           Control.Exception.Extra                hiding (bracket_) import           Control.Monad.Extra import           Control.Monad.IO.Class import           Control.Monad.Reader import           Control.Monad.Trans.Maybe+import           Data.Aeson                             (toJSON) import qualified Data.ByteString.Char8                  as BS+import qualified Data.ByteString.Char8                  as BS8+import           Data.Coerce                            (coerce)+import           Data.Default import           Data.Dynamic+import           Data.EnumMap.Strict                    (EnumMap)+import qualified Data.EnumMap.Strict                    as EM+import           Data.Foldable                          (for_, toList)+import           Data.Functor                           ((<&>)) import qualified Data.HashMap.Strict                    as HMap+import           Data.HashSet                           (HashSet)+import qualified Data.HashSet                           as HSet import           Data.Hashable+import           Data.IORef import           Data.List.Extra                        (foldl', partition,                                                          takeEnd)-import           Data.Map.Strict                        (Map) import qualified Data.Map.Strict                        as Map import           Data.Maybe import qualified Data.SortedList                        as SL+import           Data.String                            (fromString) import qualified Data.Text                              as T import           Data.Time import           Data.Traversable@@ -105,7 +118,9 @@ import           Data.Unique import           Data.Vector                            (Vector) import qualified Data.Vector                            as Vector+import           Debug.Trace.Flags                      (userTracingEnabled) import           Development.IDE.Core.Debouncer+import           Development.IDE.Core.FileUtils         (getModTime) import           Development.IDE.Core.PositionMapping import           Development.IDE.Core.ProgressReporting import           Development.IDE.Core.RuleTypes@@ -121,53 +136,82 @@ import qualified Development.IDE.Graph                  as Shake import           Development.IDE.Graph.Database         (ShakeDatabase,                                                          shakeGetBuildStep,-                                                         shakeOpenDatabase,+                                                         shakeNewDatabase,                                                          shakeProfileDatabase,                                                          shakeRunDatabaseForKeys) import           Development.IDE.Graph.Rule import           Development.IDE.Types.Action import           Development.IDE.Types.Diagnostics import           Development.IDE.Types.Exports+import qualified Development.IDE.Types.Exports          as ExportsMap import           Development.IDE.Types.KnownTargets import           Development.IDE.Types.Location import           Development.IDE.Types.Logger           hiding (Priority) import qualified Development.IDE.Types.Logger           as Logger import           Development.IDE.Types.Options import           Development.IDE.Types.Shake-import           GHC.Generics+import qualified Focus+import           GHC.Fingerprint+import           HieDb.Types+import           Ide.Plugin.Config+import qualified Ide.PluginUtils                        as HLS+import           Ide.Types                              (PluginId) import           Language.LSP.Diagnostics import qualified Language.LSP.Server                    as LSP import           Language.LSP.Types import qualified Language.LSP.Types                     as LSP+import           Language.LSP.Types.Capabilities import           Language.LSP.VFS+import qualified "list-t" ListT+import           OpenTelemetry.Eventlog+import qualified StmContainers.Map                      as STM import           System.FilePath                        hiding (makeRelative)+import           System.IO.Unsafe (unsafePerformIO) import           System.Time.Extra -import           Data.IORef-import           GHC.Fingerprint-import           Language.LSP.Types.Capabilities-import           OpenTelemetry.Eventlog+data Log+  = LogCreateHieDbExportsMapStart+  | LogCreateHieDbExportsMapFinish !Int+  | LogBuildSessionRestart !String ![DelayedActionInternal] !(HashSet Key) !Seconds !(Maybe FilePath)+  | LogBuildSessionRestartTakingTooLong !Seconds+  | LogDelayedAction !(DelayedAction ()) !Seconds+  | LogBuildSessionFinish !(Maybe SomeException)+  | LogDiagsDiffButNoLspEnv ![FileDiagnostic]+  | LogDefineEarlyCutoffRuleNoDiagHasDiag !FileDiagnostic+  | LogDefineEarlyCutoffRuleCustomNewnessHasDiag !FileDiagnostic+  deriving Show -import           Control.Concurrent.STM.Stats           (atomicallyNamed)-import           Control.Exception.Extra                hiding (bracket_)-import           Data.Aeson                             (toJSON)-import qualified Data.ByteString.Char8                  as BS8-import           Data.Coerce                            (coerce)-import           Data.Default-import           Data.Foldable                          (for_, toList)-import           Data.HashSet                           (HashSet)-import qualified Data.HashSet                           as HSet-import           Data.String                            (fromString)-import           Data.Text                              (pack)-import           Debug.Trace.Flags                      (userTracingEnabled)-import qualified Development.IDE.Types.Exports          as ExportsMap-import qualified Focus-import           HieDb.Types-import           Ide.Plugin.Config-import qualified Ide.PluginUtils                        as HLS-import           Ide.Types                              (PluginId)-import qualified "list-t" ListT-import qualified StmContainers.Map                      as STM+instance Pretty Log where+  pretty = \case+    LogCreateHieDbExportsMapStart ->+      "Initializing exports map from hiedb"+    LogCreateHieDbExportsMapFinish exportsMapSize ->+      "Done initializing exports map from hiedb. Size:" <+> pretty exportsMapSize+    LogBuildSessionRestart reason actionQueue keyBackLog abortDuration shakeProfilePath ->+      vcat+        [ "Restarting build session due to" <+> pretty reason+        , "Action Queue:" <+> pretty (map actionName actionQueue)+        , "Keys:" <+> pretty (map show $ HSet.toList keyBackLog)+        , "Aborting previous build session took" <+> pretty (showDuration abortDuration) <+> pretty shakeProfilePath ]+    LogBuildSessionRestartTakingTooLong seconds ->+        "Build restart is taking too long (" <> pretty seconds <> " seconds)"+    LogDelayedAction delayedAction duration ->+      hsep+        [ "Finished:" <+> pretty (actionName delayedAction)+        , "Took:" <+> pretty (showDuration duration) ]+    LogBuildSessionFinish e ->+      vcat+        [ "Finished build session"+        , pretty (fmap displayException e) ]+    LogDiagsDiffButNoLspEnv fileDiagnostics ->+      "updateFileDiagnostics published different from new diagnostics - file diagnostics:"+      <+> pretty (showDiagnosticsColored fileDiagnostics)+    LogDefineEarlyCutoffRuleNoDiagHasDiag fileDiagnostic ->+      "defineEarlyCutoff RuleNoDiagnostics - file diagnostic:"+      <+> pretty (showDiagnosticsColored [fileDiagnostic])+    LogDefineEarlyCutoffRuleCustomNewnessHasDiag fileDiagnostic ->+      "defineEarlyCutoff RuleWithCustomNewnessCheck - file diagnostic:"+      <+> pretty (showDiagnosticsColored [fileDiagnostic])  -- | We need to serialize writes to the database, so we send any function that -- needs to write to the database over the channel, where it will be picked up by@@ -201,7 +245,7 @@     ,publishedDiagnostics :: STM.Map NormalizedUri [Diagnostic]     -- ^ This represents the set of diagnostics that we have published.     -- Due to debouncing not every change might get published.-    ,positionMapping :: STM.Map NormalizedUri (Map TextDocumentVersion (PositionDelta, PositionMapping))+    ,positionMapping :: STM.Map NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping))     -- ^ Map from a text document version to a PositionMapping that describes how to map     -- positions in a version of that document to positions in the latest version     -- First mapping is delta from previous version and second one is an@@ -210,7 +254,8 @@     ,ideTesting :: IdeTesting     -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants     ,restartShakeSession-        :: String+        :: VFSModified+        -> String         -> [DelayedAction ()]         -> IO ()     ,ideNc :: IORef NameCache@@ -226,8 +271,12 @@     , persistentKeys :: TVar (HMap.HashMap Key GetStalePersistent)       -- ^ Registery for functions that compute/get "stale" results for the rule       -- (possibly from disk)-      -- Small and immutable after startup, so not worth using an STM.Map.-    , vfs :: VFSHandle+    , vfsVar :: TVar VFS+    -- ^ A snapshot of the current state of the virtual file system. Updated on shakeRestart+    -- VFS state is managed by LSP. However, the state according to the lsp library may be newer than the state of the current session,+    -- leaving us vulnerable to suble race conditions. To avoid this, we take a snapshot of the state of the VFS on every+    -- restart, so that the whole session sees a single consistent view of the VFS.+    -- We don't need a STM.Map because we never update individual keys ourselves.     , defaultConfig :: Config       -- ^ Default HLS config, only relevant if the client does not provide any Config     , dirtyKeys :: TVar (HashSet Key)@@ -268,19 +317,18 @@  class Typeable a => IsIdeGlobal a where +-- | Read a virtual file from the current snapshot+getVirtualFile :: NormalizedFilePath -> Action (Maybe VirtualFile)+getVirtualFile nf = do+  vfs <- fmap vfsMap . liftIO . readTVarIO . vfsVar =<< getShakeExtras+  pure $! Map.lookup (filePathToUri' nf) vfs -- Don't leak a reference to the entire map --- | haskell-lsp manages the VFS internally and automatically so we cannot use--- the builtin VFS without spawning up an LSP server. To be able to test things--- like `setBufferModified` we abstract over the VFS implementation.-data VFSHandle = VFSHandle-    { getVirtualFile         :: NormalizedUri -> IO (Maybe VirtualFile)-        -- ^ get the contents of a virtual file-    , setVirtualFileContents :: Maybe (NormalizedUri -> Maybe T.Text -> IO ())-        -- ^ set a specific file to a value. If Nothing then we are ignoring these-        --   signals anyway so can just say something was modified-    }-instance IsIdeGlobal VFSHandle+-- Take a snapshot of the current LSP VFS+vfsSnapshot :: Maybe (LSP.LanguageContextEnv a) -> IO VFS+vfsSnapshot Nothing       = pure $ VFS mempty ""+vfsSnapshot (Just lspEnv) = LSP.runLspT lspEnv LSP.getVirtualFiles + addIdeGlobal :: IsIdeGlobal a => a -> Rules () addIdeGlobal x = do     extras <- getShakeExtrasRules@@ -292,7 +340,6 @@         Just _ -> error $ "Internal error, addIdeGlobalExtras, got the same type twice for " ++ show ty         Nothing -> HMap.insert ty (toDyn x) mp - getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a getIdeGlobalExtras ShakeExtras{globals} = do     let typ = typeRep (Proxy :: Proxy a)@@ -345,13 +392,18 @@             f <- MaybeT $ pure $ HMap.lookup (Key k) pmap             (dv,del,ver) <- MaybeT $ runIdeAction "lastValueIO" s $ f file             MaybeT $ pure $ (,del,ver) <$> fromDynamic dv-          atomicallyNamed "lastValueIO" $ case mv of-            Nothing -> do+          case mv of+            Nothing -> atomicallyNamed "lastValueIO 1" $ do                 STM.focus (Focus.alter (alterValue $ Failed True)) (toKey k file) state                 return Nothing             Just (v,del,ver) -> do-                STM.focus (Focus.alter (alterValue $ Stale (Just del) ver (toDyn v))) (toKey k file) state-                Just . (v,) . addDelta del <$> mappingForVersion positionMapping file ver+                actual_version <- case ver of+                  Just ver -> pure (Just $ VFSVersion ver)+                  Nothing -> (Just . ModificationTime <$> getModTime (fromNormalizedFilePath file))+                              `catch` (\(_ :: IOException) -> pure Nothing)+                atomicallyNamed "lastValueIO 2" $ do+                  STM.focus (Focus.alter (alterValue $ Stale (Just del) actual_version (toDyn v))) (toKey k file) state+                  Just . (v,) . addDelta del <$> mappingForVersion positionMapping file actual_version          -- We got a new stale value from the persistent rule, insert it in the map without affecting diagnostics         alterValue new Nothing = Just (ValueWithDiagnostics new mempty) -- If it wasn't in the map, give it empty diagnostics@@ -379,13 +431,14 @@     liftIO $ lastValueIO s key file  mappingForVersion-    :: STM.Map NormalizedUri (Map TextDocumentVersion (a, PositionMapping))+    :: STM.Map NormalizedUri (EnumMap Int32 (a, PositionMapping))     -> NormalizedFilePath-    -> TextDocumentVersion+    -> Maybe FileVersion     -> STM PositionMapping-mappingForVersion allMappings file ver = do+mappingForVersion allMappings file (Just (VFSVersion ver)) = do     mapping <- STM.lookup (filePathToUri' file) allMappings-    return $ maybe zeroMapping snd $ Map.lookup ver =<< mapping+    return $ maybe zeroMapping snd $ EM.lookup ver =<< mapping+mappingForVersion _ _ _ = pure zeroMapping  type IdeRule k v =   ( Shake.RuleResult k ~ v@@ -407,7 +460,6 @@ data IdeState = IdeState     {shakeDb              :: ShakeDatabase     ,shakeSession         :: MVar ShakeSession-    ,shakeClose           :: IO ()     ,shakeExtras          :: ShakeExtras     ,shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe FilePath)     }@@ -494,7 +546,8 @@     Failed _        -> val  -- | Open a 'IdeState', should be shut using 'shakeShut'.-shakeOpen :: Maybe (LSP.LanguageContextEnv Config)+shakeOpen :: Recorder (WithPriority Log)+          -> Maybe (LSP.LanguageContextEnv Config)           -> Config           -> Logger           -> Debouncer NormalizedUri@@ -503,12 +556,13 @@           -> IdeTesting           -> WithHieDb           -> IndexQueue-          -> VFSHandle           -> ShakeOptions           -> Rules ()           -> IO IdeState-shakeOpen lspEnv defaultConfig logger debouncer-  shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) withHieDb indexQueue vfs opts rules = mdo+shakeOpen recorder lspEnv defaultConfig logger debouncer+  shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) withHieDb indexQueue opts rules = mdo+    let log :: Logger.Priority -> Log -> IO ()+        log = logWith recorder      us <- mkSplitUniqSupply 'r'     ideNc <- newIORef (initNameCache us knownKeyNames)@@ -520,7 +574,7 @@         publishedDiagnostics <- STM.newIO         positionMapping <- STM.newIO         knownTargetsVar <- newTVarIO $ hashed HMap.empty-        let restartShakeSession = shakeRestart ideState+        let restartShakeSession = shakeRestart recorder ideState         persistentKeys <- newTVarIO HMap.empty         indexPending <- newTVarIO HMap.empty         indexCompleted <- newTVarIO 0@@ -528,11 +582,12 @@         let hiedbWriter = HieDbWriter{..}         exportsMap <- newTVarIO mempty         -- lazily initialize the exports map with the contents of the hiedb+        -- TODO: exceptions can be swallowed here?         _ <- async $ do-            logDebug logger "Initializing exports map from hiedb"+            log Debug LogCreateHieDbExportsMapStart             em <- createExportsMapHieDb withHieDb             atomically $ modifyTVar' exportsMap (<> em)-            logDebug logger $ "Done initializing exports map from hiedb (" <> pack(show (ExportsMap.size em)) <> ")"+            log Debug $ LogCreateHieDbExportsMapFinish (ExportsMap.size em)          progress <- do             let (before, after) = if testing then (0,0.1) else (0.1,0.1)@@ -544,12 +599,13 @@         let clientCapabilities = maybe def LSP.resClientCapabilities lspEnv          dirtyKeys <- newTVarIO mempty+        -- Take one VFS snapshot at the start+        vfsVar <- newTVarIO =<< vfsSnapshot lspEnv         pure ShakeExtras{..}-    (shakeDbM, shakeClose) <--        shakeOpenDatabase+    shakeDb  <-+        shakeNewDatabase             opts { shakeExtra = newShakeExtra shakeExtras }             rules-    shakeDb <- shakeDbM     shakeSession <- newEmptyMVar     shakeDatabaseProfile <- shakeDatabaseProfileIO shakeProfileDir     let ideState = IdeState{..}@@ -584,9 +640,12 @@   -- | Must be called in the 'Initialized' handler and only once-shakeSessionInit :: IdeState -> IO ()-shakeSessionInit ide@IdeState{..} = do-    initSession <- newSession shakeExtras shakeDb [] "shakeSessionInit"+shakeSessionInit :: Recorder (WithPriority Log) -> IdeState -> IO ()+shakeSessionInit recorder ide@IdeState{..} = do+    -- Take a snapshot of the VFS - it should be empty as we've recieved no notifications+    -- till now, but it can't hurt to be in sync with the `lsp` library.+    vfs <- vfsSnapshot (lspEnv shakeExtras)+    initSession <- newSession recorder shakeExtras (VFSModified vfs) shakeDb [] "shakeSessionInit"     putMVar shakeSession initSession     logDebug (ideLogger ide) "Shake session initialized" @@ -597,7 +656,6 @@     -- request so we first abort that.     for_ runner cancelShakeSession     void $ shakeDatabaseProfile shakeDb-    shakeClose     progressStop $ progress shakeExtras  @@ -626,31 +684,40 @@ -- | Restart the current 'ShakeSession' with the given system actions. --   Any actions running in the current session will be aborted, --   but actions added via 'shakeEnqueue' will be requeued.-shakeRestart :: IdeState -> String -> [DelayedAction ()] -> IO ()-shakeRestart IdeState{..} reason acts =+shakeRestart :: Recorder (WithPriority Log) -> IdeState -> VFSModified -> String -> [DelayedAction ()] -> IO ()+shakeRestart recorder IdeState{..} vfs reason acts =     withMVar'         shakeSession         (\runner -> do-              (stopTime,()) <- duration (cancelShakeSession runner)+              let log = logWith recorder+              (stopTime,()) <- duration $ logErrorAfter 10 recorder $ cancelShakeSession runner               res <- shakeDatabaseProfile shakeDb               backlog <- readTVarIO $ dirtyKeys shakeExtras               queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras++              log Debug $ LogBuildSessionRestart reason queue backlog stopTime res+               let profile = case res of                       Just fp -> ", profile saved at " <> fp                       _       -> ""+              -- TODO: should replace with logging using a logger that sends lsp message               let msg = T.pack $ "Restarting build session " ++ reason' ++ queueMsg ++ keysMsg ++ abortMsg                   reason' = "due to " ++ reason                   queueMsg = " with queue " ++ show (map actionName queue)                   keysMsg = " for keys " ++ show (HSet.toList backlog) ++ " "                   abortMsg = "(aborting the previous one took " ++ showDuration stopTime ++ profile ++ ")"-              logDebug (logger shakeExtras) msg               notifyTestingLogMessage shakeExtras msg         )         -- It is crucial to be masked here, otherwise we can get killed         -- between spawning the new thread and updating shakeSession.         -- See https://github.com/haskell/ghcide/issues/79         (\() -> do-          (,()) <$> newSession shakeExtras shakeDb acts reason)+          (,()) <$> newSession recorder shakeExtras vfs shakeDb acts reason)+    where+        logErrorAfter :: Seconds -> Recorder (WithPriority Log) -> IO () -> IO ()+        logErrorAfter seconds recorder action = flip withAsync (const action) $ do+            sleep seconds+            logWith recorder Error (LogBuildSessionRestartTakingTooLong seconds)  notifyTestingLogMessage :: ShakeExtras -> T.Text -> IO () notifyTestingLogMessage extras msg = do@@ -681,15 +748,25 @@               ]     return (wait' b >>= either throwIO return) +data VFSModified = VFSUnmodified | VFSModified !VFS+ -- | Set up a new 'ShakeSession' with a set of initial actions --   Will crash if there is an existing 'ShakeSession' running. newSession-    :: ShakeExtras+    :: Recorder (WithPriority Log)+    -> ShakeExtras+    -> VFSModified     -> ShakeDatabase     -> [DelayedActionInternal]     -> String     -> IO ShakeSession-newSession extras@ShakeExtras{..} shakeDb acts reason = do+newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reason = do++    -- Take a new VFS snapshot+    case vfsMod of+      VFSUnmodified -> pure ()+      VFSModified vfs -> atomically $ writeTVar vfsVar vfs+     IdeOptions{optRunSubset} <- getIdeOptionsIO extras     reenqueued <- atomicallyNamed "actionQueue - peek" $ peekInProgress actionQueue     allPendingKeys <-@@ -709,10 +786,7 @@             getAction d             liftIO $ atomicallyNamed "actionQueue - done" $ doneQueue d actionQueue             runTime <- liftIO start-            let msg = T.pack $ "finish: " ++ actionName d-                            ++ " (took " ++ showDuration runTime ++ ")"-            liftIO $ do-                logPriority logger (actionPriority d) msg+            logWith recorder (actionPriority d) $ LogDelayedAction d runTime          -- The inferred type signature doesn't work in ghc >= 9.0.1         workRun :: (forall b. IO b -> IO b) -> IO (IO ())@@ -728,7 +802,11 @@                       Right _ -> "completed"           let msg = T.pack $ "Finishing build session(" ++ res' ++ ")"           return $ do-              logDebug logger msg+              let exception =+                    case res of+                      Left e -> Just e+                      _      -> Nothing+              logWith recorder Debug $ LogBuildSessionFinish exception               notifyTestingLogMessage extras msg      -- Do the work in a background thread@@ -736,6 +814,7 @@      -- run the wrap up in a separate thread since it contains interruptible     -- commands (and we are not using uninterruptible mask)+    -- TODO: can possibly swallow exceptions?     _ <- async $ join $ wait workThread      --  Cancelling is required to flush the Shake database when either@@ -843,13 +922,13 @@ -- | Define a new Rule without early cutoff define     :: IdeRule k v-    => (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()-define op = defineEarlyCutoff $ Rule $ \k v -> (Nothing,) <$> op k v+    => Recorder (WithPriority Log) -> (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()+define recorder op = defineEarlyCutoff recorder $ Rule $ \k v -> (Nothing,) <$> op k v  defineNoDiagnostics     :: IdeRule k v-    => (k -> NormalizedFilePath -> Action (Maybe v)) -> Rules ()-defineNoDiagnostics op = defineEarlyCutoff $ RuleNoDiagnostics $ \k v -> (Nothing,) <$> op k v+    => Recorder (WithPriority Log) -> (k -> NormalizedFilePath -> Action (Maybe v)) -> Rules ()+defineNoDiagnostics recorder op = defineEarlyCutoff recorder $ RuleNoDiagnostics $ \k v -> (Nothing,) <$> op k v  -- | Request a Rule result if available use :: IdeRule k v@@ -960,6 +1039,11 @@     -- whether the rule succeeded or not.     mapM (lastValue key) files +useWithoutDependency :: IdeRule k v+    => k -> NormalizedFilePath -> Action (Maybe v)+useWithoutDependency key file =+    (\[A value] -> currentValue value) <$> applyWithoutDependency [Q (key, file)]+ data RuleBody k v   = Rule (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v))   | RuleNoDiagnostics (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe v))@@ -967,54 +1051,60 @@     { newnessCheck :: BS.ByteString -> BS.ByteString -> Bool     , build :: k -> NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe v)     }+  | RuleWithOldValue (k -> NormalizedFilePath -> Value v -> Action (Maybe BS.ByteString, IdeResult v))  -- | Define a new Rule with early cutoff defineEarlyCutoff     :: IdeRule k v-    => RuleBody k v+    => Recorder (WithPriority Log)+    -> RuleBody k v     -> Rules ()-defineEarlyCutoff (Rule op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ \traceDiagnostics -> do+defineEarlyCutoff recorder (Rule op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ \traceDiagnostics -> do     extras <- getShakeExtras-    let diagnostics diags = do+    let diagnostics ver diags = do             traceDiagnostics diags-            updateFileDiagnostics file (Key key) extras . map (\(_,y,z) -> (y,z)) $ diags-    defineEarlyCutoff' diagnostics (==) key file old mode $ op key file-defineEarlyCutoff (RuleNoDiagnostics op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ \traceDiagnostics -> do-    ShakeExtras{logger} <- getShakeExtras-    let diagnostics diags = do+            updateFileDiagnostics recorder file ver (Key key) extras . map (\(_,y,z) -> (y,z)) $ diags+    defineEarlyCutoff' diagnostics (==) key file old mode $ const $ op key file+defineEarlyCutoff recorder (RuleNoDiagnostics op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ \traceDiagnostics -> do+    let diagnostics _ver diags = do             traceDiagnostics diags-            mapM_ (\d -> liftIO $ logWarning logger $ showDiagnosticsColored [d]) diags-    defineEarlyCutoff' diagnostics (==) key file old mode $ second (mempty,) <$> op key file-defineEarlyCutoff RuleWithCustomNewnessCheck{..} =+            mapM_ (logWith recorder Warning . LogDefineEarlyCutoffRuleNoDiagHasDiag) diags+    defineEarlyCutoff' diagnostics (==) key file old mode $ const $ second (mempty,) <$> op key file+defineEarlyCutoff recorder RuleWithCustomNewnessCheck{..} =     addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode ->         otTracedAction key file mode traceA $ \ traceDiagnostics -> do-            ShakeExtras{logger} <- getShakeExtras-            let diagnostics diags = do-                    mapM_ (\d -> liftIO $ logWarning logger $ showDiagnosticsColored [d]) diags+            let diagnostics _ver diags = do                     traceDiagnostics diags+                    mapM_ (logWith recorder Warning . LogDefineEarlyCutoffRuleCustomNewnessHasDiag) diags             defineEarlyCutoff' diagnostics newnessCheck key file old mode $-                second (mempty,) <$> build key file+                const $ second (mempty,) <$> build key file+defineEarlyCutoff recorder (RuleWithOldValue op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ \traceDiagnostics -> do+    extras <- getShakeExtras+    let diagnostics ver diags = do+            traceDiagnostics diags+            updateFileDiagnostics recorder file ver (Key key) extras . map (\(_,y,z) -> (y,z)) $ diags+    defineEarlyCutoff' diagnostics (==) key file old mode $ op key file -defineNoFile :: IdeRule k v => (k -> Action v) -> Rules ()-defineNoFile f = defineNoDiagnostics $ \k file -> do+defineNoFile :: IdeRule k v => Recorder (WithPriority Log) -> (k -> Action v) -> Rules ()+defineNoFile recorder f = defineNoDiagnostics recorder $ \k file -> do     if file == emptyFilePath then do res <- f k; return (Just res) else         fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file" -defineEarlyCutOffNoFile :: IdeRule k v => (k -> Action (BS.ByteString, v)) -> Rules ()-defineEarlyCutOffNoFile f = defineEarlyCutoff $ RuleNoDiagnostics $ \k file -> do+defineEarlyCutOffNoFile :: IdeRule k v => Recorder (WithPriority Log) -> (k -> Action (BS.ByteString, v)) -> Rules ()+defineEarlyCutOffNoFile recorder f = defineEarlyCutoff recorder $ RuleNoDiagnostics $ \k file -> do     if file == emptyFilePath then do (hash, res) <- f k; return (Just hash, Just res) else         fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file"  defineEarlyCutoff'-    :: IdeRule k v-    => ([FileDiagnostic] -> Action ()) -- ^ update diagnostics+    :: forall k v. IdeRule k v+    => (TextDocumentVersion -> [FileDiagnostic] -> Action ()) -- ^ update diagnostics     -- | compare current and previous for freshness     -> (BS.ByteString -> BS.ByteString -> Bool)     -> k     -> NormalizedFilePath     -> Maybe BS.ByteString     -> RunMode-    -> Action (Maybe BS.ByteString, IdeResult v)+    -> (Value v -> Action (Maybe BS.ByteString, IdeResult v))     -> Action (RunResult (A (RuleResult k))) defineEarlyCutoff' doDiagnostics cmp key file old mode action = do     ShakeExtras{state, progress, dirtyKeys} <- getShakeExtras@@ -1026,8 +1116,9 @@                 case v of                     -- No changes in the dependencies and we have                     -- an existing successful result.-                    Just (v@Succeeded{}, diags) -> do-                        doDiagnostics $ Vector.toList diags+                    Just (v@(Succeeded _ x), diags) -> do+                        ver <- estimateFileVersionUnsafely key (Just x) file+                        doDiagnostics (vfsVersion =<< ver) $ Vector.toList diags                         return $ Just $ RunResult ChangedNothing old $ A v                     _ -> return Nothing             _ ->@@ -1037,26 +1128,23 @@         res <- case val of             Just res -> return res             Nothing -> do+                staleV <- liftIO $ atomicallyNamed "define -read 3" $ getValues state key file <&> \case+                    Nothing                   -> Failed False+                    Just (Succeeded ver v, _) -> Stale Nothing ver v+                    Just (Stale d ver v, _)   -> Stale d ver v+                    Just (Failed b, _)        -> Failed b                 (bs, (diags, res)) <- actionCatch-                    (do v <- action; liftIO $ evaluate $ force v) $+                    (do v <- action staleV; liftIO $ evaluate $ force v) $                     \(e :: SomeException) -> do                         pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))-                modTime <- liftIO $ (currentValue . fst =<<) <$> atomicallyNamed "define - read 2" (getValues state GetModificationTime file)++                ver <- estimateFileVersionUnsafely key res file                 (bs, res) <- case res of                     Nothing -> do-                        staleV <- liftIO $ atomicallyNamed "define -read 3" $ getValues state key file-                        pure $ case staleV of-                            Nothing -> (toShakeValue ShakeResult bs, Failed False)-                            Just v -> case v of-                                (Succeeded ver v, _) ->-                                    (toShakeValue ShakeStale bs, Stale Nothing ver v)-                                (Stale d ver v, _) ->-                                    (toShakeValue ShakeStale bs, Stale d ver v)-                                (Failed b, _) ->-                                    (toShakeValue ShakeResult bs, Failed b)-                    Just v -> pure (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v)+                        pure (toShakeValue ShakeStale bs, staleV)+                    Just v -> pure (maybe ShakeNoCutoff ShakeResult bs, Succeeded ver v)                 liftIO $ atomicallyNamed "define - write" $ setValues state key file res (Vector.fromList diags)-                doDiagnostics diags+                doDiagnostics (vfsVersion =<< ver) diags                 let eq = case (bs, fmap decodeShakeValue old) of                         (ShakeResult a, Just (ShakeResult b)) -> cmp a b                         (ShakeStale a, Just (ShakeStale b))   -> cmp a b@@ -1069,115 +1157,73 @@                     A res         liftIO $ atomicallyNamed "define - dirtyKeys" $ modifyTVar' dirtyKeys (HSet.delete $ toKey key file)         return res+  where+    -- Highly unsafe helper to compute the version of a file+    -- without creating a dependency on the GetModificationTime rule+    -- (and without creating cycles in the build graph).+    estimateFileVersionUnsafely+        :: forall k v+         . IdeRule k v+        => k+        -> Maybe v+        -> NormalizedFilePath+        -> Action (Maybe FileVersion)+    estimateFileVersionUnsafely _k v fp+        | fp == emptyFilePath = pure Nothing+        | Just Refl <- eqT @k @GetModificationTime = pure v+        -- GetModificationTime depends on these rules, so avoid creating a cycle+        | Just Refl <- eqT @k @AddWatchedFile = pure Nothing+        | Just Refl <- eqT @k @IsFileOfInterest = pure Nothing+        -- GetFileExists gets called for missing files+        | Just Refl <- eqT @k @GetFileExists = pure Nothing+        -- For all other rules - compute the version properly without:+        --  * creating a dependency: If everything depends on GetModificationTime, we lose early cutoff+        --  * creating bogus "file does not exists" diagnostics+        | otherwise = useWithoutDependency (GetModificationTime_ False) fp  traceA :: A v -> String traceA (A Failed{})    = "Failed" traceA (A Stale{})     = "Stale" traceA (A Succeeded{}) = "Success" --- | Rule type, input file-data QDisk k = QDisk k NormalizedFilePath-  deriving (Eq, Generic)--instance Hashable k => Hashable (QDisk k)--instance NFData k => NFData (QDisk k)--instance Show k => Show (QDisk k) where-    show (QDisk k file) =-        show k ++ "; " ++ fromNormalizedFilePath file--type instance RuleResult (QDisk k) = Bool--data OnDiskRule = OnDiskRule-  { getHash :: Action BS.ByteString-  -- This is used to figure out if the state on disk corresponds to the state in the Shake-  -- database and we can therefore avoid rerunning. Often this can just be the file hash but-  -- in some cases we can be more aggressive, e.g., for GHC interface files this can be the ABI hash which-  -- is more stable than the hash of the interface file.-  -- An empty bytestring indicates that the state on disk is invalid, e.g., files are missing.-  -- We do not use a Maybe since we have to deal with encoding things into a ByteString anyway in the Shake DB.-  , runRule :: Action (IdeResult BS.ByteString)-  -- The actual rule code which produces the new hash (or Nothing if the rule failed) and the diagnostics.-  }---- This is used by the DAML compiler for incremental builds. Right now this is not used by--- ghcide itself but that might change in the future.--- The reason why this code lives in ghcide and in particular in this module is that it depends quite heavily on--- the internals of this module that we do not want to expose.-defineOnDisk-  :: (Shake.ShakeValue k, RuleResult k ~ ())-  => (k -> NormalizedFilePath -> OnDiskRule)-  -> Rules ()-defineOnDisk act = addRule $-  \(QDisk key file) (mbOld :: Maybe BS.ByteString) mode -> do-      extras <- getShakeExtras-      let OnDiskRule{..} = act key file-      let validateHash h-              | BS.null h = Nothing-              | otherwise = Just h-      let runAct = actionCatch runRule $-              \(e :: SomeException) -> pure ([ideErrorText file $ T.pack $ displayException e | not $ isBadDependency e], Nothing)-      case mbOld of-          Nothing -> do-              (diags, mbHash) <- runAct-              updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags-              pure $ RunResult ChangedRecomputeDiff (fromMaybe "" mbHash) (isJust mbHash)-          Just old -> do-              current <- validateHash <$> (actionCatch getHash $ \(_ :: SomeException) -> pure "")-              if mode == RunDependenciesSame && Just old == current && not (BS.null old)-                  then-                    -- None of our dependencies changed, we’ve had a successful run before and-                    -- the state on disk matches the state in the Shake database.-                    pure $ RunResult ChangedNothing (fromMaybe "" current) (isJust current)-                  else do-                    (diags, mbHash) <- runAct-                    updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags-                    let change-                          | mbHash == Just old = ChangedRecomputeSame-                          | otherwise = ChangedRecomputeDiff-                    pure $ RunResult change (fromMaybe "" mbHash) (isJust mbHash)--needOnDisk :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> NormalizedFilePath -> Action ()-needOnDisk k file = do-    successfull <- apply1 (QDisk k file)-    liftIO $ unless successfull $ throwIO $ BadDependency (show k)--needOnDisks :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> [NormalizedFilePath] -> Action ()-needOnDisks k files = do-    successfulls <- apply $ map (QDisk k) files-    liftIO $ unless (and successfulls) $ throwIO $ BadDependency (show k)- updateFileDiagnostics :: MonadIO m-  => NormalizedFilePath+  => Recorder (WithPriority Log)+  -> NormalizedFilePath+  -> TextDocumentVersion   -> Key   -> ShakeExtras   -> [(ShowDiagnostic,Diagnostic)] -- ^ current results   -> m ()-updateFileDiagnostics fp k ShakeExtras{logger, diagnostics, hiddenDiagnostics, publishedDiagnostics, state, debouncer, lspEnv} current = liftIO $ do-    modTime <- (currentValue . fst =<<) <$> atomicallyNamed "diagnostics - read" (getValues state GetModificationTime fp)+updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, debouncer, lspEnv} current =+  liftIO $ withTrace ("update diagnostics " <> fromString(fromNormalizedFilePath fp)) $ \ addTag -> do+    addTag "key" (show k)     let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current         uri = filePathToUri' fp-        ver = vfsVersion =<< modTime-        update new store = setStageDiagnostics uri ver (T.pack $ show k) new store+        addTagUnsafe :: String -> String -> String -> a -> a+        addTagUnsafe msg t x v = unsafePerformIO(addTag (msg <> t) x) `seq` v+        update :: (forall a. String -> String -> a -> a) -> [Diagnostic] -> STMDiagnosticStore -> STM [Diagnostic]+        update addTagUnsafe new store = addTagUnsafe "count" (show $ Prelude.length new) $ setStageDiagnostics addTagUnsafe uri ver (T.pack $ show k) new store+    addTag "version" (show ver)     mask_ $ do         -- Mask async exceptions to ensure that updated diagnostics are always         -- published. Otherwise, we might never publish certain diagnostics if         -- an exception strikes between modifyVar but before         -- publishDiagnosticsNotification.-        newDiags <- liftIO $ atomicallyNamed "diagnostics - update" $ update (map snd currentShown) diagnostics-        _ <- liftIO $ atomicallyNamed "diagnostics - hidden" $ update (map snd currentHidden) hiddenDiagnostics+        newDiags <- liftIO $ atomicallyNamed "diagnostics - update" $ update (addTagUnsafe "shown ") (map snd currentShown) diagnostics+        _ <- liftIO $ atomicallyNamed "diagnostics - hidden" $ update (addTagUnsafe "hidden ") (map snd currentHidden) hiddenDiagnostics         let uri = filePathToUri' fp         let delay = if null newDiags then 0.1 else 0-        registerEvent debouncer delay uri $ do+        registerEvent debouncer delay uri $ withTrace ("report diagnostics " <> fromString (fromNormalizedFilePath fp)) $ \tag -> do              join $ mask_ $ do                  lastPublish <- atomicallyNamed "diagnostics - publish" $ STM.focus (Focus.lookupWithDefault [] <* Focus.insert newDiags) uri publishedDiagnostics                  let action = when (lastPublish /= newDiags) $ case lspEnv of                         Nothing -> -- Print an LSP event.-                            logInfo logger $ showDiagnosticsColored $ map (fp,ShowDiag,) newDiags-                        Just env -> LSP.runLspT env $+                            logWith recorder Info $ LogDiagsDiffButNoLspEnv (map (fp, ShowDiag,) newDiags)+                        Just env -> LSP.runLspT env $ do+                            liftIO $ tag "count" (show $ Prelude.length newDiags)+                            liftIO $ tag "key" (show k)                             LSP.sendNotification LSP.STextDocumentPublishDiagnostics $-                            LSP.PublishDiagnosticsParams (fromNormalizedUri uri) (fmap fromIntegral ver) (List newDiags)+                                LSP.PublishDiagnosticsParams (fromNormalizedUri uri) (fmap fromIntegral ver) (List newDiags)                  return action  newtype Priority = Priority Double@@ -1199,28 +1245,35 @@ getDiagnosticsFromStore :: StoreItem -> [Diagnostic] getDiagnosticsFromStore (StoreItem _ diags) = concatMap SL.fromSortedList $ Map.elems diags -updateSTMDiagnostics :: STMDiagnosticStore-                  -> NormalizedUri -> TextDocumentVersion -> DiagnosticsBySource-                  -> STM [LSP.Diagnostic]-updateSTMDiagnostics store uri mv newDiagsBySource =+updateSTMDiagnostics ::+  (forall a. String -> String -> a -> a) ->+  STMDiagnosticStore ->+  NormalizedUri ->+  TextDocumentVersion ->+  DiagnosticsBySource ->+  STM [LSP.Diagnostic]+updateSTMDiagnostics addTag store uri mv newDiagsBySource =     getDiagnosticsFromStore . fromJust <$> STM.focus (Focus.alter update *> Focus.lookup) uri store   where     update (Just(StoreItem mvs dbs))+      | addTag "previous version" (show mvs) $+        addTag "previous count" (show $ Prelude.length $ filter (not.null) $ Map.elems dbs) False = undefined       | mvs == mv = Just (StoreItem mv (newDiagsBySource <> dbs))     update _ = Just (StoreItem mv newDiagsBySource)  -- | Sets the diagnostics for a file and compilation step --   if you want to clear the diagnostics call this with an empty list setStageDiagnostics-    :: NormalizedUri+    :: (forall a. String -> String -> a -> a)+    -> NormalizedUri     -> TextDocumentVersion -- ^ the time that the file these diagnostics originate from was last edited     -> T.Text     -> [LSP.Diagnostic]     -> STMDiagnosticStore     -> STM [LSP.Diagnostic]-setStageDiagnostics uri ver stage diags ds = updateSTMDiagnostics ds uri ver updatedDiags+setStageDiagnostics addTag uri ver stage diags ds = updateSTMDiagnostics addTag ds uri ver updatedDiags   where-    updatedDiags = Map.singleton (Just stage) (SL.toSortedList diags)+    !updatedDiags = Map.singleton (Just stage) $! SL.toSortedList diags  getAllDiagnostics ::     STMDiagnosticStore ->@@ -1238,7 +1291,10 @@                 -- Very important to use mapAccum here so that the tails of                 -- each mapping can be shared, otherwise quadratic space is                 -- used which is evident in long running sessions.-                Map.mapAccumRWithKey (\acc _k (delta, _) -> let new = addDelta delta acc in (new, (delta, acc)))+                EM.mapAccumRWithKey (\acc _k (delta, _) -> let new = addDelta delta acc in (new, (delta, acc)))                   zeroMapping-                  (Map.insert _version (shared_change, zeroMapping) mappingForUri)+                  (EM.insert actual_version (shared_change, zeroMapping) mappingForUri)         shared_change = mkDelta changes+        actual_version = case _version of+          Nothing -> error "Nothing version from server" -- This is a violation of the spec+          Just v  -> v

@@ -1,162 +1,162 @@-{-# LANGUAGE DerivingVia    #-}
-{-# LANGUAGE GADTs          #-}
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE RankNTypes     #-}
-
-module Development.IDE.Core.UseStale
-  ( Age(..)
-  , Tracked
-  , unTrack
-  , PositionMap
-  , TrackedStale (..)
-  , untrackedStaleValue
-  , unsafeMkStale
-  , unsafeMkCurrent
-  , unsafeCopyAge
-  , MapAge (..)
-  , dualPositionMap
-  , useWithStale
-  , useWithStale_
-  ) where
-
-import           Control.Arrow
-import           Control.Category                     (Category)
-import qualified Control.Category                     as C
-import           Control.DeepSeq                      (NFData)
-import           Data.Aeson
-import           Data.Coerce                          (coerce)
-import           Data.Functor                         ((<&>))
-import           Data.Functor.Identity                (Identity (Identity))
-import           Data.Kind                            (Type)
-import           Data.String                          (fromString)
-import           Development.IDE                      (Action, IdeRule,
-                                                       NormalizedFilePath,
-                                                       Range,
-                                                       rangeToRealSrcSpan,
-                                                       realSrcSpanToRange)
-import qualified Development.IDE.Core.PositionMapping as P
-import qualified Development.IDE.Core.Shake           as IDE
-import           Development.IDE.GHC.Compat           (RealSrcSpan, srcSpanFile)
-import           Development.IDE.GHC.Compat.Util      (unpackFS)
-
-
-------------------------------------------------------------------------------
--- | A data kind for 'Tracked'.
-data Age = Current | Stale Type
-
-
-------------------------------------------------------------------------------
--- | Some value, tagged with its age. All 'Current' ages are considered to be
--- the same thing, but 'Stale' values are protected by an untouchable variable
--- to ensure they can't be unified.
-newtype Tracked (age :: Age) a  = UnsafeTracked
-  { unTrack :: a
-  }
-  deriving stock (Functor, Foldable, Traversable)
-  deriving newtype (Eq, Ord, Show, Read, ToJSON, FromJSON, NFData)
-  deriving (Applicative, Monad) via Identity
-
-
-------------------------------------------------------------------------------
--- | Like 'P.PositionMapping', but with annotated ages for how 'Tracked' values
--- change. Use the 'Category' instance to compose 'PositionMapping's in order
--- to transform between values of different stale ages.
-newtype PositionMap (from :: Age) (to :: Age) = PositionMap
-  { _getPositionMapping :: P.PositionMapping
-  }
-
-instance Category PositionMap where
-  id  = coerce P.zeroMapping
-  (.) = coerce P.composeDelta
-
-
-------------------------------------------------------------------------------
--- | Get a 'PositionMap' that runs in the opposite direction.
-dualPositionMap :: PositionMap from to -> PositionMap to from
-dualPositionMap (PositionMap (P.PositionMapping (P.PositionDelta from to))) =
-  PositionMap $ P.PositionMapping $ P.PositionDelta to from
-
-
-------------------------------------------------------------------------------
--- | A pair containing a @'Tracked' 'Stale'@ value, as well as
--- a 'PositionMapping' that will fast-forward values to the current age.
-data TrackedStale a where
-  TrackedStale
-      :: Tracked (Stale s) a
-      -> PositionMap (Stale s) Current
-      -> TrackedStale a
-
-instance Functor TrackedStale where
-  fmap f (TrackedStale t pm) = TrackedStale (fmap f t) pm
-
-
-untrackedStaleValue :: TrackedStale a -> a
-untrackedStaleValue (TrackedStale ta _) = coerce ta
-
-
-------------------------------------------------------------------------------
--- | A class for which 'Tracked' values can be run across a 'PositionMapping'
--- to change their ages.
-class MapAge a where
-  {-# MINIMAL mapAgeFrom | mapAgeTo #-}
-  mapAgeFrom :: PositionMap from to -> Tracked to   a -> Maybe (Tracked from a)
-  mapAgeFrom = mapAgeTo . dualPositionMap
-
-  mapAgeTo   :: PositionMap from to -> Tracked from a -> Maybe (Tracked to   a)
-  mapAgeTo = mapAgeFrom . dualPositionMap
-
-
-instance MapAge Range where
-  mapAgeFrom = coerce P.fromCurrentRange
-  mapAgeTo   = coerce P.toCurrentRange
-
-
-instance MapAge RealSrcSpan where
-  mapAgeFrom =
-    invMapAge (\fs -> rangeToRealSrcSpan (fromString $ unpackFS fs))
-              (srcSpanFile &&& realSrcSpanToRange)
-      .  mapAgeFrom
-
-
-------------------------------------------------------------------------------
--- | Helper function for deriving 'MapAge' for values in terms of other
--- instances.
-invMapAge
-    :: (c -> a -> b)
-    -> (b -> (c, a))
-    -> (Tracked from a -> Maybe (Tracked to a))
-    -> Tracked from b
-    -> Maybe (Tracked to b)
-invMapAge to from f t =
-  let (c, t') = unTrack $ fmap from t
-   in fmap (fmap $ to c) $ f $ UnsafeTracked t'
-
-
-unsafeMkCurrent :: age ->  Tracked 'Current age
-unsafeMkCurrent = coerce
-
-
-unsafeMkStale :: age -> Tracked (Stale s) age
-unsafeMkStale = coerce
-
-
-unsafeCopyAge :: Tracked age a -> b -> Tracked age b
-unsafeCopyAge _ = coerce
-
-
--- | Request a Rule result, it not available return the last computed result, if any, which may be stale
-useWithStale :: IdeRule k v
-    => k -> NormalizedFilePath -> Action (Maybe (TrackedStale v))
-useWithStale key file = do
-  x <- IDE.useWithStale key file
-  pure $ x <&> \(v, pm) ->
-    TrackedStale (coerce v) (coerce pm)
-
--- | Request a Rule result, it not available return the last computed result which may be stale.
---   Errors out if none available.
-useWithStale_ :: IdeRule k v
-    => k -> NormalizedFilePath -> Action (TrackedStale v)
-useWithStale_ key file = do
-  (v, pm) <- IDE.useWithStale_ key file
-  pure $ TrackedStale (coerce v) (coerce pm)
-
+{-# LANGUAGE DerivingVia    #-}+{-# LANGUAGE GADTs          #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RankNTypes     #-}++module Development.IDE.Core.UseStale+  ( Age(..)+  , Tracked+  , unTrack+  , PositionMap+  , TrackedStale (..)+  , untrackedStaleValue+  , unsafeMkStale+  , unsafeMkCurrent+  , unsafeCopyAge+  , MapAge (..)+  , dualPositionMap+  , useWithStale+  , useWithStale_+  ) where++import           Control.Arrow+import           Control.Category                     (Category)+import qualified Control.Category                     as C+import           Control.DeepSeq                      (NFData)+import           Data.Aeson+import           Data.Coerce                          (coerce)+import           Data.Functor                         ((<&>))+import           Data.Functor.Identity                (Identity (Identity))+import           Data.Kind                            (Type)+import           Data.String                          (fromString)+import           Development.IDE                      (Action, IdeRule,+                                                       NormalizedFilePath,+                                                       Range,+                                                       rangeToRealSrcSpan,+                                                       realSrcSpanToRange)+import qualified Development.IDE.Core.PositionMapping as P+import qualified Development.IDE.Core.Shake           as IDE+import           Development.IDE.GHC.Compat           (RealSrcSpan, srcSpanFile)+import           Development.IDE.GHC.Compat.Util      (unpackFS)+++------------------------------------------------------------------------------+-- | A data kind for 'Tracked'.+data Age = Current | Stale Type+++------------------------------------------------------------------------------+-- | Some value, tagged with its age. All 'Current' ages are considered to be+-- the same thing, but 'Stale' values are protected by an untouchable variable+-- to ensure they can't be unified.+newtype Tracked (age :: Age) a  = UnsafeTracked+  { unTrack :: a+  }+  deriving stock (Functor, Foldable, Traversable)+  deriving newtype (Eq, Ord, Show, Read, ToJSON, FromJSON, NFData)+  deriving (Applicative, Monad) via Identity+++------------------------------------------------------------------------------+-- | Like 'P.PositionMapping', but with annotated ages for how 'Tracked' values+-- change. Use the 'Category' instance to compose 'PositionMapping's in order+-- to transform between values of different stale ages.+newtype PositionMap (from :: Age) (to :: Age) = PositionMap+  { _getPositionMapping :: P.PositionMapping+  }++instance Category PositionMap where+  id  = coerce P.zeroMapping+  (.) = coerce P.composeDelta+++------------------------------------------------------------------------------+-- | Get a 'PositionMap' that runs in the opposite direction.+dualPositionMap :: PositionMap from to -> PositionMap to from+dualPositionMap (PositionMap (P.PositionMapping (P.PositionDelta from to))) =+  PositionMap $ P.PositionMapping $ P.PositionDelta to from+++------------------------------------------------------------------------------+-- | A pair containing a @'Tracked' 'Stale'@ value, as well as+-- a 'PositionMapping' that will fast-forward values to the current age.+data TrackedStale a where+  TrackedStale+      :: Tracked (Stale s) a+      -> PositionMap (Stale s) Current+      -> TrackedStale a++instance Functor TrackedStale where+  fmap f (TrackedStale t pm) = TrackedStale (fmap f t) pm+++untrackedStaleValue :: TrackedStale a -> a+untrackedStaleValue (TrackedStale ta _) = coerce ta+++------------------------------------------------------------------------------+-- | A class for which 'Tracked' values can be run across a 'PositionMapping'+-- to change their ages.+class MapAge a where+  {-# MINIMAL mapAgeFrom | mapAgeTo #-}+  mapAgeFrom :: PositionMap from to -> Tracked to   a -> Maybe (Tracked from a)+  mapAgeFrom = mapAgeTo . dualPositionMap++  mapAgeTo   :: PositionMap from to -> Tracked from a -> Maybe (Tracked to   a)+  mapAgeTo = mapAgeFrom . dualPositionMap+++instance MapAge Range where+  mapAgeFrom = coerce P.fromCurrentRange+  mapAgeTo   = coerce P.toCurrentRange+++instance MapAge RealSrcSpan where+  mapAgeFrom =+    invMapAge (\fs -> rangeToRealSrcSpan (fromString $ unpackFS fs))+              (srcSpanFile &&& realSrcSpanToRange)+      .  mapAgeFrom+++------------------------------------------------------------------------------+-- | Helper function for deriving 'MapAge' for values in terms of other+-- instances.+invMapAge+    :: (c -> a -> b)+    -> (b -> (c, a))+    -> (Tracked from a -> Maybe (Tracked to a))+    -> Tracked from b+    -> Maybe (Tracked to b)+invMapAge to from f t =+  let (c, t') = unTrack $ fmap from t+   in fmap (fmap $ to c) $ f $ UnsafeTracked t'+++unsafeMkCurrent :: age ->  Tracked 'Current age+unsafeMkCurrent = coerce+++unsafeMkStale :: age -> Tracked (Stale s) age+unsafeMkStale = coerce+++unsafeCopyAge :: Tracked age a -> b -> Tracked age b+unsafeCopyAge _ = coerce+++-- | Request a Rule result, it not available return the last computed result, if any, which may be stale+useWithStale :: IdeRule k v+    => k -> NormalizedFilePath -> Action (Maybe (TrackedStale v))+useWithStale key file = do+  x <- IDE.useWithStale key file+  pure $ x <&> \(v, pm) ->+    TrackedStale (coerce v) (coerce pm)++-- | Request a Rule result, it not available return the last computed result which may be stale.+--   Errors out if none available.+useWithStale_ :: IdeRule k v+    => k -> NormalizedFilePath -> Action (TrackedStale v)+useWithStale_ key file = do+  (v, pm) <- IDE.useWithStale_ key file+  pure $ TrackedStale (coerce v) (coerce pm)+

@@ -1,63 +1,63 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.
--- SPDX-License-Identifier: Apache-2.0
-
-{-# LANGUAGE CPP                      #-}
-{-# LANGUAGE NondecreasingIndentation #-}
-
------------------------------------------------------------------------------
---
--- GHC Driver
---
--- (c) The University of Glasgow 2005
---
------------------------------------------------------------------------------
-
-module Development.IDE.GHC.CPP(doCpp, addOptP)
-where
-
-import           Development.IDE.GHC.Compat      as Compat
-import           GHC
-#if !MIN_VERSION_ghc(8,10,0)
-import qualified Development.IDE.GHC.Compat.CPP  as CPP
-#else
-import           Development.IDE.GHC.Compat.Util
-#endif
-
-#if MIN_VERSION_ghc(9,0,0)
-import qualified GHC.Driver.Pipeline             as Pipeline
-import           GHC.Settings
-#else
-#if MIN_VERSION_ghc (8,10,0)
-import qualified DriverPipeline                  as Pipeline
-import           ToolSettings
-#else
-import           DynFlags
-#endif
-#endif
-
-addOptP :: String -> DynFlags -> DynFlags
-#if MIN_VERSION_ghc (8,10,0)
-addOptP f = alterToolSettings $ \s -> s
-          { toolSettings_opt_P             = f : toolSettings_opt_P s
-          , toolSettings_opt_P_fingerprint = fingerprintStrings (f : toolSettings_opt_P s)
-          }
-  where
-    fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss
-    alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) }
-#else
-addOptP opt = onSettings (onOptP (opt:))
-  where
-    onSettings f x = x{settings = f $ settings x}
-    onOptP f x = x{sOpt_P = f $ sOpt_P x}
-#endif
-
-doCpp :: HscEnv -> Bool -> FilePath -> FilePath -> IO ()
-doCpp env raw input_fn output_fn =
-#if MIN_VERSION_ghc (9,2,0)
-    Pipeline.doCpp (hsc_logger env) (hsc_tmpfs env) (hsc_dflags env) (hsc_unit_env env) raw input_fn output_fn
-#elif MIN_VERSION_ghc (8,10,0)
-    Pipeline.doCpp (hsc_dflags env) raw input_fn output_fn
-#else
-    CPP.doCpp (hsc_dflags env) raw input_fn output_fn
-#endif
-
+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0++{-# LANGUAGE CPP                      #-}+{-# LANGUAGE NondecreasingIndentation #-}++-----------------------------------------------------------------------------+--+-- GHC Driver+--+-- (c) The University of Glasgow 2005+--+-----------------------------------------------------------------------------++module Development.IDE.GHC.CPP(doCpp, addOptP)+where++import           Development.IDE.GHC.Compat      as Compat+import           GHC+#if !MIN_VERSION_ghc(8,10,0)+import qualified Development.IDE.GHC.Compat.CPP  as CPP+#else+import           Development.IDE.GHC.Compat.Util+#endif++#if MIN_VERSION_ghc(9,0,0)+import qualified GHC.Driver.Pipeline             as Pipeline+import           GHC.Settings+#else+#if MIN_VERSION_ghc (8,10,0)+import qualified DriverPipeline                  as Pipeline+import           ToolSettings+#else+import           DynFlags+#endif+#endif++addOptP :: String -> DynFlags -> DynFlags+#if MIN_VERSION_ghc (8,10,0)+addOptP f = alterToolSettings $ \s -> s+          { toolSettings_opt_P             = f : toolSettings_opt_P s+          , toolSettings_opt_P_fingerprint = fingerprintStrings (f : toolSettings_opt_P s)+          }+  where+    fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss+    alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) }+#else+addOptP opt = onSettings (onOptP (opt:))+  where+    onSettings f x = x{settings = f $ settings x}+    onOptP f x = x{sOpt_P = f $ sOpt_P x}+#endif++doCpp :: HscEnv -> Bool -> FilePath -> FilePath -> IO ()+doCpp env raw input_fn output_fn =+#if MIN_VERSION_ghc (9,2,0)+    Pipeline.doCpp (hsc_logger env) (hsc_tmpfs env) (hsc_dflags env) (hsc_unit_env env) raw input_fn output_fn+#elif MIN_VERSION_ghc (8,10,0)+    Pipeline.doCpp (hsc_dflags env) raw input_fn output_fn+#else+    CPP.doCpp (hsc_dflags env) raw input_fn output_fn+#endif+

@@ -20,6 +20,7 @@     reLocA,     getMessages',     pattern PFailedWithErrorMessages,+    isObjectLinkable,  #if !MIN_VERSION_ghc(9,0,1)     RefMap,@@ -28,6 +29,7 @@ #if MIN_VERSION_ghc(9,2,0)     extendModSummaryNoDeps,     emsModSummary,+    myCoreToStgExpr, #endif      nodeInfo',@@ -69,6 +71,39 @@     Option (..),     runUnlit,     runPp,++    -- * Recompilation avoidance+    hscCompileCoreExprHook,+    CoreExpr,+    simplifyExpr,+    tidyExpr,+    emptyTidyEnv,+    corePrepExpr,+    lintInteractiveExpr,+    icInteractiveModule,+    HomePackageTable,+    lookupHpt,+    Dependencies(dep_mods),+    bcoFreeNames,+    ModIfaceAnnotation,+    pattern Annotation,+    AnnTarget(ModuleTarget),+    extendAnnEnvList,+    module UniqDSet,+    module UniqSet,+    module UniqDFM,+    getDependentMods,+#if MIN_VERSION_ghc(9,2,0)+    loadExpr,+    byteCodeGen,+    bc_bcos,+    loadDecls,+    hscInterp,+    expectJust,+#else+    coreExprToBCOs,+    linkExpr,+#endif     ) where  import           Development.IDE.GHC.Compat.Core@@ -84,7 +119,48 @@ import           GHC                                   hiding (HasSrcSpan,                                                         ModLocation,                                                         RealSrcSpan, getLoc,-                                                        lookupName)+                                                        lookupName, exprType)+#if MIN_VERSION_ghc(9,0,0)+import GHC.Driver.Hooks (hscCompileCoreExprHook)+import GHC.Core (CoreExpr, CoreProgram)+import qualified GHC.Core.Opt.Pipeline as GHC+import GHC.Core.Tidy (tidyExpr)+import GHC.Types.Var.Env (emptyTidyEnv)+import qualified GHC.CoreToStg.Prep as GHC+import GHC.Core.Lint (lintInteractiveExpr)+#if MIN_VERSION_ghc(9,2,0)+import GHC.Unit.Home.ModInfo (lookupHpt, HomePackageTable)+import GHC.Runtime.Context (icInteractiveModule)+import GHC.Unit.Module.Deps (Dependencies(dep_mods))+import GHC.Linker.Types (isObjectLinkable)+import GHC.Linker.Loader (loadExpr)+#else+import GHC.CoreToByteCode (coreExprToBCOs)+import GHC.Driver.Types (Dependencies(dep_mods), icInteractiveModule, lookupHpt, HomePackageTable)+import GHC.Runtime.Linker (linkExpr)+#endif+import GHC.ByteCode.Asm (bcoFreeNames)+import GHC.Types.Annotations (Annotation(..), AnnTarget(ModuleTarget), extendAnnEnvList)+import GHC.Types.Unique.DSet as UniqDSet+import GHC.Types.Unique.Set as UniqSet+import GHC.Types.Unique.DFM  as UniqDFM+#else+import Hooks (hscCompileCoreExprHook)+import CoreSyn (CoreExpr)+import qualified SimplCore as GHC+import CoreTidy (tidyExpr)+import VarEnv (emptyTidyEnv)+import CorePrep (corePrepExpr)+import CoreLint (lintInteractiveExpr)+import ByteCodeGen (coreExprToBCOs)+import HscTypes (icInteractiveModule, HomePackageTable, lookupHpt, Dependencies(dep_mods))+import Linker (linkExpr)+import ByteCodeAsm (bcoFreeNames)+import Annotations (Annotation(..), AnnTarget(ModuleTarget), extendAnnEnvList)+import UniqDSet+import UniqSet+import UniqDFM+#endif  #if MIN_VERSION_ghc(9,0,0) import           GHC.Data.StringBuffer@@ -142,12 +218,90 @@ import           Bag                                   (unitBag) #endif +#if MIN_VERSION_ghc(9,2,0)+import GHC.Types.CostCentre+import GHC.Stg.Syntax+import GHC.Types.IPE+import GHC.Stg.Syntax+import GHC.Types.IPE+import GHC.Types.CostCentre+import GHC.Core+import GHC.Builtin.Uniques+import GHC.Runtime.Interpreter+import GHC.StgToByteCode+import GHC.Stg.Pipeline+import GHC.ByteCode.Types+import GHC.Linker.Loader (loadDecls)+import GHC.Data.Maybe+import GHC.CoreToStg+#endif++type ModIfaceAnnotation = Annotation++#if MIN_VERSION_ghc(9,2,0)+myCoreToStgExpr :: Logger -> DynFlags -> InteractiveContext+                -> Module -> ModLocation -> CoreExpr+                -> IO ( Id+                      , [StgTopBinding]+                      , InfoTableProvMap+                      , CollectedCCs )+myCoreToStgExpr logger dflags ictxt this_mod ml prepd_expr = do+    {- Create a temporary binding (just because myCoreToStg needs a+       binding for the stg2stg step) -}+    let bco_tmp_id = mkSysLocal (fsLit "BCO_toplevel")+                                (mkPseudoUniqueE 0)+                                Many+                                (exprType prepd_expr)+    (stg_binds, prov_map, collected_ccs) <-+       myCoreToStg logger+                   dflags+                   ictxt+                   this_mod+                   ml+                   [NonRec bco_tmp_id prepd_expr]+    return (bco_tmp_id, stg_binds, prov_map, collected_ccs)++myCoreToStg :: Logger -> DynFlags -> InteractiveContext+            -> Module -> ModLocation -> CoreProgram+            -> IO ( [StgTopBinding] -- output program+                  , InfoTableProvMap+                  , CollectedCCs )  -- CAF cost centre info (declared and used)+myCoreToStg logger dflags ictxt this_mod ml prepd_binds = do+    let (stg_binds, denv, cost_centre_info)+         = {-# SCC "Core2Stg" #-}+           coreToStg dflags this_mod ml prepd_binds++    stg_binds2+        <- {-# SCC "Stg2Stg" #-}+           stg2stg logger dflags ictxt this_mod stg_binds++    return (stg_binds2, denv, cost_centre_info)+#endif++ #if !MIN_VERSION_ghc(9,2,0) reLoc :: Located a -> Located a reLoc = id  reLocA :: Located a -> Located a reLocA = id+#endif++getDependentMods :: ModIface -> [ModuleName]+#if MIN_VERSION_ghc(9,0,0)+getDependentMods = map gwib_mod . dep_mods . mi_deps+#else+getDependentMods = map fst . dep_mods . mi_deps+#endif++simplifyExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr+#if MIN_VERSION_ghc(9,0,0)+simplifyExpr _ = GHC.simplifyExpr++corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr+corePrepExpr _ = GHC.corePrepExpr+#else+simplifyExpr df _ = GHC.simplifyExpr df #endif  #if !MIN_VERSION_ghc(8,8,0)

@@ -1,204 +1,204 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.
--- SPDX-License-Identifier: Apache-2.0
-
--- Copied from https://github.com/ghc/ghc/blob/master/compiler/main/DriverPipeline.hs on 14 May 2019
--- Requested to be exposed at https://gitlab.haskell.org/ghc/ghc/merge_requests/944.
--- Update the above MR got merged to master on 31 May 2019. When it becomes avialable to ghc-lib, this file can be removed.
-
-{- HLINT ignore -} -- since copied from upstream
-
-{-# LANGUAGE CPP #-}
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
--- | Re-export 'doCpp' for GHC < 8.10.
---
--- Later versions export what we need.
-module Development.IDE.GHC.Compat.CPP (
-    doCpp
-    ) where
-
-import           FileCleanup
-import           Packages
-import           Panic
-import           SysTools
-#if MIN_VERSION_ghc(8,8,2)
-import           LlvmCodeGen                (llvmVersionList)
-#elif MIN_VERSION_ghc(8,8,0)
-import           LlvmCodeGen                (LlvmVersion (..))
-#endif
-import           Control.Monad
-import           Data.List                  (intercalate)
-import           Data.Maybe
-import           Data.Version
-import           DynFlags
-import           Module                     (rtsUnitId, toInstalledUnitId)
-import           System.Directory
-import           System.FilePath
-import           System.Info
-
-import           Development.IDE.GHC.Compat as Compat
-
-doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO ()
-doCpp dflags raw input_fn output_fn = do
-    let hscpp_opts = picPOpts dflags
-    let cmdline_include_paths = includePaths dflags
-
-    pkg_include_dirs <- getPackageIncludePath dflags []
-    let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []
-          (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)
-    let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []
-          (includePathsQuote cmdline_include_paths)
-    let include_paths = include_paths_quote ++ include_paths_global
-
-    let verbFlags = getVerbFlags dflags
-
-    let cpp_prog args | raw       = SysTools.runCpp dflags args
-#if MIN_VERSION_ghc(8,10,0)
-                      | otherwise = SysTools.runCc Nothing
-#else
-                      | otherwise = SysTools.runCc
-#endif
-                                          dflags (SysTools.Option "-E" : args)
-
-    let target_defs =
-          -- NEIL: Patched to use System.Info instead of constants from CPP
-          [ "-D" ++ os     ++ "_BUILD_OS",
-            "-D" ++ arch   ++ "_BUILD_ARCH",
-            "-D" ++ os     ++ "_HOST_OS",
-            "-D" ++ arch   ++ "_HOST_ARCH" ]
-        -- remember, in code we *compile*, the HOST is the same our TARGET,
-        -- and BUILD is the same as our HOST.
-
-    let sse_defs =
-          [ "-D__SSE__"      | isSseEnabled      dflags ] ++
-          [ "-D__SSE2__"     | isSse2Enabled     dflags ] ++
-          [ "-D__SSE4_2__"   | isSse4_2Enabled   dflags ]
-
-    let avx_defs =
-          [ "-D__AVX__"      | isAvxEnabled      dflags ] ++
-          [ "-D__AVX2__"     | isAvx2Enabled     dflags ] ++
-          [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++
-          [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++
-          [ "-D__AVX512F__"  | isAvx512fEnabled  dflags ] ++
-          [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ]
-
-    backend_defs <- getBackendDefs dflags
-
-    let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]
-    -- Default CPP defines in Haskell source
-    ghcVersionH <- getGhcVersionPathName dflags
-    let hsSourceCppOpts = [ "-include", ghcVersionH ]
-
-    -- MIN_VERSION macros
-    let uids = explicitPackages (pkgState dflags)
-        pkgs = catMaybes (map (lookupPackage dflags) uids)
-    mb_macro_include <-
-        if not (null pkgs) && gopt Opt_VersionMacros dflags
-            then do macro_stub <- newTempName dflags TFL_CurrentModule "h"
-                    writeFile macro_stub (generatePackageVersionMacros pkgs)
-                    -- Include version macros for every *exposed* package.
-                    -- Without -hide-all-packages and with a package database
-                    -- size of 1000 packages, it takes cpp an estimated 2
-                    -- milliseconds to process this file. See #10970
-                    -- comment 8.
-                    return [SysTools.FileOption "-include" macro_stub]
-            else return []
-
-    cpp_prog       (   map SysTools.Option verbFlags
-                    ++ map SysTools.Option include_paths
-                    ++ map SysTools.Option hsSourceCppOpts
-                    ++ map SysTools.Option target_defs
-                    ++ map SysTools.Option backend_defs
-                    ++ map SysTools.Option th_defs
-                    ++ map SysTools.Option hscpp_opts
-                    ++ map SysTools.Option sse_defs
-                    ++ map SysTools.Option avx_defs
-                    ++ mb_macro_include
-        -- Set the language mode to assembler-with-cpp when preprocessing. This
-        -- alleviates some of the C99 macro rules relating to whitespace and the hash
-        -- operator, which we tend to abuse. Clang in particular is not very happy
-        -- about this.
-                    ++ [ SysTools.Option     "-x"
-                       , SysTools.Option     "assembler-with-cpp"
-                       , SysTools.Option     input_fn
-        -- We hackily use Option instead of FileOption here, so that the file
-        -- name is not back-slashed on Windows.  cpp is capable of
-        -- dealing with / in filenames, so it works fine.  Furthermore
-        -- if we put in backslashes, cpp outputs #line directives
-        -- with *double* backslashes.   And that in turn means that
-        -- our error messages get double backslashes in them.
-        -- In due course we should arrange that the lexer deals
-        -- with these \\ escapes properly.
-                       , SysTools.Option     "-o"
-                       , SysTools.FileOption "" output_fn
-                       ])
-
-getBackendDefs :: DynFlags -> IO [String]
-getBackendDefs dflags | hscTarget dflags == HscLlvm = do
-    llvmVer <- figureLlvmVersion dflags
-    return $ case llvmVer of
-#if MIN_VERSION_ghc(8,8,2)
-               Just v
-                 | [m] <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, 0) ]
-                 | m:n:_   <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, n) ]
-#elif MIN_VERSION_ghc(8,8,0)
-               Just (LlvmVersion n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (n,0) ]
-               Just (LlvmVersionOld m n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]
-#else
-               Just n -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format n ]
-#endif
-               _      -> []
-  where
-    format (major, minor)
-      | minor >= 100 = error "getBackendDefs: Unsupported minor version"
-      | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int
-
-getBackendDefs _ =
-    return []
-
--- ---------------------------------------------------------------------------
--- Macros (cribbed from Cabal)
-
-generatePackageVersionMacros :: [Compat.UnitInfo] -> String
-generatePackageVersionMacros pkgs = concat
-  -- Do not add any C-style comments. See #3389.
-  [ generateMacros "" pkgname version
-  | pkg <- pkgs
-  , let version = packageVersion pkg
-        pkgname = map fixchar (packageNameString pkg)
-  ]
-
-fixchar :: Char -> Char
-fixchar '-' = '_'
-fixchar c   = c
-
-generateMacros :: String -> String -> Version -> String
-generateMacros prefix name version =
-  concat
-  ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n"
-  ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n"
-  ,"  (major1) <  ",major1," || \\\n"
-  ,"  (major1) == ",major1," && (major2) <  ",major2," || \\\n"
-  ,"  (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"
-  ,"\n\n"
-  ]
-  where
-    (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)
-
-
--- | Find out path to @ghcversion.h@ file
-getGhcVersionPathName :: DynFlags -> IO FilePath
-getGhcVersionPathName dflags = do
-  candidates <- case ghcVersionFile dflags of
-    Just path -> return [path]
-    Nothing -> (map (</> "ghcversion.h")) <$>
-               (getPackageIncludePath dflags [toInstalledUnitId rtsUnit])
-
-  found <- filterM doesFileExist candidates
-  case found of
-      []    -> throwGhcExceptionIO (InstallationError
-                                    ("ghcversion.h missing; tried: "
-                                      ++ intercalate ", " candidates))
-      (x:_) -> return x
-
-rtsUnit :: UnitId
-rtsUnit = Module.rtsUnitId
+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0++-- Copied from https://github.com/ghc/ghc/blob/master/compiler/main/DriverPipeline.hs on 14 May 2019+-- Requested to be exposed at https://gitlab.haskell.org/ghc/ghc/merge_requests/944.+-- Update the above MR got merged to master on 31 May 2019. When it becomes avialable to ghc-lib, this file can be removed.++{- HLINT ignore -} -- since copied from upstream++{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+-- | Re-export 'doCpp' for GHC < 8.10.+--+-- Later versions export what we need.+module Development.IDE.GHC.Compat.CPP (+    doCpp+    ) where++import           FileCleanup+import           Packages+import           Panic+import           SysTools+#if MIN_VERSION_ghc(8,8,2)+import           LlvmCodeGen                (llvmVersionList)+#elif MIN_VERSION_ghc(8,8,0)+import           LlvmCodeGen                (LlvmVersion (..))+#endif+import           Control.Monad+import           Data.List                  (intercalate)+import           Data.Maybe+import           Data.Version+import           DynFlags+import           Module                     (rtsUnitId, toInstalledUnitId)+import           System.Directory+import           System.FilePath+import           System.Info++import           Development.IDE.GHC.Compat as Compat++doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO ()+doCpp dflags raw input_fn output_fn = do+    let hscpp_opts = picPOpts dflags+    let cmdline_include_paths = includePaths dflags++    pkg_include_dirs <- getPackageIncludePath dflags []+    let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []+          (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)+    let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []+          (includePathsQuote cmdline_include_paths)+    let include_paths = include_paths_quote ++ include_paths_global++    let verbFlags = getVerbFlags dflags++    let cpp_prog args | raw       = SysTools.runCpp dflags args+#if MIN_VERSION_ghc(8,10,0)+                      | otherwise = SysTools.runCc Nothing+#else+                      | otherwise = SysTools.runCc+#endif+                                          dflags (SysTools.Option "-E" : args)++    let target_defs =+          -- NEIL: Patched to use System.Info instead of constants from CPP+          [ "-D" ++ os     ++ "_BUILD_OS",+            "-D" ++ arch   ++ "_BUILD_ARCH",+            "-D" ++ os     ++ "_HOST_OS",+            "-D" ++ arch   ++ "_HOST_ARCH" ]+        -- remember, in code we *compile*, the HOST is the same our TARGET,+        -- and BUILD is the same as our HOST.++    let sse_defs =+          [ "-D__SSE__"      | isSseEnabled      dflags ] +++          [ "-D__SSE2__"     | isSse2Enabled     dflags ] +++          [ "-D__SSE4_2__"   | isSse4_2Enabled   dflags ]++    let avx_defs =+          [ "-D__AVX__"      | isAvxEnabled      dflags ] +++          [ "-D__AVX2__"     | isAvx2Enabled     dflags ] +++          [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] +++          [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] +++          [ "-D__AVX512F__"  | isAvx512fEnabled  dflags ] +++          [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ]++    backend_defs <- getBackendDefs dflags++    let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]+    -- Default CPP defines in Haskell source+    ghcVersionH <- getGhcVersionPathName dflags+    let hsSourceCppOpts = [ "-include", ghcVersionH ]++    -- MIN_VERSION macros+    let uids = explicitPackages (pkgState dflags)+        pkgs = catMaybes (map (lookupPackage dflags) uids)+    mb_macro_include <-+        if not (null pkgs) && gopt Opt_VersionMacros dflags+            then do macro_stub <- newTempName dflags TFL_CurrentModule "h"+                    writeFile macro_stub (generatePackageVersionMacros pkgs)+                    -- Include version macros for every *exposed* package.+                    -- Without -hide-all-packages and with a package database+                    -- size of 1000 packages, it takes cpp an estimated 2+                    -- milliseconds to process this file. See #10970+                    -- comment 8.+                    return [SysTools.FileOption "-include" macro_stub]+            else return []++    cpp_prog       (   map SysTools.Option verbFlags+                    ++ map SysTools.Option include_paths+                    ++ map SysTools.Option hsSourceCppOpts+                    ++ map SysTools.Option target_defs+                    ++ map SysTools.Option backend_defs+                    ++ map SysTools.Option th_defs+                    ++ map SysTools.Option hscpp_opts+                    ++ map SysTools.Option sse_defs+                    ++ map SysTools.Option avx_defs+                    ++ mb_macro_include+        -- Set the language mode to assembler-with-cpp when preprocessing. This+        -- alleviates some of the C99 macro rules relating to whitespace and the hash+        -- operator, which we tend to abuse. Clang in particular is not very happy+        -- about this.+                    ++ [ SysTools.Option     "-x"+                       , SysTools.Option     "assembler-with-cpp"+                       , SysTools.Option     input_fn+        -- We hackily use Option instead of FileOption here, so that the file+        -- name is not back-slashed on Windows.  cpp is capable of+        -- dealing with / in filenames, so it works fine.  Furthermore+        -- if we put in backslashes, cpp outputs #line directives+        -- with *double* backslashes.   And that in turn means that+        -- our error messages get double backslashes in them.+        -- In due course we should arrange that the lexer deals+        -- with these \\ escapes properly.+                       , SysTools.Option     "-o"+                       , SysTools.FileOption "" output_fn+                       ])++getBackendDefs :: DynFlags -> IO [String]+getBackendDefs dflags | hscTarget dflags == HscLlvm = do+    llvmVer <- figureLlvmVersion dflags+    return $ case llvmVer of+#if MIN_VERSION_ghc(8,8,2)+               Just v+                 | [m] <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, 0) ]+                 | m:n:_   <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, n) ]+#elif MIN_VERSION_ghc(8,8,0)+               Just (LlvmVersion n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (n,0) ]+               Just (LlvmVersionOld m n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]+#else+               Just n -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format n ]+#endif+               _      -> []+  where+    format (major, minor)+      | minor >= 100 = error "getBackendDefs: Unsupported minor version"+      | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int++getBackendDefs _ =+    return []++-- ---------------------------------------------------------------------------+-- Macros (cribbed from Cabal)++generatePackageVersionMacros :: [Compat.UnitInfo] -> String+generatePackageVersionMacros pkgs = concat+  -- Do not add any C-style comments. See #3389.+  [ generateMacros "" pkgname version+  | pkg <- pkgs+  , let version = packageVersion pkg+        pkgname = map fixchar (packageNameString pkg)+  ]++fixchar :: Char -> Char+fixchar '-' = '_'+fixchar c   = c++generateMacros :: String -> String -> Version -> String+generateMacros prefix name version =+  concat+  ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n"+  ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n"+  ,"  (major1) <  ",major1," || \\\n"+  ,"  (major1) == ",major1," && (major2) <  ",major2," || \\\n"+  ,"  (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"+  ,"\n\n"+  ]+  where+    (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)+++-- | Find out path to @ghcversion.h@ file+getGhcVersionPathName :: DynFlags -> IO FilePath+getGhcVersionPathName dflags = do+  candidates <- case ghcVersionFile dflags of+    Just path -> return [path]+    Nothing -> (map (</> "ghcversion.h")) <$>+               (getPackageIncludePath dflags [toInstalledUnitId rtsUnit])++  found <- filterM doesFileExist candidates+  case found of+      []    -> throwGhcExceptionIO (InstallationError+                                    ("ghcversion.h missing; tried: "+                                      ++ intercalate ", " candidates))+      (x:_) -> return x++rtsUnit :: UnitId+rtsUnit = Module.rtsUnitId

@@ -141,6 +141,9 @@     ImportSpec(..),     -- * SourceText     SourceText(..),+#if !MIN_VERSION_ghc(9,2,0)+    rationalFromFractionalLit,+#endif     -- * Name     tyThingParent_maybe,     -- * Ways@@ -1075,4 +1078,9 @@ #if !MIN_VERSION_ghc(9,2,0) pattern HsLet xlet localBinds expr <- GHC.HsLet xlet (SrcLoc.unLoc -> localBinds) expr pattern LetStmt xlet localBinds <- GHC.LetStmt xlet (SrcLoc.unLoc -> localBinds)+#endif++#if !MIN_VERSION_ghc(9,2,0)+rationalFromFractionalLit :: FractionalLit -> Rational+rationalFromFractionalLit = fl_value #endif

@@ -8,11 +8,12 @@     showSDocForUser,     ppr, pprPanic, text, vcat, (<+>), ($$), empty, hang, nest,     printSDocQualifiedUnsafe,-    printNameWithoutUniques,-    printSDocAllTheWay,+    printWithoutUniques,     mkPrintUnqualified,     mkPrintUnqualifiedDefault,     PrintUnqualified(..),+    defaultUserStyle,+    withPprStyle,     -- * Parser errors     PsWarning,     PsError,@@ -43,7 +44,8 @@ import           GHC.Types.SrcLoc import           GHC.Unit.State import           GHC.Utils.Error                 hiding (mkWarnMsg)-import           GHC.Utils.Outputable+import           GHC.Utils.Outputable            as Out hiding (defaultUserStyle)+import qualified GHC.Utils.Outputable            as Out import           GHC.Utils.Panic #elif MIN_VERSION_ghc(9,0,0) import           GHC.Driver.Session@@ -52,25 +54,37 @@ import           GHC.Types.SrcLoc import           GHC.Utils.Error                 as Err hiding (mkWarnMsg) import qualified GHC.Utils.Error                 as Err-import           GHC.Utils.Outputable            as Out+import           GHC.Utils.Outputable            as Out hiding (defaultUserStyle)+import qualified GHC.Utils.Outputable            as Out #else import           Development.IDE.GHC.Compat.Core (GlobalRdrEnv) import           DynFlags import           ErrUtils                        hiding (mkWarnMsg) import qualified ErrUtils                        as Err import           HscTypes-import           Outputable                      as Out+import           Outputable                      as Out hiding (defaultUserStyle)+import qualified Outputable                      as Out import           SrcLoc #endif -printNameWithoutUniques :: Outputable a => a -> String-printNameWithoutUniques =+-- | A compatible function to print `Outputable` instances+-- without unique symbols.+--+-- It print with a user-friendly style like: `a_a4ME` as `a`.+printWithoutUniques :: Outputable a => a -> String+printWithoutUniques = #if MIN_VERSION_ghc(9,2,0)-  renderWithContext (defaultSDocContext { sdocSuppressUniques = True }) . ppr+  renderWithContext (defaultSDocContext+    {+      sdocStyle = defaultUserStyle+    , sdocSuppressUniques = True+    , sdocCanUseUnicode = True+    }) . ppr #else-  printSDocAllTheWay dyn . ppr-  where-    dyn = unsafeGlobalDynFlags `gopt_set` Opt_SuppressUniques+  go . ppr+    where+      go sdoc = oldRenderWithStyle dflags sdoc (oldMkUserStyle dflags neverQualify AllTheWay)+      dflags = unsafeGlobalDynFlags `gopt_set` Opt_SuppressUniques #endif  printSDocQualifiedUnsafe :: PrintUnqualified -> SDoc -> String@@ -86,15 +100,7 @@     showSDocForUser unsafeGlobalDynFlags unqual doc #endif -printSDocAllTheWay :: DynFlags -> SDoc -> String-#if MIN_VERSION_ghc(9,2,0)-printSDocAllTheWay dflags sdoc = renderWithContext ctxt sdoc-  where-    ctxt = initSDocContext dflags (mkUserStyle neverQualify AllTheWay)-#else-printSDocAllTheWay dflags sdoc = oldRenderWithStyle dflags sdoc (oldMkUserStyle dflags Out.neverQualify Out.AllTheWay)--#if  MIN_VERSION_ghc(9,0,0)+#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0) oldRenderWithStyle dflags sdoc sty = Out.renderWithStyle (initSDocContext dflags sty) sdoc oldMkUserStyle _ = Out.mkUserStyle oldMkErrStyle _ = Out.mkErrStyle@@ -102,8 +108,7 @@ oldFormatErrDoc :: DynFlags -> Err.ErrDoc -> Out.SDoc oldFormatErrDoc dflags = Err.formatErrDoc dummySDocContext   where dummySDocContext = initSDocContext dflags Out.defaultUserStyle--#else+#elif !MIN_VERSION_ghc(9,0,0) oldRenderWithStyle :: DynFlags -> Out.SDoc -> Out.PprStyle -> String oldRenderWithStyle = Out.renderWithStyle @@ -116,7 +121,6 @@ oldFormatErrDoc :: DynFlags -> Err.ErrDoc -> Out.SDoc oldFormatErrDoc = Err.formatErrDoc #endif-#endif  pprWarning :: PsWarning -> MsgEnvelope DecoratedSDoc pprWarning =@@ -164,7 +168,7 @@ mkPrintUnqualifiedDefault :: HscEnv -> GlobalRdrEnv -> PrintUnqualified mkPrintUnqualifiedDefault env = #if MIN_VERSION_ghc(9,2,0)-  -- GHC 9.2.1 version+  -- GHC 9.2 version   -- mkPrintUnqualified :: UnitEnv -> GlobalRdrEnv -> PrintUnqualified   mkPrintUnqualified (hsc_unit_env env) #else@@ -177,4 +181,11 @@   const Error.mkWarnMsg #else   Err.mkWarnMsg+#endif++defaultUserStyle :: PprStyle+#if MIN_VERSION_ghc(9,0,0)+defaultUserStyle = Out.defaultUserStyle+#else+defaultUserStyle = Out.defaultUserStyle unsafeGlobalDynFlags #endif

@@ -41,6 +41,8 @@ #if !MIN_VERSION_ghc(9,2,0)     Anno.AnnotationComment(..), #endif+    pattern EpaLineComment,+    pattern EpaBlockComment     ) where  #if MIN_VERSION_ghc(9,0,0)@@ -51,12 +53,18 @@ import qualified GHC.Parser.Lexer                as Lexer import           GHC.Types.SrcLoc                (PsSpan (..)) #if MIN_VERSION_ghc(9,2,0)-import           GHC                             (pm_extra_src_files,+import           GHC                             (Anchor (anchor),+                                                  EpAnnComments (priorComments),+                                                  EpaComment (EpaComment),+                                                  EpaCommentTok (..),+                                                  epAnnComments,+                                                  pm_extra_src_files,                                                   pm_mod_summary,                                                   pm_parsed_source) import qualified GHC import qualified GHC.Driver.Config               as Config-import           GHC.Hs                          (hpm_module, hpm_src_files)+import           GHC.Hs                          (LEpaComment, hpm_module,+                                                  hpm_src_files) import           GHC.Parser.Lexer                hiding (initParserState) #endif #else@@ -100,6 +108,8 @@ #endif  #if MIN_VERSION_ghc(9,2,0)+-- GHC 9.2 does not have ApiAnns anymore packaged in ParsedModule. Now the+-- annotations are found in the ast. type ApiAnns = () #else type ApiAnns = Anno.ApiAnns@@ -154,4 +164,9 @@      Map.fromList ((SrcLoc.noSrcSpan,comment_q pst)                   :annotations_comments pst)) #endif+#endif++#if !MIN_VERSION_ghc(9,2,0)+pattern EpaLineComment a = Anno.AnnLineComment a+pattern EpaBlockComment a = Anno.AnnBlockComment a #endif

@@ -23,7 +23,6 @@       transformM,       ExactPrint(..), #if !MIN_VERSION_ghc(9,2,0)-      useAnnotatedSource,       Anns,       Annotate,       setPrecedingLinesT,@@ -44,6 +43,7 @@       ASTElement (..),       ExceptStringT (..),       TransformT,+      Log(..),     ) where @@ -67,13 +67,18 @@ import           Data.Traversable                        (for) import           Development.IDE.Core.RuleTypes import           Development.IDE.Core.Service            (runAction)-import           Development.IDE.Core.Shake+import           Development.IDE.Core.Shake              hiding (Log)+import qualified Development.IDE.Core.Shake              as Shake import           Development.IDE.GHC.Compat              hiding (parseImport,                                                           parsePattern,                                                           parseType) import           Development.IDE.Graph                   (RuleResult, Rules) import           Development.IDE.Graph.Classes import           Development.IDE.Types.Location+import           Development.IDE.Types.Logger            (Pretty (pretty),+                                                          Recorder,+                                                          WithPriority,+                                                          cmapWithPrio) import qualified GHC.Generics                            as GHC import           Generics.SYB import           Generics.SYB.GHC@@ -101,6 +106,12 @@  ------------------------------------------------------------------------------ +data Log = LogShake Shake.Log deriving Show++instance Pretty Log where+  pretty = \case+    LogShake shakeLog -> pretty shakeLog+ data GetAnnotatedParsedSource = GetAnnotatedParsedSource   deriving (Eq, Show, Typeable, GHC.Generic) @@ -109,8 +120,8 @@ type instance RuleResult GetAnnotatedParsedSource = Annotated ParsedSource  -- | Get the latest version of the annotated parse source with comments.-getAnnotatedParsedSourceRule :: Rules ()-getAnnotatedParsedSourceRule = define $ \GetAnnotatedParsedSource nfp -> do+getAnnotatedParsedSourceRule :: Recorder (WithPriority Log) -> Rules ()+getAnnotatedParsedSourceRule recorder = define (cmapWithPrio LogShake recorder) $ \GetAnnotatedParsedSource nfp -> do   pm <- use GetParsedModuleWithComments nfp   return ([], fmap annotateParsedSource pm) @@ -120,16 +131,6 @@ #else annotateParsedSource :: ParsedModule -> Annotated ParsedSource annotateParsedSource = fixAnns-#endif--#if !MIN_VERSION_ghc(9,2,0)-useAnnotatedSource ::-  String ->-  IdeState ->-  NormalizedFilePath ->-  IO (Maybe (Annotated ParsedSource))-useAnnotatedSource herald state nfp =-    runAction herald state (use GetAnnotatedParsedSource nfp) #endif  ------------------------------------------------------------------------------

@@ -39,24 +39,35 @@ import           Data.Bifunctor             (Bifunctor (..)) import           Data.Hashable import           Data.String                (IsString (fromString))+import           Data.Text                  (unpack)+#if MIN_VERSION_ghc(9,0,0)+import          GHC.ByteCode.Types+#else+import          ByteCodeTypes+#endif  -- Orphan instances for types from the GHC API.-instance Show CoreModule where show = prettyPrint+instance Show CoreModule where show = unpack . printOutputable instance NFData CoreModule where rnf = rwhnf-instance Show CgGuts where show = prettyPrint . cg_module+instance Show CgGuts where show = unpack . printOutputable . cg_module instance NFData CgGuts where rnf = rwhnf instance Show ModDetails where show = const "<moddetails>" instance NFData ModDetails where rnf = rwhnf instance NFData SafeHaskellMode where rnf = rwhnf-instance Show Linkable where show = prettyPrint-instance NFData Linkable where rnf = rwhnf-instance Show PackageFlag where show = prettyPrint-instance Show InteractiveImport where show = prettyPrint-instance Show PackageName  where show = prettyPrint+instance Show Linkable where show = unpack . printOutputable+instance NFData Linkable where rnf (LM a b c) = rnf a `seq` rnf b `seq` rnf c+instance NFData Unlinked where+  rnf (DotO f) = rnf f+  rnf (DotA f) = rnf f+  rnf (DotDLL f) = rnf f+  rnf (BCOs a b) = seqCompiledByteCode a `seq` liftRnf rwhnf b+instance Show PackageFlag where show = unpack . printOutputable+instance Show InteractiveImport where show = unpack . printOutputable+instance Show PackageName  where show = unpack . printOutputable  #if !MIN_VERSION_ghc(9,0,1)-instance Show ComponentId  where show = prettyPrint-instance Show SourcePackageId  where show = prettyPrint+instance Show ComponentId  where show = unpack . printOutputable+instance Show SourcePackageId  where show = unpack . printOutputable  instance Show GhcPlugins.InstalledUnitId where     show = installedUnitIdString@@ -66,7 +77,7 @@ instance Hashable GhcPlugins.InstalledUnitId where   hashWithSalt salt = hashWithSalt salt . installedUnitIdString #else-instance Show UnitId where show = prettyPrint+instance Show UnitId where show = unpack . printOutputable deriving instance Ord SrcSpan deriving instance Ord UnhelpfulSpanReason #endif@@ -76,7 +87,7 @@ instance Show Module where     show = moduleNameString . moduleName -instance Outputable a => Show (GenLocated SrcSpan a) where show = prettyPrint+instance Outputable a => Show (GenLocated SrcSpan a) where show = unpack . printOutputable  instance (NFData l, NFData e) => NFData (GenLocated l e) where     rnf (L l e) = rnf l `seq` rnf e@@ -197,5 +208,5 @@ #endif   rnf = rwhnf -instance Show OccName where show = prettyPrint+instance Show OccName where show = unpack . printOutputable instance Hashable OccName where hashWithSalt s n = hashWithSalt s (getKey $ getUnique n)

@@ -7,8 +7,6 @@     modifyDynFlags,     evalGhcEnv,     -- * GHC wrappers-    prettyPrint,-    unsafePrintSDoc,     printRdrName,     Development.IDE.GHC.Util.printName,     ParseResult(..), runParser,@@ -28,7 +26,9 @@     setHieDir,     dontWriteHieFiles,     disableWarningsAsErrors,-    traceAst) where+    traceAst,+    printOutputable+    ) where  #if MIN_VERSION_ghc(9,2,0) import           GHC.Data.FastString@@ -130,16 +130,9 @@ bytestringToStringBuffer :: ByteString -> StringBuffer bytestringToStringBuffer (PS buf cur len) = StringBuffer{..} --- | Pretty print a GHC value using 'unsafeGlobalDynFlags '.-prettyPrint :: Outputable a => a -> String-prettyPrint = unsafePrintSDoc . ppr--unsafePrintSDoc :: SDoc -> String-unsafePrintSDoc sdoc = showSDocUnsafe sdoc- -- | Pretty print a 'RdrName' wrapping operators in parens printRdrName :: RdrName -> String-printRdrName name = showSDocUnsafe $ parenSymOcc rn (ppr rn)+printRdrName name = T.unpack $ printOutputable $ parenSymOcc rn (ppr rn)   where     rn = rdrNameOcc name @@ -304,7 +297,7 @@ #if MIN_VERSION_ghc(9,2,0)     renderDump = renderWithContext defaultSDocContext{sdocStyle = defaultDumpStyle, sdocPprDebug = True} #else-    renderDump = unsafePrintSDoc+    renderDump = showSDocUnsafe . ppr #endif     htmlDump = showAstDataHtml x     doTrace = unsafePerformIO $ do@@ -318,4 +311,18 @@ #endif             , "file://" ++ htmlDumpFileName] +-- Should in `Development.IDE.GHC.Orphans`,+-- leave it here to prevent cyclic module dependency+#if !MIN_VERSION_ghc(8,10,0)+instance Outputable SDoc where+  ppr = id+#endif +-- | Print a GHC value in `defaultUserStyle` without unique symbols.+--+-- This is the most common print utility, will print with a user-friendly style like: `a_a4ME` as `a`.+--+-- It internal using `showSDocUnsafe` with `unsafeGlobalDynFlags`.+printOutputable :: Outputable a => a -> T.Text+printOutputable = T.pack . printWithoutUniques+{-# INLINE printOutputable #-}

@@ -129,6 +129,7 @@     -- need to add edges between .hs-boot and .hs so that the .hs files     -- appear later in the sort.     , rawBootMap   :: !BootIdMap+    , rawModuleNameMap :: !(FilePathIdMap ShowableModuleName)     } deriving Show  data DependencyInformation =@@ -220,15 +221,12 @@     { depErrorNodes = IntMap.fromList errorNodes     , depModuleDeps = moduleDeps     , depReverseModuleDeps = reverseModuleDeps-    , depModuleNames = IntMap.fromList $ coerce moduleNames+    , depModuleNames = rawModuleNameMap     , depPathIdMap = rawPathIdMap     , depBootMap = rawBootMap     }   where resultGraph = buildResultGraph rawImports         (errorNodes, successNodes) = partitionNodeResults $ IntMap.toList resultGraph-        moduleNames :: [(FilePathId, ModuleName)]-        moduleNames =-          [ (fId, modName) | (_, imports) <- successNodes, (L _ modName, fId) <- imports]         successEdges :: [(FilePathId, [FilePathId])]         successEdges =             map

@@ -10,6 +10,7 @@ -- This version removes the daml: handling module Development.IDE.LSP.LanguageServer     ( runLanguageServer+    , Log(..)     ) where  import           Control.Concurrent.STM@@ -31,35 +32,61 @@ import           UnliftIO.Directory import           UnliftIO.Exception -import           Development.IDE.Core.FileStore import           Development.IDE.Core.IdeConfiguration-import           Development.IDE.Core.Shake+import           Development.IDE.Core.Shake            hiding (Log) import           Development.IDE.Core.Tracing import           Development.IDE.LSP.HoverDefinition import           Development.IDE.Types.Logger  import           Control.Monad.IO.Unlift               (MonadUnliftIO)+import qualified Development.IDE.Session               as Session+import qualified Development.IDE.Types.Logger          as Logger import           Development.IDE.Types.Shake           (WithHieDb) import           System.IO.Unsafe                      (unsafeInterleaveIO) -issueTrackerUrl :: T.Text-issueTrackerUrl = "https://github.com/haskell/haskell-language-server/issues"+data Log+  = LogRegisteringIdeConfig !IdeConfiguration+  | LogReactorThreadException !SomeException+  | LogReactorMessageActionException !SomeException+  | LogReactorThreadStopped+  | LogCancelledRequest !SomeLspId+  | LogSession Session.Log+  deriving Show +instance Pretty Log where+  pretty = \case+    LogRegisteringIdeConfig ideConfig ->+      "Registering IDE configuration:" <+> viaShow ideConfig+    LogReactorThreadException e ->+      vcat+        [ "ReactorThreadException"+        , pretty $ displayException e ]+    LogReactorMessageActionException e ->+      vcat+        [ "ReactorMessageActionException"+        , pretty $ displayException e ]+    LogReactorThreadStopped ->+      "Reactor thread stopped"+    LogCancelledRequest requestId ->+      "Cancelled request" <+> viaShow requestId+    LogSession log -> pretty log+ -- used to smuggle RankNType WithHieDb through dbMVar newtype WithHieDbShield = WithHieDbShield WithHieDb  runLanguageServer     :: forall config. (Show config)-    => LSP.Options+    => Recorder (WithPriority Log)+    -> LSP.Options     -> Handle -- input     -> Handle -- output     -> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project     -> config     -> (config -> Value -> Either T.Text config)     -> LSP.Handlers (ServerM config)-    -> (LSP.LanguageContextEnv config -> VFSHandle -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState)+    -> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState)     -> IO ()-runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChange userHandlers getIdeState = do+runLanguageServer recorder options inH outH getHieDbLoc defaultConfig onConfigurationChange userHandlers getIdeState = do      -- This MVar becomes full when the server thread exits or we receive exit message from client.     -- LSP server will be canceled when it's full.@@ -128,6 +155,9 @@             serverDefinition      where+        log :: Logger.Priority -> Log -> IO ()+        log = logWith recorder+         handleInit           :: MVar () -> IO () -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> Chan ReactorMessage           -> LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState))@@ -142,33 +172,20 @@             dbMVar <- newEmptyMVar             ~(WithHieDbShield withHieDb,hieChan) <- unsafeInterleaveIO $ takeMVar dbMVar -            ide <- getIdeState env (makeLSPVFSHandle env) root withHieDb hieChan+            ide <- getIdeState env root withHieDb hieChan              let initConfig = parseConfiguration params-            logInfo (ideLogger ide) $ T.pack $ "Registering ide configuration: " <> show initConfig++            log Info $ LogRegisteringIdeConfig initConfig             registerIdeConfiguration (shakeExtras ide) initConfig              let handleServerException (Left e) = do-                    logError logger $-                        T.pack $ "Fatal error in server thread: " <> show e-                    sendErrorMessage e+                    log Error $ LogReactorThreadException e                     exitClientMsg                 handleServerException (Right _) = pure () -                sendErrorMessage (e :: SomeException) = do-                    LSP.runLspT env $ LSP.sendNotification SWindowShowMessage $-                        ShowMessageParams MtError $ T.unlines-                        [ "Unhandled exception, please [report](" <> issueTrackerUrl <> "): "-                        , T.pack(show e)-                        ]-                 exceptionInHandler e = do-                    logError logger $ T.pack $-                        "Unexpected exception, please report!\n" ++-                        "Exception: " ++ show e-                    sendErrorMessage e--                logger = ideLogger ide+                    log Error $ LogReactorMessageActionException e                  checkCancelled _id act k =                     flip finally (clearReqId _id) $@@ -180,14 +197,14 @@                             cancelOrRes <- race (waitForCancel _id) act                             case cancelOrRes of                                 Left () -> do-                                    logDebug (ideLogger ide) $ T.pack $ "Cancelled request " <> show _id+                                    log Debug $ LogCancelledRequest _id                                     k $ ResponseError RequestCancelled "" Nothing                                 Right res -> pure res                         ) $ \(e :: SomeException) -> do                             exceptionInHandler e                             k $ ResponseError InternalError (T.pack $ show e) Nothing             _ <- flip forkFinally handleServerException $ do-                untilMVar lifetime $ runWithDb logger dbLoc $ \withHieDb hieChan -> do+                untilMVar lifetime $ runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \withHieDb hieChan -> do                     putMVar dbMVar (WithHieDbShield withHieDb,hieChan)                     forever $ do                         msg <- readChan clientMsgChan@@ -196,7 +213,7 @@                         case msg of                             ReactorNotification act -> handle exceptionInHandler act                             ReactorRequest _id act k -> void $ async $ checkCancelled _id act k-                logInfo logger "Reactor thread stopped"+                log Info LogReactorThreadStopped             pure $ Right (env,ide)  

@@ -9,6 +9,7 @@ module Development.IDE.LSP.Notifications     ( whenUriFile     , descriptor+    , Log(..)     ) where  import           Language.LSP.Types@@ -26,57 +27,69 @@                                                         resetFileStore,                                                         setFileModified,                                                         setSomethingModified)+import qualified Development.IDE.Core.FileStore        as FileStore import           Development.IDE.Core.IdeConfiguration-import           Development.IDE.Core.OfInterest+import           Development.IDE.Core.OfInterest       hiding (Log, LogShake) import           Development.IDE.Core.RuleTypes        (GetClientSettings (..))-import           Development.IDE.Core.Service-import           Development.IDE.Core.Shake+import           Development.IDE.Core.Service          hiding (Log, LogShake)+import           Development.IDE.Core.Shake            hiding (Log, Priority)+import qualified Development.IDE.Core.Shake            as Shake import           Development.IDE.Types.Location import           Development.IDE.Types.Logger import           Development.IDE.Types.Shake           (toKey) import           Ide.Types +data Log+  = LogShake Shake.Log+  | LogFileStore FileStore.Log+  deriving Show++instance Pretty Log where+  pretty = \case+    LogShake log     -> pretty log+    LogFileStore log -> pretty log+ whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO () whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath' -descriptor :: PluginId -> PluginDescriptor IdeState-descriptor plId = (defaultPluginDescriptor plId) { pluginNotificationHandlers = mconcat+descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState+descriptor recorder plId = (defaultPluginDescriptor plId) { pluginNotificationHandlers = mconcat   [ mkPluginNotificationHandler LSP.STextDocumentDidOpen $-      \ide _ (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> liftIO $ do+      \ide vfs _ (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> liftIO $ do       atomically $ updatePositionMapping ide (VersionedTextDocumentIdentifier _uri (Just _version)) (List [])       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           addFileOfInterest ide file Modified{firstOpen=True}-          setFileModified ide False file+          setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file           logDebug (ideLogger ide) $ "Opened text document: " <> getUri _uri    , mkPluginNotificationHandler LSP.STextDocumentDidChange $-      \ide _ (DidChangeTextDocumentParams identifier@VersionedTextDocumentIdentifier{_uri} changes) -> liftIO $ do+      \ide vfs _ (DidChangeTextDocumentParams identifier@VersionedTextDocumentIdentifier{_uri} changes) -> liftIO $ do         atomically $ updatePositionMapping ide identifier changes         whenUriFile _uri $ \file -> do           addFileOfInterest ide file Modified{firstOpen=False}-          setFileModified ide False file+          setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file         logDebug (ideLogger ide) $ "Modified text document: " <> getUri _uri    , mkPluginNotificationHandler LSP.STextDocumentDidSave $-      \ide _ (DidSaveTextDocumentParams TextDocumentIdentifier{_uri} _) -> liftIO $ do+      \ide vfs _ (DidSaveTextDocumentParams TextDocumentIdentifier{_uri} _) -> liftIO $ do         whenUriFile _uri $ \file -> do             addFileOfInterest ide file OnDisk-            setFileModified ide True file+            setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide True file         logDebug (ideLogger ide) $ "Saved text document: " <> getUri _uri    , mkPluginNotificationHandler LSP.STextDocumentDidClose $-        \ide _ (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do+        \ide vfs _ (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do           whenUriFile _uri $ \file -> do               deleteFileOfInterest ide file               let msg = "Closed text document: " <> getUri _uri               scheduleGarbageCollection ide-              setSomethingModified ide [] $ Text.unpack msg+              setSomethingModified (VFSModified vfs) ide [] $ Text.unpack msg               logDebug (ideLogger ide) msg    , mkPluginNotificationHandler LSP.SWorkspaceDidChangeWatchedFiles $-      \ide _ (DidChangeWatchedFilesParams (List fileEvents)) -> liftIO $ do+      \ide vfs _ (DidChangeWatchedFilesParams (List fileEvents)) -> liftIO $ do         -- See Note [File existence cache and LSP file watchers] which explains why we get these notifications and         -- what we do with them         -- filter out files of interest, since we already know all about those@@ -93,10 +106,10 @@             logDebug (ideLogger ide) $ "Watched file events: " <> Text.pack msg             modifyFileExists ide fileEvents'             resetFileStore ide fileEvents'-            setSomethingModified ide [] msg+            setSomethingModified (VFSModified vfs) ide [] msg    , mkPluginNotificationHandler LSP.SWorkspaceDidChangeWorkspaceFolders $-      \ide _ (DidChangeWorkspaceFoldersParams events) -> liftIO $ do+      \ide _ _ (DidChangeWorkspaceFoldersParams events) -> liftIO $ do         let add       = S.union             substract = flip S.difference         modifyWorkspaceFolders ide@@ -104,15 +117,15 @@           . substract (foldMap (S.singleton . parseWorkspaceFolder) (_removed events))    , mkPluginNotificationHandler LSP.SWorkspaceDidChangeConfiguration $-      \ide _ (DidChangeConfigurationParams cfg) -> liftIO $ do+      \ide vfs _ (DidChangeConfigurationParams cfg) -> liftIO $ do         let msg = Text.pack $ show cfg         logDebug (ideLogger ide) $ "Configuration changed: " <> msg         modifyClientSettings ide (const $ Just cfg)-        setSomethingModified ide [toKey GetClientSettings emptyFilePath] "config change"+        setSomethingModified (VFSModified vfs) ide [toKey GetClientSettings emptyFilePath] "config change" -  , mkPluginNotificationHandler LSP.SInitialized $ \ide _ _ -> do+  , mkPluginNotificationHandler LSP.SInitialized $ \ide _ _ _ -> do       --------- Initialize Shake session ---------------------------------------------------------------------      liftIO $ shakeSessionInit ide+      liftIO $ shakeSessionInit (cmapWithPrio LogShake recorder) ide        --------- Set up file watchers ------------------------------------------------------------------------       opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide

@@ -13,7 +13,6 @@ import           Data.Functor import           Data.Generics import           Data.Maybe-import           Data.Text                      (Text, pack) import qualified Data.Text                      as T import           Development.IDE.Core.Rules import           Development.IDE.Core.Shake@@ -21,6 +20,7 @@ import           Development.IDE.GHC.Error      (rangeToRealSrcSpan,                                                  realSrcSpanToRange) import           Development.IDE.Types.Location+import           Development.IDE.GHC.Util       (printOutputable) import           Language.LSP.Server            (LspM) import           Language.LSP.Types             (DocumentSymbol (..),                                                  DocumentSymbolParams (DocumentSymbolParams, _textDocument),@@ -47,7 +47,7 @@                moduleSymbol = hsmodName >>= \case                  (L (locA -> (RealSrcSpan l _)) m) -> Just $                    (defDocumentSymbol l :: DocumentSymbol)-                     { _name  = pprText m+                     { _name  = printOutputable m                      , _kind  = SkFile                      , _range = Range (Position 0 0) (Position maxBound 0) -- _ltop is 0 0 0 0                      }@@ -70,18 +70,18 @@ documentSymbolForDecl :: LHsDecl GhcPs -> Maybe DocumentSymbol documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } }))   = Just (defDocumentSymbol l :: DocumentSymbol)-    { _name   = showRdrName n-                  <> (case pprText fdTyVars of+    { _name   = printOutputable n+                  <> (case printOutputable fdTyVars of                        "" -> ""                        t  -> " " <> t                      )-    , _detail = Just $ pprText fdInfo+    , _detail = Just $ printOutputable fdInfo     , _kind   = SkFunction     } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ ClassDecl { tcdLName = L _ name, tcdSigs, tcdTyVars }))   = Just (defDocumentSymbol l :: DocumentSymbol)-    { _name     = showRdrName name-                    <> (case pprText tcdTyVars of+    { _name     = printOutputable name+                    <> (case printOutputable tcdTyVars of                          "" -> ""                          t  -> " " <> t                        )@@ -90,7 +90,7 @@     , _children =       Just $ List         [ (defDocumentSymbol l :: DocumentSymbol)-            { _name           = showRdrName n+            { _name           = printOutputable n             , _kind           = SkMethod             , _selectionRange = realSrcSpanToRange l'             }@@ -100,12 +100,12 @@     } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ DataDecl { tcdLName = L _ name, tcdDataDefn = HsDataDefn { dd_cons } }))   = Just (defDocumentSymbol l :: DocumentSymbol)-    { _name     = showRdrName name+    { _name     = printOutputable name     , _kind     = SkStruct     , _children =       Just $ List         [ (defDocumentSymbol l :: DocumentSymbol)-            { _name           = showRdrName n+            { _name           = printOutputable n             , _kind           = SkConstructor             , _selectionRange = realSrcSpanToRange l' #if MIN_VERSION_ghc(9,2,0)@@ -123,7 +123,7 @@   where     cvtFld :: LFieldOcc GhcPs -> Maybe DocumentSymbol     cvtFld (L (RealSrcSpan l _) n) = Just $ (defDocumentSymbol l :: DocumentSymbol)-                { _name = showRdrName (unLoc (rdrNameFieldOcc n))+                { _name = printOutputable (unLoc (rdrNameFieldOcc n))                 , _kind = SkField                 }     cvtFld _  = Nothing@@ -138,7 +138,7 @@     -- | Extract the record fields of a constructor     conArgRecordFields (RecCon (L _ lcdfs)) = Just $ List       [ (defDocumentSymbol l :: DocumentSymbol)-          { _name = showRdrName n+          { _name = printOutputable n           , _kind = SkField           }       | L _ cdf <- lcdfs@@ -147,12 +147,12 @@     conArgRecordFields _ = Nothing #endif documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ SynDecl { tcdLName = L (locA -> (RealSrcSpan l' _)) n })) = Just-  (defDocumentSymbol l :: DocumentSymbol) { _name           = showRdrName n+  (defDocumentSymbol l :: DocumentSymbol) { _name           = printOutputable n                                           , _kind           = SkTypeParameter                                           , _selectionRange = realSrcSpanToRange l'                                           } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (InstD _ ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } }))-  = Just (defDocumentSymbol l :: DocumentSymbol) { _name = pprText cid_poly_ty+  = Just (defDocumentSymbol l :: DocumentSymbol) { _name = printOutputable cid_poly_ty                                                  , _kind = SkInterface                                                  } #if MIN_VERSION_ghc(9,2,0)@@ -161,8 +161,8 @@ documentSymbolForDecl (L (RealSrcSpan l _) (InstD _ DataFamInstD { dfid_inst = DataFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } })) #endif   = Just (defDocumentSymbol l :: DocumentSymbol)-    { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords-                (map pprText feqn_pats)+    { _name = printOutputable (unLoc feqn_tycon) <> " " <> T.unwords+                (map printOutputable feqn_pats)     , _kind = SkInterface     } #if MIN_VERSION_ghc(9,2,0)@@ -171,24 +171,24 @@ documentSymbolForDecl (L (RealSrcSpan l _) (InstD _ TyFamInstD { tfid_inst = TyFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } })) #endif   = Just (defDocumentSymbol l :: DocumentSymbol)-    { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords-                (map pprText feqn_pats)+    { _name = printOutputable (unLoc feqn_tycon) <> " " <> T.unwords+                (map printOutputable feqn_pats)     , _kind = SkInterface     } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (DerivD _ DerivDecl { deriv_type })) =   gfindtype deriv_type <&> \(L (_ :: SrcSpan) name) ->-    (defDocumentSymbol l :: DocumentSymbol) { _name = pprText @(HsType GhcPs)+    (defDocumentSymbol l :: DocumentSymbol) { _name = printOutputable @(HsType GhcPs)                                               name                                             , _kind = SkInterface                                             } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (ValD _ FunBind{fun_id = L _ name})) = Just     (defDocumentSymbol l :: DocumentSymbol)-      { _name   = showRdrName name+      { _name   = printOutputable name       , _kind   = SkFunction       } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (ValD _ PatBind{pat_lhs})) = Just     (defDocumentSymbol l :: DocumentSymbol)-      { _name   = pprText pat_lhs+      { _name   = printOutputable pat_lhs       , _kind   = SkFunction       } @@ -204,7 +204,7 @@                   ForeignExport{} -> Just "export"                   XForeignDecl{}  -> Nothing     }-  where name = showRdrName $ unLoc $ fd_name x+  where name = printOutputable $ unLoc $ fd_name x  documentSymbolForDecl _ = Nothing @@ -228,7 +228,7 @@ documentSymbolForImport :: LImportDecl GhcPs -> Maybe DocumentSymbol documentSymbolForImport (L (locA -> (RealSrcSpan l _)) ImportDecl { ideclName, ideclQualified }) = Just   (defDocumentSymbol l :: DocumentSymbol)-    { _name   = "import " <> pprText ideclName+    { _name   = "import " <> printOutputable ideclName     , _kind   = SkModule #if MIN_VERSION_ghc(8,10,0)     , _detail = case ideclQualified of { NotQualified -> Nothing; _ -> Just "qualified" }@@ -248,12 +248,6 @@   _selectionRange = realSrcSpanToRange l   _children       = Nothing   _tags           = Nothing--showRdrName :: RdrName -> Text-showRdrName = pprText--pprText :: Outputable a => a -> Text-pprText = pack . showSDocUnsafe . ppr  -- the version of getConNames for ghc9 is restricted to only the renaming phase #if !MIN_VERSION_ghc(9,2,0)

@@ -22,6 +22,7 @@ import           Language.LSP.Server          (Handlers, LspM) import qualified Language.LSP.Server          as LSP import           Language.LSP.Types+import           Language.LSP.VFS import           UnliftIO.Chan  data ReactorMessage@@ -48,14 +49,16 @@ notificationHandler   :: forall (m :: Method FromClient Notification) c. (HasTracing (MessageParams m)) =>      SMethod m-  -> (IdeState -> MessageParams m -> LspM c ())+  -> (IdeState -> VFS -> MessageParams m -> LspM c ())   -> Handlers (ServerM c) notificationHandler m k = LSP.notificationHandler m $ \NotificationMessage{_params,_method}-> do   (chan,ide) <- ask   env <- LSP.getLspEnv+  -- Take a snapshot of the VFS state on every notification+  -- We only need to do this here because the VFS state is only updated+  -- on notifications+  vfs <- LSP.getVirtualFiles   let trace x = otTracedHandler "Notification" (show _method) $ \sp -> do         traceWithSpan sp _params         x-  writeChan chan $ ReactorNotification (trace $ LSP.runLspT env $ k ide _params)--+  writeChan chan $ ReactorNotification (trace $ LSP.runLspT env $ k ide vfs _params)

@@ -8,13 +8,14 @@ ,isLSP ,commandP ,defaultMain-,testing) where-import           Control.Concurrent.Extra              (newLock, withLock,-                                                        withNumCapabilities)+,testing+,Log(..)+) where+import           Control.Concurrent.Extra              (withNumCapabilities) import           Control.Concurrent.STM.Stats          (atomically,                                                         dumpSTMStats)-import           Control.Exception.Safe                (Exception (displayException),-                                                        catchAny)+import           Control.Exception.Safe                (SomeException, catchAny,+                                                        displayException) import           Control.Monad.Extra                   (concatMapM, unless,                                                         when) import qualified Data.Aeson.Encode.Pretty              as A@@ -26,18 +27,16 @@                                                         nub, nubOrd, partition) import           Data.Maybe                            (catMaybes, isJust) import qualified Data.Text                             as T-import qualified Data.Text.IO                          as T import           Data.Text.Lazy.Encoding               (decodeUtf8) import qualified Data.Text.Lazy.IO                     as LT import           Data.Typeable                         (typeOf) import           Development.IDE                       (Action, GhcVersion (..),-                                                        Priority (Debug), Rules,+                                                        Priority (Debug, Error), Rules,                                                         ghcVersion,                                                         hDuplicateTo') import           Development.IDE.Core.Debouncer        (Debouncer,                                                         newAsyncDebouncer)-import           Development.IDE.Core.FileStore        (isWatchSupported,-                                                        makeVFSHandle)+import           Development.IDE.Core.FileStore        (isWatchSupported) import           Development.IDE.Core.IdeConfiguration (IdeConfiguration (..),                                                         registerIdeConfiguration) import           Development.IDE.Core.OfInterest       (FileOfInterestStatus (OnDisk),@@ -50,17 +49,23 @@                                                         TypeCheck (TypeCheck)) import           Development.IDE.Core.Rules            (GhcSessionIO (GhcSessionIO),                                                         mainRule)+import qualified Development.IDE.Core.Rules            as Rules import           Development.IDE.Core.Service          (initialise, runAction)+import qualified Development.IDE.Core.Service          as Service import           Development.IDE.Core.Shake            (IdeState (shakeExtras),                                                         ShakeExtras (state),                                                         shakeSessionInit, uses)+import qualified Development.IDE.Core.Shake            as Shake import           Development.IDE.Core.Tracing          (measureMemory) import           Development.IDE.Graph                 (action) import           Development.IDE.LSP.LanguageServer    (runLanguageServer)+import qualified Development.IDE.LSP.LanguageServer    as LanguageServer import           Development.IDE.Main.HeapStats        (withHeapStats)+import qualified Development.IDE.Main.HeapStats        as HeapStats import           Development.IDE.Plugin                (Plugin (pluginHandlers, pluginModifyDynflags, pluginRules)) import           Development.IDE.Plugin.HLS            (asGhcIdePlugin)-import qualified Development.IDE.Plugin.HLS.GhcIde     as Ghcide+import qualified Development.IDE.Plugin.HLS            as PluginHLS+import qualified Development.IDE.Plugin.HLS.GhcIde     as GhcIde import qualified Development.IDE.Plugin.Test           as Test import           Development.IDE.Session               (SessionLoadingOptions,                                                         getHieDbLoc,@@ -68,11 +73,14 @@                                                         retryOnSqliteBusy,                                                         runWithDb,                                                         setInitialDynFlags)+import qualified Development.IDE.Session               as Session import           Development.IDE.Types.Location        (NormalizedUri,                                                         toNormalizedFilePath')-import           Development.IDE.Types.Logger          (Logger (Logger),-                                                        Priority (Info),-                                                        logDebug, logInfo)+import           Development.IDE.Types.Logger          (Logger, Pretty (pretty),+                                                        Priority (Info, Warning),+                                                        Recorder, WithPriority,+                                                        cmapWithPrio, logWith,+                                                        vsep, (<+>)) import           Development.IDE.Types.Options         (IdeGhcSession,                                                         IdeOptions (optCheckParents, optCheckProject, optReportProgress, optRunSubset),                                                         IdeTesting (IdeTesting),@@ -118,10 +126,49 @@                                                         hSetEncoding, stderr,                                                         stdin, stdout, utf8) import           System.Random                         (newStdGen)-import           System.Time.Extra                     (offsetTime,+import           System.Time.Extra                     (Seconds, offsetTime,                                                         showDuration) import           Text.Printf                           (printf) +data Log+  = LogHeapStats !HeapStats.Log+  | LogLspStart+  | LogLspStartDuration !Seconds+  | LogShouldRunSubset !Bool+  | LogOnlyPartialGhc9Support+  | LogSetInitialDynFlagsException !SomeException+  | LogService Service.Log+  | LogShake Shake.Log+  | LogGhcIde GhcIde.Log+  | LogLanguageServer LanguageServer.Log+  | LogSession Session.Log+  | LogPluginHLS PluginHLS.Log+  | LogRules Rules.Log+  deriving Show++instance Pretty Log where+  pretty = \case+    LogHeapStats log -> pretty log+    LogLspStart ->+      vsep+        [ "Staring LSP server..."+        , "If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option!"]+    LogLspStartDuration duration ->+      "Started LSP server in" <+> pretty (showDuration duration)+    LogShouldRunSubset shouldRunSubset ->+      "shouldRunSubset:" <+> pretty shouldRunSubset+    LogOnlyPartialGhc9Support ->+      "Currently, HLS supports GHC 9 only partially. See [issue #297](https://github.com/haskell/haskell-language-server/issues/297) for more detail."+    LogSetInitialDynFlagsException e ->+      "setInitialDynFlags:" <+> pretty (displayException e)+    LogService log -> pretty log+    LogShake log -> pretty log+    LogGhcIde log -> pretty log+    LogLanguageServer log -> pretty log+    LogSession log -> pretty log+    LogPluginHLS log -> pretty log+    LogRules log -> pretty log+ data Command     = Check [FilePath]  -- ^ Typecheck some paths and print diagnostics. Exit code is the number of failures     | Db {hieOptions ::  HieDb.Options, hieCommand :: HieDb.Command}@@ -132,7 +179,6 @@     | Custom {ideCommand :: IdeCommand IdeState} -- ^ User defined     deriving Show - -- TODO move these to hiedb deriving instance Show HieDb.Command deriving instance Show HieDb.Options@@ -144,8 +190,8 @@ commandP :: IdePlugins IdeState -> Parser Command commandP plugins =     hsubparser(command "typecheck" (info (Check <$> fileCmd) fileInfo)-            <> command "hiedb" (info (Db <$> HieDb.optParser "" True <*> HieDb.cmdParser <**> helper) hieInfo)-            <> command "lsp" (info (pure LSP <**> helper) lspInfo)+            <> command "hiedb" (info (Db <$> HieDb.optParser "" True <*> HieDb.cmdParser) hieInfo)+            <> command "lsp" (info (pure LSP) lspInfo)             <> command "vscode-extension-schema" extensionSchemaCommand             <> command "generate-default-config" generateDefaultConfigCommand             <> pluginCommands@@ -187,18 +233,16 @@     , argsThreads               :: Maybe Natural     } -instance Default Arguments where-    def = defaultArguments Info -defaultArguments :: Priority -> Arguments-defaultArguments priority = Arguments+defaultArguments :: Recorder (WithPriority Log) -> Logger -> Arguments+defaultArguments recorder logger = Arguments         { argsProjectRoot = Nothing         , argsOTMemoryProfiling = False         , argCommand = LSP-        , argsLogger = stderrLogger priority-        , argsRules = mainRule def >> action kick+        , argsLogger = pure logger+        , argsRules = mainRule (cmapWithPrio LogRules recorder) def >> action kick         , argsGhcidePlugin = mempty-        , argsHlsPlugins = pluginDescToIdePlugins Ghcide.descriptors+        , argsHlsPlugins = pluginDescToIdePlugins (GhcIde.descriptors (cmapWithPrio LogGhcIde recorder))         , argsSessionLoadingOptions = def         , argsIdeOptions = \config ghcSession -> (defaultIdeOptions ghcSession)             { optCheckProject = pure $ checkProject config@@ -226,35 +270,39 @@                 return newStdout         } -testing :: Arguments-testing = (defaultArguments Debug) {-    argsHlsPlugins = pluginDescToIdePlugins $-        idePluginsToPluginDesc (argsHlsPlugins def)-        ++ [Test.blockCommandDescriptor "block-command", Test.plugin],-    argsIdeOptions = \config sessionLoader ->-            let defOptions = argsIdeOptions def config sessionLoader-            in defOptions {-                optTesting = IdeTesting True-            }-} --- | Cheap stderr logger that relies on LineBuffering-stderrLogger :: Priority -> IO Logger-stderrLogger logLevel = do-    lock <- newLock-    return $ Logger $ \p m -> when (p >= logLevel) $ withLock lock $-        T.hPutStrLn stderr $ "[" <> T.pack (show p) <> "] " <> m+testing :: Recorder (WithPriority Log) -> Logger -> Arguments+testing recorder logger =+  let+    arguments@Arguments{ argsHlsPlugins, argsIdeOptions } = defaultArguments recorder logger+    hlsPlugins = pluginDescToIdePlugins $+      idePluginsToPluginDesc argsHlsPlugins+      ++ [Test.blockCommandDescriptor "block-command", Test.plugin]+    ideOptions = \config sessionLoader ->+      let+        defOptions = argsIdeOptions config sessionLoader+      in+        defOptions{ optTesting = IdeTesting True }+  in+    arguments+      { argsHlsPlugins = hlsPlugins+      , argsIdeOptions = ideOptions+      } -defaultMain :: Arguments -> IO ()-defaultMain Arguments{..} = flip withHeapStats fun =<< argsLogger++defaultMain :: Recorder (WithPriority Log) -> Arguments -> IO ()+defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats recorder) fun  where+  log :: Priority -> Log -> IO ()+  log = logWith recorder+   fun = do     setLocaleEncoding utf8     pid <- T.pack . show <$> getProcessID     logger <- argsLogger     hSetBuffering stderr LineBuffering -    let hlsPlugin = asGhcIdePlugin argsHlsPlugins+    let hlsPlugin = asGhcIdePlugin (cmapWithPrio LogPluginHLS recorder) argsHlsPlugins         hlsCommands = allLspCmdIds' pid argsHlsPlugins         plugins = hlsPlugin <> argsGhcidePlugin         options = argsLspOptions { LSP.executeCommandCommands = LSP.executeCommandCommands argsLspOptions <> Just hlsCommands }@@ -274,29 +322,29 @@             LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToDefaultConfig argsHlsPlugins         LSP -> withNumCapabilities (maybe (numProcessors `div` 2) fromIntegral argsThreads) $ do             t <- offsetTime-            logInfo logger "Starting LSP server..."-            logInfo logger "If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option!"-            runLanguageServer options inH outH argsGetHieDbLoc argsDefaultHlsConfig argsOnConfigChange (pluginHandlers plugins) $ \env vfs rootPath withHieDb hieChan -> do+            log Info LogLspStart++            runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsGetHieDbLoc argsDefaultHlsConfig argsOnConfigChange (pluginHandlers plugins) $ \env rootPath withHieDb hieChan -> do                 traverse_ IO.setCurrentDirectory rootPath                 t <- t-                logInfo logger $ T.pack $ "Started LSP server in " ++ showDuration t+                log Info $ LogLspStartDuration t                  dir <- maybe IO.getCurrentDirectory return rootPath                  -- We want to set the global DynFlags right now, so that we can use                 -- `unsafeGlobalDynFlags` even before the project is configured                 _mlibdir <--                    setInitialDynFlags logger dir argsSessionLoadingOptions-                        `catchAny` (\e -> (logDebug logger $ T.pack $ "setInitialDynFlags: " ++ displayException e) >> pure Nothing)-+                    setInitialDynFlags (cmapWithPrio LogSession recorder) dir argsSessionLoadingOptions+                        -- TODO: should probably catch/log/rethrow at top level instead+                        `catchAny` (\e -> log Error (LogSetInitialDynFlagsException e) >> pure Nothing) -                sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions dir+                sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir                 config <- LSP.runLspT env LSP.getConfig                 let def_options = argsIdeOptions config sessionLoader                  -- disable runSubset if the client doesn't support watched files                 runSubset <- (optRunSubset def_options &&) <$> LSP.runLspT env isWatchSupported-                logDebug logger $ T.pack $ "runSubset: " <> show runSubset+                log Debug $ LogShouldRunSubset runSubset                  let options = def_options                             { optReportProgress = clientSupportsProgress caps@@ -306,24 +354,22 @@                     caps = LSP.resClientCapabilities env                 -- FIXME: Remove this after GHC 9 gets fully supported                 when (ghcVersion == GHC90) $-                    hPutStrLn stderr $-                        "Currently, HLS supports GHC 9 only partially. "-                        <> "See [issue #297](https://github.com/haskell/haskell-language-server/issues/297) for more detail."+                    log Warning LogOnlyPartialGhc9Support                 initialise+                    (cmapWithPrio LogService recorder)                     argsDefaultHlsConfig                     rules                     (Just env)                     logger                     debouncer                     options-                    vfs                     withHieDb                     hieChan             dumpSTMStats         Check argFiles -> do           dir <- maybe IO.getCurrentDirectory return argsProjectRoot           dbLoc <- getHieDbLoc dir-          runWithDb logger dbLoc $ \hiedb hieChan -> do+          runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan -> do             -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error             hSetEncoding stdout utf8             hSetEncoding stderr utf8@@ -344,16 +390,15 @@             putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1]             when (n > 0) $ putStrLn $ "  (" ++ intercalate ", " (catMaybes ucradles) ++ ")"             putStrLn "\nStep 3/4: Initializing the IDE"-            vfs <- makeVFSHandle-            sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions dir+            sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir             let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader                 options = def_options                         { optCheckParents = pure NeverCheck                         , optCheckProject = pure False                         , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins                         }-            ide <- initialise argsDefaultHlsConfig rules Nothing logger debouncer options vfs hiedb hieChan-            shakeSessionInit ide+            ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig rules Nothing logger debouncer options hiedb hieChan+            shakeSessionInit (cmapWithPrio LogShake recorder) ide             registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing)              putStrLn "\nStep 4/4: Type checking the files"@@ -388,26 +433,25 @@             root <-  maybe IO.getCurrentDirectory return argsProjectRoot             dbLoc <- getHieDbLoc root             hPutStrLn stderr $ "Using hiedb at: " ++ dbLoc-            mlibdir <- setInitialDynFlags logger root def+            mlibdir <- setInitialDynFlags (cmapWithPrio LogSession recorder) root def             rng <- newStdGen             case mlibdir of                 Nothing     -> exitWith $ ExitFailure 1-                Just libdir -> retryOnSqliteBusy logger rng (HieDb.runCommand libdir opts{HieDb.database = dbLoc} cmd)+                Just libdir -> retryOnSqliteBusy (cmapWithPrio LogSession recorder) rng (HieDb.runCommand libdir opts{HieDb.database = dbLoc} cmd)          Custom (IdeCommand c) -> do           root <-  maybe IO.getCurrentDirectory return argsProjectRoot           dbLoc <- getHieDbLoc root-          runWithDb logger dbLoc $ \hiedb hieChan -> do-            vfs <- makeVFSHandle-            sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions "."+          runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan -> do+            sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions "."             let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader                 options = def_options                     { optCheckParents = pure NeverCheck                     , optCheckProject = pure False                     , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins                     }-            ide <- initialise argsDefaultHlsConfig rules Nothing logger debouncer options vfs hiedb hieChan-            shakeSessionInit ide+            ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig rules Nothing logger debouncer options hiedb hieChan+            shakeSessionInit (cmapWithPrio LogShake recorder) ide             registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing)             c ide 

@@ -1,53 +1,75 @@-{-# LANGUAGE NumericUnderscores #-}
--- | Logging utilities for reporting heap statistics
-module Development.IDE.Main.HeapStats ( withHeapStats ) where
-
-import           Control.Concurrent
-import           Control.Concurrent.Async
-import           Control.Monad
-import qualified Data.Text                    as T
-import           Data.Word
-import           Development.IDE.Types.Logger (Logger, logInfo)
-import           GHC.Stats
-import           Text.Printf                  (printf)
-
--- | Interval at which to report the latest heap statistics.
-heapStatsInterval :: Int
-heapStatsInterval = 60_000_000 -- 60s
-
--- | Report the live bytes and heap size at the last major collection.
-logHeapStats :: Logger -> IO ()
-logHeapStats l = do
-  stats <- getRTSStats
-  -- live_bytes is the total amount of live memory in a program
-  -- (corresponding to the amount on a heap profile)
-  let live_bytes = gcdetails_live_bytes (gc stats)
-  -- heap_size is the total amount of memory the RTS is using
-  -- this corresponds closer to OS memory usage
-      heap_size  = gcdetails_mem_in_use_bytes (gc stats)
-      format :: Word64 -> T.Text
-      format m = T.pack (printf "%.2fMB" (fromIntegral @Word64 @Double m / 1e6))
-      message = "Live bytes: " <> format live_bytes  <> " " <>
-                "Heap size: " <> format heap_size
-  logInfo l message
-
--- | An action which logs heap statistics at the 'heapStatsInterval'
-heapStatsThread :: Logger -> IO r
-heapStatsThread l = forever $ do
-  threadDelay heapStatsInterval
-  logHeapStats l
-
--- | A helper function which lauches the 'heapStatsThread' and kills it
--- appropiately when the inner action finishes. It also checks to see
--- if `-T` is enabled.
-withHeapStats :: Logger -> IO r -> IO r
-withHeapStats l k = do
-  enabled <- getRTSStatsEnabled
-  if enabled
-    then do
-      logInfo l ("Logging heap statistics every "
-                  <> T.pack (printf "%.2fs" (fromIntegral @Int @Double heapStatsInterval / 1e6)))
-      withAsync (heapStatsThread l) (const k)
-    else do
-      logInfo l "Heap statistics are not enabled (RTS option -T is needed)"
-      k
+{-# LANGUAGE NumericUnderscores #-}+-- | Logging utilities for reporting heap statistics+module Development.IDE.Main.HeapStats ( withHeapStats, Log(..)) where++import           Control.Concurrent+import           Control.Concurrent.Async+import           Control.Monad+import           Data.Word+import           Development.IDE.Types.Logger (Pretty (pretty), Priority (Info),+                                               Recorder, WithPriority, hsep,+                                               logWith, (<+>))+import           GHC.Stats+import           Text.Printf                  (printf)++data Log+  = LogHeapStatsPeriod !Int+  | LogHeapStatsDisabled+  | LogHeapStats !Word64 !Word64+  deriving Show++instance Pretty Log where+  pretty log = case log of+    LogHeapStatsPeriod period ->+      "Logging heap statistics every" <+> pretty (toFormattedSeconds period)+    LogHeapStatsDisabled ->+      "Heap statistics are not enabled (RTS option -T is needed)"+    LogHeapStats liveBytes heapSize ->+      hsep+        [ "Live bytes:"+        , pretty (toFormattedMegabytes liveBytes)+        , "Heap size:"+        , pretty (toFormattedMegabytes heapSize) ]+    where+      toFormattedSeconds :: Int -> String+      toFormattedSeconds s = printf "%.2fs" (fromIntegral @Int @Double s / 1e6)++      toFormattedMegabytes :: Word64 -> String+      toFormattedMegabytes b = printf "%.2fMB" (fromIntegral @Word64 @Double b / 1e6)++-- | Interval at which to report the latest heap statistics.+heapStatsInterval :: Int+heapStatsInterval = 60_000_000 -- 60s++-- | Report the live bytes and heap size at the last major collection.+logHeapStats :: Recorder (WithPriority Log) -> IO ()+logHeapStats l = do+  stats <- getRTSStats+  -- live_bytes is the total amount of live memory in a program+  -- (corresponding to the amount on a heap profile)+  let live_bytes = gcdetails_live_bytes (gc stats)+  -- heap_size is the total amount of memory the RTS is using+  -- this corresponds closer to OS memory usage+      heap_size  = gcdetails_mem_in_use_bytes (gc stats)+  logWith l Info $ LogHeapStats live_bytes heap_size++-- | An action which logs heap statistics at the 'heapStatsInterval'+heapStatsThread :: Recorder (WithPriority Log) -> IO r+heapStatsThread l = forever $ do+  threadDelay heapStatsInterval+  logHeapStats l++-- | A helper function which lauches the 'heapStatsThread' and kills it+-- appropiately when the inner action finishes. It also checks to see+-- if `-T` is enabled.+withHeapStats :: Recorder (WithPriority Log) -> IO r -> IO r+withHeapStats l k = do+  enabled <- getRTSStatsEnabled+  if enabled+    then do+      logWith l Info $ LogHeapStatsPeriod heapStatsInterval+      withAsync (heapStatsThread l) (const k)+    else do+      logWith l Info LogHeapStatsDisabled+      k+

@@ -48,15 +48,13 @@ import           Development.IDE.GHC.Compat.Util import           Development.IDE.GHC.Error import           Development.IDE.GHC.ExactPrint-import           Development.IDE.GHC.Util                          (prettyPrint,+import           Development.IDE.GHC.Util                          (printOutputable,                                                                     printRdrName,-                                                                    traceAst,-                                                                    unsafePrintSDoc)+                                                                    traceAst) import           Development.IDE.Plugin.CodeAction.Args import           Development.IDE.Plugin.CodeAction.ExactPrint import           Development.IDE.Plugin.CodeAction.PositionIndexed import           Development.IDE.Plugin.TypeLenses                 (suggestSignature)-import           Development.IDE.Spans.Common import           Development.IDE.Types.Exports import           Development.IDE.Types.Location import           Development.IDE.Types.Options@@ -546,7 +544,7 @@       isTheBinding span = srcSpanToRange span == Just _range        isSameName :: IdP GhcPs -> String -> Bool-      isSameName x name = showSDocUnsafe (ppr x) == name+      isSameName x name = T.unpack (printOutputable x) == name  data ExportsAs = ExportName | ExportPattern | ExportFamily | ExportAll   deriving (Eq)@@ -711,7 +709,7 @@       , _start `isInsideSrcSpan` l]     , nextLineP <- Position{ _line = _line lastLineP + 1, _character = 0}     = [ ("Define " <> sig-        , [TextEdit (Range nextLineP nextLineP) (T.unlines ["", sig, name <> " = error \"not implemented\""])]+        , [TextEdit (Range nextLineP nextLineP) (T.unlines ["", sig, name <> " = _"])]         )]     | otherwise = []   where@@ -719,7 +717,6 @@     sig = name <> colon <> T.dropWhileEnd isSpace typ     ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}} = parsedModule - suggestFillTypeWildcard :: Diagnostic -> [(T.Text, TextEdit)] suggestFillTypeWildcard Diagnostic{_range=_range,..} -- Foo.hs:3:8: error:@@ -1014,7 +1011,7 @@ occursUnqualified _ _ = False  symbolOccursIn :: T.Text -> IE GhcPs -> Bool-symbolOccursIn symb = any ((== symb). showNameWithoutUniques) . ieNames+symbolOccursIn symb = any ((== symb). printOutputable) . ieNames  targetModuleName :: ModuleTarget -> ModuleName targetModuleName ImplicitPrelude{} = mkModuleName "Prelude"@@ -1048,12 +1045,12 @@          in Right <$> [ if parensed                 then Rewrite (rangeToSrcSpan "<dummy>" _range) $ \df ->                     liftParseAST @(HsExpr GhcPs) df $-                    prettyPrint $+                    T.unpack $ printOutputable $                         HsVar @GhcPs noExtField $                             reLocA $ L (mkGeneralSrcSpan  "") rdr                 else Rewrite (rangeToSrcSpan "<dummy>" _range) $ \df ->                     liftParseAST @RdrName df $-                    prettyPrint $ L (mkGeneralSrcSpan  "") rdr+                    T.unpack $ printOutputable $ L (mkGeneralSrcSpan  "") rdr             ] findImportDeclByRange :: [LImportDecl GhcPs] -> Range -> Maybe (LImportDecl GhcPs) findImportDeclByRange xs range = find (\(L (locA -> l) _)-> srcSpanToRange l == Just range) xs@@ -1424,7 +1421,7 @@      symImp             | Just symbol <- mSymbol               , symOcc <- mkVarOcc $ T.unpack symbol =-              " (" <> T.pack (unsafePrintSDoc (parenSymOcc symOcc $ ppr symOcc)) <> ")"+              " (" <> printOutputable (parenSymOcc symOcc $ ppr symOcc) <> ")"             | otherwise = ""      impStmt =        "import "@@ -1530,14 +1527,22 @@       curr <- textInRange range <$> contents       pure $ "`" `T.isPrefixOf` curr && "`" `T.isSuffixOf` curr ++-- | Extract the type and surround it in parentheses except in obviously safe cases.+--+-- Inferring when parentheses are actually needed around the type signature would+-- require understanding both the precedence of the context of the hole and of+-- the signature itself. Inserting them (almost) unconditionally is ugly but safe. extractWildCardTypeSignature :: T.Text -> T.Text-extractWildCardTypeSignature =-  -- inferring when parens are actually needed around the type signature would-  -- require understanding both the precedence of the context of the _ and of-  -- the signature itself. Inserting them unconditionally is ugly but safe.-  ("(" `T.append`) . (`T.append` ")") .-  T.takeWhile (/='’') . T.dropWhile (=='‘') . T.dropWhile (/='‘') .-  snd . T.breakOnEnd "standing for "+extractWildCardTypeSignature msg = (if enclosed || not application then id else bracket) signature+  where+    msgSigPart = snd $ T.breakOnEnd "standing for " msg+    signature = T.takeWhile (/='’') . T.dropWhile (=='‘') . T.dropWhile (/='‘') $ msgSigPart+    -- parenthesize type applications, e.g. (Maybe Char)+    application = any isSpace . T.unpack $ signature+    -- do not add extra parentheses to lists, tuples and already parenthesized types+    enclosed = not (T.null signature) && (T.head signature, T.last signature) `elem` [('(',')'), ('[',']')]+    bracket = ("(" `T.append`) . (`T.append` ")")  extractRenamableTerms :: T.Text -> [T.Text] extractRenamableTerms msg@@ -1610,32 +1615,32 @@     b' = wrapOperatorInParens . unqualify $ b #if !MIN_VERSION_ghc(9,2,0)     ranges' (L _ (IEThingWith _ thing _  inners labels))-      | showSDocUnsafe (ppr thing) == b' = []+      | T.unpack (printOutputable thing) == b' = []       | otherwise =-          [ locA l' | L l' x <- inners, showSDocUnsafe (ppr x) == b']-          ++ [ l' | L l' x <- labels, showSDocUnsafe (ppr x) == b']+          [ locA l' | L l' x <- inners, T.unpack (printOutputable x) == b']+          ++ [ l' | L l' x <- labels, T.unpack (printOutputable x) == b'] #else     ranges' (L _ (IEThingWith _ thing _  inners))-      | showSDocUnsafe (ppr thing) == b' = []+      | T.unpack (printOutputable thing) == b' = []       | otherwise =-          [ locA l' | L l' x <- inners, showSDocUnsafe (ppr x) == b']+          [ locA l' | L l' x <- inners, T.unpack (printOutputable x) == b'] #endif     ranges' _ = []  rangesForBinding' :: String -> LIE GhcPs -> [SrcSpan]-rangesForBinding' b (L (locA -> l) x@IEVar{}) | showSDocUnsafe (ppr x) == b = [l]-rangesForBinding' b (L (locA -> l) x@IEThingAbs{}) | showSDocUnsafe (ppr x) == b = [l]-rangesForBinding' b (L (locA -> l) (IEThingAll _ x)) | showSDocUnsafe (ppr x) == b = [l]+rangesForBinding' b (L (locA -> l) x@IEVar{}) | T.unpack (printOutputable x) == b = [l]+rangesForBinding' b (L (locA -> l) x@IEThingAbs{}) | T.unpack (printOutputable x) == b = [l]+rangesForBinding' b (L (locA -> l) (IEThingAll _ x)) | T.unpack (printOutputable x) == b = [l] #if !MIN_VERSION_ghc(9,2,0) rangesForBinding' b (L l (IEThingWith _ thing _  inners labels)) #else rangesForBinding' b (L (locA -> l) (IEThingWith _ thing _  inners)) #endif-    | showSDocUnsafe (ppr thing) == b = [l]+    | T.unpack (printOutputable thing) == b = [l]     | otherwise =-        [ locA l' | L l' x <- inners, showSDocUnsafe (ppr x) == b]+        [ locA l' | L l' x <- inners, T.unpack (printOutputable x) == b] #if !MIN_VERSION_ghc(9,2,0)-        ++ [ l' | L l' x <- labels, showSDocUnsafe (ppr x) == b]+        ++ [ l' | L l' x <- labels, T.unpack (printOutputable x) == b] #endif rangesForBinding' _ _ = [] @@ -1726,6 +1731,13 @@       --       -- @P@ and @?@ can be a data type and a constructor, a class and a method,       -- a class and an associated type/data family, etc.++    | ImportAllConstructors T.Text+      -- ^ Import all constructors for a specific data type.+      --+      -- import M (P(..))+      --+      -- @P@ can be a data type or a class.   deriving Show  importStyles :: IdentInfo -> NonEmpty ImportStyle@@ -1734,7 +1746,9 @@     -- Constructors always have to be imported via their parent data type, but     -- methods and associated type/data families can also be imported as     -- top-level exports.-  = ImportViaParent rendered p :| [ImportTopLevel rendered | not isDatacon]+  = ImportViaParent rendered p+      :| [ImportTopLevel rendered | not isDatacon]+      <> [ImportAllConstructors p]   | otherwise   = ImportTopLevel rendered :| [] @@ -1743,15 +1757,19 @@ renderImportStyle (ImportTopLevel x)   = x renderImportStyle (ImportViaParent x p@(T.uncons -> Just ('(', _))) = "type " <> p <> "(" <> x <> ")" renderImportStyle (ImportViaParent x p) = p <> "(" <> x <> ")"+renderImportStyle (ImportAllConstructors p) = p <> "(..)"  -- | Used for extending import lists unImportStyle :: ImportStyle -> (Maybe String, String) unImportStyle (ImportTopLevel x)    = (Nothing, T.unpack x) unImportStyle (ImportViaParent x y) = (Just $ T.unpack y, T.unpack x)+unImportStyle (ImportAllConstructors x) = (Just $ T.unpack x, wildCardSymbol) + quickFixImportKind' :: T.Text -> ImportStyle -> CodeActionKind quickFixImportKind' x (ImportTopLevel _) = CodeActionUnknown $ "quickfix.import." <> x <> ".list.topLevel" quickFixImportKind' x (ImportViaParent _ _) = CodeActionUnknown $ "quickfix.import." <> x <> ".list.withParent"+quickFixImportKind' x (ImportAllConstructors _) = CodeActionUnknown $ "quickfix.import." <> x <> ".list.allConstructors"  quickFixImportKind :: T.Text -> CodeActionKind quickFixImportKind x = CodeActionUnknown $ "quickfix.import." <> x

@@ -65,7 +65,7 @@           pure $ localExports <> pkgExports         _ -> pure mempty   caaIdeOptions <- onceIO $ runAction "GhcideCodeActions.getIdeOptions" state getIdeOptions-  caaParsedModule <- onceIO $ runRule GetParsedModule+  caaParsedModule <- onceIO $ runRule GetParsedModuleWithComments   caaContents <-     onceIO $       runRule GetFileContents >>= \case

@@ -19,6 +19,8 @@   extendImport,   hideSymbol,   liftParseAST,++  wildCardSymbol ) where  import           Control.Applicative@@ -33,7 +35,7 @@ import           Data.Maybe                            (fromJust, isNothing,                                                         mapMaybe) import qualified Data.Text                             as T-import           Development.IDE.GHC.Compat+import           Development.IDE.GHC.Compat hiding (Annotation) import           Development.IDE.GHC.Error import           Development.IDE.GHC.ExactPrint import           Development.IDE.Spans.Common@@ -49,7 +51,7 @@                       DeltaPos (SameLine), EpAnn (..), EpaLocation (EpaDelta),                       IsUnicodeSyntax (NormalSyntax),                       NameAdornment (NameParens), NameAnn (..), addAnns, ann, emptyComments,-                      reAnnL, AnnList (..))+                      reAnnL, AnnList (..), TrailingAnn (AddCommaAnn), addTrailingAnnToA) #endif import           Language.LSP.Types import Development.IDE.GHC.Util@@ -330,6 +332,7 @@ extendImport mparent identifier lDecl@(L l _) =   Rewrite (locA l) $ \df -> do     case mparent of+      -- This will also work for `ImportAllConstructors`       Just parent -> extendImportViaParent df parent identifier lDecl       _           -> extendImportTopLevel identifier lDecl @@ -352,8 +355,8 @@     top <- uniqueSrcSpanT     let rdr = reLocA $ L src $ mkRdrUnqual $ mkVarOcc thing     let alreadyImported =-          showNameWithoutUniques (occName (unLoc rdr))-            `elem` map (showNameWithoutUniques @OccName) (listify (const True) lies)+          printOutputable (occName (unLoc rdr))+            `elem` map (printOutputable @OccName) (listify (const True) lies)     when alreadyImported $       lift (Left $ thing <> " already imported") @@ -374,15 +377,14 @@           transferAnn (L l' lies) (L l' [x]) id         return $ L l it{ideclHiding = Just (hide, L l' $ lies ++ [x])} #else--        x <- pure $ setEntryDP x (SameLine $ if hasSibling then 1 else 0)--        let fixLast = if hasSibling then first addComma else id-            lies' = over _last fixLast lies ++ [x]+        lies' <- addCommaInImportList lies x         return $ L l it{ideclHiding = Just (hide, L l' lies')} #endif extendImportTopLevel _ _ = lift $ Left "Unable to extend the import list" +wildCardSymbol :: String+wildCardSymbol = ".."+ -- | Add an identifier with its parent to import list -- -- extendImportViaParent "Bar" "Cons" AST:@@ -393,6 +395,11 @@ -- import A () --> import A (Bar(Cons)) -- import A (Foo, Bar) --> import A (Foo, Bar(Cons)) -- import A (Foo, Bar()) --> import A (Foo, Bar(Cons))+--+-- extendImportViaParent "Bar" ".." AST:+-- import A () --> import A (Bar(..))+-- import A (Foo, Bar) -> import A (Foo, Bar(..))+-- import A (Foo, Bar()) -> import A (Foo, Bar(..)) extendImportViaParent ::   DynFlags ->   -- | parent (already parenthesized if needs)@@ -428,6 +435,19 @@ #endif     -- ThingWith ie lies' => ThingWith ie (lies' ++ [child])     | parent == unIEWrappedName ie+    , child == wildCardSymbol = do+#if MIN_VERSION_ghc(9,2,0)+        let it' = it{ideclHiding = Just (hide, lies)}+            thing = IEThingWith newl twIE (IEWildcard 2) []+            newl = (\ann -> ann ++ [(AddEpAnn AnnDotdot d0)]) <$> l'''+            lies = L l' $ reverse pre ++ [L l'' thing] ++ xs+        return $ L l it'+#else+        let thing = L l'' (IEThingWith noExtField twIE (IEWildcard 2)  [] [])+        modifyAnnsT (Map.map (\ann -> ann{annsDP = (G AnnDotdot, dp00) : annsDP ann}))+        return $ L l it{ideclHiding = Just (hide, L l' $ reverse pre ++ [thing] ++ xs)}+#endif+    | parent == unIEWrappedName ie     , hasSibling <- not $ null lies' =       do         srcChild <- uniqueSrcSpanT@@ -436,8 +456,8 @@         childRdr <- pure $ setEntryDP childRdr $ SameLine $ if hasSibling then 1 else 0 #endif         let alreadyImported =-              showNameWithoutUniques (occName (unLoc childRdr))-                `elem` map (showNameWithoutUniques @OccName) (listify (const True) lies')+              printOutputable (occName (unLoc childRdr))+                `elem` map (printOutputable @OccName) (listify (const True) lies')         when alreadyImported $           lift (Left $ child <> " already included in " <> parent <> " imports") @@ -452,9 +472,7 @@             lies = L l' $ reverse pre ++                 [L l'' (IEThingWith l''' twIE NoIEWildcard (over _last fixLast lies' ++ [childLIE]))] ++ xs             fixLast = if hasSibling then first addComma else id-        return $ if hasSibling-            then L l it'-            else L l it'+        return $ L l it' #endif   go hide l' pre (x : xs) = go hide l' (x : pre) xs   go hide l' pre []@@ -490,15 +508,41 @@       -- we need change the ann key from `[]` to `:` to keep parens and other anns.       unless hasSibling $         transferAnn (L l' $ reverse pre) (L l' [x]) id++      let lies' = reverse pre ++ [x] #else-          x :: LIE GhcPs = reLocA $ L l'' $ IEThingWith listAnn parentLIE NoIEWildcard [childLIE]           listAnn = epAnn srcParent [AddEpAnn AnnOpenP (epl 1), AddEpAnn AnnCloseP (epl 0)]+          x :: LIE GhcPs = reLocA $ L l'' $ IEThingWith listAnn parentLIE NoIEWildcard [childLIE]++      let hasSibling = not (null pre)+      lies' <- addCommaInImportList (reverse pre) x #endif-      return $ L l it{ideclHiding = Just (hide, L l' $ reverse pre ++ [x])}+      return $ L l it{ideclHiding = Just (hide, L l' lies')} extendImportViaParent _ _ _ _ = lift $ Left "Unable to extend the import list via parent" +#if MIN_VERSION_ghc(9,2,0)+-- Add an item in an import list, taking care of adding comma if needed.+addCommaInImportList :: Monad m =>+  -- | Initial list+  [LocatedAn AnnListItem a]+  -- | Additionnal item+  -> LocatedAn AnnListItem a+  -> m [LocatedAn AnnListItem a]+addCommaInImportList lies x = do+  let hasSibling = not (null lies)+  -- Add the space before the comma+  x <- pure $ setEntryDP x (SameLine $ if hasSibling then 1 else 0)++  -- Add the comma (if needed)+  let+    fixLast = if hasSibling then first addComma else id+    lies' = over _last fixLast lies ++ [x]++  pure lies'+#endif+ unIEWrappedName :: IEWrappedName (IdP GhcPs) -> String-unIEWrappedName (occName -> occ) = showSDocUnsafe $ parenSymOcc occ (ppr occ)+unIEWrappedName (occName -> occ) = T.unpack $ printOutputable $ parenSymOcc occ (ppr occ)  hasParen :: String -> Bool hasParen ('(' : _) = True

@@ -4,6 +4,7 @@  module Development.IDE.Plugin.Completions     ( descriptor+    , Log(..)     ) where  import           Control.Concurrent.Async                     (concurrently)@@ -19,12 +20,14 @@ import qualified Data.Text                                    as T import           Development.IDE.Core.PositionMapping import           Development.IDE.Core.RuleTypes-import           Development.IDE.Core.Service-import           Development.IDE.Core.Shake+import           Development.IDE.Core.Service                 hiding (Log,+                                                               LogShake)+import           Development.IDE.Core.Shake                   hiding (Log)+import qualified Development.IDE.Core.Shake                   as Shake import           Development.IDE.GHC.Compat import           Development.IDE.GHC.Error                    (rangeToSrcSpan) import           Development.IDE.GHC.ExactPrint               (GetAnnotatedParsedSource (GetAnnotatedParsedSource))-import           Development.IDE.GHC.Util                     (prettyPrint)+import           Development.IDE.GHC.Util                     (printOutputable) import           Development.IDE.Graph import           Development.IDE.Plugin.CodeAction            (newImport,                                                                newImportToEdit)@@ -36,6 +39,10 @@                                                                hscEnv) import qualified Development.IDE.Types.KnownTargets           as KT import           Development.IDE.Types.Location+import           Development.IDE.Types.Logger                 (Pretty (pretty),+                                                               Recorder,+                                                               WithPriority,+                                                               cmapWithPrio) import           GHC.Exts                                     (fromList, toList) import           Ide.Plugin.Config                            (Config) import           Ide.Types@@ -44,17 +51,23 @@ import qualified Language.LSP.VFS                             as VFS import           Text.Fuzzy.Parallel                          (Scored (..)) -descriptor :: PluginId -> PluginDescriptor IdeState-descriptor plId = (defaultPluginDescriptor plId)-  { pluginRules = produceCompletions+data Log = LogShake Shake.Log deriving Show++instance Pretty Log where+  pretty = \case+    LogShake log -> pretty log++descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState+descriptor recorder plId = (defaultPluginDescriptor plId)+  { pluginRules = produceCompletions recorder   , pluginHandlers = mkPluginHandler STextDocumentCompletion getCompletionsLSP   , pluginCommands = [extendImportCommand]   , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties}   } -produceCompletions :: Rules ()-produceCompletions = do-    define $ \LocalCompletions file -> do+produceCompletions :: Recorder (WithPriority Log) -> Rules ()+produceCompletions recorder = do+    define (cmapWithPrio LogShake recorder) $ \LocalCompletions file -> do         let uri = fromNormalizedUri $ normalizedFilePathToUri file         pm <- useWithStale GetParsedModule file         case pm of@@ -62,7 +75,7 @@                 let cdata = localCompletionsForParsedModule uri pm                 return ([], Just cdata)             _ -> return ([], Nothing)-    define $ \NonLocalCompletions file -> do+    define (cmapWithPrio LogShake recorder) $ \NonLocalCompletions file -> do         -- For non local completions we avoid depending on the parsed module,         -- synthetizing a fake module with an empty body from the buffer         -- in the ModSummary, which preserves all the imports@@ -200,7 +213,7 @@           <> "’ from "           <> importName           <> " (at "-          <> T.pack (prettyPrint srcSpan)+          <> printOutputable srcSpan           <> ")"     void $ LSP.sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ())   return $ Right Null

@@ -31,7 +31,7 @@ import           Data.Functor import qualified Data.HashMap.Strict                      as HM import qualified Data.HashSet                             as HashSet-import           Data.Monoid                              (First(..))+import           Data.Monoid                              (First (..)) import           Data.Ord                                 (Down (Down)) import qualified Data.Set                                 as Set import           Development.IDE.Core.Compile@@ -63,7 +63,7 @@ import           Language.LSP.Types import           Language.LSP.Types.Capabilities import qualified Language.LSP.VFS                         as VFS-import           Text.Fuzzy.Parallel                      (Scored (score_),+import           Text.Fuzzy.Parallel                      (Scored (score),                                                            original)  -- Chunk size used for parallelizing fuzzy matching@@ -204,7 +204,7 @@   where kind = Just compKind         docs' = imported : spanDocToMarkdown docs         imported = case provenance of-          Local pos  -> "*Defined at " <> pprLineCol (srcSpanStart pos) <> " in this module*\n'"+          Local pos  -> "*Defined at " <> pprLineCol (srcSpanStart pos) <> " in this module*\n"           ImportedFrom mod -> "*Imported from '" <> mod <> "'*\n"           DefinedIn mod -> "*Defined in '" <> mod <> "'*\n"         colon = if optNewColonConvention then ": " else ":: "@@ -214,7 +214,7 @@         pprLineCol :: SrcLoc -> T.Text         pprLineCol (UnhelpfulLoc fs) = T.pack $ unpackFS fs         pprLineCol (RealSrcLoc loc _) =-            "line " <> ppr(srcLocLine loc) <> ", column " <> ppr(srcLocCol loc)+            "line " <> printOutputable (srcLocLine loc) <> ", column " <> printOutputable (srcLocCol loc)   mkAdditionalEditsCommand :: PluginId -> ExtendImport -> Command@@ -226,16 +226,16 @@   where     compKind = occNameToComKind typeText origName     isTypeCompl = isTcOcc origName-    label = stripPrefix $ showGhc origName+    label = stripPrefix $ printOutputable origName     insertText = case isInfix of             Nothing -> case getArgText <$> thingType of                             Nothing      -> label-                            Just argText -> label <> " " <> argText+                            Just argText -> if T.null argText then label else label <> " " <> argText             Just LeftSide -> label <> "`"              Just Surrounded -> label     typeText-          | Just t <- thingType = Just . stripForall $ showGhc t+          | Just t <- thingType = Just . stripForall $ printOutputable t           | otherwise = Nothing     additionalTextEdits =       imp <&> \x ->@@ -244,7 +244,7 @@             thingParent,             importName = showModName $ unLoc $ ideclName $ unLoc x,             importQual = getImportQual x,-            newThing = showNameWithoutUniques origName+            newThing = printOutputable origName           }      stripForall :: T.Text -> T.Text@@ -295,7 +295,7 @@     where         ctxt = defaultSDocContext{sdocStyle = mkUserStyle neverQualify AllTheWay} #else-showForSnippet x = showGhc x+showForSnippet x = printOutputable x #endif  mkModCompl :: T.Text -> CompletionItem@@ -350,7 +350,7 @@   let       packageState = hscEnv env       curModName = moduleName curMod-      curModNameText = ppr curModName+      curModNameText = printOutputable curModName        importMap = Map.fromList [ (l, imp) | imp@(L (locA -> (RealSrcSpan l _)) _) <- limports ] @@ -384,9 +384,9 @@                 -- we don't want to extend import if it's already in scope                 guard . null $ lookupGRE_Name inScopeEnv n                 -- or if it doesn't have a real location-                loc <- realSpan $ is_dloc spec+                loc <- realSpan $ is_dloc spec                 Map.lookup loc importMap-          compItem <- toCompItem par curMod (ppr $ is_mod spec) n originalImportDecl+          compItem <- toCompItem par curMod (printOutputable $ is_mod spec) n originalImportDecl           let unqual                 | is_qual spec = []                 | otherwise = compItem@@ -498,12 +498,12 @@ findRecordCompl :: Uri -> ParsedModule -> Provenance -> TyClDecl GhcPs -> [CompItem] findRecordCompl uri pmod mn DataDecl {tcdLName, tcdDataDefn} = result     where-        result = [mkRecordSnippetCompItem uri (Just $ showNameWithoutUniques $ unLoc tcdLName)-                        (showGhc . unLoc $ con_name) field_labels mn doc Nothing+        result = [mkRecordSnippetCompItem uri (Just $ printOutputable $ unLoc tcdLName)+                        (printOutputable . unLoc $ con_name) field_labels mn doc Nothing                  | ConDeclH98{..} <- unLoc <$> dd_cons tcdDataDefn                  , Just  con_details <- [getFlds con_args]                  , let field_names = concatMap extract con_details-                 , let field_labels = showGhc <$> field_names+                 , let field_labels = printOutputable <$> field_names                  , (not . List.null) field_labels                  ]         doc = SpanDocText (getDocumentation [pmod] $ reLoc tcdLName) (SpanDocUris Nothing Nothing)@@ -528,9 +528,6 @@         extract _ = [] findRecordCompl _ _ _ _ = [] -ppr :: Outputable a => a -> T.Text-ppr = T.pack . prettyPrint- toggleSnippets :: ClientCapabilities -> CompletionsConfig -> CompletionItem -> CompletionItem toggleSnippets ClientCapabilities {_textDocument} CompletionsConfig{..} =   removeSnippetsWhen (not $ enableSnippets && supported)@@ -590,7 +587,7 @@           $ (if T.null enteredQual then id else mapMaybe (T.stripPrefix enteredQual))             allModNamesAsNS -      filtCompls = Fuzzy.filter chunkSize maxC prefixText ctxCompls "" "" (label . snd)+      filtCompls = Fuzzy.filter chunkSize maxC prefixText ctxCompls (label . snd)         where            mcc = case maybe_parsed of@@ -668,7 +665,7 @@         return $           (fmap.fmap) snd $           sortBy (compare `on` lexicographicOrdering) $-          mergeListsBy (flip compare `on` score_)+          mergeListsBy (flip compare `on` score)             [ (fmap.fmap) (notQual,) filtModNameCompls             , (fmap.fmap) (notQual,) filtKeywordCompls             , (fmap.fmap.fmap) (toggleSnippets caps config) compls@@ -681,11 +678,11 @@         --  3. In-scope completions rank next         --  4. label alphabetical ordering next         --  4. detail alphabetical ordering (proxy for module)-        lexicographicOrdering Fuzzy.Scored{score_, original} =+        lexicographicOrdering Fuzzy.Scored{score, original} =           case original of             (isQual, CompletionItem{_label,_detail}) -> do               let isLocal = maybe False (":" `T.isPrefixOf`) _detail-              (Down isQual, Down score_, Down isLocal, _label, _detail)+              (Down isQual, Down score, Down isLocal, _label, _detail)   @@ -807,7 +804,7 @@ safeTyThingForRecord :: TyThing -> Maybe (T.Text, [T.Text]) safeTyThingForRecord (AnId _) = Nothing safeTyThingForRecord (AConLike dc) =-    let ctxStr =   showGhc . occName . conLikeName $ dc+    let ctxStr = printOutputable . occName . conLikeName $ dc         field_names = T.pack . unpackFS . flLabel <$> conLikeFieldLabels dc     in         Just (ctxStr, field_names)

@@ -6,11 +6,11 @@ module Development.IDE.Plugin.HLS     (       asGhcIdePlugin+    , Log(..)     ) where  import           Control.Exception            (SomeException) import           Control.Monad-import           Control.Monad.IO.Class import qualified Data.Aeson                   as J import           Data.Bifunctor import           Data.Dependent.Map           (DMap)@@ -22,7 +22,7 @@ import qualified Data.Map                     as Map import           Data.String import qualified Data.Text                    as T-import           Development.IDE.Core.Shake+import           Development.IDE.Core.Shake   hiding (Log) import           Development.IDE.Core.Tracing import           Development.IDE.Graph        (Rules) import           Development.IDE.LSP.Server@@ -33,6 +33,7 @@ import           Ide.PluginUtils              (getClientConfig) import           Ide.Types                    as HLS import qualified Language.LSP.Server          as LSP+import           Language.LSP.VFS import           Language.LSP.Types import qualified Language.LSP.Types           as J import           Text.Regex.TDFA.Text         ()@@ -43,13 +44,22 @@ -- --------------------------------------------------------------------- -- +data Log+  = LogNoEnabledPlugins+  deriving Show++instance Pretty Log where+  pretty = \case+    LogNoEnabledPlugins ->+      "extensibleNotificationPlugins no enabled plugins"+ -- | Map a set of plugins to the underlying ghcide engine.-asGhcIdePlugin :: IdePlugins IdeState -> Plugin Config-asGhcIdePlugin (IdePlugins ls) =+asGhcIdePlugin :: Recorder (WithPriority Log) -> IdePlugins IdeState -> Plugin Config+asGhcIdePlugin recorder (IdePlugins ls) =     mkPlugin rulesPlugins HLS.pluginRules <>     mkPlugin executeCommandPlugins HLS.pluginCommands <>     mkPlugin extensiblePlugins HLS.pluginHandlers <>-    mkPlugin extensibleNotificationPlugins HLS.pluginNotificationHandlers <>+    mkPlugin (extensibleNotificationPlugins recorder) HLS.pluginNotificationHandlers <>     mkPlugin dynFlagsPlugins HLS.pluginModifyDynflags     where @@ -171,8 +181,8 @@                 pure $ Right $ combineResponses m config caps params xs -- --------------------------------------------------------------------- -extensibleNotificationPlugins :: [(PluginId, PluginNotificationHandlers IdeState)] -> Plugin Config-extensibleNotificationPlugins xs = mempty { P.pluginHandlers = handlers }+extensibleNotificationPlugins :: Recorder (WithPriority Log) -> [(PluginId, PluginNotificationHandlers IdeState)] -> Plugin Config+extensibleNotificationPlugins recorder xs = mempty { P.pluginHandlers = handlers }   where     IdeNotificationHandlers handlers' = foldMap bakePluginId xs     bakePluginId :: (PluginId, PluginNotificationHandlers IdeState) -> IdeNotificationHandlers@@ -181,17 +191,17 @@       hs     handlers = mconcat $ do       (IdeNotification m :=> IdeNotificationHandler fs') <- DMap.assocs handlers'-      pure $ notificationHandler m $ \ide params -> do+      pure $ notificationHandler m $ \ide vfs params -> do         config <- Ide.PluginUtils.getClientConfig         let fs = filter (\(pid,_) -> plcGlobalOn $ configForPlugin config pid) fs'         case nonEmpty fs of           Nothing -> do-              liftIO $ logInfo (ideLogger ide) "extensibleNotificationPlugins no enabled plugins"+              logWith recorder Info LogNoEnabledPlugins               pure ()           Just fs -> do             -- We run the notifications in order, so the core ghcide provider             -- (which restarts the shake process) hopefully comes last-              mapM_ (\(pid,f) -> otTracedProvider pid (fromString $ show m) $ f ide params) fs+              mapM_ (\(pid,f) -> otTracedProvider pid (fromString $ show m) $ f ide vfs params) fs  -- --------------------------------------------------------------------- @@ -217,7 +227,7 @@  -- | Combine the 'PluginHandler' for all plugins newtype IdeNotificationHandler (m :: J.Method FromClient Notification)-  = IdeNotificationHandler [(PluginId, IdeState -> MessageParams m -> LSP.LspM Config ())]+  = IdeNotificationHandler [(PluginId, IdeState -> VFS -> MessageParams m -> LSP.LspM Config ())] -- type NotificationHandler (m :: Method FromClient Notification) = MessageParams m -> IO ()`  -- | Combine the 'PluginHandlers' for all plugins