Send WorkDoneProgressEnd only when work is done (#649)

* send WorkDoneProgressEnd only when work done * Progress reporting now spans over multiple overlapping kicks * Repurpose benchmark experiments as tests Fixes #650 * use stack to fetch from Hackage * benchmark tests run with the same lsp-test config as other tests * Fix stack cradle in benchmark * Make stack unpack --silent * Fix issues in "code actions after edit" experiment - Repeated breaking edits make ghc run out of suggestions - Diagnostics seem to come and go in-between edits, which leads to a timing issue when asking for code actions. The fix is to wait for diagnostics to be present before asking for code actions * Fix stack.yaml generation in example project * Fix getDefinition in GHC 8.4 Did it break before 0.2.0 or after? * better naming for the progress event TVar * stop progress reporting in shakeShut https://github.com/digital-asset/ghcide/pull/649#discussion_r443408884 * hlint
2024-11-22 19:14:09 +03:00 · 2020-06-22 11:47:45 +01:00 · 2020-06-22 11:47:45 +01:00 · ba4bdb2def
commit ba4bdb2def
parent 5b8d7fa661
10 changed files with 300 additions and 179 deletions
--- a/bench/README.md
+++ b/bench/README.md
@ -4,7 +4,7 @@
 This folder contains two Haskell programs that work together to simplify the
 performance analysis of ghcide:

- `Main.hs` - a standalone benchmark suite. Run with `stack bench`
+- `exe/Main.hs` - a standalone benchmark suite. Run with `stack bench`
 - `hist/Main.hs` - a Shake script for running the benchmark suite over a set of commits.
  - Run with `stack exec benchHist`,
  - Requires a `ghcide-bench` binary in the PATH,
--- a/bench/exe/Main.hs
+++ b/bench/exe/Main.hs
@ -0,0 +1,50 @@
+{- An automated benchmark built around the simple experiment described in:
+
+  > https://neilmitchell.blogspot.com/2020/05/fixing-space-leaks-in-ghcide.html
+
+  As an example project, it unpacks Cabal-3.2.0.0 in the local filesystem and
+  loads the module 'Distribution.Simple'. The rationale for this choice is:
+
+    - It's convenient to download with `cabal unpack Cabal-3.2.0.0`
+    - It has very few dependencies, and all are already needed to build ghcide
+    - Distribution.Simple has 235 transitive module dependencies, so non trivial
+
+  The experiments are sequences of lsp commands scripted using lsp-test.
+  A more refined approach would be to record and replay real IDE interactions,
+  once the replay functionality is available in lsp-test.
+  A more declarative approach would be to reuse ide-debug-driver:
+
+  > https://github.com/digital-asset/daml/blob/master/compiler/damlc/ide-debug-driver/README.md
+
+  The result of an experiment is a total duration in seconds after a preset
+  number of iterations. There is ample room for improvement:
+     - Statistical analysis to detect outliers and auto infer the number of iterations needed
+     - GC stats analysis (currently -S is printed as part of the experiment)
+     - Analyisis of performance over the commit history of the project
+
+  How to run:
+     1. `cabal bench`
+     2. `cabal exec cabal run ghcide-bench -- -- ghcide-bench-options`
+
+  Note that the package database influences the response times of certain actions,
+  e.g. code actions, and therefore the two methods above do not necessarily
+  produce the same results.
+
+ -}
+
+{-# LANGUAGE ImplicitParams #-}
+
+import Control.Exception.Safe
+import Experiments
+import Options.Applicative
+
+main :: IO ()
+main = do
+  config <- execParser $ info (configP <**> helper) fullDesc
+  let ?config = config
+
+  output "starting test"
+
+  cleanUp <- setup
+
+  runBenchmarks experiments `finally` cleanUp
--- a/bench/hist/Main.hs
+++ b/bench/hist/Main.hs
--- a/bench/lib/Experiments.hs
+++ b/bench/lib/Experiments.hs
@ -2,45 +2,26 @@
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE ImplicitParams #-}

-{- An automated benchmark built around the simple experiment described in:
-
-  > https://neilmitchell.blogspot.com/2020/05/fixing-space-leaks-in-ghcide.html
-
-  As an example project, it unpacks Cabal-3.2.0.0 in the local filesystem and
-  loads the module 'Distribution.Simple'. The rationale for this choice is:
-
-    - It's convenient to download with `cabal unpack Cabal-3.2.0.0`
-    - It has very few dependencies, and all are already needed to build ghcide
-    - Distribution.Simple has 235 transitive module dependencies, so non trivial
-
-  The experiments are sequences of lsp commands scripted using lsp-test.
-  A more refined approach would be to record and replay real IDE interactions,
-  once the replay functionality is available in lsp-test.
-  A more declarative approach would be to reuse ide-debug-driver:
-
-  > https://github.com/digital-asset/daml/blob/master/compiler/damlc/ide-debug-driver/README.md
-
-  The result of an experiment is a total duration in seconds after a preset
-  number of iterations. There is ample room for improvement:
-     - Statistical analysis to detect outliers and auto infer the number of iterations needed
-     - GC stats analysis (currently -S is printed as part of the experiment)
-     - Analyisis of performance over the commit history of the project
-
-  How to run:
-     1. `cabal bench`
-     2. `cabal exec cabal run ghcide-bench -- -- ghcide-bench-options`
-
-  Note that the package database influences the response times of certain actions,
-  e.g. code actions, and therefore the two methods above do not necessarily
-  produce the same results.
-
- -}
-
+module Experiments
+( Bench(..)
+, BenchRun(..)
+, Config(..)
+, Verbosity(..)
+, CabalStack(..)
+, experiments
+, configP
+, defConfig
+, output
+, setup
+, runBench
+, runBenchmarks
+) where
 import Control.Applicative.Combinators (skipManyTill)
 import Control.Concurrent
 import Control.Exception.Safe
 import Control.Monad.Extra
 import Control.Monad.IO.Class
+import Data.Char (isDigit)
 import Data.List
 import Data.Maybe
 import Data.Version
@ -54,7 +35,7 @@ import System.FilePath ((</>))
 import System.Process
 import System.Time.Extra
 import Text.ParserCombinators.ReadP (readP_to_S)
-import Data.Char (isDigit)
+import System.Environment.Blank (getEnv)

 -- Points to a string in the target file,
 -- convenient for hygienic edits
@ -82,16 +63,8 @@ breakingEdit =
 identifierP :: Position
 identifierP = Position 853 12

-main :: IO ()
-main = do
-  config <- execParser $ info (configP <**> helper) fullDesc
-  let ?config = config
-
-  output "starting test"
-
-  cleanUp <- setup
-
-  runBenchmarks
+experiments :: [Bench]
+experiments =
    [ ---------------------------------------------------------------------------------------
      bench "hover" 10 $ \doc ->
        isJust <$> getHover doc identifierP,
@ -131,12 +104,19 @@ main = do
            not . null <$> getCodeActions doc (Range p p)
        ),
      ---------------------------------------------------------------------------------------
-      bench "code actions after edit" 10 $ \doc -> do
-        changeDoc doc [breakingEdit]
-        void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
-        not . null <$> getCodeActions doc (Range identifierP identifierP)
+      benchWithSetup
+        "code actions after edit"
+        10
+        ( \doc -> do
+            changeDoc doc [breakingEdit]
+            return identifierP
+        )
+        ( \p doc -> do
+            changeDoc doc [hygienicEdit]
+            whileM (null <$> waitForDiagnostics)
+            not . null <$> getCodeActions doc (Range p p)
+        )
    ]
-    `finally` cleanUp

 ---------------------------------------------------------------------------------------------

@ -165,7 +145,7 @@ data Config = Config
    -- For some reason, the Shake profile files are truncated and won't load
    shakeProfiling :: !(Maybe FilePath),
    outputCSV :: !FilePath,
-    cradle :: !Cradle,
+    buildTool :: !CabalStack,
    rtsOptions :: ![String],
    matches :: ![String],
    repetitions :: Maybe Natural,
@ -175,11 +155,14 @@ data Config = Config
  }
  deriving (Eq, Show)

