ghcide-bench (empty) → 0.1
raw patch · 6 files changed
+1277/−0 lines, 6 filesdep +aesondep +asyncdep +base
Dependencies added: aeson, async, base, binary, bytestring, containers, data-default, deepseq, directory, extra, filepath, ghcide, ghcide-bench, ghcide-test-utils, hashable, hls-graph, hls-plugin-api, lens, lsp-test, lsp-types, optparse-applicative, parser-combinators, process, safe-exceptions, shake, tasty, tasty-hunit, tasty-rerun, text
Files
- LICENSE +201/−0
- exe/Main.hs +59/−0
- ghcide-bench.cabal +136/−0
- src/Experiments.hs +754/−0
- src/Experiments/Types.hs +79/−0
- test/Main.hs +48/−0
+ LICENSE view
@@ -0,0 +1,201 @@+ Apache License+ Version 2.0, January 2004+ http://www.apache.org/licenses/++ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++ 1. Definitions.++ "License" shall mean the terms and conditions for use, reproduction,+ and distribution as defined by Sections 1 through 9 of this document.++ "Licensor" shall mean the copyright owner or entity authorized by+ the copyright owner that is granting the License.++ "Legal Entity" shall mean the union of the acting entity and all+ other entities that control, are controlled by, or are under common+ control with that entity. For the purposes of this definition,+ "control" means (i) the power, direct or indirect, to cause the+ direction or management of such entity, whether by contract or+ otherwise, or (ii) ownership of fifty percent (50%) or more of the+ outstanding shares, or (iii) beneficial ownership of such entity.++ "You" (or "Your") shall mean an individual or Legal Entity+ exercising permissions granted by this License.++ "Source" form shall mean the preferred form for making modifications,+ including but not limited to software source code, documentation+ source, and configuration files.++ "Object" form shall mean any form resulting from mechanical+ transformation or translation of a Source form, including but+ not limited to compiled object code, generated documentation,+ and conversions to other media types.++ "Work" shall mean the work of authorship, whether in Source or+ Object form, made available under the License, as indicated by a+ copyright notice that is included in or attached to the work+ (an example is provided in the Appendix below).++ "Derivative Works" shall mean any work, whether in Source or Object+ form, that is based on (or derived from) the Work and for which the+ editorial revisions, annotations, elaborations, or other modifications+ represent, as a whole, an original work of authorship. For the purposes+ of this License, Derivative Works shall not include works that remain+ separable from, or merely link (or bind by name) to the interfaces of,+ the Work and Derivative Works thereof.++ "Contribution" shall mean any work of authorship, including+ the original version of the Work and any modifications or additions+ to that Work or Derivative Works thereof, that is intentionally+ submitted to Licensor for inclusion in the Work by the copyright owner+ or by an individual or Legal Entity authorized to submit on behalf of+ the copyright owner. For the purposes of this definition, "submitted"+ means any form of electronic, verbal, or written communication sent+ to the Licensor or its representatives, including but not limited to+ communication on electronic mailing lists, source code control systems,+ and issue tracking systems that are managed by, or on behalf of, the+ Licensor for the purpose of discussing and improving the Work, but+ excluding communication that is conspicuously marked or otherwise+ designated in writing by the copyright owner as "Not a Contribution."++ "Contributor" shall mean Licensor and any individual or Legal Entity+ on behalf of whom a Contribution has been received by Licensor and+ subsequently incorporated within the Work.++ 2. Grant of Copyright License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ copyright license to reproduce, prepare Derivative Works of,+ publicly display, publicly perform, sublicense, and distribute the+ Work and such Derivative Works in Source or Object form.++ 3. Grant of Patent License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ (except as stated in this section) patent license to make, have made,+ use, offer to sell, sell, import, and otherwise transfer the Work,+ where such license applies only to those patent claims licensable+ by such Contributor that are necessarily infringed by their+ Contribution(s) alone or by combination of their Contribution(s)+ with the Work to which such Contribution(s) was submitted. If You+ institute patent litigation against any entity (including a+ cross-claim or counterclaim in a lawsuit) alleging that the Work+ or a Contribution incorporated within the Work constitutes direct+ or contributory patent infringement, then any patent licenses+ granted to You under this License for that Work shall terminate+ as of the date such litigation is filed.++ 4. Redistribution. You may reproduce and distribute copies of the+ Work or Derivative Works thereof in any medium, with or without+ modifications, and in Source or Object form, provided that You+ meet the following conditions:++ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works+ that You distribute, all copyright, patent, trademark, and+ attribution notices from the Source form of the Work,+ excluding those notices that do not pertain to any part of+ the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its+ distribution, then any Derivative Works that You distribute must+ include a readable copy of the attribution notices contained+ within such NOTICE file, excluding those notices that do not+ pertain to any part of the Derivative Works, in at least one+ of the following places: within a NOTICE text file distributed+ as part of the Derivative Works; within the Source form or+ documentation, if provided along with the Derivative Works; or,+ within a display generated by the Derivative Works, if and+ wherever such third-party notices normally appear. The contents+ of the NOTICE file are for informational purposes only and+ do not modify the License. You may add Your own attribution+ notices within Derivative Works that You distribute, alongside+ or as an addendum to the NOTICE text from the Work, provided+ that such additional attribution notices cannot be construed+ as modifying the License.++ You may add Your own copyright statement to Your modifications and+ may provide additional or different license terms and conditions+ for use, reproduction, or distribution of Your modifications, or+ for any such Derivative Works as a whole, provided Your use,+ reproduction, and distribution of the Work otherwise complies with+ the conditions stated in this License.++ 5. Submission of Contributions. Unless You explicitly state otherwise,+ any Contribution intentionally submitted for inclusion in the Work+ by You to the Licensor shall be under the terms and conditions of+ this License, without any additional terms or conditions.+ Notwithstanding the above, nothing herein shall supersede or modify+ the terms of any separate license agreement you may have executed+ with Licensor regarding such Contributions.++ 6. Trademarks. This License does not grant permission to use the trade+ names, trademarks, service marks, or product names of the Licensor,+ except as required for reasonable and customary use in describing the+ origin of the Work and reproducing the content of the NOTICE file.++ 7. Disclaimer of Warranty. Unless required by applicable law or+ agreed to in writing, Licensor provides the Work (and each+ Contributor provides its Contributions) on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+ implied, including, without limitation, any warranties or conditions+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+ PARTICULAR PURPOSE. You are solely responsible for determining the+ appropriateness of using or redistributing the Work and assume any+ risks associated with Your exercise of permissions under this License.++ 8. Limitation of Liability. In no event and under no legal theory,+ whether in tort (including negligence), contract, or otherwise,+ unless required by applicable law (such as deliberate and grossly+ negligent acts) or agreed to in writing, shall any Contributor be+ liable to You for damages, including any direct, indirect, special,+ incidental, or consequential damages of any character arising as a+ result of this License or out of the use or inability to use the+ Work (including but not limited to damages for loss of goodwill,+ work stoppage, computer failure or malfunction, or any and all+ other commercial damages or losses), even if such Contributor+ has been advised of the possibility of such damages.++ 9. Accepting Warranty or Additional Liability. While redistributing+ the Work or Derivative Works thereof, You may choose to offer,+ and charge a fee for, acceptance of support, warranty, indemnity,+ or other liability obligations and/or rights consistent with this+ License. However, in accepting such obligations, You may act only+ on Your own behalf and on Your sole responsibility, not on behalf+ of any other Contributor, and only if You agree to indemnify,+ defend, and hold each Contributor harmless for any liability+ incurred by, or claims asserted against, such Contributor by reason+ of your accepting any such warranty or additional liability.++ END OF TERMS AND CONDITIONS++ APPENDIX: How to apply the Apache License to your work.++ To apply the Apache License to your work, attach the following+ boilerplate notice, with the fields enclosed by brackets "[]"+ replaced with your own identifying information. (Don't include+ the brackets!) The text should be enclosed in the appropriate+ comment syntax for the file format. We also recommend that a+ file or class name and description of purpose be included on the+ same "printed page" as the copyright notice for easier+ identification within third-party archives.++ Copyright [yyyy] [name of copyright owner]++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.
+ exe/Main.hs view
@@ -0,0 +1,59 @@+{- 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 exec cabal run ghcide-bench -- -- ghcide-bench-options`+ 1. `stack build ghcide:ghcide-bench && stack exec 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 Control.Monad+import Experiments+import Options.Applicative+import System.IO++optsP :: Parser (Config, Bool)+optsP = (,) <$> configP <*> switch (long "no-clean")++main :: IO ()+main = do+ hSetBuffering stdout LineBuffering+ hSetBuffering stderr LineBuffering+ (config, noClean) <- execParser $ info (optsP <**> helper) fullDesc+ let ?config = config++ hPrint stderr config++ output "starting test"++ SetupResult{..} <- setup++ runBenchmarks experiments `finally` unless noClean cleanUp
+ ghcide-bench.cabal view
@@ -0,0 +1,136 @@+cabal-version: 3.0+build-type: Simple+category: Development+name: ghcide-bench+version: 0.1+license: Apache-2.0+license-file: LICENSE+author: The Haskell IDE team+maintainer: pepeiborra@gmail.com+copyright: The Haskell IDE team+synopsis: An LSP client for running performance experiments on HLS+description: An LSP client for running performance experiments on HLS+homepage: https://github.com/haskell/haskell-language-server/tree/master/ghcide#readme+bug-reports: https://github.com/haskell/haskell-language-server/issues+tested-with: GHC == 8.6.5 || == 8.8.4 || == 8.10.7 || == 9.0.2 || == 9.2.3 || == 9.2.4++executable ghcide-bench+ default-language: Haskell2010+ build-depends:+ aeson,+ base,+ bytestring,+ containers,+ data-default,+ directory,+ extra,+ filepath,+ hls-plugin-api,+ lens,+ ghcide-bench,+ lsp-test,+ lsp-types,+ optparse-applicative,+ process,+ safe-exceptions,+ hls-graph,+ shake,+ tasty-hunit >= 0.10,+ text+ hs-source-dirs: exe+ ghc-options: -threaded -Wall -Wno-name-shadowing -rtsopts+ main-is: Main.hs+ default-extensions:+ BangPatterns+ DeriveFunctor+ DeriveGeneric+ FlexibleContexts+ GeneralizedNewtypeDeriving+ LambdaCase+ NamedFieldPuns+ OverloadedStrings+ RecordWildCards+ ScopedTypeVariables+ StandaloneDeriving+ TupleSections+ TypeApplications+ ViewPatterns++library+ default-language: Haskell2010+ hs-source-dirs: src+ ghc-options: -Wall -Wno-name-shadowing+ exposed-modules:+ Experiments.Types+ Experiments+ build-depends:+ aeson,+ async,+ base == 4.*,+ binary,+ bytestring,+ deepseq,+ directory,+ extra,+ filepath,+ ghcide,+ ghcide-test-utils,+ hashable,+ lens,+ lsp-test,+ lsp-types,+ optparse-applicative,+ parser-combinators,+ process,+ safe-exceptions,+ shake,+ text,+ default-extensions:+ BangPatterns+ DeriveFunctor+ DeriveGeneric+ FlexibleContexts+ GeneralizedNewtypeDeriving+ LambdaCase+ NamedFieldPuns+ RecordWildCards+ ScopedTypeVariables+ StandaloneDeriving+ TupleSections+ TypeApplications+ ViewPatterns++test-suite test+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ build-tool-depends:+ ghcide:ghcide,+ implicit-hie:gen-hie+ main-is: Main.hs+ hs-source-dirs: test+ ghc-options: -Wunused-packages+ ghc-options: -threaded -Wall+ build-depends:+ base,+ extra,+ ghcide-bench,+ lsp-test ^>= 0.14,+ tasty,+ tasty-hunit >= 0.10,+ tasty-rerun,+ default-extensions:+ BangPatterns+ DeriveFunctor+ DeriveGeneric+ FlexibleContexts+ GeneralizedNewtypeDeriving+ LambdaCase+ NamedFieldPuns+ OverloadedStrings+ RecordWildCards+ ScopedTypeVariables+ StandaloneDeriving+ TupleSections+ TypeApplications+ ViewPatterns+
+ src/Experiments.hs view
@@ -0,0 +1,754 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# OPTIONS_GHC -Wno-deprecations -Wno-unticked-promoted-constructors #-}++module Experiments+( Bench(..)+, BenchRun(..)+, Config(..)+, Verbosity(..)+, CabalStack(..)+, SetupResult(..)+, Example(..)+, experiments+, configP+, defConfig+, output+, setup+, runBench+, exampleToOptions+) where+import Control.Applicative.Combinators (skipManyTill)+import Control.Concurrent.Async (withAsync)+import Control.Exception.Safe (IOException, handleAny, try)+import Control.Monad.Extra (allM, forM, forM_, forever,+ unless, void, when, whenJust,+ (&&^))+import Control.Monad.Fail (MonadFail)+import Control.Monad.IO.Class+import Data.Aeson (Value (Null),+ eitherDecodeStrict', toJSON)+import qualified Data.Aeson as A+import qualified Data.ByteString as BS+import Data.Either (fromRight)+import Data.List+import Data.Maybe+import Data.Text (Text)+import qualified Data.Text as T+import Data.Version+import Development.IDE.Plugin.Test+import Development.IDE.Test.Diagnostic+import Development.Shake (CmdOption (Cwd, FileStdout),+ cmd_)+import Experiments.Types+import Language.LSP.Test+import Language.LSP.Types hiding+ (SemanticTokenAbsolute (length, line),+ SemanticTokenRelative (length),+ SemanticTokensEdit (_start))+import Language.LSP.Types.Capabilities+import Numeric.Natural+import Options.Applicative+import System.Directory+import System.Environment.Blank (getEnv)+import System.FilePath ((<.>), (</>))+import System.IO+import System.Process+import System.Time.Extra+import Text.ParserCombinators.ReadP (readP_to_S)+import Text.Printf++charEdit :: Position -> TextDocumentContentChangeEvent+charEdit p =+ TextDocumentContentChangeEvent+ { _range = Just (Range p p),+ _rangeLength = Nothing,+ _text = "a"+ }++data DocumentPositions = DocumentPositions {+ -- | A position that can be used to generate non null goto-def and completion responses+ identifierP :: Maybe Position,+ -- | A position that can be modified without generating a new diagnostic+ stringLiteralP :: !Position,+ -- | The document containing the above positions+ doc :: !TextDocumentIdentifier+}++allWithIdentifierPos :: MonadFail m => (DocumentPositions -> m Bool) -> [DocumentPositions] -> m Bool+allWithIdentifierPos f docs = case applicableDocs of+ -- fail if there are no documents to benchmark+ [] -> fail "None of the example modules have identifier positions"+ docs' -> allM f docs'+ where+ applicableDocs = filter (isJust . identifierP) docs++experiments :: HasConfig => [Bench]+experiments =+ [ ---------------------------------------------------------------------------------------+ bench "hover" $ allWithIdentifierPos $ \DocumentPositions{..} ->+ isJust <$> getHover doc (fromJust identifierP),+ ---------------------------------------------------------------------------------------+ bench "edit" $ \docs -> do+ forM_ docs $ \DocumentPositions{..} -> do+ changeDoc doc [charEdit stringLiteralP]+ -- wait for a fresh build start+ waitForProgressStart+ -- wait for the build to be finished+ output "edit: waitForProgressDone"+ waitForProgressDone+ return True,+ ---------------------------------------------------------------------------------------+ bench "hover after edit" $ \docs -> do+ forM_ docs $ \DocumentPositions{..} ->+ changeDoc doc [charEdit stringLiteralP]+ flip allWithIdentifierPos docs $ \DocumentPositions{..} ->+ isJust <$> getHover doc (fromJust identifierP),+ ---------------------------------------------------------------------------------------+ bench "getDefinition" $ allWithIdentifierPos $ \DocumentPositions{..} ->+ either (not . null) (not . null) . toEither <$> getDefinitions doc (fromJust identifierP),+ ---------------------------------------------------------------------------------------+ bench "getDefinition after edit" $ \docs -> do+ forM_ docs $ \DocumentPositions{..} ->+ changeDoc doc [charEdit stringLiteralP]+ flip allWithIdentifierPos docs $ \DocumentPositions{..} ->+ either (not . null) (not . null) . toEither <$> getDefinitions doc (fromJust identifierP),+ ---------------------------------------------------------------------------------------+ bench "documentSymbols" $ allM $ \DocumentPositions{..} -> do+ fmap (either (not . null) (not . null)) . getDocumentSymbols $ doc,+ ---------------------------------------------------------------------------------------+ bench "documentSymbols after edit" $ \docs -> do+ forM_ docs $ \DocumentPositions{..} ->+ changeDoc doc [charEdit stringLiteralP]+ flip allM docs $ \DocumentPositions{..} ->+ either (not . null) (not . null) <$> getDocumentSymbols doc,+ ---------------------------------------------------------------------------------------+ bench "completions" $ \docs -> do+ flip allWithIdentifierPos docs $ \DocumentPositions{..} ->+ not . null <$> getCompletions doc (fromJust identifierP),+ ---------------------------------------------------------------------------------------+ bench "completions after edit" $ \docs -> do+ forM_ docs $ \DocumentPositions{..} ->+ changeDoc doc [charEdit stringLiteralP]+ flip allWithIdentifierPos docs $ \DocumentPositions{..} ->+ not . null <$> getCompletions doc (fromJust identifierP),+ ---------------------------------------------------------------------------------------+ benchWithSetup+ "code actions"+ ( \docs -> do+ unless (any (isJust . identifierP) docs) $+ error "None of the example modules is suitable for this experiment"+ forM_ docs $ \DocumentPositions{..} -> do+ forM_ identifierP $ \p -> changeDoc doc [charEdit p]+ waitForProgressStart+ waitForProgressDone+ )+ ( \docs -> not . null . catMaybes <$> forM docs (\DocumentPositions{..} ->+ forM identifierP $ \p ->+ getCodeActions doc (Range p p))+ ),+ ---------------------------------------------------------------------------------------+ benchWithSetup+ "code actions after edit"+ ( \docs -> do+ unless (any (isJust . identifierP) docs) $+ error "None of the example modules is suitable for this experiment"+ forM_ docs $ \DocumentPositions{..} ->+ forM_ identifierP $ \p -> changeDoc doc [charEdit p]+ )+ ( \docs -> do+ forM_ docs $ \DocumentPositions{..} -> do+ changeDoc doc [charEdit stringLiteralP]+ waitForProgressStart+ waitForProgressDone+ not . null . catMaybes <$> forM docs (\DocumentPositions{..} -> do+ forM identifierP $ \p ->+ getCodeActions doc (Range p p))+ ),+ ---------------------------------------------------------------------------------------+ benchWithSetup+ "code actions after cradle edit"+ ( \docs -> do+ forM_ docs $ \DocumentPositions{..} -> do+ forM identifierP $ \p -> do+ changeDoc doc [charEdit p]+ waitForProgressStart+ void waitForBuildQueue+ )+ ( \docs -> do+ hieYamlUri <- getDocUri "hie.yaml"+ liftIO $ appendFile (fromJust $ uriToFilePath hieYamlUri) "##\n"+ sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $+ List [ FileEvent hieYamlUri FcChanged ]+ waitForProgressStart+ waitForProgressStart+ waitForProgressStart -- the Session logic restarts a second time+ waitForProgressDone+ not . all null . catMaybes <$> forM docs (\DocumentPositions{..} -> do+ forM identifierP $ \p ->+ getCodeActions doc (Range p p))+ ),+ ---------------------------------------------------------------------------------------+ bench+ "hover after cradle edit"+ (\docs -> do+ hieYamlUri <- getDocUri "hie.yaml"+ liftIO $ appendFile (fromJust $ uriToFilePath hieYamlUri) "##\n"+ sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $+ List [ FileEvent hieYamlUri FcChanged ]+ flip allWithIdentifierPos docs $ \DocumentPositions{..} -> isJust <$> getHover doc (fromJust identifierP)+ ),+ ---------------------------------------------------------------------------------------+ benchWithSetup+ "hole fit suggestions"+ ( mapM_ $ \DocumentPositions{..} -> do+ let edit :: TextDocumentContentChangeEvent =TextDocumentContentChangeEvent+ { _range = Just Range {_start = bottom, _end = bottom}+ , _rangeLength = Nothing, _text = t}+ bottom = Position maxBound 0+ t = T.unlines+ [""+ ,"holef :: [Int] -> [Int]"+ ,"holef = _"+ ,""+ ,"holeg :: [()] -> [()]"+ ,"holeg = _"+ ]+ changeDoc doc [edit]+ )+ (\docs -> do+ forM_ docs $ \DocumentPositions{..} ->+ changeDoc doc [charEdit stringLiteralP]+ void waitForDiagnostics+ waitForProgressDone+ flip allM docs $ \DocumentPositions{..} -> do+ bottom <- pred . length . T.lines <$> documentContents doc+ diags <- getCurrentDiagnostics doc+ case requireDiagnostic diags (DsError, (fromIntegral bottom, 8), "Found hole", Nothing) of+ Nothing -> pure True+ Just _err -> pure False+ )+ ]++---------------------------------------------------------------------------------------------++examplesPath :: FilePath+examplesPath = "bench/example"++defConfig :: Config+Success defConfig = execParserPure defaultPrefs (info configP fullDesc) []++quiet, verbose :: Config -> Bool+verbose = (== All) . verbosity+quiet = (== Quiet) . verbosity++type HasConfig = (?config :: Config)++configP :: Parser Config+configP =+ Config+ <$> (flag' All (short 'v' <> long "verbose")+ <|> flag' Quiet (short 'q' <> long "quiet")+ <|> pure Normal+ )+ <*> optional (strOption (long "shake-profiling" <> metavar "PATH"))+ <*> optional (strOption (long "ot-profiling" <> metavar "DIR" <> help "Enable OpenTelemetry and write eventlog for each benchmark in DIR"))+ <*> strOption (long "csv" <> metavar "PATH" <> value "results.csv" <> showDefault)+ <*> flag Cabal Stack (long "stack" <> help "Use stack (by default cabal is used)")+ <*> many (strOption (long "ghcide-options" <> help "additional 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"))+ <*> strOption (long "ghcide" <> metavar "PATH" <> help "path to ghcide" <> value "ghcide")+ <*> option auto (long "timeout" <> value 60 <> help "timeout for waiting for a ghcide response")+ <*> ( Example "name"+ <$> (Right <$> packageP)+ <*> (some moduleOption <|> pure ["src/Distribution/Simple.hs"])+ <*> pure []+ <|>+ Example "name"+ <$> (Left <$> pathP)+ <*> some moduleOption+ <*> pure [])+ <*> switch (long "lsp-config" <> help "Read an LSP config payload from standard input")+ where+ moduleOption = strOption (long "example-module" <> metavar "PATH")++ packageP = ExamplePackage+ <$> strOption (long "example-package-name" <> value "Cabal")+ <*> option versionP (long "example-package-version" <> value (makeVersion [3,6,0,0]))+ pathP = strOption (long "example-path")++versionP :: ReadM Version+versionP = maybeReader $ extract . readP_to_S parseVersion+ where+ extract parses = listToMaybe [ res | (res,"") <- parses]++output :: (MonadIO m, HasConfig) => String -> m ()+output = if quiet?config then (\_ -> pure ()) else liftIO . putStrLn++---------------------------------------------------------------------------------------++type Experiment = [DocumentPositions] -> Session Bool++data Bench =+ Bench+ { name :: !String,+ enabled :: !Bool,+ samples :: !Natural,+ benchSetup :: [DocumentPositions] -> Session (),+ experiment :: Experiment+ }++select :: HasConfig => Bench -> Bool+select Bench {name, enabled} =+ enabled && (null mm || name `elem` mm)+ where+ mm = matches ?config++benchWithSetup ::+ String ->+ ([DocumentPositions] -> Session ()) ->+ Experiment ->+ Bench+benchWithSetup name benchSetup experiment = Bench {..}+ where+ enabled = True+ samples = 100++bench :: String -> Experiment -> Bench+bench name = benchWithSetup name (const $ pure ())++runBenchmarksFun :: HasConfig => FilePath -> [Bench] -> IO ()+runBenchmarksFun dir allBenchmarks = do+ let benchmarks = [ b{samples = fromMaybe 100 (repetitions ?config) }+ | b <- allBenchmarks+ , select b ]++ whenJust (otMemoryProfiling ?config) $ \eventlogDir ->+ createDirectoryIfMissing True eventlogDir++ lspConfig <- if Experiments.Types.lspConfig ?config+ then either error Just . eitherDecodeStrict' <$> BS.getContents+ else return Nothing++ let conf = defaultConfig+ { logStdErr = verbose ?config,+ logMessages = verbose ?config,+ logColor = False,+ Language.LSP.Test.lspConfig = lspConfig,+ messageTimeout = timeoutLsp ?config+ }+ results <- forM benchmarks $ \b@Bench{name} -> do+ let p = (proc (ghcide ?config) (allArgs name dir))+ { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe }+ run sess = withCreateProcess p $ \(Just inH) (Just outH) (Just errH) pH -> do+ -- Need to continuously consume to stderr else it gets blocked+ -- Can't pass NoStream either to std_err+ hSetBuffering errH NoBuffering+ hSetBinaryMode errH True+ let errSinkThread =+ forever $ hGetLine errH >>= when (verbose ?config). putStrLn+ withAsync errSinkThread $ \_ -> do+ runSessionWithHandles' (Just pH) inH outH conf lspTestCaps dir sess+ (b,) <$> runBench run b++ -- output raw data as CSV+ let headers =+ [ "name"+ , "success"+ , "samples"+ , "startup"+ , "setup"+ , "userT"+ , "delayedT"+ , "1stBuildT"+ , "avgPerRespT"+ , "totalT"+ , "rulesBuilt"+ , "rulesChanged"+ , "rulesVisited"+ , "rulesTotal"+ , "ruleEdges"+ , "ghcRebuilds"+ ]+ rows =+ [ [ name,+ show success,+ show samples,+ showMs startup,+ showMs runSetup',+ showMs userWaits,+ showMs delayedWork,+ showMs $ firstResponse+firstResponseDelayed,+ -- Exclude first response as it has a lot of setup time included+ -- Assume that number of requests = number of modules * number of samples+ showMs ((userWaits - firstResponse)/((fromIntegral samples - 1)*modules)),+ showMs runExperiment,+ show rulesBuilt,+ show rulesChanged,+ show rulesVisited,+ show rulesTotal,+ show edgesTotal,+ show rebuildsTotal+ ]+ | (Bench {name, samples}, BenchRun {..}) <- results,+ let runSetup' = if runSetup < 0.01 then 0 else runSetup+ modules = fromIntegral $ length $ exampleModules $ example ?config+ ]+ csv = unlines $ map (intercalate ", ") (headers : rows)+ writeFile (outputCSV ?config) csv++ -- print a nice table+ let pads = map (maximum . map length) (transpose (headers : rowsHuman))+ paddedHeaders = zipWith pad pads headers+ outputRow = putStrLn . intercalate " | "+ rowsHuman =+ [ [ name,+ show success,+ show samples,+ showDuration startup,+ showDuration runSetup',+ showDuration userWaits,+ showDuration delayedWork,+ showDuration firstResponse,+ showDuration runExperiment,+ show rulesBuilt,+ show rulesChanged,+ show rulesVisited,+ show rulesTotal,+ show edgesTotal,+ show rebuildsTotal+ ]+ | (Bench {name, samples}, BenchRun {..}) <- results,+ let runSetup' = if runSetup < 0.01 then 0 else runSetup+ ]+ outputRow paddedHeaders+ outputRow $ (map . map) (const '-') paddedHeaders+ forM_ rowsHuman $ \row -> outputRow $ zipWith pad pads row+ where+ ghcideArgs dir =+ [ "--lsp",+ "--test",+ "--cwd",+ dir+ ]+ allArgs name dir =+ ghcideArgs dir+ ++ concat+ [ [ "+RTS"+ , "-l"+ , "-ol" ++ (dir </> map (\c -> if c == ' ' then '-' else c) name <.> "eventlog")+ , "-RTS"+ ]+ | Just dir <- [otMemoryProfiling ?config]+ ]+ ++ ghcideOptions ?config+ ++ concat+ [ ["--shake-profiling", path] | Just path <- [shakeProfiling ?config]+ ]+ ++ ["--ot-memory-profiling" | Just _ <- [otMemoryProfiling ?config]]+ lspTestCaps =+ fullCaps {_window = Just $ WindowClientCapabilities (Just True) Nothing Nothing }++showMs :: Seconds -> String+showMs = printf "%.2f"++data BenchRun = BenchRun+ { startup :: !Seconds,+ runSetup :: !Seconds,+ runExperiment :: !Seconds,+ userWaits :: !Seconds,+ delayedWork :: !Seconds,+ firstResponse :: !Seconds,+ firstResponseDelayed :: !Seconds,+ rulesBuilt :: !Int,+ rulesChanged :: !Int,+ rulesVisited :: !Int,+ rulesTotal :: !Int,+ edgesTotal :: !Int,+ rebuildsTotal :: !Int,+ success :: !Bool+ }++badRun :: BenchRun+badRun = BenchRun 0 0 0 0 0 0 0 0 0 0 0 0 0 False++waitForProgressStart :: Session ()+waitForProgressStart = void $ do+ skipManyTill anyMessage $ satisfy $ \case+ FromServerMess SWindowWorkDoneProgressCreate _ -> True+ _ -> False++-- | Wait for all progress to be done+-- Needs at least one progress done notification to return+waitForProgressDone :: Session ()+waitForProgressDone = loop+ where+ loop = do+ ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case+ FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just ()+ _ -> Nothing+ done <- null <$> getIncompleteProgressSessions+ unless done loop++-- | Wait for the build queue to be empty+waitForBuildQueue :: Session Seconds+waitForBuildQueue = do+ let m = SCustomMethod "test"+ waitId <- sendRequest m (toJSON WaitForShakeQueue)+ (td, resp) <- duration $ skipManyTill anyMessage $ responseForId m waitId+ case resp of+ ResponseMessage{_result=Right Null} -> return td+ -- assume a ghcide binary lacking the WaitForShakeQueue method+ _ -> return 0++runBench ::+ HasConfig =>+ (Session BenchRun -> IO BenchRun) ->+ Bench ->+ IO BenchRun+runBench runSess b = handleAny (\e -> print e >> return badRun)+ $ runSess+ $ do+ case b of+ Bench{..} -> do+ (startup, docs) <- duration $ do+ (d, docs) <- duration $ setupDocumentContents ?config+ output $ "Setting up document contents took " <> showDuration d+ -- wait again, as the progress is restarted once while loading the cradle+ -- make an edit, to ensure this doesn't block+ let DocumentPositions{..} = head docs+ changeDoc doc [charEdit stringLiteralP]+ waitForProgressDone+ return docs++ liftIO $ output $ "Running " <> name <> " benchmark"+ (runSetup, ()) <- duration $ benchSetup docs+ let loop' (Just timeForFirstResponse) !userWaits !delayedWork 0 = return $ Just (userWaits, delayedWork, timeForFirstResponse)+ loop' timeForFirstResponse !userWaits !delayedWork n = do+ (t, res) <- duration $ experiment docs+ if not res+ then return Nothing+ else do+ output (showDuration t)+ -- Wait for the delayed actions to finish+ td <- waitForBuildQueue+ loop' (timeForFirstResponse <|> (Just (t,td))) (userWaits+t) (delayedWork+td) (n -1)+ loop = loop' Nothing++ (runExperiment, result) <- duration $ loop 0 0 samples+ let success = isJust result+ (userWaits, delayedWork, (firstResponse, firstResponseDelayed)) = fromMaybe (0,0,(0,0)) result++ rulesTotal <- length <$> getStoredKeys+ rulesBuilt <- either (const 0) length <$> getBuildKeysBuilt+ rulesChanged <- either (const 0) length <$> getBuildKeysChanged+ rulesVisited <- either (const 0) length <$> getBuildKeysVisited+ edgesTotal <- fromRight 0 <$> getBuildEdgesCount+ rebuildsTotal <- fromRight 0 <$> getRebuildsCount++ return BenchRun {..}++data SetupResult = SetupResult {+ runBenchmarks :: [Bench] -> IO (),+ -- | Path to the setup benchmark example+ benchDir :: FilePath,+ cleanUp :: IO ()+}++callCommandLogging :: HasConfig => String -> IO ()+callCommandLogging cmd = do+ output cmd+ callCommand cmd++setup :: HasConfig => IO SetupResult+setup = do+-- when alreadyExists $ removeDirectoryRecursive examplesPath+ benchDir <- case exampleDetails(example ?config) of+ Left examplePath -> do+ let hieYamlPath = examplePath </> "hie.yaml"+ alreadyExists <- doesFileExist hieYamlPath+ unless alreadyExists $+ cmd_ (Cwd examplePath) (FileStdout hieYamlPath) ("gen-hie"::String)+ return examplePath+ Right ExamplePackage{..} -> do+ let path = examplesPath </> package+ package = packageName <> "-" <> showVersion packageVersion+ hieYamlPath = path </> "hie.yaml"+ alreadySetup <- doesDirectoryExist path+ unless alreadySetup $+ case buildTool ?config of+ Cabal -> do+ let cabalVerbosity = "-v" ++ show (fromEnum (verbose ?config))+ callCommandLogging $ "cabal get " <> cabalVerbosity <> " " <> package <> " -d " <> examplesPath+ let hieYamlPath = path </> "hie.yaml"+ cmd_ (Cwd path) (FileStdout hieYamlPath) ("gen-hie"::String)+ -- Need this in case there is a parent cabal.project somewhere+ writeFile+ (path </> "cabal.project")+ "packages: ."+ writeFile+ (path </> "cabal.project.local")+ ""+ Stack -> do+ let stackVerbosity = case verbosity ?config of+ Quiet -> "--silent"+ Normal -> ""+ All -> "--verbose"+ callCommandLogging $ "stack " <> stackVerbosity <> " unpack " <> package <> " --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"]+ ]+ )++ cmd_ (Cwd path) (FileStdout hieYamlPath) ("gen-hie"::String) ["--stack"::String]+ return path++ whenJust (shakeProfiling ?config) $ createDirectoryIfMissing True++ let cleanUp = case exampleDetails(example ?config) of+ Right _ -> removeDirectoryRecursive examplesPath+ Left _ -> return ()++ runBenchmarks = runBenchmarksFun benchDir++ return SetupResult{..}++setupDocumentContents :: Config -> Session [DocumentPositions]+setupDocumentContents config =+ forM (exampleModules $ example config) $ \m -> do+ doc <- openDoc m "haskell"++ -- Setup the special positions used by the experiments+ lastLine <- fromIntegral . length . T.lines <$> documentContents doc+ changeDoc doc [TextDocumentContentChangeEvent+ { _range = Just (Range (Position lastLine 0) (Position lastLine 0))+ , _rangeLength = Nothing+ , _text = T.unlines [ "_hygienic = \"hygienic\"" ]+ }]+ let+ -- Points to a string in the target file,+ -- convenient for hygienic edits+ stringLiteralP = Position lastLine 15++ -- Find an identifier defined in another file in this project+ symbols <- getDocumentSymbols doc+ let endOfImports = case symbols of+ Left symbols | Just x <- findEndOfImports symbols -> x+ _ -> error $ "symbols: " <> show symbols+ contents <- documentContents doc+ identifierP <- searchSymbol doc contents endOfImports+ return $ DocumentPositions{..}++findEndOfImports :: [DocumentSymbol] -> Maybe Position+findEndOfImports (DocumentSymbol{_kind = SkModule, _name = "imports", _range} : _) =+ Just $ Position (succ $ _line $ _end _range) 4+findEndOfImports [DocumentSymbol{_kind = SkFile, _children = Just (List cc)}] =+ findEndOfImports cc+findEndOfImports (DocumentSymbol{_range} : _) =+ Just $ _start _range+findEndOfImports _ = Nothing++--------------------------------------------------------------------------------------------++pad :: Int -> String -> String+pad n [] = replicate n ' '+pad 0 _ = error "pad"+pad n (x:xx) = x : pad (n-1) xx++-- | Search for a position where:+-- - get definition works and returns a uri other than this file+-- - get completions returns a non empty list+searchSymbol :: TextDocumentIdentifier -> T.Text -> Position -> Session (Maybe Position)+searchSymbol doc@TextDocumentIdentifier{_uri} fileContents pos = do+ -- this search is expensive, so we cache the result on disk+ let cachedPath = fromJust (uriToFilePath _uri) <.> "identifierPosition"+ cachedRes <- liftIO $ try @_ @IOException $ read <$> readFile cachedPath+ case cachedRes of+ Left _ -> do+ result <- loop pos+ liftIO $ writeFile cachedPath $ show result+ return result+ Right res ->+ return res+ where+ loop pos+ | (fromIntegral $ _line pos) >= lll =+ return Nothing+ | (fromIntegral $ _character pos) >= lengthOfLine (fromIntegral $ _line pos) =+ loop (nextLine pos)+ | otherwise = do+ checks <- checkDefinitions pos &&^ checkCompletions pos+ if checks+ then return $ Just pos+ else loop (nextIdent pos)++ nextIdent p = p{_character = _character p + 2}+ nextLine p = Position (_line p + 1) 4++ lengthOfLine n = if n >= lll then 0 else T.length (ll !! n)+ ll = T.lines fileContents+ lll = length ll++ checkDefinitions pos = do+ defs <- getDefinitions doc pos+ case defs of+ (InL [Location uri _]) -> return $ uri /= _uri+ _ -> return False+ checkCompletions pos =+ not . null <$> getCompletions doc pos+++getBuildKeysBuilt :: Session (Either ResponseError [T.Text])+getBuildKeysBuilt = tryCallTestPlugin GetBuildKeysBuilt++getBuildKeysVisited :: Session (Either ResponseError [T.Text])+getBuildKeysVisited = tryCallTestPlugin GetBuildKeysVisited++getBuildKeysChanged :: Session (Either ResponseError [T.Text])+getBuildKeysChanged = tryCallTestPlugin GetBuildKeysChanged++getBuildEdgesCount :: Session (Either ResponseError Int)+getBuildEdgesCount = tryCallTestPlugin GetBuildEdgesCount++getRebuildsCount :: Session (Either ResponseError Int)+getRebuildsCount = tryCallTestPlugin GetRebuildsCount++-- Copy&paste from ghcide/test/Development.IDE.Test+getStoredKeys :: Session [Text]+getStoredKeys = callTestPlugin GetStoredKeys++-- Copy&paste from ghcide/test/Development.IDE.Test+tryCallTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either ResponseError b)+tryCallTestPlugin cmd = do+ let cm = SCustomMethod "test"+ waitId <- sendRequest cm (A.toJSON cmd)+ ResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId+ return $ case _result of+ Left e -> Left e+ Right json -> case A.fromJSON json of+ A.Success a -> Right a+ A.Error e -> error e++-- Copy&paste from ghcide/test/Development.IDE.Test+callTestPlugin :: (A.FromJSON b) => TestRequest -> Session b+callTestPlugin cmd = do+ res <- tryCallTestPlugin cmd+ case res of+ Left (ResponseError t err _) -> error $ show t <> ": " <> T.unpack err+ Right a -> pure a
+ src/Experiments/Types.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE OverloadedStrings #-}+module Experiments.Types (module Experiments.Types ) where++import Control.DeepSeq+import Data.Aeson+import Data.Binary (Binary)+import Data.Hashable (Hashable)+import Data.Maybe (fromMaybe)+import Data.Version+import GHC.Generics+import Numeric.Natural++data CabalStack = Cabal | Stack+ deriving (Eq, Show)++data Verbosity = Quiet | Normal | All+ deriving (Eq, Show)+data Config = Config+ { verbosity :: !Verbosity,+ -- For some reason, the Shake profile files are truncated and won't load+ shakeProfiling :: !(Maybe FilePath),+ otMemoryProfiling :: !(Maybe FilePath),+ outputCSV :: !FilePath,+ buildTool :: !CabalStack,+ ghcideOptions :: ![String],+ matches :: ![String],+ repetitions :: Maybe Natural,+ ghcide :: FilePath,+ timeoutLsp :: Int,+ example :: Example,+ lspConfig :: Bool+ }+ deriving (Eq, Show)++data ExamplePackage = ExamplePackage {packageName :: !String, packageVersion :: !Version}+ deriving (Eq, Generic, Show)+ deriving anyclass (Binary, Hashable, NFData)++data Example = Example+ { exampleName :: !String+ , exampleDetails :: Either FilePath ExamplePackage+ , exampleModules :: [FilePath]+ , exampleExtraArgs :: [String]}+ deriving (Eq, Generic, Show)+ deriving anyclass (Binary, Hashable, NFData)++instance FromJSON Example where+ parseJSON = withObject "example" $ \x -> do+ exampleName <- x .: "name"+ exampleModules <- x .: "modules"+ exampleExtraArgs <- fromMaybe [] <$> x .:? "extra-args"++ path <- x .:? "path"+ case path of+ Just examplePath -> do+ let exampleDetails = Left examplePath+ return Example{..}+ Nothing -> do+ packageName <- x .: "package"+ packageVersion <- x .: "version"+ let exampleDetails = Right ExamplePackage{..}+ return Example{..}++exampleToOptions :: Example -> [String] -> [String]+exampleToOptions Example{exampleDetails = Right ExamplePackage{..}, ..} extraArgs =+ ["--example-package-name", packageName+ ,"--example-package-version", showVersion packageVersion+ ] +++ ["--example-module=" <> m | m <- exampleModules+ ] +++ ["--ghcide-options=" <> o | o <- exampleExtraArgs ++ extraArgs]+exampleToOptions Example{exampleDetails = Left examplePath, ..} extraArgs =+ ["--example-path", examplePath+ ] +++ ["--example-module=" <> m | m <- exampleModules+ ] +++ ["--ghcide-options=" <> o | o <- exampleExtraArgs ++ extraArgs]
+ test/Main.hs view
@@ -0,0 +1,48 @@+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0++{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE PolyKinds #-}+{-# OPTIONS_GHC -Wno-deprecations -Wno-unticked-promoted-constructors #-}++module Main (main) where++import Data.List.Extra+import qualified Experiments as Bench+import Language.LSP.Test+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.Ingredients.Rerun (defaultMainWithRerun)++main :: IO ()+main = defaultMainWithRerun benchmarkTests++benchmarkTests :: TestTree+benchmarkTests =+ let ?config = Bench.defConfig+ { Bench.verbosity = Bench.Quiet+ , Bench.repetitions = Just 3+ , Bench.buildTool = Bench.Cabal+ } in+ withResource Bench.setup Bench.cleanUp $ \getResource -> testGroup "benchmark experiments"+ [ testCase (Bench.name e) $ do+ Bench.SetupResult{Bench.benchDir} <- getResource+ res <- Bench.runBench (runInDir benchDir) e+ assertBool "did not successfully complete 5 repetitions" $ Bench.success res+ | e <- Bench.experiments+ , Bench.name e /= "edit" -- the edit experiment does not ever fail+ , Bench.name e /= "hole fit suggestions" -- is too slow!+ -- the cradle experiments are way too slow+ , not ("cradle" `isInfixOf` Bench.name e)+ ]++runInDir :: FilePath -> Session a -> IO a+runInDir dir = runSessionWithConfig defaultConfig cmd fullCaps dir+ where+ -- TODO use HLS instead of ghcide+ cmd = "ghcide --lsp --test --verbose -j2 --cwd " <> dir