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
This commit is contained in:
Pepe Iborra 2020-06-22 11:47:45 +01:00 committed by GitHub
parent 5b8d7fa661
commit ba4bdb2def
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
10 changed files with 300 additions and 179 deletions

View File

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

50
bench/exe/Main.hs Normal file
View File

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

View File

@ -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
benchWithSetup
"code actions after edit"
10
( \doc -> do
changeDoc doc [breakingEdit]
void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
not . null <$> getCodeActions doc (Range identifierP identifierP)
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
let path = examplesPath </> examplePackage
case buildTool ?config of
Cabal -> do
callCommand $ "cabal get -v0 " <> examplePackage <> " -d " <> examplesPath
writeFile
(examplesPath </> examplePackage </> "hie.yaml")
exampleCradle
(path </> "hie.yaml")
("cradle: {cabal: {component: " <> show examplePackageName <> "}}")
-- Need this in case there is a parent cabal.project somewhere
writeFile
(examplesPath </> examplePackage </> "cabal.project")
(path </> "cabal.project")
"packages: ."
writeFile
(examplesPath </> examplePackage </> "cabal.project.local")
(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"

View File

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

View File

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

View File

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

View File

@ -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,20 +364,45 @@ shakeOpen getLspId eventer withProgress withIndefiniteProgress logger debouncer
shakeDb <- shakeDbM
let ideState = IdeState{..}
return ideState
where
-- 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 :: Hashable a => IdeTesting -> IO LSP.LspId -> (LSP.FromServerMessage -> IO ()) -> Var (HMap.HashMap a Int) -> IO ()
lspShakeProgress (IdeTesting ideTesting) getLspId sendMsg inProgress = do
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
sendMsg $ LSP.ReqWorkDoneProgressCreate $ LSP.fmServerWorkDoneProgressCreateRequest
lspId $ LSP.WorkDoneProgressCreateParams
{ _token = u }
eventer $ 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
start id = eventer $ LSP.NotWorkDoneProgressBegin $
LSP.fmServerWorkDoneProgressBeginNotification
LSP.ProgressParams
{ _token = id
, _value = WorkDoneProgressBeginParams
@ -378,7 +412,8 @@ lspShakeProgress (IdeTesting ideTesting) getLspId sendMsg inProgress = do
, _percentage = Nothing
}
}
stop id = sendMsg $ LSP.NotWorkDoneProgressEnd $ LSP.fmServerWorkDoneProgressEndNotification
stop id = eventer $ LSP.NotWorkDoneProgressEnd $
LSP.fmServerWorkDoneProgressEndNotification
LSP.ProgressParams
{ _token = id
, _value = WorkDoneProgressEndParams
@ -393,7 +428,8 @@ lspShakeProgress (IdeTesting ideTesting) getLspId sendMsg inProgress = do
let todo = HMap.size current
let next = Just $ T.pack $ show done <> "/" <> show todo
when (next /= prev) $
sendMsg $ LSP.NotWorkDoneProgressReport $ LSP.fmServerWorkDoneProgressReportNotification
eventer $ LSP.NotWorkDoneProgressReport $
LSP.fmServerWorkDoneProgressReportNotification
LSP.ProgressParams
{ _token = id
, _value = LSP.WorkDoneProgressReportParams
@ -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

View File

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

View File

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