+defConfig :: Config
+Success defConfig = execParserPure defaultPrefs (info configP fullDesc) []
+
 quiet, verbose :: Config -> Bool
 verbose = (== All) . verbosity
 quiet   = (== Quiet) . verbosity

-data Cradle = Cabal | Stack
+data CabalStack = Cabal | Stack
  deriving (Eq, Show)

 type HasConfig = (?config :: Config)
@ -193,7 +176,7 @@ configP =
        )
    <*> optional (strOption (long "shake-profiling" <> metavar "PATH"))
    <*> strOption (long "csv" <> metavar "PATH" <> value "results.csv" <> showDefault)
-    <*> flag Cabal Stack (long "stack" <> help "Use a stack cradle")
+    <*> flag Cabal Stack (long "stack" <> help "Use stack (by default cabal is used)")
    <*> many (strOption (long "rts" <> help "additional RTS options for ghcide"))
    <*> many (strOption (short 's' <> long "select" <> help "select which benchmarks to run"))
    <*> optional (option auto (long "samples" <> metavar "NAT" <> help "override sampling count"))
@ -231,26 +214,29 @@ select Bench {name, enabled} =
    mm = matches ?config

 benchWithSetup ::
-  HasConfig =>
  String ->
  Natural ->
  (TextDocumentIdentifier -> Session p) ->
  (p -> Experiment) ->
  Bench
