@@ -0,0 +1,287 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE ExistentialQuantification #-}
3+{-# LANGUAGE ImplicitParams #-}
4+
5+{- An automated benchmark built around the simple experiment described in:
6+
7+ > https://neilmitchell.blogspot.com/2020/05/fixing-space-leaks-in-ghcide.html
8+
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:
11+
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
15+
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:
20+
21+ > https://github.com/digital-asset/daml/blob/master/compiler/damlc/ide-debug-driver/README.md
22+
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
28+
29+ How to run:
30+ 1. `cabal bench`
31+ 2. `cabal exec <absolute-path-to-ghcide-bench> -- ghcide-bench-options`
32+
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.
36+
37+ -}
38+
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
44+import Data.Aeson
45+import Data.List
46+import Data.Maybe
47+import Data.Version
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 ((</>))
55+import System.Process
56+import System.Time.Extra
57+
58+-- Points to a string in the target file,
59+-- convenient for hygienic edits
60+hygienicP :: Position
61+hygienicP = Position 854 23
62+
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
67+
68+main :: IO ()
69+main = do
70+ config <- execParser $ info configP fullDesc
71+ let ?config = config
72+
73+ output "starting test"
74+
75+ cleanUp <- setup
76+
77+ runBenchmarks
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
89+ let change =
90+ TextDocumentContentChangeEvent
91+ { _range = Just (Range hygienicP hygienicP),
92+ _rangeLength = Nothing,
93+ _text = " "
94+ }
95+ changeDoc doc [change]
96+ either (not . null) (not . null) <$> getDocumentSymbols doc,
97+ ---------------------------------------------------------------------------------------
98+ bench "completions after edit" 10 $ \doc -> do
99+ let change =
100+ TextDocumentContentChangeEvent
101+ { _range = Just (Range hygienicP hygienicP),
102+ _rangeLength = Nothing,
103+ _text = " "
104+ }
105+ changeDoc doc [change]
106+ not . null <$> getCompletions doc identifierP,
107+ ---------------------------------------------------------------------------------------
108+ benchWithSetup
109+ "code actions"
110+ 10
111+ ( \doc -> do
112+ let p = identifierP
113+ let change =
114+ TextDocumentContentChangeEvent
115+ { _range = Just (Range p p),
116+ _rangeLength = Nothing,
117+ _text = "a"
118+ }
119+ changeDoc doc [change]
120+ void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
121+ return p
122+ )
123+ ( \p doc -> do
124+ not . null <$> getCodeActions doc (Range p p)
125+ ),
126+ ---------------------------------------------------------------------------------------
127+ bench "code actions after edit" 10 $ \doc -> do
128+ let p = identifierP
129+ let change =
130+ TextDocumentContentChangeEvent
131+ { _range = Just (Range p p),
132+ _rangeLength = Nothing,
133+ _text = "a"
134+ }
135+ changeDoc doc [change]
136+ void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
137+ not . null <$> getCodeActions doc (Range p p)
138+ ]
139+ `finally` cleanUp
140+
141+---------------------------------------------------------------------------------------------
142+
143+examplePackageName :: String
144+examplePackageName = "Cabal"
145+
146+examplePackageVersion :: Version
147+examplePackageVersion = makeVersion [3, 2, 0, 0]
148+
149+examplePackage :: String
150+examplePackage = examplePackageName <> "-" <> showVersion examplePackageVersion
151+
152+exampleModulePath :: FilePath
153+exampleModulePath = "Distribution" </> "Simple.hs"
154+
155+examplesPath :: FilePath
156+examplesPath = "bench/example"
157+
158+data Config = Config
159+ { verbose :: !Bool,
160+ -- For some reason, the Shake profile files are truncated and won't load
161+ shakeProfiling :: !(Maybe FilePath),
162+ outputCSV :: !Bool
163+ }
164+
165+type HasConfig = (?config :: Config)
166+
167+configP :: Parser Config
168+configP = Config
169+ <$> (not <$> switch (long "quiet"))
170+ <*> optional (strOption (long "shake-profiling" <> metavar "PATH"))
171+ <*> switch (long "csv")
172+
173+output :: (MonadIO m, HasConfig) => String -> m ()
174+output = if verbose ?config then liftIO . putStrLn else (\_ -> pure ())
175+
176+---------------------------------------------------------------------------------------
177+
178+type Experiment = TextDocumentIdentifier -> Session Bool
179+
180+data Bench = forall setup.
181+ Bench
182+ { name :: !String,
183+ samples :: !Natural,
184+ benchSetup :: TextDocumentIdentifier -> Session setup,
185+ experiment :: setup -> Experiment
186+ }
187+
188+bench :: String -> Natural -> Experiment -> Bench
189+bench name samples userExperiment = Bench {..}
190+ where
191+ experiment () = userExperiment
192+ benchSetup _ = return ()
193+
194+benchWithSetup ::
195+ String ->
196+ Natural ->
197+ (TextDocumentIdentifier -> Session p) ->
198+ (p -> Experiment) ->
199+ Bench
200+benchWithSetup = Bench
201+
202+runBenchmarks :: HasConfig => [Bench] -> IO ()
203+runBenchmarks benchmarks = do
204+ results <- forM benchmarks $ \b -> (b,) <$> runBench b
205+
206+ forM_ results $ \(Bench {name, samples}, duration) ->
207+ output $
208+ "TOTAL "
209+ <> name
210+ <> " = "
211+ <> showDuration duration
212+ <> " ("
213+ <> show samples
214+ <> " repetitions)"
215+
216+ when (outputCSV ?config) $ do
217+ putStrLn $ intercalate ", " $ map name benchmarks
218+ putStrLn $ intercalate ", " $ map (showDuration . snd) results
219+
220+runBench :: HasConfig => Bench -> IO Seconds
221+runBench Bench {..} = handleAny (\e -> print e >> return (-1))
222+ $ runSessionWithConfig conf cmd lspTestCaps dir
223+ $ do
224+ doc <- openDoc exampleModulePath "haskell"
225+ void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
226+
227+ liftIO $ output $ "Running " <> name <> " benchmark"
228+ userState <- benchSetup doc
229+ let loop 0 = return True
230+ loop n = do
231+ (t, res) <- duration $ experiment userState doc
232+ if not res
233+ then return False
234+ else do
235+ output (showDuration t)
236+ loop (n -1)
237+
238+ (t, res) <- duration $ loop samples
239+
240+ exitServer
241+ -- sleeep to give ghcide a chance to print the RTS stats
242+ liftIO $ threadDelay 50000
243+
244+ return $ if res then t else -1
245+ where
246+ cmd =
247+ unwords $
248+ [ "ghcide",
249+ "--lsp",
250+ "--cwd",
251+ dir,
252+ "+RTS",
253+ "-S",
254+ "-RTS"
255+ ]
256+ ++ concat
257+ [ ["--shake-profiling", path]
258+ | Just path <- [shakeProfiling ?config]
259+ ]
260+ dir = "bench/example/" <> examplePackage
261+ lspTestCaps =
262+ fullCaps {_window = Just $ WindowClientCapabilities $ Just True}
263+ conf =
264+ defaultConfig
265+ { logStdErr = verbose ?config,
266+ logMessages = False,
267+ logColor = False
268+ }
269+
270+setup :: HasConfig => IO (IO ())
271+setup = do
272+ alreadyExists <- doesDirectoryExist examplesPath
273+ when alreadyExists $ removeDirectoryRecursive examplesPath
274+ callCommand $ "cabal get -v0 " <> examplePackage <> " -d " <> examplesPath
275+ writeFile
276+ (examplesPath </> examplePackage </> "hie.yaml")
277+ ("cradle: {cabal: {component: " <> show examplePackageName <> "}}")
278+
279+ whenJust (shakeProfiling ?config) $ createDirectoryIfMissing True
280+
281+ return $ removeDirectoryRecursive examplesPath
282+
283+-- | Asks the server to shutdown and exit politely
284+exitServer :: Session ()
285+exitServer = request_ Shutdown (Nothing :: Maybe Value) >> sendNotification Exit ExitParams
286+
287+--------------------------------------------------------------------------------------------