diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/exe/Main.hs b/exe/Main.hs new file mode 100644 --- /dev/null +++ b/exe/Main.hs @@ -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 diff --git a/ghcide-bench.cabal b/ghcide-bench.cabal new file mode 100644 --- /dev/null +++ b/ghcide-bench.cabal @@ -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 + diff --git a/src/Experiments.hs b/src/Experiments.hs new file mode 100644 --- /dev/null +++ b/src/Experiments.hs @@ -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 diff --git a/src/Experiments/Types.hs b/src/Experiments/Types.hs new file mode 100644 --- /dev/null +++ b/src/Experiments/Types.hs @@ -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] diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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