-benchWithSetup name defSamples benchSetup experiment = Bench {..}
+benchWithSetup name samples benchSetup experiment = Bench {..}
  where
    enabled = True
-    samples = fromMaybe defSamples (repetitions ?config)

-bench :: HasConfig => String -> Natural -> Experiment -> Bench
+bench :: String -> Natural -> Experiment -> Bench
 bench name defSamples userExperiment =
  benchWithSetup name defSamples (const $ pure ()) experiment
  where
    experiment () = userExperiment

 runBenchmarks :: HasConfig => [Bench] -> IO ()
-runBenchmarks (filter select -> benchmarks) = do
-  results <- forM benchmarks $ \b -> (b,) <$> runBench b
+runBenchmarks allBenchmarks = do
+  let benchmarks = [ b{samples = fromMaybe (samples b) (repetitions ?config) }
+                   | b <- allBenchmarks
+                   , select b ]
+  results <- forM benchmarks $ \b@Bench{name} ->
+                let run dir = runSessionWithConfig conf (cmd name dir) lspTestCaps dir
+                in (b,) <$> runBench run b

  -- output raw data as CSV
  let headers = ["name", "success", "samples", "startup", "setup", "experiment", "maxResidency"]
@ -288,6 +274,33 @@ runBenchmarks (filter select -> benchmarks) = do
  outputRow paddedHeaders
  outputRow $ (map . map) (const '-') paddedHeaders
  forM_ rowsHuman $ \row -> outputRow $ zipWith pad pads row
