mirror of
https://github.com/haskell/ghcide.git
synced 2024-11-23 03:25:40 +03:00
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:
parent
5b8d7fa661
commit
ba4bdb2def
@ -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
50
bench/exe/Main.hs
Normal 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
|
@ -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"
|
11
ghcide.cabal
11
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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user