@@ -0,0 +1,287 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE ExistentialQuantification #-}
3+{-# LANGUAGE ImplicitParams #-}
5+{- An automated benchmark built around the simple experiment described in:
7+ > https://neilmitchell.blogspot.com/2020/05/fixing-space-leaks-in-ghcide.html
9+ As an example project, it unpacks Cabal-3.2.0.0 in the local filesystem and
10+ loads the module 'Distribution.Simple'. The rationale for this choice is:
12+ - It's convenient to download with `cabal unpack Cabal-3.2.0.0`
13+ - It has very few dependencies, and all are already needed to build ghcide
14+ - Distribution.Simple has 235 transitive module dependencies, so non trivial
16+ The experiments are sequences of lsp commands scripted using lsp-test.
17+ A more refined approach would be to record and replay real IDE interactions,
18+ once the replay functionality is available in lsp-test.
19+ A more declarative approach would be to reuse ide-debug-driver:
21+ > https://github.com/digital-asset/daml/blob/master/compiler/damlc/ide-debug-driver/README.md
23+ The result of an experiment is a total duration in seconds after a preset
24+ number of iterations. There is ample room for improvement:
25+ - Statistical analysis to detect outliers and auto infer the number of iterations needed
26+ - GC stats analysis (currently -S is printed as part of the experiment)
27+ - Analyisis of performance over the commit history of the project
31+ 2. `cabal exec <absolute-path-to-ghcide-bench> -- ghcide-bench-options`
33+ Note that the package database influences the response times of certain actions,
34+ e.g. code actions, and therefore the two methods above do not necessarily
35+ produce the same results.
39+import Control.Applicative.Combinators
40+import Control.Concurrent
41+import Control.Exception.Safe
42+import Control.Monad.Extra
43+import Control.Monad.IO.Class
48+import Language.Haskell.LSP.Test
49+import Language.Haskell.LSP.Types
50+import Language.Haskell.LSP.Types.Capabilities
51+import Numeric.Natural
52+import Options.Applicative
53+import System.Directory
54+import System.FilePath ((</>))
56+import System.Time.Extra
58+-- Points to a string in the target file,
59+-- convenient for hygienic edits
61+hygienicP = Position 854 23
63+-- Points to the middle of an identifier,
64+-- convenient for requesting goto-def, hover and completions
65+identifierP :: Position
66+identifierP = Position 853 12
70+ config <- execParser $ info configP fullDesc
73+ output "starting test"
78+ [ ---------------------------------------------------------------------------------------
79+ bench "hover" 10 $ \doc ->
80+ isJust <$> getHover doc identifierP,
81+ ---------------------------------------------------------------------------------------
82+ bench "getDefinition" 10 $ \doc ->
83+ not . null <$> getDefinitions doc identifierP,
84+ ---------------------------------------------------------------------------------------
85+ bench "documentSymbols" 100 $
86+ fmap (either (not . null) (not . null)) . getDocumentSymbols,
87+ ---------------------------------------------------------------------------------------
88+ bench "documentSymbols after edit" 100 $ \doc -> do
90+ TextDocumentContentChangeEvent
91+ { _range = Just (Range hygienicP hygienicP),
92+ _rangeLength = Nothing,
95+ changeDoc doc [change]
96+ either (not . null) (not . null) <$> getDocumentSymbols doc,
97+ ---------------------------------------------------------------------------------------
98+ bench "completions after edit" 10 $ \doc -> do
100+ TextDocumentContentChangeEvent
101+ { _range = Just (Range hygienicP hygienicP),
102+ _rangeLength = Nothing,
105+ changeDoc doc [change]
106+ not . null <$> getCompletions doc identifierP,
107+ ---------------------------------------------------------------------------------------
114+ TextDocumentContentChangeEvent
115+ { _range = Just (Range p p),
116+ _rangeLength = Nothing,
119+ changeDoc doc [change]
120+ void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
124+ not . null <$> getCodeActions doc (Range p p)
126+ ---------------------------------------------------------------------------------------
127+ bench "code actions after edit" 10 $ \doc -> do
130+ TextDocumentContentChangeEvent
131+ { _range = Just (Range p p),
132+ _rangeLength = Nothing,
135+ changeDoc doc [change]
136+ void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
137+ not . null <$> getCodeActions doc (Range p p)
141+---------------------------------------------------------------------------------------------
143+examplePackageName :: String
144+examplePackageName = "Cabal"
146+examplePackageVersion :: Version
147+examplePackageVersion = makeVersion [3, 2, 0, 0]
149+examplePackage :: String
150+examplePackage = examplePackageName <> "-" <> showVersion examplePackageVersion
152+exampleModulePath :: FilePath
153+exampleModulePath = "Distribution" </> "Simple.hs"
155+examplesPath :: FilePath
156+examplesPath = "bench/example"
160+ -- For some reason, the Shake profile files are truncated and won't load
161+ shakeProfiling :: !(Maybe FilePath),
165+type HasConfig = (?config :: Config)
167+configP :: Parser Config
169+ <$> (not <$> switch (long "quiet"))
170+ <*> optional (strOption (long "shake-profiling" <> metavar "PATH"))
171+ <*> switch (long "csv")
173+output :: (MonadIO m, HasConfig) => String -> m ()
174+output = if verbose ?config then liftIO . putStrLn else (\_ -> pure ())
176+---------------------------------------------------------------------------------------
178+type Experiment = TextDocumentIdentifier -> Session Bool
180+data Bench = forall setup.
183+ samples :: !Natural,
184+ benchSetup :: TextDocumentIdentifier -> Session setup,
185+ experiment :: setup -> Experiment
188+bench :: String -> Natural -> Experiment -> Bench
189+bench name samples userExperiment = Bench {..}
191+ experiment () = userExperiment
192+ benchSetup _ = return ()
197+ (TextDocumentIdentifier -> Session p) ->
198+ (p -> Experiment) ->
200+benchWithSetup = Bench
202+runBenchmarks :: HasConfig => [Bench] -> IO ()
203+runBenchmarks benchmarks = do
204+ results <- forM benchmarks $ \b -> (b,) <$> runBench b
206+ forM_ results $ \(Bench {name, samples}, duration) ->
211+ <> showDuration duration
216+ when (outputCSV ?config) $ do
217+ putStrLn $ intercalate ", " $ map name benchmarks
218+ putStrLn $ intercalate ", " $ map (showDuration . snd) results
220+runBench :: HasConfig => Bench -> IO Seconds
221+runBench Bench {..} = handleAny (\e -> print e >> return (-1))
222+ $ runSessionWithConfig conf cmd lspTestCaps dir
224+ doc <- openDoc exampleModulePath "haskell"
225+ void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
227+ liftIO $ output $ "Running " <> name <> " benchmark"
228+ userState <- benchSetup doc
229+ let loop 0 = return True
231+ (t, res) <- duration $ experiment userState doc
235+ output (showDuration t)
238+ (t, res) <- duration $ loop samples
241+ -- sleeep to give ghcide a chance to print the RTS stats
242+ liftIO $ threadDelay 50000
244+ return $ if res then t else -1
257+ [ ["--shake-profiling", path]
258+ | Just path <- [shakeProfiling ?config]
260+ dir = "bench/example/" <> examplePackage
262+ fullCaps {_window = Just $ WindowClientCapabilities $ Just True}
265+ { logStdErr = verbose ?config,
266+ logMessages = False,
270+setup :: HasConfig => IO (IO ())
272+ alreadyExists <- doesDirectoryExist examplesPath
273+ when alreadyExists $ removeDirectoryRecursive examplesPath
274+ callCommand $ "cabal get -v0 " <> examplePackage <> " -d " <> examplesPath
276+ (examplesPath </> examplePackage </> "hie.yaml")
277+ ("cradle: {cabal: {component: " <> show examplePackageName <> "}}")
279+ whenJust (shakeProfiling ?config) $ createDirectoryIfMissing True
281+ return $ removeDirectoryRecursive examplesPath
283+-- | Asks the server to shutdown and exit politely
284+exitServer :: Session ()
285+exitServer = request_ Shutdown (Nothing :: Maybe Value) >> sendNotification Exit ExitParams
287+--------------------------------------------------------------------------------------------