+  where
+    gcStats name = escapeSpaces (name <> ".benchmark-gcStats")
+    cmd name dir =
+      unwords $
+        [ ghcide ?config,
+          "--lsp",
+          "--cwd",
+          dir,
+          "+RTS",
+          "-S" <> gcStats name
+        ]
+          ++ rtsOptions ?config
+          ++ [ "-RTS"
+             ]
+          ++ concat
+            [ ["--shake-profiling", path]
+              | Just path <- [shakeProfiling ?config]
+            ]
+    lspTestCaps =
+      fullCaps {_window = Just $ WindowClientCapabilities $ Just True}
+    conf =
+      defaultConfig
+        { logStdErr = verbose ?config,
+          logMessages = verbose ?config,
+          logColor = False,
+          messageTimeout = timeoutLsp ?config
+        }

 data BenchRun = BenchRun
  { startup :: !Seconds,
@ -304,9 +317,9 @@ waitForProgressDone :: Session ()
 waitForProgressDone =
      void(skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)

-runBench :: HasConfig => Bench -> IO BenchRun
-runBench Bench {..} = handleAny (\e -> print e >> return badRun)
-  $ runSessionWithConfig conf cmd lspTestCaps dir
+runBench :: (?config::Config) => (String -> Session BenchRun -> IO BenchRun) -> Bench -> IO BenchRun
+runBench runSess Bench {..} = handleAny (\e -> print e >> return badRun)
+  $ runSess dir
  $ do
    doc <- openDoc exampleModulePath "haskell"
    (startup, _) <- duration $ do
@ -333,53 +346,54 @@ runBench Bench {..} = handleAny (\e -> print e >> return badRun)
    -- sleep to give ghcide a chance to GC
    liftIO $ threadDelay 1100000

-    maxResidency <- liftIO $ parseMaxResidency <$> readFile gcStats
+    maxResidency <- liftIO $
+        ifM (doesFileExist gcStats)
+            (parseMaxResidency <$> readFile gcStats)
+            (pure 0)

    return BenchRun {..}
  where
-    gcStats = escapeSpaces (name <> ".benchmark-gcStats")
-    cmd =
-      unwords $
-        [ ghcide ?config,
-          "--lsp",
-          "--cwd",
-          dir,
-          "+RTS",
-          "-S" <> gcStats
-        ]
-          ++ rtsOptions ?config
-          ++ [ "-RTS"
-             ]
-          ++ concat
-            [ ["--shake-profiling", path]
-              | Just path <- [shakeProfiling ?config]
-            ]
    dir = "bench/example/" <> examplePackage
-    lspTestCaps =
-      fullCaps {_window = Just $ WindowClientCapabilities $ Just True}
-    conf =
-      defaultConfig
-        { logStdErr = verbose ?config,
-          logMessages = verbose ?config,
-          logColor = False,
-          messageTimeout = timeoutLsp ?config
-        }
+    gcStats = escapeSpaces (name <> ".benchmark-gcStats")

 setup :: HasConfig => IO (IO ())
 setup = do
  alreadyExists <- doesDirectoryExist examplesPath
  when alreadyExists $ removeDirectoryRecursive examplesPath
-  callCommand $ "cabal get -v0 " <> examplePackage <> " -d " <> examplesPath
-  writeFile
-    (examplesPath </> examplePackage </> "hie.yaml")
-    exampleCradle
-  -- Need this in case there is a parent cabal.project somewhere
-  writeFile
-    (examplesPath </> examplePackage </> "cabal.project")
-    "packages: ."
-  writeFile
-    (examplesPath </> examplePackage </> "cabal.project.local")
-    ""
+  let path = examplesPath </> examplePackage
+  case buildTool ?config of
+      Cabal -> do
+        callCommand $ "cabal get -v0 " <> examplePackage <> " -d " <> examplesPath
+        writeFile
+            (path </> "hie.yaml")
+            ("cradle: {cabal: {component: " <> show examplePackageName <> "}}")
+        -- Need this in case there is a parent cabal.project somewhere
+        writeFile
+            (path </> "cabal.project")
+            "packages: ."
+        writeFile
+            (path </> "cabal.project.local")
+            ""
+      Stack -> do
+        callCommand $ "stack --silent unpack " <> examplePackage <> " --to " <> examplesPath
+        -- Generate the stack descriptor to match the one used to build ghcide
+        stack_yaml <- fromMaybe "stack.yaml" <$> getEnv "STACK_YAML"
+        stack_yaml_lines <- lines <$> readFile stack_yaml
+        writeFile (path </> stack_yaml)
+                  (unlines $
+                   "packages: [.]" :
+                    [ l
+                    | l <- stack_yaml_lines
+                    , any (`isPrefixOf` l)
+                        ["resolver"
+                        ,"allow-newer"
+                        ,"compiler"]
+                    ]
+                  )
+
+        writeFile
+            (path </> "hie.yaml")
+            ("cradle: {stack: {component: " <> show (examplePackageName <> ":lib") <> "}}")

  whenJust (shakeProfiling ?config) $ createDirectoryIfMissing True

@ -401,11 +415,6 @@ escapeSpaces = map f
    f ' ' = '_'
    f x = x

-exampleCradle :: HasConfig => String
-exampleCradle = case cradle ?config of
-  Cabal -> "cradle: {cabal: {component: " <> show examplePackageName <> "}}"
-  Stack -> "cradle: {stack: {component: " <> show (examplePackageName <> ":lib") <> "}}"
-
 pad :: Int -> String -> String
 pad n [] = replicate n ' '
 pad 0 _ = error "pad"
--- a/ghcide.cabal
+++ b/ghcide.cabal
@ -177,7 +177,7 @@ executable benchHist
    default-language: Haskell2010
    buildable: True
    ghc-options: -Wall -Wno-name-shadowing -threaded
-    main-is: bench/Hist/Main.hs
+    main-is: bench/hist/Main.hs
    default-extensions:
        BangPatterns
        DeriveFunctor
@ -305,10 +305,13 @@ test-suite ghcide-tests
        network-uri,
        lens,
        lsp-test >= 0.11.0.1 && < 0.12,
+        optparse-applicative,
        parser-combinators,
+        process,
        QuickCheck,
        quickcheck-instances,
        rope-utf16-splay,
+        safe-exceptions,
        shake,
        tasty,
        tasty-expected-failure,
@ -316,13 +319,14 @@ test-suite ghcide-tests
        tasty-quickcheck,
        tasty-rerun,
        text
-    hs-source-dirs: test/cabal test/exe test/src
+    hs-source-dirs: test/cabal test/exe test/src bench/lib
    include-dirs: include
    ghc-options: -threaded -Wall -Wno-name-shadowing
    main-is: Main.hs
    other-modules:
        Development.IDE.Test
        Development.IDE.Test.Runfiles
+        Experiments
    default-extensions:
        BangPatterns
        DeriveFunctor
@ -358,11 +362,12 @@ benchmark ghcide-bench
        parser-combinators,
        process,
        safe-exceptions
-    hs-source-dirs: bench
+    hs-source-dirs: bench/lib bench/exe
    include-dirs: include
    ghc-options: -threaded -Wall -Wno-name-shadowing
    main-is: Main.hs
    other-modules:
+        Experiments
    default-extensions:
        BangPatterns
        DeriveFunctor
--- a/src/Development/IDE/Core/OfInterest.hs
+++ b/src/Development/IDE/Core/OfInterest.hs
@ -88,4 +88,7 @@ modifyFilesOfInterest state f = do
 kick :: Action ()
 kick = do
    files <- getFilesOfInterest
+    ShakeExtras{progressUpdate} <- getShakeExtras
+    liftIO $ progressUpdate KickStarted
    void $ uses TypeCheck $ HashSet.toList files
+    liftIO $ progressUpdate KickCompleted
--- a/src/Development/IDE/Core/Rules.hs
+++ b/src/Development/IDE/Core/Rules.hs
@ -675,6 +675,7 @@ getModSummaryRule = defineEarlyCutoff $ \GetModSummary f -> do

 getModIfaceRule :: Rules ()
 getModIfaceRule = define $ \GetModIface f -> do
+#if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB)
    fileOfInterest <- use_ IsFileOfInterest f
    let useHiFile =
          -- Never load interface files for files of interest
@ -725,6 +726,13 @@ getModIfaceRule = define $ \GetModIface f -> do
      extract (Just tmr) =
        -- Bang patterns are important to force the inner fields
        Just $! HiFileResult (tmrModSummary tmr) (hm_iface $ tmrModInfo tmr)
+#else
+    tm <- use TypeCheck f
+    let modIface = hm_iface . tmrModInfo <$> tm
+        modSummary = tmrModSummary <$> tm
+    return ([], HiFileResult <$> modSummary <*> modIface)
+#endif
+

 isFileOfInterestRule :: Rules ()
 isFileOfInterestRule = defineEarlyCutoff $ \IsFileOfInterest f -> do
--- a/src/Development/IDE/Core/Shake.hs
+++ b/src/Development/IDE/Core/Shake.hs
@ -46,7 +46,8 @@ module Development.IDE.Core.Shake(
    updatePositionMapping,
    deleteValue,
    OnDiskRule(..),
-    WithProgressFunc, WithIndefiniteProgressFunc
+    WithProgressFunc, WithIndefiniteProgressFunc,
+    ProgressEvent(..)
    ) where

 import           Development.Shake hiding (ShakeValue, doesFileExist)
@ -92,6 +93,7 @@ import           GHC.Generics
 import           System.IO.Unsafe
 import Language.Haskell.LSP.Types
 import Data.Foldable (traverse_)
+import qualified Control.Monad.STM as STM


 -- information we stash inside the shakeExtra field
@ -113,12 +115,8 @@ data ShakeExtras = ShakeExtras
    -- accumlation of all previous mappings.
    ,inProgress :: Var (HMap.HashMap NormalizedFilePath Int)
    -- ^ How many rules are running for each file
-    ,getLspId :: IO LspId
+    ,progressUpdate :: ProgressEvent -> IO ()
    -- ^ The generator for unique Lsp identifiers
-    ,reportProgress :: Bool
-    -- ^ Whether to send Progress messages to the client
-    ,ideTesting :: IdeTesting
-    -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants
    ,restartShakeSession :: [Action ()] -> IO ()
    -- ^ Used in the GhcSession rule to forcefully restart the session after adding a new component
    ,withProgress           :: WithProgressFunc
@ -132,6 +130,10 @@ type WithProgressFunc = forall a.
 type WithIndefiniteProgressFunc = forall a.
    T.Text -> LSP.ProgressCancellable -> IO a -> IO a

+data ProgressEvent
+    = KickStarted
+    | KickCompleted
+
 getShakeExtras :: Action ShakeExtras
 getShakeExtras = do
    Just x <- getShakeExtra @ShakeExtras
@ -259,6 +261,7 @@ data IdeState = IdeState
    ,shakeClose      :: IO ()
    ,shakeExtras     :: ShakeExtras
    ,shakeProfileDir :: Maybe FilePath
+    ,stopProgressReporting :: IO ()
    }


@ -335,10 +338,10 @@ shakeOpen :: IO LSP.LspId
          -> Rules ()
          -> IO IdeState
 shakeOpen getLspId eventer withProgress withIndefiniteProgress logger debouncer
-  shakeProfileDir (IdeReportProgress reportProgress) ideTesting opts rules = mdo
+  shakeProfileDir (IdeReportProgress reportProgress) (IdeTesting ideTesting) opts rules = mdo

    inProgress <- newVar HMap.empty
-    shakeExtras <- do
+    (shakeExtras, stopProgressReporting) <- do
        globals <- newVar HMap.empty
        state <- newVar HMap.empty
        diagnostics <- newVar mempty
@ -346,7 +349,13 @@ shakeOpen getLspId eventer withProgress withIndefiniteProgress logger debouncer
        publishedDiagnostics <- newVar mempty
        positionMapping <- newVar HMap.empty
        let restartShakeSession = shakeRestart ideState
-        pure ShakeExtras{..}
+        mostRecentProgressEvent <- newTVarIO KickCompleted
+        let progressUpdate = atomically . writeTVar mostRecentProgressEvent
+        progressAsync <- async $
+            when reportProgress $
+                progressThread mostRecentProgressEvent inProgress
+
+        pure (ShakeExtras{..}, cancel progressAsync)
    (shakeDbM, shakeClose) <-
        shakeOpenDatabase
            opts { shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts }
@ -355,54 +364,81 @@ shakeOpen getLspId eventer withProgress withIndefiniteProgress logger debouncer
    shakeDb <- shakeDbM
    let ideState = IdeState{..}
    return ideState
-
-lspShakeProgress :: Hashable a => IdeTesting -> IO LSP.LspId -> (LSP.FromServerMessage -> IO ()) -> Var (HMap.HashMap a Int) -> IO ()
-lspShakeProgress (IdeTesting ideTesting) getLspId sendMsg inProgress = do
-    -- first sleep a bit, so we only show progress messages if it's going to take
-    -- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes)
-    unless ideTesting $ sleep 0.1
-    lspId <- getLspId
-    u <- ProgressTextToken . T.pack . show . hashUnique <$> newUnique
-    sendMsg $ LSP.ReqWorkDoneProgressCreate $ LSP.fmServerWorkDoneProgressCreateRequest
-      lspId $ LSP.WorkDoneProgressCreateParams
-      { _token = u }
-    bracket_ (start u) (stop u) (loop u Nothing)
    where
-        start id = sendMsg $ LSP.NotWorkDoneProgressBegin $ LSP.fmServerWorkDoneProgressBeginNotification
-            LSP.ProgressParams
-                { _token = id
-                , _value = WorkDoneProgressBeginParams
-                  { _title = "Processing"
-                  , _cancellable = Nothing
-                  , _message = Nothing
-                  , _percentage = Nothing
-                  }
-                }
-        stop id = sendMsg $ LSP.NotWorkDoneProgressEnd $ LSP.fmServerWorkDoneProgressEndNotification
-            LSP.ProgressParams
-                { _token = id
-                , _value = WorkDoneProgressEndParams
-                  { _message = Nothing
-                  }
-                }
-        sample = 0.1
-        loop id prev = do
-            sleep sample
-            current <- readVar inProgress
-            let done = length $ filter (== 0) $ HMap.elems current
-            let todo = HMap.size current
-            let next = Just $ T.pack $ show done <> "/" <> show todo
-            when (next /= prev) $
-                sendMsg $ LSP.NotWorkDoneProgressReport $ LSP.fmServerWorkDoneProgressReportNotification
-                    LSP.ProgressParams
-                        { _token = id
-                        , _value = LSP.WorkDoneProgressReportParams
-                        { _cancellable = Nothing
-                        , _message = next
-                        , _percentage = Nothing
-                        }
-                        }
-            loop id next
+        -- The progress thread is a state machine with two states:
+        --   1. Idle
+        --   2. Reporting a kick event
+        -- And two transitions, modelled by 'ProgressEvent':
+        --   1. KickCompleted - transitions from Reporting into Idle
+        --   2. KickStarted - transitions from Idle into Reporting
+        progressThread mostRecentProgressEvent inProgress = progressLoopIdle
+          where
+            progressLoopIdle = do
+                atomically $ do
+                    v <- readTVar mostRecentProgressEvent
+                    case v of
+                        KickCompleted -> STM.retry
+                        KickStarted -> return ()
+                asyncReporter <- async lspShakeProgress
+                progressLoopReporting asyncReporter
+            progressLoopReporting asyncReporter = do
+                atomically $ do
+                    v <- readTVar mostRecentProgressEvent
+                    case v of
+                        KickStarted -> STM.retry
+                        KickCompleted -> return ()
+                cancel asyncReporter
+                progressLoopIdle
+
+            lspShakeProgress = do
+                -- first sleep a bit, so we only show progress messages if it's going to take
+                -- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes)
+                unless ideTesting $ sleep 0.1
+                lspId <- getLspId
+                u <- ProgressTextToken . T.pack . show . hashUnique <$> newUnique
+                eventer $ LSP.ReqWorkDoneProgressCreate $
+                  LSP.fmServerWorkDoneProgressCreateRequest lspId $
+                    LSP.WorkDoneProgressCreateParams { _token = u }
+                bracket_ (start u) (stop u) (loop u Nothing)
+                where
+                    start id = eventer $ LSP.NotWorkDoneProgressBegin $
+                      LSP.fmServerWorkDoneProgressBeginNotification
+                        LSP.ProgressParams
+                            { _token = id
+                            , _value = WorkDoneProgressBeginParams
+                              { _title = "Processing"
+                              , _cancellable = Nothing
+                              , _message = Nothing
+                              , _percentage = Nothing
+                              }
+                            }
+                    stop id = eventer $ LSP.NotWorkDoneProgressEnd $
+                      LSP.fmServerWorkDoneProgressEndNotification
+                        LSP.ProgressParams
+                            { _token = id
+                            , _value = WorkDoneProgressEndParams
+                              { _message = Nothing
+                              }
+                            }
+                    sample = 0.1
+                    loop id prev = do
+                        sleep sample
+                        current <- readVar inProgress
+                        let done = length $ filter (== 0) $ HMap.elems current
+                        let todo = HMap.size current
+                        let next = Just $ T.pack $ show done <> "/" <> show todo
+                        when (next /= prev) $
+                            eventer $ LSP.NotWorkDoneProgressReport $
+                              LSP.fmServerWorkDoneProgressReportNotification
+                                LSP.ProgressParams
+                                    { _token = id
+                                    , _value = LSP.WorkDoneProgressReportParams
+                                    { _cancellable = Nothing
+                                    , _message = next
+                                    , _percentage = Nothing
+                                    }
+                                    }
+                        loop id next

 shakeProfile :: IdeState -> FilePath -> IO ()
 shakeProfile IdeState{..} = shakeProfileDatabase shakeDb
@ -413,6 +449,7 @@ shakeShut IdeState{..} = withMVar shakeSession $ \runner -> do
    -- request so we first abort that.
    void $ cancelShakeSession runner
    shakeClose
+    stopProgressReporting

 -- | This is a variant of withMVar where the first argument is run unmasked and if it throws
 -- an exception, the previous value is restored while the second argument is executed masked.
@ -481,18 +518,8 @@ newSession IdeState{shakeExtras=ShakeExtras{..}, ..} systemActs userActs = do
                    return act
                liftIO $ atomically $ writeTVar actionInProgress Nothing

-        progressRun
-          | reportProgress = lspShakeProgress ideTesting getLspId eventer inProgress
-          | otherwise = return ()
-
-        workRun restore = withAsync progressRun $ \progressThread -> do
-          let systemActs' =
-                [ [] <$ pumpAction
-                , parallel systemActs
-                    -- Only system actions are considered for progress reporting
-                    -- When done, cancel the progressThread to indicate completion
-                    <* liftIO (cancel progressThread)
-                ]
+        workRun restore = do
+          let systemActs' = pumpAction : systemActs
          res <- try @SomeException
                 (restore $ shakeRunDatabase shakeDb systemActs')
          let res' = case res of
--- a/src/Development/IDE/GHC/Compat.hs
+++ b/src/Development/IDE/GHC/Compat.hs
@ -83,6 +83,8 @@ hieExportNames = nameListFromAvails . hie_exports
 import BinIface
 import Data.IORef
 import IfaceEnv
+#else
+import System.IO.Error
 #endif

 import Binary
@ -263,7 +265,7 @@ supportsHieFiles = False

 writeHieFile _ _ = return ()

-readHieFile _ _ = return undefined
+readHieFile _ fp = ioError $ mkIOError doesNotExistErrorType "" Nothing (Just fp)

 #endif

--- a/test/exe/Main.hs
+++ b/test/exe/Main.hs
@ -3,6 +3,7 @@

 {-# LANGUAGE AllowAmbiguousTypes   #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE ImplicitParams  #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE CPP #-}
 #include "ghc-api-version.h"
@ -17,6 +18,7 @@ import Control.Monad.IO.Class (liftIO)
 import Data.Aeson (FromJSON, Value)
 import Data.Foldable
 import Data.List.Extra
+import Data.Maybe
 import Data.Rope.UTF16 (Rope)
 import qualified Data.Rope.UTF16 as Rope
 import Development.IDE.Core.PositionMapping (fromCurrent, toCurrent)
@ -28,6 +30,7 @@ import Development.IDE.Test
 import Development.IDE.Test.Runfiles
 import Development.IDE.Types.Location
 import Development.Shake (getDirectoryFilesIO)
+import qualified Experiments as Bench
 import Language.Haskell.LSP.Test
 import Language.Haskell.LSP.Messages
 import Language.Haskell.LSP.Types
@ -48,7 +51,6 @@ import Test.Tasty.ExpectedFailure
 import Test.Tasty.Ingredients.Rerun
 import Test.Tasty.HUnit
 import Test.Tasty.QuickCheck
-import Data.Maybe

 main :: IO ()
 main = do
@ -80,6 +82,7 @@ main = do
    , cradleTests
    , dependentFileTest
    , nonLspCommandLine
+    , benchmarkTests
    ]

 initializeResponseTests :: TestTree
@ -2241,6 +2244,20 @@ nonLspCommandLine = testGroup "ghcide command line"
        ec @=? ExitSuccess
  ]

+benchmarkTests :: TestTree
+benchmarkTests =
+    let ?config = Bench.defConfig
+            { Bench.verbosity = Bench.Quiet
+            , Bench.repetitions = Just 3
+            , Bench.buildTool = Bench.Stack
+            } in
+    withResource Bench.setup id $ \_ -> testGroup "benchmark experiments"
+    [ testCase (Bench.name e) $ do
+        res <- Bench.runBench runInDir e
+        assertBool "did not successfully complete 5 repetitions" $ Bench.success res
+        | e <- Bench.experiments
+    ]
+
 ----------------------------------------------------------------------
 -- Utils